{-# 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 maintainance of on-chain relevant state.
module Hydra.Chain.Direct.Handlers where

import Hydra.Prelude

import Cardano.Api.UTxO qualified as UTxO
import Cardano.Slotting.Slot (SlotNo (..))
import Control.Concurrent.Class.MonadSTM (modifyTVar, newTVarIO, writeTVar)
import Control.Monad.Class.MonadSTM (throwSTM)
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Hydra.Cardano.Api (
  BlockHeader,
  ChainPoint (..),
  Tx,
  TxId,
  chainPointToSlotNo,
  fromLedgerTxIn,
  getChainPoint,
  getTxBody,
  getTxId,
 )
import Hydra.Chain (
  Chain (..),
  ChainCallback,
  ChainEvent (..),
  ChainStateHistory,
  ChainStateType,
  HeadParameters (..),
  IsChainState,
  OnChainTx (..),
  PostChainTx (..),
  PostTxError (..),
  currentState,
  pushNewState,
  rollbackHistory,
 )
import Hydra.Chain.Direct.State (
  ChainContext (..),
  ChainStateAt (..),
  abort,
  chainSlotFromPoint,
  close,
  collect,
  commit',
  contest,
  fanout,
  getKnownUTxO,
  initialize,
 )
import Hydra.Chain.Direct.TimeHandle (TimeHandle (..))
import Hydra.Chain.Direct.Tx (
  AbortObservation (..),
  CloseObservation (..),
  ClosedThreadOutput (..),
  CollectComObservation (..),
  CommitObservation (..),
  ContestObservation (..),
  FanoutObservation (..),
  HeadObservation (..),
  InitObservation (..),
  headSeedToTxIn,
  observeHeadTx,
  txInToHeadSeed,
 )
import Hydra.Chain.Direct.Wallet (
  ErrCoverFee (..),
  TinyWallet (..),
  TinyWalletLog,
 )
import Hydra.ContestationPeriod (toNominalDiffTime)
import Hydra.Ledger (ChainSlot (ChainSlot), UTxOType)
import Hydra.Ledger.Cardano (adjustUTxO)
import Hydra.Logging (Tracer, traceWith)
import Hydra.Plutus.Extras (posixToUTCTime)
import Hydra.Plutus.Orphans ()
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 ::
  (MonadSTM m, IsChainState tx) =>
  ChainStateHistory tx ->
  m (LocalChainState m tx)
newLocalChainState :: forall (m :: * -> *) tx.
(MonadSTM m, IsChainState tx) =>
ChainStateHistory tx -> m (LocalChainState m tx)
newLocalChainState ChainStateHistory tx
chainState = do
  TVar m (ChainStateHistory tx)
tv <- ChainStateHistory tx -> m (TVar m (ChainStateHistory tx))
forall a. a -> m (TVar m a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
newTVarIO 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)
forall {m :: * -> *} {tx}.
MonadSTM m =>
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 ()
forall {m :: * -> *} {tx}.
MonadSTM m =>
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)
forall {m :: * -> *} {tx}.
(MonadSTM m, IsChainState tx) =>
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
  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)
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.
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)
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 DirectChainLog ->
  -- | Means to acquire a new 'TimeHandle'.
  GetTimeHandle m ->
  TinyWallet m ->
  ChainContext ->
  LocalChainState m Tx ->
  SubmitTx m ->
  Chain Tx m
mkChain :: forall (m :: * -> *).
(MonadSTM m, MonadThrow (STM m)) =>
Tracer m DirectChainLog
-> GetTimeHandle m
-> TinyWallet m
-> ChainContext
-> LocalChainState m Tx
-> SubmitTx m
-> Chain Tx m
mkChain Tracer m DirectChainLog
tracer GetTimeHandle m
queryTimeHandle wallet :: TinyWallet m
wallet@TinyWallet{STM m (Map TxIn TxOut)
getUTxO :: STM m (Map TxIn TxOut)
$sel:getUTxO:TinyWallet :: forall (m :: * -> *). TinyWallet m -> STM m (Map TxIn TxOut)
getUTxO} ChainContext
ctx 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
spendableUTxO :: UTxO
$sel:spendableUTxO:ChainStateAt :: ChainStateAt -> UTxO
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 DirectChainLog -> DirectChainLog -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m DirectChainLog
tracer (DirectChainLog -> m ()) -> DirectChainLog -> m ()
forall a b. (a -> b) -> a -> b
$ ToPost{$sel:toPost:ToPost :: PostChainTx Tx
toPost = PostChainTx Tx
tx}
        TimeHandle
