{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Provide infrastructure-independent "handlers" for posting transactions and following the chain.
--
-- This module encapsulates the transformation logic between cardano transactions and `HydraNode` abstractions
-- `PostChainTx` and `OnChainTx`, and maintenance of on-chain relevant state.
module Hydra.Chain.Direct.Handlers where

import Hydra.Prelude

import Cardano.Api.UTxO qualified as UTxO
import Cardano.Ledger.Api (ppMaxValSizeL)
import Cardano.Ledger.BaseTypes (ProtVer (..))
import Cardano.Ledger.Binary (serialize)
import Cardano.Ledger.Core (PParams, ppMaxTxSizeL, ppProtocolVersionL)
import Cardano.Slotting.Slot (SlotNo (..))
import Control.Concurrent.Class.MonadSTM (modifyTVar, writeTVar)
import Control.Lens ((^.))
import Control.Monad.Class.MonadSTM (throwSTM)
import Control.Tracer.JSON (Tracer, traceWith)
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as BSL
import Data.Map.Strict qualified as Map
import Hydra.Cardano.Api (
  Address,
  BlockHeader,
  ByronAddr,
  ChainPoint (..),
  LedgerEra,
  NetworkId,
  Tx,
  TxId,
  TxIn,
  TxOut,
  UTxO,
  Value,
  calculateMinimumUTxO,
  chainPointToSlotNo,
  findTxOutByAddress,
  fromCtxUTxOTxOut,
  getChainPoint,
  getTxBody,
  getTxId,
  liftEither,
  selectLovelace,
  serialiseToCBOR,
  shelleyBasedEra,
  throwError,
  toCtxUTxOTxOut,
  toLedgerValue,
  toShelleyNetwork,
  txOutAddress,
  txOutValue,
  txOuts',
  pattern ByronAddressInEra,
 )
import Hydra.Chain (
  Chain (..),
  ChainCallback,
  ChainEvent (..),
  ChainStateHistory,
  OnChainTx (..),
  PostChainTx (..),
  PostTxError (..),
  currentState,
  pushNewState,
  rollbackHistory,
 )
import Hydra.Chain.ChainState (
  ChainSlot,
  ChainStateType,
  IsChainState,
 )
import Hydra.Chain.Direct.State (
  ChainContext (..),
  ChainStateAt (..),
  PartialFanoutError (..),
  chainSlotFromPoint,
  close,
  contest,
  decrement,
  dryRunIncrementTx,
  fanout,
  finalPartialFanout,
  getKnownUTxO,
  increment,
  initialize,
  partialFanoutFromPlan,
  preparePartialFanout,
  recover,
 )
import Hydra.Chain.Direct.TimeHandle (TimeHandle (..))
import Hydra.Chain.Direct.Wallet (
  ErrCoverFee (..),
  TinyWallet (..),
  TinyWalletLog,
 )
import Hydra.Ledger.Cardano (adjustUTxO, fromChainSlot)
import Hydra.Ledger.Cardano.Evaluate (EvaluationError (..), EvaluationReport, renderEvaluationReport)
import Hydra.Node.Util (checkNonADAAssetsUTxO)
import Hydra.Tx (
  CommitBlueprintTx (..),
  ConfirmedSnapshot,
  HeadId,
  HeadParameters (..),
  IsTx (..),
  UTxOType,
  headSeedToTxIn,
 )
import Hydra.Tx.Accumulator qualified as Accumulator
import Hydra.Tx.ContestationPeriod (toNominalDiffTime)
import Hydra.Tx.Deposit (DepositObservation (..), decodeDepositDatum, depositAddress, depositTx, observeDepositTx)
import Hydra.Tx.DepositPeriod (DepositPeriod)
import Hydra.Tx.DepositPeriod qualified as DepositPeriod
import Hydra.Tx.IsTx (combinedUTxO)
import Hydra.Tx.Observe (
  CloseObservation (..),
  ContestObservation (..),
  DecrementObservation (..),
  FanoutObservation (..),
  HeadObservation (..),
  IncrementObservation (..),
  InitObservation (..),
  PartialFanoutObservation (..),
  observeHeadTx,
 )
import Hydra.Tx.Recover (RecoverObservation (..))
import Hydra.Tx.Snapshot (getSnapshot, snapshotUTxO)
import System.IO.Error (userError)

-- | Handle of a mutable local chain state that is kept in the direct chain layer.
data LocalChainState m tx = LocalChainState
  { forall (m :: * -> *) tx.
LocalChainState m tx -> STM m (ChainStateType tx)
getLatest :: STM m (ChainStateType tx)
  , forall (m :: * -> *) tx.
LocalChainState m tx -> ChainStateType tx -> STM m ()
pushNew :: ChainStateType tx -> STM m ()
  , forall (m :: * -> *) tx.
LocalChainState m tx -> ChainSlot -> STM m (ChainStateType tx)
rollback :: ChainSlot -> STM m (ChainStateType tx)
  , forall (m :: * -> *) tx.
LocalChainState m tx -> STM m (ChainStateHistory tx)
history :: STM m (ChainStateHistory tx)
  }

-- | Initialize a new local chain state from a given chain state history.
newLocalChainState ::
  forall m tx.
  (IsChainState tx, MonadLabelledSTM m) =>
  ChainStateHistory tx ->
  m (LocalChainState m tx)
newLocalChainState :: forall (m :: * -> *) tx.
(IsChainState tx, MonadLabelledSTM m) =>
ChainStateHistory tx -> m (LocalChainState m tx)
newLocalChainState ChainStateHistory tx
chainState = do
  TVar m (ChainStateHistory tx)
tv <- String -> ChainStateHistory tx -> m (TVar m (ChainStateHistory tx))
forall (m :: * -> *) a.
MonadLabelledSTM m =>
String -> a -> m (TVar m a)
newLabelledTVarIO String
"local-chain-state" ChainStateHistory tx
chainState
  LocalChainState m tx -> m (LocalChainState m tx)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    LocalChainState
      { $sel:getLatest:LocalChainState :: STM m (ChainStateType tx)
getLatest = TVar m (ChainStateHistory tx) -> STM m (ChainStateType tx)
getLatest TVar m (ChainStateHistory tx)
tv
      , $sel:pushNew:LocalChainState :: ChainStateType tx -> STM m ()
pushNew = TVar m (ChainStateHistory tx) -> ChainStateType tx -> STM m ()
pushNew TVar m (ChainStateHistory tx)
tv
      , $sel:rollback:LocalChainState :: ChainSlot -> STM m (ChainStateType tx)
rollback = TVar m (ChainStateHistory tx)
-> ChainSlot -> STM m (ChainStateType tx)
rollback TVar m (ChainStateHistory tx)
tv
      , $sel:history:LocalChainState :: STM m (ChainStateHistory tx)
history = TVar m (ChainStateHistory tx) -> STM m (ChainStateHistory tx)
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m (ChainStateHistory tx)
tv
      }
 where
  -- REVIEW: why using `currentState` instead of `lastKnown` ???
  getLatest :: TVar m (ChainStateHistory tx) -> STM m (ChainStateType tx)
  getLatest :: TVar m (ChainStateHistory tx) -> STM m (ChainStateType tx)
getLatest TVar m (ChainStateHistory tx)
tv = ChainStateHistory tx -> ChainStateType tx
forall tx. ChainStateHistory tx -> ChainStateType tx
currentState (ChainStateHistory tx -> ChainStateType tx)
-> STM m (ChainStateHistory tx) -> STM m (ChainStateType tx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar m (ChainStateHistory tx) -> STM m (ChainStateHistory tx)
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m (ChainStateHistory tx)
tv

  pushNew :: TVar m (ChainStateHistory tx) -> ChainStateType tx -> STM m ()
  pushNew :: TVar m (ChainStateHistory tx) -> ChainStateType tx -> STM m ()
pushNew TVar m (ChainStateHistory tx)
tv ChainStateType tx
cs =
    TVar m (ChainStateHistory tx)
-> (ChainStateHistory tx -> ChainStateHistory tx) -> STM m ()
forall a. TVar m a -> (a -> a) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
TVar m a -> (a -> a) -> STM m ()
modifyTVar TVar m (ChainStateHistory tx)
tv (ChainStateType tx -> ChainStateHistory tx -> ChainStateHistory tx
forall tx.
IsChainState tx =>
ChainStateType tx -> ChainStateHistory tx -> ChainStateHistory tx
pushNewState ChainStateType tx
cs)

  rollback :: TVar m (ChainStateHistory tx) -> ChainSlot -> STM m (ChainStateType tx)
  rollback :: TVar m (ChainStateHistory tx)
-> ChainSlot -> STM m (ChainStateType tx)
rollback TVar m (ChainStateHistory tx)
tv ChainSlot
chainSlot = do
    ChainStateHistory tx
rolledBack <-
      TVar m (ChainStateHistory tx) -> STM m (ChainStateHistory tx)
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m (ChainStateHistory tx)
tv
        STM m (ChainStateHistory tx)
-> (ChainStateHistory tx -> ChainStateHistory tx)
-> STM m (ChainStateHistory tx)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ChainSlot -> ChainStateHistory tx -> ChainStateHistory tx
forall tx.
IsChainState tx =>
ChainSlot -> ChainStateHistory tx -> ChainStateHistory tx
rollbackHistory ChainSlot
chainSlot
    TVar m (ChainStateHistory tx) -> ChainStateHistory tx -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m (ChainStateHistory tx)
tv ChainStateHistory tx
rolledBack
    ChainStateType tx -> STM m (ChainStateType tx)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainStateHistory tx -> ChainStateType tx
forall tx. ChainStateHistory tx -> ChainStateType tx
currentState ChainStateHistory tx
rolledBack)

-- * Posting Transactions

-- | A callback used to actually submit a transaction to the chain.
type SubmitTx m = Tx -> m ()

-- | A way to acquire a 'TimeHandle'
type GetTimeHandle m = m TimeHandle

-- | Create a `Chain` component for posting "real" cardano transactions.
--
-- This component does not actually interact with a cardano-node, but creates
-- cardano transactions from `PostChainTx` transactions emitted by a
-- `HydraNode`, balancing and signing them using given `TinyWallet`, before
-- handing it off to the given 'SubmitTx' callback. There is also a 'draftTx'
-- option for drafting a commit tx on behalf of the user using their selected
-- utxo.
--
-- NOTE: Given the constraints on `m` this function should work within `IOSim`
-- and does not require any actual `IO` to happen which makes it highly suitable
-- for simulations and testing.
mkChain ::
  (MonadSTM m, MonadThrow (STM m)) =>
  Tracer m CardanoChainLog ->
  -- | Means to acquire a new 'TimeHandle'.
  GetTimeHandle m ->
  TinyWallet m ->
  ChainContext ->
  -- | Configured deposit period, bounding the validity of deposit txs.
  DepositPeriod ->
  LocalChainState m Tx ->
  SubmitTx m ->
  Chain Tx m
mkChain :: forall (m :: * -> *).
(MonadSTM m, MonadThrow (STM m)) =>
Tracer m CardanoChainLog
-> GetTimeHandle m
-> TinyWallet m
-> ChainContext
-> DepositPeriod
-> LocalChainState m Tx
-> SubmitTx m
-> Chain Tx m
mkChain Tracer m CardanoChainLog
tracer GetTimeHandle m
queryTimeHandle TinyWallet m
wallet ChainContext
ctx DepositPeriod
depositPeriod LocalChainState{STM m (ChainStateType Tx)
$sel:getLatest:LocalChainState :: forall (m :: * -> *) tx.
LocalChainState m tx -> STM m (ChainStateType tx)
getLatest :: STM m (ChainStateType Tx)
getLatest} SubmitTx m
submitTx =
  Chain
    { $sel:postTx:Chain :: MonadThrow m => PostChainTx Tx -> m ()
postTx = \PostChainTx Tx
tx -> do
        ChainStateAt{UTxO Era
spendableUTxO :: UTxO Era
$sel:spendableUTxO:ChainStateAt :: ChainStateAt -> UTxO Era
spendableUTxO} <- STM m ChainStateAt -> m ChainStateAt
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM m (ChainStateType Tx)
STM m ChainStateAt
getLatest
        Tracer m CardanoChainLog -> CardanoChainLog -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m CardanoChainLog
tracer (CardanoChainLog -> m ()) -> CardanoChainLog -> m ()
forall a b. (a -> b) -> a -> b
$ ToPost{$sel:toPost:ToPost :: PostChainTx Tx
toPost = PostChainTx Tx
tx}
        TimeHandle
timeHandle <- GetTimeHandle m
queryTimeHandle
        let TimeHandle{UTCTime -> Either Text SlotNo
slotFromUTCTime :: UTCTime -> Either Text SlotNo
$sel:slotFromUTCTime:TimeHandle :: TimeHandle -> UTCTime -> Either Text SlotNo
slotFromUTCTime} = TimeHandle
timeHandle
            resolveHeadInfo :: HeadSeed -> UTCTime -> m (SlotNo, TxIn)
resolveHeadInfo HeadSeed
headSeed UTCTime
deadline = do
              SlotNo
slot <- (Text -> m SlotNo)
-> (SlotNo -> m SlotNo) -> Either Text SlotNo -> m SlotNo
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\Text
err -> PostTxError Tx -> m SlotNo
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (ContestationDeadlineOutsideTimeHorizon{$sel:failureReason:NoSeedInput :: Text
failureReason = Text
err} :: PostTxError Tx)) SlotNo -> m SlotNo
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text SlotNo -> m SlotNo) -> Either Text SlotNo -> m SlotNo
forall a b. (a -> b) -> a -> b
$ UTCTime -> Either Text SlotNo
slotFromUTCTime UTCTime
deadline
              TxIn
tin <- m TxIn -> (TxIn -> m TxIn) -> Maybe TxIn -> m TxIn
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (PostTxError Tx -> m TxIn
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (InvalidSeed{HeadSeed
headSeed :: HeadSeed
$sel:headSeed:NoSeedInput :: HeadSeed
headSeed} :: PostTxError Tx)) TxIn -> m TxIn
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe TxIn -> m TxIn) -> Maybe TxIn -> m TxIn
forall a b. (a -> b) -> a -> b
$ HeadSeed -> Maybe TxIn
forall (m :: * -> *). MonadFail m => HeadSeed -> m TxIn
headSeedToTxIn HeadSeed
headSeed
              (SlotNo, TxIn) -> m (SlotNo, TxIn)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SlotNo
slot, TxIn
tin)
        Tx
