Internal.hs

module Shibuya.Adapter.Kiroku.Internal (
    acquireAllAndTransfer,
) where

import Control.Exception (SomeException)
import Data.Int (Int32)
import Effectful (Eff, IOE, (:>))
import Effectful.Exception qualified as Exception

{- | Acquire a fixed set of resources and atomically transfer their ownership.

The acquisition itself is restored to the caller's masking state because it may
perform interruptible startup work. As soon as an acquisition returns, the new
resource is added to the masked ownership ledger before the next interruptible
operation can run. If acquisition or transfer fails, every owned resource is
given one release attempt in reverse acquisition order and the original
exception is rethrown even when a release also fails.

The post-acquire hook runs while the new resource is already in the ledger. It
exists so tests can stop at the exact cancellation boundary without adding a
hook to the public adapter API; production callers pass a no-op.
-}
acquireAllAndTransfer ::
    (IOE :> es) =>
    Int32 ->
    (Int32 -> Eff es resource) ->
    (resource -> Eff es ()) ->
    (Int32 -> resource -> Eff es ()) ->
    ([resource] -> Eff es result) ->
    Eff es result
acquireAllAndTransfer count acquire release afterAcquire transfer =
    Exception.mask $ \restore -> go restore [] 0
  where
    go restore owned member
        | member >= count = do
            outcome <- tryAny (transfer (reverse owned))
            either (`cleanupAndRethrow` owned) pure outcome
        | otherwise = do
            acquisition <- tryAny (restore (acquire member))
            case acquisition of
                Left primary -> cleanupAndRethrow primary owned
                Right resource -> do
                    let owned' = resource : owned
                    handoff <- tryAny (afterAcquire member resource)
                    case handoff of
                        Left primary -> cleanupAndRethrow primary owned'
                        Right () -> go restore owned' (member + 1)

    cleanupAndRethrow primary owned = do
        mapM_ releaseIgnoringFailure owned
        Exception.throwIO primary

    releaseIgnoringFailure resource = do
        _ <- tryAny (release resource)
        pure ()

tryAny :: Eff es a -> Eff es (Either SomeException a)
tryAny = Exception.try