{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

{- | Exact-output confirmation from generic sessions and explicit clock effects.
Confirmation reads have their own acquisitions, after the body is prepared.
-}
module Singular.Registry.Confirmation
    ( ConfirmationRuntime (..)
    , ConfirmationFailure (..)
    , confirmTransaction
    , confirmationWindow
    , newIOConfirmationRuntime
    , awaitTransaction
    ) where

import Cardano.Ledger.Allegra.Scripts (ValidityInterval (..))
import Cardano.Ledger.Api.Tx
    ( bodyTxL
    , outputsTxBodyL
    , txIdTx
    , vldtTxBodyL
    )
import Cardano.Ledger.BaseTypes (StrictMaybe (..), TxIx (..))
import Cardano.Ledger.TxIn (TxId, TxIn (..))
import Cardano.Tx.Ledger (ConwayTx)
import Control.Concurrent (threadDelay)
import Control.Exception (Exception, fromException, throwIO, try)
import Control.Monad qualified
import Data.Foldable (toList)
import Data.Maybe qualified
import Data.Text qualified as Text
import Data.Time.Clock.POSIX (getPOSIXTime)
import Lens.Micro ((^.))
import Singular.Registry.Evidence (value)
import Singular.Registry.LedgerProvider
import Singular.Registry.NetworkTime (NetworkTimeFailure)
import Singular.Registry.SessionServices qualified as Services
import Singular.Registry.Wait
    ( WaitFailure
    , WaitStage (..)
    , boundWaitClosingSince
    , startWaitClock
    , tryOutcome
    )

{- | The consumer supplies clock, sleep and whole-action cancellation effects.
A pure State interpreter supplies the same vocabulary without embedded IO.
-}
data ConfirmationRuntime m = ConfirmationRuntime
    { forall (m :: * -> *). ConfirmationRuntime m -> m Integer
currentPosixMs :: m Integer
    , forall (m :: * -> *). ConfirmationRuntime m -> Int -> m ()
pausePolling :: Int -> m ()
    , forall (m :: * -> *).
ConfirmationRuntime m
-> forall a. m a -> m (Either ConfirmationFailure a)
attemptWindowRead :: forall a. m a -> m (Either ConfirmationFailure a)
    , forall (m :: * -> *).
ConfirmationRuntime m
-> forall a.
   TxId -> Int -> m (Either Integer a) -> m (Either WaitFailure a)
boundedConfirmation
        :: forall a
         . TxId -> Int -> m (Either Integer a) -> m (Either WaitFailure a)
    }

-- | Raw refusals and infrastructure timeouts remain distinct.
data ConfirmationFailure
    = ConfirmationAcquireFailure AcquireFailure
    | ConfirmationReadFailure ReadFailure
    | ConfirmationTimeFailure NetworkTimeFailure
    | ConfirmationNoOutput TxId
    | ConfirmationWaitFailure WaitFailure
    deriving stock (Int -> ConfirmationFailure -> ShowS
[ConfirmationFailure] -> ShowS
ConfirmationFailure -> String
(Int -> ConfirmationFailure -> ShowS)
-> (ConfirmationFailure -> String)
-> ([ConfirmationFailure] -> ShowS)
-> Show ConfirmationFailure
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ConfirmationFailure -> ShowS
showsPrec :: Int -> ConfirmationFailure -> ShowS
$cshow :: ConfirmationFailure -> String
show :: ConfirmationFailure -> String
$cshowList :: [ConfirmationFailure] -> ShowS
showList :: [ConfirmationFailure] -> ShowS
Show)

instance Exception ConfirmationFailure

data PollObservation = OutputVisible | WindowOpen | WindowClosed

{- | Output zero must be visible under its exact transaction reference.
The finite upper bound is validated before its uncapped two-minute margin;
an unbounded body keeps the existing five-minute wall-clock window.
Retry after one second, then back off to the original five-second interval
so a slow or missing transaction does not multiply provider traffic.
-}
confirmTransaction
    :: forall m w
     . (Monad m)
    => ConfirmationRuntime m
    -> LedgerProvider w m
    -> Network
    -> ConwayTx
    -> m (Either ConfirmationFailure ())
confirmTransaction :: forall (m :: * -> *) w.
Monad m =>
ConfirmationRuntime m
-> LedgerProvider w m
-> Network
-> ConwayTx
-> m (Either ConfirmationFailure ())
confirmTransaction ConfirmationRuntime m
runtime LedgerProvider w m
provider Network
network ConwayTx
tx = case StrictSeq (BabbageTxOut ConwayEra) -> [BabbageTxOut ConwayEra]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (ConwayTx
tx ConwayTx
-> Getting
     (StrictSeq (BabbageTxOut ConwayEra))
     ConwayTx
     (StrictSeq (BabbageTxOut ConwayEra))
-> StrictSeq (BabbageTxOut ConwayEra)
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx ConwayEra
 -> Const
      (StrictSeq (BabbageTxOut ConwayEra)) (TxBody TopTx ConwayEra))
-> ConwayTx -> Const (StrictSeq (BabbageTxOut ConwayEra)) ConwayTx
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxBody l ConwayEra)
bodyTxL ((TxBody TopTx ConwayEra
  -> Const
       (StrictSeq (BabbageTxOut ConwayEra)) (TxBody TopTx ConwayEra))
 -> ConwayTx -> Const (StrictSeq (BabbageTxOut ConwayEra)) ConwayTx)