vtx <- case PostChainTx Tx
tx of
          FanoutTx{UTxOType Tx
utxo :: UTxOType Tx
$sel:utxo:InitTx :: forall tx. PostChainTx tx -> UTxOType tx
utxo, Maybe (UTxOType Tx)
utxoToCommit :: Maybe (UTxOType Tx)
$sel:utxoToCommit:InitTx :: forall tx. PostChainTx tx -> Maybe (UTxOType tx)
utxoToCommit, Maybe (UTxOType Tx)
utxoToDecommit :: Maybe (UTxOType Tx)
$sel:utxoToDecommit:InitTx :: forall tx. PostChainTx tx -> Maybe (UTxOType tx)
utxoToDecommit, HeadSeed
headSeed :: HeadSeed
$sel:headSeed:InitTx :: forall tx. PostChainTx tx -> HeadSeed
headSeed, UTCTime
contestationDeadline :: UTCTime
$sel:contestationDeadline:InitTx :: forall tx. PostChainTx tx -> UTCTime
contestationDeadline} -> do
            (SlotNo
deadlineSlot, TxIn
seedTxIn) <- HeadSeed -> UTCTime -> m (SlotNo, TxIn)
resolveHeadInfo HeadSeed
headSeed UTCTime
contestationDeadline
            -- 'combinedUTxO' is the set 'Hydra.Tx.Fanout.fanoutTx' counts in its
            -- redeemer and proves membership for, so its size is the exact gate
            -- on whether that transaction is worth building. It is also the set
            -- the closed datum commits to, so it doubles as the proof base of the
            -- partial fallback.
            let fullUTxO :: UTxO Era
fullUTxO = UTxO Era -> Maybe (UTxO Era) -> Maybe (UTxO Era) -> UTxO Era
forall a. Monoid a => a -> Maybe a -> Maybe a -> a
combinedUTxO UTxOType Tx
UTxO Era
utxo Maybe (UTxOType Tx)
Maybe (UTxO Era)
utxoToCommit Maybe (UTxOType Tx)
Maybe (UTxO Era)
utxoToDecommit
                preferred :: Maybe Tx
preferred
                  | Int -> Bool
canBeVerifiedOnChain (UTxO Era -> Int
forall era. UTxO era -> Int
UTxO.size UTxO Era
fullUTxO) =
                      Either FanoutTxError Tx -> Maybe Tx
forall l r. Either l r -> Maybe r
rightToMaybe (Either FanoutTxError Tx -> Maybe Tx)
-> Either FanoutTxError Tx -> Maybe Tx
forall a b. (a -> b) -> a -> b
$ ChainContext
-> UTxO Era
-> TxIn
-> UTxO Era
-> Maybe (UTxO Era)
-> Maybe (UTxO Era)
-> SlotNo
-> Either FanoutTxError Tx
fanout ChainContext
ctx UTxO Era
spendableUTxO TxIn
seedTxIn UTxOType Tx
UTxO Era
utxo Maybe (UTxOType Tx)
Maybe (UTxO Era)
utxoToCommit Maybe (UTxOType Tx)
Maybe (UTxO Era)
utxoToDecommit SlotNo
deadlineSlot
                  | Bool
otherwise = Maybe Tx
forall a. Maybe a
Nothing
            Tracer m CardanoChainLog
-> TinyWallet m
-> ChainContext
-> UTxO Era
-> TxIn
-> Maybe Tx
-> UTxO Era
-> UTxO Era
-> Int
-> SlotNo
-> m Tx
forall (m :: * -> *).
MonadThrow m =>
Tracer m CardanoChainLog
-> TinyWallet m
-> ChainContext
-> UTxO Era
-> TxIn
-> Maybe Tx
-> UTxO Era
-> UTxO Era
-> Int
-> SlotNo
-> m Tx
findFittingFanoutTx
              Tracer m CardanoChainLog
tracer
              TinyWallet m
wallet
              ChainContext
ctx
              UTxO Era
spendableUTxO
              TxIn
seedTxIn
              Maybe Tx
preferred
              UTxO Era
fullUTxO
              UTxO Era
fullUTxO
              (UTxO Era -> Int
forall era. UTxO era -> Int
UTxO.size UTxO Era
fullUTxO Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
              SlotNo
deadlineSlot
              m Tx -> (Tx -> m Tx) -> m Tx
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TinyWallet m -> ChainContext -> UTxO Era -> UTxO Era -> Tx -> m Tx
forall (m :: * -> *).
MonadThrow m =>
TinyWallet m -> ChainContext -> UTxO Era -> UTxO Era -> Tx -> m Tx
finalizeTx TinyWallet m
wallet ChainContext
ctx UTxO Era
spendableUTxO UTxO Era
forall a. Monoid a => a
mempty
          FinalPartialFanoutTx{UTxOType Tx
utxoToDistribute :: UTxOType Tx
$sel:utxoToDistribute:InitTx :: forall tx. PostChainTx tx -> UTxOType tx
utxoToDistribute, HeadSeed
$sel:headSeed:InitTx :: forall tx. PostChainTx tx -> HeadSeed
headSeed :: HeadSeed
headSeed, UTCTime
$sel:contestationDeadline:InitTx :: forall tx. PostChainTx tx -> UTCTime
contestationDeadline :: UTCTime
contestationDeadline} -> do
            (SlotNo
deadlineSlot, TxIn
seedTxIn) <- HeadSeed -> UTCTime -> m (SlotNo, TxIn)
resolveHeadInfo HeadSeed
headSeed UTCTime
contestationDeadline
            let preferred :: Maybe Tx
preferred
                  | Int -> Bool
canBeVerifiedOnChain (UTxO Era -> Int
forall era. UTxO era -> Int
UTxO.size UTxOType Tx
UTxO Era
utxoToDistribute) =
                      Either PartialFanoutError Tx -> Maybe Tx
forall l r. Either l r -> Maybe r
rightToMaybe (Either PartialFanoutError Tx -> Maybe Tx)
-> Either PartialFanoutError Tx -> Maybe Tx
forall a b. (a -> b) -> a -> b
$ ChainContext
-> UTxO Era
-> TxIn
-> UTxO Era
-> SlotNo
-> Either PartialFanoutError Tx
finalPartialFanout ChainContext
ctx UTxO Era
spendableUTxO TxIn
seedTxIn UTxOType Tx
UTxO Era
utxoToDistribute SlotNo
deadlineSlot
                  | Bool
otherwise = Maybe Tx
forall a. Maybe a
Nothing
            Tracer m CardanoChainLog
-> TinyWallet m
-> ChainContext
-> UTxO Era
-> TxIn
-> Maybe Tx
-> UTxO Era
-> UTxO Era
-> Int
-> SlotNo
-> m Tx
forall (m :: * -> *).
MonadThrow m =>
Tracer m CardanoChainLog
-> TinyWallet m
-> ChainContext
-> UTxO Era
-> TxIn
-> Maybe Tx
-> UTxO Era
-> UTxO Era
-> Int
-> SlotNo
-> m Tx
findFittingFanoutTx
              Tracer m CardanoChainLog
tracer
              TinyWallet m
wallet
              ChainContext
ctx
              UTxO Era
spendableUTxO
              TxIn
seedTxIn
              Maybe Tx
preferred
              UTxOType Tx
UTxO Era
utxoToDistribute
              UTxOType Tx
UTxO Era
utxoToDistribute
              (UTxO Era -> Int
forall era. UTxO era -> Int
UTxO.size UTxOType Tx
UTxO Era
utxoToDistribute Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
              SlotNo
deadlineSlot
              m Tx -> (Tx -> m Tx) -> m Tx
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TinyWallet m -> ChainContext -> UTxO Era -> UTxO Era -> Tx -> m Tx
forall (m :: * -> *).
MonadThrow m =>
TinyWallet m -> ChainContext -> UTxO Era -> UTxO Era -> Tx -> m Tx
finalizeTx TinyWallet m
wallet ChainContext
ctx UTxO Era
spendableUTxO UTxO Era
forall a. Monoid a => a
mempty
          PartialFanoutTx{UTxOType Tx
$sel:utxoToDistribute:InitTx :: forall tx. PostChainTx tx -> UTxOType tx
utxoToDistribute :: UTxOType Tx
utxoToDistribute, UTxOType Tx
utxoForProof :: UTxOType Tx
$sel:utxoForProof:InitTx :: forall tx. PostChainTx tx -> UTxOType tx
utxoForProof, HeadSeed
$sel:headSeed:InitTx :: forall tx. PostChainTx tx -> HeadSeed
headSeed :: HeadSeed
headSeed, UTCTime
$sel:contestationDeadline:InitTx :: forall tx. PostChainTx tx -> UTCTime
contestationDeadline :: UTCTime
contestationDeadline} -> do
            (SlotNo
deadlineSlot, TxIn
seedTxIn) <- HeadSeed -> UTCTime -> m (SlotNo, TxIn)
resolveHeadInfo HeadSeed
headSeed UTCTime
contestationDeadline
            -- Non-final partial fanout: no preferred tx, always chunk from the
            -- user-selected set. The whole selection may be distributed in one
            -- tx (size, not size-1): the selection is a strict subset of the
            -- head's remaining UTxO, so the unselected remainder stays in the
            -- accumulator and 'mustNotBeLastBatch' is satisfied regardless of
            -- chunk size.
            --
            -- 'Hydra.HeadLogic.nextFanoutStep' keeps it that way for every
            -- producer of this transaction: a target covering the whole
            -- remainder becomes a full fanout or the final step instead.
            --
            -- Nothing breaks if it ever stops holding: 'mustNotBeLastBatch'
            -- rejects a chunk that would empty the head, so the search settles
            -- for a smaller one and the head needs another transaction.
            Tracer m CardanoChainLog
-> TinyWallet m
-> ChainContext
-> UTxO Era
-> TxIn
-> Maybe Tx
-> UTxO Era
-> UTxO Era
-> Int
-> SlotNo
-> m Tx
forall (m :: * -> *).
MonadThrow m =>
Tracer m CardanoChainLog
-> TinyWallet m
-> ChainContext
-> UTxO Era
-> TxIn
-> Maybe Tx
-> UTxO Era
-> UTxO Era
-> Int
-> SlotNo
-> m Tx
findFittingFanoutTx
              Tracer m CardanoChainLog
tracer
              TinyWallet m
wallet
              ChainContext
ctx
              UTxO Era
spendableUTxO
              TxIn
seedTxIn
              Maybe Tx
forall a. Maybe a
Nothing
              UTxOType Tx
UTxO Era
utxoForProof
              UTxOType Tx
UTxO Era
utxoToDistribute
              (UTxO Era -> Int
forall era. UTxO era -> Int
UTxO.size UTxOType Tx
UTxO Era
utxoToDistribute)
              SlotNo
deadlineSlot
              m Tx -> (Tx -> m Tx) -> m Tx
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TinyWallet m -> ChainContext -> UTxO Era -> UTxO Era -> Tx -> m Tx
forall (m :: * -> *).
MonadThrow m =>
TinyWallet m -> ChainContext -> UTxO Era -> UTxO Era -> Tx -> m Tx
finalizeTx TinyWallet m
wallet ChainContext
ctx UTxO Era
spendableUTxO UTxO Era
forall a. Monoid a => a
mempty
          InitTx{[OnChainId]
participants :: [OnChainId]
$sel:participants:InitTx :: forall tx. PostChainTx tx -> [OnChainId]
participants, HeadParameters
headParameters :: HeadParameters
$sel:headParameters:InitTx :: forall tx. PostChainTx tx -> HeadParameters
headParameters} -> do
            TxIn
seedInput <-
              STM m TxIn -> m TxIn
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m TxIn -> m TxIn) -> STM m TxIn -> m TxIn
forall a b. (a -> b) -> a -> b
$
                TinyWallet m -> STM m (Maybe TxIn)
forall (m :: * -> *). TinyWallet m -> STM m (Maybe TxIn)
getSeedInput TinyWallet m
wallet STM m (Maybe TxIn) -> (Maybe TxIn -> STM m TxIn) -> STM m TxIn
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STM m TxIn -> (TxIn -> STM m TxIn) -> Maybe TxIn -> STM m TxIn
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (PostTxError Tx -> STM m TxIn
forall (m :: * -> *) e a.
(MonadSTM m, MonadThrow (STM m), Exception e) =>
e -> STM m a
throwSTM (forall tx. PostTxError tx
NoSeedInput @Tx)) TxIn -> STM m TxIn
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
            PParams ConwayEra
pparams <- TinyWallet m -> m (PParams LedgerEra)
forall (m :: * -> *). TinyWallet m -> m (PParams LedgerEra)
getPParams TinyWallet m
wallet
            TinyWallet m -> ChainContext -> UTxO Era -> UTxO Era -> Tx -> m Tx
forall (m :: * -> *).
MonadThrow m =>
TinyWallet m -> ChainContext -> UTxO Era -> UTxO Era -> Tx -> m Tx
finalizeTx TinyWallet m
wallet ChainContext
ctx UTxO Era
spendableUTxO UTxO Era
forall a. Monoid a => a
mempty (Tx -> m Tx) -> Tx -> m Tx
forall a b. (a -> b) -> a -> b
$
              ChainContext
-> PParams LedgerEra -> TxIn -> [OnChainId] -> HeadParameters -> Tx
initialize ChainContext
ctx PParams ConwayEra
PParams LedgerEra
pparams TxIn
seedInput [OnChainId]
participants HeadParameters
headParameters
          PostChainTx Tx
_ ->
            STM m Tx -> m Tx
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (TimeHandle
-> ChainContext -> UTxOType Tx -> PostChainTx Tx -> STM m Tx
forall (m :: * -> *).
(MonadSTM m, MonadThrow (STM m)) =>
TimeHandle
-> ChainContext -> UTxOType Tx -> PostChainTx Tx -> STM m Tx
prepareTxToPost TimeHandle
timeHandle ChainContext
ctx UTxOType Tx
UTxO Era
spendableUTxO PostChainTx Tx
tx)
              m Tx -> (Tx -> m Tx) -> m Tx
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TinyWallet m -> ChainContext -> UTxO Era -> UTxO Era -> Tx -> m Tx
forall (m :: * -> *).
MonadThrow m =>
TinyWallet m -> ChainContext -> UTxO Era -> UTxO Era -> Tx -> m Tx
finalizeTx TinyWallet m
wallet ChainContext
ctx UTxO Era
spendableUTxO UTxO Era
forall a. Monoid a => a
mempty
        SubmitTx m
submitTx Tx
vtx
    , $sel:draftDepositTx:Chain :: MonadThrow m =>
HeadId
-> PParams LedgerEra
-> ConfirmedSnapshot Tx
-> CommitBlueprintTx Tx
-> UTCTime
-> Maybe AddressInEra
-> m (Either (PostTxError Tx) Tx)
draftDepositTx = \HeadId
headId PParams LedgerEra
pparams ConfirmedSnapshot Tx
currentSnapshot CommitBlueprintTx Tx
commitBlueprintTx UTCTime
deadline Maybe AddressInEra
changeAddress -> do
        let CommitBlueprintTx{UTxOType Tx
lookupUTxO :: UTxOType Tx
$sel:lookupUTxO:CommitBlueprintTx :: forall tx. CommitBlueprintTx tx -> UTxOType tx
lookupUTxO} = CommitBlueprintTx Tx
commitBlueprintTx
        ChainStateAt{UTxO Era
$sel:spendableUTxO:ChainStateAt :: ChainStateAt -> UTxO Era
spendableUTxO :: UTxO Era
spendableUTxO} <- STM m ChainStateAt -> m ChainStateAt
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM m (ChainStateType Tx)
STM m ChainStateAt
getLatest
        TimeHandle{Either Text PointInTime
currentPointInTime :: Either Text PointInTime
$sel:currentPointInTime:TimeHandle :: TimeHandle -> Either Text PointInTime
currentPointInTime} <- GetTimeHandle m
queryTimeHandle
        -- XXX: What an error handling mess
        ExceptT (PostTxError Tx) m Tx -> m (Either (PostTxError Tx) Tx)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT (PostTxError Tx) m Tx -> m (Either (PostTxError Tx) Tx))
