diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,6 @@ +# hpqtypes-effectful-1.1.0.0 (2025-11-27) +* Compatibility with `hpqtypes` >= 1.13.0.0. + # hpqtypes-effectful-1.0.2.0 (2024-03-18) * Compatibility with `hpqtypes` >= 1.12.0.0. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,8 +1,7 @@ # hpqtypes-effectful -[![Build Status](https://github.com/haskell-effectful/hpqtypes-effectful/workflows/Haskell-CI/badge.svg?branch=master)](https://github.com/haskell-effectful/hpqtypes-effectful/actions?query=branch%3Amaster) +[![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) [![Hackage](https://img.shields.io/hackage/v/hpqtypes-effectful.svg)](https://hackage.haskell.org/package/hpqtypes-effectful) -[![Dependencies](https://img.shields.io/hackage-deps/v/hpqtypes-effectful.svg)](https://packdeps.haskellers.com/feed?needle=andrzej@rybczak.net) [![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/examples/OuterJoins.hs b/examples/OuterJoins.hs --- a/examples/OuterJoins.hs +++ b/examples/OuterJoins.hs @@ -4,11 +4,11 @@ module OuterJoins (runApp) where import Control.Monad -import Control.Monad.Catch import Data.Int import Data.Pool -import qualified Data.Text as T +import Data.Text qualified as T import Effectful +import Effectful.Exception import Effectful.HPQTypes -- | Generic 'putStrLn'. 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.0.2.0 +version: 1.1.0.0 license: BSD-3-Clause license-file: LICENSE category: Database @@ -16,7 +16,7 @@ CHANGELOG.md README.md -tested-with: GHC == { 8.10.7, 9.0.2, 9.2.8, 9.4.8, 9.6.4, 9.8.2 } +tested-with: GHC == { 9.2.8, 9.4.8, 9.6.7, 9.8.4, 9.10.3, 9.12.2, 9.14.1 } bug-reports: https://github.com/haskell-effectful/hpqtypes-effectful/issues source-repository head @@ -26,7 +26,7 @@ common language ghc-options: -Wall -Wcompat -Wredundant-constraints -Wno-unticked-promoted-constructors - + -Werror=prepositive-qualified-module default-language: Haskell2010 @@ -38,6 +38,7 @@ DerivingStrategies FlexibleContexts FlexibleInstances + ImportQualifiedPost GADTs GeneralizedNewtypeDeriving LambdaCase @@ -51,14 +52,14 @@ TypeApplications TypeFamilies TypeOperators + UndecidableInstances library import: language - build-depends: base >= 4.14 && < 5 - , effectful-core >= 1.2.0.0 && < 3.0.0.0 - , exceptions - , hpqtypes >= 1.12.0.0 && < 1.13.0.0 + 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 hs-source-dirs: src @@ -72,8 +73,6 @@ build-depends: base , effectful-core , hpqtypes-effectful - , exceptions - , hpqtypes , resource-pool , tasty , tasty-hunit diff --git a/src/Effectful/HPQTypes.hs b/src/Effectful/HPQTypes.hs --- a/src/Effectful/HPQTypes.hs +++ b/src/Effectful/HPQTypes.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} -- | Access to a PostgreSQL database via 'MonadDB'. @@ -11,211 +10,130 @@ -- * Re-exports , module Database.PostgreSQL.PQTypes - ) -where + ) where -import Control.Concurrent.MVar (readMVar) -import Control.Monad.Catch import Database.PostgreSQL.PQTypes -import qualified Database.PostgreSQL.PQTypes.Internal.Connection as PQ -import qualified Database.PostgreSQL.PQTypes.Internal.Notification as PQ -import qualified Database.PostgreSQL.PQTypes.Internal.State as PQ +import Database.PostgreSQL.PQTypes.Internal.Connection qualified as PQ +import Database.PostgreSQL.PQTypes.Internal.Notification qualified as PQ +import Database.PostgreSQL.PQTypes.Internal.State qualified as PQ import Effectful import Effectful.Dispatch.Dynamic -import Effectful.State.Static.Local (State, evalState) -import qualified Effectful.State.Static.Local as State +import Effectful.Exception +import Effectful.State.Static.Local qualified as State import GHC.Stack -- | Provide the ability to access a PostgreSQL database via 'MonadDB'. data DB :: Effect where RunQuery :: IsSQL sql => sql -> DB m Int - GetQueryResult :: FromRow row => DB m (Maybe (QueryResult row)) - ClearQueryResult :: DB m () - GetBackendPid :: DB m BackendPid - GetConnectionStats :: DB m PQ.ConnectionStats RunPreparedQuery :: IsSQL sql => PQ.QueryName -> sql -> DB m Int - GetLastQuery :: DB m SomeSQL - GetTransactionSettings :: DB m TransactionSettings - SetTransactionSettings :: TransactionSettings -> DB m () + GetLastQuery :: DB m (BackendPid, SomeSQL) WithFrozenLastQuery :: m a -> DB m a - WithNewConnection :: m a -> DB m a + GetConnectionStats :: DB m PQ.ConnectionStats + GetQueryResult :: FromRow row => DB m (Maybe (QueryResult row)) + ClearQueryResult :: DB m () + GetConnectionAcquisitionMode :: DB m ConnectionAcquisitionMode + AcquireAndHoldConnection :: IsolationLevel -> Permissions -> DB m () + UnsafeAcquireOnDemandConnection :: DB m () GetNotification :: Int -> DB m (Maybe PQ.Notification) + WithNewConnection :: m a -> DB m a type instance DispatchOf DB = Dynamic -- | Orphan, canonical instance. instance DB :> es => MonadDB (Eff es) where runQuery = withFrozenCallStack $ send . RunQuery - getQueryResult = send GetQueryResult - clearQueryResult = send ClearQueryResult - getBackendPid = send GetBackendPid - getConnectionStats = withFrozenCallStack $ send GetConnectionStats - runPreparedQuery qn = withFrozenCallStack $ send . RunPreparedQuery qn + runPreparedQuery name = withFrozenCallStack $ send . RunPreparedQuery name getLastQuery = send GetLastQuery - getTransactionSettings = send GetTransactionSettings - setTransactionSettings = send . SetTransactionSettings withFrozenLastQuery = send . WithFrozenLastQuery - withNewConnection = send . WithNewConnection + getConnectionStats = withFrozenCallStack $ send GetConnectionStats + getQueryResult = send GetQueryResult + clearQueryResult = send ClearQueryResult + getConnectionAcquisitionMode = send GetConnectionAcquisitionMode + acquireAndHoldConnection isoLevel = send . AcquireAndHoldConnection isoLevel + unsafeAcquireOnDemandConnection = send UnsafeAcquireOnDemandConnection getNotification = send . GetNotification + withNewConnection = send . WithNewConnection -- | Run the 'DB' effect with the given connection source and transaction -- settings. -- -- /Note:/ this is the @effectful@ version of 'runDBT'. runDB - :: forall es a - . IOE :> es + :: IOE :> es => PQ.ConnectionSourceM (Eff es) -- ^ Connection source. -> TransactionSettings -- ^ Transaction settings. -> Eff (DB : es) a -> Eff es a -runDB connectionSource transactionSettings = - reinterpret runWithState $ \env -> \case - RunQuery sql -> unDBEff $ runQuery sql - GetQueryResult -> unDBEff getQueryResult - ClearQueryResult -> unDBEff clearQueryResult - GetBackendPid -> unDBEff getBackendPid - GetConnectionStats -> unDBEff getConnectionStats - RunPreparedQuery queryName sql -> unDBEff $ runPreparedQuery queryName sql - GetLastQuery -> unDBEff getLastQuery - GetTransactionSettings -> unDBEff getTransactionSettings - SetTransactionSettings settings -> unDBEff $ setTransactionSettings settings - WithFrozenLastQuery (action :: Eff localEs b) -> do - localSeqUnlift env $ \unlift -> do - unDBEff . withFrozenLastQuery . DBEff $ unlift action - WithNewConnection (action :: Eff localEs b) -> do - localSeqUnlift env $ \unlift -> do - unDBEff . withNewConnection . DBEff $ unlift action - GetNotification time -> unDBEff $ getNotification time - where - runWithState :: Eff (State (DBState es) : es) a -> Eff es a - runWithState eff = - PQ.withConnection connectionSource $ \conn -> do - let dbState0 = mkDBState connectionSource conn transactionSettings - evalState dbState0 $ do - handleAutoTransaction transactionSettings doWithTransaction eff - - doWithTransaction - :: TransactionSettings - -> Eff (State (DBState es) : es) a - -> Eff (State (DBState es) : es) a - doWithTransaction ts eff = unDBEff . withTransaction' ts $ DBEff eff - -mkDBState - :: PQ.ConnectionSourceM m - -> PQ.Connection - -> TransactionSettings - -> PQ.DBState m -mkDBState connectionSource conn ts = - PQ.DBState - { PQ.dbConnection = conn - , PQ.dbConnectionSource = connectionSource - , PQ.dbTransactionSettings = ts - , PQ.dbLastQuery = SomeSQL (mempty :: SQL) - , PQ.dbRecordLastQuery = True - , PQ.dbQueryResult = Nothing - } - -handleAutoTransaction - :: TransactionSettings - -> (TransactionSettings -> m a -> m a) - -> m a - -> m a -handleAutoTransaction transactionSettings doWithTransaction action = - -- We don't set tsAutoTransaction to False in the context of the action - -- because if the action calls commit inside, then with tsAutoTransaction - -- another transaction should be started automatically and if it's not set, it - -- won't happen (see source of the commit' function). On the other hand, - -- withTransaction itself uses commit' and there we don't want to start - -- another transaction. - if tsAutoTransaction transactionSettings - then doWithTransaction (transactionSettings {tsAutoTransaction = False}) action - else action - ---------------------------------------------------- --- Internal effect stack ---------------------------------------------------- +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 + liftIO $ PQ.updateStateWith conn st sql =<< PQ.runQueryIO conn sql + RunPreparedQuery name sql -> modifyState $ \st -> withFrozenCallStack $ do + PQ.withConnection (PQ.dbConnectionData st) $ \conn -> do + liftIO $ PQ.updateStateWith conn st sql =<< PQ.runPreparedQueryIO conn name sql + GetLastQuery -> PQ.dbLastQuery <$> get + WithFrozenLastQuery action -> do + origValue <- PQ.dbRecordLastQuery <$> get + bracket_ + (modify $ \st -> st {PQ.dbRecordLastQuery = False}) + (modify $ \st -> st {PQ.dbRecordLastQuery = origValue}) + (localSeqUnlift env $ \unlift -> unlift action) + GetConnectionStats -> PQ.dbConnectionStats <$> get + GetQueryResult -> PQ.dbQueryResult <$> get + ClearQueryResult -> modify $ \st -> st {PQ.dbQueryResult = Nothing} + GetConnectionAcquisitionMode -> do + liftIO . PQ.getConnectionAcquisitionModeIO . PQ.dbConnectionData =<< get + AcquireAndHoldConnection isolationLevel permissions -> withState $ \st -> do + PQ.changeAcquisitionModeTo + (AcquireAndHold isolationLevel permissions) + (PQ.dbConnectionData st) + UnsafeAcquireOnDemandConnection -> withState $ \st -> do + PQ.changeAcquisitionModeTo AcquireOnDemand (PQ.dbConnectionData st) + GetNotification time -> withState $ \st -> do + PQ.withConnection (PQ.dbConnectionData st) $ \conn -> do + liftIO $ PQ.getNotificationIO conn time + WithNewConnection action -> do + st <- get + cam <- liftIO . PQ.getConnectionAcquisitionModeIO $ PQ.dbConnectionData st + let cs = PQ.getConnectionSource $ PQ.dbConnectionData st + ts = + TransactionSettings + { tsRestartPredicate = PQ.dbRestartPredicate st + , tsConnectionAcquisitionMode = cam + } + raiseWith SeqUnlift $ \lower -> do + PQ.withConnectionData cs ts $ \cd -> lower $ do + localSeqUnlift env $ \unlift -> do + bracket_ (put $ PQ.mkDBState cd ts) (put st) $ unlift action --- | Newtype wrapper over the internal DB effect stack -newtype DBEff es a = DBEff - { unDBEff :: Eff (State (DBState es) : es) a - } - deriving newtype (Functor, Applicative, Monad, MonadThrow, MonadCatch, MonadMask) +---------------------------------------- +-- Internal helpers -- | Internal state used to reinterpret the `DB` effect type DBState es = PQ.DBState (Eff es) --- Convenience `MonadIO` instance -instance IOE :> es => MonadIO (DBEff es) where - liftIO b = DBEff $ liftIO b - -get :: DBEff es (DBState es) -get = DBEff State.get - -put :: DBState es -> DBEff es () -put = DBEff . State.put - -modify :: (DBState es -> DBState es) -> DBEff es () -modify = DBEff . State.modify - -instance IOE :> es => MonadDB (DBEff es) where - runQuery sql = do - dbState <- get - (rows, newDbState) <- liftIO $ do - PQ.updateStateWith dbState sql - =<< PQ.runQueryIO (PQ.dbConnection dbState) sql - put newDbState - pure rows - - getQueryResult = - get >>= \dbState -> pure $ PQ.dbQueryResult dbState - - clearQueryResult = - modify $ \st -> st {PQ.dbQueryResult = Nothing} - - getBackendPid = liftIO . PQ.getBackendPidIO . PQ.dbConnection =<< get - - getConnectionStats = do - dbState <- get - mconn <- liftIO . readMVar . PQ.unConnection $ PQ.dbConnection dbState - case mconn of - Nothing -> throwDB $ HPQTypesError "getConnectionStats: no connection" - Just cd -> pure $ PQ.cdStats cd - - runPreparedQuery queryName sql = do - dbState <- get - (rows, newDbState) <- liftIO $ do - PQ.updateStateWith dbState sql - =<< PQ.runPreparedQueryIO (PQ.dbConnection dbState) queryName sql - put newDbState - pure rows - - getLastQuery = PQ.dbLastQuery <$> get - - getTransactionSettings = PQ.dbTransactionSettings <$> get +get :: Eff (State.State (DBState es) : es) (DBState es) +get = State.get - setTransactionSettings settings = modify $ \st' -> - st' {PQ.dbTransactionSettings = settings} +put :: DBState es -> Eff (State.State (DBState es) : es) () +put = State.put - withFrozenLastQuery action = do - let restoreRecordLastQuery st = - modify $ \st' -> - st' {PQ.dbRecordLastQuery = PQ.dbRecordLastQuery st} - bracket get restoreRecordLastQuery $ \st -> do - put st {PQ.dbRecordLastQuery = False} - action +modify :: (DBState es -> DBState es) -> Eff (State.State (DBState es) : es) () +modify = State.modify - withNewConnection action = DBEff $ do - dbState0 <- State.get - raiseWith SeqUnlift $ \lower -> do - PQ.withConnection (PQ.dbConnectionSource dbState0) $ \newConn -> lower $ do - let transactionSettings = PQ.dbTransactionSettings dbState0 - dbState = mkDBState (PQ.dbConnectionSource dbState0) newConn transactionSettings - unDBEff . bracket_ (put dbState) (put dbState0) $ do - handleAutoTransaction transactionSettings withTransaction' action +modifyState + :: (DBState es -> Eff es (a, DBState es)) + -> Eff (State.State (DBState es) : es) a +modifyState action = do + s0 <- get + (a, s) <- raise $ action s0 + put s + pure a - getNotification time = do - dbState <- get - liftIO $ PQ.getNotificationIO dbState time +withState + :: (DBState es -> Eff es a) + -> Eff (State.State (DBState es) : es) a +withState action = raise . action =<< get diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -4,9 +4,9 @@ import Control.Monad (void) import Data.Int (Int32) -import qualified Data.Text as T +import Data.Text qualified as T import Effectful -import Effectful.Error.Static +import Effectful.Exception import Effectful.HPQTypes import System.Environment (lookupEnv) import Test.Tasty @@ -28,65 +28,61 @@ testGetLastQuery = do dbUrl <- getConnString let connectionSource = simpleSource $ defaultConnectionSettings {csConnInfo = dbUrl} - void . runEff . runErrorNoCallStack @HPQTypesError . runDB (unConnectionSource connectionSource) defaultTransactionSettings $ do + void . runEff . runDB (unConnectionSource connectionSource) defaultTransactionSettings $ do do -- Run the first query and perform some basic sanity checks - let sql = mkSQL "SELECT 1" - rowNo <- runQuery sql + 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 + (_, 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 = mkSQL "SELECT 2" - runQuery_ newSQL - SomeSQL newLastQuery <- getLastQuery + 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 . runErrorNoCallStack @HPQTypesError . runDB (unConnectionSource connectionSource) defaultTransactionSettings $ do - let sql = mkSQL "SELECT 1" - runQuery_ sql + void . runEff . runDB (unConnectionSource connectionSource) defaultTransactionSettings $ do + let sql = "SELECT 1" + runSQL_ sql withFrozenLastQuery $ do - runQuery_ $ mkSQL "SELECT 2" - getLastQuery >>= \(SomeSQL lastQuery) -> - liftIO $ assertEqual "The last query before freeze should be reported" (show sql) (show lastQuery) - getLastQuery >>= \(SomeSQL lastQuery) -> + 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) testConnectionStatsWithNewConnection :: Assertion testConnectionStatsWithNewConnection = do dbUrl <- getConnString let connectionSource = simpleSource $ defaultConnectionSettings {csConnInfo = dbUrl} - transactionSettings = - defaultTransactionSettings - { tsIsolationLevel = ReadCommitted - , tsAutoTransaction = False - } - void . runEff . runErrorNoCallStack @HPQTypesError . runDB (unConnectionSource connectionSource) transactionSettings $ do - do - runQuery_ $ mkSQL "SELECT 1" - runQuery_ $ mkSQL "SELECT 2" - connectionStats <- getConnectionStats - liftIO $ assertEqual "Incorrect connection stats" (ConnectionStats 3 3 3 0) connectionStats - do - runQuery_ $ mkSQL "CREATE TABLE some_table (field INT)" - runQuery_ $ mkSQL "BEGIN" - runQuery_ $ mkSQL "INSERT INTO some_table VALUES (1)" - withNewConnection $ do - connectionStats <- getConnectionStats - liftIO $ assertEqual "Connection stats should be reset" (ConnectionStats 1 1 1 0) connectionStats - noOfResults <- runQuery $ mkSQL "SELECT * FROM some_table" - liftIO $ assertEqual "Results should not be visible yet" 0 noOfResults - runQuery_ $ mkSQL "COMMIT" - noOfResults <- runQuery $ mkSQL "SELECT * FROM some_table" - liftIO $ assertEqual "Results should be visible" 1 noOfResults - runQuery_ $ mkSQL "DROP TABLE some_table" + 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 ---------------------------------------- -- Helpers