-> ((StrictSeq (BabbageTxOut ConwayEra)
     -> Const
          (StrictSeq (BabbageTxOut ConwayEra))
          (StrictSeq (BabbageTxOut ConwayEra)))
    -> TxBody TopTx ConwayEra
    -> Const
         (StrictSeq (BabbageTxOut ConwayEra)) (TxBody TopTx ConwayEra))
-> Getting
     (StrictSeq (BabbageTxOut ConwayEra))
     ConwayTx
     (StrictSeq (BabbageTxOut ConwayEra))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxOut ConwayEra)
 -> Const
      (StrictSeq (BabbageTxOut ConwayEra)) (StrictSeq (TxOut ConwayEra)))
-> TxBody TopTx ConwayEra
-> Const
     (StrictSeq (BabbageTxOut ConwayEra)) (TxBody TopTx ConwayEra)
(StrictSeq (BabbageTxOut ConwayEra)
 -> Const
      (StrictSeq (BabbageTxOut ConwayEra))
      (StrictSeq (BabbageTxOut ConwayEra)))
-> TxBody TopTx ConwayEra
-> Const
     (StrictSeq (BabbageTxOut ConwayEra)) (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel).
Lens' (TxBody l ConwayEra) (StrictSeq (TxOut ConwayEra))
outputsTxBodyL) of
    [] -> Either ConfirmationFailure () -> m (Either ConfirmationFailure ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConfirmationFailure -> Either ConfirmationFailure ()
forall a b. a -> Either a b
Left (TxId -> ConfirmationFailure
ConfirmationNoOutput TxId
tid))
    BabbageTxOut ConwayEra
_ : [BabbageTxOut ConwayEra]
_ -> do
        windowResult <- ConfirmationRuntime m
-> LedgerProvider w m
-> Network
-> ConwayTx
-> m (Either ConfirmationFailure (Integer, Int))
forall (m :: * -> *) w.
Monad m =>
ConfirmationRuntime m
-> LedgerProvider w m
-> Network
-> ConwayTx
-> m (Either ConfirmationFailure (Integer, Int))
confirmationWindow ConfirmationRuntime m
runtime LedgerProvider w m
provider Network
network ConwayTx
tx
        case windowResult of
            Left ConfirmationFailure
failure -> Either ConfirmationFailure () -> m (Either ConfirmationFailure ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConfirmationFailure -> Either ConfirmationFailure ()
forall a b. a -> Either a b
Left ConfirmationFailure
failure)
            Right (Integer
deadline, Int
bound) -> do
                result <- ConfirmationRuntime m
-> forall a.
   TxId -> Int -> m (Either Integer a) -> m (Either WaitFailure a)
