{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DuplicateRecordFields #-}

-- | Smart constructors for creating Hydra protocol transactions to be used in
-- the 'Hydra.Chain.Direct' way of talking to the main-chain.
--
-- This module also encapsulates the transaction format used when talking to the
-- cardano-node, which is currently different from the 'Hydra.Ledger.Cardano',
-- thus we have not yet "reached" 'isomorphism'.
module Hydra.Chain.Direct.Tx (
  module Hydra.Chain.Direct.Tx,
) where

import Hydra.Cardano.Api
import Hydra.Prelude hiding (toList)

import Cardano.Api.UTxO qualified as UTxO
import Data.Aeson qualified as Aeson
import Data.ByteString qualified as BS
import Data.ByteString.Base16 qualified as Base16
import Data.Map qualified as Map
import GHC.IsList (IsList (..))
import Hydra.Contract.Commit qualified as Commit
import Hydra.Contract.Deposit qualified as Deposit
import Hydra.Contract.Head qualified as Head
import Hydra.Contract.HeadState qualified as Head
import Hydra.Contract.HeadTokens qualified as HeadTokens
import Hydra.Data.ContestationPeriod qualified as OnChain
import Hydra.Data.Party qualified as OnChain
import Hydra.Plutus (commitValidatorScript, initialValidatorScript)
import Hydra.Plutus.Extras (posixToUTCTime)
import Hydra.Plutus.Orphans ()
import Hydra.Tx (
  HeadId (..),
  HeadSeed (..),
  Party,
  SnapshotNumber,
  SnapshotVersion,
  fromChainSnapshotNumber,
  fromChainSnapshotVersion,
  headIdToCurrencySymbol,
  mkHeadId,
  partyFromChain,
 )
import Hydra.Tx.Close (OpenThreadOutput (..))
import Hydra.Tx.Contest (ClosedThreadOutput (..))
import Hydra.Tx.ContestationPeriod (ContestationPeriod, fromChain)
import Hydra.Tx.Deposit (DepositObservation (..), observeDepositTx)
import Hydra.Tx.OnChainId (OnChainId (..))
import Hydra.Tx.Recover (RecoverObservation (..), observeRecoverTx)
import Hydra.Tx.Utils (assetNameToOnChainId, findFirst, hydraHeadV1AssetName, hydraMetadataLabel)
import PlutusLedgerApi.V3 (CurrencySymbol, fromBuiltin)
import PlutusLedgerApi.V3 qualified as Plutus
import Test.Hydra.Tx.Gen ()
import Test.QuickCheck (vectorOf)

-- | Needed on-chain data to create Head transactions.
type UTxOWithScript = (TxIn, TxOut CtxUTxO, HashableScriptData)

newtype UTxOHash = UTxOHash ByteString
  deriving stock (UTxOHash -> UTxOHash -> Bool
(UTxOHash -> UTxOHash -> Bool)
-> (UTxOHash -> UTxOHash -> Bool) -> Eq UTxOHash
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UTxOHash -> UTxOHash -> Bool
== :: UTxOHash -> UTxOHash -> Bool
$c/= :: UTxOHash -> UTxOHash -> Bool
/= :: UTxOHash -> UTxOHash -> Bool
Eq, Int -> UTxOHash -> ShowS
[UTxOHash] -> ShowS
UTxOHash -> String
(Int -> UTxOHash -> ShowS)
-> (UTxOHash -> String) -> ([UTxOHash] -> ShowS) -> Show UTxOHash
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UTxOHash -> ShowS
showsPrec :: Int -> UTxOHash -> ShowS
$cshow :: UTxOHash -> String
show :: UTxOHash -> String
$cshowList :: [UTxOHash] -> ShowS
showList :: [UTxOHash] -> ShowS
Show, (forall x. UTxOHash -> Rep UTxOHash x)
-> (forall x. Rep UTxOHash x -> UTxOHash) -> Generic UTxOHash
forall x. Rep UTxOHash x -> UTxOHash
forall x. UTxOHash -> Rep UTxOHash x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. UTxOHash -> Rep UTxOHash x
from :: forall x. UTxOHash -> Rep UTxOHash x
$cto :: forall x. Rep UTxOHash x -> UTxOHash
to :: forall x. Rep UTxOHash x -> UTxOHash
Generic)

instance ToJSON UTxOHash where
  toJSON :: UTxOHash -> Value
toJSON (UTxOHash ByteString
bytes) =
    Text -> Value
Aeson.String (Text -> Value) -> (ByteString -> Text) -> ByteString -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (ByteString -> Value) -> ByteString -> Value
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
Base16.encode ByteString
bytes

instance FromJSON UTxOHash where
  parseJSON :: Value -> Parser UTxOHash
parseJSON = String -> (Text -> Parser UTxOHash) -> Value -> Parser UTxOHash
forall a. String -> (Text -> Parser a) -> Value -> Parser a
Aeson.withText String
"UTxOHash" ((Text -> Parser UTxOHash) -> Value -> Parser UTxOHash)
-> (Text -> Parser UTxOHash) -> Value -> Parser UTxOHash
forall a b. (a -> b) -> a -> b
$ \Text
cborText ->
    case ByteString -> Either String ByteString
Base16.decode (ByteString -> Either String ByteString)
-> ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 Text
cborText of
      Left String
e -> String -> Parser UTxOHash
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
e
      Right ByteString
bs -> UTxOHash -> Parser UTxOHash
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTxOHash -> Parser UTxOHash) -> UTxOHash -> Parser UTxOHash
forall a b. (a -> b) -> a -> b
$ ByteString -> UTxOHash
UTxOHash ByteString
bs

instance Arbitrary UTxOHash where
  arbitrary :: Gen UTxOHash
arbitrary = ByteString -> UTxOHash
UTxOHash (ByteString -> UTxOHash)
-> ([Word8] -> ByteString) -> [Word8] -> UTxOHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> ByteString
BS.pack ([Word8] -> UTxOHash) -> Gen [Word8] -> Gen UTxOHash
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen Word8 -> Gen [Word8]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
32 Gen Word8
forall a. Arbitrary a => Gen a
arbitrary

-- | Representation of the Head output after an Init transaction.
data InitialThreadOutput = InitialThreadOutput
  { InitialThreadOutput -> (TxIn, TxOut CtxUTxO)
initialThreadUTxO :: (TxIn, TxOut CtxUTxO)
  , InitialThreadOutput -> ContestationPeriod
initialContestationPeriod :: OnChain.ContestationPeriod
  , InitialThreadOutput -> [Party]
initialParties :: [OnChain.Party]
  }
  deriving stock (InitialThreadOutput -> InitialThreadOutput -> Bool
(InitialThreadOutput -> InitialThreadOutput -> Bool)
-> (InitialThreadOutput -> InitialThreadOutput -> Bool)
-> Eq InitialThreadOutput
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: InitialThreadOutput -> InitialThreadOutput -> Bool
== :: InitialThreadOutput -> InitialThreadOutput -> Bool
$c/= :: InitialThreadOutput -> InitialThreadOutput -> Bool
/= :: InitialThreadOutput -> InitialThreadOutput -> Bool
Eq, Int -> InitialThreadOutput -> ShowS
[InitialThreadOutput] -> ShowS
InitialThreadOutput -> String
(Int -> InitialThreadOutput -> ShowS)
-> (InitialThreadOutput -> String)
-> ([InitialThreadOutput] -> ShowS)
-> Show InitialThreadOutput
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> InitialThreadOutput -> ShowS
showsPrec :: Int -> InitialThreadOutput -> ShowS
$cshow :: InitialThreadOutput -> String
show :: InitialThreadOutput -> String
$cshowList :: [InitialThreadOutput] -> ShowS
showList :: [InitialThreadOutput] -> ShowS
Show, (forall x. InitialThreadOutput -> Rep InitialThreadOutput x)
-> (forall x. Rep InitialThreadOutput x -> InitialThreadOutput)
-> Generic InitialThreadOutput
forall x. Rep InitialThreadOutput x -> InitialThreadOutput
forall x. InitialThreadOutput -> Rep InitialThreadOutput x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. InitialThreadOutput -> Rep InitialThreadOutput x
from :: forall x. InitialThreadOutput -> Rep InitialThreadOutput x
$cto :: forall x. Rep InitialThreadOutput x -> InitialThreadOutput
to :: forall x. Rep InitialThreadOutput x -> InitialThreadOutput
Generic)
  deriving anyclass ([InitialThreadOutput] -> Value
[InitialThreadOutput] -> Encoding
InitialThreadOutput -> Bool
InitialThreadOutput -> Value
InitialThreadOutput -> Encoding
(InitialThreadOutput -> Value)
-> (InitialThreadOutput -> Encoding)
-> ([InitialThreadOutput] -> Value)
-> ([InitialThreadOutput] -> Encoding)
-> (InitialThreadOutput -> Bool)
-> ToJSON InitialThreadOutput
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: InitialThreadOutput -> Value
toJSON :: InitialThreadOutput -> Value
$ctoEncoding :: InitialThreadOutput -> Encoding
toEncoding :: InitialThreadOutput -> Encoding
$ctoJSONList :: [InitialThreadOutput] -> Value
toJSONList :: [InitialThreadOutput] -> Value
$ctoEncodingList :: [InitialThreadOutput] -> Encoding
toEncodingList :: [InitialThreadOutput] -> Encoding
$comitField :: InitialThreadOutput -> Bool
omitField :: InitialThreadOutput -> Bool
ToJSON, Maybe InitialThreadOutput
Value -> Parser [InitialThreadOutput]
Value -> Parser InitialThreadOutput
(Value -> Parser InitialThreadOutput)
-> (Value -> Parser [InitialThreadOutput])
-> Maybe InitialThreadOutput
-> FromJSON InitialThreadOutput
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser InitialThreadOutput
parseJSON :: Value -> Parser InitialThreadOutput
$cparseJSONList :: Value -> Parser [InitialThreadOutput]
parseJSONList :: Value -> Parser [InitialThreadOutput]
$comittedField :: Maybe InitialThreadOutput
omittedField :: Maybe InitialThreadOutput
FromJSON)

instance Arbitrary InitialThreadOutput where
  arbitrary :: Gen InitialThreadOutput
arbitrary = Gen InitialThreadOutput
forall a.
(Generic a, GA UnsizedOpts (Rep a),
 UniformWeight (Weights_ (Rep a))) =>
Gen a
genericArbitrary
  shrink :: InitialThreadOutput -> [InitialThreadOutput]
shrink = InitialThreadOutput -> [InitialThreadOutput]
forall a.
(Generic a, RecursivelyShrink (Rep a), GSubterms (Rep a) a) =>
a -> [a]
genericShrink

-- | Get the metadata entry to identify Hydra transactions (for informational
-- purposes).
getHydraHeadV1TxName :: Tx -> Maybe Text
getHydraHeadV1TxName :: Tx -> Maybe Text
getHydraHeadV1TxName =
  TxMetadataInEra -> Maybe Text
lookupName (TxMetadataInEra -> Maybe Text)
-> (Tx -> TxMetadataInEra) -> Tx -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxBodyContent ViewTx -> TxMetadataInEra
forall buidl. TxBodyContent buidl -> TxMetadataInEra
txMetadata (TxBodyContent ViewTx -> TxMetadataInEra)
-> (Tx -> TxBodyContent ViewTx) -> Tx -> TxMetadataInEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxBody Era -> TxBodyContent ViewTx
forall era. TxBody era -> TxBodyContent ViewTx era
getTxBodyContent (TxBody Era -> TxBodyContent ViewTx)
-> (Tx -> TxBody Era) -> Tx -> TxBodyContent ViewTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx -> TxBody Era
forall era. Tx era -> TxBody era
getTxBody
 where
  lookupName :: TxMetadataInEra -> Maybe Text
lookupName = \case
    TxMetadataInEra
