git.iko.soy/squeal
on 9c844cc help sign in
ddc9847
swap
2 ahead, 145 behind
squeal-postgresql/squeal-postgresql.cabal+3−1
since splitsnapshots
unifiedsplit
@@ -101,11 +101,13 @@ test-suite squeal-postgresql-specs
101 , bytestring >= 0.10.8.2
101 , bytestring >= 0.10.8.2
102 , generics-sop >= 0.3.1.0
102 , generics-sop >= 0.3.1.0
103 , hspec >= 2.4.8
103 , hspec >= 2.4.8
104+ , QuickCheck
104 , squeal-postgresql
105 , squeal-postgresql
105 , text >= 1.2.2.2
106 , text >= 1.2.2.2
106 , transformers >= 0.5.2.0
107 , transformers >= 0.5.2.0
107 , vector >= 0.12.0.1
108 , vector >= 0.12.0.1
108−
109+ , generic-random
110+ , quickcheck-instances
109executable squeal-postgresql-example
111executable squeal-postgresql-example
110 default-language: Haskell2010
112 default-language: Haskell2010
111 hs-source-dirs: exe
113 hs-source-dirs: exe
squeal-postgresql/test/Specs/ExceptionHandling.hs+60−35
@@ -1,31 +1,36 @@
1+{-# LANGUAGE
1−{-# LANGUAGE DataKinds #-}
2+ DataKinds
3+ , StandaloneDeriving
4+ , GeneralizedNewtypeDeriving
2−{-# LANGUAGE DeriveGeneric #-}
5+ , DeriveGeneric
3−{-# LANGUAGE DuplicateRecordFields #-}
6+ , DuplicateRecordFields
4−{-# LANGUAGE FlexibleContexts #-}
7+ , FlexibleContexts
5−{-# LANGUAGE OverloadedLabels #-}
8+ , OverloadedLabels
6−{-# LANGUAGE OverloadedLists #-}
9+ , OverloadedLists
7−{-# LANGUAGE OverloadedStrings #-}
10+ , OverloadedStrings
11+ , ScopedTypeVariables
8−{-# LANGUAGE TypeApplications #-}
12+ , TypeApplications
9−{-# LANGUAGE TypeFamilies #-}
13+ , TypeFamilies
10−{-# LANGUAGE TypeInType #-}
14+ , TypeInType
11−{-# LANGUAGE TypeOperators #-}
15+ , TypeOperators
16+#-}
17+
12module ExceptionHandling
18module ExceptionHandling
13 ( specs
19 ( specs
14 , User (..)
20 , User (..)
15− )
16−where
21+ ) where
17
22
18−import Control.Monad (void)
23+import Control.Monad(void)
19import Control.Monad.IO.Class (MonadIO (..))
24import Control.Monad.IO.Class (MonadIO (..))
20−import qualified Data.ByteString.Char8 as Char8
25+import qualified Data.ByteString.Char8 as Char8
21−import Data.Int (Int16)
26+import Data.Int (Int16)
22−import Data.Text (Text)
27+import Data.Text (Text)
23−import Data.Vector (Vector)
28+import Data.Vector (Vector)
24−import qualified Generics.SOP as SOP
29+import qualified Generics.SOP as SOP
25−import qualified GHC.Generics as GHC
30+import qualified GHC.Generics as GHC
26−import Squeal.PostgreSQL
31+import Squeal.PostgreSQL
27−import Squeal.PostgreSQL.Migration
32+import Squeal.PostgreSQL.Migration
28−import Test.Hspec
33+import Test.Hspec
29
34
30type Schema =
35type Schema =
31 '[ "users" ::: 'Table (
36 '[ "users" ::: 'Table (
@@ -52,16 +57,10 @@ data User =
52 User { userName :: Text
57 User { userName :: Text
53 , userEmail :: Maybe Text
58 , userEmail :: Maybe Text
54 , userVec :: VarArray (Vector (Maybe Int16)) }
59 , userVec :: VarArray (Vector (Maybe Int16)) }
55− deriving (Show, GHC.Generic)
60+ deriving (Show, GHC.Generic, Eq)
56instance SOP.Generic User
61instance SOP.Generic User
57instance SOP.HasDatatypeInfo User
62instance SOP.HasDatatypeInfo User
58
63
59−insertUser :: Manipulation '[] Schemas '[ 'NotNull 'PGtext, 'NotNull ('PGvararray ('Null 'PGint2))]
60− '[ "fromOnly" ::: 'NotNull 'PGint4 ]
61−insertUser = insertInto #users
62− (Values_ (Default `as` #id :* Set (param @1) `as` #name :* Set (param @2) `as` #vec))
63− OnConflictDoRaise (Returning (#id `as` #fromOnly))
64−
65setup :: Definition (Public '[]) Schemas
64setup :: Definition (Public '[]) Schemas
66setup =
65setup =
67 createTable #users
66 createTable #users
@@ -98,16 +97,36 @@ dropDB = void . withConnection connectionString $
98 & pqThen (migrateDown (single migration))
97 & pqThen (migrateDown (single migration))
99
98
100connectionString :: Char8.ByteString
99connectionString :: Char8.ByteString
101−connectionString = "host=localhost port=5432 dbname=exampledb"
100+connectionString = "postgres:///exampledb"
102
101
103testUser :: User
102testUser :: User
104testUser = User "TestUser" Nothing (VarArray [])
103testUser = User "TestUser" Nothing (VarArray [])
105
104
106−newUser :: (MonadIO m, MonadPQ Schemas m) => User -> m ()
105+badTestUser :: User
107−newUser u = void $ manipulateParams insertUser (userName u, userVec u)
106+badTestUser = User "TestUser\NUL1" Nothing (VarArray [])
108
107
109−insertUserTwice :: (MonadIO m, MonadPQ Schemas m) => m ()
108+newUser :: (MonadIO m, MonadPQ Schemas m) => User -> m ()
110−insertUserTwice = newUser testUser >> newUser testUser
109+newUser u = void $ manipulateParams insertUser u
110+
111+
112+insertUser :: Manipulation_ Schemas User ()
113+insertUser = with (u `as` #u) e
114+ where
115+ u = insertInto #users
116+ (Values_ (Default `as` #id :* Set (param @1) `as` #name :* Set (param @3) `as` #vec) )
117+ OnConflictDoRaise (Returning_ (#id :* param @2 `as` #email))
118+ e = insertInto_ #emails $ Select
119+ (Default `as` #id :* Set (#u ! #id) `as` #user_id :* Set (#u ! #email) `as` #email)
120+ (from (common #u))
121+
122+getUsers :: Query_ Schemas () User
123+getUsers = select_
124+ (#u ! #name `as` #userName :*
125+ #e ! #email `as` #userEmail :*
126+ #u ! #vec `as` #userVec )
127+ ( from (table (#users `as` #u)
128+ & innerJoin (table (#emails `as` #e ) )
129+ (#u ! #id .== #e ! #user_id )))
111
130
112specs :: SpecWith ()
131specs :: SpecWith ()
113specs = before_ setupDB $ after_ dropDB $
132specs = before_ setupDB $ after_ dropDB $
@@ -124,3 +143,9 @@ specs = before_ setupDB $ after_ dropDB $
124 it "should be rethrown for unique constraint violation in a manipulation by a transaction" $
143 it "should be rethrown for unique constraint violation in a manipulation by a transaction" $
125 withConnection connectionString (transactionally_ insertUserTwice)
144 withConnection connectionString (transactionally_ insertUserTwice)
126 `shouldThrow` (== dupKeyErr)
145 `shouldThrow` (== dupKeyErr)
146+
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]