forall (m :: * -> *).
ConfirmationRuntime m
-> forall a.
   TxId -> Int -> m (Either Integer a) -> m (Either WaitFailure a)
boundedConfirmation ConfirmationRuntime m
runtime TxId
tid Int
bound (Integer
-> Int -> m (Either Integer (Either ConfirmationFailure ()))
poll Integer
deadline Int
1)
                pure $ case result of
                    Left WaitFailure
failure -> ConfirmationFailure -> Either ConfirmationFailure ()
forall a b. a -> Either a b
Left (WaitFailure -> ConfirmationFailure
ConfirmationWaitFailure WaitFailure
failure)
                    Right Either ConfirmationFailure ()
outcome -> Either ConfirmationFailure ()
outcome
  where
    tid :: TxId
tid = ConwayTx -> TxId
forall era (l :: TxLevel). EraTx era => Tx l era -> TxId
txIdTx ConwayTx
tx
    wanted :: TxIn
wanted = TxId -> TxIx -> TxIn
TxIn TxId
tid (Word16 -> TxIx
TxIx Word16
0)
    poll :: Integer
-> Int -> m (Either Integer (Either ConfirmationFailure ()))
poll Integer
deadline Int
delay = do
        observed <- LedgerProvider w m
-> Network
-> (Session w m -> m (Either ConfirmationFailure PollObservation))
-> m (Either ConfirmationFailure PollObservation)
forall (m :: * -> *) w a.
Monad m =>
LedgerProvider w m
-> Network
-> (Session w m -> m (Either ConfirmationFailure a))
-> m (Either ConfirmationFailure a)
readScope LedgerProvider w m
provider Network
network ((Session w m -> m (Either ConfirmationFailure PollObservation))
 -> m (Either ConfirmationFailure PollObservation))
-> (Session w m -> m (Either ConfirmationFailure PollObservation))
-> m (Either ConfirmationFailure PollObservation)
forall a b. (a -> b) -> a -> b
$ \Session w m
session -> do
            exact <- Session w m
-> OutputQuery -> m (Either ReadFailure (Evidenced w Outputs))
forall w (m :: * -> *).
Session w m
-> OutputQuery -> m (Either ReadFailure (Evidenced w Outputs))
outputs Session w m
session (TxIn -> OutputQuery
AtTxIn TxIn
wanted)
            case exact of
                Right Evidenced w [(TxIn, BabbageTxOut ConwayEra)]
fact | ((TxIn, BabbageTxOut ConwayEra) -> Bool)
-> [(TxIn, BabbageTxOut ConwayEra)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((TxIn -> TxIn -> Bool
forall a. Eq a => a -> a -> Bool
== TxIn
wanted) (TxIn -> Bool)
-> ((TxIn, BabbageTxOut ConwayEra) -> TxIn)
-> (TxIn, BabbageTxOut ConwayEra)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxIn, BabbageTxOut ConwayEra) -> TxIn
forall a b. (a, b) -> a
fst) (Evidenced w [(TxIn, BabbageTxOut ConwayEra)]
-> [(TxIn, BabbageTxOut ConwayEra)]
forall w a. Evidenced w a -> a
value Evidenced w [(TxIn, BabbageTxOut ConwayEra)]
fact) -> Either ConfirmationFailure PollObservation
-> m (Either ConfirmationFailure PollObservation)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PollObservation -> Either ConfirmationFailure PollObservation
forall a b. b -> Either a b
Right PollObservation
OutputVisible)
                Left (MissingOutput TxIn
missing)
                    | TxIn
missing TxIn -> TxIn -> Bool
forall a. Eq a => a -> a -> Bool
/= TxIn
wanted ->
                        Either ConfirmationFailure PollObservation
-> m (Either ConfirmationFailure PollObservation)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConfirmationFailure -> Either ConfirmationFailure PollObservation
forall a b. a -> Either a b
Left (ReadFailure -> ConfirmationFailure
ConfirmationReadFailure (TxIn -> ReadFailure
MissingOutput TxIn
missing)))
                Left failure :: ReadFailure
