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

module Hydra.Tx.CollectCom where

import Data.Map qualified as Map
import Hydra.Cardano.Api
import Hydra.Prelude

import Data.ByteString qualified as BS
import Hydra.Contract.Commit qualified as Commit
import Hydra.Contract.Head qualified as Head
import Hydra.Contract.HeadState qualified as Head
import Hydra.Ledger.Cardano.Builder (unsafeBuildTransaction)
import Hydra.Plutus (commitValidatorScript)
import Hydra.Tx.ContestationPeriod (toChain)
import Hydra.Tx.HeadId (HeadId, headIdToCurrencySymbol)
import Hydra.Tx.HeadParameters (HeadParameters (..))
import Hydra.Tx.IsTx (hashUTxO)
import Hydra.Tx.Party (partyToChain)
import Hydra.Tx.ScriptRegistry (ScriptRegistry (..))
import Hydra.Tx.Utils (findStateToken, mkHydraHeadV1TxName)
import PlutusLedgerApi.Common (fromBuiltin)
import PlutusLedgerApi.V3 (toBuiltin)
import Test.QuickCheck (vectorOf)

-- * Construction

-- | Create a transaction collecting all "committed" utxo and opening a Head,
-- i.e. driving the Head script state.
collectComTx ::
  NetworkId ->
  -- | Published Hydra scripts to reference.
  ScriptRegistry ->
  -- | Party who's authorizing this transaction
  VerificationKey PaymentKey ->
  -- | Head identifier
  HeadId ->
  -- | Parameters of the head to collect .
  HeadParameters ->
  -- | Everything needed to spend the Head state-machine output.
  (TxIn, TxOut CtxUTxO) ->
  -- | Data needed to spend the commit output produced by each party.
  -- Should contain the PT and is locked by @ν_commit@ script.
  Map TxIn (TxOut CtxUTxO) ->
  -- | UTxO to be used to collect.
  -- Should match whatever is recorded in the commit inputs.
  UTxO ->
  Tx
collectComTx :: NetworkId
-> ScriptRegistry
-> VerificationKey PaymentKey
-> HeadId
-> HeadParameters
-> (TxIn, TxOut CtxUTxO)
-> Map TxIn (TxOut CtxUTxO)
-> UTxO
-> Tx
collectComTx NetworkId
networkId ScriptRegistry
scriptRegistry VerificationKey PaymentKey
vk HeadId
headId HeadParameters
headParameters (TxIn
headInput, TxOut CtxUTxO
initialHeadOutput) Map TxIn (TxOut CtxUTxO)
commits UTxO
utxoToCollect =
  HasCallStack => TxBodyContent BuildTx -> Tx
TxBodyContent BuildTx -> Tx
unsafeBuildTransaction (TxBodyContent BuildTx -> Tx) -> TxBodyContent BuildTx -> Tx
forall a b. (a -> b) -> a -> b
$
    TxBodyContent BuildTx
defaultTxBodyContent
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& TxIns BuildTx Era -> TxBodyContent BuildTx -> TxBodyContent BuildTx
forall build era.
TxIns build era
-> TxBodyContent build era -> TxBodyContent build era
addTxIns ((TxIn
headInput, BuildTxWith BuildTx (Witness WitCtxTxIn)
headWitness) (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn))
-> TxIns BuildTx Era -> TxIns BuildTx Era
forall a. a -> [a] -> [a]
: (TxIn -> (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn))
mkCommit (TxIn -> (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn)))
-> [TxIn] -> TxIns BuildTx Era
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map TxIn (TxOut CtxUTxO) -> [TxIn]
forall k a. Map k a -> [k]
Map.keys Map TxIn (TxOut CtxUTxO)
commits))
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [TxIn]
-> Set HashableScriptData
-> TxBodyContent BuildTx
-> TxBodyContent BuildTx
forall build era.
(Applicative (BuildTxWith build), IsBabbageBasedEra era) =>
[TxIn]
-> Set HashableScriptData
-> TxBodyContent build era
-> TxBodyContent build era
addTxInsReference [TxIn
commitScriptRef, TxIn
headScriptRef] Set HashableScriptData
forall a. Monoid a => a
mempty
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [TxOut CtxTx Era] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
forall era build.
[TxOut CtxTx era]
-> TxBodyContent build era -> TxBodyContent build era
addTxOuts [TxOut CtxTx Era
headOutput]
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [Hash PaymentKey] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
forall era build.
IsAlonzoBasedEra era =>
[Hash PaymentKey]
-> TxBodyContent build era -> TxBodyContent build era
addTxExtraKeyWits [VerificationKey PaymentKey -> Hash PaymentKey
forall keyrole.
Key keyrole =>
VerificationKey keyrole -> Hash keyrole
verificationKeyHash VerificationKey PaymentKey
vk]
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& TxMetadataInEra Era
-> TxBodyContent BuildTx -> TxBodyContent BuildTx
forall era build.
TxMetadataInEra era
-> TxBodyContent build era -> TxBodyContent build era
setTxMetadata (TxMetadata -> TxMetadataInEra Era
TxMetadataInEra (TxMetadata -> TxMetadataInEra Era)
-> TxMetadata -> TxMetadataInEra Era
forall a b. (a -> b) -> a -> b
$ Text -> TxMetadata
mkHydraHeadV1TxName Text
"CollectComTx")
 where
  HeadParameters{[Party]
parties :: [Party]
$sel:parties:HeadParameters :: HeadParameters -> [Party]
parties, ContestationPeriod
contestationPeriod :: ContestationPeriod
$sel:contestationPeriod:HeadParameters :: HeadParameters -> ContestationPeriod
contestationPeriod} = HeadParameters
headParameters

  headWitness :: BuildTxWith BuildTx (Witness WitCtxTxIn)