TxMetadataNone -> Maybe Text
forall a. Maybe a
Nothing
    TxMetadataInEra (TxMetadata Map Word64 TxMetadataValue
m) ->
      case Word64 -> Map Word64 TxMetadataValue -> Maybe TxMetadataValue
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Word64
hydraMetadataLabel Map Word64 TxMetadataValue
m of
        Just (TxMetaText Text
name) -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
name
        Maybe TxMetadataValue
_ -> Maybe Text
forall a. Maybe a
Nothing

-- * Observe Hydra Head transactions

-- | Generalised type for arbitrary Head observations on-chain.
data HeadObservation
  = NoHeadTx
  | Init InitObservation
  | Abort AbortObservation
  | Commit CommitObservation
  | CollectCom CollectComObservation
  | Deposit DepositObservation
  | Recover RecoverObservation
  | Increment IncrementObservation
  | Decrement DecrementObservation
  | Close CloseObservation
  | Contest ContestObservation
  | Fanout FanoutObservation
  deriving stock (HeadObservation -> HeadObservation -> Bool
(HeadObservation -> HeadObservation -> Bool)
-> (HeadObservation -> HeadObservation -> Bool)
-> Eq HeadObservation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HeadObservation -> HeadObservation -> Bool
== :: HeadObservation -> HeadObservation -> Bool
$c/= :: HeadObservation -> HeadObservation -> Bool
/= :: HeadObservation -> HeadObservation -> Bool
Eq, Int -> HeadObservation -> ShowS
[HeadObservation] -> ShowS
HeadObservation -> String
(Int -> HeadObservation -> ShowS)
-> (HeadObservation -> String)
-> ([HeadObservation] -> ShowS)
-> Show HeadObservation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HeadObservation -> ShowS
showsPrec :: Int -> HeadObservation -> ShowS
$cshow :: HeadObservation -> String
show :: HeadObservation -> String
$cshowList :: [HeadObservation] -> ShowS
showList :: [HeadObservation] -> ShowS
Show, (forall x. HeadObservation -> Rep HeadObservation x)
-> (forall x. Rep HeadObservation x -> HeadObservation)
-> Generic HeadObservation
forall x. Rep HeadObservation x -> HeadObservation
forall x. HeadObservation -> Rep HeadObservation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. HeadObservation -> Rep HeadObservation x
from :: forall x. HeadObservation -> Rep HeadObservation x
$cto :: forall x. Rep HeadObservation x -> HeadObservation
to :: forall x. Rep HeadObservation x -> HeadObservation
Generic)

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

-- | Observe any Hydra head transaction.
observeHeadTx :: NetworkId -> UTxO -> Tx -> HeadObservation
observeHeadTx :: NetworkId -> UTxO -> Tx -> HeadObservation
observeHeadTx NetworkId
networkId UTxO
utxo Tx
tx =
  HeadObservation -> Maybe HeadObservation -> HeadObservation
forall a. a -> Maybe a -> a
fromMaybe HeadObservation
NoHeadTx (Maybe HeadObservation -> HeadObservation)
-> Maybe HeadObservation -> HeadObservation
forall a b. (a -> b) -> a -> b
$
    (NotAnInitReason -> Maybe HeadObservation)
-> (InitObservation -> Maybe HeadObservation)
-> Either NotAnInitReason InitObservation
-> Maybe HeadObservation
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe HeadObservation -> NotAnInitReason -> Maybe HeadObservation
forall a b. a -> b -> a
const Maybe HeadObservation
forall a. Maybe a
Nothing) (HeadObservation -> Maybe HeadObservation
forall a. a -> Maybe a
Just (HeadObservation -> Maybe HeadObservation)
-> (InitObservation -> HeadObservation)
-> InitObservation
-> Maybe HeadObservation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InitObservation -> HeadObservation
Init) (Tx -> Either NotAnInitReason InitObservation
observeInitTx Tx
tx)
      Maybe HeadObservation
-> Maybe HeadObservation -> Maybe HeadObservation
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> AbortObservation -> HeadObservation
Abort (AbortObservation -> HeadObservation)
-> Maybe AbortObservation -> Maybe HeadObservation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxO -> Tx -> Maybe AbortObservation
observeAbortTx UTxO
utxo Tx
tx
      Maybe HeadObservation
-> Maybe HeadObservation -> Maybe HeadObservation
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> CommitObservation -> HeadObservation
Commit (CommitObservation -> HeadObservation)
-> Maybe CommitObservation -> Maybe HeadObservation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NetworkId -> UTxO -> Tx -> Maybe CommitObservation
observeCommitTx NetworkId
networkId UTxO
utxo Tx
tx
      Maybe HeadObservation
-> Maybe HeadObservation -> Maybe HeadObservation
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> CollectComObservation -> HeadObservation
CollectCom (CollectComObservation -> HeadObservation)
-> Maybe CollectComObservation -> Maybe HeadObservation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxO -> Tx -> Maybe CollectComObservation
observeCollectComTx UTxO
utxo Tx
tx
      Maybe HeadObservation
-> Maybe HeadObservation -> Maybe HeadObservation
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> DepositObservation -> HeadObservation
Deposit (DepositObservation -> HeadObservation)
-> Maybe DepositObservation -> Maybe HeadObservation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NetworkId -> Tx -> Maybe DepositObservation
observeDepositTx NetworkId
networkId Tx
tx
      Maybe HeadObservation
-> Maybe HeadObservation -> Maybe HeadObservation
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> RecoverObservation -> HeadObservation
Recover (RecoverObservation -> HeadObservation)
-> Maybe RecoverObservation -> Maybe HeadObservation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NetworkId -> UTxO -> Tx -> Maybe RecoverObservation
observeRecoverTx NetworkId
networkId UTxO
utxo Tx
tx
      Maybe HeadObservation
-> Maybe HeadObservation -> Maybe HeadObservation
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> IncrementObservation -> HeadObservation
Increment (IncrementObservation -> HeadObservation)
-> Maybe IncrementObservation -> Maybe HeadObservation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxO -> Tx -> Maybe IncrementObservation
observeIncrementTx UTxO
utxo Tx
tx
      Maybe HeadObservation
-> Maybe HeadObservation -> Maybe HeadObservation
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> DecrementObservation -> HeadObservation
Decrement (DecrementObservation -> HeadObservation)
-> Maybe DecrementObservation -> Maybe HeadObservation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxO -> Tx -> Maybe DecrementObservation
observeDecrementTx UTxO
utxo Tx
tx
      Maybe HeadObservation
-> Maybe HeadObservation -> Maybe HeadObservation
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> CloseObservation -> HeadObservation
Close (CloseObservation -> HeadObservation)
-> Maybe CloseObservation -> Maybe HeadObservation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxO -> Tx -> Maybe CloseObservation
observeCloseTx UTxO
utxo Tx
tx
      Maybe HeadObservation
-> Maybe HeadObservation -> Maybe HeadObservation
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ContestObservation -> HeadObservation
Contest (ContestObservation -> HeadObservation)
-> Maybe ContestObservation -> Maybe HeadObservation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxO -> Tx -> Maybe ContestObservation
observeContestTx UTxO
utxo Tx
tx
      Maybe HeadObservation
-> Maybe HeadObservation -> Maybe HeadObservation
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> FanoutObservation -> HeadObservation
Fanout (FanoutObservation -> HeadObservation)
-> Maybe FanoutObservation -> Maybe HeadObservation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxO -> Tx -> Maybe FanoutObservation
observeFanoutTx UTxO
utxo Tx
tx

-- | Data which can be observed from an `initTx`.
data InitObservation = InitObservation
  { InitObservation -> (TxIn, TxOut CtxUTxO)
initialThreadUTxO :: (TxIn, TxOut CtxUTxO)
  , InitObservation -> [(TxIn, TxOut CtxUTxO)]
initials :: [(TxIn, TxOut CtxUTxO)]
  , InitObservation -> HeadId
headId :: HeadId
  , -- XXX: This is cardano-specific, while headId, parties and
    -- contestationPeriod are already generic here. Check which is more
    -- convenient and consistent!
    InitObservation -> TxIn
seedTxIn :: TxIn
  , InitObservation -> ContestationPeriod
contestationPeriod :: ContestationPeriod
  , InitObservation -> [Party]
parties :: [Party]
  , -- XXX: Improve naming
    InitObservation -> [OnChainId]
participants :: [OnChainId]
  }
  deriving stock (Int -> InitObservation -> ShowS
[InitObservation] -> ShowS
InitObservation -> String
(Int -> InitObservation -> ShowS)
-> (InitObservation -> String)
-> ([InitObservation] -> ShowS)
-> Show InitObservation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> InitObservation -> ShowS
showsPrec :: Int -> InitObservation -> ShowS
$cshow :: InitObservation -> String
show :: InitObservation -> String
$cshowList :: [InitObservation] -> ShowS
showList :: [InitObservation] -> ShowS
Show, InitObservation -> InitObservation -> Bool
(InitObservation -> InitObservation -> Bool)
-> (InitObservation -> InitObservation -> Bool)
-> Eq InitObservation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: InitObservation -> InitObservation -> Bool
== :: InitObservation -> InitObservation -> Bool
$c/= :: InitObservation -> InitObservation -> Bool
/= :: InitObservation -> InitObservation -> Bool
Eq, (forall x. InitObservation -> Rep InitObservation x)
-> (forall x. Rep InitObservation x -> InitObservation)
-> Generic InitObservation
forall x. Rep InitObservation x -> InitObservation
forall x. InitObservation -> Rep InitObservation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. InitObservation -> Rep InitObservation x
from :: forall x. InitObservation -> Rep InitObservation x
$cto :: forall x. Rep InitObservation x -> InitObservation
to :: forall x. Rep InitObservation x -> InitObservation
Generic)

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

data NotAnInitReason
  = NoHeadOutput
  | NotAHeadDatum
  | NoSTFound
  | NotAHeadPolicy
  deriving stock (Int -> NotAnInitReason -> ShowS
[NotAnInitReason] -> ShowS
NotAnInitReason -> String
(Int -> NotAnInitReason -> ShowS)
-> (NotAnInitReason -> String)
-> ([NotAnInitReason] -> ShowS)
-> Show NotAnInitReason
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NotAnInitReason -> ShowS
showsPrec :: Int -> NotAnInitReason -> ShowS
$cshow :: NotAnInitReason -> String
show :: NotAnInitReason -> String
$cshowList :: [NotAnInitReason] -> ShowS
showList :: [NotAnInitReason] -> ShowS
Show, NotAnInitReason -> NotAnInitReason -> Bool
(NotAnInitReason -> NotAnInitReason -> Bool)
-> (NotAnInitReason -> NotAnInitReason -> Bool)
-> Eq NotAnInitReason
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NotAnInitReason -> NotAnInitReason -> Bool
== :: NotAnInitReason -> NotAnInitReason -> Bool
$c/= :: NotAnInitReason -> NotAnInitReason -> Bool
/= :: NotAnInitReason -> NotAnInitReason -> Bool
Eq, (forall x. NotAnInitReason -> Rep NotAnInitReason x)
-> (forall x. Rep NotAnInitReason x -> NotAnInitReason)
-> Generic NotAnInitReason
forall x. Rep NotAnInitReason x -> NotAnInitReason
forall x. NotAnInitReason -> Rep NotAnInitReason x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. NotAnInitReason -> Rep NotAnInitReason x
from :: forall x. NotAnInitReason -> Rep NotAnInitReason x
$cto :: forall x. Rep NotAnInitReason x -> NotAnInitReason
to :: forall x. Rep NotAnInitReason x -> NotAnInitReason
Generic)
  deriving anyclass ([NotAnInitReason] -> Value
[NotAnInitReason] -> Encoding
NotAnInitReason -> Bool
NotAnInitReason -> Value
NotAnInitReason -> Encoding
(NotAnInitReason -> Value)
-> (NotAnInitReason -> Encoding)
-> ([NotAnInitReason] -> Value)
-> ([NotAnInitReason] -> Encoding)
-> (NotAnInitReason -> Bool)
-> ToJSON NotAnInitReason
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: NotAnInitReason -> Value
toJSON :: NotAnInitReason -> Value
$ctoEncoding :: NotAnInitReason -> Encoding
toEncoding :: NotAnInitReason -> Encoding
$ctoJSONList :: [NotAnInitReason] -> Value
toJSONList :: [NotAnInitReason] -> Value
$ctoEncodingList :: [NotAnInitReason] -> Encoding
toEncodingList :: [NotAnInitReason] -> Encoding
$comitField :: NotAnInitReason -> Bool
omitField :: NotAnInitReason -> Bool
ToJSON, Maybe NotAnInitReason
Value -> Parser [NotAnInitReason]
Value -> Parser NotAnInitReason
(Value -> Parser NotAnInitReason)
-> (Value -> Parser [NotAnInitReason])
-> Maybe NotAnInitReason
-> FromJSON NotAnInitReason
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser NotAnInitReason
parseJSON :: Value -> Parser NotAnInitReason
$cparseJSONList :: Value -> Parser [NotAnInitReason]
parseJSONList :: Value -> Parser [NotAnInitReason]
$comittedField :: Maybe NotAnInitReason
omittedField :: Maybe NotAnInitReason
FromJSON)

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