failure@(ConflictingOutput TxIn
_) -> Either ConfirmationFailure PollObservation
-> m (Either ConfirmationFailure PollObservation)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConfirmationFailure -> Either ConfirmationFailure PollObservation
forall a b. a -> Either a b
Left (ReadFailure -> ConfirmationFailure
ConfirmationReadFailure ReadFailure
failure))
                Left failure :: ReadFailure
failure@(ReleasedSession SessionId
_) -> Either ConfirmationFailure PollObservation
-> m (Either ConfirmationFailure PollObservation)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConfirmationFailure -> Either ConfirmationFailure PollObservation
forall a b. a -> Either a b
Left (ReadFailure -> ConfirmationFailure
ConfirmationReadFailure ReadFailure
failure))
                Left failure :: ReadFailure
failure@(BackendReadFailure Text
_) -> Either ConfirmationFailure PollObservation
-> m (Either ConfirmationFailure PollObservation)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConfirmationFailure -> Either ConfirmationFailure PollObservation
forall a b. a -> Either a b
Left (ReadFailure -> ConfirmationFailure
ConfirmationReadFailure ReadFailure
failure))
                Left failure :: ReadFailure
failure@(NetworkTimeRefusal NetworkTimeFailure
_) -> Either ConfirmationFailure PollObservation
-> m (Either ConfirmationFailure PollObservation)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConfirmationFailure -> Either ConfirmationFailure PollObservation
forall a b. a -> Either a b
Left (ReadFailure -> ConfirmationFailure
ConfirmationReadFailure ReadFailure
failure))
                Either ReadFailure (Evidenced w [(TxIn, BabbageTxOut ConwayEra)])
_ -> do
                    tip <- Session w m -> m (Either ReadFailure (Evidenced w TipObservation))
forall w (m :: * -> *).
Session w m -> m (Either ReadFailure (Evidenced w TipObservation))
tipObservation Session w m
session
                    pure $ case tip of
                        Left ReadFailure
failure -> ConfirmationFailure -> Either ConfirmationFailure PollObservation
forall a b. a -> Either a b
Left (ReadFailure -> ConfirmationFailure
ConfirmationReadFailure ReadFailure
failure)
                        Right Evidenced w TipObservation
fact ->
                            PollObservation -> Either ConfirmationFailure PollObservation
forall a b. b -> Either a b
Right
                                ( if Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger (TipObservation -> Word64
observedBlockTime (Evidenced w TipObservation -> TipObservation
forall w a. Evidenced w a -> a
value Evidenced w TipObservation
fact)) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
1000 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
deadline
                                    then PollObservation
WindowOpen
                                    else PollObservation
WindowClosed
                                )
        case observed of
            Left ConfirmationFailure
failure -> Either Integer (Either ConfirmationFailure ())
-> m (Either Integer (Either ConfirmationFailure ()))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ConfirmationFailure ()
-> Either Integer (Either ConfirmationFailure ())
forall a b. b -> Either a b
Right (ConfirmationFailure -> Either ConfirmationFailure ()
forall a b. a -> Either a b
Left ConfirmationFailure
failure))
            Right PollObservation
WindowClosed -> Either Integer (Either ConfirmationFailure ())
-> m (Either Integer (Either ConfirmationFailure ()))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Either Integer (Either ConfirmationFailure ())
forall a b. a -> Either a b
Left Integer
deadline)
            Right PollObservation
WindowOpen ->
                ConfirmationRuntime m -> Int -> m ()
forall (m :: * -> *). ConfirmationRuntime m -> Int -> m ()
pausePolling ConfirmationRuntime m
runtime Int
delay m ()
-> m (Either Integer (Either ConfirmationFailure ()))
-> m (Either Integer (Either ConfirmationFailure ()))
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Integer
-> Int -> m (Either Integer (Either ConfirmationFailure ()))
poll Integer
deadline (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
5 (Int
delay Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2))
            Right PollObservation
OutputVisible -> Either Integer (Either ConfirmationFailure ())
-> m (Either Integer (Either ConfirmationFailure ()))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ConfirmationFailure ()
-> Either Integer (Either ConfirmationFailure ())
forall a b. b -> Either a b
Right (() -> Either ConfirmationFailure ()
forall a b. b -> Either a b
Right ()))