timeHandle <- GetTimeHandle m
queryTimeHandle
        Tx
vtx <-
          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
-> TinyWallet m
-> ChainContext
-> UTxOType Tx
-> PostChainTx Tx
-> STM m Tx
forall (m :: * -> *).
(MonadSTM m, MonadThrow (STM m)) =>
TimeHandle
-> TinyWallet m
-> ChainContext
-> UTxOType Tx
-> PostChainTx Tx
-> STM m Tx
prepareTxToPost TimeHandle
timeHandle TinyWallet m
wallet ChainContext
ctx UTxO
UTxOType Tx
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 -> UTxO -> Tx -> m Tx
forall (m :: * -> *).
MonadThrow m =>
TinyWallet m -> ChainContext -> UTxO -> UTxO -> Tx -> m Tx
finalizeTx TinyWallet m
wallet ChainContext
ctx UTxO
spendableUTxO UTxO
forall a. Monoid a => a
mempty
        SubmitTx m
submitTx Tx
vtx
    , -- Handle that creates a draft commit tx using the user utxo.
      -- Possible errors are handled at the api server level.
      $sel:draftCommitTx:Chain :: MonadThrow m =>
HeadId
-> UTxO' (TxOut CtxUTxO, Witness WitCtxTxIn)
-> m (Either (PostTxError Tx) Tx)
draftCommitTx = \HeadId
headId UTxO' (TxOut CtxUTxO, Witness WitCtxTxIn)
utxoToCommit -> do
        ChainStateAt{UTxO
$sel:spendableUTxO:ChainStateAt :: ChainStateAt -> UTxO
spendableUTxO :: UTxO
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
        Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
walletUtxos <- STM m (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
-> m (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM m (Map TxIn TxOut)
STM m (Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)))
getUTxO
        let walletTxIns :: [TxIn]
walletTxIns = TxIn -> TxIn
fromLedgerTxIn (TxIn -> TxIn) -> [TxIn] -> [TxIn]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map TxIn (BabbageTxOut (BabbageEra StandardCrypto)) -> [TxIn]
forall k a. Map k a -> [k]
Map.keys Map TxIn (BabbageTxOut (BabbageEra StandardCrypto))
walletUtxos
        let userTxIns :: [TxIn]
userTxIns = Set TxIn -> [TxIn]
forall a. Set a -> [a]
Set.toList (Set TxIn -> [TxIn]) -> Set TxIn -> [TxIn]
forall a b. (a -> b) -> a -> b
$ UTxO' (TxOut CtxUTxO, Witness WitCtxTxIn) -> Set TxIn
forall out. UTxO' out -> Set TxIn
UTxO.inputSet UTxO' (TxOut CtxUTxO, Witness WitCtxTxIn)
utxoToCommit
        let matchedWalletUtxo :: [TxIn]
matchedWalletUtxo = (TxIn -> Bool) -> [TxIn] -> [TxIn]
forall a. (a -> Bool) -> [a] -> [a]
filter (TxIn -> [TxIn] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [TxIn]
walletTxIns) [TxIn]
userTxIns
        -- prevent trying to spend internal wallet's utxo
        if [TxIn] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TxIn]
matchedWalletUtxo
          then
            (Tx -> m Tx)