-- | Identify a init tx by checking the output value for holding tokens that are
-- valid head tokens (checked by seed + policy).
observeInitTx ::
  Tx ->
  Either NotAnInitReason InitObservation
observeInitTx :: Tx -> Either NotAnInitReason InitObservation
observeInitTx Tx
tx = do
  -- XXX: Lots of redundant information here
  (Word
ix, TxOut CtxTx Era
headOut, State
headState) <-
    NotAnInitReason
-> Maybe (Word, TxOut CtxTx Era, State)
-> Either NotAnInitReason (Word, TxOut CtxTx Era, State)
forall {a} {b}. a -> Maybe b -> Either a b
maybeLeft NotAnInitReason
NoHeadOutput (Maybe (Word, TxOut CtxTx Era, State)
 -> Either NotAnInitReason (Word, TxOut CtxTx Era, State))
-> Maybe (Word, TxOut CtxTx Era, State)
-> Either NotAnInitReason (Word, TxOut CtxTx Era, State)
forall a b. (a -> b) -> a -> b
$
      ((Word, TxOut CtxTx Era) -> Maybe (Word, TxOut CtxTx Era, State))
-> [(Word, TxOut CtxTx Era)]
-> Maybe (Word, TxOut CtxTx Era, State)
forall (t :: * -> *) a b.
Foldable t =>
(a -> Maybe b) -> t a -> Maybe b
findFirst (Word, TxOut CtxTx Era) -> Maybe (Word, TxOut CtxTx Era, State)
forall {a} {t} {era}.
FromData a =>
(t, TxOut CtxTx era) -> Maybe (t, TxOut CtxTx era, a)
matchHeadOutput [(Word, TxOut CtxTx Era)]
indexedOutputs

  -- check that we have a proper head
  (PolicyId
pid, ContestationPeriod
contestationPeriod, [Party]
onChainParties, TxIn
seedTxIn) <- case State
headState of
    (Head.Initial ContestationPeriod
cp [Party]
ps CurrencySymbol
cid TxOutRef
outRef) -> do
      PolicyId
pid <- CurrencySymbol -> Maybe PolicyId
forall (m :: * -> *). MonadFail m => CurrencySymbol -> m PolicyId
fromPlutusCurrencySymbol CurrencySymbol
cid Maybe PolicyId
-> NotAnInitReason -> Either NotAnInitReason PolicyId
forall a e. Maybe a -> e -> Either e a
?> NotAnInitReason
NotAHeadPolicy
      (PolicyId, ContestationPeriod, [Party], TxIn)
-> Either
     NotAnInitReason (PolicyId, ContestationPeriod, [Party], TxIn)
forall a. a -> Either NotAnInitReason a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PolicyId
pid, ContestationPeriod -> ContestationPeriod
fromChain ContestationPeriod
cp, [Party]
ps, TxOutRef -> TxIn
fromPlutusTxOutRef TxOutRef
outRef)
    State
_ -> NotAnInitReason
-> Either
     NotAnInitReason (PolicyId, ContestationPeriod, [Party], TxIn)
forall a b. a -> Either a b
Left NotAnInitReason
NotAHeadDatum

  let stQuantity :: Quantity
stQuantity = Value -> AssetId -> Quantity
selectAsset (TxOut CtxTx Era -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxTx Era
headOut) (PolicyId -> AssetName -> AssetId
AssetId PolicyId
pid AssetName
hydraHeadV1AssetName)

  -- check that ST is present in the head output
  Bool -> Either NotAnInitReason () -> Either NotAnInitReason ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Quantity
stQuantity Quantity -> Quantity -> Bool
forall a. Eq a => a -> a -> Bool
== Quantity
1) (Either NotAnInitReason () -> Either NotAnInitReason ())
-> Either NotAnInitReason () -> Either NotAnInitReason ()
forall a b. (a -> b) -> a -> b
$
    NotAnInitReason -> Either NotAnInitReason ()
forall a b. a -> Either a b
Left NotAnInitReason
NoSTFound

  -- check that we are using the same seed and headId matches
  Bool -> Either NotAnInitReason () -> Either NotAnInitReason ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (PolicyId
pid PolicyId -> PolicyId -> Bool
forall a. Eq a => a -> a -> Bool
== TxIn -> PolicyId
HeadTokens.headPolicyId TxIn
seedTxIn) (Either NotAnInitReason () -> Either NotAnInitReason ())
-> Either NotAnInitReason () -> Either NotAnInitReason ()
forall a b. (a -> b) -> a -> b
$
    NotAnInitReason -> Either NotAnInitReason ()
forall a b. a -> Either a b
Left NotAnInitReason
NotAHeadPolicy

  InitObservation -> Either NotAnInitReason InitObservation
forall a. a -> Either NotAnInitReason a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InitObservation -> Either NotAnInitReason InitObservation)
-> InitObservation -> Either NotAnInitReason InitObservation
forall a b. (a -> b) -> a -> b
$
    InitObservation
      { $sel:headId:InitObservation :: HeadId
headId = PolicyId -> HeadId
mkHeadId PolicyId
pid
      , TxIn
$sel:seedTxIn:InitObservation :: TxIn
seedTxIn :: TxIn
seedTxIn
      , $sel:initialThreadUTxO:InitObservation :: (TxIn, TxOut CtxUTxO)
initialThreadUTxO = (Tx -> Word -> TxIn
forall era. Tx era -> Word -> TxIn
mkTxIn Tx
tx Word
ix, TxOut CtxTx Era -> TxOut CtxUTxO
forall era. TxOut CtxTx era -> TxOut CtxUTxO era
toCtxUTxOTxOut TxOut CtxTx Era
headOut)
      , [(TxIn, TxOut CtxUTxO)]
$sel:initials:InitObservation :: [(TxIn, TxOut CtxUTxO)]
initials :: [(TxIn, TxOut CtxUTxO)]
initials
      , ContestationPeriod
$sel:contestationPeriod:InitObservation :: ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod
      , $sel:parties:InitObservation :: [Party]
parties = (Party -> Maybe Party) -> [Party] -> [Party]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Party -> Maybe Party
forall (m :: * -> *). MonadFail m => Party -> m Party
partyFromChain [Party]
onChainParties
      , $sel:participants:InitObservation :: [OnChainId]
participants = AssetName -> OnChainId
assetNameToOnChainId (AssetName -> OnChainId) -> [AssetName] -> [OnChainId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PolicyId -> [AssetName]
mintedTokenNames PolicyId
pid
      }
 where
  maybeLeft :: a -> Maybe b -> Either a b
maybeLeft a
e = Either a b -> (b -> Either a b) -> Maybe b -> Either a b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (a -> Either a b
forall a b. a -> Either a b
Left a
e) b -> Either a b
forall a b. b -> Either a b
Right

  matchHeadOutput :: (t, TxOut CtxTx era) -> Maybe (t, TxOut CtxTx era, a)
matchHeadOutput (t
ix, TxOut CtxTx era
out) = do
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ PlutusScript PlutusScriptV3 -> TxOut CtxTx era -> Bool
forall lang ctx era.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> TxOut ctx era -> Bool
isScriptTxOut PlutusScript PlutusScriptV3
headScript TxOut CtxTx era
out
    (t
ix,TxOut CtxTx era
out,) (a -> (t, TxOut CtxTx era, a))
-> Maybe a -> Maybe (t, TxOut CtxTx era, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (HashableScriptData -> Maybe a
forall a. FromScriptData a => HashableScriptData -> Maybe a
fromScriptData (HashableScriptData -> Maybe a)
-> Maybe HashableScriptData -> Maybe a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TxOut CtxTx era -> Maybe HashableScriptData
forall era. TxOut CtxTx era -> Maybe HashableScriptData
txOutScriptData TxOut CtxTx era
out)

  headScript :: PlutusScript PlutusScriptV3
headScript = forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript @PlutusScriptV3 SerialisedScript
Head.validatorScript

  indexedOutputs :: [(Word, TxOut CtxTx Era)]
indexedOutputs = [Word] -> [TxOut CtxTx Era] -> [(Word, TxOut CtxTx Era)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Word
0 ..] (Tx -> [TxOut CtxTx Era]
forall era. Tx era -> [TxOut CtxTx era]
txOuts' Tx
tx)

  initialOutputs :: [(Word, TxOut CtxTx Era)]
initialOutputs = ((Word, TxOut CtxTx Era) -> Bool)
-> [(Word, TxOut CtxTx Era)] -> [(Word, TxOut CtxTx Era)]
forall a. (a -> Bool) -> [a] -> [a]
filter (TxOut CtxTx Era -> Bool
forall {ctx} {era}. TxOut ctx era -> Bool
isInitial (TxOut CtxTx Era -> Bool)
-> ((Word, TxOut CtxTx Era) -> TxOut CtxTx Era)
-> (Word, TxOut CtxTx Era)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word, TxOut CtxTx Era) -> TxOut CtxTx Era
forall a b. (a, b) -> b
snd) [(Word, TxOut CtxTx Era)]
indexedOutputs

  initials :: [(TxIn, TxOut CtxUTxO)]
initials =
    ((Word, TxOut CtxTx Era) -> (TxIn, TxOut CtxUTxO))
-> [(Word, TxOut CtxTx Era)] -> [(TxIn, TxOut CtxUTxO)]
forall a b. (a -> b) -> [a] -> [b]
map
      ((Word -> TxIn)
-> (TxOut CtxTx Era -> TxOut CtxUTxO)
-> (Word, TxOut CtxTx Era)
-> (TxIn, TxOut CtxUTxO)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (Tx -> Word -> TxIn
forall era. Tx era -> Word -> TxIn
mkTxIn Tx
tx) TxOut CtxTx Era -> TxOut CtxUTxO
forall era. TxOut CtxTx era -> TxOut CtxUTxO era
toCtxUTxOTxOut)
      [(Word, TxOut CtxTx Era)]
initialOutputs

  isInitial :: TxOut ctx era -> Bool
isInitial = PlutusScript PlutusScriptV3 -> TxOut ctx era -> Bool
forall lang ctx era.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> TxOut ctx era -> Bool
isScriptTxOut PlutusScript PlutusScriptV3
initialScript

  initialScript :: PlutusScript PlutusScriptV3
initialScript = forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript @PlutusScriptV3 SerialisedScript
initialValidatorScript

  mintedTokenNames :: PolicyId -> [AssetName]
mintedTokenNames PolicyId
pid =
    [ AssetName
assetName
    | (AssetId PolicyId
policyId AssetName
assetName, Quantity
q) <- Tx -> [(AssetId, Quantity)]
forall era. Tx era -> [(AssetId, Quantity)]
txMintAssets Tx
tx
    , Quantity
q Quantity -> Quantity -> Bool
forall a. Eq a => a -> a -> Bool
== Quantity
1 -- NOTE: Only consider unique tokens
    , PolicyId
policyId PolicyId -> PolicyId -> Bool
forall a. Eq a => a -> a -> Bool
== PolicyId
pid
    , AssetName
assetName AssetName -> AssetName -> Bool
forall a. Eq a => a -> a -> Bool
/= AssetName
hydraHeadV1AssetName
    ]

-- | Full observation of a commit transaction.
data CommitObservation = CommitObservation
  { CommitObservation -> (TxIn, TxOut CtxUTxO)
commitOutput :: (TxIn, TxOut CtxUTxO)
  , CommitObservation -> Party
party :: Party
  -- ^ Hydra participant who committed the UTxO.
  , CommitObservation -> UTxO
committed :: UTxO
  , CommitObservation -> HeadId
headId :: HeadId
  }
  deriving stock (CommitObservation -> CommitObservation -> Bool
(CommitObservation -> CommitObservation -> Bool)
-> (CommitObservation -> CommitObservation -> Bool)
-> Eq CommitObservation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CommitObservation -> CommitObservation -> Bool
== :: CommitObservation -> CommitObservation -> Bool
$c/= :: CommitObservation -> CommitObservation -> Bool
/= :: CommitObservation -> CommitObservation -> Bool
Eq, Int -> CommitObservation -> ShowS
[CommitObservation] -> ShowS
CommitObservation -> String
(Int -> CommitObservation -> ShowS)
-> (CommitObservation -> String)
-> ([CommitObservation] -> ShowS)
-> Show CommitObservation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CommitObservation -> ShowS
showsPrec :: Int -> CommitObservation -> ShowS
$cshow :: CommitObservation -> String
show :: CommitObservation -> String
$cshowList :: [CommitObservation] -> ShowS
showList :: [CommitObservation] -> ShowS
Show, (forall x. CommitObservation -> Rep CommitObservation x)
-> (forall x. Rep CommitObservation x -> CommitObservation)
-> Generic CommitObservation
forall x. Rep CommitObservation x -> CommitObservation
forall x. CommitObservation -> Rep CommitObservation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CommitObservation -> Rep CommitObservation x
from :: forall x. CommitObservation -> Rep CommitObservation x
$cto :: forall x. Rep CommitObservation x -> CommitObservation
to :: forall x. Rep CommitObservation x -> CommitObservation
Generic)

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

-- | Identify a commit tx by:
--
-- - Check that its spending from the init validator,
-- - Find the outputs which pays to the commit validator,
-- - Using the datum of that output, deserialize the committed output,
-- - Reconstruct the committed UTxO from both values (tx input and output).
observeCommitTx ::
  NetworkId ->
  -- | A UTxO set to lookup tx inputs. Should at least contain the input
  -- spending from νInitial.
  UTxO ->
  Tx ->
  Maybe CommitObservation
observeCommitTx :: NetworkId -> UTxO -> Tx -> Maybe CommitObservation
observeCommitTx NetworkId
networkId UTxO
utxo Tx
tx = do
  -- NOTE: Instead checking to spend from initial we could be looking at the
  -- seed:
  --
  --  - We must check that participation token in output satisfies
  --      policyId = hash(mu_head(seed))
  --
  --  - This allows us to assume (by induction) the output datum at the commit
  --    script is legit
  --
  --  - Further, we need to assert / assume that only one script is spent = onle
  --    one redeemer matches the InitialRedeemer, as we do not have information
  --    which of the inputs is spending from the initial script otherwise.
  --
  --  Right now we only have the headId in the datum, so we use that in place of
  --  the seed -> THIS CAN NOT BE TRUSTED.
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
isSpendingFromInitial

  (TxIn
commitIn, TxOut CtxTx Era
commitOut) <- AddressInEra -> Tx -> Maybe (TxIn, TxOut CtxTx Era)
forall era.
AddressInEra era -> Tx era -> Maybe (TxIn, TxOut CtxTx era)
findTxOutByAddress AddressInEra
commitAddress Tx
tx
  HashableScriptData
dat <- TxOut CtxTx Era -> Maybe HashableScriptData
forall era. TxOut CtxTx era -> Maybe HashableScriptData
txOutScriptData TxOut CtxTx Era
commitOut
  (Party
onChainParty, [Commit]
onChainCommits, CurrencySymbol
headId) :: Commit.DatumType <- HashableScriptData -> Maybe DatumType
forall a. FromScriptData a => HashableScriptData -> Maybe a
fromScriptData HashableScriptData
dat
  Party
party <- Party -> Maybe Party
forall (m :: * -> *). MonadFail m => Party -> m Party
partyFromChain Party
onChainParty

  -- NOTE: If we have the resolved inputs (utxo) then we could avoid putting
  -- the commit into the datum (+ changing the hashing strategy of
  -- collect/fanout)
  UTxO
committed <- do
    [(TxIn, TxOut CtxUTxO)]
committedUTxO <- (Commit -> Maybe (TxIn, TxOut CtxUTxO))
-> [Commit] -> Maybe [(TxIn, TxOut CtxUTxO)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Network -> Commit -> Maybe (TxIn, TxOut CtxUTxO)
Commit.deserializeCommit (NetworkId -> Network
networkIdToNetwork NetworkId
networkId)) [Commit]
onChainCommits
    UTxO -> Maybe UTxO
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTxO -> Maybe UTxO)
-> ([(TxIn, TxOut CtxUTxO)] -> UTxO)
-> [(TxIn, TxOut CtxUTxO)]
-> Maybe UTxO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(TxIn, TxOut CtxUTxO)] -> UTxO
forall out. [(TxIn, out)] -> UTxO' out
UTxO.fromPairs ([(TxIn, TxOut CtxUTxO)] -> Maybe UTxO)
-> [(TxIn, TxOut CtxUTxO)] -> Maybe UTxO
forall a b. (a -> b) -> a -> b
$ [(TxIn, TxOut CtxUTxO)]
committedUTxO

  PolicyId