-> ExceptT (PostTxError Tx) m Tx -> m (Either (PostTxError Tx) Tx)
forall a b. (a -> b) -> a -> b
$
          do
            Either (PostTxError Tx) () -> ExceptT (PostTxError Tx) m ()
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either (PostTxError Tx) () -> ExceptT (PostTxError Tx) m ())
-> Either (PostTxError Tx) () -> ExceptT (PostTxError Tx) m ()
forall a b. (a -> b) -> a -> b
$ do
              UTxO Era -> Either (PostTxError Tx) ()
rejectByronAddresses UTxOType Tx
UTxO Era
lookupUTxO
              PParams LedgerEra -> UTxO Era -> Either (PostTxError Tx) ()
rejectLowDeposits PParams LedgerEra
pparams UTxOType Tx
UTxO Era
lookupUTxO
            (SlotNo
currentSlot, UTCTime
currentTime) <- case Either Text PointInTime
currentPointInTime of
              Left Text
failureReason -> PostTxError Tx -> ExceptT (PostTxError Tx) m PointInTime
forall a. PostTxError Tx -> ExceptT (PostTxError Tx) m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError FailedToConstructDepositTx{Text
$sel:failureReason:NoSeedInput :: Text
failureReason :: Text
failureReason}
              Right (SlotNo
s, UTCTime
t) -> PointInTime -> ExceptT (PostTxError Tx) m PointInTime
forall a. a -> ExceptT (PostTxError Tx) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SlotNo
s, UTCTime
t)
            -- NOTE: A deposit only activates at @created + depositActivation@,
            -- with @created@ the upper validity bound set here, and expires at
            -- @deadline - depositPeriod@. Capping the grace time at half the
            -- deposit period keeps at least the other half as active window;
            -- the deadline term guards against deadlines closer than the
            -- @depositActivation + 2 * depositPeriod@ the API server uses.
            let untilDeadline :: NominalDiffTime
untilDeadline = UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
deadline UTCTime
currentTime
            let graceTime :: NominalDiffTime
graceTime = NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Ord a => a -> a -> a
min NominalDiffTime
maxGraceTime (NominalDiffTime -> NominalDiffTime)
-> NominalDiffTime -> NominalDiffTime
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Ord a => a -> a -> a
min (NominalDiffTime
untilDeadline NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Fractional a => a -> a -> a
/ NominalDiffTime
2) (DepositPeriod -> NominalDiffTime
DepositPeriod.toNominalDiffTime DepositPeriod
depositPeriod NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Fractional a => a -> a -> a
/ NominalDiffTime
2)
            -- NOTE: But also not make it smaller than 10 slots.
            let validBeforeSlot :: SlotNo
validBeforeSlot = SlotNo
currentSlot SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ Integer -> SlotNo
forall a. Num a => Integer -> a
fromInteger (NominalDiffTime -> Integer
forall b. Integral b => NominalDiffTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate NominalDiffTime
graceTime Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
`max` Integer
10)
            let depositDraftTx :: Tx
depositDraftTx = HasCallStack =>
NetworkId
-> PParams LedgerEra
-> HeadId
-> CommitBlueprintTx Tx
-> SlotNo
-> UTCTime
-> Maybe AddressInEra
-> Tx
NetworkId
-> PParams LedgerEra
-> HeadId
-> CommitBlueprintTx Tx
-> SlotNo
-> UTCTime
-> Maybe AddressInEra
-> Tx
depositTx (ChainContext -> NetworkId
networkId ChainContext
ctx) PParams LedgerEra
pparams HeadId
headId CommitBlueprintTx Tx
commitBlueprintTx SlotNo
validBeforeSlot UTCTime
deadline Maybe AddressInEra
changeAddress
            PParams ConwayEra
l1PParams <- m (PParams ConwayEra)
-> ExceptT (PostTxError Tx) m (PParams ConwayEra)
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (PostTxError Tx) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (PParams ConwayEra)
 -> ExceptT (PostTxError Tx) m (PParams ConwayEra))
-> m (PParams ConwayEra)
-> ExceptT (PostTxError Tx) m (PParams ConwayEra)
forall a b. (a -> b) -> a -> b
$ TinyWallet m -> m (PParams LedgerEra)
forall (m :: * -> *). TinyWallet m -> m (PParams LedgerEra)
getPParams TinyWallet m
wallet
            Either (PostTxError Tx) () -> ExceptT (PostTxError Tx) m ()
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either (PostTxError Tx) () -> ExceptT (PostTxError Tx) m ())
-> Either (PostTxError Tx) () -> ExceptT (PostTxError Tx) m ()
forall a b. (a -> b) -> a -> b
$ PParams LedgerEra
-> ChainContext
-> UTxO Era
-> HeadId
-> ConfirmedSnapshot Tx
-> Tx
-> SlotNo
-> Either (PostTxError Tx) ()
rejectOversizedDeposit PParams ConwayEra
PParams LedgerEra
l1PParams ChainContext
ctx UTxO Era
spendableUTxO HeadId
headId ConfirmedSnapshot Tx
currentSnapshot Tx
depositDraftTx SlotNo
validBeforeSlot
            Tx
finalizedTx <- m Tx -> ExceptT (PostTxError Tx) m Tx
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (PostTxError Tx) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Tx -> ExceptT (PostTxError Tx) m Tx)
-> m Tx -> ExceptT (PostTxError Tx) m Tx
forall a b. (a -> b) -> a -> b
$ TinyWallet m -> ChainContext -> UTxO Era -> UTxO Era -> Tx -> m Tx
forall (m :: * -> *).
MonadThrow m =>
TinyWallet m -> ChainContext -> UTxO Era -> UTxO Era -> Tx -> m Tx
finalizeTx TinyWallet m
wallet ChainContext
ctx UTxO Era
spendableUTxO UTxOType Tx
UTxO Era
lookupUTxO Tx
depositDraftTx
            Either (PostTxError Tx) () -> ExceptT (PostTxError Tx) m ()
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either (PostTxError Tx) () -> ExceptT (PostTxError Tx) m ())
-> Either (PostTxError Tx) () -> ExceptT (PostTxError Tx) m ()
forall a b. (a -> b) -> a -> b
$ NetworkId -> Tx -> Either (PostTxError Tx) ()
rejectUnobservableDeposit (ChainContext -> NetworkId
networkId ChainContext
ctx) Tx
finalizedTx
            Tx -> ExceptT (PostTxError Tx) m Tx
forall a. a -> ExceptT (PostTxError Tx) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx
finalizedTx
    , -- Submit a cardano transaction to the cardano-node using the
      -- LocalTxSubmission protocol.
      MonadThrow m => SubmitTx m
SubmitTx m
submitTx :: SubmitTx m
$sel:submitTx:Chain :: MonadThrow m => SubmitTx m
submitTx
    , $sel:checkNonADAAssets:Chain :: ConfirmedSnapshot Tx -> Either Value ()
checkNonADAAssets = UTxO Era -> Either Value ()
checkNonADAAssetsUTxO (UTxO Era -> Either Value ())
-> (ConfirmedSnapshot Tx -> UTxO Era)
-> ConfirmedSnapshot Tx
-> Either Value ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Snapshot Tx -> UTxOType Tx
Snapshot Tx -> UTxO Era
forall tx. IsTx tx => Snapshot tx -> UTxOType tx
snapshotUTxO (Snapshot Tx -> UTxO Era)
-> (ConfirmedSnapshot Tx -> Snapshot Tx)
-> ConfirmedSnapshot Tx
-> UTxO Era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfirmedSnapshot Tx -> Snapshot Tx
forall tx. IsTx tx => ConfirmedSnapshot tx -> Snapshot tx
getSnapshot
    }

-- | Reject a drafted deposit the node would never observe on chain.
--
-- 'observeDepositTx' requires the deposit output's value to equal the value
-- recorded in its datum. Balancing tops every output up to its minimum ADA,
-- and the deposit output needs more than the deposited outputs themselves
-- because its inline datum embeds them. The datum keeps the original value,
-- so the finalized transaction would be ignored by every node, never reach
-- L2 and only be recoverable by hand. Report how much ADA is missing instead.
rejectUnobservableDeposit :: NetworkId -> Tx -> Either (PostTxError Tx) ()
rejectUnobservableDeposit :: NetworkId -> Tx -> Either (PostTxError Tx) ()
rejectUnobservableDeposit NetworkId
networkId Tx
tx
  | Maybe DepositObservation -> Bool
forall a. Maybe a -> Bool
isJust (NetworkId -> Tx -> Maybe DepositObservation
observeDepositTx NetworkId
networkId Tx
tx) = () -> Either (PostTxError Tx) ()
forall a b. b -> Either a b
Right ()
  | Bool
otherwise =
      case AddressInEra -> Tx -> Maybe (TxIn, TxOut CtxTx Era)
forall era.
AddressInEra era -> Tx era -> Maybe (TxIn, TxOut CtxTx era)
findTxOutByAddress (NetworkId -> AddressInEra
depositAddress NetworkId
networkId) Tx
tx of
        Just (TxIn
_, TxOut CtxTx Era
depositOut)
          | Just (HeadId
_, UTxO Era
deposited, POSIXTime
_) <- Network -> TxOut CtxUTxO -> Maybe (HeadId, UTxO Era, POSIXTime)
decodeDepositDatum (NetworkId -> Network
toShelleyNetwork NetworkId
networkId) (TxOut CtxTx Era -> TxOut CtxUTxO
forall era. TxOut CtxTx era -> TxOut CtxUTxO era
toCtxUTxOTxOut TxOut CtxTx Era
depositOut)
          , let providedValue :: Coin
providedValue = UTxO Era -> Coin
forall era. UTxO era -> Coin
UTxO.totalLovelace UTxO Era
deposited
          , let minimumValue :: Coin
minimumValue = Value -> Coin
selectLovelace (TxOut CtxTx Era -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxTx Era
depositOut)
          , Coin
providedValue Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
< Coin
minimumValue ->
              PostTxError Tx -> Either (PostTxError Tx) ()
forall a b. a -> Either a b
Left DepositTooLow{Coin
providedValue :: Coin
$sel:providedValue:NoSeedInput :: Coin
providedValue, Coin
minimumValue :: Coin
$sel:minimumValue:NoSeedInput :: Coin
minimumValue}
        Maybe (TxIn, TxOut CtxTx Era)
_ -> PostTxError Tx -> Either (PostTxError Tx) ()
forall a b. a -> Either a b
Left FailedToConstructDepositTx{$sel:failureReason:NoSeedInput :: Text
failureReason = Text
"Drafted deposit transaction would not be observed by hydra-node"}

-- Check each UTxO entry against the minADAUTxO value.
-- Throws 'DepositTooLow' exception.
rejectLowDeposits :: PParams LedgerEra -> UTxO -> Either (PostTxError Tx) ()
rejectLowDeposits :: PParams LedgerEra -> UTxO Era -> Either (PostTxError Tx) ()
rejectLowDeposits PParams LedgerEra
pparams UTxO Era
utxo =
  -- The provided and minimum values both derive from the same output, so we can
  -- compare them in a single pass over the UTxO.
  [(TxIn, TxOut CtxUTxO)]
-> ((TxIn, TxOut CtxUTxO) -> Either (PostTxError Tx) ())
-> Either (PostTxError Tx) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (UTxO Era -> [(TxIn, TxOut CtxUTxO)]
forall era. UTxO era -> [(TxIn, TxOut CtxUTxO era)]
UTxO.toList UTxO Era
utxo) (((TxIn, TxOut CtxUTxO) -> Either (PostTxError Tx) ())
 -> Either (PostTxError Tx) ())
-> ((TxIn, TxOut CtxUTxO) -> Either (PostTxError Tx) ())
-> Either (PostTxError Tx) ()
forall a b. (a -> b) -> a -> b
$ \(TxIn
i, TxOut CtxUTxO
o) -> do
    let providedValue :: Coin
providedValue = UTxO Era -> Coin
forall era. UTxO era -> Coin
UTxO.totalLovelace (UTxO Era -> Coin) -> UTxO Era -> Coin
forall a b. (a -> b) -> a -> b
$ TxIn -> TxOut CtxUTxO -> UTxO Era
forall era. TxIn -> TxOut CtxUTxO era -> UTxO era
UTxO.singleton TxIn
i TxOut CtxUTxO
o
        minimumValue :: Coin
minimumValue = ShelleyBasedEra Era -> PParams LedgerEra -> TxOut CtxTx Era -> Coin
forall era.
HasCallStack =>
ShelleyBasedEra era
-> PParams (ShelleyLedgerEra era) -> TxOut CtxTx era -> Coin
calculateMinimumUTxO ShelleyBasedEra Era
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra PParams LedgerEra
pparams (TxOut CtxTx Era -> Coin) -> TxOut CtxTx Era -> Coin
forall a b. (a -> b) -> a -> b
$ TxOut CtxUTxO -> TxOut CtxTx Era
forall era. TxOut CtxUTxO era -> TxOut CtxTx era
fromCtxUTxOTxOut TxOut CtxUTxO
o
    Bool -> Either (PostTxError Tx) () -> Either (PostTxError Tx) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Coin
providedValue Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
< Coin
minimumValue) (Either (PostTxError Tx) () -> Either (PostTxError Tx) ())
-> Either (PostTxError Tx) () -> Either (PostTxError Tx) ()
forall a b. (a -> b) -> a -> b
$
      PostTxError Tx -> Either (PostTxError Tx) ()
forall a b. a -> Either a b
Left (DepositTooLow{Coin
$sel:providedValue:NoSeedInput :: Coin
providedValue :: Coin
providedValue, Coin
$sel:minimumValue:NoSeedInput :: Coin
minimumValue :: Coin
minimumValue} :: PostTxError Tx)

