hpqtypes-effectful 1.1.0.0 → 1.2.0.0

raw patch · 8 files changed

+219/−100 lines, 8 filesdep +effectfuldep ~effectful-coredep ~hpqtypesPVP ok

version bump matches the API change (PVP)

Dependencies added: effectful

Dependency ranges changed: effectful-core, hpqtypes

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−0
• README.md +1/−1
• hpqtypes-effectful.cabal +11/−6
• src/Effectful/HPQTypes.hs +13/−10
• test/Main.hs +37/−83
• test/Test/Connection.hs +83/−0
• test/Test/Env.hs +17/−0
• test/Test/LastQuery.hs +47/−0

@@ -1,3 +1,13 @@+# hpqtypes-effectful-1.2.0.0 (2026-09-28)+* Compatibility with `hpqtypes` >= 1.15.0.0.+* Rename the `WithNewConnection` constructor of the `DB` effect to+  `WithNewSession`, to match the rename of `withNewConnection` to+  `withNewSession` in `hpqtypes`.+* A database session is now bound to the thread that started it. If another+  thread runs a query in that session, the query throws `ThreadMismatchError`.+  To run queries from another thread, start a separate session there with+  `withNewSession`.+ # hpqtypes-effectful-1.1.0.0 (2025-11-27) * Compatibility with `hpqtypes` >= 1.13.0.0. 

@@ -1,6 +1,6 @@ # hpqtypes-effectful -[![CI](https://github.com/haskell-effectful/hpqtypes-effectful/actions/workflows/haskell-ci.yml/badge.svg?branch=master)](https://github.com/haskell-effectful/hpqtypes-effectful/actions/workflows/haskell-ci.yml)+[![CI](https://github.com/haskell-effectful/hpqtypes-effectful/actions/workflows/haskell-gha.yml/badge.svg?branch=master)](https://github.com/haskell-effectful/hpqtypes-effectful/actions/workflows/haskell-gha.yml) [![Hackage](https://img.shields.io/hackage/v/hpqtypes-effectful.svg)](https://hackage.haskell.org/package/hpqtypes-effectful) [![Stackage LTS](https://www.stackage.org/package/hpqtypes-effectful/badge/lts)](https://www.stackage.org/lts/package/hpqtypes-effectful) [![Stackage Nightly](https://www.stackage.org/package/hpqtypes-effectful/badge/nightly)](https://www.stackage.org/nightly/package/hpqtypes-effectful)

@@ -1,7 +1,7 @@ cabal-version:      3.0 build-type:         Simple name:               hpqtypes-effectful-version:            1.1.0.0+version:            1.2.0.0 license:            BSD-3-Clause license-file:       LICENSE category:           Database@@ -12,11 +12,11 @@ description:        Adaptation of the @<https://hackage.haskell.org/package/hpqtypes hpqtypes>@ library for the @<https://hackage.haskell.org/package/effectful effectful>@ ecosystem. homepage:           https://github.com/haskell-effectful/hpqtypes-effectful -extra-source-files:+extra-doc-files:   CHANGELOG.md   README.md -tested-with: GHC == { 9.2.8, 9.4.8, 9.6.7, 9.8.4, 9.10.3, 9.12.2, 9.14.1 }+tested-with: GHC ^>= { 9.2, 9.4, 9.6, 9.8, 9.10, 9.12, 9.14 }  bug-reports: https://github.com/haskell-effectful/hpqtypes-effectful/issues source-repository head@@ -58,8 +58,8 @@   import:          language    build-depends:   base               >= 4.16      && < 5-                 , effectful-core     >= 2.5.0.0   && < 3.0.0.0-                 , hpqtypes           >= 1.13.0.0  && < 1.14.0.0+                 , effectful-core     >= 2.5.0.0   && < 3+                 , hpqtypes           >= 1.15.0.0  && < 1.16    hs-source-dirs:   src @@ -71,6 +71,7 @@   ghc-options:    -threaded    build-depends:  base+                , effectful                 , effectful-core                 , hpqtypes-effectful                 , resource-pool@@ -78,9 +79,13 @@                 , tasty-hunit                 , text -  hs-source-dirs: examples test+  hs-source-dirs: test+  other-modules:  Test.Connection+                  Test.Env+                  Test.LastQuery    -- Include examples to make sure they compile.+  hs-source-dirs: examples   other-modules:  OuterJoins    type:           exitcode-stdio-1.0