policyId <- CurrencySymbol -> Maybe PolicyId
forall (m :: * -> *). MonadFail m => CurrencySymbol -> m PolicyId
fromPlutusCurrencySymbol CurrencySymbol
headId
  CommitObservation -> Maybe CommitObservation
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    CommitObservation
      { $sel:commitOutput:CommitObservation :: (TxIn, TxOut CtxUTxO)
commitOutput = (TxIn
commitIn, TxOut CtxTx Era -> TxOut CtxUTxO
forall era. TxOut CtxTx era -> TxOut CtxUTxO era
forall {k} (f :: * -> k -> *) (era :: k).
ToUTxOContext f =>
f CtxTx era -> f CtxUTxO era
toUTxOContext TxOut CtxTx Era
commitOut)
      , Party
$sel:party:CommitObservation :: Party
party :: Party
party
      , UTxO
$sel:committed:CommitObservation :: UTxO
committed :: UTxO
committed
      , $sel:headId:CommitObservation :: HeadId
headId = PolicyId -> HeadId
mkHeadId PolicyId
policyId
      }
 where
  isSpendingFromInitial :: Bool
  isSpendingFromInitial :: Bool
isSpendingFromInitial =
    (TxOut CtxUTxO -> Bool) -> UTxO -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\TxOut CtxUTxO
o -> TxOut CtxUTxO -> AddressInEra
forall ctx. TxOut ctx -> AddressInEra
txOutAddress TxOut CtxUTxO
o AddressInEra -> AddressInEra -> Bool
forall a. Eq a => a -> a -> Bool
== AddressInEra
initialAddress) (UTxO -> Tx -> UTxO
resolveInputsUTxO UTxO
utxo Tx
tx)

  initialAddress :: AddressInEra
initialAddress = forall lang era.
(IsShelleyBasedEra era, IsPlutusScriptLanguage lang) =>
NetworkId -> PlutusScript lang -> AddressInEra era
mkScriptAddress @PlutusScriptV3 NetworkId
networkId PlutusScript PlutusScriptV3
initialScript

  initialScript :: PlutusScript PlutusScriptV3
initialScript = forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript @PlutusScriptV3 SerialisedScript
initialValidatorScript

  commitAddress :: AddressInEra
commitAddress = NetworkId -> PlutusScript PlutusScriptV3 -> AddressInEra
forall lang era.
(IsShelleyBasedEra era, IsPlutusScriptLanguage lang) =>
NetworkId -> PlutusScript lang -> AddressInEra era
mkScriptAddress NetworkId
networkId PlutusScript PlutusScriptV3
commitScript

  commitScript :: PlutusScript PlutusScriptV3
commitScript = forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript @PlutusScriptV3 SerialisedScript
commitValidatorScript

data CollectComObservation = CollectComObservation
  { CollectComObservation -> OpenThreadOutput
threadOutput :: OpenThreadOutput
  , CollectComObservation -> HeadId
headId :: HeadId
  , CollectComObservation -> UTxOHash
utxoHash :: UTxOHash
  }
  deriving stock (Int -> CollectComObservation -> ShowS
[CollectComObservation] -> ShowS
CollectComObservation -> String
(Int -> CollectComObservation -> ShowS)
-> (CollectComObservation -> String)
-> ([CollectComObservation] -> ShowS)
-> Show CollectComObservation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CollectComObservation -> ShowS
showsPrec :: Int -> CollectComObservation -> ShowS
$cshow :: CollectComObservation -> String
show :: CollectComObservation -> String
$cshowList :: [CollectComObservation] -> ShowS
showList :: [CollectComObservation] -> ShowS
Show, CollectComObservation -> CollectComObservation -> Bool
(CollectComObservation -> CollectComObservation -> Bool)
-> (CollectComObservation -> CollectComObservation -> Bool)
-> Eq CollectComObservation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CollectComObservation -> CollectComObservation -> Bool
== :: CollectComObservation -> CollectComObservation -> Bool
$c/= :: CollectComObservation -> CollectComObservation -> Bool
/= :: CollectComObservation -> CollectComObservation -> Bool
Eq, (forall x. CollectComObservation -> Rep CollectComObservation x)
-> (forall x. Rep CollectComObservation x -> CollectComObservation)
-> Generic CollectComObservation
forall x. Rep CollectComObservation x -> CollectComObservation
forall x. CollectComObservation -> Rep CollectComObservation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CollectComObservation -> Rep CollectComObservation x
from :: forall x. CollectComObservation -> Rep CollectComObservation x
$cto :: forall x. Rep CollectComObservation x -> CollectComObservation
to :: forall x. Rep CollectComObservation x -> CollectComObservation
Generic)

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

-- | Identify a collectCom tx by lookup up the input spending the Head output
-- and decoding its redeemer.
observeCollectComTx ::
  -- | A UTxO set to lookup tx inputs
  UTxO ->
  Tx ->
  Maybe CollectComObservation
observeCollectComTx :: UTxO -> Tx -> Maybe CollectComObservation
observeCollectComTx UTxO
utxo Tx
tx = do
  let inputUTxO :: UTxO
inputUTxO = UTxO -> Tx -> UTxO
resolveInputsUTxO UTxO
utxo Tx
tx
  (TxIn
headInput, TxOut CtxUTxO
headOutput) <- forall lang.
IsPlutusScriptLanguage lang =>
UTxO -> PlutusScript lang -> Maybe (TxIn, TxOut CtxUTxO)
findTxOutByScript @PlutusScriptV3 UTxO
inputUTxO PlutusScript PlutusScriptV3
forall {lang}. PlutusScript lang
headScript
  Input
redeemer <- Tx -> TxIn -> Maybe Input
forall a. FromData a => Tx -> TxIn -> Maybe a
findRedeemerSpending Tx
tx TxIn
headInput
  HashableScriptData
oldHeadDatum <- TxOut CtxTx Era -> Maybe HashableScriptData
forall era. TxOut CtxTx era -> Maybe HashableScriptData
txOutScriptData (TxOut CtxTx Era -> Maybe HashableScriptData)
-> TxOut CtxTx Era -> Maybe HashableScriptData
forall a b. (a -> b) -> a -> b
$ TxOut CtxUTxO -> TxOut CtxTx Era
forall era. TxOut CtxUTxO era -> TxOut CtxTx era
forall {k} (f :: * -> k -> *) (era :: k).
ToTxContext f =>
f CtxUTxO era -> f CtxTx era
toTxContext TxOut CtxUTxO
headOutput
  State
