hpqtypes-effectful 1.0.2.0 → 1.1.0.0

raw patch · 6 files changed

+135/−220 lines, 6 filesdep −exceptionsdep ~basedep ~effectful-coredep ~hpqtypesPVP ok

version bump matches the API change (PVP)

Dependencies removed: exceptions

Dependency ranges changed: base, effectful-core, hpqtypes

API changes (from Hackage documentation)

Files

• CHANGELOG.md +3/−0
• README.md +1/−2
• examples/OuterJoins.hs +2/−2
• hpqtypes-effectful.cabal +8/−9
• src/Effectful/HPQTypes.hs +85/−167
• test/Main.hs +36/−40

@@ -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. 

@@ -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) 

@@ -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'.

@@ -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

@@ -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

@@ -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