-- | Reject any UTxO containing a Byron address, which cannot be represented
-- in the Hydra head protocol.
rejectByronAddresses :: UTxO -> Either (PostTxError Tx) ()
rejectByronAddresses :: UTxO Era -> Either (PostTxError Tx) ()
rejectByronAddresses UTxO Era
utxo =
  case ((TxIn, TxOut CtxUTxO) -> [Address ByronAddr])
-> [(TxIn, TxOut CtxUTxO)] -> [Address ByronAddr]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (TxIn, TxOut CtxUTxO) -> [Address ByronAddr]
forall a era. (a, TxOut era) -> [Address ByronAddr]
toByronAddr (UTxO Era -> [(TxIn, TxOut CtxUTxO)]
forall era. UTxO era -> [(TxIn, TxOut CtxUTxO era)]
UTxO.toList UTxO Era
utxo) of
    (Address ByronAddr
addr : [Address ByronAddr]
_) -> PostTxError Tx -> Either (PostTxError Tx) ()
forall a b. a -> Either a b
Left (Address ByronAddr -> PostTxError Tx
forall tx. Address ByronAddr -> PostTxError tx
UnsupportedLegacyOutput Address ByronAddr
addr)
    [] -> () -> Either (PostTxError Tx) ()
forall a b. b -> Either a b
Right ()
 where
  toByronAddr :: forall a era. (a, TxOut era) -> [Address ByronAddr]
  toByronAddr :: forall a era. (a, TxOut era) -> [Address ByronAddr]
toByronAddr (a
_, TxOut era
out) = case TxOut era -> AddressInEra
forall ctx. TxOut ctx -> AddressInEra
txOutAddress TxOut era
out of
    ByronAddressInEra Address ByronAddr
addr -> [Address ByronAddr
addr]
    AddressInEra
_ -> []

-- | Reject deposits which could never be claimed: builds a dry-run increment
-- transaction for the drafted deposit and rejects with 'DepositTooLarge' when
-- it would violate layer 1 ledger limits - the maximum transaction size, or
-- the maximum serialized value size of the merged head output.
rejectOversizedDeposit ::
  -- | Layer 1 protocol parameters (from 'getPParams' of the wallet, NOT the L2
  -- ledger parameters passed to the draft endpoint).
  PParams LedgerEra ->
  ChainContext ->
  -- | Spendable UTxO containing the current head output.
  UTxO ->
  HeadId ->
  -- | Current confirmed snapshot, basis for the dry-run increment.
  ConfirmedSnapshot Tx ->
  -- | Drafted (unbalanced) deposit transaction.
  Tx ->
  -- | Upper validity slot for the dry-run increment.
  SlotNo ->
  Either (PostTxError Tx) ()
rejectOversizedDeposit :: PParams LedgerEra
-> ChainContext
-> UTxO Era
-> HeadId
-> ConfirmedSnapshot Tx
-> Tx
-> SlotNo
-> Either (PostTxError Tx) ()
rejectOversizedDeposit PParams LedgerEra
pparams ChainContext
ctx UTxO Era
spendableUTxO HeadId
headId ConfirmedSnapshot Tx
currentSnapshot Tx
depositDraftTx SlotNo
upperValiditySlot = do
  Tx
dryRunTx <-
    (IncrementTxError -> PostTxError Tx)
-> Either IncrementTxError Tx -> Either (PostTxError Tx) Tx
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first
      (\IncrementTxError
err -> FailedToConstructDepositTx{$sel:failureReason:NoSeedInput :: Text
failureReason = Text
"increment dry-run: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> IncrementTxError -> Text
forall b a. (Show a, IsString b) => a -> b
show IncrementTxError
err})
      (ChainContext
-> UTxO Era
-> HeadId
-> ConfirmedSnapshot Tx
-> Tx
-> SlotNo
-> Either IncrementTxError Tx
dryRunIncrementTx ChainContext
ctx UTxO Era
spendableUTxO HeadId
headId ConfirmedSnapshot Tx
currentSnapshot Tx
depositDraftTx SlotNo
upperValiditySlot)
  let estimatedTxSize :: Natural
estimatedTxSize = Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length (Tx -> ByteString
forall a. SerialiseAsCBOR a => a -> ByteString
serialiseToCBOR Tx
dryRunTx)) Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
incrementTxBalancingMargin
      maximumTxSize :: Natural
maximumTxSize = Word32 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PParams ConwayEra
PParams LedgerEra
pparams PParams ConwayEra
-> Getting Word32 (PParams ConwayEra) Word32 -> Word32
forall s a. s -> Getting a s a -> a
^. Getting Word32 (PParams ConwayEra) Word32
forall era. EraPParams era => Lens' (PParams era) Word32
Lens' (PParams ConwayEra) Word32
ppMaxTxSizeL)
      -- The dry-run increment has exactly one output: the merged head output.
      estimatedValueSize :: Natural
estimatedValueSize = (TxOut CtxTx Era -> Natural -> Natural)
-> Natural -> [TxOut CtxTx Era] -> Natural
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Natural -> Natural -> Natural
forall a. Ord a => a -> a -> a
max (Natural -> Natural -> Natural)
-> (TxOut CtxTx Era -> Natural)
-> TxOut CtxTx Era
-> Natural
-> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PParams LedgerEra -> Value -> Natural
serializedValueSize PParams LedgerEra
pparams (Value -> Natural)
-> (TxOut CtxTx Era -> Value) -> TxOut CtxTx Era -> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut CtxTx Era -> Value
forall ctx. TxOut ctx -> Value
txOutValue) Natural
0 (Tx -> [TxOut CtxTx Era]
forall era. Tx era -> [TxOut CtxTx era]
txOuts' Tx
dryRunTx)
      maximumValueSize :: Natural
maximumValueSize = Word32 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PParams ConwayEra
PParams LedgerEra
pparams PParams ConwayEra
-> Getting Word32 (PParams ConwayEra) Word32 -> Word32
forall s a. s -> Getting a s a -> a
^. Getting Word32 (PParams ConwayEra) Word32
forall era. AlonzoEraPParams era => Lens' (PParams era) Word32
Lens' (PParams ConwayEra) Word32
ppMaxValSizeL)
  Bool -> Either (PostTxError Tx) () -> Either (PostTxError Tx) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Natural
estimatedTxSize Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
> Natural
maximumTxSize Bool -> Bool -> Bool
|| Natural
estimatedValueSize Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
> Natural
maximumValueSize) (Either (PostTxError Tx) () -> Either (PostTxError Tx) ())
-> Either (PostTxError Tx) () -> Either (PostTxError Tx) ()
forall a b. (a -> b) -> a -> b
$
    PostTxError Tx -> Either (PostTxError Tx) ()
forall a b. a -> Either a b
Left DepositTooLarge{Natural
estimatedTxSize :: Natural
$sel:estimatedTxSize:NoSeedInput :: Natural
estimatedTxSize, Natural
maximumTxSize :: Natural
$sel:maximumTxSize:NoSeedInput :: Natural
maximumTxSize, Natural
estimatedValueSize :: Natural
$sel:estimatedValueSize:NoSeedInput :: Natural
estimatedValueSize, Natural
maximumValueSize :: Natural
$sel:maximumValueSize:NoSeedInput :: Natural
maximumValueSize}

-- | Serialized size of a value, computed exactly like the ledger's
-- OutputTooBigUTxO check. NOTE: Keep in sync with
-- 'Cardano.Ledger.Alonzo.Rules.validateOutputTooBigUTxO'.
serializedValueSize :: PParams LedgerEra -> Value -> Natural
serializedValueSize :: PParams LedgerEra -> Value -> Natural
serializedValueSize PParams LedgerEra
pparams =
  Int64 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Natural) -> (Value -> Int64) -> Value -> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int64
BSL.length (ByteString -> Int64) -> (Value -> ByteString) -> Value -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> MaryValue -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
serialize (ProtVer -> Version
pvMajor (PParams ConwayEra
PParams LedgerEra
pparams PParams ConwayEra
-> Getting ProtVer (PParams ConwayEra) ProtVer -> ProtVer
forall s a. s -> Getting a s a -> a
^. Getting ProtVer (PParams ConwayEra) ProtVer
forall era. EraPParams era => Lens' (PParams era) ProtVer
Lens' (PParams ConwayEra) ProtVer
ppProtocolVersionL)) (MaryValue -> ByteString)
-> (Value -> MaryValue) -> Value -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> MaryValue
toLedgerValue

-- | Byte headroom added to the unbalanced dry-run increment transaction when
-- comparing against the maximum transaction size, covering what 'coverFee' and
-- 'sign' add to the real increment: a fee input (~40 bytes), a collateral
-- input (~40 bytes), an ada-only change output (~70 bytes), the script
-- integrity hash (~37 bytes), the fee field (~5 bytes), one key witness (~102
-- bytes), and wider integer encodings for the estimated execution units,
-- snapshot number and validity slot (~40 bytes) - around 334 bytes in total.
-- We add some overhead and use 512 just to be more safe.
incrementTxBalancingMargin :: Natural
incrementTxBalancingMargin :: Natural
incrementTxBalancingMargin = Natural
512

-- | Balance and sign the given partial transaction.
finalizeTx ::
  MonadThrow m =>
  TinyWallet m ->
  ChainContext ->
  UTxO ->
  UTxO ->
  Tx ->
  m Tx
finalizeTx :: forall (m :: * -> *).
MonadThrow m =>
TinyWallet m -> ChainContext -> UTxO Era -> UTxO Era -> Tx -> m Tx
finalizeTx TinyWallet{Tx -> Tx
sign :: forall (m :: * -> *). TinyWallet m -> Tx -> Tx
sign :: Tx -> Tx
sign, UTxO Era -> Tx -> m (Either ErrCoverFee Tx)
coverFee :: forall (m :: * -> *).
TinyWallet m -> UTxO Era -> Tx -> m (Either ErrCoverFee Tx)
coverFee :: UTxO Era -> Tx -> m (Either ErrCoverFee Tx)
coverFee} ChainContext
ctx UTxO Era
utxo UTxO Era
userUTxO Tx
partialTx = do
  let headUTxO :: UTxO Era
headUTxO = ChainContext -> UTxO Era
forall a. HasKnownUTxO a => a -> UTxO Era
getKnownUTxO ChainContext
ctx UTxO Era -> UTxO Era -> UTxO Era
forall a. Semigroup a => a -> a -> a
<> UTxO Era
utxo UTxO Era -> UTxO Era -> UTxO Era
forall a. Semigroup a => a -> a -> a
<> UTxO Era
userUTxO
  UTxO Era -> Tx -> m (Either ErrCoverFee Tx)
coverFee UTxO Era
headUTxO Tx
partialTx m (Either ErrCoverFee Tx)
-> (Either ErrCoverFee Tx -> m Tx) -> m Tx
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left ErrCoverFee
ErrNoFuelUTxOFound ->
      PostTxError Tx -> m Tx
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO NoFuelUTXOFound{$sel:failingTx:NoSeedInput :: Tx
failingTx = Tx
partialTx}
    Left ErrNotEnoughFunds{} ->
      PostTxError Tx -> m Tx
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO NotEnoughFuel{$sel:failingTx:NoSeedInput :: Tx
failingTx = Tx
partialTx}
    Left ErrScriptExecutionFailed{Text
redeemerPointer :: Text
$sel:redeemerPointer:ErrNotEnoughFunds :: ErrCoverFee -> Text
redeemerPointer, Text
scriptFailure :: Text
$sel:scriptFailure:ErrNotEnoughFunds :: ErrCoverFee -> Text
scriptFailure} ->
      PostTxError Tx -> m Tx
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO
        ( ScriptFailedInWallet
            { $sel:redeemerPtr:NoSeedInput :: Text
redeemerPtr = Text
redeemerPointer
            , $sel:failureReason:NoSeedInput :: Text
failureReason = Text
scriptFailure
            , $sel:failingTx:NoSeedInput :: Tx
failingTx = Tx
partialTx
            } ::
            PostTxError Tx
        )
    Left ErrMissingScript{Text
scriptHash :: Text
$sel:scriptHash:ErrNotEnoughFunds :: ErrCoverFee -> Text
scriptHash, Text
purpose :: Text
$sel:purpose:ErrNotEnoughFunds :: ErrCoverFee -> Text
purpose} ->
      PostTxError Tx -> m Tx
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO
        ( ScriptFailedInWallet
            { $sel:redeemerPtr:NoSeedInput :: Text
redeemerPtr = Text
purpose
            , $sel:failureReason:NoSeedInput :: Text
failureReason = Text
"Missing script witness for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
scriptHash
            , $sel:failingTx:NoSeedInput :: Tx
failingTx = Tx
partialTx
            } ::
            PostTxError Tx
        )
    Left ErrCoverFee
e ->
      PostTxError Tx -> m Tx
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO
        ( InternalWalletError
            { UTxOType Tx
UTxO Era
headUTxO :: UTxO Era
$sel:headUTxO:NoSeedInput :: UTxOType Tx
headUTxO
            , $sel:reason:NoSeedInput :: Text
reason = ErrCoverFee -> Text
forall b a. (Show a, IsString b) => a -> b
show ErrCoverFee
e
            , $sel:failingTx:NoSeedInput :: Tx
failingTx = Tx
partialTx
            } ::
            PostTxError Tx
        )
    Right Tx
balancedTx ->
      Tx -> m Tx
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx -> m Tx) -> Tx -> m Tx
forall a b. (a -> b) -> a -> b
$ Tx -> Tx
sign Tx
balancedTx

-- * Following the Chain

-- | A /handler/ that takes care of following the chain.
data ChainSyncHandler m = ChainSyncHandler
  { forall (m :: * -> *).
ChainSyncHandler m -> BlockHeader -> [Tx] -> m ()
onRollForward :: BlockHeader -> [Tx] -> m ()
  , forall (m :: * -> *). ChainSyncHandler m -> ChainPoint -> m ()
onRollBackward :: ChainPoint -> m ()
  }