-> Either (PostTxError Tx) Tx -> m (Either (PostTxError Tx) Tx)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b)
-> Either (PostTxError Tx) a -> f (Either (PostTxError Tx) b)
traverse (TinyWallet m -> ChainContext -> UTxO -> UTxO -> Tx -> m Tx
forall (m :: * -> *).
MonadThrow m =>
TinyWallet m -> ChainContext -> UTxO -> UTxO -> Tx -> m Tx
finalizeTx TinyWallet m
wallet ChainContext
ctx UTxO
spendableUTxO ((TxOut CtxUTxO, Witness WitCtxTxIn) -> TxOut CtxUTxO
forall a b. (a, b) -> a
fst ((TxOut CtxUTxO, Witness WitCtxTxIn) -> TxOut CtxUTxO)
-> UTxO' (TxOut CtxUTxO, Witness WitCtxTxIn) -> UTxO
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxO' (TxOut CtxUTxO, Witness WitCtxTxIn)
utxoToCommit)) (Either (PostTxError Tx) Tx -> m (Either (PostTxError Tx) Tx))
-> Either (PostTxError Tx) Tx -> m (Either (PostTxError Tx) Tx)
forall a b. (a -> b) -> a -> b
$
              ChainContext
-> HeadId
-> UTxO
-> UTxO' (TxOut CtxUTxO, Witness WitCtxTxIn)
-> Either (PostTxError Tx) Tx
commit' ChainContext
ctx HeadId
headId UTxO
spendableUTxO UTxO' (TxOut CtxUTxO, Witness WitCtxTxIn)
utxoToCommit
          else Either (PostTxError Tx) Tx -> m (Either (PostTxError Tx) Tx)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (PostTxError Tx) Tx -> m (Either (PostTxError Tx) Tx))
-> Either (PostTxError Tx) Tx -> m (Either (PostTxError Tx) Tx)
forall a b. (a -> b) -> a -> b
$ PostTxError Tx -> Either (PostTxError Tx) Tx
forall a b. a -> Either a b
Left PostTxError Tx
forall tx. PostTxError tx
SpendingNodeUtxoForbidden
    , -- 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
    }

-- | Balance and sign the given partial transaction.
finalizeTx ::
  MonadThrow m =>
  TinyWallet m ->
  ChainContext ->
  UTxO.UTxO ->
  UTxO.UTxO ->
  Tx ->
  m Tx
finalizeTx :: forall (m :: * -> *).
MonadThrow m =>
TinyWallet m -> ChainContext -> UTxO -> UTxO -> Tx -> m Tx
finalizeTx TinyWallet{Tx -> Tx
sign :: Tx -> Tx
$sel:sign:TinyWallet :: forall (m :: * -> *). TinyWallet m -> Tx -> Tx
sign, UTxO -> Tx -> m (Either ErrCoverFee Tx)
coverFee :: UTxO -> Tx -> m (Either ErrCoverFee Tx)
$sel:coverFee:TinyWallet :: forall (m :: * -> *).
TinyWallet m -> UTxO -> Tx -> m (Either ErrCoverFee Tx)
coverFee} ChainContext
ctx UTxO
utxo UTxO
userUTxO Tx
partialTx = do
  let headUTxO :: UTxO
headUTxO = ChainContext -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO ChainContext
ctx UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxO
utxo UTxO -> UTxO -> UTxO
forall a. Semigroup a => a -> a -> a
<> UTxO
userUTxO
  UTxO -> Tx -> m (Either ErrCoverFee Tx)
coverFee UTxO
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 (PostTxError Tx
forall tx. PostTxError tx
NoFuelUTXOFound :: PostTxError Tx)
    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 (PostTxError Tx
forall tx. PostTxError tx
NotEnoughFuel :: PostTxError Tx)
    Left ErrScriptExecutionFailed{$sel:scriptFailure:ErrNotEnoughFunds :: ErrCoverFee
-> (PlutusPurpose AsIndex LedgerEra,
    TransactionScriptFailure LedgerEra)
scriptFailure = (PlutusPurpose AsIndex LedgerEra
redeemerPtr, TransactionScriptFailure LedgerEra
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 = AlonzoPlutusPurpose AsIndex (BabbageEra StandardCrypto) -> Text
forall b a. (Show a, IsString b) => a -> b
show PlutusPurpose AsIndex LedgerEra
AlonzoPlutusPurpose AsIndex (BabbageEra StandardCrypto)
redeemerPtr
            , $sel:failureReason:NoSeedInput :: Text
failureReason = TransactionScriptFailure (BabbageEra StandardCrypto) -> Text
forall b a. (Show a, IsString b) => a -> b
show TransactionScriptFailure LedgerEra
TransactionScriptFailure (BabbageEra StandardCrypto)
scriptFailure
            } ::
            PostTxError Tx
        )
    Left ErrCoverFee
