{-# LANGUAGE
DataKinds
, DeriveAnyClass
, DeriveGeneric
, DerivingStrategies
, DerivingVia
, DuplicateRecordFields
, FlexibleContexts
, FlexibleInstances
, MultiParamTypeClasses
, OverloadedLabels
, OverloadedStrings
, RankNTypes
, StandaloneDeriving
, TypeApplications
, TypeFamilies
, TypeSynonymInstances
, DataKinds
, PolyKinds
, TypeOperators
, UndecidableInstances
#-}
module Main (main) where
import Control.Concurrent.Async (replicateConcurrently)
import Data.ByteString (ByteString)
import Data.Int (Int32)
import Data.Text (Text)
import Test.Hspec
import qualified Data.ByteString.Char8 as Char8 (unlines)
import qualified Generics.SOP as SOP
import qualified GHC.Generics as GHC
import Squeal.PostgreSQL
main :: IO ()
main = hspec spec
type UsersConstraints =
'[ "pk_users" ::: 'PrimaryKey '["id"]
, "unique_names" ::: 'Unique '["name"] ]
type UsersColumns =
'[ "id" ::: 'Def :=> 'NotNull 'PGint4
, "name" ::: 'NoDef :=> 'NotNull 'PGtext ]
type Schema =
'[ "users" ::: 'Table (UsersConstraints :=> UsersColumns)
, "person" ::: 'Typedef (PG Person) ]
type DB = '[ "public" ::: Schema ]
data User = User
{ userName :: Text
} deriving stock (Eq, Show, GHC.Generic)
deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
insertUser :: Manipulation_ DB User ()
insertUser = insertInto_ #users
(Values_ (Default `as` #id :* Set (param @1) `as` #name))
insertUsers :: Text -> [Text] -> Statement DB () ()
insertUsers name1 names = manipulation $ insertInto_ #users $ Values
(Default `as` #id :* Set (inline name1) `as` #name)
[Default `as` #id :* Set (inline namei) `as` #name | namei <- names]
deleteUser :: Text -> Statement DB () ()
deleteUser name1 = manipulation $ deleteFrom_ #users (#name .== inline name1)
setup :: Definition (Public '[]) DB
setup =
createTable #users
( serial `as` #id :*
notNullable text `as` #name )
( primaryKey #id `as` #pk_users :*
unique #name `as` #unique_names ) >>>
createTypeCompositeFrom @Person #person
teardown :: Definition DB (Public '[])
teardown = dropType #person >>> dropTable #users
silent :: Statement db () ()
silent = manipulation $ UnsafeManipulation "Set client_min_messages TO WARNING"
silence :: MonadPQ db pq => pq ()
silence = execute_ silent
setupDB :: IO ()
setupDB = withConnection connectionString $
silence & pqThen (define setup)
dropDB :: IO ()
dropDB = withConnection connectionString $
silence & pqThen (define teardown)
connectionString :: ByteString
connectionString = "host=localhost port=5432 dbname=exampledb user=postgres password=postgres"
data Person = Person { name :: Maybe String, age :: Maybe Int32 }
deriving (Eq, Show, GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)
deriving (IsPG, FromPG, ToPG db, Inline) via (Composite Person)
spec :: Spec
spec = before_ setupDB . after_ dropDB $ do
describe "Exceptions" $ do
let
testUser = User "TestUser"
newUser :: User -> Transaction DB ()
newUser usr = manipulateParams_ insertUser usr
insertUserTwice :: Transaction DB ()
insertUserTwice = newUser testUser >> newUser testUser
err23505 = UniqueViolation $ Char8.unlines
[ "ERROR: duplicate key value violates unique constraint \"unique_names\""
, "DETAIL: Key (name)=(TestUser) already exists." ]
it "should be thrown for constraint violation" $
withConnection connectionString insertUserTwice
`shouldThrow` (== err23505)
it "should be rethrown for constraint violation in a transaction" $
withConnection connectionString (transactionally_ insertUserTwice)
`shouldThrow` (== err23505)
describe "Pools" $
it "should manage concurrent transactions" $ do
pool <- createConnectionPool
"host=localhost port=5432 dbname=exampledb user=postgres password=postgres" 1 0.5 10
let
qry :: Query_ (Public '[]) () (Only Char)
qry = values_ (inline 'a' `as` #fromOnly)
session = usingConnectionPool pool $ transactionally_ $
firstRow =<< runQuery qry
chrs <- replicateConcurrently 10 session
chrs `shouldSatisfy` all (== Just (Only 'a'))
describe "Ranges" $
it "should correctly decode ranges" $ do
rangesOut <- withConnection connectionString $ do
let
qry :: Query_ (Public '[]) () (Only (Range Int32))
qry = values
( range int4range (atLeast 3) `as` #fromOnly )
[ range int4range (3 <=..< 5) `as` #fromOnly
, range int4range Empty `as` #fromOnly
, range int4range whole `as` #fromOnly ]
getRows =<< runQuery qry
(fromOnly <$> rangesOut :: [Range Int32]) `shouldBe`
[ atLeast 3, 3 <=..< 5, Empty, whole ]
describe "Parameters" $ do
it "should run queries that don't reference all their parameters" $ do
out <- withConnection connectionString $ do
let
qry :: Query_ (Public '[]) (Char,Int32) (Only Int32)
qry = values_ (param @2 `as` #fromOnly)
firstRow =<< runQueryParams qry ('a', 3 :: Int32)
(fromOnly <$> out :: Maybe Int32) `shouldBe` Just 3
describe "Composite types" $ do
it "should be embeddible" $ do
let
roundtrip :: Query_ DB (Only Person) (Only Person)
roundtrip = values_ (param @1 `as` #fromOnly)
roundtrip_inline :: Person -> Query_ DB () (Only Person)
roundtrip_inline person = values_ (inline person `as` #fromOnly)
roundtrip_array :: Query_ DB
(Only (VarArray [Person])) (Only (VarArray [Person]))
roundtrip_array = values_ (param @1 `as` #fromOnly)
oneway :: Query_ DB () (Only Person)
oneway = values_ (row ("Adam" `as` #name :* 6000 `as` #age) `as` #fromOnly)
oneway_array :: Query_ DB () (Only (VarArray [Person]))
oneway_array = values_ $ array
[ row ("Adam" `as` #name :* 6000 `as` #age)
, row ("Lucy" `as` #name :* 2420000 `as` #age)
] `as` #fromOnly
unsafeQ :: Query_ DB () (Only (VarArray [Composite Person]))
unsafeQ = UnsafeQuery "select array[row(\'Adam\', 6000)]"
nothingQ :: Query_ DB () (Only Person)
nothingQ = values_ (row (null_ `as` #name :* null_ `as` #age) `as` #fromOnly)
adam = Person (Just "Adam") (Just 6000)
lucy = Person (Just "Lucy") (Just 2420000)
people = VarArray [adam, lucy]
out <- withConnection connectionString $
firstRow =<< runQueryParams roundtrip (Only adam)
out_inline <- withConnection connectionString $
firstRow =<< runQuery (roundtrip_inline adam)
out_array <- withConnection connectionString $
firstRow =<< runQueryParams roundtrip_array (Only people)
out2 <- withConnection connectionString $
firstRow =<< runQuery oneway
out2_array <- withConnection connectionString $
firstRow =<< runQuery oneway_array
unsafe_array <- withConnection connectionString $
firstRow =<< runQuery unsafeQ
nothings <- withConnection connectionString $
firstRow =<< runQuery nothingQ
out `shouldBe` Just (Only adam)
out_inline `shouldBe` Just (Only adam)
out_array `shouldBe` Just (Only people)
out2 `shouldBe` Just (Only adam)
out2_array `shouldBe` Just (Only people)
unsafe_array `shouldBe` Just (Only (VarArray [Composite adam]))
nothings `shouldBe` Just (Only (Person Nothing Nothing))
describe "cmdStatus and cmdTuples" $ do
let
statusAndTuples stmnt = withConnection connectionString $ do
result <- execute stmnt
status <- cmdStatus result
tuples <- cmdTuples result
return (status, tuples)
it "should tell you about the command and the number of rows effected" $ do
(status1, tuples1) <- statusAndTuples (insertUsers "Jonah" ["Isaiah"])
status1 `shouldBe` "INSERT 0 2"
tuples1 `shouldBe` Just 2
(status2, tuples2) <- statusAndTuples (deleteUser "Noah")
status2 `shouldBe` "DELETE 0"
tuples2 `shouldBe` Just 0
(status3, tuples3) <- statusAndTuples (deleteUser "Jonah")
status3 `shouldBe` "DELETE 1"
tuples3 `shouldBe` Just 1
(status4, tuples4) <- statusAndTuples silent
status4 `shouldBe` "SET"
tuples4 `shouldBe` Nothing