datum <- HashableScriptData -> Maybe State
forall a. FromScriptData a => HashableScriptData -> Maybe a
fromScriptData HashableScriptData
oldHeadDatum
  HeadId
headId <- TxOut CtxUTxO -> Maybe HeadId
forall ctx. TxOut ctx -> Maybe HeadId
findStateToken TxOut CtxUTxO
headOutput
  case (State
datum, Input
redeemer) of
    (Head.Initial{[Party]
parties :: [Party]
$sel:parties:Initial :: State -> [Party]
parties, ContestationPeriod
contestationPeriod :: ContestationPeriod
$sel:contestationPeriod:Initial :: State -> ContestationPeriod
contestationPeriod}, Input
Head.CollectCom) -> do
      (TxIn
newHeadInput, TxOut CtxUTxO
newHeadOutput) <- forall lang.
IsPlutusScriptLanguage lang =>
UTxO -> PlutusScript lang -> Maybe (TxIn, TxOut CtxUTxO)
findTxOutByScript @PlutusScriptV3 (Tx -> UTxO
utxoFromTx Tx
tx) PlutusScript PlutusScriptV3
forall {lang}. PlutusScript lang
headScript
      HashableScriptData
newHeadDatum <- TxOut CtxTx Era -> Maybe HashableScriptData
forall era. TxOut CtxTx era -> Maybe HashableScriptData
txOutScriptData (TxOut CtxTx Era -> Maybe HashableScriptData)
-> TxOut CtxTx Era -> Maybe HashableScriptData
forall a b. (a -> b) -> a -> b
$ TxOut CtxUTxO -> TxOut CtxTx Era
forall era. TxOut CtxUTxO era -> TxOut CtxTx era
forall {k} (f :: * -> k -> *) (era :: k).
ToTxContext f =>
f CtxUTxO era -> f CtxTx era
toTxContext TxOut CtxUTxO
newHeadOutput
      UTxOHash
utxoHash <- ByteString -> UTxOHash
UTxOHash (ByteString -> UTxOHash) -> Maybe ByteString -> Maybe UTxOHash
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashableScriptData -> Maybe ByteString
decodeUtxoHash HashableScriptData
newHeadDatum
      CollectComObservation -> Maybe CollectComObservation
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        CollectComObservation
          { $sel:threadOutput:CollectComObservation :: OpenThreadOutput
threadOutput =
              OpenThreadOutput
                { $sel:openThreadUTxO:OpenThreadOutput :: (TxIn, TxOut CtxUTxO)
openThreadUTxO = (TxIn
newHeadInput, TxOut CtxUTxO
newHeadOutput)
                , $sel:openParties:OpenThreadOutput :: [Party]
openParties = [Party]
parties
                , $sel:openContestationPeriod:OpenThreadOutput :: ContestationPeriod
openContestationPeriod = ContestationPeriod
contestationPeriod
                }
          , HeadId
$sel:headId:CollectComObservation :: HeadId
headId :: HeadId
headId
          , UTxOHash
$sel:utxoHash:CollectComObservation :: UTxOHash
utxoHash :: UTxOHash
utxoHash
          }
    (State, Input)
_ -> Maybe CollectComObservation
forall a. Maybe a
Nothing
 where
  headScript :: PlutusScript lang
headScript = SerialisedScript -> PlutusScript lang
forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript SerialisedScript
Head.validatorScript
  decodeUtxoHash :: HashableScriptData -> Maybe ByteString
decodeUtxoHash HashableScriptData
datum =
    case HashableScriptData -> Maybe State
forall a. FromScriptData a => HashableScriptData -> Maybe a
fromScriptData HashableScriptData
datum of
      Just (Head.Open Head.OpenDatum{Hash
utxoHash :: Hash
$sel:utxoHash:OpenDatum :: OpenDatum -> Hash
utxoHash}) -> ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Hash -> FromBuiltin Hash
forall arep. HasFromBuiltin arep => arep -> FromBuiltin arep
fromBuiltin Hash
utxoHash
      Maybe State
_ -> Maybe ByteString
forall a. Maybe a
Nothing

data IncrementObservation = IncrementObservation
  { IncrementObservation -> HeadId
headId :: HeadId
  , IncrementObservation -> SnapshotVersion
newVersion :: SnapshotVersion
  , IncrementObservation -> TxId
depositTxId :: TxId
  }
  deriving stock (Int -> IncrementObservation -> ShowS
[IncrementObservation] -> ShowS
IncrementObservation -> String
(Int -> IncrementObservation -> ShowS)
-> (IncrementObservation -> String)
-> ([IncrementObservation] -> ShowS)
-> Show IncrementObservation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IncrementObservation -> ShowS
showsPrec :: Int -> IncrementObservation -> ShowS
$cshow :: IncrementObservation -> String
show :: IncrementObservation -> String
$cshowList :: [IncrementObservation] -> ShowS
showList :: [IncrementObservation] -> ShowS
Show, IncrementObservation -> IncrementObservation -> Bool
(IncrementObservation -> IncrementObservation -> Bool)
-> (IncrementObservation -> IncrementObservation -> Bool)
-> Eq IncrementObservation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: IncrementObservation -> IncrementObservation -> Bool
== :: IncrementObservation -> IncrementObservation -> Bool
$c/= :: IncrementObservation -> IncrementObservation -> Bool
/= :: IncrementObservation -> IncrementObservation -> Bool
Eq, (forall x. IncrementObservation -> Rep IncrementObservation x)
-> (forall x. Rep IncrementObservation x -> IncrementObservation)
-> Generic IncrementObservation
forall x. Rep IncrementObservation x -> IncrementObservation
forall x. IncrementObservation -> Rep IncrementObservation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. IncrementObservation -> Rep IncrementObservation x
from :: forall x. IncrementObservation -> Rep IncrementObservation x
$cto :: forall x. Rep IncrementObservation x -> IncrementObservation
to :: forall x. Rep IncrementObservation x -> IncrementObservation
Generic)

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

observeIncrementTx ::
  UTxO ->
  Tx ->
  Maybe IncrementObservation
observeIncrementTx :: UTxO -> Tx -> Maybe IncrementObservation
observeIncrementTx UTxO
utxo Tx
tx = do
  let inputUTxO :: UTxO
inputUTxO = UTxO -> Tx -> UTxO
resolveInputsUTxO UTxO
utxo Tx
tx
  (TxIn
headInput, TxOut CtxUTxO
headOutput) <- forall lang.
IsPlutusScriptLanguage lang =>
UTxO -> PlutusScript lang -> Maybe (TxIn, TxOut CtxUTxO)
findTxOutByScript @PlutusScriptV3 UTxO
inputUTxO PlutusScript PlutusScriptV3
forall {lang}. PlutusScript lang
headScript
  (TxIn TxId
depositTxId TxIx
_, TxOut CtxUTxO
depositOutput) <- forall lang.
IsPlutusScriptLanguage lang =>
UTxO -> PlutusScript lang -> Maybe (TxIn, TxOut CtxUTxO)
findTxOutByScript @PlutusScriptV3 UTxO
utxo PlutusScript PlutusScriptV3
forall {lang}. PlutusScript lang
depositScript
  HashableScriptData
dat <- TxOut CtxTx Era -> Maybe HashableScriptData
forall era. TxOut CtxTx era -> Maybe HashableScriptData
txOutScriptData (TxOut CtxTx Era -> Maybe HashableScriptData)
-> TxOut CtxTx Era -> Maybe HashableScriptData
forall a b. (a -> b) -> a -> b
$ TxOut CtxUTxO -> TxOut CtxTx Era
forall era. TxOut CtxUTxO era -> TxOut CtxTx era
forall {k} (f :: * -> k -> *) (era :: k).
ToTxContext f =>
f CtxUTxO era -> f CtxTx era
toTxContext TxOut CtxUTxO
depositOutput
  Deposit.DepositDatum (CurrencySymbol, POSIXTime, [Commit])
_ <- HashableScriptData -> Maybe DepositDatum
forall a. FromScriptData a => HashableScriptData -> Maybe a
fromScriptData HashableScriptData
dat
  Input
redeemer <- Tx -> TxIn -> Maybe Input
forall a. FromData a => Tx -> TxIn -> Maybe a
findRedeemerSpending Tx
tx TxIn
headInput
  HashableScriptData
oldHeadDatum <- TxOut CtxTx Era -> Maybe HashableScriptData
forall era. TxOut CtxTx era -> Maybe HashableScriptData
txOutScriptData (TxOut CtxTx Era -> Maybe HashableScriptData)
-> TxOut CtxTx Era -> Maybe HashableScriptData
forall a b. (a -> b) -> a -> b
$ TxOut CtxUTxO -> TxOut CtxTx Era
forall era. TxOut CtxUTxO era -> TxOut CtxTx era
forall {k} (f :: * -> k -> *) (era :: k).
ToTxContext f =>
f CtxUTxO era -> f CtxTx era
toTxContext TxOut CtxUTxO
headOutput
  State
datum <- HashableScriptData -> Maybe State
forall a. FromScriptData a => HashableScriptData -> Maybe a
fromScriptData HashableScriptData
oldHeadDatum
  HeadId
headId <- TxOut CtxUTxO -> Maybe HeadId
forall ctx. TxOut ctx -> Maybe HeadId
findStateToken TxOut CtxUTxO
headOutput
  case (State
datum, Input
redeemer) of
    (Head.Open{}, Head.Increment Head.IncrementRedeemer{}) -> do
      (TxIn
_, TxOut CtxUTxO
newHeadOutput) <- forall lang.
IsPlutusScriptLanguage lang =>
UTxO -> PlutusScript lang -> Maybe (TxIn, TxOut CtxUTxO)
findTxOutByScript @PlutusScriptV3 (Tx -> UTxO
utxoFromTx Tx
tx) PlutusScript PlutusScriptV3
forall {lang}. PlutusScript lang
headScript
      HashableScriptData
newHeadDatum <- TxOut CtxTx Era -> Maybe HashableScriptData
forall era. TxOut CtxTx era -> Maybe HashableScriptData
txOutScriptData (TxOut CtxTx Era -> Maybe HashableScriptData)
-> TxOut CtxTx Era -> Maybe HashableScriptData
forall a b. (a -> b) -> a -> b
$ TxOut CtxUTxO -> TxOut CtxTx Era
forall era. TxOut CtxUTxO era -> TxOut CtxTx era
forall {k} (f :: * -> k -> *) (era :: k).
ToTxContext f =>
f CtxUTxO era -> f CtxTx era
toTxContext TxOut CtxUTxO
newHeadOutput
      case HashableScriptData -> Maybe State
forall a. FromScriptData a => HashableScriptData -> Maybe a
fromScriptData HashableScriptData
newHeadDatum of
        Just (Head.Open Head.OpenDatum{Integer
version :: Integer
$sel:version:OpenDatum :: OpenDatum -> Integer
version}) ->
          IncrementObservation -> Maybe IncrementObservation
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
            IncrementObservation
              { HeadId
$sel:headId:IncrementObservation :: HeadId
headId :: HeadId
headId
              , $sel:newVersion:IncrementObservation :: SnapshotVersion
newVersion = Integer -> SnapshotVersion
fromChainSnapshotVersion Integer
version
              , TxId
$sel:depositTxId:IncrementObservation :: TxId
depositTxId :: TxId
depositTxId
              }
        Maybe State
_ -> Maybe IncrementObservation
forall a. Maybe a
Nothing
    (State, Input)
_ -> Maybe IncrementObservation
forall a. Maybe a
Nothing
 where
  depositScript :: PlutusScript lang
depositScript = SerialisedScript -> PlutusScript lang
forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript SerialisedScript
Deposit.validatorScript
  headScript :: PlutusScript lang
headScript = SerialisedScript -> PlutusScript lang
forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript SerialisedScript
Head.validatorScript

