Bracket.hs

{- |
Copyright : Flipstone Technology Partners 2023-2025
License   : MIT
Stability : Stable

@since 1.0.0.0
-}
module Orville.PostgreSQL.Internal.Bracket
  ( bracketWithResult
  , BracketResult (BracketSuccess, BracketError)
  ) where

import Control.Exception (SomeException, catch, mask, throwIO)
import Control.Monad (void)
import Control.Monad.IO.Class (MonadIO (liftIO))

import Orville.PostgreSQL.Monad.MonadOrville (MonadOrvilleControl (liftCatch, liftMask))

{- | Track the result of a bracket

@since 1.0.0.0
-}
data BracketResult a
  = BracketSuccess a
  | BracketError

{- | INTERNAL: A version of 'Control.Exception.bracket' that allows us to distinguish between
  exception and non-exception release cases. This is available in certain
  packages as a typeclass function under the name "generalBracket", but is
  implemented here directly in terms of IO's 'mask' and 'catch' to guarantee
  our exception handling semantics without forcing the Orville user's choice of
  library for lifting and unlift IO actions (e.g. UnliftIO).

@since 1.0.0.0
-}
bracketWithResult ::
  (MonadIO m, MonadOrvilleControl m) =>
  m a ->
  (a -> BracketResult b -> m c) ->
  (a -> m b) ->
  m b
bracketWithResult acquire release action = do
  liftMask mask $ \restore -> do
    resource <- acquire
    result <-
      liftCatch
        catch
        (restore (action resource))
        (handleAndRethrow (release resource BracketError))

    _ <- release resource (BracketSuccess result)

    pure result

{- | INTERNAL: Catch any exception, run the given handler, and rethrow the
  exception. This is mostly useful to force the exception being caught to be of
  the type 'SomeException'.

@since 1.0.0.0
-}
handleAndRethrow ::
  (MonadIO m, MonadOrvilleControl m) =>
  m a ->
  SomeException ->
  m b
handleAndRethrow handle ex = do
  liftCatch catch (void handle) (\e -> case e :: SomeException of _ -> pure ())
  liftIO . throwIO $ ex