e -> do
      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
            { UTxO
UTxOType Tx
headUTxO :: UTxO
$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:tx:NoSeedInput :: Tx
tx = Tx
partialTx
            } ::
            PostTxError Tx
        )
    Right Tx
balancedTx -> do
      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 DirectChainLog ->
  ChainCallback Tx m ->
  -- | Means to acquire a new 'TimeHandle'.
  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 DirectChainLog
-> ChainCallback Tx m
-> GetTimeHandle m
-> ChainContext
-> LocalChainState m Tx
-> ChainSyncHandler m
chainSyncHandler Tracer m DirectChainLog
tracer ChainCallback Tx m
callback 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
networkId :: NetworkId
$sel:networkId:ChainContext :: ChainContext -> 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 DirectChainLog -> DirectChainLog -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m DirectChainLog
tracer (DirectChainLog -> m ()) -> DirectChainLog -> m ()
forall a b. (a -> b) -> a -> b
$ RolledBackward{ChainPoint
point :: ChainPoint
$sel:point:ToPost :: ChainPoint
point}
    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}

  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 DirectChainLog -> DirectChainLog -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m DirectChainLog
tracer (DirectChainLog -> m ()) -> DirectChainLog -> 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
        }

    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
        TimeHandle
timeHandle <- GetTimeHandle m
getTimeHandle
        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
            let chainSlot :: ChainSlot
chainSlot = Natural -> ChainSlot
ChainSlot (Natural -> ChainSlot)
-> (Word64 -> Natural) -> Word64 -> ChainSlot
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> ChainSlot) -> Word64 -> ChainSlot
forall a b. (a -> b) -> a -> b
$ SlotNo -> Word64
unSlotNo SlotNo
slotNo
            ChainCallback Tx m
callback (Tick{$sel:chainTime:Observation :: UTCTime
chainTime = UTCTime
utcTime, ChainSlot
chainSlot :: ChainSlot
$sel:chainSlot:Observation :: ChainSlot
chainSlot})

    [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
$
      ChainPoint -> Tx -> m (Maybe (ChainEvent Tx))
maybeObserveSomeTx 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

  maybeObserveSomeTx :: ChainPoint -> Tx -> m (Maybe (ChainEvent Tx))
maybeObserveSomeTx 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
$sel:spendableUTxO:ChainStateAt :: ChainStateAt -> UTxO
spendableUTxO :: UTxO
spendableUTxO} <- STM m (ChainStateType Tx)
STM m ChainStateAt
getLatest
    let observation :: HeadObservation
observation = NetworkId -> UTxO -> Tx -> HeadObservation
observeHeadTx NetworkId
networkId UTxO
spendableUTxO Tx
tx
    case HeadObservation -> Maybe (OnChainTx Tx)
convertObservation 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
spendableUTxO = Tx -> UTxO -> UTxO
adjustUTxO Tx
tx UTxO
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 :: HeadObservation -> Maybe (OnChainTx Tx)
convertObservation :: HeadObservation -> Maybe (OnChainTx Tx)
convertObservation = \case
  HeadObservation
