diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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) diff --git a/hpqtypes-effectful.cabal b/hpqtypes-effectful.cabal --- a/hpqtypes-effectful.cabal +++ b/hpqtypes-effectful.cabal @@ -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 @@ library for the @@ 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 diff --git a/src/Effectful/HPQTypes.hs b/src/Effectful/HPQTypes.hs --- a/src/Effectful/HPQTypes.hs +++ b/src/Effectful/HPQTypes.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 <> " [tasty args]" diff --git a/test/Test/Connection.hs b/test/Test/Connection.hs new file mode 100644 --- /dev/null +++ b/test/Test/Connection.hs @@ -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" diff --git a/test/Test/Env.hs b/test/Test/Env.hs new file mode 100644 --- /dev/null +++ b/test/Test/Env.hs @@ -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 diff --git a/test/Test/LastQuery.hs b/test/Test/LastQuery.hs new file mode 100644 --- /dev/null +++ b/test/Test/LastQuery.hs @@ -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)