@@ -1,10 +1,13 @@
11{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE StandaloneDeriving #-}
3+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
24{-# LANGUAGE DeriveGeneric #-}
35{-# LANGUAGE DuplicateRecordFields #-}
46{-# LANGUAGE FlexibleContexts #-}
57{-# LANGUAGE OverloadedLabels #-}
68{-# LANGUAGE OverloadedLists #-}
79{-# LANGUAGE OverloadedStrings #-}
10+{-# LANGUAGE ScopedTypeVariables #-}
811{-# LANGUAGE TypeApplications #-}
912{-# LANGUAGE TypeFamilies #-}
1013{-# LANGUAGE TypeInType #-}
@@ -20,12 +23,16 @@ import Control.Monad.IO.Class (MonadIO (..))
2023import qualified Data.ByteString.Char8 as Char8
2124import Data.Int (Int16)
2225import Data.Text (Text)
23−import Data.Vector (Vector)
26+import Data.Vector (Vector, fromList)
2427import qualified Generics.SOP as SOP
2528import qualified GHC.Generics as GHC
2629import Squeal.PostgreSQL
2730import Squeal.PostgreSQL.Migration
2831import 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()
2936
3037type Schema =
3138 '[ "users" ::: 'Table (
@@ -52,15 +59,19 @@ data User =
5259 User { userName :: Text
5360 , userEmail :: Maybe Text
5461 , userVec :: VarArray (Vector (Maybe Int16)) }
55− deriving (Show, GHC.Generic)
62+ deriving (Show, GHC.Generic, Eq)
5663instance SOP.Generic User
5764instance SOP.HasDatatypeInfo User
5865
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))
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+
6475
6576setup :: Definition (Public '[]) Schemas
6677setup =
@@ -98,17 +109,48 @@ dropDB = void . withConnection connectionString $
98109 & pqThen (migrateDown (single migration))
99110
100111connectionString :: Char8.ByteString
101−connectionString = "host=localhost port=5432 dbname=exampledb"
112+-- connectionString = "host=localhost port=5432 dbname=exampledb"
113+-- connectionString = "host=localhost port=5432 dbname=exampledb"
114+connectionString = "postgres:///exampledb"
102115
103116testUser :: User
104117testUser = User "TestUser" Nothing (VarArray [])
105118
106119newUser :: (MonadIO m, MonadPQ Schemas m) => User -> m ()
107−newUser u = void $ manipulateParams insertUser (userName u, userVec u)
120+newUser u = void $ manipulateParams insertUser u
121+
122+
123+insertUser :: Manipulation_ Schemas User ()
124+insertUser = with (u `as` #u) e
125+ where
126+ u = insertInto #users
127+ (Values_ (Default `as` #id :* Set (param @1) `as` #name :* Set (param @3) `as` #vec) )
128+ OnConflictDoRaise (Returning_ (#id :* param @2 `as` #email))
129+ e = insertInto_ #emails $ Select
130+ (Default `as` #id :* Set (#u ! #id) `as` #user_id :* Set (#u ! #email) `as` #email)
131+ (from (common #u))
132+
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+
108139
109140insertUserTwice :: (MonadIO m, MonadPQ Schemas m) => m ()
110141insertUserTwice = newUser testUser >> newUser testUser
111142
143+
144+getUsers :: Query_ Schemas () User
145+getUsers = select_
146+ (#u ! #name `as` #userName :*
147+ #e ! #email `as` #userEmail :*
148+ #u ! #vec `as` #userVec )
149+ ( from (table (#users `as` #u)
150+ & innerJoin (table (#emails `as` #e ) )
151+ (#u ! #id .== #e ! #user_id )))
152+
153+
112154specs :: SpecWith ()
113155specs = before_ setupDB $ after_ dropDB $
114156 describe "Exceptions" $ do
@@ -124,3 +166,9 @@ specs = before_ setupDB $ after_ dropDB $
124166 it "should be rethrown for unique constraint violation in a manipulation by a transaction" $
125167 withConnection connectionString (transactionally_ insertUserTwice)
126168 `shouldThrow` (== dupKeyErr)
169+
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]