data DecrementObservation = DecrementObservation
  { DecrementObservation -> HeadId
headId :: HeadId
  , DecrementObservation -> SnapshotVersion
newVersion :: SnapshotVersion
  , DecrementObservation -> [TxOut CtxUTxO]
distributedOutputs :: [TxOut CtxUTxO]
  }
  deriving stock (Int -> DecrementObservation -> ShowS
[DecrementObservation] -> ShowS
DecrementObservation -> String
(Int -> DecrementObservation -> ShowS)
-> (DecrementObservation -> String)
-> ([DecrementObservation] -> ShowS)
-> Show DecrementObservation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DecrementObservation -> ShowS
showsPrec :: Int -> DecrementObservation -> ShowS
$cshow :: DecrementObservation -> String
show :: DecrementObservation -> String
$cshowList :: [DecrementObservation] -> ShowS
showList :: [DecrementObservation] -> ShowS
Show, DecrementObservation -> DecrementObservation -> Bool
(DecrementObservation -> DecrementObservation -> Bool)
-> (DecrementObservation -> DecrementObservation -> Bool)
-> Eq DecrementObservation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DecrementObservation -> DecrementObservation -> Bool
== :: DecrementObservation -> DecrementObservation -> Bool
$c/= :: DecrementObservation -> DecrementObservation -> Bool
/= :: DecrementObservation -> DecrementObservation -> Bool
Eq, (forall x. DecrementObservation -> Rep DecrementObservation x)
-> (forall x. Rep DecrementObservation x -> DecrementObservation)
-> Generic DecrementObservation
forall x. Rep DecrementObservation x -> DecrementObservation
forall x. DecrementObservation -> Rep DecrementObservation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. DecrementObservation -> Rep DecrementObservation x
from :: forall x. DecrementObservation -> Rep DecrementObservation x
$cto :: forall x. Rep DecrementObservation x -> DecrementObservation
to :: forall x. Rep DecrementObservation x -> DecrementObservation
Generic)

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

observeDecrementTx ::
  UTxO ->
  Tx ->
  Maybe DecrementObservation
observeDecrementTx :: UTxO -> Tx -> Maybe DecrementObservation
observeDecrementTx UTxO
utxo Tx
tx = do
  let inputUTxO :: UTxO
inputUTxO = UTxO -> Tx -> UTxO
resolveInputsUTxO UTxO
utxo Tx
tx
  (TxIn
headInput, TxOut CtxUTxO
headOutput) <- forall lang.
IsPlutusScriptLanguage lang =>
UTxO -> PlutusScript lang -> Maybe (TxIn, TxOut CtxUTxO)
findTxOutByScript @PlutusScriptV3 UTxO
inputUTxO PlutusScript PlutusScriptV3
forall {lang}. PlutusScript lang
headScript
  Input
redeemer <- Tx -> TxIn -> Maybe Input
forall a. FromData a => Tx -> TxIn -> Maybe a
findRedeemerSpending Tx
tx TxIn
headInput
  HashableScriptData
oldHeadDatum <- TxOut CtxTx Era -> Maybe HashableScriptData
forall era. TxOut CtxTx era -> Maybe HashableScriptData
txOutScriptData (TxOut CtxTx Era -> Maybe HashableScriptData)
-> TxOut CtxTx Era -> Maybe HashableScriptData
forall a b. (a -> b) -> a -> b
$ TxOut CtxUTxO -> TxOut CtxTx Era
forall era. TxOut CtxUTxO era -> TxOut CtxTx era
forall {k} (f :: * -> k -> *) (era :: k).
ToTxContext f =>
f CtxUTxO era -> f CtxTx era
toTxContext TxOut CtxUTxO
headOutput
  State
datum <- HashableScriptData -> Maybe State
forall a. FromScriptData a => HashableScriptData -> Maybe a
fromScriptData HashableScriptData
oldHeadDatum
  HeadId
headId <- TxOut CtxUTxO -> Maybe HeadId
forall ctx. TxOut ctx -> Maybe HeadId
findStateToken TxOut CtxUTxO
headOutput
  case (State
datum, Input
redeemer) of
    (Head.Open{}, Head.Decrement Head.DecrementRedeemer{Integer
numberOfDecommitOutputs :: Integer
$sel:numberOfDecommitOutputs:DecrementRedeemer :: DecrementRedeemer -> Integer
numberOfDecommitOutputs}) -> do
      (TxIn
_, TxOut CtxUTxO
newHeadOutput) <- forall lang.
IsPlutusScriptLanguage lang =>
UTxO -> PlutusScript lang -> Maybe (TxIn, TxOut CtxUTxO)
findTxOutByScript @PlutusScriptV3 (Tx -> UTxO
utxoFromTx Tx
tx) PlutusScript PlutusScriptV3
forall {lang}. PlutusScript lang
headScript
      HashableScriptData
newHeadDatum <- TxOut CtxTx Era -> Maybe HashableScriptData
forall era. TxOut CtxTx era -> Maybe HashableScriptData
txOutScriptData (TxOut CtxTx Era -> Maybe HashableScriptData)
-> TxOut CtxTx Era -> Maybe HashableScriptData
forall a b. (a -> b) -> a -> b
$ TxOut CtxUTxO -> TxOut CtxTx Era
forall era. TxOut CtxUTxO era -> TxOut CtxTx era
forall {k} (f :: * -> k -> *) (era :: k).
ToTxContext f =>
f CtxUTxO era -> f CtxTx era
toTxContext TxOut CtxUTxO
newHeadOutput
      case HashableScriptData -> Maybe State
forall a. FromScriptData a => HashableScriptData -> Maybe a
fromScriptData HashableScriptData
newHeadDatum of
        Just (Head.Open Head.OpenDatum{Integer
$sel:version:OpenDatum :: OpenDatum -> Integer
version :: Integer
version}) ->
          DecrementObservation -> Maybe DecrementObservation
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
            DecrementObservation
              { HeadId
$sel:headId:DecrementObservation :: HeadId
headId :: HeadId
headId
              , $sel:newVersion:DecrementObservation :: SnapshotVersion
newVersion = Integer -> SnapshotVersion
fromChainSnapshotVersion Integer
version
              , $sel:distributedOutputs:DecrementObservation :: [TxOut CtxUTxO]
distributedOutputs =
                  TxOut CtxTx Era -> TxOut CtxUTxO
forall era. TxOut CtxTx era -> TxOut CtxUTxO era
forall {k} (f :: * -> k -> *) (era :: k).
ToUTxOContext f =>
f CtxTx era -> f CtxUTxO era
toUTxOContext (TxOut CtxTx Era -> TxOut CtxUTxO)
-> [TxOut CtxTx Era] -> [TxOut CtxUTxO]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tx -> [TxOut CtxTx Era]
forall era. Tx era -> [TxOut CtxTx era]
txOuts' Tx
tx
                    [TxOut CtxUTxO]
-> ([TxOut CtxUTxO] -> [TxOut CtxUTxO]) -> [TxOut CtxUTxO]
forall a b. a -> (a -> b) -> b
& Int -> [TxOut CtxUTxO] -> [TxOut CtxUTxO]
forall a. Int -> [a] -> [a]
drop Int
1 -- NOTE: Head output must be in first position
                    [TxOut CtxUTxO]
-> ([TxOut CtxUTxO] -> [TxOut CtxUTxO]) -> [TxOut CtxUTxO]
forall a b. a -> (a -> b) -> b
& Int -> [TxOut CtxUTxO] -> [TxOut CtxUTxO]
forall a. Int -> [a] -> [a]
take (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
numberOfDecommitOutputs)
              }
        Maybe State
_ -> Maybe DecrementObservation
forall a. Maybe a
Nothing
    (State, Input)
_ -> Maybe DecrementObservation
forall a. Maybe a
Nothing
 where
  headScript :: PlutusScript lang
headScript = SerialisedScript -> PlutusScript lang
forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript SerialisedScript
Head.validatorScript

data CloseObservation = CloseObservation
  { CloseObservation -> ClosedThreadOutput
threadOutput :: ClosedThreadOutput
  , CloseObservation -> HeadId
headId :: HeadId
  , CloseObservation -> SnapshotNumber
snapshotNumber :: SnapshotNumber
  }
  deriving stock (Int -> CloseObservation -> ShowS
[CloseObservation] -> ShowS
CloseObservation -> String
(Int -> CloseObservation -> ShowS)
-> (CloseObservation -> String)
-> ([CloseObservation] -> ShowS)
-> Show CloseObservation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CloseObservation -> ShowS
showsPrec :: Int -> CloseObservation -> ShowS
$cshow :: CloseObservation -> String
show :: CloseObservation -> String
$cshowList :: [CloseObservation] -> ShowS
showList :: [CloseObservation] -> ShowS
Show, CloseObservation -> CloseObservation -> Bool
(CloseObservation -> CloseObservation -> Bool)
-> (CloseObservation -> CloseObservation -> Bool)
-> Eq CloseObservation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CloseObservation -> CloseObservation -> Bool
== :: CloseObservation -> CloseObservation -> Bool
$c/= :: CloseObservation -> CloseObservation -> Bool
/= :: CloseObservation -> CloseObservation -> Bool
Eq, (forall x. CloseObservation -> Rep CloseObservation x)
-> (forall x. Rep CloseObservation x -> CloseObservation)
-> Generic CloseObservation
forall x. Rep CloseObservation x -> CloseObservation
forall x. CloseObservation -> Rep CloseObservation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CloseObservation -> Rep CloseObservation x
from :: forall x. CloseObservation -> Rep CloseObservation x
$cto :: forall x. Rep CloseObservation x -> CloseObservation
to :: forall x. Rep CloseObservation x -> CloseObservation
Generic)

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

-- | Identify a close tx by lookup up the input spending the Head output and
-- decoding its redeemer.
observeCloseTx ::
  -- | A UTxO set to lookup tx inputs
  UTxO ->
  Tx ->
  Maybe CloseObservation
observeCloseTx :: UTxO -> Tx -> Maybe CloseObservation
observeCloseTx UTxO
utxo Tx
tx = do
  let inputUTxO :: UTxO
inputUTxO = UTxO -> Tx -> UTxO
resolveInputsUTxO UTxO
utxo Tx
tx
  (TxIn
headInput, TxOut CtxUTxO
headOutput) <- forall lang.
IsPlutusScriptLanguage lang =>
UTxO -> PlutusScript lang -> Maybe (TxIn, TxOut CtxUTxO)
findTxOutByScript @PlutusScriptV3 UTxO
inputUTxO PlutusScript PlutusScriptV3
forall {lang}. PlutusScript lang
headScript
  Input
redeemer <- Tx -> TxIn -> Maybe Input
forall a. FromData a => Tx -> TxIn -> Maybe a
findRedeemerSpending Tx
tx TxIn
headInput
  HashableScriptData
oldHeadDatum <- TxOut CtxTx Era -> Maybe HashableScriptData
forall era. TxOut CtxTx era -> Maybe HashableScriptData
txOutScriptData (TxOut CtxTx Era -> Maybe HashableScriptData)
-> TxOut CtxTx Era -> Maybe HashableScriptData
forall a b. (a -> b) -> a -> b
$ TxOut CtxUTxO -> TxOut CtxTx Era
forall era. TxOut CtxUTxO era -> TxOut CtxTx era
forall {k} (f :: * -> k -> *) (era :: k).
ToTxContext f =>
f CtxUTxO era -> f CtxTx era
toTxContext TxOut CtxUTxO
headOutput
  State
datum <- HashableScriptData -> Maybe State
forall a. FromScriptData a => HashableScriptData -> Maybe a
fromScriptData HashableScriptData
oldHeadDatum
  HeadId
