@@ -1,38 +1,36 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE StandaloneDeriving #-}
3−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4−{-# LANGUAGE DeriveGeneric #-}
5−{-# LANGUAGE DuplicateRecordFields #-}
6−{-# LANGUAGE FlexibleContexts #-}
7−{-# LANGUAGE OverloadedLabels #-}
8−{-# LANGUAGE OverloadedLists #-}
9−{-# LANGUAGE OverloadedStrings #-}
10−{-# LANGUAGE ScopedTypeVariables #-}
11−{-# LANGUAGE TypeApplications #-}
12−{-# LANGUAGE TypeFamilies #-}
13−{-# LANGUAGE TypeInType #-}
14−{-# LANGUAGE TypeOperators #-}
1+{-# LANGUAGE
2+ DataKinds
3+ , StandaloneDeriving
4+ , GeneralizedNewtypeDeriving
5+ , DeriveGeneric
6+ , DuplicateRecordFields
7+ , FlexibleContexts
8+ , OverloadedLabels
9+ , OverloadedLists
10+ , OverloadedStrings
11+ , ScopedTypeVariables
12+ , TypeApplications
13+ , TypeFamilies
14+ , TypeInType
15+ , TypeOperators
16+#-}
17+
1518module ExceptionHandling
1619 ( specs
1720 , User (..)
18− )
19−where
21+ ) where
2022
21−import Control.Monad (void)
23+import Control.Monad(void)
2224import Control.Monad.IO.Class (MonadIO (..))
23−import qualified Data.ByteString.Char8 as Char8
24−import Data.Int (Int16)
25−import Data.Text (Text)
26−import Data.Vector (Vector, fromList)
27−import qualified Generics.SOP as SOP
28−import qualified GHC.Generics as GHC
29−import Squeal.PostgreSQL
30−import Squeal.PostgreSQL.Migration
31−import Test.Hspec
32−import Test.QuickCheck
33−import Generic.Random(withBaseCase, (%), genericArbitraryRec)
34−import Generic.Random (listOf1', genericArbitrary, uniform)
35−import Test.QuickCheck.Instances.Text()
25+import qualified Data.ByteString.Char8 as Char8
26+import Data.Int (Int16)
27+import Data.Text (Text)
28+import Data.Vector (Vector)
29+import qualified Generics.SOP as SOP
30+import qualified GHC.Generics as GHC
31+import Squeal.PostgreSQL
32+import Squeal.PostgreSQL.Migration
33+import Test.Hspec
3634
3735type Schema =
3836 '[ "users" ::: 'Table (
@@ -63,16 +61,6 @@ data User =
6361instance SOP.Generic User
6462instance SOP.HasDatatypeInfo User
6563
66−instance Arbitrary User where
67− arbitrary = genericArbitrary uniform
68−
69−instance Arbitrary a => Arbitrary (Vector a) where
70− arbitrary = fromList <$> arbitrary
71−
72−
73−deriving instance Arbitrary a => Arbitrary (VarArray a)
74−
75−
7664setup :: Definition (Public '[]) Schemas
7765setup =
7866 createTable #users
@@ -109,13 +97,14 @@ dropDB = void . withConnection connectionString $
10997 & pqThen (migrateDown (single migration))
11098
11199connectionString :: Char8.ByteString
112−-- connectionString = "host=localhost port=5432 dbname=exampledb"
113−-- connectionString = "host=localhost port=5432 dbname=exampledb"
114100connectionString = "postgres:///exampledb"
115101
116102testUser :: User
117103testUser = User "TestUser" Nothing (VarArray [])
118104
105+badTestUser :: User
106+badTestUser = User "TestUser\NUL1" Nothing (VarArray [])
107+
119108newUser :: (MonadIO m, MonadPQ Schemas m) => User -> m ()
120109newUser u = void $ manipulateParams insertUser u
121110
@@ -130,17 +119,6 @@ insertUser = with (u `as` #u) e
130119 (Default `as` #id :* Set (#u ! #id) `as` #user_id :* Set (#u ! #email) `as` #email)
131120 (from (common #u))
132121
133−insertUser' :: Manipulation '[] Schemas '[ 'NotNull 'PGtext, 'NotNull ('PGvararray ('Null 'PGint2))]
134− '[ "fromOnly" ::: 'NotNull 'PGint4 ]
135−insertUser' = insertInto #users
136− (Values_ (Default `as` #id :* Set (param @1) `as` #name :* Set (param @2) `as` #vec))
137− OnConflictDoRaise (Returning (#id `as` #fromOnly))
138−
139−
140−insertUserTwice :: (MonadIO m, MonadPQ Schemas m) => m ()
141−insertUserTwice = newUser testUser >> newUser testUser
142−
143−
144122getUsers :: Query_ Schemas () User
145123getUsers = select_
146124 (#u ! #name `as` #userName :*
@@ -150,7 +128,6 @@ getUsers = select_
150128 & innerJoin (table (#emails `as` #e ) )
151129 (#u ! #id .== #e ! #user_id )))
152130
153−
154131specs :: SpecWith ()
155132specs = before_ setupDB $ after_ dropDB $
156133 describe "Exceptions" $ do
@@ -167,8 +144,8 @@ specs = before_ setupDB $ after_ dropDB $
167144 withConnection connectionString (transactionally_ insertUserTwice)
168145 `shouldThrow` (== dupKeyErr)
169146
170− it "should be able to insert and then read a user" $ property $ \(user :: User) -> do
171− (fetchedUsers :: [User]) <- withConnection connectionString $ do
172− newUser user
173− & pqThen (getRows =<< runQuery getUsers)
174− fetchedUsers `shouldBe` [user]
147+ it "should be able to insert and then read a user" $ do
148+ fetchedUsers <- withConnection connectionString $ do
149+ newUser badTestUser
150+ getRows =<< runQuery getUsers
151+ fetchedUsers `shouldBe` [badTestUser]