{- | Derive the same bounded window used by 'confirmTransaction'. A private
read-only recorder may inspect it without inventing a transaction output or
starting a visibility poll. This performs no submission or confirmation.
-}
confirmationWindow
    :: (Monad m)
    => ConfirmationRuntime m
    -> LedgerProvider w m
    -> Network
    -> ConwayTx
    -> m (Either ConfirmationFailure (Integer, Int))
confirmationWindow :: forall (m :: * -> *) w.
Monad m =>
ConfirmationRuntime m
-> LedgerProvider w m
-> Network
-> ConwayTx
-> m (Either ConfirmationFailure (Integer, Int))
confirmationWindow ConfirmationRuntime m
runtime LedgerProvider w m
provider Network
network ConwayTx
tx = do
    result <-
        ConfirmationRuntime m
-> forall a.
   TxId -> Int -> m (Either Integer a) -> m (Either WaitFailure a)
forall (m :: * -> *).
ConfirmationRuntime m
-> forall a.
   TxId -> Int -> m (Either Integer a) -> m (Either WaitFailure a)
boundedConfirmation ConfirmationRuntime m
runtime (ConwayTx -> TxId
forall era (l :: TxLevel). EraTx era => Tx l era -> TxId
txIdTx ConwayTx
tx) Int
30 (Either ConfirmationFailure (Integer, Int)
-> Either Integer (Either ConfirmationFailure (Integer, Int))
forall a b. b -> Either a b
Right (Either ConfirmationFailure (Integer, Int)
 -> Either Integer (Either ConfirmationFailure (Integer, Int)))
-> m (Either ConfirmationFailure (Integer, Int))
-> m (Either Integer (Either ConfirmationFailure (Integer, Int)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Either ConfirmationFailure (Integer, Int))
window)
    pure (either (Left . ConfirmationWaitFailure) id result)
  where
    window :: m (Either ConfirmationFailure (Integer, Int))
window = do
        attempted <- ConfirmationRuntime m
-> forall a. m a -> m (Either ConfirmationFailure a)
forall (m :: * -> *).
ConfirmationRuntime m
-> forall a. m a -> m (Either ConfirmationFailure a)
attemptWindowRead ConfirmationRuntime m
runtime (m (Either ConfirmationFailure (Maybe Integer))
 -> m (Either
         ConfirmationFailure (Either ConfirmationFailure (Maybe Integer))))
-> m (Either ConfirmationFailure (Maybe Integer))
-> m (Either
        ConfirmationFailure (Either ConfirmationFailure (Maybe Integer)))
forall a b. (a -> b) -> a -> b
$ LedgerProvider w m
-> Network
-> (Session w m -> m (Either ConfirmationFailure (Maybe Integer)))
-> m (Either ConfirmationFailure (Maybe Integer))
forall (m :: * -> *) w a.
Monad m =>
LedgerProvider w m
-> Network
-> (Session w m -> m (Either ConfirmationFailure a))
-> m (Either ConfirmationFailure a)
readScope LedgerProvider w m
provider Network
network ((Session w m -> m (Either ConfirmationFailure (Maybe Integer)))
 -> m (Either ConfirmationFailure (Maybe Integer)))
-> (Session w m -> m (Either ConfirmationFailure (Maybe Integer)))
-> m (Either ConfirmationFailure (Maybe Integer))
forall a b. (a -> b) -> a -> b
$ \Session w m
session -> case ValidityInterval -> StrictMaybe SlotNo
invalidHereafter (ConwayTx
tx ConwayTx
-> Getting ValidityInterval ConwayTx ValidityInterval
-> ValidityInterval
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx ConwayEra
 -> Const ValidityInterval (TxBody TopTx ConwayEra))
-> ConwayTx -> Const ValidityInterval ConwayTx
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxBody l ConwayEra)
bodyTxL ((TxBody TopTx ConwayEra
  -> Const ValidityInterval (TxBody TopTx ConwayEra))
 -> ConwayTx -> Const ValidityInterval ConwayTx)
