-- | Bounded signed submission and confirmation waits, independent of transport.
module Singular.Registry.Wait
    ( WaitStage (..)
    , WaitFailure (..)
    , WaitClock
    , startWaitClock
    , boundWait
    , boundWaitSince
    , boundWaitClosingSince
    , submissionBound
    , boundedSignedSubmission
    , tryOutcome
    ) where

import Cardano.Ledger.Api.Tx (txIdTx)
import Cardano.Ledger.TxIn (TxId)
import Control.Exception
    ( SomeAsyncException
    , SomeException
    , fromException
    , throwIO
    , try
    )
import GHC.Clock (getMonotonicTime)
import Singular.Registry.Signing (SignedTx, signedTx)
import Singular.Registry.WaitTypes (WaitFailure (..), WaitStage (..))
import System.Timeout (timeout)

{- | The start of a wait on the monotonic clock. The public call that
waits takes it at its entry and hands it to every bound it runs under,
so the elapsed time a failure reports covers the whole call — reads
made before the wait proper included — and never less than the time
actually spent.
-}
newtype WaitClock = WaitClock Double

-- | Start a wait's clock.
startWaitClock :: IO WaitClock
startWaitClock :: IO WaitClock
startWaitClock = Double -> WaitClock
WaitClock (Double -> WaitClock) -> IO Double -> IO WaitClock
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Double
getMonotonicTime

{- | Run an action as one wait on a transaction: the whole action, from
its first step to its last, obeys the bound. When it has not returned
after @bound@ seconds the waiting thread is cancelled and the wait
failure is raised. A prompt return passes through unchanged, and the
action's own asynchronous exceptions reach it exactly as without the
wrap: nothing here masks them. The elapsed time the failure reports is
measured from this call.
-}
boundWait :: WaitStage -> TxId -> Int -> IO a -> IO a
boundWait :: forall a. WaitStage -> TxId -> Int -> IO a -> IO a
boundWait WaitStage
stage TxId
tid Int
bound IO a
action = do
    clock <- IO WaitClock
startWaitClock
    boundWaitSince clock stage tid bound action

{- | 'boundWait' with the elapsed time measured from an earlier clock:
the bound applies to this action, the reported time to the whole call
that started the clock.
-}
boundWaitSince
    :: WaitClock -> WaitStage -> TxId -> Int -> IO a -> IO a
boundWaitSince :: forall a. WaitClock -> WaitStage -> TxId -> Int -> IO a -> IO a
boundWaitSince WaitClock
clock WaitStage
stage TxId
tid Int
bound IO a
action =
    WaitClock
-> WaitStage -> TxId -> Int -> IO (Either Integer a) -> IO a
forall a.
WaitClock
-> WaitStage -> TxId -> Int -> IO (Either Integer a) -> IO a
boundWaitClosingSince WaitClock
clock WaitStage
stage TxId
tid Int
bound (a -> Either Integer a
forall a b. b -> Either a b
Right (a -> Either Integer a) -> IO a -> IO (Either Integer a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
action)

{- | 'boundWaitSince' for a wait that can also give up on its own: an
action that finds the confirmation window closed returns 'Left' the
POSIX deadline in milliseconds, and the wait ends at once with the same failure,
carrying that POSIX deadline. The failure a closed window raises is the one a
bound raises, so no caller can read it as a refusal.
-}
boundWaitClosingSince
    :: WaitClock
    -> WaitStage
    -> TxId
    -> Int
    -> IO (Either Integer a)
    -> IO a
boundWaitClosingSince :: forall a.
WaitClock
-> WaitStage -> TxId -> Int -> IO (Either Integer a) -> IO a
boundWaitClosingSince (WaitClock Double
start) WaitStage
stage TxId
tid Int
bound IO (Either Integer a)
action = do
    outcome <- Int -> IO (Either Integer a) -> IO (Maybe (Either Integer a))
forall a. Int -> IO a -> IO (Maybe a)
timeout (Int
bound Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1_000_000) IO (Either Integer a)
action
    end <- getMonotonicTime
    let giveUp Maybe Integer
closedAt =
            WaitFailure -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO
                WaitFailure
                    { waitStage :: WaitStage
waitStage = WaitStage
stage
                    , waitTxId :: TxId
waitTxId = TxId
tid
                    , waitElapsed :: Double
waitElapsed = Double
end Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
start
                    , waitBound :: Int
waitBound = Int
bound
                    , waitClosedAt :: Maybe Integer
waitClosedAt = Maybe Integer
closedAt
                    }
    case outcome of
        Maybe (Either Integer a)
Nothing -> Maybe Integer -> IO a
forall {a}. Maybe Integer -> IO a
giveUp Maybe Integer
forall a. Maybe a
Nothing
        Just (Left Integer
deadline) -> Maybe Integer -> IO a
forall {a}. Maybe Integer -> IO a
giveUp (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
deadline)
        Just (Right a
a) -> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

-- | Preserve the existing five-minute infrastructure bound.
submissionBound :: Int
submissionBound :: Int
submissionBound = Int
300

-- | A timeout remains a named infrastructure exception, never a submit verdict.
boundedSignedSubmission
    :: Int -> (SignedTx -> IO a) -> SignedTx -> IO a
boundedSignedSubmission :: forall a. Int -> (SignedTx -> IO a) -> SignedTx -> IO a
boundedSignedSubmission Int
bound SignedTx -> IO a
submit SignedTx
signed =
    WaitStage -> TxId -> Int -> IO a -> IO a
forall a. WaitStage -> TxId -> Int -> IO a -> IO a
boundWait
        WaitStage
SubmissionWait
        (Tx TopTx ConwayEra -> TxId
forall era (l :: TxLevel). EraTx era => Tx l era -> TxId
txIdTx (SignedTx -> Tx TopTx ConwayEra
signedTx SignedTx
signed))
        Int
bound
        (SignedTx -> IO a
submit SignedTx
signed)

{- | Run an action and classify what it throws: any synchronous exception
is returned as 'Left', except the wait failure, which is rethrown, and
asynchronous exceptions, which propagate. Every site that turns a
failure into a refusal, a control outcome or a reason to retry catches
through this, so a wait that gave up on a stalled node is never
published as a ledger refusal nor retried as one.
-}
tryOutcome :: IO a -> IO (Either SomeException a)
tryOutcome :: forall a. IO a -> IO (Either SomeException a)
tryOutcome IO a
action = do
    outcome <- IO a -> IO (Either SomeException a)
forall e a. Exception e => IO a -> IO (Either e a)
try IO a
action
    case outcome of
        Right a
a -> Either SomeException a -> IO (Either SomeException a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Either SomeException a
forall a b. b -> Either a b
Right a
a)
        Left SomeException
e
            | Just (SomeAsyncException
_ :: SomeAsyncException) <- SomeException -> Maybe SomeAsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e ->
                SomeException -> IO (Either SomeException a)
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO SomeException
e
            | Just (WaitFailure
_ :: WaitFailure) <- SomeException -> Maybe WaitFailure
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e -> SomeException -> IO (Either SomeException a)
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO SomeException
e
            | Bool
otherwise -> Either SomeException a -> IO (Either SomeException a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SomeException -> Either SomeException a
forall a b. a -> Either a b
Left SomeException
e)