NoHeadTx -> Maybe (OnChainTx Tx)
forall a. Maybe a
Nothing
  Init InitObservation{HeadId
headId :: HeadId
$sel:headId:InitObservation :: InitObservation -> HeadId
headId, ContestationPeriod
contestationPeriod :: ContestationPeriod
$sel:contestationPeriod:InitObservation :: InitObservation -> ContestationPeriod
contestationPeriod, [Party]
parties :: [Party]
$sel:parties:InitObservation :: InitObservation -> [Party]
parties, TxIn
seedTxIn :: TxIn
$sel:seedTxIn:InitObservation :: InitObservation -> TxIn
seedTxIn, [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
        , $sel:headSeed:OnInitTx :: HeadSeed
headSeed = TxIn -> HeadSeed
txInToHeadSeed TxIn
seedTxIn
        , $sel:headParameters:OnInitTx :: HeadParameters
headParameters = HeadParameters{ContestationPeriod
contestationPeriod :: ContestationPeriod
$sel:contestationPeriod:HeadParameters :: ContestationPeriod
contestationPeriod, [Party]
parties :: [Party]
$sel:parties:HeadParameters :: [Party]
parties}
        , [OnChainId]
participants :: [OnChainId]
$sel:participants:OnInitTx :: [OnChainId]
participants
        }
  Abort AbortObservation{HeadId
headId :: HeadId
$sel:headId:AbortObservation :: AbortObservation -> HeadId
headId} ->
    OnChainTx Tx -> Maybe (OnChainTx Tx)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OnAbortTx{HeadId
$sel:headId:OnInitTx :: HeadId
headId :: HeadId
headId}
  Commit CommitObservation{HeadId
headId :: HeadId
$sel:headId:CommitObservation :: CommitObservation -> HeadId
headId, Party
party :: Party
$sel:party:CommitObservation :: CommitObservation -> Party
party, UTxO
committed :: UTxO
$sel:committed:CommitObservation :: CommitObservation -> UTxO
committed} ->
    OnChainTx Tx -> Maybe (OnChainTx Tx)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OnCommitTx{HeadId
$sel:headId:OnInitTx :: HeadId
headId :: HeadId
headId, Party
party :: Party
$sel:party:OnInitTx :: Party
party, UTxO
UTxOType Tx
committed :: UTxO
$sel:committed:OnInitTx :: UTxOType Tx
committed}
  CollectCom CollectComObservation{HeadId
headId :: HeadId
$sel:headId:CollectComObservation :: CollectComObservation -> HeadId
headId} ->
    OnChainTx Tx -> Maybe (OnChainTx Tx)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OnCollectComTx{HeadId
$sel:headId:OnInitTx :: HeadId
headId :: HeadId
headId}
  Close CloseObservation{HeadId
headId :: HeadId
$sel:headId:CloseObservation :: CloseObservation -> HeadId
headId, SnapshotNumber
snapshotNumber :: SnapshotNumber
$sel:snapshotNumber:CloseObservation :: CloseObservation -> SnapshotNumber
snapshotNumber, $sel:threadOutput:CloseObservation :: CloseObservation -> ClosedThreadOutput
threadOutput = ClosedThreadOutput{POSIXTime
closedContestationDeadline :: POSIXTime
$sel:closedContestationDeadline:ClosedThreadOutput :: ClosedThreadOutput -> POSIXTime
closedContestationDeadline}} ->
    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
        , $sel:contestationDeadline:OnInitTx :: UTCTime
contestationDeadline = POSIXTime -> UTCTime
posixToUTCTime POSIXTime
closedContestationDeadline
        }
  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} ->
    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}

prepareTxToPost ::
  (MonadSTM m, MonadThrow (STM m)) =>
  TimeHandle ->
  TinyWallet m ->
  ChainContext ->
  -- | Spendable UTxO
  UTxOType Tx ->
  PostChainTx Tx ->
  STM m Tx
prepareTxToPost :: forall (m :: * -> *).
(MonadSTM m, MonadThrow (STM m)) =>
TimeHandle
-> TinyWallet m
-> ChainContext
-> UTxOType Tx
-> PostChainTx Tx
-> STM m Tx
prepareTxToPost TimeHandle
timeHandle TinyWallet m
wallet ChainContext
ctx UTxOType Tx
spendableUTxO PostChainTx Tx
tx =
  case PostChainTx Tx
tx of
    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} ->
      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 Tx) -> STM m Tx
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
>>= \case
        Just TxIn
seedInput ->
          Tx -> STM m Tx
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx -> STM m Tx) -> Tx -> STM m Tx
forall a b. (a -> b) -> a -> b
$ ChainContext -> TxIn -> [OnChainId] -> HeadParameters -> Tx
initialize ChainContext
ctx TxIn
seedInput [OnChainId]
participants HeadParameters
headParameters
        Maybe TxIn
