{-# 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 Hydra.Cardano.Api (
  BlockHeader,
  ChainPoint (..),
  Tx,
  TxId,
  chainPointToSlotNo,
  getChainPoint,
  getTxBody,
  getTxId,
 )
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 (..),
  abort,
  chainSlotFromPoint,
  close,
  collect,
  commit',
  contest,
  decrement,
  fanout,
  getKnownUTxO,
  increment,
  initialize,
  recover,
 )
import Hydra.Chain.Direct.TimeHandle (TimeHandle (..))
import Hydra.Chain.Direct.Tx (
  AbortObservation (..),
  CloseObservation (..),
  CollectComObservation (..),
  CommitObservation (..),
  ContestObservation (..),
  DecrementObservation (..),
  FanoutObservation (..),
  HeadObservation (..),
  IncrementObservation (..),
  InitObservation (..),
  headSeedToTxIn,
  observeHeadTx,
  txInToHeadSeed,
 )
import Hydra.Chain.Direct.Wallet (
  ErrCoverFee (..),
  TinyWallet (..),
  TinyWalletLog,
 )
import Hydra.Ledger.Cardano (adjustUTxO, fromChainSlot)
import Hydra.Logging (Tracer, traceWith)
import Hydra.Plutus.Extras (posixToUTCTime)
import Hydra.Tx (
  CommitBlueprintTx (..),
  HeadParameters (..),
  UTxOType,
 )
import Hydra.Tx.Contest (ClosedThreadOutput (..))
import Hydra.Tx.ContestationPeriod (toNominalDiffTime)
import Hydra.Tx.Deposit (DepositObservation (..), depositTx)
import Hydra.Tx.Recover (RecoverObservation (..))
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 TinyWallet m
wallet 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 UTxOType Tx
UTxO
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 and a _blueprint_ transaction.
      -- Possible errors are handled at the api server level.
      $sel:draftCommitTx:Chain :: MonadThrow m =>
HeadId -> CommitBlueprintTx Tx -> m (Either (PostTxError Tx) Tx)
draftCommitTx = \HeadId
headId CommitBlueprintTx Tx
commitBlueprintTx -> 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
        let CommitBlueprintTx{UTxOType Tx
lookupUTxO :: UTxOType Tx
$sel:lookupUTxO:CommitBlueprintTx :: forall tx. CommitBlueprintTx tx -> UTxOType tx
lookupUTxO} = CommitBlueprintTx Tx
commitBlueprintTx
        (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 UTxOType Tx
UTxO
lookupUTxO) (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
-> CommitBlueprintTx Tx
-> Either (PostTxError Tx) Tx
commit' ChainContext
ctx HeadId
headId UTxO
spendableUTxO CommitBlueprintTx Tx
commitBlueprintTx
    , -- Handle that creates a draft **deposit** tx using the user utxo and a deadline.
      -- Possible errors are handled at the api server level.
      $sel:draftDepositTx:Chain :: MonadThrow m =>
HeadId
-> CommitBlueprintTx Tx
-> UTCTime
-> m (Either (PostTxError Tx) Tx)
draftDepositTx = \HeadId
headId CommitBlueprintTx Tx
commitBlueprintTx UTCTime
deadline -> do
        let CommitBlueprintTx{UTxOType Tx
$sel:lookupUTxO:CommitBlueprintTx :: forall tx. CommitBlueprintTx tx -> UTxOType tx
lookupUTxO :: UTxOType Tx
lookupUTxO} = CommitBlueprintTx Tx
commitBlueprintTx
        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
        (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 UTxOType Tx
UTxO
lookupUTxO) (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
$
          -- TODO: Should we move deposit tx argument verification to `depositTx` function and have Either here?
          Tx -> Either (PostTxError Tx) Tx
forall a b. b -> Either a b
Right (NetworkId -> HeadId -> CommitBlueprintTx Tx -> UTCTime -> Tx
depositTx (ChainContext -> NetworkId
networkId ChainContext
ctx) HeadId
headId CommitBlueprintTx Tx
commitBlueprintTx UTCTime
deadline)
    , -- 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{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
            } ::
            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
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 ->
      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
$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 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, UTxOType Tx
UTxO
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}
  Deposit DepositObservation{HeadId
headId :: HeadId
$sel:headId:DepositObservation :: DepositObservation -> HeadId
headId, UTxO
deposited :: UTxO
$sel:deposited:DepositObservation :: DepositObservation -> UTxO
deposited, TxId
depositTxId :: TxId
$sel:depositTxId:DepositObservation :: DepositObservation -> TxId
depositTxId, POSIXTime
deadline :: POSIXTime
$sel:deadline:DepositObservation :: DepositObservation -> POSIXTime
deadline} ->
    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, UTxOType Tx
UTxO
deposited :: UTxO
$sel:deposited:OnInitTx :: UTxOType Tx
deposited, TxIdType Tx
TxId
depositTxId :: TxId
$sel:depositTxId:OnInitTx :: TxIdType Tx
depositTxId, $sel:deadline:OnInitTx :: UTCTime
deadline = POSIXTime -> UTCTime
posixToUTCTime POSIXTime
deadline}
  Recover RecoverObservation{HeadId
headId :: HeadId
$sel:headId:RecoverObservation :: RecoverObservation -> HeadId
headId, TxId
recoveredTxId :: TxId
$sel:recoveredTxId:RecoverObservation :: RecoverObservation -> TxId
recoveredTxId} ->
    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}
  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, [TxOut CtxUTxO]
