{-# 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.NonEmpty ((<|))
import Hydra.Cardano.Api (
  Address,
  ByronAddr,
  Coin (..),
 )
import Hydra.Chain.ChainState (ChainSlot, IsChainState (..))
import Hydra.Tx (
  CommitBlueprintTx,
  ConfirmedSnapshot,
  HeadId,
  HeadParameters (..),
  HeadSeed,
  IsTx (..),
  Party,
  SnapshotNumber,
  SnapshotVersion,
  UTxOType,
 )
import Hydra.Tx.IsTx (ArbitraryIsTx)
import Hydra.Tx.OnChainId (OnChainId)
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'). A too high
-- enough number would be detected by property and acceptance tests.
maximumNumberOfParties :: Int
maximumNumberOfParties :: Int
maximumNumberOfParties = Int
7

-- | 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}
  | IncrementTx
      { headId :: HeadId
      , headParameters :: HeadParameters
      , forall tx. PostChainTx tx -> ConfirmedSnapshot tx
incrementingSnapshot :: ConfirmedSnapshot tx
      , forall tx. PostChainTx tx -> TxIdType tx
depositTxId :: TxIdType tx
      }
  | RecoverTx
      { headId :: HeadId
      , forall tx. PostChainTx tx -> TxIdType tx
recoverTxId :: TxIdType tx
      , forall tx. PostChainTx tx -> ChainSlot
deadline :: ChainSlot
      }
  | DecrementTx
      { 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 {utxo :: UTxOType tx, forall tx. PostChainTx tx -> Maybe (UTxOType tx)
utxoToDecommit :: Maybe (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 ArbitraryIsTx 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
    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
$sel:incrementingSnapshot:InitTx :: forall tx. PostChainTx tx -> ConfirmedSnapshot tx
incrementingSnapshot :: ConfirmedSnapshot tx
incrementingSnapshot, TxIdType tx
$sel:depositTxId:InitTx :: forall tx. PostChainTx tx -> TxIdType tx
depositTxId :: TxIdType tx
depositTxId} ->
      HeadId
-> HeadParameters
-> ConfirmedSnapshot tx
-> TxIdType tx
-> PostChainTx tx
forall tx.
HeadId
-> HeadParameters
-> ConfirmedSnapshot tx
-> TxIdType tx
-> PostChainTx tx
IncrementTx (HeadId
 -> HeadParameters
 -> ConfirmedSnapshot tx
 -> TxIdType tx
 -> PostChainTx tx)
-> [HeadId]
-> [HeadParameters
    -> ConfirmedSnapshot tx -> TxIdType 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 -> TxIdType tx -> PostChainTx tx]
-> [HeadParameters]
-> [ConfirmedSnapshot tx -> TxIdType 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 -> TxIdType tx -> PostChainTx tx]
-> [ConfirmedSnapshot tx] -> [TxIdType 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
incrementingSnapshot [TxIdType tx -> PostChainTx tx]
-> [TxIdType tx] -> [PostChainTx tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TxIdType tx -> [TxIdType tx]
forall a. Arbitrary a => a -> [a]
shrink TxIdType tx
depositTxId
    RecoverTx{HeadId
$sel:headId:InitTx :: forall tx. PostChainTx tx -> HeadId
headId :: HeadId
headId, TxIdType tx
$sel:recoverTxId:InitTx :: forall tx. PostChainTx tx -> TxIdType tx
recoverTxId :: TxIdType tx
recoverTxId, ChainSlot
$sel:deadline:InitTx :: forall tx. PostChainTx tx -> ChainSlot
deadline :: ChainSlot
deadline} ->
      HeadId -> TxIdType tx -> ChainSlot -> PostChainTx tx
forall tx. HeadId -> TxIdType tx -> ChainSlot -> PostChainTx tx
RecoverTx (HeadId -> TxIdType tx -> ChainSlot -> PostChainTx tx)
-> [HeadId] -> [TxIdType tx -> ChainSlot -> 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 [TxIdType tx -> ChainSlot -> PostChainTx tx]
-> [TxIdType tx] -> [ChainSlot -> PostChainTx tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TxIdType tx -> [TxIdType tx]
forall a. Arbitrary a => a -> [a]
shrink TxIdType tx
recoverTxId [ChainSlot -> PostChainTx tx] -> [ChainSlot] -> [PostChainTx tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ChainSlot -> [ChainSlot]
forall a. Arbitrary a => a -> [a]
shrink ChainSlot
deadline
    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
$sel:decrementingSnapshot:InitTx :: forall tx. PostChainTx tx -> ConfirmedSnapshot tx
decrementingSnapshot :: ConfirmedSnapshot tx
decrementingSnapshot} -> HeadId -> HeadParameters -> ConfirmedSnapshot tx -> PostChainTx tx
forall tx.
HeadId -> HeadParameters -> ConfirmedSnapshot tx -> PostChainTx tx
DecrementTx (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
decrementingSnapshot
    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
$sel:openVersion:InitTx :: forall tx. PostChainTx tx -> SnapshotVersion
openVersion :: SnapshotVersion
openVersion, ConfirmedSnapshot tx
$sel:closingSnapshot:InitTx :: forall tx. PostChainTx tx -> ConfirmedSnapshot tx
closingSnapshot :: ConfirmedSnapshot tx
closingSnapshot} -> HeadId
-> HeadParameters
-> SnapshotVersion
-> ConfirmedSnapshot tx
-> PostChainTx tx
forall tx.
HeadId
-> HeadParameters
-> SnapshotVersion
-> ConfirmedSnapshot tx
-> PostChainTx tx
CloseTx (HeadId
 -> HeadParameters
 -> SnapshotVersion
 -> ConfirmedSnapshot tx
 -> PostChainTx tx)
-> [HeadId]
-> [HeadParameters
    -> SnapshotVersion -> 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
 -> SnapshotVersion -> ConfirmedSnapshot tx -> PostChainTx tx]
-> [HeadParameters]
-> [SnapshotVersion -> 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 [SnapshotVersion -> ConfirmedSnapshot tx -> PostChainTx tx]
-> [SnapshotVersion] -> [ConfirmedSnapshot tx -> PostChainTx tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SnapshotVersion -> [SnapshotVersion]
forall a. Arbitrary a => a -> [a]
shrink SnapshotVersion
openVersion [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
closingSnapshot
    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
$sel:contestingSnapshot:InitTx :: forall tx. PostChainTx tx -> ConfirmedSnapshot tx
contestingSnapshot :: ConfirmedSnapshot tx
contestingSnapshot} -> HeadId
-> HeadParameters
-> SnapshotVersion
-> ConfirmedSnapshot tx
-> PostChainTx tx
forall tx.
HeadId
-> HeadParameters
-> SnapshotVersion
-> ConfirmedSnapshot tx
-> PostChainTx tx
ContestTx (HeadId
 -> HeadParameters
 -> SnapshotVersion
 -> ConfirmedSnapshot tx
 -> PostChainTx tx)
-> [HeadId]
-> [HeadParameters
    -> SnapshotVersion -> 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
 -> SnapshotVersion -> ConfirmedSnapshot tx -> PostChainTx tx]
-> [HeadParameters]
-> [SnapshotVersion -> 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 [SnapshotVersion -> ConfirmedSnapshot tx -> PostChainTx tx]
-> [SnapshotVersion] -> [ConfirmedSnapshot tx -> PostChainTx tx]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SnapshotVersion -> [SnapshotVersion]
forall a. Arbitrary a => a -> [a]
shrink SnapshotVersion
openVersion [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
contestingSnapshot
    FanoutTx{UTxOType tx
$sel:utxo:InitTx :: forall tx. PostChainTx tx -> UTxOType tx
utxo :: UTxOType tx
utxo, Maybe (UTxOType tx)
$sel:utxoToDecommit:InitTx :: forall tx. PostChainTx tx -> Maybe (UTxOType tx)
utxoToDecommit :: Maybe (UTxOType tx)
utxoToDecommit, 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
-> Maybe (UTxOType tx) -> HeadSeed -> UTCTime -> PostChainTx tx
forall tx.
UTxOType tx
-> Maybe (UTxOType tx) -> HeadSeed -> UTCTime -> PostChainTx tx
FanoutTx (UTxOType tx
 -> Maybe (UTxOType tx) -> HeadSeed -> UTCTime -> PostChainTx tx)
-> [UTxOType tx]
-> [Maybe (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 [Maybe (UTxOType tx) -> HeadSeed -> UTCTime -> PostChainTx tx]
-> [Maybe (UTxOType 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
<*> Maybe (UTxOType tx) -> [Maybe (UTxOType tx)]
forall a. Arbitrary a => a -> [a]
shrink Maybe (UTxOType tx)
utxoToDecommit [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}
  | OnDepositTx
      { headId :: HeadId
      , forall tx. OnChainTx tx -> UTxOType tx
deposited :: UTxOType tx
      , forall tx. OnChainTx tx -> TxIdType tx
depositTxId :: TxIdType tx
      , forall tx. OnChainTx tx -> UTCTime
deadline :: UTCTime
      }
  | OnRecoverTx
      { headId :: HeadId
      , forall tx. OnChainTx tx -> TxIdType tx
recoveredTxId :: TxIdType tx
      }
  | OnIncrementTx
      { headId :: HeadId
      , forall tx. OnChainTx tx -> SnapshotVersion
newVersion :: SnapshotVersion
      , depositTxId :: TxIdType tx
      }
  | OnDecrementTx
      { headId :: HeadId
      , newVersion :: SnapshotVersion
      , forall tx. OnChainTx tx -> [TxOutType tx]
distributedOutputs :: [TxOutType 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}
  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 ArbitraryIsTx 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}
  | 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
  | FailedToConstructAbortTx
  | FailedToConstructCloseTx
  | FailedToConstructContestTx
  | FailedToConstructCollectTx
  | FailedToConstructDepositTx
  | FailedToConstructRecoverTx
  | FailedToConstructIncrementTx
  | FailedToConstructDecrementTx
  | 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 (ArbitraryIsTx tx, IsChainState 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

-- | 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 -> CommitBlueprintTx tx -> m (Either (PostTxError tx) tx)
draftCommitTx ::
      MonadThrow m =>
      HeadId ->
      CommitBlueprintTx tx ->
      m (Either (PostTxError tx) tx)
  -- ^ Create a commit transaction using user provided utxos (zero or many) and
  -- a _blueprint_ transaction which spends these outputs.
  -- Errors are handled at the call site.
  , forall tx (m :: * -> *).
Chain tx m
-> MonadThrow m =>
   HeadId
   -> CommitBlueprintTx tx
   -> UTCTime
   -> m (Either (PostTxError tx) tx)
draftDepositTx ::
      MonadThrow m =>
      HeadId ->
      CommitBlueprintTx tx ->
      UTCTime ->
      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. 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 (ArbitraryIsTx 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