headId <- TxOut CtxUTxO -> Maybe HeadId
forall ctx. TxOut ctx -> Maybe HeadId
findStateToken TxOut CtxUTxO
headOutput
  case (State
datum, Input
redeemer) of
    (Head.Open Head.OpenDatum{[Party]
parties :: [Party]
$sel:parties:OpenDatum :: OpenDatum -> [Party]
parties}, Head.Close{}) -> do
      (TxIn
newHeadInput, TxOut CtxUTxO
newHeadOutput) <- forall lang.
IsPlutusScriptLanguage lang =>
UTxO -> PlutusScript lang -> Maybe (TxIn, TxOut CtxUTxO)
findTxOutByScript @PlutusScriptV3 (Tx -> UTxO
utxoFromTx Tx
tx) PlutusScript PlutusScriptV3
forall {lang}. PlutusScript lang
headScript
      HashableScriptData
newHeadDatum <- TxOut CtxTx Era -> Maybe HashableScriptData
forall era. TxOut CtxTx era -> Maybe HashableScriptData
txOutScriptData (TxOut CtxTx Era -> Maybe HashableScriptData)
-> TxOut CtxTx Era -> Maybe HashableScriptData
forall a b. (a -> b) -> a -> b
$ TxOut CtxUTxO -> TxOut CtxTx Era
forall era. TxOut CtxUTxO era -> TxOut CtxTx era
forall {k} (f :: * -> k -> *) (era :: k).
ToTxContext f =>
f CtxUTxO era -> f CtxTx era
toTxContext TxOut CtxUTxO
newHeadOutput
      (POSIXTime
closeContestationDeadline, Integer
onChainSnapshotNumber) <- case HashableScriptData -> Maybe State
forall a. FromScriptData a => HashableScriptData -> Maybe a
fromScriptData HashableScriptData
newHeadDatum of
        Just (Head.Closed Head.ClosedDatum{POSIXTime
contestationDeadline :: POSIXTime
$sel:contestationDeadline:ClosedDatum :: ClosedDatum -> POSIXTime
contestationDeadline, Integer
snapshotNumber :: Integer
$sel:snapshotNumber:ClosedDatum :: ClosedDatum -> Integer
snapshotNumber}) ->
          (POSIXTime, Integer) -> Maybe (POSIXTime, Integer)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (POSIXTime
contestationDeadline, Integer
snapshotNumber)
        Maybe State
_ -> Maybe (POSIXTime, Integer)
forall a. Maybe a
Nothing
      CloseObservation -> Maybe CloseObservation
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        CloseObservation
          { $sel:threadOutput:CloseObservation :: ClosedThreadOutput
threadOutput =
              ClosedThreadOutput
                { $sel:closedThreadUTxO:ClosedThreadOutput :: (TxIn, TxOut CtxUTxO)
closedThreadUTxO = (TxIn
newHeadInput, TxOut CtxUTxO
newHeadOutput)
                , $sel:closedParties:ClosedThreadOutput :: [Party]
closedParties = [Party]
parties
                , $sel:closedContestationDeadline:ClosedThreadOutput :: POSIXTime
closedContestationDeadline = POSIXTime
closeContestationDeadline
                , $sel:closedContesters:ClosedThreadOutput :: [PubKeyHash]
closedContesters = []
                }
          , HeadId
$sel:headId:CloseObservation :: HeadId
headId :: HeadId
headId
          , $sel:snapshotNumber:CloseObservation :: SnapshotNumber
snapshotNumber = Integer -> SnapshotNumber
fromChainSnapshotNumber Integer
onChainSnapshotNumber
          }
    (State, Input)
_ -> Maybe CloseObservation
forall a. Maybe a
Nothing
 where
  headScript :: PlutusScript lang
headScript = SerialisedScript -> PlutusScript lang
forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript SerialisedScript
Head.validatorScript

data ContestObservation = ContestObservation
  { ContestObservation -> (TxIn, TxOut CtxUTxO)
contestedThreadOutput :: (TxIn, TxOut CtxUTxO)
  , ContestObservation -> HeadId
headId :: HeadId
  , ContestObservation -> SnapshotNumber
snapshotNumber :: SnapshotNumber
  , ContestObservation -> UTCTime
contestationDeadline :: UTCTime
  , ContestObservation -> [PubKeyHash]
contesters :: [Plutus.PubKeyHash]
  }
  deriving stock (Int -> ContestObservation -> ShowS
[ContestObservation] -> ShowS
ContestObservation -> String
(Int -> ContestObservation -> ShowS)
-> (ContestObservation -> String)
-> ([ContestObservation] -> ShowS)
-> Show ContestObservation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ContestObservation -> ShowS
showsPrec :: Int -> ContestObservation -> ShowS
$cshow :: ContestObservation -> String
show :: ContestObservation -> String
$cshowList :: [ContestObservation] -> ShowS
showList :: [ContestObservation] -> ShowS
Show, ContestObservation -> ContestObservation -> Bool
(ContestObservation -> ContestObservation -> Bool)
-> (ContestObservation -> ContestObservation -> Bool)
-> Eq ContestObservation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ContestObservation -> ContestObservation -> Bool
== :: ContestObservation -> ContestObservation -> Bool
$c/= :: ContestObservation -> ContestObservation -> Bool
/= :: ContestObservation -> ContestObservation -> Bool
Eq, (forall x. ContestObservation -> Rep ContestObservation x)
-> (forall x. Rep ContestObservation x -> ContestObservation)
-> Generic ContestObservation
forall x. Rep ContestObservation x -> ContestObservation
forall x. ContestObservation -> Rep ContestObservation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ContestObservation -> Rep ContestObservation x
from :: forall x. ContestObservation -> Rep ContestObservation x
$cto :: forall x. Rep ContestObservation x -> ContestObservation
to :: forall x. Rep ContestObservation x -> ContestObservation
Generic)

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

-- | Identify a close tx by lookup up the input spending the Head output and
-- decoding its redeemer.
observeContestTx ::
  -- | A UTxO set to lookup tx inputs
  UTxO ->
  Tx ->
  Maybe ContestObservation
observeContestTx :: UTxO -> Tx -> Maybe ContestObservation
observeContestTx UTxO
utxo Tx
tx = do
  let inputUTxO :: UTxO
inputUTxO = UTxO -> Tx -> UTxO
resolveInputsUTxO UTxO
utxo Tx
tx
  (TxIn
headInput, TxOut CtxUTxO
headOutput) <- forall lang.
IsPlutusScriptLanguage lang =>
UTxO -> PlutusScript lang -> Maybe (TxIn, TxOut CtxUTxO)
findTxOutByScript @PlutusScriptV3 UTxO
inputUTxO PlutusScript PlutusScriptV3
forall {lang}. PlutusScript lang
headScript
  Input
redeemer <- Tx -> TxIn -> Maybe Input
forall a. FromData a => Tx -> TxIn -> Maybe a
findRedeemerSpending Tx
tx TxIn
headInput
  HashableScriptData
oldHeadDatum <- TxOut CtxTx Era -> Maybe HashableScriptData
forall era. TxOut CtxTx era -> Maybe HashableScriptData
txOutScriptData (TxOut CtxTx Era -> Maybe HashableScriptData)
-> TxOut CtxTx Era -> Maybe HashableScriptData
forall a b. (a -> b) -> a -> b
$ TxOut CtxUTxO -> TxOut CtxTx Era
forall era. TxOut CtxUTxO era -> TxOut CtxTx era
forall {k} (f :: * -> k -> *) (era :: k).
ToTxContext f =>
f CtxUTxO era -> f CtxTx era
toTxContext TxOut CtxUTxO
headOutput
  State
datum <- HashableScriptData -> Maybe State
forall a. FromScriptData a => HashableScriptData -> Maybe a
fromScriptData HashableScriptData
oldHeadDatum
  HeadId
headId <- TxOut CtxUTxO -> Maybe HeadId
forall ctx. TxOut ctx -> Maybe HeadId
findStateToken TxOut CtxUTxO
headOutput
  case (State
datum, Input
redeemer) of
    (Head.Closed Head.ClosedDatum{}, Head.Contest{}) -> do
      (TxIn
newHeadInput, TxOut CtxUTxO
newHeadOutput) <- forall lang.
IsPlutusScriptLanguage lang =>
UTxO -> PlutusScript lang -> Maybe (TxIn, TxOut CtxUTxO)
findTxOutByScript @PlutusScriptV3 (Tx -> UTxO
utxoFromTx Tx
tx) PlutusScript PlutusScriptV3
forall {lang}. PlutusScript lang
headScript
      HashableScriptData
newHeadDatum <- TxOut CtxTx Era -> Maybe HashableScriptData
forall era. TxOut CtxTx era -> Maybe HashableScriptData
txOutScriptData (TxOut CtxTx Era -> Maybe HashableScriptData)
-> TxOut CtxTx Era -> Maybe HashableScriptData
forall a b. (a -> b) -> a -> b
$ TxOut CtxUTxO -> TxOut CtxTx Era
forall era. TxOut CtxUTxO era -> TxOut CtxTx era
forall {k} (f :: * -> k -> *) (era :: k).
ToTxContext f =>
f CtxUTxO era -> f CtxTx era
toTxContext TxOut CtxUTxO
newHeadOutput
      let (Integer
onChainSnapshotNumber, POSIXTime
contestationDeadline, [PubKeyHash]
contesters) = HashableScriptData -> (Integer, POSIXTime, [PubKeyHash])
decodeDatum HashableScriptData
newHeadDatum
      ContestObservation -> Maybe ContestObservation
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ContestObservation
          { $sel:contestedThreadOutput:ContestObservation :: (TxIn, TxOut CtxUTxO)
contestedThreadOutput = (TxIn
newHeadInput, TxOut CtxUTxO
newHeadOutput)
          , HeadId
$sel:headId:ContestObservation :: HeadId
headId :: HeadId
headId
          , $sel:snapshotNumber:ContestObservation :: SnapshotNumber
snapshotNumber = Integer -> SnapshotNumber
fromChainSnapshotNumber Integer
onChainSnapshotNumber
          , $sel:contestationDeadline:ContestObservation :: UTCTime
contestationDeadline = POSIXTime -> UTCTime
posixToUTCTime POSIXTime
contestationDeadline
          , [PubKeyHash]
$sel:contesters:ContestObservation :: [PubKeyHash]
contesters :: [PubKeyHash]
contesters
          }
    (State, Input)
_ -> Maybe ContestObservation
forall a. Maybe a
Nothing
 where
  headScript :: PlutusScript lang
headScript = SerialisedScript -> PlutusScript lang
forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript SerialisedScript
Head.validatorScript

  decodeDatum :: HashableScriptData -> (Integer, POSIXTime, [PubKeyHash])
decodeDatum HashableScriptData
headDatum =
    case HashableScriptData -> Maybe State
forall a. FromScriptData a => HashableScriptData -> Maybe a
fromScriptData HashableScriptData
headDatum of
      Just (Head.Closed Head.ClosedDatum{Integer
$sel:snapshotNumber:ClosedDatum :: ClosedDatum -> Integer
snapshotNumber :: Integer
snapshotNumber, POSIXTime
$sel:contestationDeadline:ClosedDatum :: ClosedDatum -> POSIXTime
contestationDeadline :: POSIXTime
contestationDeadline, [PubKeyHash]
contesters :: [PubKeyHash]
$sel:contesters:ClosedDatum :: ClosedDatum -> [PubKeyHash]
contesters}) ->
        (Integer
snapshotNumber, POSIXTime
contestationDeadline, [PubKeyHash]
contesters)
      Maybe State
_ -> Text -> (Integer, POSIXTime, [PubKeyHash])
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"wrong state in output datum"