-> ((ValidityInterval -> Const ValidityInterval ValidityInterval)
    -> TxBody TopTx ConwayEra
    -> Const ValidityInterval (TxBody TopTx ConwayEra))
-> Getting ValidityInterval ConwayTx ValidityInterval
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ValidityInterval -> Const ValidityInterval ValidityInterval)
-> TxBody TopTx ConwayEra
-> Const ValidityInterval (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
AllegraEraTxBody era =>
Lens' (TxBody l era) ValidityInterval
forall (l :: TxLevel). Lens' (TxBody l ConwayEra) ValidityInterval
vldtTxBodyL) of
            SJust SlotNo
upper -> do
                start <- Session w m -> SlotNo -> m (Either ServiceFailure Integer)
forall (m :: * -> *) w.
Monad m =>
Session w m -> SlotNo -> m (Either ServiceFailure Integer)
Services.slotStart Session w m
session SlotNo
upper
                pure $ case start of
                    Right Integer
ms -> Maybe Integer -> Either ConfirmationFailure (Maybe Integer)
forall a b. b -> Either a b
Right (Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer
ms Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
120000))
                    Left (Services.ServiceTimeFailure NetworkTimeFailure
failure) -> ConfirmationFailure -> Either ConfirmationFailure (Maybe Integer)
forall a b. a -> Either a b
Left (NetworkTimeFailure -> ConfirmationFailure
ConfirmationTimeFailure NetworkTimeFailure
failure)
                    Left (Services.ServiceReadFailure ReadFailure
failure) -> ConfirmationFailure -> Either ConfirmationFailure (Maybe Integer)
forall a b. a -> Either a b
Left (ReadFailure -> ConfirmationFailure
ConfirmationReadFailure ReadFailure
failure)
                    Left ServiceFailure
failure ->
                        ConfirmationFailure -> Either ConfirmationFailure (Maybe Integer)
forall a b. a -> Either a b
Left
                            (ReadFailure -> ConfirmationFailure
ConfirmationReadFailure (Text -> ReadFailure
BackendReadFailure (ServiceFailure -> Text
showService ServiceFailure
failure)))
            StrictMaybe SlotNo
SNothing -> do
                tip <- Session w m -> m (Either ReadFailure (Evidenced w TipObservation))
forall w (m :: * -> *).
Session w m -> m (Either ReadFailure (Evidenced w TipObservation))
tipObservation Session w m
session
                case tip of
                    Left ReadFailure
failure -> Either ConfirmationFailure (Maybe Integer)
-> m (Either ConfirmationFailure (Maybe Integer))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConfirmationFailure -> Either ConfirmationFailure (Maybe Integer)
forall a b. a -> Either a b
Left (ReadFailure -> ConfirmationFailure
ConfirmationReadFailure ReadFailure
failure))
                    Right Evidenced w TipObservation
fact -> do
                        checked <- Session w m -> SlotNo -> m (Either ServiceFailure Integer)
forall (m :: * -> *) w.
Monad m =>
Session w m -> SlotNo -> m (Either ServiceFailure Integer)
Services.slotStart Session w m
session (TipObservation -> SlotNo
observedSlot (Evidenced w TipObservation -> TipObservation
forall w a. Evidenced w a -> a
value Evidenced w TipObservation
fact))
                        pure $ case checked of
                            Right Integer
_ -> Maybe Integer -> Either ConfirmationFailure (Maybe Integer)
forall a b. b -> Either a b
Right Maybe Integer
forall a. Maybe a
Nothing
                            Left (Services.ServiceTimeFailure NetworkTimeFailure
failure) -> ConfirmationFailure -> Either ConfirmationFailure (Maybe Integer)
forall a b. a -> Either a b
Left (NetworkTimeFailure -> ConfirmationFailure
ConfirmationTimeFailure NetworkTimeFailure
failure)
                            Left (Services.ServiceReadFailure ReadFailure
failure) -> ConfirmationFailure -> Either ConfirmationFailure (Maybe Integer)
forall a b. a -> Either a b
Left (ReadFailure -> ConfirmationFailure
ConfirmationReadFailure ReadFailure
failure)
                            Left ServiceFailure
