{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- | Specifies the /Head-Chain Interaction/ part of the protocol
--
-- Incoming and outgoing on-chain transactions are modelled respectively as `OnChainTx`
-- and `PostChainTx` which are data type that abstracts away the details of the structure
-- of the transaction.
module Hydra.Chain where

import Hydra.Prelude

import Cardano.Ledger.Core (PParams)
import Data.List.NonEmpty ((<|))
import Data.List.NonEmpty qualified as NE
import Hydra.Cardano.Api (
  Address,
  AddressInEra,
  ByronAddr,
  Coin (..),
  LedgerEra,
  PolicyAssets,
  PolicyId,
  Value,
 )
import Hydra.Chain.ChainState (ChainSlot, IsChainState (..), chainStateSlot)
import Hydra.Tx (
  CommitBlueprintTx,
  ConfirmedSnapshot,
  HeadId,
  HeadParameters (..),
  HeadSeed,
  IsTx (..),
  SnapshotNumber,
  SnapshotVersion,
  UTxOType,
 )
import Hydra.Tx.OnChainId (OnChainId)

-- | Hardcoded limit for maximum number of parties in a head protocol. A too
-- high number would be detected by property and acceptance tests.
maximumNumberOfParties :: Int
maximumNumberOfParties :: Int
maximumNumberOfParties = Int
29

-- | Data type used to post transactions on chain. It holds everything to
-- construct corresponding Head protocol transactions.
-- TODO: somehow merge HeadSeed/HeadId
data PostChainTx tx
  = InitTx {forall tx. PostChainTx tx -> [OnChainId]
participants :: [OnChainId], forall tx. PostChainTx tx -> HeadParameters
headParameters :: HeadParameters}
  | IncrementTx
      { forall tx. PostChainTx tx -> HeadSeed
headSeed :: HeadSeed
      , forall tx. PostChainTx tx -> HeadId
headId :: HeadId
      , headParameters :: HeadParameters
      , forall tx. PostChainTx tx -> ConfirmedSnapshot tx
incrementingSnapshot :: ConfirmedSnapshot tx
      , forall tx. PostChainTx tx -> TxIdType tx
depositTxId :: TxIdType tx
      -- ^ Which deposit this increment was posted for. Not an input to building
      -- the transaction: 'Hydra.Chain.Direct.State.increment' takes the deposit
      -- from 'incrementingSnapshot', since only the deposit bound into the signed
      -- snapshot can validate on-chain. Kept as a record of the choice, for the
      -- offline-mode chain and for tests asserting which deposit was claimed.
      }
  | RecoverTx
      { headId :: HeadId
      , forall tx. PostChainTx tx -> TxIdType tx
recoverTxId :: TxIdType tx
      , forall tx. PostChainTx tx -> ChainSlot
deadline :: ChainSlot
      , forall tx. PostChainTx tx -> UTxOType tx
recoverUTxO :: UTxOType tx
      }
  | DecrementTx
      { headSeed :: HeadSeed
      , headId :: HeadId
      , headParameters :: HeadParameters
      , forall tx. PostChainTx tx -> ConfirmedSnapshot tx
decrementingSnapshot :: ConfirmedSnapshot tx
      }
  | CloseTx
      { headId :: HeadId
      , headParameters :: HeadParameters
      , forall tx. PostChainTx tx -> SnapshotVersion
openVersion :: SnapshotVersion
      , forall tx. PostChainTx tx -> ConfirmedSnapshot tx
closingSnapshot :: ConfirmedSnapshot tx
      }
  | ContestTx
      { headId :: HeadId
      , headParameters :: HeadParameters
      , openVersion :: SnapshotVersion
      , forall tx. PostChainTx tx -> ConfirmedSnapshot tx
contestingSnapshot :: ConfirmedSnapshot tx
      }
  | FanoutTx
      { forall tx. PostChainTx tx -> UTxOType tx
utxo :: UTxOType tx
      , forall tx. PostChainTx tx -> Maybe (UTxOType tx)
utxoToCommit :: Maybe (UTxOType tx)
      , forall tx. PostChainTx tx -> Maybe (UTxOType tx)
utxoToDecommit :: Maybe (UTxOType tx)
      , forall tx. PostChainTx tx -> UTxOType tx
utxoForProof :: UTxOType tx
      , headSeed :: HeadSeed
      , forall tx. PostChainTx tx -> UTCTime
contestationDeadline :: UTCTime
      }
  | -- | Non-final partial fanout of a user-selected subset. Distributes
    -- 'utxoToDistribute' (dynamically chunked to fit) and leaves the head in the
    -- 'FanoutProgress' state without burning tokens. 'utxoForProof' is the full
    -- accumulator UTxO matching the current on-chain datum (everything still in
    -- the head plus any pre-settled elements).
    PartialFanoutTx
      { forall tx. PostChainTx tx -> UTxOType tx
utxoToDistribute :: UTxOType tx
      , utxoForProof :: UTxOType tx
      , headSeed :: HeadSeed
      , contestationDeadline :: UTCTime
      }
  | FinalPartialFanoutTx
      { utxoToDistribute :: UTxOType tx
      , forall tx. PostChainTx tx -> UTxOType tx
presettledUTxO :: UTxOType tx
      , headSeed :: HeadSeed
      , contestationDeadline :: UTCTime
      }
  deriving stock ((forall x. PostChainTx tx -> Rep (PostChainTx tx) x)
-> (forall x. Rep (PostChainTx tx) x -> PostChainTx tx)
-> Generic (PostChainTx tx)
forall x. Rep (PostChainTx tx) x -> PostChainTx tx
forall x. PostChainTx tx -> Rep (PostChainTx tx) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall tx x. Rep (PostChainTx tx) x -> PostChainTx tx
forall tx x. PostChainTx tx -> Rep (PostChainTx tx) x
$cfrom :: forall tx x. PostChainTx tx -> Rep (PostChainTx tx) x
from :: forall x. PostChainTx tx -> Rep (PostChainTx tx) x
$cto :: forall tx x. Rep (PostChainTx tx) x -> PostChainTx tx
to :: forall x. Rep (PostChainTx tx) x -> PostChainTx tx
Generic)

deriving stock instance IsTx tx => Eq (PostChainTx tx)
deriving stock instance IsTx tx => Show (PostChainTx tx)
deriving anyclass instance IsTx tx => ToJSON (PostChainTx tx)
deriving anyclass instance IsTx tx => FromJSON (PostChainTx tx)

instance IsTx tx => ToCBOR (PostChainTx tx) where
  toCBOR :: PostChainTx tx -> Encoding
toCBOR = PostChainTx tx -> Encoding
forall a. (Generic a, GToCBOR (Rep a)) => a -> Encoding
genericToCBOR

instance IsTx tx => FromCBOR (PostChainTx tx) where
  fromCBOR :: forall s. Decoder s (PostChainTx tx)
fromCBOR = Decoder s (PostChainTx tx)
forall a s. (Generic a, GFromCBOR (Rep a)) => Decoder s a
genericFromCBOR

-- | Describes transactions as seen on chain. Holds as minimal information as
-- possible to simplify observing the chain.
data OnChainTx tx
  = OnInitTx
      { forall tx. OnChainTx tx -> HeadId
headId :: HeadId
      , forall tx. OnChainTx tx -> HeadSeed
headSeed :: HeadSeed
      , forall tx. OnChainTx tx -> HeadParameters
headParameters :: HeadParameters
      , forall tx. OnChainTx tx -> [OnChainId]
participants :: [OnChainId]
      }
  | OnDepositTx
      { headId :: HeadId
      , forall tx. OnChainTx tx -> TxIdType tx
depositTxId :: TxIdType tx
      , forall tx. OnChainTx tx -> UTxOType tx
deposited :: UTxOType tx
      , forall tx. OnChainTx tx -> UTCTime
created :: UTCTime
      , forall tx. OnChainTx tx -> UTCTime
deadline :: UTCTime
      }
  | OnRecoverTx
      { headId :: HeadId
      , forall tx. OnChainTx tx -> TxIdType tx
recoveredTxId :: TxIdType tx
      , forall tx. OnChainTx tx -> UTxOType tx
recoveredUTxO :: UTxOType tx
      }
  | OnIncrementTx
      { headId :: HeadId
      , forall tx. OnChainTx tx -> SnapshotVersion
newVersion :: SnapshotVersion
      , depositTxId :: TxIdType tx
      }
  | OnDecrementTx
      { headId :: HeadId
      , newVersion :: SnapshotVersion
      , forall tx. OnChainTx tx -> UTxOType tx
distributedUTxO :: UTxOType tx
      }
  | OnCloseTx
      { headId :: HeadId
      , forall tx. OnChainTx tx -> SnapshotNumber
snapshotNumber :: SnapshotNumber
      , forall tx. OnChainTx tx -> UTCTime
contestationDeadline :: UTCTime
      }
  | OnContestTx
      { headId :: HeadId
      , snapshotNumber :: SnapshotNumber
      , contestationDeadline :: UTCTime
      }
  | OnFanoutTx {headId :: HeadId, forall tx. OnChainTx tx -> UTxOType tx
fanoutUTxO :: UTxOType tx}
  | OnPartialFanoutTx {headId :: HeadId, forall tx. OnChainTx tx -> UTxOType tx
distributedOutputs :: UTxOType tx}
  deriving stock ((forall x. OnChainTx tx -> Rep (OnChainTx tx) x)
-> (forall x. Rep (OnChainTx tx) x -> OnChainTx tx)
-> Generic (OnChainTx tx)
forall x. Rep (OnChainTx tx) x -> OnChainTx tx
forall x. OnChainTx tx -> Rep (OnChainTx tx) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall tx x. Rep (OnChainTx tx) x -> OnChainTx tx
forall tx x. OnChainTx tx -> Rep (OnChainTx tx) x
$cfrom :: forall tx x. OnChainTx tx -> Rep (OnChainTx tx) x
from :: forall x. OnChainTx tx -> Rep (OnChainTx tx) x
$cto :: forall tx x. Rep (OnChainTx tx) x -> OnChainTx tx
to :: forall x. Rep (OnChainTx tx) x -> OnChainTx tx
Generic)

deriving stock instance IsTx tx => Eq (OnChainTx tx)
deriving stock instance IsTx tx => Show (OnChainTx tx)
deriving anyclass instance IsTx tx => ToJSON (OnChainTx tx)
deriving anyclass instance IsTx tx => FromJSON (OnChainTx tx)

instance IsTx tx => ToCBOR (OnChainTx tx) where
  toCBOR :: OnChainTx tx -> Encoding
toCBOR = OnChainTx tx -> Encoding
forall a. (Generic a, GToCBOR (Rep a)) => a -> Encoding
genericToCBOR

instance IsTx tx => FromCBOR (OnChainTx tx) where
  fromCBOR :: forall s. Decoder s (OnChainTx tx)
fromCBOR = Decoder s (OnChainTx tx)
forall a s. (Generic a, GFromCBOR (Rep a)) => Decoder s a
genericFromCBOR

-- | Exceptions thrown by 'postTx'.
data PostTxError tx
  = NoSeedInput
  | InvalidSeed {forall tx. PostTxError tx -> HeadSeed
headSeed :: HeadSeed}
  | InvalidHeadId {forall tx. PostTxError tx -> HeadId
headId :: HeadId}
  | -- | Committing byron addresses is not supported.
    UnsupportedLegacyOutput {forall tx. PostTxError tx -> Address ByronAddr
byronAddress :: Address ByronAddr}
  | DepositTooLow {forall tx. PostTxError tx -> Coin
providedValue :: Coin, forall tx. PostTxError tx -> Coin
minimumValue :: Coin}
  | -- | The deposit is too large: the increment transaction claiming it would
    -- exceed layer 1 ledger limits (estimated sizes include a balancing margin).
    DepositTooLarge
      { forall tx. PostTxError tx -> Natural
estimatedTxSize :: Natural
      , forall tx. PostTxError tx -> Natural
maximumTxSize :: Natural
      , forall tx. PostTxError tx -> Natural
estimatedValueSize :: Natural
      , forall tx. PostTxError tx -> Natural
maximumValueSize :: Natural
      }
  | InvalidStateToPost {forall tx. PostTxError tx -> PostChainTx tx
txTried :: PostChainTx tx, forall tx. PostTxError tx -> ChainStateType tx
chainState :: ChainStateType tx}
  | NotEnoughFuel {forall tx. PostTxError tx -> tx
failingTx :: tx}
  | NoFuelUTXOFound {failingTx :: tx}
  | -- | Script execution failed when finalizing a transaction in the wallet.
    -- XXX: Ideally we want a cardano-api type with corresponding JSON instance
    -- here. But the wallet still uses ledger types and we don't want to copy the
    -- conversion from ledger 'TransactionScriptFailure' to the cardano-api
    -- 'ScriptExecutionError' type.
    ScriptFailedInWallet {forall tx. PostTxError tx -> Text
redeemerPtr :: Text, forall tx. PostTxError tx -> Text
failureReason :: Text, failingTx :: tx}
  | -- | A generic error happened when finalizing a transaction in the wallet.
    InternalWalletError {forall tx. PostTxError tx -> UTxOType tx
headUTxO :: UTxOType tx, forall tx. PostTxError tx -> Text
reason :: Text, failingTx :: tx}
  | -- | An error occurred when submitting a transaction to the cardano-node.
    FailedToPostTx {failureReason :: Text, failingTx :: tx}
  | FailedToConstructCloseTx
  | FailedToConstructContestTx
  | FailedToConstructDepositTx {failureReason :: Text}
  | FailedToConstructRecoverTx {failureReason :: Text}
  | FailedToConstructIncrementTx {failureReason :: Text}
  | FailedToConstructDecrementTx {failureReason :: Text}
  | FailedToConstructFanoutTx
  | FailedToConstructPartialFanoutTx
  | -- | Another node already posted this partial fanout step; the chain
    -- observation loop will emit the correct next step automatically.
    StalePartialFanoutTx
  | ContestationDeadlineOutsideTimeHorizon {failureReason :: Text}
  | InvalidTokenRequest [(PolicyId, PolicyAssets)]
  deriving stock ((forall x. PostTxError tx -> Rep (PostTxError tx) x)
-> (forall x. Rep (PostTxError tx) x -> PostTxError tx)
-> Generic (PostTxError tx)
forall x. Rep (PostTxError tx) x -> PostTxError tx
forall x. PostTxError tx -> Rep (PostTxError tx) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall tx x. Rep (PostTxError tx) x -> PostTxError tx
forall tx x. PostTxError tx -> Rep (PostTxError tx) x
$cfrom :: forall tx x. PostTxError tx -> Rep (PostTxError tx) x
from :: forall x. PostTxError tx -> Rep (PostTxError tx) x
$cto :: forall tx x. Rep (PostTxError tx) x -> PostTxError tx
to :: forall x. Rep (PostTxError tx) x -> PostTxError tx
Generic)

deriving stock instance IsChainState tx => Eq (PostTxError tx)
deriving stock instance IsChainState tx => Show (PostTxError tx)
deriving anyclass instance IsChainState tx => ToJSON (PostTxError tx)
deriving anyclass instance IsChainState tx => FromJSON (PostTxError tx)

instance IsChainState tx => Exception (PostTxError tx)

instance IsChainState tx => ToCBOR (PostTxError tx) where
  toCBOR :: PostTxError tx -> Encoding
toCBOR = PostTxError tx -> Encoding
forall a. (Generic a, GToCBOR (Rep a)) => a -> Encoding
genericToCBOR

instance IsChainState tx => FromCBOR (PostTxError tx) where
  fromCBOR :: forall s. Decoder s (PostTxError tx)
fromCBOR = Decoder s (PostTxError tx)
forall a s. (Generic a, GFromCBOR (Rep a)) => Decoder s a
genericFromCBOR

-- | A non empty sequence of chain states that can be rolled back.
-- This is expected to be constructed by using the smart constructor
-- 'initHistory'.
data ChainStateHistory tx = UnsafeChainStateHistory
  { forall tx. ChainStateHistory tx -> NonEmpty (ChainStateType tx)
history :: NonEmpty (ChainStateType tx)
  -- ^ The sequence of known chain states, ordered from most recent to oldest.
  -- These contain notable state observed on-chain to be able to interact with
  -- Hydra heads.
  , forall tx. ChainStateHistory tx -> ChainPointType tx
lastKnown :: ChainPointType tx
  -- ^ The last known chain point, which may be used to continue observing the
  -- chain.
  , forall tx. ChainStateHistory tx -> ChainStateType tx
defaultChainState :: ChainStateType tx
  -- ^ The default chain state to fall back to when rolling back beyond known
  -- history.
  }
  deriving stock ((forall x. ChainStateHistory tx -> Rep (ChainStateHistory tx) x)
-> (forall x. Rep (ChainStateHistory tx) x -> ChainStateHistory tx)
-> Generic (ChainStateHistory tx)
forall x. Rep (ChainStateHistory tx) x -> ChainStateHistory tx
forall x. ChainStateHistory tx -> Rep (ChainStateHistory tx) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall tx x. Rep (ChainStateHistory tx) x -> ChainStateHistory tx
forall tx x. ChainStateHistory tx -> Rep (ChainStateHistory tx) x
$cfrom :: forall tx x. ChainStateHistory tx -> Rep (ChainStateHistory tx) x
from :: forall x. ChainStateHistory tx -> Rep (ChainStateHistory tx) x
$cto :: forall tx x. Rep (ChainStateHistory tx) x -> ChainStateHistory tx
to :: forall x. Rep (ChainStateHistory tx) x -> ChainStateHistory tx
Generic)

-- Fetches the last updated chain state from history.
currentState :: ChainStateHistory tx -> ChainStateType tx
currentState :: forall tx. ChainStateHistory tx -> ChainStateType tx
currentState UnsafeChainStateHistory{NonEmpty (ChainStateType tx)
$sel:history:UnsafeChainStateHistory :: forall tx. ChainStateHistory tx -> NonEmpty (ChainStateType tx)
history :: NonEmpty (ChainStateType tx)
history} = NonEmpty (ChainStateType tx) -> ChainStateType tx
forall (f :: * -> *) a. IsNonEmpty f a a "head" => f a -> a
head NonEmpty (ChainStateType tx)
history

-- | Record a new chain state in history. Also ensures the 'lastKnown' point is
-- updated accordingly.
pushNewState :: IsChainState tx => ChainStateType tx -> ChainStateHistory tx -> ChainStateHistory tx
pushNewState :: forall tx.
IsChainState tx =>
ChainStateType tx -> ChainStateHistory tx -> ChainStateHistory tx
pushNewState ChainStateType tx
cs h :: ChainStateHistory tx
h@UnsafeChainStateHistory{NonEmpty (ChainStateType tx)
$sel:history:UnsafeChainStateHistory :: forall tx. ChainStateHistory tx -> NonEmpty (ChainStateType tx)
history :: NonEmpty (ChainStateType tx)
history, ChainPointType tx
$sel:lastKnown:UnsafeChainStateHistory :: forall tx. ChainStateHistory tx -> ChainPointType tx
lastKnown :: ChainPointType tx
lastKnown} =
  ChainStateHistory tx
h
    { history = cs <| history
    , lastKnown = max lastKnown (chainStatePoint cs)
    }

-- | Update the last known chain point. Use 'pushNewState' if you have a full 'ChainStateType tx'.
setLastKnown :: ChainPointType tx -> ChainStateHistory tx -> ChainStateHistory tx
setLastKnown :: forall tx.
ChainPointType tx -> ChainStateHistory tx -> ChainStateHistory tx
setLastKnown ChainPointType tx
cp ChainStateHistory tx
h = ChainStateHistory tx
h{lastKnown = cp}

initHistory :: IsChainState tx => ChainStateType tx -> ChainStateHistory tx
initHistory :: forall tx.
IsChainState tx =>
ChainStateType tx -> ChainStateHistory tx
initHistory ChainStateType tx
cs =
  UnsafeChainStateHistory
    { $sel:history:UnsafeChainStateHistory :: NonEmpty (ChainStateType tx)
history = ChainStateType tx
cs ChainStateType tx
-> [ChainStateType tx] -> NonEmpty (ChainStateType tx)
forall a. a -> [a] -> NonEmpty a
:| []
    , $sel:lastKnown:UnsafeChainStateHistory :: ChainPointType tx
lastKnown = ChainStateType tx -> ChainPointType tx
forall tx.
IsChainState tx =>
ChainStateType tx -> ChainPointType tx
chainStatePoint ChainStateType tx
cs
    , $sel:defaultChainState:UnsafeChainStateHistory :: ChainStateType tx
defaultChainState = ChainStateType tx
cs
    }

rollbackHistory :: IsChainState tx => ChainSlot -> ChainStateHistory tx -> ChainStateHistory tx
rollbackHistory :: forall tx.
IsChainState tx =>
ChainSlot -> ChainStateHistory tx -> ChainStateHistory tx
rollbackHistory ChainSlot
rollbackChainSlot h :: ChainStateHistory tx
h@UnsafeChainStateHistory{NonEmpty (ChainStateType tx)
$sel:history:UnsafeChainStateHistory :: forall tx. ChainStateHistory tx -> NonEmpty (ChainStateType tx)
history :: NonEmpty (ChainStateType tx)
history, ChainStateType tx
$sel:defaultChainState:UnsafeChainStateHistory :: forall tx. ChainStateHistory tx -> ChainStateType tx
defaultChainState :: ChainStateType tx
defaultChainState} =
  ChainStateHistory tx
h
    { history = rolledBack
    , lastKnown = chainStatePoint (head rolledBack)
    }
 where
  rolledBack :: NonEmpty (ChainStateType tx)
rolledBack =
    NonEmpty (ChainStateType tx)
-> Maybe (NonEmpty (ChainStateType tx))
-> NonEmpty (ChainStateType tx)
forall a. a -> Maybe a -> a
fromMaybe (ChainStateType tx
defaultChainState ChainStateType tx
-> [ChainStateType tx] -> NonEmpty (ChainStateType tx)
forall a. a -> [a] -> NonEmpty a
:| []) (Maybe (NonEmpty (ChainStateType tx))
 -> NonEmpty (ChainStateType tx))
-> ([ChainStateType tx] -> Maybe (NonEmpty (ChainStateType tx)))
-> [ChainStateType tx]
-> NonEmpty (ChainStateType tx)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ChainStateType tx] -> Maybe (NonEmpty (ChainStateType tx))
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ([ChainStateType tx] -> NonEmpty (ChainStateType tx))
-> [ChainStateType tx] -> NonEmpty (ChainStateType tx)
forall a b. (a -> b) -> a -> b
$
      (ChainStateType tx -> Bool)