@@ -35,7 +35,7 @@   AcquireAndHoldConnection :: IsolationLevel -> Permissions -> DB m ()   UnsafeAcquireOnDemandConnection :: DB m ()   GetNotification :: Int -> DB m (Maybe PQ.Notification)-  WithNewConnection :: m a -> DB m a+  WithNewSession :: m a -> DB m a  type instance DispatchOf DB = Dynamic @@ -52,11 +52,16 @@   acquireAndHoldConnection isoLevel = send . AcquireAndHoldConnection isoLevel   unsafeAcquireOnDemandConnection = send UnsafeAcquireOnDemandConnection   getNotification = send . GetNotification-  withNewConnection = send . WithNewConnection+  withNewSession = send . WithNewSession  -- | Run the 'DB' effect with the given connection source and transaction -- settings. --+-- The session is bound to the calling thread. If another thread invokes a+-- 'MonadDB' operation that uses the connection, the operation throws+-- 'ThreadMismatchError' wrapped in 'DBException'. To run queries from another+-- thread, start a separate session there with 'withNewSession'.+-- -- /Note:/ this is the @effectful@ version of 'runDBT'. runDB   :: IOE :> es@@ -69,10 +74,10 @@ runDB cs0 ts0 m = PQ.withConnectionData cs0 ts0 $ \cd0 -> do   reinterpretWith (State.evalState $ PQ.mkDBState cd0 ts0) m $ \env -> \case     RunQuery sql -> modifyState $ \st -> withFrozenCallStack $ do-      PQ.withConnection (PQ.dbConnectionData st) $ \conn -> do+      PQ.withConnection st $ \conn -> do         liftIO $ PQ.updateStateWith conn st sql =<< PQ.runQueryIO conn sql     RunPreparedQuery name sql -> modifyState $ \st -> withFrozenCallStack $ do-      PQ.withConnection (PQ.dbConnectionData st) $ \conn -> do+      PQ.withConnection st $ \conn -> do         liftIO $ PQ.updateStateWith conn st sql =<< PQ.runPreparedQueryIO conn name sql     GetLastQuery -> PQ.dbLastQuery <$> get     WithFrozenLastQuery action -> do@@ -87,15 +92,13 @@     GetConnectionAcquisitionMode -> do       liftIO . PQ.getConnectionAcquisitionModeIO . PQ.dbConnectionData =<< get     AcquireAndHoldConnection isolationLevel permissions -> withState $ \st -> do-      PQ.changeAcquisitionModeTo-        (AcquireAndHold isolationLevel permissions)-        (PQ.dbConnectionData st)+      PQ.changeAcquisitionModeTo (AcquireAndHold isolationLevel permissions) st     UnsafeAcquireOnDemandConnection -> withState $ \st -> do-      PQ.changeAcquisitionModeTo AcquireOnDemand (PQ.dbConnectionData st)+      PQ.changeAcquisitionModeTo AcquireOnDemand st     GetNotification time -> withState $ \st -> do-      PQ.withConnection (PQ.dbConnectionData st) $ \conn -> do+      PQ.withConnection st $ \conn -> do         liftIO $ PQ.getNotificationIO conn time-    WithNewConnection action -> do+    WithNewSession action -> do       st <- get       cam <- liftIO . PQ.getConnectionAcquisitionModeIO $ PQ.dbConnectionData st       let cs = PQ.getConnectionSource $ PQ.dbConnectionData st