headWitness =
    Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn)
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn))
-> Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn)
forall a b. (a -> b) -> a -> b
$
      ScriptWitnessInCtx WitCtxTxIn
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn
forall ctx.
ScriptWitnessInCtx ctx -> ScriptWitness ctx -> Witness ctx
ScriptWitness ScriptWitnessInCtx WitCtxTxIn
forall ctx. IsScriptWitnessInCtx ctx => ScriptWitnessInCtx ctx
scriptWitnessInCtx (ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn)
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn
forall a b. (a -> b) -> a -> b
$
        TxIn
-> PlutusScript PlutusScriptV3
-> ScriptDatum WitCtxTxIn
-> HashableScriptData
-> ScriptWitness WitCtxTxIn
forall ctx era lang.
(IsPlutusScriptLanguage lang, HasScriptLanguageInEra lang era) =>
TxIn
-> PlutusScript lang
-> ScriptDatum ctx
-> HashableScriptData
-> ScriptWitness ctx era
mkScriptReference TxIn
headScriptRef PlutusScript PlutusScriptV3
Head.validatorScript ScriptDatum WitCtxTxIn
InlineScriptDatum HashableScriptData
headRedeemer
  headScriptRef :: TxIn
headScriptRef = (TxIn, TxOut CtxUTxO) -> TxIn
forall a b. (a, b) -> a
fst (ScriptRegistry -> (TxIn, TxOut CtxUTxO)
headReference ScriptRegistry
scriptRegistry)
  headRedeemer :: HashableScriptData
headRedeemer = Input -> HashableScriptData
forall a. ToScriptData a => a -> HashableScriptData
toScriptData Input
Head.CollectCom
  headOutput :: TxOut CtxTx Era
headOutput =
    AddressInEra
-> Value -> TxOutDatum CtxTx -> ReferenceScript -> TxOut CtxTx Era
forall ctx.
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut
      (NetworkId -> PlutusScript PlutusScriptV3 -> AddressInEra
forall lang era.
(IsShelleyBasedEra era, IsPlutusScriptLanguage lang) =>
NetworkId -> PlutusScript lang -> AddressInEra era
mkScriptAddress NetworkId
networkId PlutusScript PlutusScriptV3
Head.validatorScript)
      (TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO
initialHeadOutput Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value
commitValue)
      TxOutDatum CtxTx
headDatumAfter
      ReferenceScript
ReferenceScriptNone
  headDatumAfter :: TxOutDatum CtxTx
headDatumAfter =
    State -> TxOutDatum CtxTx
forall era a ctx.
(ToScriptData a, IsBabbageBasedEra era) =>
a -> TxOutDatum ctx era
mkTxOutDatumInline (State -> TxOutDatum CtxTx) -> State -> TxOutDatum CtxTx
forall a b. (a -> b) -> a -> b
$
      OpenDatum -> State
Head.Open
        Head.OpenDatum
          { $sel:parties:OpenDatum :: [Party]
Head.parties = Party -> Party
partyToChain (Party -> Party) -> [Party] -> [Party]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Party]
parties
          , Hash
ToBuiltin ByteString
utxoHash :: ToBuiltin ByteString
$sel:utxoHash:OpenDatum :: Hash
utxoHash
          , $sel:contestationPeriod:OpenDatum :: ContestationPeriod