-> NonEmpty (ChainStateType tx) -> [ChainStateType tx]
forall a. (a -> Bool) -> NonEmpty a -> [a]
NE.dropWhile
        (\ChainStateType tx
cs -> ChainStateType tx -> ChainSlot
forall tx. IsChainState tx => ChainStateType tx -> ChainSlot
chainStateSlot ChainStateType tx
cs ChainSlot -> ChainSlot -> Bool
forall a. Ord a => a -> a -> Bool
> ChainSlot
rollbackChainSlot)
        NonEmpty (ChainStateType tx)
history

-- | Get the known prefix of all the ChainStateHistory.
prefixOf :: IsChainState tx => ChainStateHistory tx -> NonEmpty (ChainPointType tx)
prefixOf :: forall tx.
IsChainState tx =>
ChainStateHistory tx -> NonEmpty (ChainPointType tx)
prefixOf ch :: ChainStateHistory tx
ch@UnsafeChainStateHistory{NonEmpty (ChainStateType tx)
$sel:history:UnsafeChainStateHistory :: forall tx. ChainStateHistory tx -> NonEmpty (ChainStateType tx)
history :: NonEmpty (ChainStateType tx)
history, ChainPointType tx
$sel:lastKnown:UnsafeChainStateHistory :: forall tx. ChainStateHistory tx -> ChainPointType tx
lastKnown :: ChainPointType tx
lastKnown}
  | ChainPointType tx
