{-# 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 Data.List (nub)
import Data.List.NonEmpty ((<|))
import Hydra.Cardano.Api (
  Address,
  ByronAddr,
  Coin (..),
  CtxUTxO,
  Tx,
  TxOut,
  UTxO',
  WitCtxTxIn,
  Witness,
 )
import Hydra.ContestationPeriod (ContestationPeriod)
import Hydra.Environment (Environment (..))
import Hydra.HeadId (HeadId, HeadSeed)
import Hydra.Ledger (ChainSlot, IsTx, UTxOType)
import Hydra.OnChainId (OnChainId)
import Hydra.Party (Party)
import Hydra.Snapshot (ConfirmedSnapshot, SnapshotNumber)
import Test.Cardano.Ledger.Core.Arbitrary ()
import Test.QuickCheck.Instances.Semigroup ()
import Test.QuickCheck.Instances.Time ()

-- | Hardcoded limit for commit tx on mainnet
maxMainnetLovelace :: Coin
maxMainnetLovelace :: Coin
maxMainnetLovelace = Integer -> Coin
Coin Integer
100_000_000

-- | Hardcoded limit for maximum number of parties in a head protocol
-- The value is obtained from calculating the costs of running the scripts
-- and on-chan validators (see 'computeCollectComCost' 'computeAbortCost')
maximumNumberOfParties :: Int
maximumNumberOfParties :: Int
maximumNumberOfParties = Int
5

-- | Contains the head's parameters as established in the initial transaction.
data HeadParameters = HeadParameters
  { HeadParameters -> ContestationPeriod
contestationPeriod :: ContestationPeriod
  , HeadParameters -> [Party]
parties :: [Party] -- NOTE(SN): The order of this list is important for leader selection.
  }
  deriving stock (HeadParameters -> HeadParameters -> Bool
(HeadParameters -> HeadParameters -> Bool)
-> (HeadParameters -> HeadParameters -> Bool) -> Eq HeadParameters
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HeadParameters -> HeadParameters -> Bool
== :: HeadParameters -> HeadParameters -> Bool
$c/= :: HeadParameters -> HeadParameters -> Bool
/= :: HeadParameters -> HeadParameters -> Bool
Eq, Int -> HeadParameters -> ShowS
[HeadParameters] -> ShowS
HeadParameters -> String
(Int -> HeadParameters -> ShowS)
-> (HeadParameters -> String)
-> ([HeadParameters] -> ShowS)
-> Show HeadParameters
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HeadParameters -> ShowS
showsPrec :: Int -> HeadParameters -> ShowS
$cshow :: HeadParameters -> String
show :: HeadParameters -> String
$cshowList :: [HeadParameters] -> ShowS
showList :: [HeadParameters] -> ShowS
Show, (forall x. HeadParameters -> Rep HeadParameters x)
-> (forall x. Rep HeadParameters x -> HeadParameters)
-> Generic HeadParameters
forall x. Rep HeadParameters x -> HeadParameters
forall x. HeadParameters -> Rep HeadParameters x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. HeadParameters -> Rep HeadParameters x
from :: forall x. HeadParameters -> Rep HeadParameters x
$cto :: forall x. Rep HeadParameters x -> HeadParameters
to :: forall x. Rep HeadParameters x -> HeadParameters
Generic)
  deriving anyclass ([HeadParameters] -> Value
[HeadParameters] -> Encoding
HeadParameters -> Bool
HeadParameters -> Value
HeadParameters -> Encoding
(HeadParameters -> Value)
-> (HeadParameters -> Encoding)
-> ([HeadParameters] -> Value)
-> ([HeadParameters] -> Encoding)
-> (HeadParameters -> Bool)
-> ToJSON HeadParameters
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: HeadParameters -> Value
toJSON :: HeadParameters -> Value
$ctoEncoding :: HeadParameters -> Encoding
toEncoding :: HeadParameters -> Encoding
$ctoJSONList :: [HeadParameters] -> Value
toJSONList :: [HeadParameters] -> Value
$ctoEncodingList :: [HeadParameters] -> Encoding
toEncodingList :: [HeadParameters] -> Encoding
$comitField :: HeadParameters -> Bool
omitField :: HeadParameters -> Bool
ToJSON, Maybe HeadParameters
Value -> Parser [HeadParameters]
Value -> Parser HeadParameters
(Value -> Parser HeadParameters)
-> (Value -> Parser [HeadParameters])
-> Maybe HeadParameters
-> FromJSON HeadParameters
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser HeadParameters
parseJSON :: Value -> Parser HeadParameters
$cparseJSONList :: Value -> Parser [HeadParameters]
parseJSONList :: Value -> Parser [HeadParameters]
$comittedField :: Maybe HeadParameters
omittedField :: Maybe HeadParameters
FromJSON)

instance Arbitrary HeadParameters where
  arbitrary :: Gen HeadParameters
arbitrary = HeadParameters -> HeadParameters
dedupParties (HeadParameters -> HeadParameters)
-> Gen HeadParameters -> Gen HeadParameters
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen HeadParameters
forall a.
(Generic a, GA UnsizedOpts (Rep a),
 UniformWeight (Weights_ (Rep a))) =>
Gen a
genericArbitrary
   where
    dedupParties :: HeadParameters -> HeadParameters
dedupParties HeadParameters{ContestationPeriod
$sel:contestationPeriod:HeadParameters :: HeadParameters -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod, [Party]
$sel:parties:HeadParameters :: HeadParameters -> [Party]
parties :: [Party]
parties} =
      HeadParameters{ContestationPeriod
$sel:contestationPeriod:HeadParameters :: ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod, $sel:parties:HeadParameters :: [Party]
parties = [Party] -> [Party]
forall a. Eq a => [a] -> [a]
nub [Party]
parties}

-- | Make 'HeadParameters' that are consistent with the given 'Environment'.
mkHeadParameters :: Environment -> HeadParameters
mkHeadParameters :: Environment -> HeadParameters
mkHeadParameters Environment{Party
party :: Party
$sel:party:Environment :: Environment -> Party
party, [Party]
otherParties :: [Party]
$sel:otherParties:Environment :: Environment -> [Party]
otherParties, ContestationPeriod
contestationPeriod :: ContestationPeriod
$sel:contestationPeriod:Environment :: Environment -> ContestationPeriod
contestationPeriod} =
  HeadParameters{ContestationPeriod
$sel:contestationPeriod:HeadParameters :: ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod, $sel:parties:HeadParameters :: [Party]
parties = Party
party Party -> [Party] -> [Party]
forall a. a -> [a] -> [a]
: [Party]
otherParties}

-- | Data type used to post transactions on chain. It holds everything to
-- construct corresponding Head protocol transactions.
data PostChainTx tx
  = InitTx {forall tx. PostChainTx tx -> [OnChainId]
participants :: [OnChainId], forall tx. PostChainTx tx -> HeadParameters
headParameters :: HeadParameters}
  | AbortTx {forall tx. PostChainTx tx -> UTxOType tx
utxo :: UTxOType tx, forall tx. PostChainTx tx -> HeadSeed
headSeed :: HeadSeed}
  | CollectComTx {utxo :: UTxOType tx, forall tx. PostChainTx tx -> HeadId
headId :: HeadId, headParameters :: HeadParameters}
  | CloseTx {headId :: HeadId, headParameters :: HeadParameters, forall tx. PostChainTx tx -> ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx}
  | ContestTx {headId :: HeadId, headParameters :: HeadParameters, confirmedSnapshot :: ConfirmedSnapshot tx}
  | FanoutTx {utxo :: UTxOType tx, headSeed :: HeadSeed, forall tx. PostChainTx tx -> UTCTime
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 => Arbitrary (PostChainTx tx) where
  arbitrary :: Gen (PostChainTx tx)
arbitrary = Gen (PostChainTx tx)
forall a.
(Generic a, GA UnsizedOpts (Rep a),
 UniformWeight (Weights_ (Rep a))) =>
Gen a
genericArbitrary
  shrink :: PostChainTx tx -> [PostChainTx tx]
shrink = \case
    InitTx{[OnChainId]
$sel:participants:InitTx :: forall tx. PostChainTx tx -> [OnChainId]
participants :: [OnChainId]
participants, HeadParameters
$sel:headParameters:InitTx :: forall tx. PostChainTx tx -> HeadParameters
headParameters :: HeadParameters
headParameters} -> [OnChainId] -> HeadParameters -> PostChainTx tx
forall tx. [OnChainId] -> HeadParameters -> PostChainTx tx
InitTx ([OnChainId] -> HeadParameters -> PostChainTx tx)
-> [[OnChainId]] -> [HeadParameters -> PostChainTx tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [OnChainId] -> [[OnChainId]]
forall a. Arbitrary a => a -> [a]
shrink [OnChainId]
participants [HeadParameters -> PostChainTx tx]
-> [HeadParameters] -> [PostChainTx tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HeadParameters -> [HeadParameters]
forall a. Arbitrary a => a -> [a]
shrink HeadParameters
headParameters
    AbortTx{UTxOType tx
$sel:utxo:InitTx :: forall tx. PostChainTx tx -> UTxOType tx
utxo :: UTxOType tx
utxo, HeadSeed
$sel:headSeed:InitTx :: forall tx. PostChainTx tx -> HeadSeed
headSeed :: HeadSeed
headSeed} -> UTxOType tx -> HeadSeed -> PostChainTx tx
forall tx. UTxOType tx -> HeadSeed -> PostChainTx tx
AbortTx (UTxOType tx -> HeadSeed -> PostChainTx tx)
-> [UTxOType tx] -> [HeadSeed -> PostChainTx tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxOType tx -> [UTxOType tx]
forall a. Arbitrary a => a -> [a]
shrink UTxOType tx
utxo [HeadSeed -> PostChainTx tx] -> [HeadSeed] -> [PostChainTx tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HeadSeed -> [HeadSeed]
forall a. Arbitrary a => a -> [a]
shrink HeadSeed
headSeed
    CollectComTx{UTxOType tx
$sel:utxo:InitTx :: forall tx. PostChainTx tx -> UTxOType tx
utxo :: UTxOType tx
utxo, HeadId
$sel:headId:InitTx :: forall tx. PostChainTx tx -> HeadId
headId :: HeadId
headId, HeadParameters
$sel:headParameters:InitTx :: forall tx. PostChainTx tx -> HeadParameters
headParameters :: HeadParameters
headParameters} -> UTxOType tx -> HeadId -> HeadParameters -> PostChainTx tx
forall tx.
UTxOType tx -> HeadId -> HeadParameters -> PostChainTx tx
CollectComTx (UTxOType tx -> HeadId -> HeadParameters -> PostChainTx tx)
-> [UTxOType tx] -> [HeadId -> HeadParameters -> PostChainTx tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxOType tx -> [UTxOType tx]
forall a. Arbitrary a => a -> [a]
shrink UTxOType tx
utxo [HeadId -> HeadParameters -> PostChainTx tx]
-> [HeadId] -> [HeadParameters -> PostChainTx tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HeadId -> [HeadId]
forall a. Arbitrary a => a -> [a]
shrink HeadId
headId [HeadParameters -> PostChainTx tx]
-> [HeadParameters] -> [PostChainTx tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HeadParameters -> [HeadParameters]
forall a. Arbitrary a => a -> [a]
shrink HeadParameters
headParameters
    CloseTx{HeadId
$sel:headId:InitTx :: forall tx. PostChainTx tx -> HeadId
headId :: HeadId
headId, HeadParameters
$sel:headParameters:InitTx :: forall tx. PostChainTx tx -> HeadParameters
headParameters :: HeadParameters
headParameters, ConfirmedSnapshot tx
$sel:confirmedSnapshot:InitTx :: forall tx. PostChainTx tx -> ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx
confirmedSnapshot} -> HeadId -> HeadParameters -> ConfirmedSnapshot tx -> PostChainTx tx
forall tx.
HeadId -> HeadParameters -> ConfirmedSnapshot tx -> PostChainTx tx
CloseTx (HeadId
 -> HeadParameters -> ConfirmedSnapshot tx -> PostChainTx tx)
-> [HeadId]
-> [HeadParameters -> ConfirmedSnapshot tx -> PostChainTx tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HeadId -> [HeadId]
forall a. Arbitrary a => a -> [a]
shrink HeadId
headId [HeadParameters -> ConfirmedSnapshot tx -> PostChainTx tx]
-> [HeadParameters] -> [ConfirmedSnapshot tx -> PostChainTx tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HeadParameters -> [HeadParameters]
forall a. Arbitrary a => a -> [a]
shrink HeadParameters
headParameters [ConfirmedSnapshot tx -> PostChainTx tx]
-> [ConfirmedSnapshot tx] -> [PostChainTx tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ConfirmedSnapshot tx -> [ConfirmedSnapshot tx]
forall a. Arbitrary a => a -> [a]
shrink ConfirmedSnapshot tx
confirmedSnapshot
    ContestTx{HeadId
$sel:headId:InitTx :: forall tx. PostChainTx tx -> HeadId
headId :: HeadId
headId, HeadParameters
$sel:headParameters:InitTx :: forall tx. PostChainTx tx -> HeadParameters
headParameters :: HeadParameters
headParameters, ConfirmedSnapshot tx
$sel:confirmedSnapshot:InitTx :: forall tx. PostChainTx tx -> ConfirmedSnapshot tx
confirmedSnapshot :: ConfirmedSnapshot tx
confirmedSnapshot} -> HeadId -> HeadParameters -> ConfirmedSnapshot tx -> PostChainTx tx
forall tx.
HeadId -> HeadParameters -> ConfirmedSnapshot tx -> PostChainTx tx
ContestTx (HeadId
 -> HeadParameters -> ConfirmedSnapshot tx -> PostChainTx tx)
-> [HeadId]
-> [HeadParameters -> ConfirmedSnapshot tx -> PostChainTx tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HeadId -> [HeadId]
forall a. Arbitrary a => a -> [a]
shrink HeadId
headId [HeadParameters -> ConfirmedSnapshot tx -> PostChainTx tx]
-> [HeadParameters] -> [ConfirmedSnapshot tx -> PostChainTx tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HeadParameters -> [HeadParameters]
forall a. Arbitrary a => a -> [a]
shrink HeadParameters
headParameters [ConfirmedSnapshot tx -> PostChainTx tx]
-> [ConfirmedSnapshot tx] -> [PostChainTx tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ConfirmedSnapshot tx -> [ConfirmedSnapshot tx]
forall a. Arbitrary a => a -> [a]
shrink ConfirmedSnapshot tx
confirmedSnapshot
    FanoutTx{UTxOType tx
$sel:utxo:InitTx :: forall tx. PostChainTx tx -> UTxOType tx
utxo :: UTxOType tx
utxo, HeadSeed
$sel:headSeed:InitTx :: forall tx. PostChainTx tx -> HeadSeed
headSeed :: HeadSeed
headSeed, UTCTime
$sel:contestationDeadline:InitTx :: forall tx. PostChainTx tx -> UTCTime
contestationDeadline :: UTCTime
contestationDeadline} -> UTxOType tx -> HeadSeed -> UTCTime -> PostChainTx tx
forall tx. UTxOType tx -> HeadSeed -> UTCTime -> PostChainTx tx
FanoutTx (UTxOType tx -> HeadSeed -> UTCTime -> PostChainTx tx)
-> [UTxOType tx] -> [HeadSeed -> UTCTime -> PostChainTx tx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxOType tx -> [UTxOType tx]
forall a. Arbitrary a => a -> [a]
shrink UTxOType tx
utxo [HeadSeed -> UTCTime -> PostChainTx tx]
-> [HeadSeed] -> [UTCTime -> PostChainTx tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HeadSeed -> [HeadSeed]
forall a. Arbitrary a => a -> [a]
shrink HeadSeed
headSeed [UTCTime -> PostChainTx tx] -> [UTCTime] -> [PostChainTx tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> UTCTime -> [UTCTime]
forall a. Arbitrary a => a -> [a]
shrink UTCTime
contestationDeadline

-- | 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]
      }
  | OnCommitTx
      { headId :: HeadId
      , forall tx. OnChainTx tx -> Party
party :: Party
      , forall tx. OnChainTx tx -> UTxOType tx
committed :: UTxOType tx
      }
  | OnAbortTx {headId :: HeadId}
  | OnCollectComTx {headId :: HeadId}
  | 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}
  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 (Arbitrary tx, Arbitrary (UTxOType tx)) => Arbitrary (OnChainTx tx) where
  arbitrary :: Gen (OnChainTx tx)
arbitrary = Gen (OnChainTx tx)
forall a.
(Generic a, GA UnsizedOpts (Rep a),
 UniformWeight (Weights_ (Rep a))) =>
Gen a
genericArbitrary

-- | Exceptions thrown by 'postTx'.
data PostTxError tx
  = NoSeedInput
  | InvalidSeed {forall tx. PostTxError tx -> HeadSeed
headSeed :: HeadSeed}
  | InvalidHeadId {forall tx. PostTxError tx -> HeadId
headId :: HeadId}
  | CannotFindOwnInitial {forall tx. PostTxError tx -> UTxOType tx
knownUTxO :: UTxOType tx}
  | -- | Comitting byron addresses is not supported.
    UnsupportedLegacyOutput {forall tx. PostTxError tx -> Address ByronAddr
byronAddress :: Address ByronAddr}
  | -- | Comitting reference scripts is not supported right now.
    CannotCommitReferenceScript
  | InvalidStateToPost {forall tx. PostTxError tx -> PostChainTx tx
txTried :: PostChainTx tx, forall tx. PostTxError tx -> ChainStateType tx
chainState :: ChainStateType tx}
  | NotEnoughFuel
  | NoFuelUTXOFound
  | -- | Script execution failed when finalizing a transaction in the wallet.
    -- XXX: Ideally we want a cardano-api type with corresonding 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}
  | -- | A generic error happened when finalizing a transction in the wallet.
    InternalWalletError {forall tx. PostTxError tx -> UTxOType tx
headUTxO :: UTxOType tx, forall tx. PostTxError tx -> Text
reason :: Text, forall tx. PostTxError tx -> tx
tx :: tx}
  | -- | An error occurred when submitting a transaction to the cardano-node.
    FailedToPostTx {failureReason :: Text}
  | -- | A plutus script failed in a transaction submitted to the cardano-node.
    -- NOTE: PlutusDebugInfo does not have much available instances so we put it
    -- in Text form but it's lame
    PlutusValidationFailed {forall tx. PostTxError tx -> Text
plutusFailure :: Text, forall tx. PostTxError tx -> Text
plutusDebugInfo :: Text}
  | -- | User tried to commit more than 'maxMainnetLovelace' hardcoded limit on mainnet
    -- we keep track of both the hardcoded limit and what the user originally tried to commit
    CommittedTooMuchADAForMainnet {forall tx. PostTxError tx -> Coin
userCommittedLovelace :: Coin, forall tx. PostTxError tx -> Coin
mainnetLimitLovelace :: Coin}
  | -- | We can only draft commit tx for the user when in Initializing state
    FailedToDraftTxNotInitializing
  | -- | Committing UTxO addressed to the internal wallet is forbidden.
    SpendingNodeUtxoForbidden
  | FailedToConstructAbortTx
  | FailedToConstructCloseTx
  | FailedToConstructContestTx
  | FailedToConstructCollectTx
  | FailedToConstructFanoutTx
  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 (IsTx tx, Arbitrary (ChainStateType tx)) => Arbitrary (PostTxError tx) where
  arbitrary :: Gen (PostTxError tx)
arbitrary = Gen (PostTxError tx)
forall a.
(Generic a, GA UnsizedOpts (Rep a),
 UniformWeight (Weights_ (Rep a))) =>
Gen a
genericArbitrary

-- | 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)
  , forall tx. ChainStateHistory tx -> ChainStateType tx
defaultChainState :: ChainStateType tx
  }
  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)

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

pushNewState :: ChainStateType tx -> ChainStateHistory tx -> ChainStateHistory tx
pushNewState :: forall 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} = ChainStateHistory tx
h{history = cs <| history}

initHistory :: ChainStateType tx -> ChainStateHistory tx
initHistory :: forall 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: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 = fromMaybe (defaultChainState :| []) (nonEmpty rolledBack)}
 where
  rolledBack :: [ChainStateType tx]
rolledBack =
    (ChainStateType tx -> Bool)
-> [ChainStateType tx] -> [ChainStateType tx]
forall a. (a -> Bool) -> [a] -> [a]
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) -> [ChainStateType tx]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (ChainStateType tx)
history)

deriving stock instance Eq (ChainStateType tx) => Eq (ChainStateHistory tx)
deriving stock instance Show (ChainStateType tx) => Show (ChainStateHistory tx)
deriving anyclass instance ToJSON (ChainStateType tx) => ToJSON (ChainStateHistory tx)
deriving anyclass instance FromJSON (ChainStateType tx) => FromJSON (ChainStateHistory tx)

instance Arbitrary (ChainStateType tx) => Arbitrary (ChainStateHistory tx) where
  arbitrary :: Gen (ChainStateHistory tx)
arbitrary = Gen (ChainStateHistory tx)
forall a.
(Generic a, GA UnsizedOpts (Rep a),
 UniformWeight (Weights_ (Rep a))) =>
Gen a
genericArbitrary

-- | Types that can be used on-chain by the Hydra protocol.
-- XXX: Find a better name for this. Maybe IsChainTx or IsL1Tx?
class
  ( IsTx tx
  , Eq (ChainStateType tx)
  , Show (ChainStateType tx)
  , Arbitrary (ChainStateType tx)
  , FromJSON (ChainStateType tx)
  , ToJSON (ChainStateType tx)
  ) =>
  IsChainState tx
  where
  -- | Types of what to keep as L1 chain state.
  type ChainStateType tx = c | c -> tx

  -- | Get the chain slot for a chain state. NOTE: For any sequence of 'a'
  -- encountered, we assume monotonically increasing slots.
  chainStateSlot :: ChainStateType tx -> ChainSlot

-- | 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
   -> UTxO' (TxOut CtxUTxO, Witness WitCtxTxIn)
   -> m (Either (PostTxError Tx) Tx)
draftCommitTx ::
      MonadThrow m =>
      HeadId ->
      UTxO' (TxOut CtxUTxO, Witness WitCtxTxIn) ->
      m (Either (PostTxError Tx) Tx)
  -- ^ Create a commit transaction using user provided utxos (zero or many) and
  -- information to spend from a script. 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.
  }

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 -> ChainStateType tx
rolledBackChainState :: ChainStateType tx
      }
  | -- | Indicate time has advanced on the chain.
    --
    -- NOTE: While the type does not guarantee that the UTCTime and ChainSlot
    -- 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
      { forall tx. ChainEvent tx -> UTCTime
chainTime :: UTCTime
      , forall tx. ChainEvent tx -> ChainSlot
chainSlot :: ChainSlot
      }
  | -- | 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}
  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 (IsTx tx, IsChainState tx) => Arbitrary (ChainEvent tx) where
  arbitrary :: Gen (ChainEvent tx)
arbitrary = Gen (ChainEvent tx)
forall a.
(Generic a, GA UnsizedOpts (Rep a),
 UniformWeight (Weights_ (Rep a))) =>
Gen a
genericArbitrary

-- | 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