newtype FanoutObservation = FanoutObservation {FanoutObservation -> HeadId
headId :: HeadId} deriving stock (FanoutObservation -> FanoutObservation -> Bool
(FanoutObservation -> FanoutObservation -> Bool)
-> (FanoutObservation -> FanoutObservation -> Bool)
-> Eq FanoutObservation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FanoutObservation -> FanoutObservation -> Bool
== :: FanoutObservation -> FanoutObservation -> Bool
$c/= :: FanoutObservation -> FanoutObservation -> Bool
/= :: FanoutObservation -> FanoutObservation -> Bool
Eq, Int -> FanoutObservation -> ShowS
[FanoutObservation] -> ShowS
FanoutObservation -> String
(Int -> FanoutObservation -> ShowS)
-> (FanoutObservation -> String)
-> ([FanoutObservation] -> ShowS)
-> Show FanoutObservation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FanoutObservation -> ShowS
showsPrec :: Int -> FanoutObservation -> ShowS
$cshow :: FanoutObservation -> String
show :: FanoutObservation -> String
$cshowList :: [FanoutObservation] -> ShowS
showList :: [FanoutObservation] -> ShowS
Show, (forall x. FanoutObservation -> Rep FanoutObservation x)
-> (forall x. Rep FanoutObservation x -> FanoutObservation)
-> Generic FanoutObservation
forall x. Rep FanoutObservation x -> FanoutObservation
forall x. FanoutObservation -> Rep FanoutObservation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. FanoutObservation -> Rep FanoutObservation x
from :: forall x. FanoutObservation -> Rep FanoutObservation x
$cto :: forall x. Rep FanoutObservation x -> FanoutObservation
to :: forall x. Rep FanoutObservation x -> FanoutObservation
Generic)

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

-- | Identify a fanout tx by lookup up the input spending the Head output and
-- decoding its redeemer.
observeFanoutTx ::
  -- | A UTxO set to lookup tx inputs
  UTxO ->
  Tx ->
  Maybe FanoutObservation
observeFanoutTx :: UTxO -> Tx -> Maybe FanoutObservation
observeFanoutTx UTxO
utxo Tx
tx = do
  let inputUTxO :: UTxO
inputUTxO = UTxO -> Tx -> UTxO
resolveInputsUTxO UTxO
utxo Tx
tx
  (TxIn
headInput, TxOut CtxUTxO
headOutput) <- forall lang.
IsPlutusScriptLanguage lang =>
UTxO -> PlutusScript lang -> Maybe (TxIn, TxOut CtxUTxO)
findTxOutByScript @PlutusScriptV3 UTxO
inputUTxO PlutusScript PlutusScriptV3
forall {lang}. PlutusScript lang
headScript
  HeadId
headId <- TxOut CtxUTxO -> Maybe HeadId
forall ctx. TxOut ctx -> Maybe HeadId
findStateToken TxOut CtxUTxO
headOutput
  Tx -> TxIn -> Maybe Input
forall a. FromData a => Tx -> TxIn -> Maybe a
findRedeemerSpending Tx
tx TxIn
headInput
    Maybe Input
-> (Input -> Maybe FanoutObservation) -> Maybe FanoutObservation
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Head.Fanout{} -> FanoutObservation -> Maybe FanoutObservation
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FanoutObservation{HeadId
$sel:headId:FanoutObservation :: HeadId
headId :: HeadId
headId}
      Input
_ -> Maybe FanoutObservation
forall a. Maybe a
Nothing
 where
  headScript :: PlutusScript lang
headScript = SerialisedScript -> PlutusScript lang
forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript SerialisedScript
Head.validatorScript

newtype AbortObservation = AbortObservation {AbortObservation -> HeadId
headId :: HeadId} deriving stock (AbortObservation -> AbortObservation -> Bool
(AbortObservation -> AbortObservation -> Bool)
-> (AbortObservation -> AbortObservation -> Bool)
-> Eq AbortObservation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AbortObservation -> AbortObservation -> Bool
== :: AbortObservation -> AbortObservation -> Bool
$c/= :: AbortObservation -> AbortObservation -> Bool
/= :: AbortObservation -> AbortObservation -> Bool
Eq, Int -> AbortObservation -> ShowS
[AbortObservation] -> ShowS
AbortObservation -> String
(Int -> AbortObservation -> ShowS)
-> (AbortObservation -> String)
-> ([AbortObservation] -> ShowS)
-> Show AbortObservation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AbortObservation -> ShowS
showsPrec :: Int -> AbortObservation -> ShowS
$cshow :: AbortObservation -> String
show :: AbortObservation -> String
$cshowList :: [AbortObservation] -> ShowS
showList :: [AbortObservation] -> ShowS
Show, (forall x. AbortObservation -> Rep AbortObservation x)
-> (forall x. Rep AbortObservation x -> AbortObservation)
-> Generic AbortObservation
forall x. Rep AbortObservation x -> AbortObservation
forall x. AbortObservation -> Rep AbortObservation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. AbortObservation -> Rep AbortObservation x
from :: forall x. AbortObservation -> Rep AbortObservation x
$cto :: forall x. Rep AbortObservation x -> AbortObservation
to :: forall x. Rep AbortObservation x -> AbortObservation
Generic)

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

-- | Identify an abort tx by looking up the input spending the Head output and
-- decoding its redeemer.
observeAbortTx ::
  -- | A UTxO set to lookup tx inputs
  UTxO ->
  Tx ->
  Maybe AbortObservation
observeAbortTx :: UTxO -> Tx -> Maybe AbortObservation
observeAbortTx UTxO
utxo Tx
tx = do
  let inputUTxO :: UTxO
inputUTxO = UTxO -> Tx -> UTxO
resolveInputsUTxO UTxO
utxo Tx
tx
  (TxIn
headInput, TxOut CtxUTxO
headOutput) <- forall lang.
IsPlutusScriptLanguage lang =>
UTxO -> PlutusScript lang -> Maybe (TxIn, TxOut CtxUTxO)
findTxOutByScript @PlutusScriptV3 UTxO
inputUTxO PlutusScript PlutusScriptV3
forall {lang}. PlutusScript lang
headScript
  HeadId
headId <- TxOut CtxUTxO -> Maybe HeadId
forall ctx. TxOut ctx -> Maybe HeadId
findStateToken TxOut CtxUTxO
headOutput
  Tx -> TxIn -> Maybe Input
forall a. FromData a => Tx -> TxIn -> Maybe a
findRedeemerSpending Tx
tx TxIn
headInput Maybe Input
-> (Input -> Maybe AbortObservation) -> Maybe AbortObservation
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Input
Head.Abort -> AbortObservation -> Maybe AbortObservation
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AbortObservation -> Maybe AbortObservation)
-> AbortObservation -> Maybe AbortObservation
forall a b. (a -> b) -> a -> b
$ HeadId -> AbortObservation
AbortObservation HeadId
headId
    Input
_ -> Maybe AbortObservation
forall a. Maybe a
Nothing
 where
  headScript :: PlutusScript lang
headScript = SerialisedScript -> PlutusScript lang
forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript SerialisedScript
Head.validatorScript

-- * Cardano specific identifiers

currencySymbolToHeadId :: MonadFail m => CurrencySymbol -> m HeadId
currencySymbolToHeadId :: forall (m :: * -> *). MonadFail m => CurrencySymbol -> m HeadId
currencySymbolToHeadId = (PolicyId -> HeadId) -> m PolicyId -> m HeadId
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PolicyId -> HeadId
mkHeadId (m PolicyId -> m HeadId)
-> (CurrencySymbol -> m PolicyId) -> CurrencySymbol -> m HeadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CurrencySymbol -> m PolicyId
forall (m :: * -> *). MonadFail m => CurrencySymbol -> m PolicyId
fromPlutusCurrencySymbol

headIdToPolicyId :: MonadFail m => HeadId -> m PolicyId
headIdToPolicyId :: forall (m :: * -> *). MonadFail m => HeadId -> m PolicyId
headIdToPolicyId = CurrencySymbol -> m PolicyId
forall (m :: * -> *). MonadFail m => CurrencySymbol -> m PolicyId
fromPlutusCurrencySymbol (CurrencySymbol -> m PolicyId)
-> (HeadId -> CurrencySymbol) -> HeadId -> m PolicyId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeadId -> CurrencySymbol
headIdToCurrencySymbol

headSeedToTxIn :: MonadFail m => HeadSeed -> m TxIn
headSeedToTxIn :: forall (m :: * -> *). MonadFail m => HeadSeed -> m TxIn
headSeedToTxIn (UnsafeHeadSeed ByteString
bytes) =
  case ByteString -> Maybe TxIn
forall a. FromJSON a => ByteString -> Maybe a
Aeson.decodeStrict ByteString
bytes of
    Maybe TxIn
Nothing -> String -> m TxIn
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m TxIn) -> String -> m TxIn
forall a b. (a -> b) -> a -> b
$ String
"Failed to decode HeadSeed " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall b a. (Show a, IsString b) => a -> b
show ByteString
bytes
    Just TxIn
txIn -> TxIn -> m TxIn
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TxIn
txIn

txInToHeadSeed :: TxIn -> HeadSeed
txInToHeadSeed :: TxIn -> HeadSeed
txInToHeadSeed TxIn
txin = ByteString -> HeadSeed
UnsafeHeadSeed (ByteString -> HeadSeed) -> ByteString -> HeadSeed
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
forall l s. LazyStrict l s => l -> s
toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ TxIn -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode TxIn
txin

-- * Helpers

findHeadAssetId :: TxOut ctx -> Maybe (PolicyId, AssetName)
findHeadAssetId :: forall ctx. TxOut ctx -> Maybe (PolicyId, AssetName)
findHeadAssetId TxOut ctx
txOut =
  (((AssetId, Quantity) -> Maybe (PolicyId, AssetName))
 -> [(AssetId, Quantity)] -> Maybe (PolicyId, AssetName))
-> [(AssetId, Quantity)]
-> ((AssetId, Quantity) -> Maybe (PolicyId, AssetName))
-> Maybe (PolicyId, AssetName)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((AssetId, Quantity) -> Maybe (PolicyId, AssetName))
-> [(AssetId, Quantity)] -> Maybe (PolicyId, AssetName)
forall (t :: * -> *) a b.
Foldable t =>
(a -> Maybe b) -> t a -> Maybe b
findFirst (Value -> [Item Value]
forall l. IsList l => l -> [Item l]
toList (Value -> [Item Value]) -> Value -> [Item Value]
forall a b. (a -> b) -> a -> b
$ TxOut ctx -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut ctx
txOut) (((AssetId, Quantity) -> Maybe (PolicyId, AssetName))
 -> Maybe (PolicyId, AssetName))
-> ((AssetId, Quantity) -> Maybe (PolicyId, AssetName))
-> Maybe (PolicyId, AssetName)
forall a b. (a -> b) -> a -> b
$ \case
    (AssetId PolicyId
pid AssetName
aname, Quantity
q)
      | AssetName
aname AssetName -> AssetName -> Bool
forall a. Eq a => a -> a -> Bool
== AssetName
hydraHeadV1AssetName Bool -> Bool -> Bool
&& Quantity
q Quantity -> Quantity -> Bool
forall a. Eq a => a -> a -> Bool
== Quantity
1 ->
          (PolicyId, AssetName) -> Maybe (PolicyId, AssetName)
forall a. a -> Maybe a
Just (PolicyId
pid, AssetName
aname)
    (AssetId, Quantity)
_ ->
      Maybe (PolicyId, AssetName)
forall a. Maybe a
Nothing

-- | Find (if it exists) the head identifier contained in given `TxOut`.
findStateToken :: TxOut ctx -> Maybe HeadId
findStateToken :: forall ctx. TxOut ctx -> Maybe HeadId
findStateToken =
  ((PolicyId, AssetName) -> HeadId)
-> Maybe (PolicyId, AssetName) -> Maybe HeadId
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PolicyId -> HeadId
mkHeadId (PolicyId -> HeadId)
-> ((PolicyId, AssetName) -> PolicyId)
-> (PolicyId, AssetName)
-> HeadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PolicyId, AssetName) -> PolicyId
forall a b. (a, b) -> a
fst) (Maybe (PolicyId, AssetName) -> Maybe HeadId)
-> (TxOut ctx -> Maybe (PolicyId, AssetName))
-> TxOut ctx
-> Maybe HeadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut ctx -> Maybe (PolicyId, AssetName)
forall ctx. TxOut ctx -> Maybe (PolicyId, AssetName)
findHeadAssetId