lastKnown ChainPointType tx -> ChainPointType tx -> Bool
forall a. Eq a => a -> a -> Bool
== ChainStateType tx -> ChainPointType tx
forall tx.
IsChainState tx =>
ChainStateType tx -> ChainPointType tx
chainStatePoint (ChainStateHistory tx -> ChainStateType tx
forall tx. ChainStateHistory tx -> ChainStateType tx
currentState ChainStateHistory tx
ch) = NonEmpty (ChainPointType tx)
historyPoints
  | Bool
otherwise = ChainPointType tx
lastKnown ChainPointType tx
-> NonEmpty (ChainPointType tx) -> NonEmpty (ChainPointType tx)
forall a. a -> NonEmpty a -> NonEmpty a
<| NonEmpty (ChainPointType tx)
historyPoints
 where
  historyPoints :: NonEmpty (ChainPointType tx)
historyPoints = ChainStateType tx -> ChainPointType tx
forall tx.
IsChainState tx =>
ChainStateType tx -> ChainPointType tx
chainStatePoint (ChainStateType tx -> ChainPointType tx)
-> NonEmpty (ChainStateType tx) -> NonEmpty (ChainPointType tx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (ChainStateType tx)
history

deriving stock instance
  ( Eq (ChainPointType tx)
  , Eq (ChainStateType tx)
  ) =>
  Eq (ChainStateHistory tx)

deriving stock instance
  ( Show (ChainPointType tx)
  , Show (ChainStateType tx)
  ) =>
  Show (ChainStateHistory tx)

-- | Handle to interface with the main chain network
data Chain tx m = Chain
  { forall tx (m :: * -> *).
Chain tx m -> MonadThrow m => PostChainTx tx -> m ()
postTx :: MonadThrow m => PostChainTx tx -> m ()
  -- ^ Construct and send a transaction to the main chain corresponding to the
  -- given 'PostChainTx' description.
  -- This function is not expected to block, so it is only responsible for
  -- submitting, but it should validate the created transaction against a
  -- reasonable local view of the chain and throw an exception when invalid.
  --
  -- Does at least throw 'PostTxError'.
  , forall tx (m :: * -> *).
Chain tx m
-> MonadThrow m =>
   HeadId
   -> PParams LedgerEra
   -> ConfirmedSnapshot tx
   -> CommitBlueprintTx tx
   -> UTCTime
   -> Maybe AddressInEra
   -> m (Either (PostTxError tx) tx)
draftDepositTx ::
      MonadThrow m =>
      HeadId ->
      PParams LedgerEra ->
      ConfirmedSnapshot tx ->
      CommitBlueprintTx tx ->
      UTCTime ->
      Maybe AddressInEra ->
      m (Either (PostTxError tx) tx)
  -- ^ Create a deposit transaction using user provided utxos (zero or many) ,
  -- _blueprint_ transaction which spends these outputs and a deadline for
  -- their inclusion into L2. The current confirmed snapshot serves as the
  -- basis for a dry-run increment transaction rejecting deposits which could
  -- never be claimed. Errors are handled at the call site.
  , forall tx (m :: * -> *). Chain tx m -> MonadThrow m => tx -> m ()
submitTx :: MonadThrow m => tx -> m ()
  -- ^ Submit a cardano transaction.
  --
  -- Throws at least 'PostTxError'.
  --
  -- XXX: While technically they could be any of 'PostTxError tx', only
  -- `FailedToPostTx` errors are expected here.
  , forall tx (m :: * -> *).
Chain tx m -> ConfirmedSnapshot tx -> Either Value ()
checkNonADAAssets :: ConfirmedSnapshot tx -> Either Value ()
  }

data ChainEvent tx
  = -- | Indicates a head protocol transaction has been observed.
    Observation
      { forall tx. ChainEvent tx -> OnChainTx tx
observedTx :: OnChainTx tx
      , forall tx. ChainEvent tx -> ChainStateType tx
newChainState :: ChainStateType tx
      }
  | Rollback
      { forall tx. ChainEvent tx -> UTCTime
chainTime :: UTCTime
      , forall tx. ChainEvent tx -> ChainStateType tx
rolledBackChainState :: ChainStateType tx
      }
  | -- | Indicate time has advanced on the chain. This is deliberately not a
    -- ChainStateType because state updates are only expected upon 'Observation'
    -- or'Rollback'.
    --
    -- NOTE: While the type does not guarantee that the UTCTime and the slot in
    -- ChainPointType tx are consistent the alternative would be provide the
    -- means to do the conversion. For Cardano, this would be a systemStart and
    -- eraHistory.. which is annoying and if it's kept in the chain layer, it
    -- would mean another round trip / state to keep there.
    Tick
      { chainTime :: UTCTime
      , forall tx. ChainEvent tx -> ChainPointType tx
chainPoint :: ChainPointType tx
      }
  | -- | Event to re-ingest errors from 'postTx' for further processing.
    PostTxError {forall tx. ChainEvent tx -> PostChainTx tx
postChainTx :: PostChainTx tx, forall tx. ChainEvent tx -> PostTxError tx
postTxError :: PostTxError tx, forall tx. ChainEvent tx -> Maybe tx
failingTx :: Maybe tx}
  deriving stock ((forall x. ChainEvent tx -> Rep (ChainEvent tx) x)
-> (forall x. Rep (ChainEvent tx) x -> ChainEvent tx)
-> Generic (ChainEvent tx)
forall x. Rep (ChainEvent tx) x -> ChainEvent tx
forall x. ChainEvent tx -> Rep (ChainEvent tx) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall tx x. Rep (ChainEvent tx) x -> ChainEvent tx
forall tx x. ChainEvent tx -> Rep (ChainEvent tx) x
$cfrom :: forall tx x. ChainEvent tx -> Rep (ChainEvent tx) x
from :: forall x. ChainEvent tx -> Rep (ChainEvent tx) x
$cto :: forall tx x. Rep (ChainEvent tx) x -> ChainEvent tx
to :: forall x. Rep (ChainEvent tx) x -> ChainEvent tx
Generic)

deriving stock instance (IsTx tx, IsChainState tx) => Eq (ChainEvent tx)
deriving stock instance (IsTx tx, IsChainState tx) => Show (ChainEvent tx)
deriving anyclass instance (IsTx tx, IsChainState tx) => ToJSON (ChainEvent tx)
deriving anyclass instance (IsTx tx, IsChainState tx) => FromJSON (ChainEvent tx)

instance IsChainState tx => ToCBOR (ChainEvent tx) where
  toCBOR :: ChainEvent tx -> Encoding
toCBOR = ChainEvent tx -> Encoding
forall a. (Generic a, GToCBOR (Rep a)) => a -> Encoding
genericToCBOR

instance IsChainState tx => FromCBOR (ChainEvent tx) where
  fromCBOR :: forall s. Decoder s (ChainEvent tx)
fromCBOR = Decoder s (ChainEvent tx)
forall a s. (Generic a, GFromCBOR (Rep a)) => Decoder s a
genericFromCBOR

-- | A callback indicating a 'ChainEvent tx' happened. Most importantly the
-- 'Observation' of a relevant Hydra transaction.
type ChainCallback tx m = ChainEvent tx -> m ()

-- | A type tying both posting and observing transactions into a single /Component/.
type ChainComponent tx m a = ChainCallback tx m -> (Chain tx m -> m a) -> m a