Adds inWithTransaction helper to get transaction status

I added a function that will return `True` when called within the action passed to `withTransaction`.
flipstone · Nov 19, 2024 · 27008f3 · 27008f3
1 parent e0ef4af
commit 27008f3
Show file tree

Hide file tree

Showing 3 changed files with 33 additions and 0 deletions.
diff --git a/orville-postgresql/src/Orville/PostgreSQL.hs b/orville-postgresql/src/Orville/PostgreSQL.hs
@@ -70,6 +70,7 @@ module Orville.PostgreSQL
 
     -- * Opening transactions and savepoints
   , Transaction.withTransaction
+  , Transaction.inWithTransaction
 
     -- * Types for incorporating Orville into other Monads
   , MonadOrville.MonadOrville

diff --git a/orville-postgresql/src/Orville/PostgreSQL/Execution/Transaction.hs b/orville-postgresql/src/Orville/PostgreSQL/Execution/Transaction.hs
@@ -10,6 +10,7 @@ to ensure some Haskell action occurs within a database transaction.
 -}
 module Orville.PostgreSQL.Execution.Transaction
   ( withTransaction
+  , inWithTransaction
   )
 where
 
@@ -125,3 +126,21 @@ savepointName savepoint =
     n = OrvilleState.savepointNestingLevel savepoint
   in
     Expr.savepointName ("orville_savepoint_level_" <> show n)
+
+{- |
+  Returns 'True' when called inside of the action passed to 'Orville.PostgreSQL.withTransaction',
+  and 'False' otherwise.
+
+@since 1.1.0.0
+-}
+inWithTransaction :: MonadOrville.MonadOrville m => m Bool
+inWithTransaction =
+  fmap
+    ( \state -> case OrvilleState.orvilleConnectionState state of
+        OrvilleState.Connected connectedState -> case OrvilleState.connectedTransaction connectedState of
+          Just _ -> True
+          Nothing -> False
+        OrvilleState.NotConnected ->
+          False
+    )
+    Monad.askOrvilleState
diff --git a/orville-postgresql/test/Test/Transaction.hs b/orville-postgresql/test/Test/Transaction.hs
@@ -30,6 +30,7 @@ transactionTests pool =
     , prop_callbacksMadeForTransactionCommit pool
     , prop_callbacksMadeForTransactionRollback pool
     , prop_usesCustomBeginTransactionSql pool
+    , prop_inWithTransaction pool
     ]
 
 prop_transactionsWithoutExceptionsCommit :: Property.NamedDBProperty
@@ -162,6 +163,18 @@ prop_usesCustomBeginTransactionSql =
           , (Orville.OtherQuery, RawSql.toExampleBytes customExpr)
           ]
 
+prop_inWithTransaction :: Property.NamedDBProperty
+prop_inWithTransaction =
+  Property.singletonNamedDBProperty "inWithTransaction returns true inside of withTransaction" $ \pool -> do
+    (inside, outsideBefore, outsideAfter) <- HH.evalIO . Orville.runOrville pool $ do
+      outsideBefore <- Orville.inWithTransaction
+      inside <- Orville.withTransaction Orville.inWithTransaction
+      outsideAfter <- Orville.inWithTransaction
+      pure (inside, outsideBefore, outsideAfter)
+    inside === True
+    outsideBefore === False
+    outsideAfter === False
+
 captureTransactionCallbackEvents ::
   Orville.ConnectionPool ->
   Orville.Orville () ->