Introduce on-demand connection acquisition mode

Author: arybczak

.github/workflows/haskell-ci.yml

@@ -8,9 +8,9 @@
 #
 # For more information, see https://github.com/haskell-CI/haskell-ci
 #
-# version: 0.19.20250216
+# version: 0.19.20250821
 #
-# REGENDATA ("0.19.20250216",["github","--config=cabal.haskell-ci","cabal.project"])
+# REGENDATA ("0.19.20250821",["github","--config=cabal.haskell-ci","cabal.project"])
 #
 name: Haskell-CI
 on:
@@ -38,24 +38,29 @@ jobs:
     strategy:
       matrix:
         include:
-          - compiler: ghc-9.12.1
+          - compiler: ghc-9.14.0.20250819
             compilerKind: ghc
-            compilerVersion: 9.12.1
+            compilerVersion: 9.14.0.20250819
+            setup-method: ghcup-prerelease
+            allow-failure: false
+          - compiler: ghc-9.12.2
+            compilerKind: ghc
+            compilerVersion: 9.12.2
             setup-method: ghcup
             allow-failure: false
-          - compiler: ghc-9.10.1
+          - compiler: ghc-9.10.2
             compilerKind: ghc
-            compilerVersion: 9.10.1
+            compilerVersion: 9.10.2
             setup-method: ghcup
             allow-failure: false
           - compiler: ghc-9.8.4
             compilerKind: ghc
             compilerVersion: 9.8.4
             setup-method: ghcup
             allow-failure: false
-          - compiler: ghc-9.6.6
+          - compiler: ghc-9.6.7
             compilerKind: ghc
-            compilerVersion: 9.6.6
+            compilerVersion: 9.6.7
             setup-method: ghcup
             allow-failure: false
           - compiler: ghc-9.4.8
@@ -87,12 +92,12 @@ jobs:
       - name: Install GHCup
         run: |
           mkdir -p "$HOME/.ghcup/bin"
-          curl -sL https://downloads.haskell.org/ghcup/0.1.30.0/x86_64-linux-ghcup-0.1.30.0 > "$HOME/.ghcup/bin/ghcup"
+          curl -sL https://downloads.haskell.org/ghcup/0.1.50.1/x86_64-linux-ghcup-0.1.50.1 > "$HOME/.ghcup/bin/ghcup"
           chmod a+x "$HOME/.ghcup/bin/ghcup"
       - name: Install cabal-install
         run: |
