{-# 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
_ -> 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
FailedToConstructIncrementTx @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
_ -> 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
FailedToConstructRecoverTx @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
_ -> 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
FailedToConstructDecrementTx @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)
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
-> SlotNo
-> Either FanoutTxError Tx
fanout ChainContext
ctx UTxOType Tx
UTxO
spendableUTxO TxIn
seedTxIn UTxOType Tx
UTxO
utxo 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, 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