contestationPeriod = ContestationPeriod -> ContestationPeriod
toChain ContestationPeriod
contestationPeriod
          , $sel:headId:OpenDatum :: CurrencySymbol
headId = HeadId -> CurrencySymbol
headIdToCurrencySymbol HeadId
headId
          , $sel:version:OpenDatum :: SnapshotVersion
version = SnapshotVersion
0
          }

  utxoHash :: ToBuiltin ByteString
utxoHash = ByteString -> ToBuiltin ByteString
forall a. HasToBuiltin a => a -> ToBuiltin a
toBuiltin (ByteString -> ToBuiltin ByteString)
-> ByteString -> ToBuiltin ByteString
forall a b. (a -> b) -> a -> b
$ forall tx. IsTx tx => UTxOType tx -> ByteString
hashUTxO @Tx UTxO
UTxOType Tx
utxoToCollect

  mkCommit :: TxIn -> (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn))
mkCommit TxIn
commitTxIn = (TxIn
commitTxIn, BuildTxWith BuildTx (Witness WitCtxTxIn)
commitWitness)
  commitWitness :: BuildTxWith BuildTx (Witness WitCtxTxIn)
commitWitness =
    Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn)
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn))
-> Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn)
forall a b. (a -> b) -> a -> b
$
      ScriptWitnessInCtx WitCtxTxIn
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn
forall ctx.
ScriptWitnessInCtx ctx -> ScriptWitness ctx -> Witness ctx
ScriptWitness ScriptWitnessInCtx WitCtxTxIn
forall ctx. IsScriptWitnessInCtx ctx => ScriptWitnessInCtx ctx
scriptWitnessInCtx (ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn)
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn
forall a b. (a -> b) -> a -> b
$
        TxIn
-> PlutusScript PlutusScriptV3
-> ScriptDatum WitCtxTxIn
-> HashableScriptData
-> ScriptWitness WitCtxTxIn
forall ctx era lang.
(IsPlutusScriptLanguage lang, HasScriptLanguageInEra lang era) =>
TxIn
-> PlutusScript lang
-> ScriptDatum ctx
-> HashableScriptData
-> ScriptWitness ctx era
mkScriptReference TxIn
commitScriptRef PlutusScript PlutusScriptV3
commitValidatorScript ScriptDatum WitCtxTxIn
InlineScriptDatum HashableScriptData
commitRedeemer
  commitScriptRef :: TxIn
commitScriptRef =
    (TxIn, TxOut CtxUTxO) -> TxIn
forall a b. (a, b) -> a
fst (ScriptRegistry -> (TxIn, TxOut CtxUTxO)
commitReference ScriptRegistry
scriptRegistry)
  commitValue :: Value
commitValue =
    [Value] -> Value
forall a. Monoid a => [a] -> a
mconcat ([Value] -> Value) -> [Value] -> Value
forall a b. (a -> b) -> a -> b
$ TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue (TxOut CtxUTxO -> Value) -> [TxOut CtxUTxO] -> [Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map TxIn (TxOut CtxUTxO) -> [TxOut CtxUTxO]
forall k a. Map k a -> [a]
Map.elems Map TxIn (TxOut CtxUTxO)
commits
  commitRedeemer :: HashableScriptData
commitRedeemer =
    Redeemer -> HashableScriptData
forall a. ToScriptData a => a -> HashableScriptData
toScriptData (Redeemer -> HashableScriptData) -> Redeemer -> HashableScriptData
forall a b. (a -> b) -> a -> b
$ RedeemerType -> Redeemer
Commit.redeemer RedeemerType
Commit.ViaCollectCom

-- * Observation

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)
  deriving ([UTxOHash] -> Value
[UTxOHash] -> Encoding
UTxOHash -> Bool
UTxOHash -> Value
UTxOHash -> Encoding
(UTxOHash -> Value)
-> (UTxOHash -> Encoding)
-> ([UTxOHash] -> Value)
-> ([UTxOHash] -> Encoding)
-> (UTxOHash -> Bool)
-> ToJSON UTxOHash
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: UTxOHash -> Value
toJSON :: UTxOHash -> Value
$ctoEncoding :: UTxOHash -> Encoding
toEncoding :: UTxOHash -> Encoding
$ctoJSONList :: [UTxOHash] -> Value
toJSONList :: [UTxOHash] -> Value
$ctoEncodingList :: [UTxOHash] -> Encoding
toEncodingList :: [UTxOHash] -> Encoding
$comitField :: UTxOHash -> Bool
omitField :: UTxOHash -> Bool
ToJSON, Maybe UTxOHash
Value -> Parser [UTxOHash]
Value -> Parser UTxOHash
(Value -> Parser UTxOHash)
-> (Value -> Parser [UTxOHash])
-> Maybe UTxOHash
-> FromJSON UTxOHash
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser UTxOHash
parseJSON :: Value -> Parser UTxOHash
$cparseJSONList :: Value -> Parser [UTxOHash]
parseJSONList :: Value -> Parser [UTxOHash]
$comittedField :: Maybe UTxOHash
omittedField :: Maybe UTxOHash
FromJSON) via (UsingRawBytesHex UTxOHash)