Nothing ->
          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
NoSeedInput @Tx)
    AbortTx{UTxOType Tx
utxo :: UTxOType Tx
$sel:utxo:InitTx :: forall tx. PostChainTx tx -> UTxOType tx
utxo, HeadSeed
headSeed :: HeadSeed
$sel:headSeed:InitTx :: forall tx. PostChainTx tx -> HeadSeed
headSeed} ->
      case HeadSeed -> Maybe TxIn
forall (m :: * -> *). MonadFail m => HeadSeed -> m TxIn
headSeedToTxIn HeadSeed
headSeed of
        Maybe TxIn
Nothing ->
          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 (InvalidSeed{HeadSeed
headSeed :: HeadSeed
$sel:headSeed:NoSeedInput :: HeadSeed
headSeed} :: PostTxError Tx)
        Just TxIn
seedTxIn ->
          case ChainContext -> TxIn -> UTxO -> UTxO -> Either AbortTxError Tx
abort ChainContext
ctx TxIn
seedTxIn UTxO
UTxOType Tx
spendableUTxO UTxO
UTxOType Tx
utxo of
            Left AbortTxError
_ -> 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
FailedToConstructAbortTx @Tx)
            Right Tx
abortTx -> Tx -> STM m Tx
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx
abortTx
    -- TODO: We do not rely on the utxo from the collect com tx here because the
    -- chain head-state is already tracking UTXO entries locked by commit scripts,
    -- and thus, can re-construct the committed UTXO for the collectComTx from
    -- the commits' datums.
    --
    -- Perhaps we do want however to perform some kind of sanity check to ensure
    -- that both states are consistent.
    CollectComTx{UTxOType Tx
$sel:utxo:InitTx :: forall tx. PostChainTx tx -> UTxOType tx
utxo :: UTxOType Tx
utxo, HeadId
headId :: HeadId
$sel:headId:InitTx :: forall tx. PostChainTx tx -> HeadId
headId, HeadParameters
$sel:headParameters:InitTx :: forall tx. PostChainTx tx -> HeadParameters
headParameters :: HeadParameters
headParameters} ->
      case ChainContext
-> HeadId
-> HeadParameters
-> UTxO
-> UTxO
-> Either CollectTxError Tx
collect ChainContext
ctx HeadId
headId HeadParameters
headParameters UTxO
UTxOType Tx
utxo UTxO
UTxOType Tx
spendableUTxO of
        Left CollectTxError
_ -> 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
FailedToConstructCollectTx @Tx)
        Right Tx
collectTx -> Tx -> STM m Tx
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx
collectTx
    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, ConfirmedSnapshot Tx
confirmedSnapshot :: ConfirmedSnapshot Tx
$sel:confirmedSnapshot:InitTx :: forall tx. PostChainTx tx -> ConfirmedSnapshot tx
confirmedSnapshot} -> do
      (SlotNo
currentSlot, UTCTime
currentTime) <- Either Text (SlotNo, UTCTime) -> STM m (SlotNo, UTCTime)
forall {b}. Either Text b -> STM m b
throwLeft Either Text (SlotNo, UTCTime)
currentPointInTime
      let HeadParameters{ContestationPeriod
$sel:contestationPeriod:HeadParameters :: HeadParameters -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod} = HeadParameters
headParameters
      (SlotNo, UTCTime)
upperBound <- UTCTime -> ContestationPeriod -> STM m (SlotNo, UTCTime)
calculateTxUpperBoundFromContestationPeriod UTCTime
currentTime ContestationPeriod
contestationPeriod
      case ChainContext
