git.iko.soy/squeal
on dev help sign in
Add hspec suite with exception cases
64c80c3Raveline
squeal-postgresql/test/Specs/ExceptionHandling.hsnew file+118
compare with dev
unifiedsplit
@@ -0,0 +1,118 @@
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 TypeOperators #-}
11+module ExceptionHandling
12+ (
13+ specs
14+ )
15+where
16+
17+import Control.Monad (void)
18+import Control.Monad.Base (MonadBase)
19+import qualified Data.ByteString.Char8 as Char8
20+import Data.Int (Int16)
21+import Data.Text (Text)
22+import Data.Vector (Vector)
23+import qualified Generics.SOP as SOP
24+import qualified GHC.Generics as GHC
25+import Squeal.PostgreSQL
26+import Squeal.PostgreSQL.Migration
27+import Test.Hspec
28+
29+type Schema =
30+ '[ "users" ::: 'Table (
31+ '[ "pk_users" ::: 'PrimaryKey '["id"]
32+ , "unique_names" ::: 'Unique '["name"]
33+ ] :=>
34+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
35+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext
36+ , "vec" ::: 'NoDef :=> 'NotNull ('PGvararray 'PGint2)
37+ ])
38+ , "emails" ::: 'Table (
39+ '[ "pk_emails" ::: 'PrimaryKey '["id"]
40+ , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
41+ ] :=>
42+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
43+ , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
44+ , "email" ::: 'NoDef :=> 'Null 'PGtext
45+ ])
46+ ]
47+
48+data User =
49+ User { userName :: Text
50+ , userEmail :: Maybe Text
51+ , userVec :: Vector (Maybe Int16) }
52+ deriving (Show, GHC.Generic)
53+instance SOP.Generic User
54+instance SOP.HasDatatypeInfo User
55+
56+insertUser :: Manipulation Schema '[ 'NotNull 'PGtext, 'NotNull ('PGvararray 'PGint2)]
57+ '[ "fromOnly" ::: 'NotNull 'PGint4 ]
58+insertUser = insertRows #users
59+ (Default `as` #id :* Set (param @1) `as` #name :* Set (param @2) `as` #vec) []
60+ OnConflictDoRaise (Returning (#id `as` #fromOnly))
61+
62+setup :: Definition '[] Schema
63+setup =
64+ createTable #users
65+ ( serial `as` #id :*
66+ (text & notNullable) `as` #name :*
67+ (vararray int2 & notNullable) `as` #vec )
68+ ( primaryKey #id `as` #pk_users
69+ :* unique #name `as` #unique_names )
70+ >>>
71+ createTable #emails
72+ ( serial `as` #id :*
73+ (int & notNullable) `as` #user_id :*
74+ (text & nullable) `as` #email )
75+ ( primaryKey #id `as` #pk_emails :*
76+ foreignKey #user_id #users #id
77+ OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
78+
79+teardown :: Definition Schema '[]
80+teardown = dropTable #emails >>> dropTable #users
81+
82+migration :: Migration IO '[] Schema
83+migration = Migration { name = "test"
84+ , up = void $ define setup
85+ , down = void $ define teardown }
86+
87+setupDB :: IO ()
88+setupDB = void . withConnection connectionString $
89+ manipulate (UnsafeManipulation "SET client_min_messages = error;")
90+ & pqThen $ migrateUp $ single migration
91+
92+dropDB :: IO ()
93+dropDB = void . withConnection connectionString $
94+ manipulate (UnsafeManipulation "SET client_min_messages = error;")
95+ & pqThen $ migrateDown $ single migration
96+
97+connectionString :: Char8.ByteString
98+connectionString = "host=localhost port=5432 dbname=exampledb"
99+
100+testUser :: User
101+testUser = User "TestUser" Nothing []
102+
103+newUser :: (MonadBase IO m, MonadPQ Schema m) => User -> m ()
104+newUser u = void $ manipulateParams insertUser (userName u, userVec u)
105+
106+insertUserTwice :: (MonadBase IO m, MonadPQ Schema m) => m ()
107+insertUserTwice = newUser testUser >> newUser testUser
108+
109+specs :: SpecWith ()
110+specs = before_ setupDB $ after_ dropDB $
111+ describe "Exceptions" $ do
112+ it "Should be raised in transactions and cause rollback" $
113+ withConnection connectionString insertUserTwice
114+ `shouldThrow` anyErrorCall
115+
116+ it "Should be raised outside of transactions" $
117+ withConnection connectionString (transactionally_ insertUserTwice)
118+ `shouldThrow` anyErrorCall
squeal-postgresql/test/Specs/Specs.hsnew file+7
@@ -0,0 +1,7 @@
1+module Specs where
2+
3+import Test.Hspec
4+import qualified ExceptionHandling
5+
6+main :: IO ()
7+main = hspec ExceptionHandling.specs