Adds inWithTransaction helper to get transaction status

I added a function that will return a new type called
`InWithTransaction` when called within the action passed to
`withTransaction`. The value indicates whether the transaction is the
outermost, or is within a savepoint.

orville-postgresql/src/Orville/PostgreSQL.hs

@@ -70,6 +70,8 @@ module Orville.PostgreSQL
 
     -- * Opening transactions and savepoints
   , Transaction.withTransaction
+  , Transaction.inWithTransaction
+  , Transaction.InWithTransaction (InOutermostTransaction, InSavepointTransaction)
 
     -- * Types for incorporating Orville into other Monads
   , MonadOrville.MonadOrville

orville-postgresql/src/Orville/PostgreSQL/Execution/Transaction.hs

@@ -10,10 +10,13 @@ to ensure some Haskell action occurs within a database transaction.
 -}
 module Orville.PostgreSQL.Execution.Transaction
   ( withTransaction
+  , inWithTransaction
+  , InWithTransaction (InOutermostTransaction, InSavepointTransaction)
   )
 where
 
 import Control.Monad.IO.Class (MonadIO, liftIO)
+import Numeric.Natural (Natural)
 
 import qualified Orville.PostgreSQL.Execution.Execute as Execute
 import qualified Orville.PostgreSQL.Execution.QueryType as QueryType
@@ -125,3 +128,45 @@ savepointName savepoint =
     n = OrvilleState.savepointNestingLevel savepoint
   in
     Expr.savepointName ("orville_savepoint_level_" <> show n)
+
+{- |
+  Information about the current transaction state of an action passed to 'withTransaction'.
+
+@since 1.1.0.0
+-}
+data InWithTransaction
+  = InOutermostTransaction
+  | -- | The 'Natural' indicates the savepoint depth, where @1@ is the first savepoint.
+    InSavepointTransaction Natural
+  deriving
+    ( -- | @since 1.1.0.0
+      Eq
+    , -- | @since 1.1.0.0
+      Ord
+    , -- | @since 1.1.0.0
+      Show
+    )
+
+{- |
+  Returns 'Just' an 'InWithTransaction' value when called inside of the action passed to
+  'withTransaction', and 'Nothing' otherwise.
+
+@since 1.1.0.0
+-}
+inWithTransaction :: MonadOrville.MonadOrville m => m (Maybe InWithTransaction)
+inWithTransaction =
+  fmap
+    ( \state -> case OrvilleState.orvilleConnectionState state of
+        OrvilleState.Connected connectedState ->
+          fmap
+            ( \transactionState -> case transactionState of
+                OrvilleState.OutermostTransaction ->
+                  InOutermostTransaction
+                OrvilleState.SavepointTransaction i ->
+                  InSavepointTransaction . fromIntegral $ OrvilleState.savepointNestingLevel i
+            )
+            (OrvilleState.connectedTransaction connectedState)
+        OrvilleState.NotConnected ->
+          Nothing
+    )
+    Monad.askOrvilleState

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,20 @@ prop_usesCustomBeginTransactionSql =
           , (Orville.OtherQuery, RawSql.toExampleBytes customExpr)
           ]
 
+prop_inWithTransaction :: Property.NamedDBProperty
+prop_inWithTransaction =
+  Property.singletonNamedDBProperty "inWithTransaction returns InWithTransaction inside of withTransaction" $ \pool -> do
+    (inside, insideSavepoint, outsideBefore, outsideAfter) <- HH.evalIO . Orville.runOrville pool $ do
+      outsideBefore <- Orville.inWithTransaction
+      inside <- Orville.withTransaction Orville.inWithTransaction
+      insideSavepoint <- Orville.withTransaction $ Orville.withTransaction Orville.inWithTransaction
+      outsideAfter <- Orville.inWithTransaction
+      pure (inside, insideSavepoint, outsideBefore, outsideAfter)
+    inside === Just Orville.InOutermostTransaction
+    insideSavepoint === Just (Orville.InSavepointTransaction 1)
+    outsideBefore === Nothing
+    outsideAfter === Nothing
+
 captureTransactionCallbackEvents ::
   Orville.ConnectionPool ->
   Orville.Orville () ->