-- | Conversion of a slot number to a time failed. This can be usually be
-- considered an internal error and may be happening because the used era
-- history is too old.
data TimeConversionException = TimeConversionException
  { TimeConversionException -> SlotNo
slotNo :: SlotNo
  , TimeConversionException -> Text
reason :: Text
  }
  deriving stock (TimeConversionException -> TimeConversionException -> Bool
(TimeConversionException -> TimeConversionException -> Bool)
-> (TimeConversionException -> TimeConversionException -> Bool)
-> Eq TimeConversionException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TimeConversionException -> TimeConversionException -> Bool
== :: TimeConversionException -> TimeConversionException -> Bool
$c/= :: TimeConversionException -> TimeConversionException -> Bool
/= :: TimeConversionException -> TimeConversionException -> Bool
Eq, Int -> TimeConversionException -> ShowS
[TimeConversionException] -> ShowS
TimeConversionException -> String
(Int -> TimeConversionException -> ShowS)
-> (TimeConversionException -> String)
-> ([TimeConversionException] -> ShowS)
-> Show TimeConversionException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TimeConversionException -> ShowS
showsPrec :: Int -> TimeConversionException -> ShowS
$cshow :: TimeConversionException -> String
show :: TimeConversionException -> String
$cshowList :: [TimeConversionException] -> ShowS
showList :: [TimeConversionException] -> ShowS
Show)
  deriving anyclass (Show TimeConversionException
Typeable TimeConversionException
(Typeable TimeConversionException, Show TimeConversionException) =>
(TimeConversionException -> SomeException)
-> (SomeException -> Maybe TimeConversionException)
-> (TimeConversionException -> String)
-> Exception TimeConversionException
SomeException -> Maybe TimeConversionException
TimeConversionException -> String
TimeConversionException -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: TimeConversionException -> SomeException
toException :: TimeConversionException -> SomeException
$cfromException :: SomeException -> Maybe TimeConversionException
fromException :: SomeException -> Maybe TimeConversionException
$cdisplayException :: TimeConversionException -> String
displayException :: TimeConversionException -> String
Exception)

-- | Creates a `ChainSyncHandler` that can notify the given `callback` of events happening
-- on-chain.
--
-- This forms the other half of a `ChainComponent` along with `mkChain` but is decoupled from
-- actual interactions with the chain.
--
-- A `TimeHandle` is needed to do `SlotNo -> POSIXTime` conversions for 'Tick' events.
--
-- Throws 'TimeConversionException' when a received block's 'SlotNo' cannot be
-- converted to a 'UTCTime' with the given 'TimeHandle'.
chainSyncHandler ::
  forall m.
  (MonadSTM m, MonadThrow m) =>
  -- | Tracer for logging
  Tracer m CardanoChainLog ->
  ChainCallback Tx m ->
  -- | Means to acquire a 'TimeHandle' able to convert the given slot.
  (SlotNo -> GetTimeHandle m) ->
  -- | Contextual information about our chain connection.
  ChainContext ->
  LocalChainState m Tx ->
  -- | A chain-sync handler to use in a local-chain-sync client.
  ChainSyncHandler m
chainSyncHandler :: forall (m :: * -> *).
(MonadSTM m, MonadThrow m) =>
Tracer m CardanoChainLog
-> ChainCallback Tx m
-> (SlotNo -> GetTimeHandle m)
-> ChainContext
-> LocalChainState m Tx
-> ChainSyncHandler m
chainSyncHandler Tracer m CardanoChainLog
tracer ChainCallback Tx m
callback SlotNo -> GetTimeHandle m
getTimeHandle ChainContext
ctx LocalChainState m Tx
localChainState =
  ChainSyncHandler
    { ChainPoint -> m ()
$sel:onRollBackward:ChainSyncHandler :: ChainPoint -> m ()
onRollBackward :: ChainPoint -> m ()
onRollBackward
    , BlockHeader -> [Tx] -> m ()
$sel:onRollForward:ChainSyncHandler :: BlockHeader -> [Tx] -> m ()
onRollForward :: BlockHeader -> [Tx] -> m ()
onRollForward
    }
 where
  ChainContext{NetworkId
$sel:networkId:ChainContext :: ChainContext -> NetworkId
networkId :: NetworkId
networkId} = ChainContext
ctx
  LocalChainState{ChainSlot -> STM m (ChainStateType Tx)
$sel:rollback:LocalChainState :: forall (m :: * -> *) tx.
LocalChainState m tx -> ChainSlot -> STM m (ChainStateType tx)
rollback :: ChainSlot -> STM m (ChainStateType Tx)
rollback, STM m (ChainStateType Tx)
$sel:getLatest:LocalChainState :: forall (m :: * -> *) tx.
LocalChainState m tx -> STM m (ChainStateType tx)
getLatest :: STM m (ChainStateType Tx)
getLatest, ChainStateType Tx -> STM m ()
$sel:pushNew:LocalChainState :: forall (m :: * -> *) tx.
LocalChainState m tx -> ChainStateType tx -> STM m ()
pushNew :: ChainStateType Tx -> STM m ()
pushNew} = LocalChainState m Tx
localChainState

  onRollBackward :: ChainPoint -> m ()
  onRollBackward :: ChainPoint -> m ()
onRollBackward ChainPoint
point = do
    Tracer m CardanoChainLog -> CardanoChainLog -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m CardanoChainLog
tracer (CardanoChainLog -> m ()) -> CardanoChainLog -> m ()
forall a b. (a -> b) -> a -> b
$ RolledBackward{ChainPoint
point :: ChainPoint
$sel:point:ToPost :: ChainPoint
point}
    let slotNo :: SlotNo
slotNo = SlotNo -> Maybe SlotNo -> SlotNo
forall a. a -> Maybe a -> a
fromMaybe SlotNo
0 (ChainPoint -> Maybe SlotNo
chainPointToSlotNo ChainPoint
point)
    TimeHandle
timeHandle <- SlotNo -> GetTimeHandle m
getTimeHandle SlotNo
slotNo
    case TimeHandle -> SlotNo -> Either Text UTCTime
slotToUTCTime TimeHandle
timeHandle SlotNo
slotNo of
      Left Text
reason ->
        TimeConversionException -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO TimeConversionException{SlotNo
$sel:slotNo:TimeConversionException :: SlotNo
slotNo :: SlotNo
slotNo, Text
$sel:reason:TimeConversionException :: Text
reason :: Text
reason}
      Right UTCTime
utcTime -> do
        ChainStateAt
rolledBackChainState <- STM m ChainStateAt -> m ChainStateAt
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m ChainStateAt -> m ChainStateAt)
-> STM m ChainStateAt -> m ChainStateAt
forall a b. (a -> b) -> a -> b
$ ChainSlot -> STM m (ChainStateType Tx)
rollback (ChainPoint -> ChainSlot
chainSlotFromPoint ChainPoint
point)
        ChainCallback Tx m
callback Rollback{ChainStateType Tx
ChainStateAt
rolledBackChainState :: ChainStateAt
$sel:rolledBackChainState:Observation :: ChainStateType Tx
rolledBackChainState, $sel:chainTime:Observation :: UTCTime
chainTime = UTCTime
utcTime}

  onRollForward :: BlockHeader -> [Tx] -> m ()
  onRollForward :: BlockHeader -> [Tx] -> m ()
onRollForward BlockHeader
header [Tx]
receivedTxs = do
    let point :: ChainPoint
point = BlockHeader -> ChainPoint
getChainPoint BlockHeader
header
    Tracer m CardanoChainLog -> CardanoChainLog -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m CardanoChainLog
tracer (CardanoChainLog -> m ()) -> CardanoChainLog -> m ()
forall a b. (a -> b) -> a -> b
$
      RolledForward
        { ChainPoint
$sel:point:ToPost :: ChainPoint
point :: ChainPoint
point
        , $sel:receivedTxIds:ToPost :: [TxId]
receivedTxIds = TxBody Era -> TxId
forall era. TxBody era -> TxId
getTxId (TxBody Era -> TxId) -> (Tx -> TxBody Era) -> Tx -> TxId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx -> TxBody Era
forall era. Tx era -> TxBody era
getTxBody (Tx -> TxId) -> [Tx] -> [TxId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Tx]
receivedTxs
        }

    TimeHandle
timeHandle <- SlotNo -> GetTimeHandle m
getTimeHandle (SlotNo -> GetTimeHandle m) -> SlotNo -> GetTimeHandle m
forall a b. (a -> b) -> a -> b
$ SlotNo -> Maybe SlotNo -> SlotNo
forall a. a -> Maybe a -> a
fromMaybe SlotNo
0 (ChainPoint -> Maybe SlotNo
chainPointToSlotNo ChainPoint
point)

    [Tx] -> (Tx -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Tx]
receivedTxs ((Tx -> m ()) -> m ()) -> (Tx -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$
      TimeHandle -> ChainPoint -> Tx -> m (Maybe (ChainEvent Tx))
maybeObserveSomeTx TimeHandle
timeHandle ChainPoint
point (Tx -> m (Maybe (ChainEvent Tx)))
-> (Maybe (ChainEvent Tx) -> m ()) -> Tx -> m ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \case
        Maybe (ChainEvent Tx)
Nothing -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just ChainEvent Tx
event -> ChainCallback Tx m
callback ChainEvent Tx
event

    case ChainPoint -> Maybe SlotNo
chainPointToSlotNo ChainPoint
point of
      Maybe SlotNo
Nothing -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just SlotNo
slotNo -> do
        case TimeHandle -> SlotNo -> Either Text UTCTime
slotToUTCTime TimeHandle
timeHandle SlotNo
slotNo of
          Left Text
reason ->
            TimeConversionException -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO TimeConversionException{SlotNo
$sel:slotNo:TimeConversionException :: SlotNo
slotNo :: SlotNo
slotNo, Text
$sel:reason:TimeConversionException :: Text
reason :: Text
reason}
          Right UTCTime
utcTime -> do
            ChainCallback Tx m
callback (Tick{$sel:chainTime:Observation :: UTCTime
chainTime = UTCTime
utcTime, $sel:chainPoint:Observation :: ChainPointType Tx
chainPoint = ChainPoint
ChainPointType Tx
point})

  maybeObserveSomeTx :: TimeHandle -> ChainPoint -> Tx -> m (Maybe (ChainEvent Tx))
maybeObserveSomeTx TimeHandle
timeHandle ChainPoint
point Tx
tx = STM m (Maybe (ChainEvent Tx)) -> m (Maybe (ChainEvent Tx))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Maybe (ChainEvent Tx)) -> m (Maybe (ChainEvent Tx)))
-> STM m (Maybe (ChainEvent Tx)) -> m (Maybe (ChainEvent Tx))
forall a b. (a -> b) -> a -> b
$ do
    ChainStateAt{UTxO Era
$sel:spendableUTxO:ChainStateAt :: ChainStateAt -> UTxO Era
spendableUTxO :: UTxO Era
spendableUTxO} <- STM m (ChainStateType Tx)
STM m ChainStateAt
getLatest
    let observation :: HeadObservation
observation = NetworkId -> UTxO Era -> Tx -> HeadObservation
observeHeadTx NetworkId
networkId UTxO Era
spendableUTxO Tx
tx
    case TimeHandle -> HeadObservation -> Maybe (OnChainTx Tx)
convertObservation TimeHandle
timeHandle HeadObservation
observation of
      Maybe (OnChainTx Tx)
Nothing -> Maybe (ChainEvent Tx) -> STM m (Maybe (ChainEvent Tx))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ChainEvent Tx)
forall a. Maybe a
Nothing
      Just OnChainTx Tx
observedTx -> do
        let newChainState :: ChainStateAt
newChainState =
              ChainStateAt
                { $sel:spendableUTxO:ChainStateAt :: UTxO Era
spendableUTxO = Tx -> UTxO Era -> UTxO Era
adjustUTxO Tx
tx UTxO Era
spendableUTxO
                , $sel:recordedAt:ChainStateAt :: Maybe ChainPoint
recordedAt = ChainPoint -> Maybe ChainPoint
forall a. a -> Maybe a
Just ChainPoint
point
                }
        ChainStateType Tx -> STM m ()
pushNew ChainStateType Tx
ChainStateAt
newChainState
        Maybe (ChainEvent Tx) -> STM m (Maybe (ChainEvent Tx))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (ChainEvent Tx) -> STM m (Maybe (ChainEvent Tx)))
-> Maybe (ChainEvent Tx) -> STM m (Maybe (ChainEvent Tx))
forall a b. (a -> b) -> a -> b
$ ChainEvent Tx -> Maybe (ChainEvent Tx)
forall a. a -> Maybe a
Just Observation{OnChainTx Tx
observedTx :: OnChainTx Tx
$sel:observedTx:Observation :: OnChainTx Tx
observedTx, ChainStateType Tx
ChainStateAt
newChainState :: ChainStateAt
$sel:newChainState:Observation :: ChainStateType Tx
newChainState}

convertObservation :: TimeHandle -> HeadObservation -> Maybe (OnChainTx Tx)
convertObservation :: TimeHandle -> HeadObservation -> Maybe (OnChainTx Tx)
convertObservation TimeHandle{SlotNo -> Either Text UTCTime
$sel:slotToUTCTime:TimeHandle :: TimeHandle -> SlotNo -> Either Text UTCTime
slotToUTCTime :: SlotNo -> Either Text UTCTime
slotToUTCTime} = \case
  HeadObservation
NoHeadTx -> Maybe (OnChainTx Tx)
forall a. Maybe a
Nothing
  Init InitObservation{HeadId
headId :: HeadId
$sel:headId:InitObservation :: InitObservation -> HeadId
headId, HeadSeed
headSeed :: HeadSeed
$sel:headSeed:InitObservation :: InitObservation -> HeadSeed
headSeed, HeadParameters
headParameters :: HeadParameters
$sel:headParameters:InitObservation :: InitObservation -> HeadParameters
headParameters, [OnChainId]
participants :: [OnChainId]
$sel:participants:InitObservation :: InitObservation -> [OnChainId]
participants} ->
    OnChainTx Tx -> Maybe (OnChainTx Tx)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OnInitTx{HeadId
headId :: HeadId
$sel:headId:OnInitTx :: HeadId
headId, HeadSeed
headSeed :: HeadSeed
$sel:headSeed:OnInitTx :: HeadSeed
headSeed, HeadParameters
headParameters :: HeadParameters
$sel:headParameters:OnInitTx :: HeadParameters
headParameters, [OnChainId]
participants :: [OnChainId]
$sel:participants:OnInitTx :: [OnChainId]
participants}
  Deposit DepositObservation{HeadId
headId :: HeadId
$sel:headId:DepositObservation :: DepositObservation -> HeadId
headId, TxId
depositTxId :: TxId
$sel:depositTxId:DepositObservation :: DepositObservation -> TxId
depositTxId, UTxO Era
deposited :: UTxO Era
$sel:deposited:DepositObservation :: DepositObservation -> UTxO Era
deposited, SlotNo
created :: SlotNo
$sel:created:DepositObservation :: DepositObservation -> SlotNo
created, UTCTime
deadline :: UTCTime
$sel:deadline:DepositObservation :: DepositObservation -> UTCTime
deadline} -> do
    UTCTime
createdTime <- (Text -> Maybe UTCTime)
-> (UTCTime -> Maybe UTCTime)
-> Either Text UTCTime
-> Maybe UTCTime
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe UTCTime -> Text -> Maybe UTCTime
forall a b. a -> b -> a
const Maybe UTCTime
forall a. Maybe a
Nothing) UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just (Either Text UTCTime -> Maybe UTCTime)
-> Either Text UTCTime -> Maybe UTCTime
forall a b. (a -> b) -> a -> b
$ SlotNo -> Either Text UTCTime
slotToUTCTime SlotNo
created
    OnChainTx Tx -> Maybe (OnChainTx Tx)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OnChainTx Tx -> Maybe (OnChainTx Tx))
