Something went wrong. Try again.
Compile-time SQL datatype generation from PostgreSQL for Haskell
Something went wrong. Try again.
28 kB · 782 lines
Haskell
at main
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783module Main ( main ) where
----------------------------------------------------------------------------------------------------
import Control.Exception ( bracket )
import Data.Aeson ( FromJSON, ToJSON, eitherDecode, encode )import Data.Default.Class ( Default (def) )import Data.Either ( Either (..) )import Data.Eq ( Eq, (/=), (==) )import Data.Function ( ($), (&) )import Data.Int ( Int32 )import Data.List ( any, length, null )import Data.Maybe ( Maybe (..) )import Data.Ord ( Ord )import Data.Semigroup ( (<>) )import Data.String ( String )import Data.Text ( Text )import Data.UUID ( UUID )import qualified Data.UUIDimport Data.UUID.V4 ( nextRandom )
import GHC.Generics ( Generic )import GHC.Show ( Show, show )
import qualified Hasql.Connectionimport qualified Hasql.Decodersimport qualified Hasql.Encodersimport Hasql.Generate ( Config (..) , HasEnum (..) , HasPrimaryKey (..) , fromTable , fromType , fromView , generate , withDefaultedCols , withDerivations )import qualified Hasql.Generate.Class as Qimport qualified Hasql.Sessionimport qualified Hasql.Statement
import Prelude ( Bool (..) , IO , error , fmap , not , otherwise , pure , putStrLn , seq , (>>) )
import System.Exit ( die, exitSuccess )
----------------------------------------------------------------------------------------------------
-- Enum type: generates sum type + PgCodec + PgColumn instances.-- Must appear before any fromTable whose columns reference this enum.$(generate (def {allowDuplicateRecordFields = True}) (fromType "hg_test" "user_role" & withDerivations [''Show, ''Eq, ''Ord]))
-- Table with enum column: exercises the PgColumn instance generated by fromType above.$(generate (def {allowDuplicateRecordFields = True}) (fromTable "hg_test" "with_role" & withDerivations [''Show, ''Eq]))
-- Functional test table: CRUD + derived instances + global type override exercised at runtime$( generate (def {allowDuplicateRecordFields = True, globalOverrides = [("text", ''String)]}) ( fromTable "hg_test" "users" & withDerivations [''Show, ''Eq, ''Generic, ''ToJSON, ''FromJSON] & withDefaultedCols ["id"] ) )
-- Single UUID PK: generates data type, decoder, encoder, select, insert, update, delete$(generate (def {allowDuplicateRecordFields = True}) (fromTable "hg_test" "with_pk"))
-- No PK: generates data type, decoder, encoder only$(generate (def {allowDuplicateRecordFields = True}) (fromTable "hg_test" "no_pk"))
-- Composite PK: generates all CRUD with tuple PK type$(generate (def {allowDuplicateRecordFields = True}) (fromTable "hg_test" "composite_pk"))
-- View: generates read-only data type, decoder, SELECT, and HasView instance$(generate (def {allowDuplicateRecordFields = True}) (fromView "hg_test" "user_emails" & withDerivations [''Show, ''Eq]))
-- Newtype PK (single): generates newtype wrapper, PgCodec, HasPrimaryKey$( generate (def {allowDuplicateRecordFields = True, newtypePrimaryKeys = True}) (fromTable "hg_test" "nt_single" & withDerivations [''Show, ''Eq]) )
-- Newtype PK (composite): generates data record wrapper, encoder, HasPrimaryKey$( generate (def {allowDuplicateRecordFields = True, newtypePrimaryKeys = True}) (fromTable "hg_test" "nt_composite" & withDerivations [''Show, ''Eq]) )
-- Prefixed fields (default config): field names are prefixed with the type name$(generate def (fromTable "hg_test" "prefix_demo"))
-- Reserved keyword columns: tests that field names colliding with Haskell keywords-- get an apostrophe suffix (e.g. "type" -> "type'", "class" -> "class'", "data" -> "data'")$(generate (def {allowDuplicateRecordFields = True}) (fromTable "hg_test" "keyword_cols" & withDerivations [''Show, ''Eq]))
----------------------------------------------------------------------------------------------------
main :: IO ()main = do testGeneratorsGenerate testPrefixedFields testKeywordSanitization testUsersCrud testUsersDerivation testEnumUtilities testEnumRoundTrip testViewSelect testNewtypePkCrud testHasPrimaryKey testBatchCrud testBatchTypeclasses exitSuccess
------------------------------------------------------------------------------------------------------ Compile-time generation test----------------------------------------------------------------------------------------------------
{- If this module compiles, the TH splices produced valid, well-typed code. We reference every generated binding to ensure nothing was silently omitted.-}testGeneratorsGenerate :: IO ()testGeneratorsGenerate = _urAdmin .> _urModerator .> _urMember .> _wrDec .> _wrEnc .> _wrSel .> _wrIns .> _wrUpd .> _wrDel .> _wpDec .> _wpEnc .> _wpSel .> _wpIns .> _wpUpd .> _wpDel .> _npDec .> _npEnc .> _npIns .> _cpDec .> _cpEnc .> _cpSel .> _cpIns .> _cpUpd .> _cpDel .> _ueDec .> _ueSel .> _nsSel .> _nsDel .> _nsIns .> _ncSel .> _ncDel .> _ncIns .> _urAll .> _urToText .> _urFromText .> _pdDec .> _pdEnc .> _pdIns .> _kwDec .> _kwEnc .> _kwIns .> _smWp .> _dmWp .> _imWp .> _umWp .> _smCp .> _dmCp .> _imNp .> _imU .> _smNs .> _smNc .> _imCp .> _umCp .> _wrSmany .> _wrDmany .> _wrImany .> _wrUmany .> pure () >> putStrLn "Generator test passed ✔" where a .> b = a `seq` b
_urAdmin :: UserRole _urAdmin = Admin
_urModerator :: UserRole _urModerator = Moderator
_urMember :: UserRole _urMember = Member
_wrDec :: Hasql.Decoders.Row WithRole _wrDec = withRoleDecoder
_wrEnc :: Hasql.Encoders.Params WithRole _wrEnc = withRoleEncoder
_wrSel :: Hasql.Statement.Statement UUID (Maybe WithRole) _wrSel = selectWithRole
_wrIns :: Hasql.Statement.Statement WithRole WithRole _wrIns = insertWithRole
_wrUpd :: Hasql.Statement.Statement WithRole (Maybe WithRole) _wrUpd = updateWithRole
_wrDel :: Hasql.Statement.Statement UUID () _wrDel = deleteWithRole
_wpDec :: Hasql.Decoders.Row WithPk _wpDec = withPkDecoder
_wpEnc :: Hasql.Encoders.Params WithPk _wpEnc = withPkEncoder
_wpSel :: Hasql.Statement.Statement UUID (Maybe WithPk) _wpSel = selectWithPk
_wpIns :: Hasql.Statement.Statement WithPk WithPk _wpIns = insertWithPk
_wpUpd :: Hasql.Statement.Statement WithPk (Maybe WithPk) _wpUpd = updateWithPk
_wpDel :: Hasql.Statement.Statement UUID () _wpDel = deleteWithPk
_npDec :: Hasql.Decoders.Row NoPk _npDec = noPkDecoder
_npEnc :: Hasql.Encoders.Params NoPk _npEnc = noPkEncoder
_npIns :: Hasql.Statement.Statement NoPk NoPk _npIns = insertNoPk
_cpDec :: Hasql.Decoders.Row CompositePk _cpDec = compositePkDecoder
_cpEnc :: Hasql.Encoders.Params CompositePk _cpEnc = compositePkEncoder
_cpSel :: Hasql.Statement.Statement (UUID, Int32) (Maybe CompositePk) _cpSel = selectCompositePk
_cpIns :: Hasql.Statement.Statement CompositePk CompositePk _cpIns = insertCompositePk
_cpUpd :: Hasql.Statement.Statement CompositePk (Maybe CompositePk) _cpUpd = updateCompositePk
_cpDel :: Hasql.Statement.Statement (UUID, Int32) () _cpDel = deleteCompositePk
_ueDec :: Hasql.Decoders.Row UserEmails _ueDec = userEmailsDecoder
_ueSel :: Hasql.Statement.Statement () [UserEmails] _ueSel = selectUserEmails
_urAll :: [UserRole] _urAll = allValues
_urToText :: UserRole -> Text _urToText = toText
_urFromText :: Text -> Maybe UserRole _urFromText = fromText
-- Newtype PK (single) — PK param is NtSinglePk, not raw UUID _nsSel :: Hasql.Statement.Statement NtSinglePk (Maybe NtSingle) _nsSel = selectNtSingle
_nsDel :: Hasql.Statement.Statement NtSinglePk () _nsDel = deleteNtSingle
_nsIns :: Hasql.Statement.Statement NtSingle NtSingle _nsIns = insertNtSingle
-- Newtype PK (composite) — PK param is NtCompositePk record, not raw tuple _ncSel :: Hasql.Statement.Statement NtCompositePk (Maybe NtComposite) _ncSel = selectNtComposite
_ncDel :: Hasql.Statement.Statement NtCompositePk () _ncDel = deleteNtComposite
_ncIns :: Hasql.Statement.Statement NtComposite NtComposite _ncIns = insertNtComposite
_pdDec :: Hasql.Decoders.Row PrefixDemo _pdDec = prefixDemoDecoder
_pdEnc :: Hasql.Encoders.Params PrefixDemo _pdEnc = prefixDemoEncoder
_pdIns :: Hasql.Statement.Statement PrefixDemo PrefixDemo _pdIns = insertPrefixDemo
_kwDec :: Hasql.Decoders.Row KeywordCols _kwDec = keywordColsDecoder
_kwEnc :: Hasql.Encoders.Params KeywordCols _kwEnc = keywordColsEncoder
_kwIns :: Hasql.Statement.Statement KeywordCols KeywordCols _kwIns = insertKeywordCols
-- Batch with single PK _smWp :: Hasql.Statement.Statement [UUID] [WithPk] _smWp = selectManyWithPk
_dmWp :: Hasql.Statement.Statement [UUID] () _dmWp = deleteManyWithPk
_imWp :: Hasql.Statement.Statement [WithPk] [WithPk] _imWp = insertManyWithPk
_umWp :: Hasql.Statement.Statement [WithPk] [WithPk] _umWp = updateManyWithPk
-- Batch with composite PK _smCp :: Hasql.Statement.Statement [(UUID, Int32)] [CompositePk] _smCp = selectManyCompositePk
_dmCp :: Hasql.Statement.Statement [(UUID, Int32)] () _dmCp = deleteManyCompositePk
_imCp :: Hasql.Statement.Statement [CompositePk] [CompositePk] _imCp = insertManyCompositePk
_umCp :: Hasql.Statement.Statement [CompositePk] [CompositePk] _umCp = updateManyCompositePk
-- Batch insert (always generated, even no-PK tables) _imNp :: Hasql.Statement.Statement [NoPk] [NoPk] _imNp = insertManyNoPk
-- Batch with defaulted PK (insert excludes PK columns) _imU :: Hasql.Statement.Statement [Users] [Users] _imU = insertManyUsers
-- Batch with newtype PKs _smNs :: Hasql.Statement.Statement [NtSinglePk] [NtSingle] _smNs = selectManyNtSingle
_smNc :: Hasql.Statement.Statement [NtCompositePk] [NtComposite] _smNc = selectManyNtComposite
-- Batch with enum column _wrSmany :: Hasql.Statement.Statement [UUID] [WithRole] _wrSmany = selectManyWithRole
_wrDmany :: Hasql.Statement.Statement [UUID] () _wrDmany = deleteManyWithRole
_wrImany :: Hasql.Statement.Statement [WithRole] [WithRole] _wrImany = insertManyWithRole
_wrUmany :: Hasql.Statement.Statement [WithRole] [WithRole] _wrUmany = updateManyWithRole
------------------------------------------------------------------------------------------------------ Prefixed field name test----------------------------------------------------------------------------------------------------
testPrefixedFields :: IO ()testPrefixedFields = do let pd = PrefixDemo {prefixDemoVal = 42} assertEqual "prefixed field named \"val\"" 42 (prefixDemoVal pd) putStrLn "Prefixed fields test passed ✔"
------------------------------------------------------------------------------------------------------ Keyword sanitization test----------------------------------------------------------------------------------------------------
{- Verify that PostgreSQL columns named after Haskell reserved keywords get an apostrophe suffix in the generated record fields. If this function compiles and the field names are accessible, the sanitization works.-}testKeywordSanitization :: IO ()testKeywordSanitization = withTestConnection $ \conn -> do let kw = KeywordCols { id = Data.UUID.nil , type' = "something" :: Text , class' = Just ("someclass" :: Text) , data' = 42 :: Int32 }
-- Insert via typeclass — exercises encoder with sanitized field names inserted <- runSession conn (Q.insert kw) assertEqual "keyword sanitization > type'" kw.type' inserted.type' assertEqual "keyword sanitization > class'" kw.class' inserted.class' assertEqual "keyword sanitization > data'" kw.data' inserted.data'
-- Clean up runSession conn (Q.delete @KeywordCols inserted.id)
putStrLn "Keyword sanitization test passed ✔"
------------------------------------------------------------------------------------------------------ CRUD functional test----------------------------------------------------------------------------------------------------
testUsersCrud :: IO ()testUsersCrud = withTestConnection $ \conn -> do let testUuid = Data.UUID.nil let user = Users { id = testUuid , name = "Alice" , email = Just "alice@example.com" }
-- Insert via typeclass inserted <- runSession conn (Q.insert user) assertNotEqual "insert roundtrip > id" user.id inserted.id assertEqual "insert roundtrip > name" user.name inserted.name assertEqual "insert roundtrip > email" user.email inserted.email
-- Select by PK via typeclass found <- runSession conn (Q.select @Users inserted.id) assertEqual "select by PK" (Just inserted) found assertEqual "select by PK > id" (Just inserted.id) (fmap (.id) found)
-- Update via typeclass let updatedUser = Users { id = inserted.id , name = "Bob" , email = Just "bob@example.com" } updated <- runSession conn (Q.update updatedUser) assertEqual "update roundtrip" (Just updatedUser) updated
-- Verify update persisted found2 <- runSession conn (Q.select @Users inserted.id) assertEqual "select after update" (Just updatedUser) found2
-- Delete via typeclass runSession conn (Q.delete @Users inserted.id)
-- Verify deletion gone <- runSession conn (Q.select @Users inserted.id) assertEqual "select after delete" (Nothing :: Maybe Users) gone
putStrLn "CRUD test passed ✔"
------------------------------------------------------------------------------------------------------ Derivation tests----------------------------------------------------------------------------------------------------
testUsersDerivation :: IO ()testUsersDerivation = do testUuid <- nextRandom let user = Users { id = testUuid , name = "Alice" , email = Just "alice@example.com" } encoded = encode user case eitherDecode encoded of Left err -> error ("JSON roundtrip failed: " <> err) Right decoded -> assertEqual "JSON roundtrip" user decoded
-- Also test with a Nothing field let userNoEmail = Users { id = testUuid , name = "Bob" , email = Nothing } encodedNoEmail = encode userNoEmail case eitherDecode encodedNoEmail of Left err -> error ("JSON roundtrip (null email) failed: " <> err) Right decoded -> assertEqual "JSON roundtrip (null email)" userNoEmail decoded
assertEqual "show derivation" ("Users {id = " <> show testUuid <> ", name = \"Alice\", email = Just \"alice@example.com\"}") (show user)
putStrLn "Derivation test passed ✔"
------------------------------------------------------------------------------------------------------ HasEnum utility test----------------------------------------------------------------------------------------------------
testEnumUtilities :: IO ()testEnumUtilities = do assertEqual "allValues length" 3 (length (allValues :: [UserRole])) assertEqual "allValues order" [Admin, Moderator, Member] (allValues :: [UserRole]) assertEqual "toText Admin" "admin" (toText Admin) assertEqual "toText Moderator" "moderator" (toText Moderator) assertEqual "toText Member" "member" (toText Member) assertEqual "fromText admin" (Just Admin) (fromText "admin") assertEqual "fromText moderator" (Just Moderator) (fromText "moderator") assertEqual "fromText member" (Just Member) (fromText "member") assertEqual "fromText bogus" (Nothing :: Maybe UserRole) (fromText "bogus") putStrLn "Enum utilities test passed ✔"
------------------------------------------------------------------------------------------------------ Enum round-trip test----------------------------------------------------------------------------------------------------
testEnumRoundTrip :: IO ()testEnumRoundTrip = withTestConnection $ \conn -> do let wr = WithRole { id = Data.UUID.nil , name = "EnumUser" , role' = Admin }
-- Insert via typeclass inserted <- runSession conn (Q.insert wr) assertEqual "enum roundtrip > role'" Admin inserted.role' assertEqual "enum roundtrip > name" "EnumUser" inserted.name
-- Select by PK via typeclass found <- runSession conn (Q.select @WithRole inserted.id) assertEqual "enum select" (Just inserted) found
-- Update to a different role let updated = inserted {role' = Member} result <- runSession conn (Q.update updated) assertEqual "enum update > role'" (Just Member) (fmap (.role') result)
-- Clean up runSession conn (Q.delete @WithRole inserted.id)
-- Verify deletion gone <- runSession conn (Q.select @WithRole inserted.id) assertEqual "enum delete" (Nothing :: Maybe WithRole) gone
putStrLn "Enum roundtrip test passed ✔"
------------------------------------------------------------------------------------------------------ View functional test----------------------------------------------------------------------------------------------------
testViewSelect :: IO ()testViewSelect = withTestConnection $ \conn -> do -- Insert a user with email (appears in user_emails view) let user = Users { id = Data.UUID.nil , name = "ViewUser" , email = Just "view@example.com" } inserted <- runSession conn (Q.insert user)
-- Select all from the view via typeclass rows <- runSession conn (Q.selectView @UserEmails) assertTrue "view returns rows" (not (null rows)) assertTrue "view contains inserted user" (any (\ue -> ue.id == Just inserted.id) rows)
-- Clean up runSession conn (Q.delete @Users inserted.id)
putStrLn "View test passed ✔"
------------------------------------------------------------------------------------------------------ Newtype PK CRUD test----------------------------------------------------------------------------------------------------
testNewtypePkCrud :: IO ()testNewtypePkCrud = withTestConnection $ \conn -> do testUuid <- nextRandom let user = NtSingle { id = NtSinglePk testUuid , name = "NtAlice" , email = Just "nt@example.com" }
-- Insert inserted <- runSession conn (Hasql.Session.statement user insertNtSingle) assertEqual "nt insert > name" "NtAlice" inserted.name assertEqual "nt insert > email" (Just "nt@example.com") inserted.email
-- Select by newtype PK found <- runSession conn (Hasql.Session.statement inserted.id selectNtSingle) assertEqual "nt select by PK" (Just inserted) found
-- Update let updatedUser = NtSingle { id = inserted.id , name = "NtBob" , email = Just "ntbob@example.com" } updated <- runSession conn (Hasql.Session.statement updatedUser updateNtSingle) assertEqual "nt update" (Just updatedUser) updated
-- Delete by newtype PK runSession conn (Hasql.Session.statement inserted.id deleteNtSingle) gone <- runSession conn (Hasql.Session.statement inserted.id selectNtSingle) assertEqual "nt delete" (Nothing :: Maybe NtSingle) gone
putStrLn "Newtype PK CRUD test passed ✔"
------------------------------------------------------------------------------------------------------ HasPrimaryKey test----------------------------------------------------------------------------------------------------
testHasPrimaryKey :: IO ()testHasPrimaryKey = do testUuid <- nextRandom
-- Test HasPrimaryKey on existing table with raw UUID PK (no newtypes) let wp = WithPk {pkid = testUuid, name = "Test", email = Nothing, age = Nothing} assertEqual "withPk toPk" testUuid (toPk wp) assertEqual "withPk wrapPk" testUuid (wrapPk @WithPk testUuid) assertEqual "withPk unwrapPk" testUuid (unwrapPk @WithPk testUuid) assertEqual "withPk rawPk" testUuid (rawPk wp)
-- Test HasPrimaryKey on newtype single PK table let ns = NtSingle {id = NtSinglePk testUuid, name = "NtTest", email = Nothing} assertEqual "ntSingle toPk" (NtSinglePk testUuid) (toPk ns) assertEqual "ntSingle wrapPk" (NtSinglePk testUuid) (wrapPk @NtSingle testUuid) assertEqual "ntSingle unwrapPk" testUuid (unwrapPk @NtSingle (NtSinglePk testUuid)) assertEqual "ntSingle rawPk" testUuid (rawPk ns)
-- Test wrapPk / unwrapPk roundtrip let pk = NtSinglePk testUuid assertEqual "ntSingle wrap/unwrap roundtrip" pk (wrapPk @NtSingle (unwrapPk @NtSingle pk))
-- Test HasPrimaryKey on composite PK table (no newtypes) let cp = CompositePk {tenantId = testUuid, itemId = 42, payload = "test"} assertEqual "compositePk toPk" (testUuid, 42) (toPk cp) assertEqual "compositePk rawPk" (testUuid, 42) (rawPk cp)
-- Test HasPrimaryKey on newtype composite PK table let nc = NtComposite {tenantId = testUuid, itemId = 99, payload = "nctest"} ncPk = NtCompositePk {tenantId = testUuid, itemId = 99} assertEqual "ntComposite toPk" ncPk (toPk nc) assertEqual "ntComposite wrapPk" ncPk (wrapPk @NtComposite (testUuid, 99)) assertEqual "ntComposite unwrapPk" (testUuid, 99) (unwrapPk @NtComposite ncPk) assertEqual "ntComposite rawPk" (testUuid, 99) (rawPk nc)
putStrLn "HasPrimaryKey test passed ✔"
------------------------------------------------------------------------------------------------------ Batch CRUD functional test----------------------------------------------------------------------------------------------------
testBatchCrud :: IO ()testBatchCrud = withTestConnection $ \conn -> do uuid1 <- nextRandom uuid2 <- nextRandom uuid3 <- nextRandom
let rec1 = WithPk {pkid = uuid1, name = "Batch1", email = Just "b1@test.com", age = Just 10} rec2 = WithPk {pkid = uuid2, name = "Batch2", email = Nothing, age = Just 20} rec3 = WithPk {pkid = uuid3, name = "Batch3", email = Just "b3@test.com", age = Nothing}
-- insertMany inserted <- runSession conn (Hasql.Session.statement [rec1, rec2, rec3] insertManyWithPk) assertEqual "insertMany count" 3 (length inserted)
-- selectMany all 3 found <- runSession conn (Hasql.Session.statement [uuid1, uuid2, uuid3] selectManyWithPk) assertEqual "selectMany count" 3 (length found) assertTrue "selectMany contains uuid1" (any (\r -> r.pkid == uuid1) found) assertTrue "selectMany contains uuid2" (any (\r -> r.pkid == uuid2) found) assertTrue "selectMany contains uuid3" (any (\r -> r.pkid == uuid3) found)
-- updateMany (use full construction to avoid ambiguous record update) let upd1 = WithPk {pkid = uuid1, name = "Updated1", email = rec1.email, age = rec1.age} upd2 = WithPk {pkid = uuid2, name = "Updated2", email = rec2.email, age = rec2.age} upd3 = WithPk {pkid = uuid3, name = "Updated3", email = rec3.email, age = rec3.age} updated <- runSession conn (Hasql.Session.statement [upd1, upd2, upd3] updateManyWithPk) assertEqual "updateMany count" 3 (length updated) assertTrue "updateMany name1" (any (\(r :: WithPk) -> r.name == "Updated1") updated) assertTrue "updateMany name2" (any (\(r :: WithPk) -> r.name == "Updated2") updated) assertTrue "updateMany name3" (any (\(r :: WithPk) -> r.name == "Updated3") updated)
-- deleteMany first 2 runSession conn (Hasql.Session.statement [uuid1, uuid2] deleteManyWithPk)
-- selectMany all 3 — only the third should remain remaining <- runSession conn (Hasql.Session.statement [uuid1, uuid2, uuid3] selectManyWithPk) assertEqual "after deleteMany count" 1 (length remaining) assertTrue "after deleteMany only uuid3 remains" (any (\r -> r.pkid == uuid3) remaining)
-- Clean up runSession conn (Hasql.Session.statement [uuid3] deleteManyWithPk)
putStrLn "Batch CRUD test passed ✔"
------------------------------------------------------------------------------------------------------ Batch typeclass test----------------------------------------------------------------------------------------------------
testBatchTypeclasses :: IO ()testBatchTypeclasses = withTestConnection $ \conn -> do uuid1 <- nextRandom uuid2 <- nextRandom
let rec1 = WithPk {pkid = uuid1, name = "TC1", email = Just "tc1@test.com", age = Just 30} rec2 = WithPk {pkid = uuid2, name = "TC2", email = Nothing, age = Nothing}
-- insertMany via typeclass inserted <- runSession conn (Q.insertMany [rec1, rec2]) assertEqual "typeclass insertMany count" 2 (length inserted)
-- selectMany via typeclass found <- runSession conn (Q.selectMany @WithPk [uuid1, uuid2]) assertEqual "typeclass selectMany count" 2 (length found)
-- updateMany via typeclass (use full construction to avoid ambiguous record update) let upd1 = WithPk {pkid = uuid1, name = "TC1-updated", email = rec1.email, age = rec1.age} upd2 = WithPk {pkid = uuid2, name = "TC2-updated", email = rec2.email, age = rec2.age} updated <- runSession conn (Q.updateMany [upd1, upd2]) assertEqual "typeclass updateMany count" 2 (length updated) assertTrue "typeclass updateMany name" (any (\(r :: WithPk) -> r.name == "TC1-updated") updated)
-- deleteMany via typeclass runSession conn (Q.deleteMany @WithPk [uuid1, uuid2])
-- Verify deletion gone <- runSession conn (Q.selectMany @WithPk [uuid1, uuid2]) assertEqual "typeclass deleteMany" 0 (length gone)
putStrLn "Batch typeclass test passed ✔"
------------------------------------------------------------------------------------------------------ Test helpers----------------------------------------------------------------------------------------------------
withTestConnection :: (Hasql.Connection.Connection -> IO a) -> IO awithTestConnection = bracket acquire Hasql.Connection.release where acquire :: IO Hasql.Connection.Connection acquire = do result <- Hasql.Connection.acquire "" case result of Left err -> error ("Failed to connect: " <> show err) Right conn -> pure conn
runSession :: Hasql.Connection.Connection -> Hasql.Session.Session a -> IO arunSession conn session = do result <- Hasql.Session.run session conn case result of Left err -> error ("Session failed: " <> show err) Right a -> pure a
assertEqual :: (Eq a, Show a) => String -> a -> a -> IO ()assertEqual label expected actual | expected == actual = pure () | otherwise = die $ "Assertion failed (" <> label <> "): expected " <> show expected <> " but got " <> show actual
assertTrue :: String -> Bool -> IO ()assertTrue label condition | condition = pure () | otherwise = die ("Assertion failed (" <> label <> "): expected True but got False")
assertNotEqual :: (Eq a, Show a) => String -> a -> a -> IO ()assertNotEqual label unexpected actual | unexpected /= actual = pure () | otherwise = die $ "Assertion failed (" <> label <> "): expected NOT " <> show unexpected <> " but got " <> show actual