@@ -1,10 +1,13 @@
1{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE StandaloneDeriving #-}
3+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2{-# LANGUAGE DeriveGeneric #-}
4{-# LANGUAGE DeriveGeneric #-}
3{-# LANGUAGE DuplicateRecordFields #-}
5{-# LANGUAGE DuplicateRecordFields #-}
4{-# LANGUAGE FlexibleContexts #-}
6{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE OverloadedLabels #-}
7{-# LANGUAGE OverloadedLabels #-}
6{-# LANGUAGE OverloadedLists #-}
8{-# LANGUAGE OverloadedLists #-}
7{-# LANGUAGE OverloadedStrings #-}
9{-# LANGUAGE OverloadedStrings #-}
10+{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE TypeApplications #-}
11{-# LANGUAGE TypeApplications #-}
9{-# LANGUAGE TypeFamilies #-}
12{-# LANGUAGE TypeFamilies #-}
10{-# LANGUAGE TypeInType #-}
13{-# LANGUAGE TypeInType #-}
@@ -20,12 +23,16 @@ import Control.Monad.IO.Class (MonadIO (..))
20import qualified Data.ByteString.Char8 as Char8
23import qualified Data.ByteString.Char8 as Char8
21import Data.Int (Int16)
24import Data.Int (Int16)
22import Data.Text (Text)
25import Data.Text (Text)
23−import Data.Vector (Vector)
26+import Data.Vector (Vector, fromList)
24import qualified Generics.SOP as SOP
27import qualified Generics.SOP as SOP
25import qualified GHC.Generics as GHC
28import qualified GHC.Generics as GHC
26import Squeal.PostgreSQL
29import Squeal.PostgreSQL
27import Squeal.PostgreSQL.Migration
30import Squeal.PostgreSQL.Migration
28import Test.Hspec
31import 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()
30type Schema =
37type Schema =
31 '[ "users" ::: 'Table (
38 '[ "users" ::: 'Table (
@@ -52,15 +59,19 @@ data User =
52 User { userName :: Text
59 User { userName :: Text
53 , userEmail :: Maybe Text
60 , userEmail :: Maybe Text
54 , userVec :: VarArray (Vector (Maybe Int16)) }
61 , userVec :: VarArray (Vector (Maybe Int16)) }
55− deriving (Show, GHC.Generic)
62+ deriving (Show, GHC.Generic, Eq)
56instance SOP.Generic User
63instance SOP.Generic User
57instance SOP.HasDatatypeInfo User
64instance SOP.HasDatatypeInfo User
59−insertUser :: Manipulation '[] Schemas '[ 'NotNull 'PGtext, 'NotNull ('PGvararray ('Null 'PGint2))]
66+instance Arbitrary User where
60− '[ "fromOnly" ::: 'NotNull 'PGint4 ]
67+ arbitrary = genericArbitrary uniform
61−insertUser = insertInto #users
68+
62− (Values_ (Default `as` #id :* Set (param @1) `as` #name :* Set (param @2) `as` #vec))
69+instance Arbitrary a => Arbitrary (Vector a) where
63− OnConflictDoRaise (Returning (#id `as` #fromOnly))
70+ arbitrary = fromList <$> arbitrary
73+deriving instance Arbitrary a => Arbitrary (VarArray a)
65setup :: Definition (Public '[]) Schemas
76setup :: Definition (Public '[]) Schemas
@@ -98,17 +109,48 @@ dropDB = void . withConnection connectionString $
98 & pqThen (migrateDown (single migration))
109 & pqThen (migrateDown (single migration))
100connectionString :: Char8.ByteString
111connectionString :: Char8.ByteString
112+-- connectionString = "host=localhost port=5432 dbname=exampledb"
101−connectionString = "host=localhost port=5432 dbname=exampledb"
113+-- connectionString = "host=localhost port=5432 dbname=exampledb"
114+connectionString = "postgres:///exampledb"
103testUser :: User
116testUser :: User
104testUser = User "TestUser" Nothing (VarArray [])
117testUser = User "TestUser" Nothing (VarArray [])
106newUser :: (MonadIO m, MonadPQ Schemas m) => User -> m ()
119newUser :: (MonadIO m, MonadPQ Schemas m) => User -> m ()
107−newUser u = void $ manipulateParams insertUser (userName u, userVec u)
120+newUser u = void $ manipulateParams insertUser u
123+insertUser :: Manipulation_ Schemas User ()
124+insertUser = with (u `as` #u) e
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)
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))
109insertUserTwice :: (MonadIO m, MonadPQ Schemas m) => m ()
140insertUserTwice :: (MonadIO m, MonadPQ Schemas m) => m ()
110insertUserTwice = newUser testUser >> newUser testUser
141insertUserTwice = newUser testUser >> newUser testUser
144+getUsers :: Query_ Schemas () User
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 )))
112specs :: SpecWith ()
154specs :: SpecWith ()
113specs = before_ setupDB $ after_ dropDB $
155specs = before_ setupDB $ after_ dropDB $
114 describe "Exceptions" $ do
156 describe "Exceptions" $ do
@@ -124,3 +166,9 @@ specs = before_ setupDB $ after_ dropDB $
124 it "should be rethrown for unique constraint violation in a manipulation by a transaction" $
166 it "should be rethrown for unique constraint violation in a manipulation by a transaction" $
125 withConnection connectionString (transactionally_ insertUserTwice)
167 withConnection connectionString (transactionally_ insertUserTwice)
126 `shouldThrow` (== dupKeyErr)
168 `shouldThrow` (== dupKeyErr)
170+ it "should be able to insert and then read a user" $ property $ \(user :: User) -> do
171+ (fetchedUsers :: [User]) <- withConnection connectionString $ do
173+ & pqThen (getRows =<< runQuery getUsers)
174+ fetchedUsers `shouldBe` [user]