instance HasTypeProxy UTxOHash where
  data AsType UTxOHash = AsUTxOHash
  proxyToAsType :: Proxy UTxOHash -> AsType UTxOHash
proxyToAsType Proxy UTxOHash
_ = AsType UTxOHash
AsUTxOHash

instance SerialiseAsRawBytes UTxOHash where
  serialiseToRawBytes :: UTxOHash -> ByteString
serialiseToRawBytes (UTxOHash ByteString
bytes) = ByteString
bytes
  deserialiseFromRawBytes :: AsType UTxOHash
-> ByteString -> Either SerialiseAsRawBytesError UTxOHash
deserialiseFromRawBytes AsType UTxOHash
_ = UTxOHash -> Either SerialiseAsRawBytesError UTxOHash
forall a b. b -> Either a b
Right (UTxOHash -> Either SerialiseAsRawBytesError UTxOHash)
-> (ByteString -> UTxOHash)
-> ByteString
-> Either SerialiseAsRawBytesError UTxOHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> UTxOHash
UTxOHash

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

data CollectComObservation = CollectComObservation
  { 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)
  deriving anyclass ([CollectComObservation] -> Value
[CollectComObservation] -> Encoding
CollectComObservation -> Bool
CollectComObservation -> Value
CollectComObservation -> Encoding
(CollectComObservation -> Value)
-> (CollectComObservation -> Encoding)
-> ([CollectComObservation] -> Value)
-> ([CollectComObservation] -> Encoding)
-> (CollectComObservation -> Bool)
-> ToJSON CollectComObservation
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: CollectComObservation -> Value
toJSON :: CollectComObservation -> Value
$ctoEncoding :: CollectComObservation -> Encoding
toEncoding :: CollectComObservation -> Encoding
$ctoJSONList :: [CollectComObservation] -> Value
toJSONList :: [CollectComObservation] -> Value
$ctoEncodingList :: [CollectComObservation] -> Encoding
toEncodingList :: [CollectComObservation] -> Encoding
$comitField :: CollectComObservation -> Bool
omitField :: CollectComObservation -> Bool
ToJSON, Maybe CollectComObservation
Value -> Parser [CollectComObservation]
Value -> Parser CollectComObservation
(Value -> Parser CollectComObservation)
-> (Value -> Parser [CollectComObservation])
-> Maybe CollectComObservation
-> FromJSON CollectComObservation
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser CollectComObservation
parseJSON :: Value -> Parser CollectComObservation
$cparseJSONList :: Value -> Parser [CollectComObservation]
parseJSONList :: Value -> Parser [CollectComObservation]
$comittedField :: Maybe CollectComObservation
omittedField :: Maybe CollectComObservation
FromJSON)

-- | 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) <- UTxO -> PlutusScript PlutusScriptV3 -> Maybe (TxIn, TxOut CtxUTxO)
forall lang.
IsPlutusScriptLanguage lang =>
UTxO -> PlutusScript lang -> Maybe (TxIn, TxOut CtxUTxO)
findTxOutByScript UTxO
inputUTxO PlutusScript PlutusScriptV3
Head.validatorScript
  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
fromCtxUTxOTxOut 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{}, Input
Head.CollectCom) -> do
      (TxIn
_, TxOut CtxUTxO
newHeadOutput) <- UTxO -> PlutusScript PlutusScriptV3 -> Maybe (TxIn, TxOut CtxUTxO)
forall lang.
IsPlutusScriptLanguage lang =>
UTxO -> PlutusScript lang -> Maybe (TxIn, TxOut CtxUTxO)
findTxOutByScript (Tx -> UTxO
utxoFromTx Tx
tx) PlutusScript PlutusScriptV3
Head.validatorScript
      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
fromCtxUTxOTxOut 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
          { 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
  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
$sel:utxoHash:OpenDatum :: OpenDatum -> Hash
utxoHash :: 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