-          "$HOME/.ghcup/bin/ghcup" install cabal 3.12.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false)
-          echo "CABAL=$HOME/.ghcup/bin/cabal-3.12.1.0 -vnormal+nowrap" >> "$GITHUB_ENV"
+          "$HOME/.ghcup/bin/ghcup" install cabal 3.16.0.0 || (cat "$HOME"/.ghcup/logs/*.* && false)
+          echo "CABAL=$HOME/.ghcup/bin/cabal-3.16.0.0 -vnormal+nowrap" >> "$GITHUB_ENV"
       - name: Install GHC (GHCup)
         if: matrix.setup-method == 'ghcup'
         run: |
@@ -107,6 +112,21 @@ jobs:
           HCKIND: ${{ matrix.compilerKind }}
           HCNAME: ${{ matrix.compiler }}
           HCVER: ${{ matrix.compilerVersion }}
+      - name: Install GHC (GHCup prerelease)
+        if: matrix.setup-method == 'ghcup-prerelease'
+        run: |
+          "$HOME/.ghcup/bin/ghcup" config add-release-channel prereleases
+          "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false)
+          HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER")
+          HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#')
+          HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#')
+          echo "HC=$HC" >> "$GITHUB_ENV"
+          echo "HCPKG=$HCPKG" >> "$GITHUB_ENV"
+          echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV"
+        env:
+          HCKIND: ${{ matrix.compilerKind }}
+          HCNAME: ${{ matrix.compiler }}
+          HCVER: ${{ matrix.compilerVersion }}
       - name: Set PATH and environment variables
         run: |
           echo "$HOME/.cabal/bin" >> $GITHUB_PATH
@@ -117,7 +137,7 @@ jobs:
           echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV"
           echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV"
           echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV"
-          echo "HEADHACKAGE=false" >> "$GITHUB_ENV"
+          if [ $((HCNUMVER >= 91400)) -ne 0 ] ; then echo "HEADHACKAGE=true" >> "$GITHUB_ENV" ; else echo "HEADHACKAGE=false" >> "$GITHUB_ENV" ; fi
           echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV"
         env:
           HCKIND: ${{ matrix.compilerKind }}
@@ -145,6 +165,18 @@ jobs:
           repository hackage.haskell.org
             url: http://hackage.haskell.org/
           EOF
+          if $HEADHACKAGE; then
+          cat >> $CABAL_CONFIG <<EOF
+          repository head.hackage.ghc.haskell.org
+             url: https://ghc.gitlab.haskell.org/head.hackage/
+             secure: True
+             root-keys: 7541f32a4ccca4f97aea3b22f5e593ba2c0267546016b992dfadcd2fe944e55d
+                        26021a13b401500c8eb2761ca95c61f2d625bfef951b939a8124ed12ecf07329
+                        f76d08be13e9a61a377a85e2fb63f4c5435d40f8feb3e12eb05905edb8cdea89
+             key-threshold: 3
+          active-repositories: hackage.haskell.org, head.hackage.ghc.haskell.org:override
+          EOF
+          fi
           cat >> $CABAL_CONFIG <<EOF
           program-default-options
             ghc-options: $GHCJOBS +RTS -M3G -RTS
@@ -193,12 +225,19 @@ jobs:
           touch cabal.project.local
           echo "packages: ${PKGDIR_hpqtypes}" >> cabal.project
           echo "package hpqtypes" >> cabal.project
-          echo "    ghc-options: -Werror=missing-methods" >> cabal.project
+          echo "    ghc-options: -Werror=missing-methods -Werror=missing-fields" >> cabal.project
+          if [ $((HCNUMVER >= 90400)) -ne 0 ] ; then echo "package hpqtypes" >> cabal.project ; fi
+          if [ $((HCNUMVER >= 90400)) -ne 0 ] ; then echo "    ghc-options: -Werror=unused-packages" >> cabal.project ; fi
+          if [ $((HCNUMVER >= 90000)) -ne 0 ] ; then echo "package hpqtypes" >> cabal.project ; fi
+          if [ $((HCNUMVER >= 90000)) -ne 0 ] ; then echo "    ghc-options: -Werror=incomplete-patterns -Werror=incomplete-uni-patterns" >> cabal.project ; fi
           cat >> cabal.project <<EOF
           allow-newer: *:base
           allow-newer: *:ghc-prim
           allow-newer: *:template-haskell
           EOF
+          if $HEADHACKAGE; then
+          echo "allow-newer: $($HCPKG list --simple-output | sed -E 's/([a-zA-Z-]+)-[0-9.]+/*:\1,/g')" >> cabal.project
+          fi
           $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: any.$_ installed\n" unless /^(hpqtypes)$/; }' >> cabal.project.local
           cat cabal.project
           cat cabal.project.local

hpqtypes.cabal

@@ -21,7 +21,7 @@ author:              Scrive AB
 maintainer:          Andrzej Rybczak <[email protected]>
 copyright:           Scrive AB
 category:            Database
-tested-with:         GHC == { 8.10.7, 9.0.2, 9.2.8, 9.4.8, 9.6.6, 9.8.4, 9.10.1, 9.12.1 }
+tested-with:         GHC == { 8.10.7, 9.0.2, 9.2.8, 9.4.8, 9.6.7, 9.8.4, 9.10.2, 9.12.2, 9.14.1 }
 
 extra-source-files: README.md
                   , CHANGELOG.md
@@ -171,6 +171,9 @@ library
   other-extensions:   AllowAmbiguousTypes
                     , CPP
 
+  if impl(ghc >= 9)
+     default-extensions: DeepSubsumption
+
 test-suite hpqtypes-tests
   type:              exitcode-stdio-1.0
   ghc-options:       -Wall -Wprepositive-qualified-module -threaded

src/Database/PostgreSQL/PQTypes/Class.hs

@@ -30,32 +30,34 @@ class (Applicative m, Monad m) => MonadDB m where
   -- given name.
   runPreparedQuery :: (HasCallStack, IsSQL sql) => QueryName -> sql -> m Int
 
-  -- | Get last SQL query that was executed.
-  getLastQuery :: m SomeSQL
+  -- | Get last SQL query that was executed and ID of the server process
+  -- attached to the session that executed it.
+  getLastQuery :: m (BackendPid, SomeSQL)
 
   -- | Subsequent queries in the callback do not alter the result of
   -- 'getLastQuery'.
   withFrozenLastQuery :: m a -> m a
 
-  -- | Get ID of the server process attached to the current session.
-  getBackendPid :: m BackendPid
-
   -- | Get current connection statistics.
-  getConnectionStats :: HasCallStack => m ConnectionStats
+  getConnectionStats :: m ConnectionStats
 
   -- | Get current query result.
   getQueryResult :: FromRow row => m (Maybe (QueryResult row))
 
   -- | Clear current query result.
   clearQueryResult :: m ()
 
-  -- | Get current transaction settings.
-  getTransactionSettings :: m TransactionSettings
+  -- | Get current connection acquisition mode.
+  getConnectionAcquisitionMode :: HasCallStack => m ConnectionAcquisitionMode
+
+  -- | Acquire and hold a connection with a given isolation level and
+  -- permissions. If the connection is already held, nothing happens.
+  acquireAndHoldConnection :: HasCallStack => IsolationLevel -> Permissions -> m ()
 
-  -- | Set transaction settings to supplied ones. Note that it
-  -- won't change any properties of currently running transaction,
-  -- only the subsequent ones.
-  setTransactionSettings :: TransactionSettings -> m ()
+  -- | Unsafely switch to the 'AcquireOnDemand' mode. This function is unsafe
+  -- because if a connection is already held, the transaction in progress is
+  -- commited, so atomicity guarantee is lost.
+  unsafeAcquireOnDemandConnection :: HasCallStack => m ()
 
   -- | Attempt to receive a notification from the server. This
   -- function waits until a notification arrives or specified
@@ -72,15 +74,15 @@ class (Applicative m, Monad m) => MonadDB m where
   -- for further info), therefore calling this function within
   -- a transaction block will return 'Just' only if notifications
   -- were received before the transaction began.
-  getNotification :: Int -> m (Maybe Notification)
+  getNotification :: HasCallStack => Int -> m (Maybe Notification)
 
   -- | Execute supplied monadic action with new connection
   -- using current connection source and transaction settings.
   --
   -- Particularly useful when you want to spawn a new thread, but
   -- do not want the connection in child thread to be shared with
   -- the parent one.
-  withNewConnection :: m a -> m a
+  withNewConnection :: HasCallStack => m a -> m a
 
 -- | Generic, overlappable instance.
 instance
@@ -97,11 +99,11 @@ instance
   runPreparedQuery name = withFrozenCallStack $ lift . runPreparedQuery name
   getLastQuery = lift getLastQuery
   withFrozenLastQuery m = controlT $ \run -> withFrozenLastQuery (run m)
-  getBackendPid = lift getBackendPid
-  getConnectionStats = withFrozenCallStack $ lift getConnectionStats
+  getConnectionStats = lift getConnectionStats
   getQueryResult = lift getQueryResult
   clearQueryResult = lift clearQueryResult
-  getTransactionSettings = lift getTransactionSettings
-  setTransactionSettings = lift . setTransactionSettings
+  getConnectionAcquisitionMode = lift getConnectionAcquisitionMode
+  acquireAndHoldConnection isoLevel = lift . acquireAndHoldConnection isoLevel
+  unsafeAcquireOnDemandConnection = lift unsafeAcquireOnDemandConnection
   getNotification = lift . getNotification
   withNewConnection m = controlT $ \run -> withNewConnection (run m)

src/Database/PostgreSQL/PQTypes/Internal/BackendPid.hs

@@ -1,7 +1,11 @@
 module Database.PostgreSQL.PQTypes.Internal.BackendPid
   ( BackendPid (..)
+  , noBackendPid
   ) where
 
 -- | Process ID of the server process attached to the current session.
 newtype BackendPid = BackendPid Int
   deriving newtype (Eq, Ord, Show)
+
+noBackendPid :: BackendPid
+noBackendPid = BackendPid 0