@@ -1,140 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE DuplicateRecordFields #-}
4−{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE OverloadedLabels #-}
6−{-# LANGUAGE OverloadedLists #-}
7−{-# LANGUAGE OverloadedStrings #-}
8−{-# LANGUAGE TypeApplications #-}
9−{-# LANGUAGE TypeFamilies #-}
10−{-# LANGUAGE TypeInType #-}
11−{-# LANGUAGE TypeOperators #-}
12−module ExceptionHandling
13− ( specs
14− , User (..)
15− ) where
16−
17−import Control.Concurrent.Async (replicateConcurrently)
18−import Control.Monad (void)
19−import Control.Monad.IO.Class (MonadIO (..))
20−import Data.Int (Int16)
21−import Data.Text (Text)
22−import Data.Vector (Vector)
23−import Test.Hspec
24−
25−import qualified Data.ByteString.Char8 as Char8
26−import qualified Generics.SOP as SOP
27−import qualified GHC.Generics as GHC
28−
29−import Squeal.PostgreSQL
30−
31−type Schema =
32− '[ "users" ::: 'Table (
33− '[ "pk_users" ::: 'PrimaryKey '["id"]
34− , "unique_names" ::: 'Unique '["name"]
35− ] :=>
36− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
37− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
38− , "vec" ::: 'NoDef :=> 'NotNull ('PGvararray ('Null 'PGint2))
39− ])
40− , "emails" ::: 'Table (
41− '[ "pk_emails" ::: 'PrimaryKey '["id"]
42− , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
43− ] :=>
44− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
45− , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
46− , "email" ::: 'NoDef :=> 'Null 'PGtext
47− ])
48− ]
49−
50−type Schemas = Public Schema
51−
52−data User =
53− User { userName :: Text
54− , userEmail :: Maybe Text
55− , userVec :: VarArray (Vector (Maybe Int16)) }
56− deriving (Show, GHC.Generic)
57−instance SOP.Generic User
58−instance SOP.HasDatatypeInfo User
59−
60−insertUser :: Manipulation '[] Schemas '[ 'NotNull 'PGtext, 'NotNull ('PGvararray ('Null 'PGint2))]
61− '[ "fromOnly" ::: 'NotNull 'PGint4 ]
62−insertUser = insertInto #users
63− (Values_ (Default `as` #id :* Set (param @1) `as` #name :* Set (param @2) `as` #vec))
64− OnConflictDoRaise (Returning (#id `as` #fromOnly))
65−
66−setup :: Definition (Public '[]) Schemas
67−setup =
68− createTable #users
69− ( serial `as` #id :*
70− (text & notNullable) `as` #name :*
71− (vararray int2 & notNullable) `as` #vec )
72− ( primaryKey #id `as` #pk_users
73− :* unique #name `as` #unique_names )
74− >>>
75− createTable #emails
76− ( serial `as` #id :*
77− (int & notNullable) `as` #user_id :*
78− (text & nullable) `as` #email )
79− ( primaryKey #id `as` #pk_emails :*
80− foreignKey #user_id #users #id
81− OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
82−
83−teardown :: Definition Schemas (Public '[])
84−teardown = dropTable #emails >>> dropTable #users
85−
86−migration :: Migration Definition (Public '[]) Schemas
87−migration = Migration { name = "test"
88− , up = setup
89− , down = teardown }
90−
91−setupDB :: IO ()
92−setupDB = withConnection connectionString $
93− manipulate (UnsafeManipulation "SET client_min_messages TO WARNING;")
94− & pqThen (migrateUp (single migration))
95−
96−dropDB :: IO ()
97−dropDB = withConnection connectionString $
98− manipulate (UnsafeManipulation "SET client_min_messages TO WARNING;")
99− & pqThen (migrateDown (single migration))
100−
101−connectionString :: Char8.ByteString
102−connectionString = "host=localhost port=5432 dbname=exampledb"
103−
104−testUser :: User
105−testUser = User "TestUser" Nothing (VarArray [])
106−
107−newUser :: (MonadIO m, MonadPQ Schemas m) => User -> m ()
108−newUser u = void $ manipulateParams insertUser (userName u, userVec u)
109−
110−insertUserTwice :: (MonadIO m, MonadPQ Schemas m) => m ()
111−insertUserTwice = newUser testUser >> newUser testUser
112−
113−specs :: SpecWith ()
114−specs = before_ setupDB $ after_ dropDB $
115− describe "Exceptions" $ do
116−
117− let
118− dupKeyErr = PQException $ PQState FatalError (Just "23505")
119− (Just "ERROR: duplicate key value violates unique constraint \"unique_names\"\nDETAIL: Key (name)=(TestUser) already exists.\n")
120−
121− it "should be thrown for unique constraint violation in a manipulation" $
122− withConnection connectionString insertUserTwice
123− `shouldThrow` (== dupKeyErr)
124−
125− it "should be rethrown for unique constraint violation in a manipulation by a transaction" $
126− withConnection connectionString (transactionally_ insertUserTwice)
127− `shouldThrow` (== dupKeyErr)
128−
129− it "should handle concurrent transactions using pooled connections" $ do
130− pool <- createConnectionPool
131− "host=localhost port=5432 dbname=exampledb" 1 0.5 10
132− let
133− query :: Query_ (Public '[]) () (Only Char)
134− query = values_ (literal 'a' `as` #fromOnly)
135− session = usingConnectionPool pool . transactionally_ $ do
136− result <- runQuery query
137− Just (Only chr) <- firstRow result
138− return chr
139− chrs <- replicateConcurrently 10 session
140− chrs `shouldSatisfy` (all (== 'a'))