-> OnChainTx Tx -> Maybe (OnChainTx Tx)
forall a b. (a -> b) -> a -> b
$ OnDepositTx{HeadId
$sel:headId:OnInitTx :: HeadId
headId :: HeadId
headId, TxIdType Tx
TxId
depositTxId :: TxId
$sel:depositTxId:OnInitTx :: TxIdType Tx
depositTxId, UTxOType Tx
UTxO Era
deposited :: UTxO Era
$sel:deposited:OnInitTx :: UTxOType Tx
deposited, $sel:created:OnInitTx :: UTCTime
created = UTCTime
createdTime, UTCTime
deadline :: UTCTime
$sel:deadline:OnInitTx :: UTCTime
deadline}
  Recover RecoverObservation{HeadId
headId :: HeadId
$sel:headId:RecoverObservation :: RecoverObservation -> HeadId
headId, TxId
recoveredTxId :: TxId
$sel:recoveredTxId:RecoverObservation :: RecoverObservation -> TxId
recoveredTxId, UTxO Era
recoveredUTxO :: UTxO Era
$sel:recoveredUTxO:RecoverObservation :: RecoverObservation -> UTxO Era
recoveredUTxO} ->
    OnChainTx Tx -> Maybe (OnChainTx Tx)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OnRecoverTx{HeadId
$sel:headId:OnInitTx :: HeadId
headId :: HeadId
headId, TxIdType Tx
TxId
recoveredTxId :: TxId
$sel:recoveredTxId:OnInitTx :: TxIdType Tx
recoveredTxId, UTxOType Tx
UTxO Era
recoveredUTxO :: UTxO Era
$sel:recoveredUTxO:OnInitTx :: UTxOType Tx
recoveredUTxO}
  Increment IncrementObservation{HeadId
headId :: HeadId
$sel:headId:IncrementObservation :: IncrementObservation -> HeadId
headId, SnapshotVersion
newVersion :: SnapshotVersion
$sel:newVersion:IncrementObservation :: IncrementObservation -> SnapshotVersion
newVersion, TxId
depositTxId :: TxId
$sel:depositTxId:IncrementObservation :: IncrementObservation -> TxId
depositTxId} ->
    OnChainTx Tx -> Maybe (OnChainTx Tx)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OnIncrementTx{HeadId
$sel:headId:OnInitTx :: HeadId
headId :: HeadId
headId, SnapshotVersion
newVersion :: SnapshotVersion
$sel:newVersion:OnInitTx :: SnapshotVersion
newVersion, TxIdType Tx
TxId
$sel:depositTxId:OnInitTx :: TxIdType Tx
depositTxId :: TxId
depositTxId}
  Decrement DecrementObservation{HeadId
headId :: HeadId
$sel:headId:DecrementObservation :: DecrementObservation -> HeadId
headId, SnapshotVersion
newVersion :: SnapshotVersion
$sel:newVersion:DecrementObservation :: DecrementObservation -> SnapshotVersion
newVersion, UTxO Era
distributedUTxO :: UTxO Era
$sel:distributedUTxO:DecrementObservation :: DecrementObservation -> UTxO Era
distributedUTxO} ->
    OnChainTx Tx -> Maybe (OnChainTx Tx)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OnDecrementTx{HeadId
$sel:headId:OnInitTx :: HeadId
headId :: HeadId
headId, SnapshotVersion
$sel:newVersion:OnInitTx :: SnapshotVersion
newVersion :: SnapshotVersion
newVersion, UTxOType Tx
UTxO Era
distributedUTxO :: UTxO Era
$sel:distributedUTxO:OnInitTx :: UTxOType Tx
distributedUTxO}
  Close CloseObservation{HeadId
headId :: HeadId
$sel:headId:CloseObservation :: CloseObservation -> HeadId
headId, SnapshotNumber
snapshotNumber :: SnapshotNumber
$sel:snapshotNumber:CloseObservation :: CloseObservation -> SnapshotNumber
snapshotNumber, UTCTime
contestationDeadline :: UTCTime
$sel:contestationDeadline:CloseObservation :: CloseObservation -> UTCTime
contestationDeadline} ->
    OnChainTx Tx -> Maybe (OnChainTx Tx)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OnCloseTx{HeadId
$sel:headId:OnInitTx :: HeadId
headId :: HeadId
headId, SnapshotNumber
snapshotNumber :: SnapshotNumber
$sel:snapshotNumber:OnInitTx :: SnapshotNumber
snapshotNumber, UTCTime
contestationDeadline :: UTCTime
$sel:contestationDeadline:OnInitTx :: UTCTime
contestationDeadline}
  Contest ContestObservation{UTCTime
contestationDeadline :: UTCTime
$sel:contestationDeadline:ContestObservation :: ContestObservation -> UTCTime
contestationDeadline, HeadId
headId :: HeadId
$sel:headId:ContestObservation :: ContestObservation -> HeadId
headId, SnapshotNumber
snapshotNumber :: SnapshotNumber
$sel:snapshotNumber:ContestObservation :: ContestObservation -> SnapshotNumber
snapshotNumber} ->
    OnChainTx Tx -> Maybe (OnChainTx Tx)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OnContestTx{UTCTime
$sel:contestationDeadline:OnInitTx :: UTCTime
contestationDeadline :: UTCTime
contestationDeadline, HeadId
$sel:headId:OnInitTx :: HeadId
headId :: HeadId
headId, SnapshotNumber
$sel:snapshotNumber:OnInitTx :: SnapshotNumber
snapshotNumber :: SnapshotNumber
snapshotNumber}
  Fanout FanoutObservation{HeadId
headId :: HeadId
$sel:headId:FanoutObservation :: FanoutObservation -> HeadId
headId, UTxO Era
fanoutUTxO :: UTxO Era
$sel:fanoutUTxO:FanoutObservation :: FanoutObservation -> UTxO Era
fanoutUTxO} ->
    OnChainTx Tx -> Maybe (OnChainTx Tx)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OnFanoutTx{HeadId
$sel:headId:OnInitTx :: HeadId
headId :: HeadId
headId, UTxOType Tx
UTxO Era
fanoutUTxO :: UTxO Era
$sel:fanoutUTxO:OnInitTx :: UTxOType Tx
fanoutUTxO}
  FinalPartialFanout FanoutObservation{HeadId
$sel:headId:FanoutObservation :: FanoutObservation -> HeadId
headId :: HeadId
headId, UTxO Era
$sel:fanoutUTxO:FanoutObservation :: FanoutObservation -> UTxO Era
fanoutUTxO :: UTxO Era
fanoutUTxO} ->
    OnChainTx Tx -> Maybe (OnChainTx Tx)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OnFanoutTx{HeadId
$sel:headId:OnInitTx :: HeadId
headId :: HeadId
headId, UTxOType Tx
UTxO Era
$sel:fanoutUTxO:OnInitTx :: UTxOType Tx
fanoutUTxO :: UTxO Era
fanoutUTxO}
  PartialFanout PartialFanoutObservation{HeadId
headId :: HeadId
$sel:headId:PartialFanoutObservation :: PartialFanoutObservation -> HeadId
headId, UTxO Era
distributedOutputs :: UTxO Era
$sel:distributedOutputs:PartialFanoutObservation :: PartialFanoutObservation -> UTxO Era
distributedOutputs} ->
    OnChainTx Tx -> Maybe (OnChainTx Tx)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OnPartialFanoutTx{HeadId
$sel:headId:OnInitTx :: HeadId
headId :: HeadId
headId, UTxOType Tx
UTxO Era
distributedOutputs :: UTxO Era
$sel:distributedOutputs:OnInitTx :: UTxOType Tx
distributedOutputs}

prepareTxToPost ::
  forall m.
  (MonadSTM m, MonadThrow (STM m)) =>
  TimeHandle ->
  ChainContext ->
  -- | Spendable UTxO
  UTxOType Tx ->
  PostChainTx Tx ->
  STM m Tx
prepareTxToPost :: forall (m :: * -> *).
(MonadSTM m, MonadThrow (STM m)) =>
TimeHandle
-> ChainContext -> UTxOType Tx -> PostChainTx Tx -> STM m Tx
prepareTxToPost TimeHandle
timeHandle ChainContext
ctx UTxOType Tx
spendableUTxO PostChainTx Tx
tx =
  case PostChainTx Tx
tx of
    -- InitTx is handled in mkChain.postTx before reaching this function.
    InitTx{} -> PostTxError Tx -> STM m Tx
forall (m :: * -> *) e a.
(MonadSTM m, MonadThrow (STM m), Exception e) =>
e -> STM m a
throwSTM (forall tx. PostTxError tx
NoSeedInput @Tx)
    IncrementTx{HeadSeed
$sel:headSeed:InitTx :: forall tx. PostChainTx tx -> HeadSeed
headSeed :: HeadSeed
headSeed, HeadId
headId :: HeadId
$sel:headId:InitTx :: forall tx. PostChainTx tx -> HeadId
headId, HeadParameters
$sel:headParameters:InitTx :: forall tx. PostChainTx tx -> HeadParameters
headParameters :: HeadParameters
headParameters, ConfirmedSnapshot Tx
incrementingSnapshot :: ConfirmedSnapshot Tx
$sel:incrementingSnapshot:InitTx :: forall tx. PostChainTx tx -> ConfirmedSnapshot tx
incrementingSnapshot} -> do
      (SlotNo
_, UTCTime
currentTime) <- Either Text PointInTime -> STM m PointInTime
forall a. Either Text a -> STM m a
throwLeft Either Text PointInTime
currentPointInTime
      let HeadParameters{ContestationPeriod
contestationPeriod :: ContestationPeriod
$sel:contestationPeriod:HeadParameters :: HeadParameters -> ContestationPeriod
contestationPeriod} = HeadParameters
headParameters
      (SlotNo
upperBound, UTCTime
_) <- UTCTime -> ContestationPeriod -> STM m PointInTime
calculateTxUpperBoundFromContestationPeriod UTCTime
currentTime ContestationPeriod
contestationPeriod
      case ChainContext
-> UTxO Era
-> (HeadSeed, HeadId)
-> HeadParameters
-> ConfirmedSnapshot Tx
-> SlotNo
-> Either IncrementTxError Tx
increment ChainContext
ctx UTxOType Tx
UTxO Era
spendableUTxO (HeadSeed
headSeed, HeadId
headId) HeadParameters
headParameters ConfirmedSnapshot Tx
incrementingSnapshot SlotNo
upperBound of
        Left IncrementTxError
err -> PostTxError Tx -> STM m Tx
forall e a. Exception e => e -> STM m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (FailedToConstructIncrementTx{$sel:failureReason:NoSeedInput :: Text
failureReason = IncrementTxError -> Text
forall b a. (Show a, IsString b) => a -> b
show IncrementTxError
err} :: PostTxError Tx)
        Right Tx
incrementTx' -> Tx -> STM m Tx
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx
incrementTx'
    RecoverTx{HeadId
$sel:headId:InitTx :: forall tx. PostChainTx tx -> HeadId
headId :: HeadId
headId, TxIdType Tx
recoverTxId :: TxIdType Tx
$sel:recoverTxId:InitTx :: forall tx. PostChainTx tx -> TxIdType tx
recoverTxId, ChainSlot
deadline :: ChainSlot
$sel:deadline:InitTx :: forall tx. PostChainTx tx -> ChainSlot
deadline} -> do
      case ChainContext
-> HeadId -> TxId -> UTxO Era -> SlotNo -> Either RecoverTxError Tx
recover ChainContext
ctx HeadId
headId TxIdType Tx
TxId
recoverTxId UTxOType Tx
UTxO Era
spendableUTxO (ChainSlot -> SlotNo
fromChainSlot ChainSlot
deadline) of
        Left RecoverTxError
err -> PostTxError Tx -> STM m Tx
forall e a. Exception e => e -> STM m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (FailedToConstructRecoverTx{$sel:failureReason:NoSeedInput :: Text
failureReason = RecoverTxError -> Text
forall b a. (Show a, IsString b) => a -> b
show RecoverTxError
err} :: PostTxError Tx)
        Right Tx
recoverTx' -> Tx -> STM m Tx
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx
recoverTx'
    DecrementTx{HeadSeed
$sel:headSeed:InitTx :: forall tx. PostChainTx tx -> HeadSeed
headSeed :: HeadSeed
headSeed, HeadId
$sel:headId:InitTx :: forall tx. PostChainTx tx -> HeadId
headId :: HeadId
headId, HeadParameters
$sel:headParameters:InitTx :: forall tx. PostChainTx tx -> HeadParameters
headParameters :: HeadParameters
headParameters, ConfirmedSnapshot Tx
decrementingSnapshot :: ConfirmedSnapshot Tx
$sel:decrementingSnapshot:InitTx :: forall tx. PostChainTx tx -> ConfirmedSnapshot tx
decrementingSnapshot} ->
      case ChainContext
-> UTxO Era
-> (HeadSeed, HeadId)
-> HeadParameters
-> ConfirmedSnapshot Tx
-> Either DecrementTxError Tx
decrement ChainContext
ctx UTxOType Tx
UTxO Era
spendableUTxO (HeadSeed
headSeed, HeadId
headId) HeadParameters
headParameters ConfirmedSnapshot Tx
decrementingSnapshot of
        Left DecrementTxError
err -> PostTxError Tx -> STM m Tx
forall e a. Exception e => e -> STM m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (FailedToConstructDecrementTx{$sel:failureReason:NoSeedInput :: Text
failureReason = DecrementTxError -> Text
forall b a. (Show a, IsString b) => a -> b
show DecrementTxError
err} :: PostTxError Tx)
        Right Tx
decrementTx' -> Tx -> STM m Tx
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx
decrementTx'
    CloseTx{HeadId
$sel:headId:InitTx :: forall tx. PostChainTx tx -> HeadId
headId :: HeadId
headId, HeadParameters
$sel:headParameters:InitTx :: forall tx. PostChainTx tx -> HeadParameters
headParameters :: HeadParameters
headParameters, SnapshotVersion
openVersion :: SnapshotVersion
$sel:openVersion:InitTx :: forall tx. PostChainTx tx -> SnapshotVersion
openVersion, ConfirmedSnapshot Tx
closingSnapshot :: ConfirmedSnapshot Tx
$sel:closingSnapshot:InitTx :: forall tx. PostChainTx tx -> ConfirmedSnapshot tx
closingSnapshot} -> do
      (SlotNo
currentSlot, UTCTime
currentTime) <- Either Text PointInTime -> STM m PointInTime
forall a. Either Text a -> STM m a
throwLeft Either Text PointInTime
currentPointInTime
      let HeadParameters{ContestationPeriod
$sel:contestationPeriod:HeadParameters :: HeadParameters -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod} = HeadParameters
headParameters
      PointInTime
