{-# LANGUAGE CPP #-}

-- | Registry of monadic actions supporting rollback actions and delayed actions
-- in the presence of (a-)synchronous exceptions.
--
-- This module is heavily inspired by:
--
-- * [resource-registry](https://github.com/IntersectMBO/io-classes-extra/blob/main/resource-registry/src/Control/ResourceRegistry.hs)
--
-- * [resourcet](https://hackage.haskell.org/package/resourcet)
module Control.ActionRegistry (
    -- * Modify mutable state #modifyMutableState#
    -- $modify-mutable-state
    modifyWithActionRegistry
  , modifyWithActionRegistry_
    -- * Action registry  #actionRegistry#
    -- $action-registry
  , ActionRegistry
  , ActionError
  , getActionError
  , mapActionError
    -- * Runners
  , withActionRegistry
  , unsafeNewActionRegistry
  , unsafeFinaliseActionRegistry
  , CommitActionRegistryError (..)
  , AbortActionRegistryError (..)
  , AbortActionRegistryReason (..)
  , getReasonExitCaseException
    -- * Registering actions #registeringActions#
    -- $registering-actions
  , withRollback
  , withRollback_
  , withRollbackMaybe
  , withRollbackEither
  , withRollbackFun
  , delayedCommit
  ) where

import           Control.Monad.Class.MonadThrow
import           Control.Monad.Primitive
import           Data.Kind
import           Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import           Data.Primitive.MutVar

#ifdef NO_IGNORE_ASSERTS
import           GHC.Stack
#endif

-- TODO: add tests using fs-sim/io-sim to make sure exception safety is
-- guaranteed.

-- TODO: add assertions that allocated resources end up in the final state, and
-- that temporarily freed resources are removed from the final state.

-- TODO: could we statically disallow using a resource after it is freed using
-- @delayedCommit@, for example through data abstraction?

-- Call stack instrumentation is enabled if assertions are enabled.
#ifdef NO_IGNORE_ASSERTS
#define HasCallStackIfDebug HasCallStack
#else
#define HasCallStackIfDebug ()
#endif

{-------------------------------------------------------------------------------
  Printing utilities
-------------------------------------------------------------------------------}

tabLines1 :: String -> String
tabLines1 :: String -> String
tabLines1 = Int -> String -> String
tabLinesN Int
1

#ifdef NO_IGNORE_ASSERTS
tabLines2 :: String -> String
tabLines2 = tabLinesN 2
#endif

tabLinesN :: Int -> String -> String
tabLinesN :: Int -> String -> String
tabLinesN Int
n = [String] -> String
unlines ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String
ts++) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
  where
    ts :: String
ts = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ Int -> String -> [String]
forall a. Int -> a -> [a]
replicate Int
n String
"  "

{-------------------------------------------------------------------------------
  Modify mutable state
-------------------------------------------------------------------------------}

{- $modify-mutable-state

  When a piece of mutable state holding system resources is updated, then it is
  important to guarantee in the presence of (a-)synchronous exceptions that:

  1. Allocated resources end up in the state
  2. Freed resources are removed from the state

  Consider the example program below. We have some mutable @State@ that holds a
  file handle/descriptor. We want to mutate this state by closing the current
  handle, and replacing it by a newly opened handle. Using the tools at our
  disposal in "Control.ActionRegistry", we guarantee (1) and (2).

  @
    type State = MVar Handle

    example :: State -> IO ()
    example st =
      'modifyWithActionRegistry_'
        (takeMVar st)
        (putMVar st)
        $ \\reg h -> do
          h' <- 'withRollback' reg
                  (openFile  "file.txt" ReadWriteMode)
                  hClose
          'delayedCommit' reg (hClose h)
          pure h'
  @

  What is also nice about this examples is that it is atomic: other threads will
  not be able to see the updated @State@ until 'modifyWithActionRegistry_' has
  exited and the necessary side effects have been performed. Of course, another
  thread *could* observe that the @file.txt@ was created before
  'modifyWithActionRegistry_' has exited, but the assumption is that the threads
  in our program are cooperative. It is up to the user to ensure that actions
  that are performed as part of the state update do not conflict with other
  actions.
-}

{-# SPECIALISE modifyWithActionRegistry ::
     IO st
  -> (st -> IO ())
  -> (ActionRegistry IO -> st -> IO (st, a))
  -> IO a
  #-}
-- | Modify a piece piece of state given a fresh action registry.
modifyWithActionRegistry ::
     (PrimMonad m, MonadCatch m)
  => m st -- ^ Get the state
  -> (st -> m ()) -- ^ Store a state
  -> (ActionRegistry m -> st -> m (st, a)) -- ^ Modify the state
  -> m a
modifyWithActionRegistry :: forall (m :: * -> *) st a.
(PrimMonad m, MonadCatch m) =>
m st
-> (st -> m ()) -> (ActionRegistry m -> st -> m (st, a)) -> m a
modifyWithActionRegistry m st
getSt st -> m ()
putSt ActionRegistry m -> st -> m (st, a)
action =
    (st, a) -> a
forall a b. (a, b) -> b
snd ((st, a) -> a) -> (((st, a), ()) -> (st, a)) -> ((st, a), ()) -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((st, a), ()) -> (st, a)
forall a b. (a, b) -> a
fst (((st, a), ()) -> a) -> m ((st, a), ()) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (ActionRegistry m, st)
-> ((ActionRegistry m, st) -> ExitCase (st, a) -> m ())
-> ((ActionRegistry m, st) -> m (st, a))
-> m ((st, a), ())
forall a b c.
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
forall (m :: * -> *) a b c.
MonadCatch m =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
generalBracket m (ActionRegistry m, st)
acquire (ActionRegistry m, st) -> ExitCase (st, a) -> m ()
release ((ActionRegistry m -> st -> m (st, a))
-> (ActionRegistry m, st) -> m (st, a)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ActionRegistry m -> st -> m (st, a)
action)
  where
    acquire :: m (ActionRegistry m, st)
acquire = (,) (ActionRegistry m -> st -> (ActionRegistry m, st))
-> m (ActionRegistry m) -> m (st -> (ActionRegistry m, st))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (ActionRegistry m)
forall (m :: * -> *). PrimMonad m => m (ActionRegistry m)
unsafeNewActionRegistry m (st -> (ActionRegistry m, st))
-> m st -> m (ActionRegistry m, st)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m st
getSt
    release :: (ActionRegistry m, st) -> ExitCase (st, a) -> m ()
release (ActionRegistry m
reg, st
oldSt) ExitCase (st, a)
ec = do
        case ExitCase (st, a)
ec of
          ExitCaseSuccess (st
newSt, a
_) -> st -> m ()
putSt st
newSt
          ExitCaseException SomeException
_        -> st -> m ()
putSt st
oldSt
          ExitCase (st, a)
ExitCaseAbort              -> st -> m ()
putSt st
oldSt
        ActionRegistry m -> ExitCase (st, a) -> m ()
forall (m :: * -> *) a.
(PrimMonad m, MonadCatch m) =>
ActionRegistry m -> ExitCase a -> m ()
unsafeFinaliseActionRegistry ActionRegistry m
reg ExitCase (st, a)
ec

{-# SPECIALISE modifyWithActionRegistry_ ::
     IO st
  -> (st -> IO ())
  -> (ActionRegistry IO -> st -> IO st)
  -> IO ()
  #-}
-- | Like 'modifyWithActionRegistry', but without a return value.
modifyWithActionRegistry_ ::
     (PrimMonad m, MonadCatch m)
  => m st -- ^ Get the state
  -> (st -> m ()) -- ^ Store a state
  -> (ActionRegistry m -> st -> m st)
  -> m ()
modifyWithActionRegistry_ :: forall (m :: * -> *) st.
(PrimMonad m, MonadCatch m) =>
m st -> (st -> m ()) -> (ActionRegistry m -> st -> m st) -> m ()
modifyWithActionRegistry_ m st
getSt st -> m ()
putSt ActionRegistry m -> st -> m st
action =
    m st
-> (st -> m ()) -> (ActionRegistry m -> st -> m (st, ())) -> m ()
forall (m :: * -> *) st a.
(PrimMonad m, MonadCatch m) =>
m st
-> (st -> m ()) -> (ActionRegistry m -> st -> m (st, a)) -> m a
modifyWithActionRegistry m st
getSt st -> m ()
putSt (\ActionRegistry m
reg st
content -> (,()) (st -> (st, ())) -> m st -> m (st, ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ActionRegistry m -> st -> m st
action ActionRegistry m
reg st
content)

{-------------------------------------------------------------------------------
  Action registry
-------------------------------------------------------------------------------}

{- $action-registry

  An 'ActionRegistry' is a registry of monadic actions to support working with
  resources and mutable state in the presence of (a)synchronous exceptions. It
  works analogously to database transactions: within the \"transaction\" scope
  we can perform actions (such as resource allocations and state changes) and we
  can register delayed (commit) and rollback actions. The delayed actions are
  all executed at the end if the transaction scope is exited successfully, but
  if an exception is thrown (sync or async) then the rollback actions are
  executed instead, and the exception is propagated.

  * Rollback actions are executed in the reverse order in which they were
  registered, which is the natural nesting order when considered as bracketing.

  * Delayed actions are executed in the same order in which they are registered.
-}

-- | Registry of monadic actions supporting rollback actions and delayed actions
-- in the presence of (a-)synchronous exceptions.
--
-- See [Action registry](#g:actionRegistry) for more information.
--
-- An action registry should be short-lived, and it is not thread-safe.
data ActionRegistry m = ActionRegistry {
      -- | Registered rollback actions. Use 'consAction' when modifying this
      -- variable.
      --
      -- INVARIANT: actions are stored in LIFO order.
      --
      -- INVARIANT: the contents of this variable are in NF.
      forall (m :: * -> *).
ActionRegistry m -> MutVar (PrimState m) [Action m]
registryRollback :: !(MutVar (PrimState m) [Action m])

      -- | Registered, delayed actions. Use 'consAction' when modifying this
      -- variable.
      --
      -- INVARIANT: actions are stored in LIFO order.
      --
      -- INVARIANT: the contents of this variable are in NF.
    , forall (m :: * -> *).
ActionRegistry m -> MutVar (PrimState m) [Action m]
registryDelay    :: !(MutVar (PrimState m) [Action m])
    }

{-# SPECIALISE consAction :: Action IO -> MutVar RealWorld [Action IO] -> IO () #-}
-- | Cons an action onto the contents of an actions variable.
--
-- Both the action and the resulting variable contents are evaluated to WHNF. If
-- the contents of the variable were already in NF, then the result will also be
-- in NF.
consAction :: PrimMonad m => Action m -> MutVar (PrimState m) [Action m] -> m ()
consAction :: forall (m :: * -> *).
PrimMonad m =>
Action m -> MutVar (PrimState m) [Action m] -> m ()
consAction !Action m
a MutVar (PrimState m) [Action m]
var = MutVar (PrimState m) [Action m]
-> ([Action m] -> [Action m]) -> m ()
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> (a -> a) -> m ()
modifyMutVar' MutVar (PrimState m) [Action m]
var (([Action m] -> [Action m]) -> m ())
-> ([Action m] -> [Action m]) -> m ()
forall a b. (a -> b) -> a -> b
$ \[Action m]
as -> Action m
a Action m -> [Action m] -> [Action m]
forall {a}. a -> [a] -> [a]
`consStrict` [Action m]
as
  where consStrict :: a -> [a] -> [a]
consStrict !a
x [a]
xs = a
x a -> [a] -> [a]
forall {a}. a -> [a] -> [a]
: [a]
xs

-- | Monadic computations that (may) produce side effects
type Action :: (Type -> Type) -> Type

-- | An action failed with an exception
type ActionError :: Type

mkAction :: HasCallStackIfDebug => m () -> Action m
mkActionError :: SomeException -> Action m -> ActionError
getActionError :: ActionError -> SomeException
mapActionError :: (SomeException -> SomeException) -> ActionError -> ActionError

#ifdef NO_IGNORE_ASSERTS
data Action m = Action {
    runAction       :: !(m ())
  , actionCallStack :: !CallStack
  }

data ActionError = ActionError SomeException CallStack
  deriving stock Show

instance Exception ActionError where
  displayException (ActionError err registerSite) = unlines [
      "A registered action threw an error: "
    , tabLines1 "The error:"
    , tabLines2 (displayException err)
    , tabLines1 "Registration site:"
    , tabLines2 (prettyCallStack registerSite)
    ]

mkAction a = Action a callStack

mkActionError e a = ActionError e (actionCallStack a)

getActionError (ActionError e _) = e

mapActionError f (ActionError e s) = ActionError (f e) s
#else
newtype Action m = Action {
    forall (m :: * -> *). Action m -> m ()
runAction :: m ()
  }

newtype ActionError = ActionError SomeException
  deriving stock Int -> ActionError -> String -> String
[ActionError] -> String -> String
ActionError -> String
(Int -> ActionError -> String -> String)
-> (ActionError -> String)
-> ([ActionError] -> String -> String)
-> Show ActionError
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ActionError -> String -> String
showsPrec :: Int -> ActionError -> String -> String
$cshow :: ActionError -> String
show :: ActionError -> String
$cshowList :: [ActionError] -> String -> String
showList :: [ActionError] -> String -> String
Show
  deriving anyclass Show ActionError
Typeable ActionError
(Typeable ActionError, Show ActionError) =>
(ActionError -> SomeException)
-> (SomeException -> Maybe ActionError)
-> (ActionError -> String)
-> Exception ActionError
SomeException -> Maybe ActionError
ActionError -> String
ActionError -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: ActionError -> SomeException
toException :: ActionError -> SomeException
$cfromException :: SomeException -> Maybe ActionError
fromException :: SomeException -> Maybe ActionError
$cdisplayException :: ActionError -> String
displayException :: ActionError -> String
Exception

mkAction :: forall (m :: * -> *). m () -> Action m
mkAction m ()
a = m () -> Action m
forall (m :: * -> *). m () -> Action m
Action m ()
a

mkActionError :: forall (m :: * -> *). SomeException -> Action m -> ActionError
mkActionError SomeException
e Action m
_ = SomeException -> ActionError
ActionError SomeException
e

getActionError :: ActionError -> SomeException
getActionError (ActionError SomeException
e) = SomeException
e

mapActionError :: (SomeException -> SomeException) -> ActionError -> ActionError
mapActionError SomeException -> SomeException
f (ActionError SomeException
e) = SomeException -> ActionError
ActionError (SomeException -> SomeException
f SomeException
e)
#endif

{-------------------------------------------------------------------------------
  Runners
-------------------------------------------------------------------------------}

{-# SPECIALISE withActionRegistry :: (ActionRegistry IO -> IO a) -> IO a #-}
-- | Run code with a new 'ActionRegistry'.
--
-- (A-)synchronous exception safety is only guaranteed within the scope of
-- 'withActionRegistry' (and only for properly registered actions). As soon as
-- we leave this scope, all bets are off. If, for example, a newly allocated
-- file handle escapes the scope, then that file handle can be leaked. If such
-- is the case, then it is highly likely that you should be using
-- 'modifyWithActionRegistry' instead.
--
-- If the code was interrupted due to an exception for example, then the
-- registry is aborted, which performs registered rollback actions. If the code
-- succesfully terminated, then the registry is committed, in which case
-- registered, delayed actions will be performed.
--
-- Registered actions are run in LIFO order, whether they be rollback actions or
-- delayed actions.
withActionRegistry ::
     (PrimMonad m, MonadCatch m)
  => (ActionRegistry m -> m a)
  -> m a
withActionRegistry :: forall (m :: * -> *) a.
(PrimMonad m, MonadCatch m) =>
(ActionRegistry m -> m a) -> m a
withActionRegistry ActionRegistry m -> m a
k = (a, ()) -> a
forall a b. (a, b) -> a
fst ((a, ()) -> a) -> m (a, ()) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (ActionRegistry m)
-> (ActionRegistry m -> ExitCase a -> m ())
-> (ActionRegistry m -> m a)
-> m (a, ())
forall a b c.
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
forall (m :: * -> *) a b c.
MonadCatch m =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
generalBracket m (ActionRegistry m)
acquire ActionRegistry m -> ExitCase a -> m ()
forall (m :: * -> *) a.
(PrimMonad m, MonadCatch m) =>
ActionRegistry m -> ExitCase a -> m ()
release ActionRegistry m -> m a
k
  where
    acquire :: m (ActionRegistry m)
acquire = m (ActionRegistry m)
forall (m :: * -> *). PrimMonad m => m (ActionRegistry m)
unsafeNewActionRegistry
    release :: ActionRegistry m -> ExitCase a -> m ()
release ActionRegistry m
reg ExitCase a
ec = ActionRegistry m -> ExitCase a -> m ()
forall (m :: * -> *) a.
(PrimMonad m, MonadCatch m) =>
ActionRegistry m -> ExitCase a -> m ()
unsafeFinaliseActionRegistry ActionRegistry m
reg ExitCase a
ec

{-# SPECIALISE unsafeNewActionRegistry :: IO (ActionRegistry IO) #-}
-- | This function is considered unsafe. Preferably, use 'withActionRegistry'
-- instead.
--
-- If this function is used directly, use 'generalBracket' to pair
-- 'unsafeNewActionRegistry' with an 'unsafeFinaliseActionRegistry'.
unsafeNewActionRegistry :: PrimMonad m => m (ActionRegistry m)
unsafeNewActionRegistry :: forall (m :: * -> *). PrimMonad m => m (ActionRegistry m)
unsafeNewActionRegistry = do
    MutVar (PrimState m) [Action m]
registryRollback <- [Action m] -> m (MutVar (PrimState m) [Action m])
forall (m :: * -> *) a.
PrimMonad m =>
a -> m (MutVar (PrimState m) a)
newMutVar ([Action m] -> m (MutVar (PrimState m) [Action m]))
-> [Action m] -> m (MutVar (PrimState m) [Action m])
forall a b. (a -> b) -> a -> b
$! []
    MutVar (PrimState m) [Action m]
registryDelay <- [Action m] -> m (MutVar (PrimState m) [Action m])
forall (m :: * -> *) a.
PrimMonad m =>
a -> m (MutVar (PrimState m) a)
newMutVar ([Action m] -> m (MutVar (PrimState m) [Action m]))
-> [Action m] -> m (MutVar (PrimState m) [Action m])
forall a b. (a -> b) -> a -> b
$! []
    ActionRegistry m -> m (ActionRegistry m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ActionRegistry m -> m (ActionRegistry m))
-> ActionRegistry m -> m (ActionRegistry m)
forall a b. (a -> b) -> a -> b
$! ActionRegistry {MutVar (PrimState m) [Action m]
registryRollback :: MutVar (PrimState m) [Action m]
registryDelay :: MutVar (PrimState m) [Action m]
registryRollback :: MutVar (PrimState m) [Action m]
registryDelay :: MutVar (PrimState m) [Action m]
..}

{-# SPECIALISE unsafeFinaliseActionRegistry :: ActionRegistry IO -> ExitCase a -> IO () #-}
-- | This function is considered unsafe. See 'unsafeNewActionRegistry'.
--
-- This commits the action registry on 'ExitCaseSuccess', and otherwise aborts
-- the action registry.
unsafeFinaliseActionRegistry ::
     (PrimMonad m, MonadCatch m)
  => ActionRegistry m
  -> ExitCase a
  -> m ()
unsafeFinaliseActionRegistry :: forall (m :: * -> *) a.
(PrimMonad m, MonadCatch m) =>
ActionRegistry m -> ExitCase a -> m ()
unsafeFinaliseActionRegistry ActionRegistry m
reg ExitCase a
ec = case ExitCase a
ec of
    ExitCaseSuccess{}   -> ActionRegistry m -> m ()
forall (m :: * -> *).
(PrimMonad m, MonadCatch m) =>
ActionRegistry m -> m ()
unsafeCommitActionRegistry ActionRegistry m
reg
    ExitCaseException SomeException
e -> ActionRegistry m -> AbortActionRegistryReason -> m ()
forall (m :: * -> *).
(PrimMonad m, MonadCatch m) =>
ActionRegistry m -> AbortActionRegistryReason -> m ()
unsafeAbortActionRegistry ActionRegistry m
reg (SomeException -> AbortActionRegistryReason
ReasonExitCaseException SomeException
e)
    ExitCase a
ExitCaseAbort       -> ActionRegistry m -> AbortActionRegistryReason -> m ()
forall (m :: * -> *).
(PrimMonad m, MonadCatch m) =>
ActionRegistry m -> AbortActionRegistryReason -> m ()
unsafeAbortActionRegistry ActionRegistry m
reg AbortActionRegistryReason
ReasonExitCaseAbort

{-# SPECIALISE unsafeCommitActionRegistry :: ActionRegistry IO -> IO () #-}
-- | Perform delayed actions, but not rollback actions.
unsafeCommitActionRegistry :: (PrimMonad m, MonadCatch m) => ActionRegistry m -> m ()
unsafeCommitActionRegistry :: forall (m :: * -> *).
(PrimMonad m, MonadCatch m) =>
ActionRegistry m -> m ()
unsafeCommitActionRegistry ActionRegistry m
reg = do
    [Action m]
as <- MutVar (PrimState m) [Action m] -> m [Action m]
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar (ActionRegistry m -> MutVar (PrimState m) [Action m]
forall (m :: * -> *).
ActionRegistry m -> MutVar (PrimState m) [Action m]
registryDelay ActionRegistry m
reg)
    -- Run actions in FIFO order
    [ActionError]
r <- [Action m] -> m [ActionError]
forall (m :: * -> *). MonadCatch m => [Action m] -> m [ActionError]
runActions ([Action m] -> [Action m]
forall a. [a] -> [a]
reverse [Action m]
as)
    case [ActionError] -> Maybe (NonEmpty ActionError)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [ActionError]
r of
      Maybe (NonEmpty ActionError)
Nothing         -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just NonEmpty ActionError
exceptions -> CommitActionRegistryError -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (NonEmpty ActionError -> CommitActionRegistryError
CommitActionRegistryError NonEmpty ActionError
exceptions)

data CommitActionRegistryError = CommitActionRegistryError (NonEmpty ActionError)
  deriving stock Int -> CommitActionRegistryError -> String -> String
[CommitActionRegistryError] -> String -> String
CommitActionRegistryError -> String
(Int -> CommitActionRegistryError -> String -> String)
-> (CommitActionRegistryError -> String)
-> ([CommitActionRegistryError] -> String -> String)
-> Show CommitActionRegistryError
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> CommitActionRegistryError -> String -> String
showsPrec :: Int -> CommitActionRegistryError -> String -> String
$cshow :: CommitActionRegistryError -> String
show :: CommitActionRegistryError -> String
$cshowList :: [CommitActionRegistryError] -> String -> String
showList :: [CommitActionRegistryError] -> String -> String
Show

instance Exception CommitActionRegistryError where
  displayException :: CommitActionRegistryError -> String
displayException (CommitActionRegistryError NonEmpty ActionError
es) = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [
        String
"Exceptions thrown while committing an action registry."
      ] [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> NonEmpty String -> [String]
forall a. NonEmpty a -> [a]
NE.toList ((ActionError -> String) -> NonEmpty ActionError -> NonEmpty String
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ActionError -> String
forall {e}. Exception e => e -> String
displayOne NonEmpty ActionError
es)
    where
      displayOne :: e -> String
displayOne e
e = String -> String
tabLines1 (e -> String
forall {e}. Exception e => e -> String
displayException e
e)

{-# SPECIALISE unsafeAbortActionRegistry ::
     ActionRegistry IO
  -> AbortActionRegistryReason
  -> IO () #-}
-- | Perform rollback actions, but not delayed actions
unsafeAbortActionRegistry ::
     (PrimMonad m, MonadCatch m)
  => ActionRegistry m
  -> AbortActionRegistryReason
  -> m ()
unsafeAbortActionRegistry :: forall (m :: * -> *).
(PrimMonad m, MonadCatch m) =>
ActionRegistry m -> AbortActionRegistryReason -> m ()
unsafeAbortActionRegistry ActionRegistry m
reg AbortActionRegistryReason
reason = do
    [Action m]
as <- MutVar (PrimState m) [Action m] -> m [Action m]
forall (m :: * -> *) a.
PrimMonad m =>
MutVar (PrimState m) a -> m a
readMutVar (ActionRegistry m -> MutVar (PrimState m) [Action m]
forall (m :: * -> *).
ActionRegistry m -> MutVar (PrimState m) [Action m]
registryRollback ActionRegistry m
reg)
    -- Run actions in LIFO order
    [ActionError]
r <- [Action m] -> m [ActionError]
forall (m :: * -> *). MonadCatch m => [Action m] -> m [ActionError]
runActions [Action m]
as
    case [ActionError] -> Maybe (NonEmpty ActionError)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [ActionError]
r of
      Maybe (NonEmpty ActionError)
Nothing         -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just NonEmpty ActionError
exceptions -> AbortActionRegistryError -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (AbortActionRegistryReason
-> NonEmpty ActionError -> AbortActionRegistryError
AbortActionRegistryError AbortActionRegistryReason
reason NonEmpty ActionError
exceptions)

-- | Reasons why an action registry was aborted.
data AbortActionRegistryReason =
    -- | The action registry was aborted because the code that it scoped over
    -- threw an exception (see 'ExitCaseException').
    ReasonExitCaseException SomeException
    -- | The action registry was aborted because the code that it scoped over
    -- aborted (see 'ExitCaseAbort').
  | ReasonExitCaseAbort
  deriving stock Int -> AbortActionRegistryReason -> String -> String
[AbortActionRegistryReason] -> String -> String
AbortActionRegistryReason -> String
(Int -> AbortActionRegistryReason -> String -> String)
-> (AbortActionRegistryReason -> String)
-> ([AbortActionRegistryReason] -> String -> String)
-> Show AbortActionRegistryReason
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> AbortActionRegistryReason -> String -> String
showsPrec :: Int -> AbortActionRegistryReason -> String -> String
$cshow :: AbortActionRegistryReason -> String
show :: AbortActionRegistryReason -> String
$cshowList :: [AbortActionRegistryReason] -> String -> String
showList :: [AbortActionRegistryReason] -> String -> String
Show

getReasonExitCaseException :: AbortActionRegistryReason -> Maybe SomeException
getReasonExitCaseException :: AbortActionRegistryReason -> Maybe SomeException
getReasonExitCaseException = \case
  ReasonExitCaseException SomeException
e -> SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
e
  AbortActionRegistryReason
ReasonExitCaseAbort -> Maybe SomeException
forall a. Maybe a
Nothing

data AbortActionRegistryError =
    AbortActionRegistryError AbortActionRegistryReason (NonEmpty ActionError)
  deriving stock Int -> AbortActionRegistryError -> String -> String
[AbortActionRegistryError] -> String -> String
AbortActionRegistryError -> String
(Int -> AbortActionRegistryError -> String -> String)
-> (AbortActionRegistryError -> String)
-> ([AbortActionRegistryError] -> String -> String)
-> Show AbortActionRegistryError
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> AbortActionRegistryError -> String -> String
showsPrec :: Int -> AbortActionRegistryError -> String -> String
$cshow :: AbortActionRegistryError -> String
show :: AbortActionRegistryError -> String
$cshowList :: [AbortActionRegistryError] -> String -> String
showList :: [AbortActionRegistryError] -> String -> String
Show

instance Exception AbortActionRegistryError where
  displayException :: AbortActionRegistryError -> String
displayException (AbortActionRegistryError AbortActionRegistryReason
reason NonEmpty ActionError
es) = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [
        String
"Exceptions thrown while aborting an action registry."
      , (String
"Reason for aborting the registry: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ AbortActionRegistryReason -> String
forall a. Show a => a -> String
show AbortActionRegistryReason
reason)
      ] [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> NonEmpty String -> [String]
forall a. NonEmpty a -> [a]
NE.toList ((ActionError -> String) -> NonEmpty ActionError -> NonEmpty String
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ActionError -> String
forall {e}. Exception e => e -> String
displayOne NonEmpty ActionError
es)
    where
      displayOne :: e -> String
displayOne e
e = String -> String
tabLines1 (e -> String
forall {e}. Exception e => e -> String
displayException e
e)

{-# SPECIALISE runActions :: [Action IO] -> IO [ActionError] #-}
-- | Run all actions even if previous actions threw exceptions.
runActions :: MonadCatch m => [Action m] -> m [ActionError]
runActions :: forall (m :: * -> *). MonadCatch m => [Action m] -> m [ActionError]
runActions = [ActionError] -> [Action m] -> m [ActionError]
forall {m :: * -> *}.
MonadCatch m =>
[ActionError] -> [Action m] -> m [ActionError]
go []
  where
    go :: [ActionError] -> [Action m] -> m [ActionError]
go [ActionError]
es [] = [ActionError] -> m [ActionError]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ActionError] -> [ActionError]
forall a. [a] -> [a]
reverse [ActionError]
es)
    go [ActionError]
es (Action m
a:[Action m]
as) = do
      Either SomeException ()
eith <- forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try @_ @SomeException (Action m -> m ()
forall (m :: * -> *). Action m -> m ()
runAction Action m
a)
      case Either SomeException ()
eith of
        Left SomeException
e  -> [ActionError] -> [Action m] -> m [ActionError]
go (SomeException -> Action m -> ActionError
forall (m :: * -> *). SomeException -> Action m -> ActionError
mkActionError SomeException
e Action m
a ActionError -> [ActionError] -> [ActionError]
forall {a}. a -> [a] -> [a]
: [ActionError]
es) [Action m]
as
        Right ()
_ -> [ActionError] -> [Action m] -> m [ActionError]
go [ActionError]
es [Action m]
as

{-------------------------------------------------------------------------------
  Registering actions
-------------------------------------------------------------------------------}

{- $registering-actions

  /Actions/ are monadic computations that (may) produce side effects. Such side
  effects can include opening or closing a file handle, but also modifying a
  mutable variable.

  We make a distinction between three types of actions:

  * An /immediate action/ is performed immediately, as the name suggests.

  * A /rollback action/ is an action that is registered in an action registry,
    and it is performed precisely when the corresponding action registry is
    aborted. See 'withRollback' for examples.

  * A /delayed action/ is an action that is registered in an action registry,
    and it is performed precisely when the corresponding action registry is
    committed. See 'delayedCommit' for examples.

  Immediate actions are run with asynchronous exceptions masked to guarantee
  that the rollback action is registered after the immediate action has returned
  successfully. This means that all the usual masking caveats apply for the
  immediate acion.

  Rollback actions and delayed actions are performed /precisely/ when aborting
  or committing an action registry respectively (see [Action
  registry](#g:actionRegistry)). To achieve this, finalisation of the action
  registry happens in the same masked state as runnning the registered actions.
  This means all the usual masking caveats apply for the registered actions.
-}

{-# SPECIALISE withRollback ::
     HasCallStackIfDebug
  => ActionRegistry IO
  -> IO a
  -> (a -> IO ())
  -> IO a #-}
-- | Perform an immediate action and register a rollback action.
--
-- See [Registering actions](#g:registeringActions) for more information about
-- the different types of actions.
--
-- A typical use case for 'withRollback' is to allocate a resource as the
-- immediate action, and to release said resource as the rollback action. In
-- that sense, 'withRollback' is similar to 'bracketOnError', but 'withRollback'
-- offers stronger guarantees.
--
-- Note that the following two expressions are /not/ equivalent. The former is
-- correct in the presence of asynchronous exceptions, while the latter is not!
--
-- @
--    withRollback reg acquire free
-- =/=
--    acquire >>= \x -> withRollback reg free (pure x)
-- @
withRollback ::
     (PrimMonad m, MonadMask m)
  => HasCallStackIfDebug
  => ActionRegistry m
  -> m a
  -> (a -> m ())
  -> m a
withRollback :: forall (m :: * -> *) a.
(PrimMonad m, MonadMask m) =>
ActionRegistry m -> m a -> (a -> m ()) -> m a
withRollback ActionRegistry m
reg m a
acquire a -> m ()
release =
    ActionRegistry m -> (a -> Maybe a) -> m a -> (a -> m ()) -> m a
forall (m :: * -> *) a b.
(PrimMonad m, MonadMask m) =>
ActionRegistry m -> (a -> Maybe b) -> m a -> (b -> m ()) -> m a
withRollbackFun ActionRegistry m
reg a -> Maybe a
forall a. a -> Maybe a
Just m a
acquire a -> m ()
release

{-# SPECIALISE withRollback_ ::
     HasCallStackIfDebug
  => ActionRegistry IO
  -> IO a
  -> IO ()
  -> IO a #-}
-- | Like 'withRollback', but the rollback action does not get access to the
-- result of the immediate action.
--
withRollback_ ::
     (PrimMonad m, MonadMask m)
  => HasCallStackIfDebug
  => ActionRegistry m
  -> m a
  -> m ()
  -> m a
withRollback_ :: forall (m :: * -> *) a.
(PrimMonad m, MonadMask m) =>
ActionRegistry m -> m a -> m () -> m a
withRollback_ ActionRegistry m
reg m a
acquire m ()
release =
    ActionRegistry m -> (a -> Maybe a) -> m a -> (a -> m ()) -> m a
forall (m :: * -> *) a b.
(PrimMonad m, MonadMask m) =>
ActionRegistry m -> (a -> Maybe b) -> m a -> (b -> m ()) -> m a
withRollbackFun ActionRegistry m
reg a -> Maybe a
forall a. a -> Maybe a
Just m a
acquire (\a
_ -> m ()
release)

{-# SPECIALISE withRollbackMaybe ::
     HasCallStackIfDebug
  => ActionRegistry IO
  -> IO (Maybe a)
  -> (a -> IO ())
  -> IO (Maybe a)
  #-}
-- | Like 'withRollback', but the immediate action may fail with a 'Nothing'.
-- The rollback action will only be registered if 'Just'.
--
withRollbackMaybe ::
     (PrimMonad m, MonadMask m)
  => HasCallStackIfDebug
  => ActionRegistry m
  -> m (Maybe a)
  -> (a -> m ())
  -> m (Maybe a)
withRollbackMaybe :: forall (m :: * -> *) a.
(PrimMonad m, MonadMask m) =>
ActionRegistry m -> m (Maybe a) -> (a -> m ()) -> m (Maybe a)
withRollbackMaybe ActionRegistry m
reg m (Maybe a)
acquire a -> m ()
release =
    ActionRegistry m
-> (Maybe a -> Maybe a)
-> m (Maybe a)
-> (a -> m ())
-> m (Maybe a)
forall (m :: * -> *) a b.
(PrimMonad m, MonadMask m) =>
ActionRegistry m -> (a -> Maybe b) -> m a -> (b -> m ()) -> m a
withRollbackFun ActionRegistry m
reg Maybe a -> Maybe a
forall a. a -> a
id m (Maybe a)
acquire a -> m ()
release

{-# SPECIALISE withRollbackEither ::
     HasCallStackIfDebug
  => ActionRegistry IO
  -> IO (Either e a)
  -> (a -> IO ())
  -> IO (Either e a)
  #-}
-- | Like 'withRollback', but the immediate action may fail with a 'Left'. The
-- rollback action will only be registered if 'Right'.
--
withRollbackEither ::
     (PrimMonad m, MonadMask m)
  => HasCallStackIfDebug
  => ActionRegistry m
  -> m (Either e a)
  -> (a -> m ())
  -> m (Either e a)
withRollbackEither :: forall (m :: * -> *) e a.
(PrimMonad m, MonadMask m) =>
ActionRegistry m -> m (Either e a) -> (a -> m ()) -> m (Either e a)
withRollbackEither ActionRegistry m
reg m (Either e a)
acquire a -> m ()
release =
    ActionRegistry m
-> (Either e a -> Maybe a)
-> m (Either e a)
-> (a -> m ())
-> m (Either e a)
forall (m :: * -> *) a b.
(PrimMonad m, MonadMask m) =>
ActionRegistry m -> (a -> Maybe b) -> m a -> (b -> m ()) -> m a
withRollbackFun ActionRegistry m
reg Either e a -> Maybe a
forall e a. Either e a -> Maybe a
fromEither m (Either e a)
acquire a -> m ()
release
  where
    fromEither :: Either e a -> Maybe a
    fromEither :: forall e a. Either e a -> Maybe a
fromEither (Left e
_)  = Maybe a
forall a. Maybe a
Nothing
    fromEither (Right a
x) = a -> Maybe a
forall a. a -> Maybe a
Just a
x

{-# SPECIALISE withRollbackFun ::
     HasCallStackIfDebug
  => ActionRegistry IO
  -> (a -> Maybe b)
  -> IO a
  -> (b -> IO ())
  -> IO a
  #-}
-- | Like 'withRollback', but the immediate action may fail in some general
-- way. The rollback function will only be registered if the @(a -> Maybe b)@
-- function returned 'Just'.
--
-- 'withRollbackFun' is the most general form in the 'withRollback*' family of
-- functions. All 'withRollback*' functions can be defined in terms of
-- 'withRollBackFun'.
--
withRollbackFun ::
     (PrimMonad m, MonadMask m)
  => HasCallStackIfDebug
  => ActionRegistry m
  -> (a -> Maybe b)
  -> m a
  -> (b -> m ())
  -> m a
withRollbackFun :: forall (m :: * -> *) a b.
(PrimMonad m, MonadMask m) =>
ActionRegistry m -> (a -> Maybe b) -> m a -> (b -> m ()) -> m a
withRollbackFun ActionRegistry m
reg a -> Maybe b
extract m a
acquire b -> m ()
release = do
    m a -> m a
forall a. m a -> m a
forall (m :: * -> *) a. MonadMask m => m a -> m a
mask_ (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ do
      a
x <- m a
acquire
      case a -> Maybe b
extract a
x of
        Maybe b
Nothing -> a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
        Just b
y -> do
          Action m -> MutVar (PrimState m) [Action m] -> m ()
forall (m :: * -> *).
PrimMonad m =>
Action m -> MutVar (PrimState m) [Action m] -> m ()
consAction (m () -> Action m
forall (m :: * -> *). m () -> Action m
mkAction (b -> m ()
release b
y)) (ActionRegistry m -> MutVar (PrimState m) [Action m]
forall (m :: * -> *).
ActionRegistry m -> MutVar (PrimState m) [Action m]
registryRollback ActionRegistry m
reg)
          a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x

{-# SPECIALISE delayedCommit ::
     HasCallStackIfDebug
  => ActionRegistry IO
  -> IO ()
  -> IO () #-}
-- | Register a delayed action.
--
-- See [Registering actions](#g:registeringActions) for more information about
-- the different types of actions.
--
-- A typical use case for 'delayedCommit' is to delay destructive actions until
-- they are safe to be performed. For example, a destructive action such as
-- removing a file can often not be rolled back without jumping through
-- additional hoops.
--
-- If you can think of a sensible rollback action for the action you want to
-- delay then 'withRollback' might be a more suitable fit than 'delayedCommit'.
-- For example, incrementing a thread-safe mutable variable can easily be rolled
-- back by decrementing the same variable again.
--
delayedCommit ::
     PrimMonad m
  => HasCallStackIfDebug
  => ActionRegistry m
  -> m ()
  -> m ()
delayedCommit :: forall (m :: * -> *).
PrimMonad m =>
ActionRegistry m -> m () -> m ()
delayedCommit ActionRegistry m
reg m ()
action = Action m -> MutVar (PrimState m) [Action m] -> m ()
forall (m :: * -> *).
PrimMonad m =>
Action m -> MutVar (PrimState m) [Action m] -> m ()
consAction (m () -> Action m
forall (m :: * -> *). m () -> Action m
mkAction m ()
action) (ActionRegistry m -> MutVar (PrimState m) [Action m]
forall (m :: * -> *).
ActionRegistry m -> MutVar (PrimState m) [Action m]
registryDelay ActionRegistry m
reg)