failure ->
                                ConfirmationFailure -> Either ConfirmationFailure (Maybe Integer)
forall a b. a -> Either a b
Left
                                    (ReadFailure -> ConfirmationFailure
ConfirmationReadFailure (Text -> ReadFailure
BackendReadFailure (ServiceFailure -> Text
showService ServiceFailure
failure)))
        let derived = Either
  ConfirmationFailure (Either ConfirmationFailure (Maybe Integer))
-> Either ConfirmationFailure (Maybe Integer)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
Control.Monad.join Either
  ConfirmationFailure (Either ConfirmationFailure (Maybe Integer))
attempted
        selected <- case derived of
            -- Preserve the historical synchronous context-read fallback. Its
            -- independent block-time read is still within the window-read bound.
            Left (ConfirmationReadFailure ReadFailure
_) -> do
                fallback <- LedgerProvider w m
-> Network
-> (Session w m -> m (Either ConfirmationFailure ()))
-> m (Either ConfirmationFailure ())
forall (m :: * -> *) w a.
Monad m =>
LedgerProvider w m
-> Network
-> (Session w m -> m (Either ConfirmationFailure a))
-> m (Either ConfirmationFailure a)
readScope LedgerProvider w m
provider Network
network ((Session w m -> m (Either ConfirmationFailure ()))
 -> m (Either ConfirmationFailure ()))
-> (Session w m -> m (Either ConfirmationFailure ()))
-> m (Either ConfirmationFailure ())
forall a b. (a -> b) -> a -> b
$ \Session w m
session ->
                    (Either ReadFailure (Evidenced w TipObservation)
 -> Either ConfirmationFailure ())
-> m (Either ReadFailure (Evidenced w TipObservation))
-> m (Either ConfirmationFailure ())
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
                        ((ReadFailure -> Either ConfirmationFailure ())
-> (Evidenced w TipObservation -> Either ConfirmationFailure ())
-> Either ReadFailure (Evidenced w TipObservation)
-> Either ConfirmationFailure ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ConfirmationFailure -> Either ConfirmationFailure ()
forall a b. a -> Either a b
Left (ConfirmationFailure -> Either ConfirmationFailure ())
-> (ReadFailure -> ConfirmationFailure)
-> ReadFailure
-> Either ConfirmationFailure ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReadFailure -> ConfirmationFailure
ConfirmationReadFailure) (Either ConfirmationFailure ()
-> Evidenced w TipObservation -> Either ConfirmationFailure ()
forall a b. a -> b -> a
const (() -> Either ConfirmationFailure ()
forall a b. b -> Either a b
Right ())))
                        (Session w m -> m (Either ReadFailure (Evidenced w TipObservation))
forall w (m :: * -> *).
Session w m -> m (Either ReadFailure (Evidenced w TipObservation))
tipObservation Session w m
session)
                pure (Nothing <$ fallback)
            Either ConfirmationFailure (Maybe Integer)
other -> Either ConfirmationFailure (Maybe Integer)
-> m (Either ConfirmationFailure (Maybe Integer))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either ConfirmationFailure (Maybe Integer)
other
        case selected of
            Left ConfirmationFailure
failure -> Either ConfirmationFailure (Integer, Int)
-> m (Either ConfirmationFailure (Integer, Int))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConfirmationFailure -> Either ConfirmationFailure (Integer, Int)
forall a b. a -> Either a b
Left ConfirmationFailure
failure)
            Right Maybe Integer
supplied -> do
                now <- ConfirmationRuntime m -> m Integer
forall (m :: * -> *). ConfirmationRuntime m -> m Integer
currentPosixMs ConfirmationRuntime m
runtime
                let deadline = Integer -> Maybe Integer -> Integer
forall a. a -> Maybe a -> a
Data.Maybe.fromMaybe (Integer
now Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
300000) Maybe Integer
supplied
                    seconds = Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max Integer
0 ((Integer
deadline Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
now Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
999) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
1000)
                pure (Right (deadline, fromInteger seconds + 10))