upperBound <- UTCTime -> ContestationPeriod -> STM m PointInTime
calculateTxUpperBoundFromContestationPeriod UTCTime
currentTime ContestationPeriod
contestationPeriod
      case ChainContext
-> UTxO Era
-> HeadId
-> HeadParameters
-> SnapshotVersion
-> ConfirmedSnapshot Tx
-> SlotNo
-> PointInTime
-> Either CloseTxError Tx
close ChainContext
ctx UTxOType Tx
UTxO Era
spendableUTxO HeadId
headId HeadParameters
headParameters SnapshotVersion
openVersion ConfirmedSnapshot Tx
closingSnapshot SlotNo
currentSlot PointInTime
upperBound of
        Left CloseTxError
_ -> PostTxError Tx -> STM m Tx
forall e a. Exception e => e -> STM m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (forall tx. PostTxError tx
FailedToConstructCloseTx @Tx)
        Right Tx
closeTx -> Tx -> STM m Tx
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx
closeTx
    ContestTx{HeadId
$sel:headId:InitTx :: forall tx. PostChainTx tx -> HeadId
headId :: HeadId
headId, HeadParameters
$sel:headParameters:InitTx :: forall tx. PostChainTx tx -> HeadParameters
headParameters :: HeadParameters
headParameters, SnapshotVersion
$sel:openVersion:InitTx :: forall tx. PostChainTx tx -> SnapshotVersion
openVersion :: SnapshotVersion
openVersion, ConfirmedSnapshot Tx
contestingSnapshot :: ConfirmedSnapshot Tx
$sel:contestingSnapshot:InitTx :: forall tx. PostChainTx tx -> ConfirmedSnapshot tx
contestingSnapshot} -> do
      (SlotNo
_, UTCTime
currentTime) <- Either Text PointInTime -> STM m PointInTime
forall a. Either Text a -> STM m a
throwLeft Either Text PointInTime
currentPointInTime
      let HeadParameters{ContestationPeriod
$sel:contestationPeriod:HeadParameters :: HeadParameters -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod} = HeadParameters
headParameters
      PointInTime
upperBound <- UTCTime -> ContestationPeriod -> STM m PointInTime
calculateTxUpperBoundFromContestationPeriod UTCTime
currentTime ContestationPeriod
contestationPeriod
      case ChainContext
-> UTxO Era
-> HeadId
-> ContestationPeriod
-> SnapshotVersion
-> ConfirmedSnapshot Tx
-> PointInTime
-> Either ContestTxError Tx
contest ChainContext
ctx UTxOType Tx
UTxO Era
spendableUTxO HeadId
headId ContestationPeriod
contestationPeriod SnapshotVersion
openVersion ConfirmedSnapshot Tx
contestingSnapshot PointInTime
upperBound of
        Left ContestTxError
_ -> PostTxError Tx -> STM m Tx
forall e a. Exception e => e -> STM m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (forall tx. PostTxError tx
FailedToConstructContestTx @Tx)
        Right Tx
contestTx -> Tx -> STM m Tx
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx
contestTx
    -- These are handled in mkChain.postTx before reaching this function.
    FanoutTx{} -> PostTxError Tx -> STM m Tx
forall (m :: * -> *) e a.
(MonadSTM m, MonadThrow (STM m), Exception e) =>
e -> STM m a
throwSTM (PostTxError Tx
forall tx. PostTxError tx
FailedToConstructFanoutTx :: PostTxError Tx)
    FinalPartialFanoutTx{} -> PostTxError Tx -> STM m Tx
forall (m :: * -> *) e a.
(MonadSTM m, MonadThrow (STM m), Exception e) =>
e -> STM m a
throwSTM (PostTxError Tx
forall tx. PostTxError tx
FailedToConstructPartialFanoutTx :: PostTxError Tx)
    PartialFanoutTx{} -> PostTxError Tx -> STM m Tx
forall (m :: * -> *) e a.
(MonadSTM m, MonadThrow (STM m), Exception e) =>
e -> STM m a
throwSTM (PostTxError Tx
forall tx. PostTxError tx
FailedToConstructPartialFanoutTx :: PostTxError Tx)
 where
  -- XXX: Might want a dedicated exception type here
  throwLeft :: Either Text a -> STM m a
  throwLeft :: forall a. Either Text a -> STM m a
throwLeft = (Text -> STM m a) -> (a -> STM m a) -> Either Text a -> STM m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (IOError -> STM m a
forall (m :: * -> *) e a.
(MonadSTM m, MonadThrow (STM m), Exception e) =>
e -> STM m a
throwSTM (IOError -> STM m a) -> (Text -> IOError) -> Text -> STM m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IOError
userError (String -> IOError) -> (Text -> String) -> Text -> IOError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a. ToString a => a -> String
toString) a -> STM m a
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

  TimeHandle{Either Text PointInTime
$sel:currentPointInTime:TimeHandle :: TimeHandle -> Either Text PointInTime
currentPointInTime :: Either Text PointInTime
currentPointInTime, UTCTime -> Either Text SlotNo
$sel:slotFromUTCTime:TimeHandle :: TimeHandle -> UTCTime -> Either Text SlotNo
slotFromUTCTime :: UTCTime -> Either Text SlotNo
slotFromUTCTime} = TimeHandle
timeHandle

  -- See ADR21 for context
  calculateTxUpperBoundFromContestationPeriod :: UTCTime -> ContestationPeriod -> STM m PointInTime
calculateTxUpperBoundFromContestationPeriod UTCTime
currentTime ContestationPeriod
contestationPeriod = do
    let effectiveDelay :: NominalDiffTime
effectiveDelay = NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Ord a => a -> a -> a
min (ContestationPeriod -> NominalDiffTime
toNominalDiffTime ContestationPeriod
contestationPeriod) NominalDiffTime
maxGraceTime
    let upperBoundTime :: UTCTime
upperBoundTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
effectiveDelay UTCTime
currentTime
    SlotNo
upperBoundSlot <- Either Text SlotNo -> STM m SlotNo
forall a. Either Text a -> STM m a
throwLeft (Either Text SlotNo -> STM m SlotNo)
-> Either Text SlotNo -> STM m SlotNo
forall a b. (a -> b) -> a -> b
$ UTCTime -> Either Text SlotNo
slotFromUTCTime UTCTime
upperBoundTime
    PointInTime -> STM m PointInTime
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SlotNo
upperBoundSlot, UTCTime
upperBoundTime)

-- | Whether a fanout distributing this many outputs can be verified on chain at
-- all, and so is worth building.
--
-- Above 'Accumulator.deployedFanoutBatchSize' the head validator rejects the
-- membership proof however cheap the transaction is, and building the
-- transaction means computing that proof over the whole set — discarded on every
-- fanout step. Callers guard on this rather than passing the built transaction
-- and discarding it, so the expensive call is unreachable rather than merely
-- unforced.
canBeVerifiedOnChain :: Int -> Bool
canBeVerifiedOnChain :: Int -> Bool
canBeVerifiedOnChain Int
numOutputs =
  Int
numOutputs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
Accumulator.deployedFanoutBatchSize

-- | Binary search for the largest chunk size in @[1..maxChunk]@ for which
-- 'tryTx' returns 'Just'. Assumes the predicate is monotone: if size @n@ fits,
-- all sizes @< n@ also fit. Uses upper-mid so the search terminates correctly
-- when @hi = lo + 1@. Returns 'Left ()' if no size fits. 'tryTx' may throw to
-- abort the search early.
findLargestFitting ::
  Monad m =>
  -- | Construct and check a transaction; Just tx = fits, Nothing = doesn't fit; may throw on structural failure
  (Int -> m (Maybe tx)) ->
  -- | Upper bound of chunk sizes to search (inclusive)
  Int ->
  m (Either () tx)
findLargestFitting :: forall (m :: * -> *) tx.
Monad m =>
(Int -> m (Maybe tx)) -> Int -> m (Either () tx)
findLargestFitting Int -> m (Maybe tx)
tryTx = Either () tx -> Int -> Int -> m (Either () tx)
go (() -> Either () tx
forall a b. a -> Either a b
Left ()) Int
1
 where
  go :: Either () tx -> Int -> Int -> m (Either () tx)
go Either () tx
best Int
lo Int
hi
    | Int
lo Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
hi = Either () tx -> m (Either () tx)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either () tx
best
    | Bool
otherwise = do
        let mid :: Int