distributedOutputs :: [TxOut CtxUTxO]
$sel:distributedOutputs:DecrementObservation :: DecrementObservation -> [TxOut CtxUTxO]
distributedOutputs} ->
    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, [TxOutType Tx]
[TxOut CtxUTxO]
distributedOutputs :: [TxOut CtxUTxO]
$sel:distributedOutputs:OnInitTx :: [TxOutType Tx]
distributedOutputs}
  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 UTxOType Tx
UTxO
spendableUTxO UTxOType Tx
UTxO
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 UTxOType Tx
UTxO
utxo UTxOType Tx
UTxO
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
    IncrementTx{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
incrementingSnapshot :: ConfirmedSnapshot Tx
$sel:incrementingSnapshot:InitTx :: forall tx. PostChainTx tx -> ConfirmedSnapshot tx
incrementingSnapshot, TxIdType Tx
depositTxId :: TxIdType Tx
$sel:depositTxId:InitTx :: forall tx. PostChainTx tx -> TxIdType tx
depositTxId} -> 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
upperBound, UTCTime
_) <- UTCTime -> ContestationPeriod -> STM m (SlotNo, UTCTime)
calculateTxUpperBoundFromContestationPeriod UTCTime
currentTime ContestationPeriod
contestationPeriod
      case ChainContext
-> UTxO
-> HeadId
-> HeadParameters
-> ConfirmedSnapshot Tx
-> TxId
-> SlotNo
-> Either IncrementTxError Tx
increment ChainContext
ctx UTxOType Tx
UTxO
spendableUTxO HeadId
headId HeadParameters
headParameters ConfirmedSnapshot Tx
incrementingSnapshot TxIdType Tx
TxId
depositTxId 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 -> SlotNo -> Either RecoverTxError Tx
recover ChainContext
ctx HeadId
headId TxIdType Tx
TxId
recoverTxId UTxOType Tx
UTxO
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{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
-> HeadId
-> HeadParameters
-> ConfirmedSnapshot Tx
-> Either DecrementTxError Tx
decrement ChainContext
ctx UTxOType Tx
UTxO
spendableUTxO 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 (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
-> SnapshotVersion
-> ConfirmedSnapshot Tx
-> SlotNo
-> (SlotNo, UTCTime)
-> Either CloseTxError Tx
close ChainContext
ctx UTxOType Tx
UTxO
spendableUTxO HeadId
headId HeadParameters
headParameters SnapshotVersion
openVersion ConfirmedSnapshot Tx
closingSnapshot 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, 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 (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
-> SnapshotVersion
-> ConfirmedSnapshot Tx
-> (SlotNo, UTCTime)
-> Either ContestTxError Tx
contest ChainContext
ctx UTxOType Tx
UTxO
spendableUTxO HeadId
headId ContestationPeriod
contestationPeriod SnapshotVersion
openVersion ConfirmedSnapshot Tx
contestingSnapshot (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, 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
$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
-> Maybe UTxO
-> Maybe UTxO
-> SlotNo
-> Either FanoutTxError Tx
fanout ChainContext
ctx UTxOType Tx
UTxO
spendableUTxO TxIn
seedTxIn UTxOType Tx
UTxO
utxo Maybe (UTxOType Tx)
Maybe UTxO
utxoToCommit Maybe (UTxOType Tx)
Maybe UTxO
utxoToDecommit 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)

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