@@ -1,31 +1,36 @@
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 #-}
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+
1218module ExceptionHandling
1319 ( specs
1420 , User (..)
15− )
16−where
21+ ) where
1722
18−import Control.Monad (void)
23+import Control.Monad(void)
1924import Control.Monad.IO.Class (MonadIO (..))
20−import qualified Data.ByteString.Char8 as Char8
21−import Data.Int (Int16)
22−import Data.Text (Text)
23−import Data.Vector (Vector)
24−import qualified Generics.SOP as SOP
25−import qualified GHC.Generics as GHC
26−import Squeal.PostgreSQL
27−import Squeal.PostgreSQL.Migration
28−import Test.Hspec
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
2934
3035type Schema =
3136 '[ "users" ::: 'Table (
@@ -52,16 +57,10 @@ data User =
5257 User { userName :: Text
5358 , userEmail :: Maybe Text
5459 , userVec :: VarArray (Vector (Maybe Int16)) }
55− deriving (Show, GHC.Generic)
60+ deriving (Show, GHC.Generic, Eq)
5661instance SOP.Generic User
5762instance SOP.HasDatatypeInfo User
5863
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−
6564setup :: Definition (Public '[]) Schemas
6665setup =
6766 createTable #users
@@ -98,16 +97,36 @@ dropDB = void . withConnection connectionString $
9897 & pqThen (migrateDown (single migration))
9998
10099connectionString :: Char8.ByteString
101−connectionString = "host=localhost port=5432 dbname=exampledb"
100+connectionString = "postgres:///exampledb"
102101
103102testUser :: User
104103testUser = User "TestUser" Nothing (VarArray [])
105104
106−newUser :: (MonadIO m, MonadPQ Schemas m) => User -> m ()
107−newUser u = void $ manipulateParams insertUser (userName u, userVec u)
105+badTestUser :: User
106+badTestUser = User "TestUser\NUL1" Nothing (VarArray [])
108107
109−insertUserTwice :: (MonadIO m, MonadPQ Schemas m) => m ()
110−insertUserTwice = newUser testUser >> newUser testUser
108+newUser :: (MonadIO m, MonadPQ Schemas m) => User -> m ()
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 )))
111130
112131specs :: SpecWith ()
113132specs = before_ setupDB $ after_ dropDB $
@@ -124,3 +143,9 @@ specs = before_ setupDB $ after_ dropDB $
124143 it "should be rethrown for unique constraint violation in a manipulation by a transaction" $
125144 withConnection connectionString (transactionally_ insertUserTwice)
126145 `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]