mid = (Int
lo Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
hi Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2 -- ceiling division: biases toward hi so we test the larger candidate first
        Int -> m (Maybe tx)
tryTx Int
mid m (Maybe tx) -> (Maybe tx -> m (Either () tx)) -> m (Either () tx)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Just tx
tx -> Either () tx -> Int -> Int -> m (Either () tx)
go (tx -> Either () tx
forall a b. b -> Either a b
Right tx
tx) (Int
mid Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
hi
          Maybe tx
Nothing -> Either () tx -> Int -> Int -> m (Either () tx)
go Either () tx
best Int
lo (Int
mid Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

-- | Check whether a transaction fits within protocol size and script execution
-- limits. Size check is cheap so it short-circuits before the expensive UPLC
-- evaluation. Structural errors (script failures, protocol parameter conversion
-- errors) are traced via the provided tracer; transient misses (size exceeded,
-- budget overrun) are silent.
fitsTx ::
  Monad m =>
  Tracer m CardanoChainLog ->
  (Tx -> m Bool) ->
  (Tx -> UTxO -> m (Either EvaluationError EvaluationReport)) ->
  UTxO ->
  Tx ->
  m Bool
fitsTx :: forall (m :: * -> *).
Monad m =>
Tracer m CardanoChainLog
-> (Tx -> m Bool)
-> (Tx -> UTxO Era -> m (Either EvaluationError EvaluationReport))
-> UTxO Era
-> Tx
-> m Bool
fitsTx Tracer m CardanoChainLog
tracer Tx -> m Bool
withinSizeLimits Tx -> UTxO Era -> m (Either EvaluationError EvaluationReport)
evalCosts UTxO Era
evalUTxO Tx
tx = do
  Bool
withinSize <- Tx -> m Bool
withinSizeLimits Tx
tx
  if Bool
withinSize
    then
      Tx -> UTxO Era -> m (Either EvaluationError EvaluationReport)
evalCosts Tx
tx UTxO Era
evalUTxO m (Either EvaluationError EvaluationReport)
-> (Either EvaluationError EvaluationReport -> m Bool) -> m Bool
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left TransactionBudgetOverspent{} -> Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
        Left (TransactionInvalid TransactionValidityError Era
err) -> Bool
False Bool -> m () -> m Bool
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tracer m CardanoChainLog -> CardanoChainLog -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m CardanoChainLog
tracer PartialFanoutFailed{$sel:reason:ToPost :: Text
reason = TransactionValidityError Era -> Text
forall b a. (Show a, IsString b) => a -> b
show TransactionValidityError Era
err}
        Left (PParamsConversion ProtocolParametersConversionError
err) -> Bool
False Bool -> m () -> m Bool
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tracer m CardanoChainLog -> CardanoChainLog -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m CardanoChainLog
tracer PartialFanoutFailed{$sel:reason:ToPost :: Text
reason = ProtocolParametersConversionError -> Text
forall b a. (Show a, IsString b) => a -> b
show ProtocolParametersConversionError
err}
        Right EvaluationReport
report ->
          let failures :: EvaluationReport
failures = (Either ScriptExecutionError ExecutionUnits -> Bool)
-> EvaluationReport -> EvaluationReport
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter Either ScriptExecutionError ExecutionUnits -> Bool
forall a b. Either a b -> Bool
isLeft EvaluationReport
report
           in if EvaluationReport -> Bool
forall k a. Map k a -> Bool
Map.null EvaluationReport
failures
                then Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
                else Bool
False Bool -> m () -> m Bool
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tracer m CardanoChainLog -> CardanoChainLog -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m CardanoChainLog
tracer PartialFanoutFailed{$sel:reason:ToPost :: Text
reason = EvaluationReport -> Text
renderEvaluationReport EvaluationReport
failures}
    else Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

-- | Try the preferred transaction first; if it doesn't fit within the script
-- execution budget or exceeds the maximum transaction size, fall back to a
-- binary search over partial fanout chunk sizes. Returns the largest chunk that
-- fits, minimising the number of fanout steps.
--
-- Error mapping:
--   * 'StaleChainState' from 'preparePartialFanout' → 'StalePartialFanoutTx' (race
--     condition; HeadLogic silently ignores it and the chain observation loop
--     triggers the correct next step).
--   * Any other 'PartialFanoutError' → 'FailedToConstructPartialFanoutTx'
--     (structural mismatch that will not resolve on retry).
--   * No chunk fits within budget → 'FailedToConstructPartialFanoutTx'
--     (budget exhaustion; also not a race condition).
findFittingFanoutTx ::
  forall m.
  MonadThrow m =>
  Tracer m CardanoChainLog ->
  TinyWallet m ->
  ChainContext ->
  -- | Spendable UTxO containing head output
  UTxO ->
  -- | Seed TxIn
  TxIn ->
  -- | Preferred tx to try first (FanoutTx or FinalPartialFanoutTx); 'Nothing' skips straight to the fallback loop
  Maybe Tx ->
  -- | UTxO for the accumulator check in the partial-fanout fallback (matches the on-chain datum)
  UTxO ->
  -- | UTxOs to distribute in the partial-fanout fallback
  UTxO ->
  -- | Upper bound (inclusive) of chunk sizes to search in the fallback. For the
  --   final/full fanout fallback this is @size - 1@ (the preferred tx handles
  --   the full set; a partial fanout must leave at least one output). For an
  --   explicit non-final partial fanout this is the full @size@: the selection
  --   is a strict subset of the head's remaining UTxO, so even distributing all
  --   of it leaves the unselected remainder in the accumulator and
  --   'mustNotBeLastBatch' holds (see the caller for what keeps that true).
  --   The search caps this at 'Accumulator.deployedFanoutBatchSize' regardless:
  --   no larger subset can be verified, however cheap its transaction is.
  Int ->
  -- | Contestation deadline as SlotNo
  SlotNo ->
  m Tx
findFittingFanoutTx :: forall (m :: * -> *).
MonadThrow m =>
Tracer m CardanoChainLog
-> TinyWallet m
-> ChainContext
-> UTxO Era
-> TxIn
-> Maybe Tx
-> UTxO Era
-> UTxO Era
-> Int
-> SlotNo
-> m Tx
findFittingFanoutTx Tracer m CardanoChainLog
tracer TinyWallet{Tx -> UTxO Era -> m (Either EvaluationError EvaluationReport)
evaluateScriptCosts :: Tx -> UTxO Era -> m (Either EvaluationError EvaluationReport)
$sel:evaluateScriptCosts:TinyWallet :: forall (m :: * -> *).
TinyWallet m
-> Tx -> UTxO Era -> m (Either EvaluationError EvaluationReport)
evaluateScriptCosts, Tx -> m Bool
isTxWithinSizeLimits :: Tx -> m Bool
$sel:isTxWithinSizeLimits:TinyWallet :: forall (m :: * -> *). TinyWallet m -> Tx -> m Bool
isTxWithinSizeLimits} ChainContext
ctx UTxO Era
spendableUTxO TxIn
seedTxIn Maybe Tx
ePreferred UTxO Era
proofUTxO UTxO Era
fullUTxO Int
maxChunkSize SlotNo
deadlineSlot =
  m (Either () Tx)
findBest m (Either () Tx) -> (Either () Tx -> m Tx) -> m Tx
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (() -> m Tx) -> (Tx -> m Tx) -> Either () Tx -> m Tx
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (m Tx -> () -> m Tx
forall a b. a -> b -> a
const (m Tx -> () -> m Tx) -> m Tx -> () -> m Tx
forall a b. (a -> b) -> a -> b
$ PostTxError Tx -> m Tx
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (forall tx. PostTxError tx
FailedToConstructPartialFanoutTx @Tx)) Tx -> m Tx
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
 where
  -- Try the preferred tx (full fanout or final partial fanout) first; only
  -- fall back to the binary search if it doesn't fit.
  findBest :: m (Either () Tx)
findBest = m (Either () Tx)
-> (Tx -> m (Either () Tx)) -> Maybe Tx -> m (Either () Tx)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m (Either () Tx)
findFallback Tx -> m (Either () Tx)
tryPreferred Maybe Tx
ePreferred
   where
    tryPreferred :: Tx -> m (Either () Tx)
tryPreferred Tx
tx = Tx -> m Bool
fits Tx
tx m Bool -> (Bool -> m (Either () Tx)) -> m (Either () Tx)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m (Either () Tx) -> m (Either () Tx) -> Bool -> m (Either () Tx)
forall a. a -> a -> Bool -> a
bool m (Either () Tx)
findFallback (Either () Tx -> m (Either () Tx)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx -> Either () Tx
forall a b. b -> Either a b
Right Tx
tx))

  -- Reading the head output and verifying its accumulator does not depend on the
  -- chunk size, so it happens once here rather than per candidate. There is
  -- nothing to prepare when no chunk size is in range: preparing anyway would
  -- turn a stale chain state into 'StalePartialFanoutTx', which HeadLogic
  -- ignores, where there is in fact no chunk to post and the caller should hear
  -- the terminal 'FailedToConstructPartialFanoutTx'. Note that HeadLogic only
  -- reverts the head on that error while nothing has been distributed yet, so
  -- this restores the revert on the 'FanoutTx' path and, on the
  -- 'FinalPartialFanoutTx' path, only the client error.
  findFallback :: m (Either () Tx)
findFallback
    | Int
searchRange Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 = Either () Tx -> m (Either () Tx)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> Either () Tx
forall a b. a -> Either a b
Left ())
    | Bool
otherwise = do
        PartialFanoutPlan
plan <- Either PartialFanoutError PartialFanoutPlan -> m PartialFanoutPlan
forall a. Either PartialFanoutError a -> m a
orThrow (Either PartialFanoutError PartialFanoutPlan
 -> m PartialFanoutPlan)
-> Either PartialFanoutError PartialFanoutPlan
-> m PartialFanoutPlan
forall a b. (a -> b) -> a -> b
$ UTxO Era
-> TxIn
-> UTxO Era
-> UTxO Era
-> Either PartialFanoutError PartialFanoutPlan
preparePartialFanout UTxO Era
spendableUTxO TxIn
seedTxIn UTxO Era
proofUTxO UTxO Era
fullUTxO
        (Int -> m (Maybe Tx)) -> Int -> m (Either () Tx)
forall (m :: * -> *) tx.
Monad m =>
(Int -> m (Maybe tx)) -> Int -> m (Either () tx)
findLargestFitting (PartialFanoutPlan -> Int -> m (Maybe Tx)
tryChunk PartialFanoutPlan
plan) Int
searchRange
   where
    searchRange :: Int
searchRange = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
maxChunkSize Int
Accumulator.deployedFanoutBatchSize

    tryChunk :: PartialFanoutPlan -> Int -> m (Maybe Tx)
tryChunk PartialFanoutPlan
plan Int
n = PartialFanoutPlan -> Int -> m Tx
buildTx PartialFanoutPlan
plan Int
n m Tx -> (Tx -> m (Maybe Tx)) -> m (Maybe Tx)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Tx
tx -> Maybe Tx -> Maybe Tx -> Bool -> Maybe Tx
forall a. a -> a -> Bool -> a
bool Maybe Tx
forall a. Maybe a
Nothing (Tx -> Maybe Tx
forall a. a -> Maybe a
Just Tx
tx) (Bool -> Maybe Tx) -> m Bool -> m (Maybe Tx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tx -> m Bool
fits Tx
tx

  buildTx :: PartialFanoutPlan -> Int -> m Tx
buildTx PartialFanoutPlan
plan Int
n =
    Either PartialFanoutError Tx -> m Tx
forall a. Either PartialFanoutError a -> m a
orThrow (Either PartialFanoutError Tx -> m Tx)
-> Either PartialFanoutError Tx -> m Tx
forall a b. (a -> b) -> a -> b
$ ChainContext
-> PartialFanoutPlan
-> Int
-> SlotNo
-> Either PartialFanoutError Tx
partialFanoutFromPlan ChainContext
ctx PartialFanoutPlan
plan Int
n SlotNo
deadlineSlot

  orThrow :: Either PartialFanoutError a -> m a
  orThrow :: forall a. Either PartialFanoutError a -> m a
orThrow = (PartialFanoutError -> m a)
-> (a -> m a) -> Either PartialFanoutError a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either PartialFanoutError -> m a
handleErr a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
   where
    handleErr :: PartialFanoutError -> m a
handleErr PartialFanoutError
err = do
      Tracer m CardanoChainLog -> CardanoChainLog -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m CardanoChainLog
tracer PartialFanoutFailed{$sel:reason:ToPost :: Text
reason = PartialFanoutError -> Text
forall b a. (Show a, IsString b) => a -> b
show PartialFanoutError
err}
      PostTxError Tx -> m a
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (PostTxError Tx -> m a) -> PostTxError Tx -> m a
forall a b. (a -> b) -> a -> b
$ case PartialFanoutError
err of
        PartialFanoutError
StaleChainState -> forall tx. PostTxError tx
StalePartialFanoutTx @Tx
        -- Everything else stays terminal, including 'CannotFindHeadOutput'.
        -- A missing head output usually does mean another fanout consumed it,
        -- which is benign, but 'StalePartialFanoutTx' is silently ignored by
        -- HeadLogic: reporting it that way would also swallow the cases where the
        -- output is missing for some other reason, losing both the revert to
        -- 'Closed' and the client notification.
        PartialFanoutError
_ -> forall tx. PostTxError tx
FailedToConstructPartialFanoutTx @Tx

  fits :: Tx -> m Bool
fits = Tracer m CardanoChainLog
-> (Tx -> m Bool)
-> (Tx -> UTxO Era -> m (Either EvaluationError EvaluationReport))
-> UTxO Era
-> Tx
-> m Bool
forall (m :: * -> *).
Monad m =>
Tracer m CardanoChainLog
-> (Tx -> m Bool)
-> (Tx -> UTxO Era -> m (Either EvaluationError EvaluationReport))
-> UTxO Era
-> Tx
-> m Bool
fitsTx Tracer m CardanoChainLog
tracer Tx -> m Bool
isTxWithinSizeLimits Tx -> UTxO Era -> m (Either EvaluationError EvaluationReport)
evaluateScriptCosts UTxO Era
evalUTxO

  evalUTxO :: UTxO Era
evalUTxO = UTxO Era
spendableUTxO UTxO Era -> UTxO Era -> UTxO Era
forall a. Semigroup a => a -> a -> a
<> ChainContext -> UTxO Era
forall a. HasKnownUTxO a => a -> UTxO Era
getKnownUTxO ChainContext
ctx

-- | Maximum delay we put on the upper bound of transactions to fit into a block.
-- NOTE: This is highly depending on the network. If the security parameter and
-- epoch length result in a short horizon, this is problematic.
maxGraceTime :: NominalDiffTime
maxGraceTime :: NominalDiffTime
maxGraceTime = NominalDiffTime
200

--
-- Tracing
--

data StartingDecision
  = FromProvided ChainPoint
  | FromTip ChainPoint
  | FromPersisted
      { StartingDecision -> ChainPoint
chainPoint :: ChainPoint
      , StartingDecision -> Bool
startChainFromSet :: Bool
      -- ^ Whether the user-provided --start-chain-from point was set
      -- but ignored, because it was older than persisted points.
      }
  deriving stock (StartingDecision -> StartingDecision -> Bool
(StartingDecision -> StartingDecision -> Bool)
-> (StartingDecision -> StartingDecision -> Bool)
-> Eq StartingDecision
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StartingDecision -> StartingDecision -> Bool
== :: StartingDecision -> StartingDecision -> Bool
$c/= :: StartingDecision -> StartingDecision -> Bool
/= :: StartingDecision -> StartingDecision -> Bool
Eq, Int -> StartingDecision -> ShowS
[StartingDecision] -> ShowS
StartingDecision -> String
(Int -> StartingDecision -> ShowS)
-> (StartingDecision -> String)
-> ([StartingDecision] -> ShowS)
-> Show StartingDecision
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StartingDecision -> ShowS
showsPrec :: Int -> StartingDecision -> ShowS
$cshow :: StartingDecision -> String
show :: StartingDecision -> String
$cshowList :: [StartingDecision] -> ShowS
showList :: [StartingDecision] -> ShowS
Show, (forall x. StartingDecision -> Rep StartingDecision x)
-> (forall x. Rep StartingDecision x -> StartingDecision)
-> Generic StartingDecision
forall x. Rep StartingDecision x -> StartingDecision
forall x. StartingDecision -> Rep StartingDecision x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. StartingDecision -> Rep StartingDecision x
from :: forall x. StartingDecision -> Rep StartingDecision x
$cto :: forall x. Rep StartingDecision x -> StartingDecision
to :: forall x. Rep StartingDecision x -> StartingDecision
Generic)
  deriving anyclass ([StartingDecision] -> Value
[StartingDecision] -> Encoding
StartingDecision -> Bool
StartingDecision -> Value
StartingDecision -> Encoding
(StartingDecision -> Value)
-> (StartingDecision -> Encoding)
-> ([StartingDecision] -> Value)
-> ([StartingDecision] -> Encoding)
-> (StartingDecision -> Bool)
-> ToJSON StartingDecision
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: StartingDecision -> Value
toJSON :: StartingDecision -> Value
$ctoEncoding :: StartingDecision -> Encoding
toEncoding :: StartingDecision -> Encoding
$ctoJSONList :: [StartingDecision] -> Value
toJSONList :: [StartingDecision] -> Value
$ctoEncodingList :: [StartingDecision] -> Encoding
toEncodingList :: [StartingDecision] -> Encoding
$comitField :: StartingDecision -> Bool
omitField :: StartingDecision -> Bool
ToJSON)

data CardanoChainLog
  = ToPost {CardanoChainLog -> PostChainTx Tx
toPost :: PostChainTx Tx}
  | PostingTx {CardanoChainLog -> TxId
txId :: TxId}
  | PostedTx {txId :: TxId}
  | PostingFailed {CardanoChainLog -> Tx
tx :: Tx, CardanoChainLog -> PostTxError Tx
postTxError :: PostTxError Tx}
  | RolledForward {CardanoChainLog -> ChainPoint
point :: ChainPoint, CardanoChainLog -> [TxId]
receivedTxIds :: [TxId]}
  | RolledBackward {point :: ChainPoint}
  | Wallet TinyWalletLog
  | StartingChainDecision StartingDecision
  | BlockfrostTransientError {CardanoChainLog -> Text
reason :: Text, CardanoChainLog -> Int
retryDelay :: Int}
  | PartialFanoutFailed {reason :: Text}
  deriving stock (CardanoChainLog -> CardanoChainLog -> Bool
(CardanoChainLog -> CardanoChainLog -> Bool)
-> (CardanoChainLog -> CardanoChainLog -> Bool)
-> Eq CardanoChainLog
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CardanoChainLog -> CardanoChainLog -> Bool
== :: CardanoChainLog -> CardanoChainLog -> Bool
$c/= :: CardanoChainLog -> CardanoChainLog -> Bool
/= :: CardanoChainLog -> CardanoChainLog -> Bool
Eq, Int -> CardanoChainLog -> ShowS
[CardanoChainLog] -> ShowS
CardanoChainLog -> String
(Int -> CardanoChainLog -> ShowS)
-> (CardanoChainLog -> String)
-> ([CardanoChainLog] -> ShowS)
-> Show CardanoChainLog
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CardanoChainLog -> ShowS
showsPrec :: Int -> CardanoChainLog -> ShowS
$cshow :: CardanoChainLog -> String
show :: CardanoChainLog -> String
$cshowList :: [CardanoChainLog] -> ShowS
showList :: [CardanoChainLog] -> ShowS
Show, (forall x. CardanoChainLog -> Rep CardanoChainLog x)
-> (forall x. Rep CardanoChainLog x -> CardanoChainLog)
-> Generic CardanoChainLog
forall x. Rep CardanoChainLog x -> CardanoChainLog
forall x. CardanoChainLog -> Rep CardanoChainLog x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CardanoChainLog -> Rep CardanoChainLog x
from :: forall x. CardanoChainLog -> Rep CardanoChainLog x
$cto :: forall x. Rep CardanoChainLog x -> CardanoChainLog
to :: forall x. Rep CardanoChainLog x -> CardanoChainLog
Generic)
  deriving anyclass ([CardanoChainLog] -> Value
[CardanoChainLog] -> Encoding
CardanoChainLog -> Bool
CardanoChainLog -> Value
CardanoChainLog -> Encoding
(CardanoChainLog -> Value)
-> (CardanoChainLog -> Encoding)
-> ([CardanoChainLog] -> Value)
-> ([CardanoChainLog] -> Encoding)
-> (CardanoChainLog -> Bool)
-> ToJSON CardanoChainLog
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: CardanoChainLog -> Value
toJSON :: CardanoChainLog -> Value
$ctoEncoding :: CardanoChainLog -> Encoding
toEncoding :: CardanoChainLog -> Encoding
$ctoJSONList :: [CardanoChainLog] -> Value
toJSONList :: [CardanoChainLog] -> Value
$ctoEncodingList :: [CardanoChainLog] -> Encoding
toEncodingList :: [CardanoChainLog] -> Encoding
$comitField :: CardanoChainLog -> Bool
omitField :: CardanoChainLog -> Bool
ToJSON)