-> UTxO
-> HeadId
-> HeadParameters
-> ConfirmedSnapshot Tx
-> SlotNo
-> (SlotNo, UTCTime)
-> Either CloseTxError Tx
close ChainContext
ctx UTxO
UTxOType Tx
spendableUTxO HeadId
headId HeadParameters
headParameters ConfirmedSnapshot Tx
confirmedSnapshot SlotNo
currentSlot (SlotNo, UTCTime)
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, ConfirmedSnapshot Tx
$sel:confirmedSnapshot:InitTx :: forall tx. PostChainTx tx -> ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot Tx
confirmedSnapshot} -> do
      (SlotNo
_, UTCTime
currentTime) <- Either Text (SlotNo, UTCTime) -> STM m (SlotNo, UTCTime)
forall {b}. Either Text b -> STM m b
throwLeft Either Text (SlotNo, UTCTime)
currentPointInTime
      let HeadParameters{ContestationPeriod
$sel:contestationPeriod:HeadParameters :: HeadParameters -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod} = HeadParameters
headParameters
      (SlotNo, UTCTime)
upperBound <- UTCTime -> ContestationPeriod -> STM m (SlotNo, UTCTime)
calculateTxUpperBoundFromContestationPeriod UTCTime
currentTime ContestationPeriod
contestationPeriod
      case ChainContext
-> UTxO
-> HeadId
-> ContestationPeriod
-> ConfirmedSnapshot Tx
-> (SlotNo, UTCTime)
-> Either ContestTxError Tx
contest ChainContext
ctx UTxO
UTxOType Tx
spendableUTxO HeadId
headId ContestationPeriod
contestationPeriod ConfirmedSnapshot Tx
confirmedSnapshot (SlotNo, UTCTime)
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
    FanoutTx{UTxOType Tx
$sel:utxo:InitTx :: forall tx. PostChainTx tx -> UTxOType tx
utxo :: UTxOType Tx
utxo, HeadSeed
$sel:headSeed:InitTx :: forall tx. PostChainTx tx -> HeadSeed
headSeed :: HeadSeed
headSeed, UTCTime
contestationDeadline :: UTCTime
$sel:contestationDeadline:InitTx :: forall tx. PostChainTx tx -> UTCTime
contestationDeadline} -> do
      SlotNo
deadlineSlot <- Either Text SlotNo -> STM m SlotNo
forall {b}. Either Text b -> STM m b
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
contestationDeadline
      case HeadSeed -> Maybe TxIn
forall (m :: * -> *). MonadFail m => HeadSeed -> m TxIn
headSeedToTxIn HeadSeed
headSeed of
        Maybe TxIn
Nothing ->
          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 (InvalidSeed{HeadSeed
$sel:headSeed:NoSeedInput :: HeadSeed
headSeed :: HeadSeed
headSeed} :: PostTxError Tx)
        Just TxIn
seedTxIn ->
          case ChainContext
-> UTxO -> TxIn -> UTxO -> SlotNo -> Either FanoutTxError Tx
fanout ChainContext
ctx UTxO
UTxOType Tx
spendableUTxO TxIn
seedTxIn UTxO
UTxOType Tx
utxo SlotNo
deadlineSlot of
            Left FanoutTxError
_ -> 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
FailedToConstructFanoutTx @Tx)
            Right Tx
fanoutTx -> Tx -> STM m Tx
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx
fanoutTx
 where
  -- XXX: Might want a dedicated exception type here
  throwLeft :: Either Text b -> STM m b
throwLeft = (Text -> STM m b) -> (b -> STM m b) -> Either Text b -> STM m b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (IOError -> STM m b
forall (m :: * -> *) e a.
(MonadSTM m, MonadThrow (STM m), Exception e) =>
e -> STM m a
throwSTM (IOError -> STM m b) -> (Text -> IOError) -> Text -> STM m b
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) b -> STM m b
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

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

  -- See ADR21 for context
  calculateTxUpperBoundFromContestationPeriod :: UTCTime -> ContestationPeriod -> STM m (SlotNo, UTCTime)
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 {b}. Either Text b -> STM m b
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
    (SlotNo, UTCTime) -> STM m (SlotNo, UTCTime)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SlotNo
upperBoundSlot, UTCTime
upperBoundTime)