@@ -2,96 +2,50 @@  module Main (main) where -import Control.Monad (void)-import Data.Int (Int32)+import Data.Pool import Data.Text qualified as T-import Effectful-import Effectful.Exception import Effectful.HPQTypes-import System.Environment (lookupEnv)+import System.Environment+import System.Exit import Test.Tasty-import Test.Tasty.HUnit -main :: IO ()-main = defaultMain tests+import Test.Connection+import Test.Env+import Test.LastQuery -tests :: TestTree-tests =-  testGroup-    "tests"-    [ testCase "test getLastQuery" testGetLastQuery-    , testCase "test withFrozenLastQuery" testWithFrozenLastQuery-    , testCase "test connection stats retrieval with new connection" testConnectionStatsWithNewConnection+tests :: TestData -> [TestTree]+tests td =+  concat+    [ lastQueryTests td+    , connectionTests td     ] -testGetLastQuery :: Assertion-testGetLastQuery = do-  dbUrl <- getConnString-  let connectionSource = simpleSource $ defaultConnectionSettings {csConnInfo = dbUrl}-  void . runEff . runDB (unConnectionSource connectionSource) defaultTransactionSettings $ do-    do-      -- Run the first query and perform some basic sanity checks-      let sql = "SELECT 1"-      rowNo <- runSQL sql-      liftIO $ assertEqual "One row should be retrieved" 1 rowNo-      result <- fetchMany (runIdentity @Int32)-      liftIO $ assertEqual "Result should be [1]" [1] result-      (_, SomeSQL lastQuery) <- getLastQuery-      liftIO $ assertEqual "SQL don't match" (show sql) (show lastQuery)-    do-      -- Run the second query and check that `getLastQuery` gives updated result-      let newSQL = "SELECT 2"-      runSQL_ newSQL-      (_, SomeSQL newLastQuery) <- getLastQuery-      liftIO $ assertEqual "SQL don't match" (show newSQL) (show newLastQuery)--testWithFrozenLastQuery :: Assertion-testWithFrozenLastQuery = do-  dbUrl <- getConnString-  let connectionSource = simpleSource $ defaultConnectionSettings {csConnInfo = dbUrl}-  void . runEff . runDB (unConnectionSource connectionSource) defaultTransactionSettings $ do-    let sql = "SELECT 1"-    runSQL_ sql-    withFrozenLastQuery $ do-      runSQL_ "SELECT 2"-      (_, SomeSQL lastQuery) <- getLastQuery-      liftIO $ assertEqual "The last query before freeze should be reported" (show sql) (show lastQuery)-    (_, SomeSQL lastQuery) <- getLastQuery-    liftIO $ assertEqual "The last query before freeze should be reported" (show sql) (show lastQuery)+main :: IO ()+main = do+  (connString, args) <- getConnString+  let connSettings = defaultConnectionSettings {csConnInfo = connString}+  connSource <- poolSource connSettings $ \connect disconnect ->+    defaultPoolConfig connect disconnect cacheTTL maxConnections+  let td = TestData {tdConnSource = unConnectionSource connSource}+  withArgs args . defaultMain . testGroup "hpqtypes-effectful" $ tests td+  where+    -- For parallel execution of tests.+    maxConnections :: Int+    maxConnections = 16 -testConnectionStatsWithNewConnection :: Assertion-testConnectionStatsWithNewConnection = do-  dbUrl <- getConnString-  let connectionSource = simpleSource $ defaultConnectionSettings {csConnInfo = dbUrl}-  void . runEff . runDB (unConnectionSource connectionSource) defaultTransactionSettings $ do-    runSQL_ "SELECT 1"-    runSQL_ "SELECT 2"-    stats <- getConnectionStats-    liftIO $ assertEqual "Incorrect statsQueries" 2 $ statsQueries stats-    unsafeWithoutTransaction-      . bracket_-        (runSQL_ "CREATE TABLE some_table (field INT)")-        (runSQL_ "DROP TABLE some_table")-      $ do-        runSQL_ "BEGIN"-        runSQL_ "INSERT INTO some_table VALUES (1)"-        withNewConnection $ do-          newStats <- getConnectionStats-          liftIO $ assertEqual "Connection stats should be reset" 0 $ statsQueries newStats-          noOfResults <- runSQL "SELECT * FROM some_table"-          liftIO $ assertEqual "Results should not be visible yet" 0 noOfResults-        runSQL_ "COMMIT"-        noOfResults <- runSQL "SELECT * FROM some_table"-        liftIO $ assertEqual "Results should be visible" 1 noOfResults+    cacheTTL :: Double+    cacheTTL = 10 -------------------------------------------- Helpers+    getConnString :: IO (T.Text, [String])+    getConnString =+      getArgs >>= \case+        connString : args -> pure (T.pack connString, args)+        [] ->+          lookupEnv "GITHUB_ACTIONS" >>= \case+            Just "true" -> pure ("host=localhost user=postgres password=postgres", [])+            _ -> printUsage >> exitFailure -getConnString :: IO T.Text-getConnString =-  lookupEnv "GITHUB_ACTIONS" >>= \case-    Just "true" -> pure . T.pack $ "host=postgres user=postgres password=postgres"-    _ -> do-      lookupEnv "DATABASE_URL" >>= \case-        Just url -> pure $ T.pack url-        Nothing -> error "DATABASE_URL environment variable is not set"+    printUsage :: IO ()+    printUsage = do+      prog <- getProgName+      putStrLn $ "Usage: " <> prog <> " <connection info string> [tasty args]"

@@ -0,0 +1,83 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Tests of connection handling.+module Test.Connection (connectionTests) where++import Control.Monad+import Data.Typeable+import Effectful+import Effectful.Concurrent+import Effectful.Concurrent.MVar+import Effectful.Exception+import Effectful.HPQTypes+import Test.Tasty+import Test.Tasty.HUnit++import Test.Env++connectionTests :: TestData -> [TestTree]+connectionTests td =+  [ testCase "connection stats with a new session" $+      testConnectionStatsWithNewSession td+  , testCase "session thread binding" $+      testSessionThreadBinding td+  ]++testConnectionStatsWithNewSession :: TestData -> Assertion+testConnectionStatsWithNewSession td = runTest td $ do+  runSQL_ "SELECT 1"+  runSQL_ "SELECT 2"+  stats <- getConnectionStats+  liftIO $ assertEqual "Incorrect statsQueries" 2 $ statsQueries stats+  unsafeWithoutTransaction+    . bracket_+      (runSQL_ "CREATE TABLE some_table (field INT)")+      (runSQL_ "DROP TABLE some_table")+    $ do+      withManualTransaction $ do+        runSQL_ "INSERT INTO some_table VALUES (1)"+        withNewSession $ do+          newStats <- getConnectionStats+          liftIO $ assertEqual "Connection stats should be reset" 0 $ statsQueries newStats+          noOfResults <- runSQL "SELECT * FROM some_table"+          liftIO $ assertEqual "Results should not be visible yet" 0 noOfResults+      noOfResults <- runSQL "SELECT * FROM some_table"+      liftIO $ assertEqual "Results should be visible" 1 noOfResults+  where+    -- Without the rollback the DROP TABLE of the enclosing bracket_ runs+    -- inside the failed transaction and is discarded with it.+    withManualTransaction :: DB :> es => Eff es a -> Eff es a+    withManualTransaction action =+      fst+        <$> generalBracket+          (runSQL_ "BEGIN")+          ( \() -> \case+              ExitCaseSuccess _ -> runSQL_ "COMMIT"+              _ -> runSQL_ "ROLLBACK"+          )+          (\() -> action)++testSessionThreadBinding :: TestData -> Assertion+testSessionThreadBinding td = runTest td $ do+  result <- newEmptyMVar+  void . forkIO $ do+    sameSession <- try $ runSQL_ "SELECT 1"+    newSession <- try @SomeException . withNewSession $ runSQL_ "SELECT 1"+    putMVar result (sameSession, newSession)+  (sameSession, newSession) <- takeMVar result+  liftIO $ do+    assertThreadMismatch sameSession+    case newSession of+      Left err ->+        assertFailure $ "withNewSession failed in another thread: " <> show err+      Right () -> pure ()+  where+    assertThreadMismatch :: Either SomeException () -> Assertion+    assertThreadMismatch = \case+      Left err+        | Just (DBException _ _ specificError _) <- fromException err+        , Just ThreadMismatchError {} <- cast specificError ->+            pure ()+        | otherwise ->+            assertFailure $ "The query threw an unexpected exception: " <> show err+      Right () -> assertFailure "The query did not throw ThreadMismatchError"

@@ -0,0 +1,17 @@+-- | Data shared by all the tests.+module Test.Env+  ( TestData (..)+  , runTest+  ) where++import Effectful+import Effectful.Concurrent+import Effectful.HPQTypes++newtype TestData = TestData+  { tdConnSource :: forall es. IOE :> es => ConnectionSourceM (Eff es)+  }++runTest :: TestData -> Eff [DB, Concurrent, IOE] a -> IO a+runTest td =+  runEff . runConcurrent . runDB (tdConnSource td) defaultTransactionSettings

@@ -0,0 +1,47 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Tests of the query recorded as the last one.+module Test.LastQuery (lastQueryTests) where++import Data.Int+import Effectful+import Effectful.HPQTypes+import Test.Tasty+import Test.Tasty.HUnit++import Test.Env++lastQueryTests :: TestData -> [TestTree]+lastQueryTests td =+  [ testCase "getLastQuery" $ testGetLastQuery td+  , testCase "withFrozenLastQuery" $ testWithFrozenLastQuery td+  ]++testGetLastQuery :: TestData -> Assertion+testGetLastQuery td = runTest td $ do+  do+    -- Run the first query and perform some basic sanity checks+    let sql = "SELECT 1"+    rowNo <- runSQL sql+    liftIO $ assertEqual "One row should be retrieved" 1 rowNo+    result <- fetchMany (runIdentity @Int32)+    liftIO $ assertEqual "Result should be [1]" [1] result+    (_, SomeSQL lastQuery) <- getLastQuery+    liftIO $ assertEqual "SQL don't match" (show sql) (show lastQuery)+  do+    -- Run the second query and check that `getLastQuery` gives updated result+    let newSQL = "SELECT 2"+    runSQL_ newSQL+    (_, SomeSQL newLastQuery) <- getLastQuery+    liftIO $ assertEqual "SQL don't match" (show newSQL) (show newLastQuery)++testWithFrozenLastQuery :: TestData -> Assertion+testWithFrozenLastQuery td = runTest td $ do+  let sql = "SELECT 1"+  runSQL_ sql+  withFrozenLastQuery $ do+    runSQL_ "SELECT 2"+    (_, SomeSQL lastQuery) <- getLastQuery+    liftIO $ assertEqual "The last query before freeze should be reported" (show sql) (show lastQuery)+  (_, SomeSQL lastQuery) <- getLastQuery+  liftIO $ assertEqual "The last query before freeze should be reported" (show sql) (show lastQuery)