readScope
    :: (Monad m)
    => LedgerProvider w m
    -> Network
    -> (Session w m -> m (Either ConfirmationFailure a))
    -> m (Either ConfirmationFailure a)
readScope :: forall (m :: * -> *) w a.
Monad m =>
LedgerProvider w m
-> Network
-> (Session w m -> m (Either ConfirmationFailure a))
-> m (Either ConfirmationFailure a)
readScope LedgerProvider w m
provider Network
network Session w m -> m (Either ConfirmationFailure a)
action = do
    acquired <- LedgerProvider w m
-> forall a.
   Acquisition -> (Session w m -> m a) -> m (Either AcquireFailure a)
forall w (m :: * -> *).
LedgerProvider w m
-> forall a.
   Acquisition -> (Session w m -> m a) -> m (Either AcquireFailure a)
acquire LedgerProvider w m
provider (Network -> Acquisition
Latest Network
network) Session w m -> m (Either ConfirmationFailure a)
action
    pure (either (Left . ConfirmationAcquireFailure) id acquired)

-- | IO cancellation preserves the original wait failure and other exceptions.
newIOConfirmationRuntime :: IO (ConfirmationRuntime IO)
newIOConfirmationRuntime :: IO (ConfirmationRuntime IO)
newIOConfirmationRuntime = do
    clock <- IO WaitClock
startWaitClock
    pure
        ConfirmationRuntime
            { currentPosixMs = round . (* 1000) <$> getPOSIXTime
            , pausePolling = \Int
seconds -> Int -> IO ()
threadDelay (Int
seconds Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000000)
            , attemptWindowRead = \IO a
action -> do
                result <- IO a -> IO (Either SomeException a)
forall a. IO a -> IO (Either SomeException a)
tryOutcome IO a
action
                pure $ case result of
                    Right a
answer -> a -> Either ConfirmationFailure a
forall a b. b -> Either a b
Right a
answer
                    Left SomeException
failure -> case SomeException -> Maybe NetworkTimeFailure
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
failure of
                        Just NetworkTimeFailure
timeFailure -> ConfirmationFailure -> Either ConfirmationFailure a
forall a b. a -> Either a b
Left (NetworkTimeFailure -> ConfirmationFailure
ConfirmationTimeFailure NetworkTimeFailure
timeFailure)
                        Maybe NetworkTimeFailure
Nothing ->
                            ConfirmationFailure -> Either ConfirmationFailure a
forall a b. a -> Either a b
Left
                                ( ReadFailure -> ConfirmationFailure
ConfirmationReadFailure
                                    (Text -> ReadFailure
BackendReadFailure (String -> Text
Text.pack (SomeException -> String
forall a. Show a => a -> String
show SomeException
failure)))
                                )
            , boundedConfirmation = \TxId
tid Int
bound IO (Either Integer a)
action ->
                IO a -> IO (Either WaitFailure a)
forall e a. Exception e => IO a -> IO (Either e a)
try
                    (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
SessionConfirmationWait TxId
tid Int
bound IO (Either Integer a)
action)
            }

{- | Production IO callers rethrow wait failures as infrastructure exceptions,
retaining the existing timeout identity instead of publishing a refusal.
-}
awaitTransaction
    :: LedgerProvider w IO -> Network -> ConwayTx -> IO ()
awaitTransaction :: forall w. LedgerProvider w IO -> Network -> ConwayTx -> IO ()
awaitTransaction LedgerProvider w IO
provider Network
network ConwayTx
tx = do
    runtime <- IO (ConfirmationRuntime IO)
newIOConfirmationRuntime
    result <- confirmTransaction runtime provider network tx
    case result of
        Left (ConfirmationWaitFailure WaitFailure
failure) -> WaitFailure -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO WaitFailure
failure
        Left ConfirmationFailure
failure -> ConfirmationFailure -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO ConfirmationFailure
failure
        Right () -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

showService :: Services.ServiceFailure -> Text.Text
showService :: ServiceFailure -> Text
showService = String -> Text
Text.pack (String -> Text)
-> (ServiceFailure -> String) -> ServiceFailure -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServiceFailure -> String
forall a. Show a => a -> String
show