-- | 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 DirectChainLog
  = ToPost {DirectChainLog -> PostChainTx Tx
toPost :: PostChainTx Tx}
  | PostingTx {DirectChainLog -> TxId
txId :: TxId}
  | PostedTx {txId :: TxId}
  | PostingFailed {DirectChainLog -> Tx
tx :: Tx, DirectChainLog -> PostTxError Tx
postTxError :: PostTxError Tx}
  | RolledForward {DirectChainLog -> ChainPoint
point :: ChainPoint, DirectChainLog -> [TxId]
receivedTxIds :: [TxId]}
  | RolledBackward {point :: ChainPoint}
  | Wallet TinyWalletLog
  deriving stock (DirectChainLog -> DirectChainLog -> Bool
(DirectChainLog -> DirectChainLog -> Bool)
-> (DirectChainLog -> DirectChainLog -> Bool) -> Eq DirectChainLog
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DirectChainLog -> DirectChainLog -> Bool
== :: DirectChainLog -> DirectChainLog -> Bool
$c/= :: DirectChainLog -> DirectChainLog -> Bool
/= :: DirectChainLog -> DirectChainLog -> Bool
Eq, Int -> DirectChainLog -> ShowS
[DirectChainLog] -> ShowS
DirectChainLog -> String
(Int -> DirectChainLog -> ShowS)
-> (DirectChainLog -> String)
-> ([DirectChainLog] -> ShowS)
-> Show DirectChainLog
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DirectChainLog -> ShowS
showsPrec :: Int -> DirectChainLog -> ShowS
$cshow :: DirectChainLog -> String
show :: DirectChainLog -> String
$cshowList :: [DirectChainLog] -> ShowS
showList :: [DirectChainLog] -> ShowS
Show, (forall x. DirectChainLog -> Rep DirectChainLog x)
-> (forall x. Rep DirectChainLog x -> DirectChainLog)
-> Generic DirectChainLog
forall x. Rep DirectChainLog x -> DirectChainLog
forall x. DirectChainLog -> Rep DirectChainLog x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. DirectChainLog -> Rep DirectChainLog x
from :: forall x. DirectChainLog -> Rep DirectChainLog x
$cto :: forall x. Rep DirectChainLog x -> DirectChainLog
to :: forall x. Rep DirectChainLog x -> DirectChainLog
Generic)
  deriving anyclass ([DirectChainLog] -> Value
[DirectChainLog] -> Encoding
DirectChainLog -> Bool
DirectChainLog -> Value
DirectChainLog -> Encoding
(DirectChainLog -> Value)
-> (DirectChainLog -> Encoding)
-> ([DirectChainLog] -> Value)
-> ([DirectChainLog] -> Encoding)
-> (DirectChainLog -> Bool)
-> ToJSON DirectChainLog
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: DirectChainLog -> Value
toJSON :: DirectChainLog -> Value
$ctoEncoding :: DirectChainLog -> Encoding
toEncoding :: DirectChainLog -> Encoding
$ctoJSONList :: [DirectChainLog] -> Value
toJSONList :: [DirectChainLog] -> Value
$ctoEncodingList :: [DirectChainLog] -> Encoding
toEncodingList :: [DirectChainLog] -> Encoding
$comitField :: DirectChainLog -> Bool
omitField :: DirectChainLog -> Bool
ToJSON, Maybe DirectChainLog
Value -> Parser [DirectChainLog]
Value -> Parser DirectChainLog
(Value -> Parser DirectChainLog)
-> (Value -> Parser [DirectChainLog])
-> Maybe DirectChainLog
-> FromJSON DirectChainLog
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser DirectChainLog
parseJSON :: Value -> Parser DirectChainLog
$cparseJSONList :: Value -> Parser [DirectChainLog]
parseJSONList :: Value -> Parser [DirectChainLog]
$comittedField :: Maybe DirectChainLog
omittedField :: Maybe DirectChainLog
FromJSON)

instance Arbitrary DirectChainLog where
  arbitrary :: Gen DirectChainLog
arbitrary = Gen DirectChainLog
forall a.
(Generic a, GA UnsizedOpts (Rep a),
 UniformWeight (Weights_ (Rep a))) =>
Gen a
genericArbitrary
  shrink :: DirectChainLog -> [DirectChainLog]
shrink = DirectChainLog -> [DirectChainLog]
forall a.
(Generic a, RecursivelyShrink (Rep a), GSubterms (Rep a) a) =>
a -> [a]
genericShrink