{-# 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 where

import Hydra.Cardano.Api
import Hydra.Prelude

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 Hydra.Cardano.Api.Network (networkIdToNetwork)
import Hydra.Chain (HeadParameters (..))
import Hydra.Chain.Direct.ScriptRegistry (ScriptRegistry (..))
import Hydra.Chain.Direct.TimeHandle (PointInTime)
import Hydra.ContestationPeriod (ContestationPeriod, fromChain, toChain)
import Hydra.Contract.Commit qualified as Commit
import Hydra.Contract.Head qualified as Head
import Hydra.Contract.HeadState qualified as Head
import Hydra.Contract.HeadTokens qualified as HeadTokens
import Hydra.Contract.Initial qualified as Initial
import Hydra.Contract.MintAction (MintAction (Burn, Mint))
import Hydra.Contract.Util (hydraHeadV1)
import Hydra.Crypto (MultiSignature, toPlutusSignatures)
import Hydra.Data.ContestationPeriod (addContestationPeriod)
import Hydra.Data.ContestationPeriod qualified as OnChain
import Hydra.Data.Party qualified as OnChain
import Hydra.HeadId (HeadId (..), HeadSeed (..))
import Hydra.Ledger (IsTx (hashUTxO))
import Hydra.Ledger.Cardano (addReferenceInputs)
import Hydra.Ledger.Cardano.Builder (
  addExtraRequiredSigners,
  addInputs,
  addOutputs,
  addVkInputs,
  burnTokens,
  emptyTxBody,
  mintTokens,
  setValidityLowerBound,
  setValidityUpperBound,
  unsafeBuildTransaction,
 )
import Hydra.OnChainId (OnChainId (..))
import Hydra.Party (Party, partyFromChain, partyToChain)
import Hydra.Plutus.Extras (posixFromUTCTime, posixToUTCTime)
import Hydra.Plutus.Orphans ()
import Hydra.Snapshot (Snapshot (..), SnapshotNumber, fromChainSnapshot)
import PlutusLedgerApi.V2 (CurrencySymbol (CurrencySymbol), fromBuiltin, getPubKeyHash, toBuiltin)
import PlutusLedgerApi.V2 qualified as Plutus
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

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

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

data ClosedThreadOutput = ClosedThreadOutput
  { ClosedThreadOutput -> (TxIn, TxOut CtxUTxO)
closedThreadUTxO :: (TxIn, TxOut CtxUTxO)
  , ClosedThreadOutput -> [Party]
closedParties :: [OnChain.Party]
  , ClosedThreadOutput -> POSIXTime
closedContestationDeadline :: Plutus.POSIXTime
  , ClosedThreadOutput -> [PubKeyHash]
closedContesters :: [Plutus.PubKeyHash]
  }
  deriving stock (ClosedThreadOutput -> ClosedThreadOutput -> Bool
(ClosedThreadOutput -> ClosedThreadOutput -> Bool)
-> (ClosedThreadOutput -> ClosedThreadOutput -> Bool)
-> Eq ClosedThreadOutput
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ClosedThreadOutput -> ClosedThreadOutput -> Bool
== :: ClosedThreadOutput -> ClosedThreadOutput -> Bool
$c/= :: ClosedThreadOutput -> ClosedThreadOutput -> Bool
/= :: ClosedThreadOutput -> ClosedThreadOutput -> Bool
Eq, Int -> ClosedThreadOutput -> ShowS
[ClosedThreadOutput] -> ShowS
ClosedThreadOutput -> String
(Int -> ClosedThreadOutput -> ShowS)
-> (ClosedThreadOutput -> String)
-> ([ClosedThreadOutput] -> ShowS)
-> Show ClosedThreadOutput
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ClosedThreadOutput -> ShowS
showsPrec :: Int -> ClosedThreadOutput -> ShowS
$cshow :: ClosedThreadOutput -> String
show :: ClosedThreadOutput -> String
$cshowList :: [ClosedThreadOutput] -> ShowS
showList :: [ClosedThreadOutput] -> ShowS
Show, (forall x. ClosedThreadOutput -> Rep ClosedThreadOutput x)
-> (forall x. Rep ClosedThreadOutput x -> ClosedThreadOutput)
-> Generic ClosedThreadOutput
forall x. Rep ClosedThreadOutput x -> ClosedThreadOutput
forall x. ClosedThreadOutput -> Rep ClosedThreadOutput x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ClosedThreadOutput -> Rep ClosedThreadOutput x
from :: forall x. ClosedThreadOutput -> Rep ClosedThreadOutput x
$cto :: forall x. Rep ClosedThreadOutput x -> ClosedThreadOutput
to :: forall x. Rep ClosedThreadOutput x -> ClosedThreadOutput
Generic)
  deriving anyclass ([ClosedThreadOutput] -> Value
[ClosedThreadOutput] -> Encoding
ClosedThreadOutput -> Bool
ClosedThreadOutput -> Value
ClosedThreadOutput -> Encoding
(ClosedThreadOutput -> Value)
-> (ClosedThreadOutput -> Encoding)
-> ([ClosedThreadOutput] -> Value)
-> ([ClosedThreadOutput] -> Encoding)
-> (ClosedThreadOutput -> Bool)
-> ToJSON ClosedThreadOutput
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: ClosedThreadOutput -> Value
toJSON :: ClosedThreadOutput -> Value
$ctoEncoding :: ClosedThreadOutput -> Encoding
toEncoding :: ClosedThreadOutput -> Encoding
$ctoJSONList :: [ClosedThreadOutput] -> Value
toJSONList :: [ClosedThreadOutput] -> Value
$ctoEncodingList :: [ClosedThreadOutput] -> Encoding
toEncodingList :: [ClosedThreadOutput] -> Encoding
$comitField :: ClosedThreadOutput -> Bool
omitField :: ClosedThreadOutput -> Bool
ToJSON, Maybe ClosedThreadOutput
Value -> Parser [ClosedThreadOutput]
Value -> Parser ClosedThreadOutput
(Value -> Parser ClosedThreadOutput)
-> (Value -> Parser [ClosedThreadOutput])
-> Maybe ClosedThreadOutput
-> FromJSON ClosedThreadOutput
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser ClosedThreadOutput
parseJSON :: Value -> Parser ClosedThreadOutput
$cparseJSONList :: Value -> Parser [ClosedThreadOutput]
parseJSONList :: Value -> Parser [ClosedThreadOutput]
$comittedField :: Maybe ClosedThreadOutput
omittedField :: Maybe ClosedThreadOutput
FromJSON)

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

hydraHeadV1AssetName :: AssetName
hydraHeadV1AssetName :: AssetName
hydraHeadV1AssetName = ByteString -> AssetName
AssetName (BuiltinByteString -> ByteString
forall arep a. FromBuiltin arep a => arep -> a
fromBuiltin BuiltinByteString
hydraHeadV1)

-- | The metadata label used for identifying Hydra protocol transactions. As
-- suggested by a friendly large language model: The number most commonly
-- associated with "Hydra" is 5, as in the mythological creature Hydra, which
-- had multiple heads, and the number 5 often symbolizes multiplicity or
-- diversity. However, there is no specific numerical association for Hydra
-- smaller than 10000 beyond this mythological reference.
hydraMetadataLabel :: Word64
hydraMetadataLabel :: Word64
hydraMetadataLabel = Word64
55555

-- | Create a transaction metadata entry to identify Hydra transactions (for
-- informational purposes).
mkHydraHeadV1TxName :: Text -> TxMetadata
mkHydraHeadV1TxName :: Text -> TxMetadata
mkHydraHeadV1TxName Text
name =
  Map Word64 TxMetadataValue -> TxMetadata
TxMetadata (Map Word64 TxMetadataValue -> TxMetadata)
-> Map Word64 TxMetadataValue -> TxMetadata
forall a b. (a -> b) -> a -> b
$ [(Word64, TxMetadataValue)] -> Map Word64 TxMetadataValue
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Word64
hydraMetadataLabel, Text -> TxMetadataValue
TxMetaText (Text -> TxMetadataValue) -> Text -> TxMetadataValue
forall a b. (a -> b) -> a -> b
$ Text
"HydraV1/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name)]

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

-- * Create Hydra Head transactions

-- | Create the init transaction from some 'HeadParameters' and a single TxIn
-- which will be used as unique parameter for minting NFTs.
initTx ::
  NetworkId ->
  -- | Seed input.
  TxIn ->
  -- | Verification key hashes of all participants.
  [OnChainId] ->
  HeadParameters ->
  Tx
initTx :: NetworkId -> TxIn -> [OnChainId] -> HeadParameters -> Tx
initTx NetworkId
networkId TxIn
seedTxIn [OnChainId]
participants HeadParameters
parameters =
  HasCallStack => TxBodyContent BuildTx -> Tx
TxBodyContent BuildTx -> Tx
unsafeBuildTransaction (TxBodyContent BuildTx -> Tx) -> TxBodyContent BuildTx -> Tx
forall a b. (a -> b) -> a -> b
$
    TxBodyContent BuildTx
emptyTxBody
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [TxIn] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addVkInputs [TxIn
seedTxIn]
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [TxOut CtxTx] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addOutputs
        ( NetworkId -> TxIn -> HeadParameters -> TxOut CtxTx
mkHeadOutputInitial NetworkId
networkId TxIn
seedTxIn HeadParameters
parameters
            TxOut CtxTx -> [TxOut CtxTx] -> [TxOut CtxTx]
forall a. a -> [a] -> [a]
: (OnChainId -> TxOut CtxTx) -> [OnChainId] -> [TxOut CtxTx]
forall a b. (a -> b) -> [a] -> [b]
map (NetworkId -> TxIn -> OnChainId -> TxOut CtxTx
mkInitialOutput NetworkId
networkId TxIn
seedTxIn) [OnChainId]
participants
        )
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& PlutusScript
-> MintAction
-> [(AssetName, Quantity)]
-> TxBodyContent BuildTx
-> TxBodyContent BuildTx
forall redeemer.
ToScriptData redeemer =>
PlutusScript
-> redeemer
-> [(AssetName, Quantity)]
-> TxBodyContent BuildTx
-> TxBodyContent BuildTx
mintTokens (TxIn -> PlutusScript
HeadTokens.mkHeadTokenScript TxIn
seedTxIn) MintAction
Mint ((AssetName
hydraHeadV1AssetName, Quantity
1) (AssetName, Quantity)
-> [(AssetName, Quantity)] -> [(AssetName, Quantity)]
forall a. a -> [a] -> [a]
: [(AssetName, Quantity)]
participationTokens)
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& TxMetadataInEra -> TxBodyContent BuildTx -> TxBodyContent BuildTx
forall era build.
TxMetadataInEra era
-> TxBodyContent build era -> TxBodyContent build era
setTxMetadata (TxMetadata -> TxMetadataInEra
TxMetadataInEra (TxMetadata -> TxMetadataInEra) -> TxMetadata -> TxMetadataInEra
forall a b. (a -> b) -> a -> b
$ Text -> TxMetadata
mkHydraHeadV1TxName Text
"InitTx")
 where
  participationTokens :: [(AssetName, Quantity)]
participationTokens =
    [(OnChainId -> AssetName
onChainIdToAssetName OnChainId
oid, Quantity
1) | OnChainId
oid <- [OnChainId]
participants]

mkHeadOutput :: NetworkId -> PolicyId -> TxOutDatum ctx -> TxOut ctx
mkHeadOutput :: forall ctx. NetworkId -> PolicyId -> TxOutDatum ctx -> TxOut ctx
mkHeadOutput NetworkId
networkId PolicyId
tokenPolicyId TxOutDatum ctx
datum =
  AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
forall ctx.
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut
    (forall lang era.
(IsShelleyBasedEra era, IsPlutusScriptLanguage lang) =>
NetworkId -> PlutusScript lang -> AddressInEra era
mkScriptAddress @PlutusScriptV2 NetworkId
networkId PlutusScript
forall {lang}. PlutusScript lang
headScript)
    ([(AssetId, Quantity)] -> Value
valueFromList [(PolicyId -> AssetName -> AssetId
AssetId PolicyId
tokenPolicyId AssetName
hydraHeadV1AssetName, Quantity
1)])
    TxOutDatum ctx
datum
    ReferenceScript
ReferenceScriptNone
 where
  headScript :: PlutusScript lang
headScript = SerialisedScript -> PlutusScript lang
forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript SerialisedScript
Head.validatorScript

mkHeadOutputInitial :: NetworkId -> TxIn -> HeadParameters -> TxOut CtxTx
mkHeadOutputInitial :: NetworkId -> TxIn -> HeadParameters -> TxOut CtxTx
mkHeadOutputInitial NetworkId
networkId TxIn
seedTxIn HeadParameters{ContestationPeriod
contestationPeriod :: ContestationPeriod
$sel:contestationPeriod:HeadParameters :: HeadParameters -> ContestationPeriod
contestationPeriod, [Party]
parties :: [Party]
$sel:parties:HeadParameters :: HeadParameters -> [Party]
parties} =
  NetworkId -> PolicyId -> TxOutDatum CtxTx -> TxOut CtxTx
forall ctx. NetworkId -> PolicyId -> TxOutDatum ctx -> TxOut ctx
mkHeadOutput NetworkId
networkId PolicyId
tokenPolicyId TxOutDatum CtxTx
headDatum
 where
  tokenPolicyId :: PolicyId
tokenPolicyId = TxIn -> PolicyId
HeadTokens.headPolicyId TxIn
seedTxIn
  headDatum :: TxOutDatum CtxTx
headDatum =
    State -> TxOutDatum CtxTx
forall era a ctx.
(ToScriptData a, IsBabbageEraOnwards era) =>
a -> TxOutDatum ctx era
mkTxOutDatumInline (State -> TxOutDatum CtxTx) -> State -> TxOutDatum CtxTx
forall a b. (a -> b) -> a -> b
$
      Head.Initial
        { $sel:contestationPeriod:Initial :: ContestationPeriod
contestationPeriod = ContestationPeriod -> ContestationPeriod
toChain ContestationPeriod
contestationPeriod
        , $sel:parties:Initial :: [Party]
parties = (Party -> Party) -> [Party] -> [Party]
forall a b. (a -> b) -> [a] -> [b]
map Party -> Party
partyToChain [Party]
parties
        , $sel:headId:Initial :: CurrencySymbol
headId = PolicyId -> CurrencySymbol
toPlutusCurrencySymbol PolicyId
tokenPolicyId
        , $sel:seed:Initial :: TxOutRef
seed = TxIn -> TxOutRef
toPlutusTxOutRef TxIn
seedTxIn
        }

mkInitialOutput :: NetworkId -> TxIn -> OnChainId -> TxOut CtxTx
mkInitialOutput :: NetworkId -> TxIn -> OnChainId -> TxOut CtxTx
mkInitialOutput NetworkId
networkId TxIn
seedTxIn OnChainId
participant =
  AddressInEra
-> Value -> TxOutDatum CtxTx -> ReferenceScript -> TxOut CtxTx
forall ctx.
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut AddressInEra
initialAddress Value
initialValue TxOutDatum CtxTx
initialDatum ReferenceScript
ReferenceScriptNone
 where
  tokenPolicyId :: PolicyId
tokenPolicyId = TxIn -> PolicyId
HeadTokens.headPolicyId TxIn
seedTxIn
  initialValue :: Value
initialValue =
    [(AssetId, Quantity)] -> Value
valueFromList [(PolicyId -> AssetName -> AssetId
AssetId PolicyId
tokenPolicyId (OnChainId -> AssetName
onChainIdToAssetName OnChainId
participant), Quantity
1)]
  initialAddress :: AddressInEra
initialAddress =
    forall lang era.
(IsShelleyBasedEra era, IsPlutusScriptLanguage lang) =>
NetworkId -> PlutusScript lang -> AddressInEra era
mkScriptAddress @PlutusScriptV2 NetworkId
networkId PlutusScript
forall {lang}. PlutusScript lang
initialScript
  initialScript :: PlutusScript lang
initialScript =
    SerialisedScript -> PlutusScript lang
forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript SerialisedScript
Initial.validatorScript
  initialDatum :: TxOutDatum CtxTx
initialDatum =
    Datum -> TxOutDatum CtxTx
forall era a ctx.
(ToScriptData a, IsBabbageEraOnwards era) =>
a -> TxOutDatum ctx era
mkTxOutDatumInline (Datum -> TxOutDatum CtxTx) -> Datum -> TxOutDatum CtxTx
forall a b. (a -> b) -> a -> b
$ CurrencySymbol -> Datum
Initial.datum (PolicyId -> CurrencySymbol
toPlutusCurrencySymbol PolicyId
tokenPolicyId)

-- | Craft a commit transaction which includes the "committed" utxo as a datum.
commitTx ::
  NetworkId ->
  -- | Published Hydra scripts to reference.
  ScriptRegistry ->
  HeadId ->
  Party ->
  -- | The UTxO to commit to the Head along with witnesses.
  UTxO' (TxOut CtxUTxO, Witness WitCtxTxIn) ->
  -- | The initial output (sent to each party) which should contain the PT and is
  -- locked by initial script
  (TxIn, TxOut CtxUTxO, Hash PaymentKey) ->
  Tx
commitTx :: NetworkId
-> ScriptRegistry
-> HeadId
-> Party
-> UTxO' (TxOut CtxUTxO, Witness WitCtxTxIn Era)
-> (TxIn, TxOut CtxUTxO, Hash PaymentKey)
-> Tx
commitTx NetworkId
networkId ScriptRegistry
scriptRegistry HeadId
headId Party
party UTxO' (TxOut CtxUTxO, Witness WitCtxTxIn Era)
utxoToCommitWitnessed (TxIn
initialInput, TxOut CtxUTxO
out, Hash PaymentKey
vkh) =
  HasCallStack => TxBodyContent BuildTx -> Tx
TxBodyContent BuildTx -> Tx
unsafeBuildTransaction (TxBodyContent BuildTx -> Tx) -> TxBodyContent BuildTx -> Tx
forall a b. (a -> b) -> a -> b
$
    TxBodyContent BuildTx
emptyTxBody
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))]
-> TxBodyContent BuildTx -> TxBodyContent BuildTx
addInputs [(TxIn
initialInput, BuildTxWith BuildTx (Witness WitCtxTxIn Era)
initialWitness)]
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [TxIn] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addReferenceInputs [TxIn
initialScriptRef]
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))]
-> TxBodyContent BuildTx -> TxBodyContent BuildTx
addInputs [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))]
committedTxIns
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [Hash PaymentKey] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addExtraRequiredSigners [Hash PaymentKey
vkh]
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [TxOut CtxTx] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addOutputs [TxOut CtxTx
commitOutput]
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& TxMetadataInEra -> TxBodyContent BuildTx -> TxBodyContent BuildTx
forall era build.
TxMetadataInEra era
-> TxBodyContent build era -> TxBodyContent build era
setTxMetadata (TxMetadata -> TxMetadataInEra
TxMetadataInEra (TxMetadata -> TxMetadataInEra) -> TxMetadata -> TxMetadataInEra
forall a b. (a -> b) -> a -> b
$ Text -> TxMetadata
mkHydraHeadV1TxName Text
"CommitTx")
 where
  initialWitness :: BuildTxWith BuildTx (Witness WitCtxTxIn Era)
initialWitness =
    Witness WitCtxTxIn Era
-> BuildTxWith BuildTx (Witness WitCtxTxIn Era)
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Witness WitCtxTxIn Era
 -> BuildTxWith BuildTx (Witness WitCtxTxIn Era))
-> Witness WitCtxTxIn Era
-> BuildTxWith BuildTx (Witness WitCtxTxIn Era)
forall a b. (a -> b) -> a -> b
$
      ScriptWitnessInCtx WitCtxTxIn
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn Era
forall ctx.
ScriptWitnessInCtx ctx -> ScriptWitness ctx -> Witness ctx
ScriptWitness ScriptWitnessInCtx WitCtxTxIn
forall ctx. IsScriptWitnessInCtx ctx => ScriptWitnessInCtx ctx
scriptWitnessInCtx (ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn Era)
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn Era
forall a b. (a -> b) -> a -> b
$
        TxIn
-> PlutusScript
-> ScriptDatum WitCtxTxIn
-> ScriptRedeemer
-> ScriptWitness WitCtxTxIn
forall ctx era lang.
(IsPlutusScriptLanguage lang, HasScriptLanguageInEra lang era) =>
TxIn
-> PlutusScript lang
-> ScriptDatum ctx
-> ScriptRedeemer
-> ScriptWitness ctx era
mkScriptReference TxIn
initialScriptRef PlutusScript
initialScript ScriptDatum WitCtxTxIn
InlineScriptDatum ScriptRedeemer
initialRedeemer

  initialScript :: PlutusScript
initialScript =
    forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript @PlutusScriptV2 SerialisedScript
Initial.validatorScript

  initialScriptRef :: TxIn
initialScriptRef =
    (TxIn, TxOut CtxUTxO) -> TxIn
forall a b. (a, b) -> a
fst (ScriptRegistry -> (TxIn, TxOut CtxUTxO)
initialReference ScriptRegistry
scriptRegistry)

  initialRedeemer :: ScriptRedeemer
initialRedeemer =
    Redeemer -> ScriptRedeemer
forall a. ToScriptData a => a -> ScriptRedeemer
toScriptData (Redeemer -> ScriptRedeemer)
-> (InitialRedeemer -> Redeemer)
-> InitialRedeemer
-> ScriptRedeemer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InitialRedeemer -> Redeemer
Initial.redeemer (InitialRedeemer -> ScriptRedeemer)
-> InitialRedeemer -> ScriptRedeemer
forall a b. (a -> b) -> a -> b
$
      [TxOutRef] -> InitialRedeemer
Initial.ViaCommit (TxIn -> TxOutRef
toPlutusTxOutRef (TxIn -> TxOutRef)
-> ((TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era)) -> TxIn)
-> (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))
-> TxOutRef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era)) -> TxIn
forall a b. (a, b) -> a
fst ((TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era)) -> TxOutRef)
-> [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))]
-> [TxOutRef]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))]
committedTxIns)

  committedTxIns :: [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))]
committedTxIns =
    ((TxIn, (TxOut CtxUTxO, Witness WitCtxTxIn Era))
 -> (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era)))
-> [(TxIn, (TxOut CtxUTxO, Witness WitCtxTxIn Era))]
-> [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))]
forall a b. (a -> b) -> [a] -> [b]
map (\(TxIn
i, (TxOut CtxUTxO
_, Witness WitCtxTxIn Era
w)) -> (TxIn
i, Witness WitCtxTxIn Era
-> BuildTxWith BuildTx (Witness WitCtxTxIn Era)
forall a. a -> BuildTxWith BuildTx a
BuildTxWith Witness WitCtxTxIn Era
w)) ([(TxIn, (TxOut CtxUTxO, Witness WitCtxTxIn Era))]
 -> [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))])
-> [(TxIn, (TxOut CtxUTxO, Witness WitCtxTxIn Era))]
-> [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))]
forall a b. (a -> b) -> a -> b
$ UTxO' (TxOut CtxUTxO, Witness WitCtxTxIn Era)
-> [(TxIn, (TxOut CtxUTxO, Witness WitCtxTxIn Era))]
forall out. UTxO' out -> [(TxIn, out)]
UTxO.pairs UTxO' (TxOut CtxUTxO, Witness WitCtxTxIn Era)
utxoToCommitWitnessed

  commitOutput :: TxOut CtxTx
commitOutput =
    AddressInEra
-> Value -> TxOutDatum CtxTx -> ReferenceScript -> TxOut CtxTx
forall ctx.
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut AddressInEra
commitAddress Value
commitValue TxOutDatum CtxTx
commitDatum ReferenceScript
ReferenceScriptNone

  commitScript :: PlutusScript lang
commitScript =
    SerialisedScript -> PlutusScript lang
forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript SerialisedScript
Commit.validatorScript

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

  commitValue :: Value
commitValue =
    TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO
out Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> (TxOut CtxUTxO -> Value) -> UTxO' (TxOut CtxUTxO) -> Value
forall m a. Monoid m => (a -> m) -> UTxO' a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue UTxO' (TxOut CtxUTxO)
utxoToCommit

  commitDatum :: TxOutDatum CtxTx
commitDatum =
    Datum -> TxOutDatum CtxTx
forall era a ctx.
(ToScriptData a, IsBabbageEraOnwards era) =>
a -> TxOutDatum ctx era
mkTxOutDatumInline (Datum -> TxOutDatum CtxTx) -> Datum -> TxOutDatum CtxTx
forall a b. (a -> b) -> a -> b
$ Party -> UTxO' (TxOut CtxUTxO) -> CurrencySymbol -> Datum
mkCommitDatum Party
party UTxO' (TxOut CtxUTxO)
utxoToCommit (HeadId -> CurrencySymbol
headIdToCurrencySymbol HeadId
headId)

  utxoToCommit :: UTxO' (TxOut CtxUTxO)
utxoToCommit = (TxOut CtxUTxO, Witness WitCtxTxIn Era) -> TxOut CtxUTxO
forall a b. (a, b) -> a
fst ((TxOut CtxUTxO, Witness WitCtxTxIn Era) -> TxOut CtxUTxO)
-> UTxO' (TxOut CtxUTxO, Witness WitCtxTxIn Era)
-> UTxO' (TxOut CtxUTxO)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxO' (TxOut CtxUTxO, Witness WitCtxTxIn Era)
utxoToCommitWitnessed

mkCommitDatum :: Party -> UTxO -> CurrencySymbol -> Plutus.Datum
mkCommitDatum :: Party -> UTxO' (TxOut CtxUTxO) -> CurrencySymbol -> Datum
mkCommitDatum Party
party UTxO' (TxOut CtxUTxO)
utxo CurrencySymbol
headId =
  DatumType -> Datum
Commit.datum (Party -> Party
partyToChain Party
party, [Commit]
commits, CurrencySymbol
headId)
 where
  commits :: [Commit]
commits =
    ((TxIn, TxOut CtxUTxO) -> Maybe Commit)
-> [(TxIn, TxOut CtxUTxO)] -> [Commit]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (TxIn, TxOut CtxUTxO) -> Maybe Commit
Commit.serializeCommit ([(TxIn, TxOut CtxUTxO)] -> [Commit])
-> [(TxIn, TxOut CtxUTxO)] -> [Commit]
forall a b. (a -> b) -> a -> b
$ UTxO' (TxOut CtxUTxO) -> [(TxIn, TxOut CtxUTxO)]
forall out. UTxO' out -> [(TxIn, out)]
UTxO.pairs UTxO' (TxOut CtxUTxO)
utxo

-- | 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' (TxOut CtxUTxO)
-> Tx
collectComTx NetworkId
networkId ScriptRegistry
scriptRegistry VerificationKey PaymentKey
vk HeadId
headId HeadParameters
headParameters (TxIn
headInput, TxOut CtxUTxO
initialHeadOutput) Map TxIn (TxOut CtxUTxO)
commits UTxO' (TxOut CtxUTxO)
utxoToCollect =
  HasCallStack => TxBodyContent BuildTx -> Tx
TxBodyContent BuildTx -> Tx
unsafeBuildTransaction (TxBodyContent BuildTx -> Tx) -> TxBodyContent BuildTx -> Tx
forall a b. (a -> b) -> a -> b
$
    TxBodyContent BuildTx
emptyTxBody
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))]
-> TxBodyContent BuildTx -> TxBodyContent BuildTx
addInputs ((TxIn
headInput, BuildTxWith BuildTx (Witness WitCtxTxIn Era)
headWitness) (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))
-> [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))]
-> [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))]
forall a. a -> [a] -> [a]
: (TxIn -> (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))
mkCommit (TxIn -> (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era)))
-> [TxIn] -> [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn 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] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addReferenceInputs [TxIn
commitScriptRef, TxIn
headScriptRef]
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [TxOut CtxTx] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addOutputs [TxOut CtxTx
headOutput]
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [Hash PaymentKey] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addExtraRequiredSigners [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 -> TxBodyContent BuildTx -> TxBodyContent BuildTx
forall era build.
TxMetadataInEra era
-> TxBodyContent build era -> TxBodyContent build era
setTxMetadata (TxMetadata -> TxMetadataInEra
TxMetadataInEra (TxMetadata -> TxMetadataInEra) -> TxMetadata -> TxMetadataInEra
forall a b. (a -> b) -> a -> b
$ Text -> TxMetadata
mkHydraHeadV1TxName Text
"CollectComTx")
 where
  HeadParameters{[Party]
$sel:parties:HeadParameters :: HeadParameters -> [Party]
parties :: [Party]
parties, ContestationPeriod
$sel:contestationPeriod:HeadParameters :: HeadParameters -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod} = HeadParameters
headParameters

  headWitness :: BuildTxWith BuildTx (Witness WitCtxTxIn Era)
headWitness =
    Witness WitCtxTxIn Era
-> BuildTxWith BuildTx (Witness WitCtxTxIn Era)
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Witness WitCtxTxIn Era
 -> BuildTxWith BuildTx (Witness WitCtxTxIn Era))
-> Witness WitCtxTxIn Era
-> BuildTxWith BuildTx (Witness WitCtxTxIn Era)
forall a b. (a -> b) -> a -> b
$
      ScriptWitnessInCtx WitCtxTxIn
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn Era
forall ctx.
ScriptWitnessInCtx ctx -> ScriptWitness ctx -> Witness ctx
ScriptWitness ScriptWitnessInCtx WitCtxTxIn
forall ctx. IsScriptWitnessInCtx ctx => ScriptWitnessInCtx ctx
scriptWitnessInCtx (ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn Era)
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn Era
forall a b. (a -> b) -> a -> b
$
        TxIn
-> PlutusScript
-> ScriptDatum WitCtxTxIn
-> ScriptRedeemer
-> ScriptWitness WitCtxTxIn
forall ctx era lang.
(IsPlutusScriptLanguage lang, HasScriptLanguageInEra lang era) =>
TxIn
-> PlutusScript lang
-> ScriptDatum ctx
-> ScriptRedeemer
-> ScriptWitness ctx era
mkScriptReference TxIn
headScriptRef PlutusScript
headScript ScriptDatum WitCtxTxIn
InlineScriptDatum ScriptRedeemer
headRedeemer
  headScript :: PlutusScript
headScript = forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript @PlutusScriptV2 SerialisedScript
Head.validatorScript
  headScriptRef :: TxIn
headScriptRef = (TxIn, TxOut CtxUTxO) -> TxIn
forall a b. (a, b) -> a
fst (ScriptRegistry -> (TxIn, TxOut CtxUTxO)
headReference ScriptRegistry
scriptRegistry)
  headRedeemer :: ScriptRedeemer
headRedeemer = Input -> ScriptRedeemer
forall a. ToScriptData a => a -> ScriptRedeemer
toScriptData Input
Head.CollectCom
  headOutput :: TxOut CtxTx
headOutput =
    AddressInEra
-> Value -> TxOutDatum CtxTx -> ReferenceScript -> TxOut CtxTx
forall ctx.
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut
      (forall lang era.
(IsShelleyBasedEra era, IsPlutusScriptLanguage lang) =>
NetworkId -> PlutusScript lang -> AddressInEra era
mkScriptAddress @PlutusScriptV2 NetworkId
networkId PlutusScript
headScript)
      (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, IsBabbageEraOnwards era) =>
a -> TxOutDatum ctx era
mkTxOutDatumInline
      Head.Open
        { $sel:parties:Initial :: [Party]
Head.parties = Party -> Party
partyToChain (Party -> Party) -> [Party] -> [Party]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Party]
parties
        , BuiltinByteString
utxoHash :: BuiltinByteString
$sel:utxoHash:Initial :: BuiltinByteString
utxoHash
        , $sel:contestationPeriod:Initial :: ContestationPeriod
contestationPeriod = ContestationPeriod -> ContestationPeriod
toChain ContestationPeriod
contestationPeriod
        , $sel:headId:Initial :: CurrencySymbol
headId = HeadId -> CurrencySymbol
headIdToCurrencySymbol HeadId
headId
        }

  utxoHash :: BuiltinByteString
utxoHash = ByteString -> BuiltinByteString
forall a arep. ToBuiltin a arep => a -> arep
toBuiltin (ByteString -> BuiltinByteString)
-> ByteString -> BuiltinByteString
forall a b. (a -> b) -> a -> b
$ forall tx. IsTx tx => UTxOType tx -> ByteString
hashUTxO @Tx UTxO' (TxOut CtxUTxO)
UTxOType Tx
utxoToCollect

  mkCommit :: TxIn -> (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))
mkCommit TxIn
commitTxIn = (TxIn
commitTxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era)
commitWitness)
  commitWitness :: BuildTxWith BuildTx (Witness WitCtxTxIn Era)
commitWitness =
    Witness WitCtxTxIn Era
-> BuildTxWith BuildTx (Witness WitCtxTxIn Era)
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Witness WitCtxTxIn Era
 -> BuildTxWith BuildTx (Witness WitCtxTxIn Era))
-> Witness WitCtxTxIn Era
-> BuildTxWith BuildTx (Witness WitCtxTxIn Era)
forall a b. (a -> b) -> a -> b
$
      ScriptWitnessInCtx WitCtxTxIn
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn Era
forall ctx.
ScriptWitnessInCtx ctx -> ScriptWitness ctx -> Witness ctx
ScriptWitness ScriptWitnessInCtx WitCtxTxIn
forall ctx. IsScriptWitnessInCtx ctx => ScriptWitnessInCtx ctx
scriptWitnessInCtx (ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn Era)
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn Era
forall a b. (a -> b) -> a -> b
$
        TxIn
-> PlutusScript
-> ScriptDatum WitCtxTxIn
-> ScriptRedeemer
-> ScriptWitness WitCtxTxIn
forall ctx era lang.
(IsPlutusScriptLanguage lang, HasScriptLanguageInEra lang era) =>
TxIn
-> PlutusScript lang
-> ScriptDatum ctx
-> ScriptRedeemer
-> ScriptWitness ctx era
mkScriptReference TxIn
commitScriptRef PlutusScript
commitScript ScriptDatum WitCtxTxIn
InlineScriptDatum ScriptRedeemer
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
  commitScript :: PlutusScript
commitScript =
    forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript @PlutusScriptV2 SerialisedScript
Commit.validatorScript
  commitRedeemer :: ScriptRedeemer
commitRedeemer =
    Redeemer -> ScriptRedeemer
forall a. ToScriptData a => a -> ScriptRedeemer
toScriptData (Redeemer -> ScriptRedeemer) -> Redeemer -> ScriptRedeemer
forall a b. (a -> b) -> a -> b
$ RedeemerType -> Redeemer
Commit.redeemer RedeemerType
Commit.ViaCollectCom

-- | Low-level data type of a snapshot to close the head with. This is different
-- to the 'ConfirmedSnasphot', which is provided to `CloseTx` as it also
-- contains relevant chain state like the 'openUtxoHash'.
data ClosingSnapshot
  = CloseWithInitialSnapshot {ClosingSnapshot -> UTxOHash
openUtxoHash :: UTxOHash}
  | CloseWithConfirmedSnapshot
      { ClosingSnapshot -> SnapshotNumber
snapshotNumber :: SnapshotNumber
      , ClosingSnapshot -> UTxOHash
closeUtxoHash :: UTxOHash
      , -- XXX: This is a bit of a wart and stems from the fact that our
        -- SignableRepresentation of 'Snapshot' is in fact the snapshotNumber
        -- and the closeUtxoHash as also included above
        ClosingSnapshot -> MultiSignature (Snapshot Tx)
signatures :: MultiSignature (Snapshot Tx)
      }

data CloseTxError
  = InvalidHeadIdInClose {CloseTxError -> HeadId
headId :: HeadId}
  | CannotFindHeadOutputToClose
  deriving stock (Int -> CloseTxError -> ShowS
[CloseTxError] -> ShowS
CloseTxError -> String
(Int -> CloseTxError -> ShowS)
-> (CloseTxError -> String)
-> ([CloseTxError] -> ShowS)
-> Show CloseTxError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CloseTxError -> ShowS
showsPrec :: Int -> CloseTxError -> ShowS
$cshow :: CloseTxError -> String
show :: CloseTxError -> String
$cshowList :: [CloseTxError] -> ShowS
showList :: [CloseTxError] -> ShowS
Show)

-- | Create a transaction closing a head with either the initial snapshot or
-- with a multi-signed confirmed snapshot.
closeTx ::
  -- | Published Hydra scripts to reference.
  ScriptRegistry ->
  -- | Party who's authorizing this transaction
  VerificationKey PaymentKey ->
  -- | The snapshot to close with, can be either initial or confirmed one.
  ClosingSnapshot ->
  -- | Lower validity slot number, usually a current or quite recent slot number.
  SlotNo ->
  -- | Upper validity slot and UTC time to compute the contestation deadline time.
  PointInTime ->
  -- | Everything needed to spend the Head state-machine output.
  OpenThreadOutput ->
  -- | Head identifier
  HeadId ->
  Tx
closeTx :: ScriptRegistry
-> VerificationKey PaymentKey
-> ClosingSnapshot
-> SlotNo
-> PointInTime
-> OpenThreadOutput
-> HeadId
-> Tx
closeTx ScriptRegistry
scriptRegistry VerificationKey PaymentKey
vk ClosingSnapshot
closing SlotNo
startSlotNo (SlotNo
endSlotNo, UTCTime
utcTime) OpenThreadOutput
openThreadOutput HeadId
headId =
  HasCallStack => TxBodyContent BuildTx -> Tx
TxBodyContent BuildTx -> Tx
unsafeBuildTransaction (TxBodyContent BuildTx -> Tx) -> TxBodyContent BuildTx -> Tx
forall a b. (a -> b) -> a -> b
$
    TxBodyContent BuildTx
emptyTxBody
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))]
-> TxBodyContent BuildTx -> TxBodyContent BuildTx
addInputs [(TxIn
headInput, BuildTxWith BuildTx (Witness WitCtxTxIn Era)
headWitness)]
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [TxIn] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addReferenceInputs [TxIn
headScriptRef]
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [TxOut CtxTx] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addOutputs [TxOut CtxTx
headOutputAfter]
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [Hash PaymentKey] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addExtraRequiredSigners [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
& SlotNo -> TxBodyContent BuildTx -> TxBodyContent BuildTx
setValidityLowerBound SlotNo
startSlotNo
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& SlotNo -> TxBodyContent BuildTx -> TxBodyContent BuildTx
setValidityUpperBound SlotNo
endSlotNo
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& TxMetadataInEra -> TxBodyContent BuildTx -> TxBodyContent BuildTx
forall era build.
TxMetadataInEra era
-> TxBodyContent build era -> TxBodyContent build era
setTxMetadata (TxMetadata -> TxMetadataInEra
TxMetadataInEra (TxMetadata -> TxMetadataInEra) -> TxMetadata -> TxMetadataInEra
forall a b. (a -> b) -> a -> b
$ Text -> TxMetadata
mkHydraHeadV1TxName Text
"CloseTx")
 where
  OpenThreadOutput
    { $sel:openThreadUTxO:OpenThreadOutput :: OpenThreadOutput -> (TxIn, TxOut CtxUTxO)
openThreadUTxO = (TxIn
headInput, TxOut CtxUTxO
headOutputBefore)
    , ContestationPeriod
$sel:openContestationPeriod:OpenThreadOutput :: OpenThreadOutput -> ContestationPeriod
openContestationPeriod :: ContestationPeriod
openContestationPeriod
    , [Party]
$sel:openParties:OpenThreadOutput :: OpenThreadOutput -> [Party]
openParties :: [Party]
openParties
    } = OpenThreadOutput
openThreadOutput

  headWitness :: BuildTxWith BuildTx (Witness WitCtxTxIn Era)
headWitness =
    Witness WitCtxTxIn Era
-> BuildTxWith BuildTx (Witness WitCtxTxIn Era)
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Witness WitCtxTxIn Era
 -> BuildTxWith BuildTx (Witness WitCtxTxIn Era))
-> Witness WitCtxTxIn Era
-> BuildTxWith BuildTx (Witness WitCtxTxIn Era)
forall a b. (a -> b) -> a -> b
$
      ScriptWitnessInCtx WitCtxTxIn
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn Era
forall ctx.
ScriptWitnessInCtx ctx -> ScriptWitness ctx -> Witness ctx
ScriptWitness ScriptWitnessInCtx WitCtxTxIn
forall ctx. IsScriptWitnessInCtx ctx => ScriptWitnessInCtx ctx
scriptWitnessInCtx (ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn Era)
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn Era
forall a b. (a -> b) -> a -> b
$
        TxIn
-> PlutusScript
-> ScriptDatum WitCtxTxIn
-> ScriptRedeemer
-> ScriptWitness WitCtxTxIn
forall ctx era lang.
(IsPlutusScriptLanguage lang, HasScriptLanguageInEra lang era) =>
TxIn
-> PlutusScript lang
-> ScriptDatum ctx
-> ScriptRedeemer
-> ScriptWitness ctx era
mkScriptReference TxIn
headScriptRef PlutusScript
headScript ScriptDatum WitCtxTxIn
InlineScriptDatum ScriptRedeemer
headRedeemer

  headScriptRef :: TxIn
headScriptRef =
    (TxIn, TxOut CtxUTxO) -> TxIn
forall a b. (a, b) -> a
fst (ScriptRegistry -> (TxIn, TxOut CtxUTxO)
headReference ScriptRegistry
scriptRegistry)

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

  headRedeemer :: ScriptRedeemer
headRedeemer =
    Input -> ScriptRedeemer
forall a. ToScriptData a => a -> ScriptRedeemer
toScriptData
      Head.Close
        { [BuiltinByteString]
signature :: [BuiltinByteString]
$sel:signature:CollectCom :: [BuiltinByteString]
signature
        }

  headOutputAfter :: TxOut CtxTx
headOutputAfter =
    (TxOutDatum CtxUTxO Era -> TxOutDatum CtxTx)
-> TxOut CtxUTxO -> TxOut CtxTx
forall ctx0 era ctx1.
(TxOutDatum ctx0 era -> TxOutDatum ctx1 era)
-> TxOut ctx0 era -> TxOut ctx1 era
modifyTxOutDatum (TxOutDatum CtxTx -> TxOutDatum CtxUTxO Era -> TxOutDatum CtxTx
forall a b. a -> b -> a
const TxOutDatum CtxTx
headDatumAfter) TxOut CtxUTxO
headOutputBefore

  headDatumAfter :: TxOutDatum CtxTx
headDatumAfter =
    State -> TxOutDatum CtxTx
forall era a ctx.
(ToScriptData a, IsBabbageEraOnwards era) =>
a -> TxOutDatum ctx era
mkTxOutDatumInline
      Head.Closed
        { Integer
snapshotNumber :: Integer
$sel:snapshotNumber:Initial :: Integer
snapshotNumber
        , $sel:utxoHash:Initial :: BuiltinByteString
utxoHash = ByteString -> BuiltinByteString
forall a arep. ToBuiltin a arep => a -> arep
toBuiltin ByteString
utxoHashBytes
        , $sel:parties:Initial :: [Party]
parties = [Party]
openParties
        , POSIXTime
contestationDeadline :: POSIXTime
$sel:contestationDeadline:Initial :: POSIXTime
contestationDeadline
        , $sel:contestationPeriod:Initial :: ContestationPeriod
contestationPeriod = ContestationPeriod
openContestationPeriod
        , $sel:headId:Initial :: CurrencySymbol
headId = HeadId -> CurrencySymbol
headIdToCurrencySymbol HeadId
headId
        , $sel:contesters:Initial :: [PubKeyHash]
contesters = []
        }

  snapshotNumber :: Integer
snapshotNumber = SnapshotNumber -> Integer
forall a. Integral a => a -> Integer
toInteger (SnapshotNumber -> Integer) -> SnapshotNumber -> Integer
forall a b. (a -> b) -> a -> b
$ case ClosingSnapshot
closing of
    CloseWithInitialSnapshot{} -> SnapshotNumber
0
    CloseWithConfirmedSnapshot{$sel:snapshotNumber:CloseWithInitialSnapshot :: ClosingSnapshot -> SnapshotNumber
snapshotNumber = SnapshotNumber
sn} -> SnapshotNumber
sn

  UTxOHash ByteString
utxoHashBytes = case ClosingSnapshot
closing of
    CloseWithInitialSnapshot{UTxOHash
openUtxoHash :: ClosingSnapshot -> UTxOHash
openUtxoHash :: UTxOHash
openUtxoHash} -> UTxOHash
openUtxoHash
    CloseWithConfirmedSnapshot{UTxOHash
$sel:closeUtxoHash:CloseWithInitialSnapshot :: ClosingSnapshot -> UTxOHash
closeUtxoHash :: UTxOHash
closeUtxoHash} -> UTxOHash
closeUtxoHash

  signature :: [BuiltinByteString]
signature = case ClosingSnapshot
closing of
    CloseWithInitialSnapshot{} -> [BuiltinByteString]
forall a. Monoid a => a
mempty
    CloseWithConfirmedSnapshot{$sel:signatures:CloseWithInitialSnapshot :: ClosingSnapshot -> MultiSignature (Snapshot Tx)
signatures = MultiSignature (Snapshot Tx)
s} -> MultiSignature (Snapshot Tx) -> [BuiltinByteString]
forall {k} (a :: k). MultiSignature a -> [BuiltinByteString]
toPlutusSignatures MultiSignature (Snapshot Tx)
s

  contestationDeadline :: POSIXTime
contestationDeadline =
    POSIXTime -> ContestationPeriod -> POSIXTime
addContestationPeriod (UTCTime -> POSIXTime
posixFromUTCTime UTCTime
utcTime) ContestationPeriod
openContestationPeriod

data ContestTxError
  = InvalidHeadIdInContest {ContestTxError -> HeadId
headId :: HeadId}
  | CannotFindHeadOutputToContest
  | MissingHeadDatumInContest
  | MissingHeadRedeemerInContest
  | WrongDatumInContest
  | FailedToConvertFromScriptDataInContest
  deriving stock (Int -> ContestTxError -> ShowS
[ContestTxError] -> ShowS
ContestTxError -> String
(Int -> ContestTxError -> ShowS)
-> (ContestTxError -> String)
-> ([ContestTxError] -> ShowS)
-> Show ContestTxError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ContestTxError -> ShowS
showsPrec :: Int -> ContestTxError -> ShowS
$cshow :: ContestTxError -> String
show :: ContestTxError -> String
$cshowList :: [ContestTxError] -> ShowS
showList :: [ContestTxError] -> ShowS
Show)

-- XXX: This function is VERY similar to the 'closeTx' function (only notable
-- difference being the redeemer, which is in itself also the same structure as
-- the close's one. We could potentially refactor this to avoid repetition or do
-- something more principled at the protocol level itself and "merge" close and
-- contest as one operation.
contestTx ::
  -- | Published Hydra scripts to reference.
  ScriptRegistry ->
  -- | Party who's authorizing this transaction
  VerificationKey PaymentKey ->
  -- | Contested snapshot number (i.e. the one we contest to)
  Snapshot Tx ->
  -- | Multi-signature of the whole snapshot
  MultiSignature (Snapshot Tx) ->
  -- | Current slot and posix time to be used as the contestation time.
  PointInTime ->
  -- | Everything needed to spend the Head state-machine output.
  ClosedThreadOutput ->
  HeadId ->
  ContestationPeriod ->
  Tx
contestTx :: ScriptRegistry
-> VerificationKey PaymentKey
-> Snapshot Tx
-> MultiSignature (Snapshot Tx)
-> PointInTime
-> ClosedThreadOutput
-> HeadId
-> ContestationPeriod
-> Tx
contestTx ScriptRegistry
scriptRegistry VerificationKey PaymentKey
vk Snapshot{SnapshotNumber
number :: SnapshotNumber
$sel:number:Snapshot :: forall tx. Snapshot tx -> SnapshotNumber
number, UTxOType Tx
utxo :: UTxOType Tx
$sel:utxo:Snapshot :: forall tx. Snapshot tx -> UTxOType tx
utxo} MultiSignature (Snapshot Tx)
sig (SlotNo
slotNo, UTCTime
_) ClosedThreadOutput
closedThreadOutput HeadId
headId ContestationPeriod
contestationPeriod =
  HasCallStack => TxBodyContent BuildTx -> Tx
TxBodyContent BuildTx -> Tx
unsafeBuildTransaction (TxBodyContent BuildTx -> Tx) -> TxBodyContent BuildTx -> Tx
forall a b. (a -> b) -> a -> b
$
    TxBodyContent BuildTx
emptyTxBody
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))]
-> TxBodyContent BuildTx -> TxBodyContent BuildTx
addInputs [(TxIn
headInput, BuildTxWith BuildTx (Witness WitCtxTxIn Era)
headWitness)]
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [TxIn] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addReferenceInputs [TxIn
headScriptRef]
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [TxOut CtxTx] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addOutputs [TxOut CtxTx
headOutputAfter]
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [Hash PaymentKey] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addExtraRequiredSigners [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
& SlotNo -> TxBodyContent BuildTx -> TxBodyContent BuildTx
setValidityUpperBound SlotNo
slotNo
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& TxMetadataInEra -> TxBodyContent BuildTx -> TxBodyContent BuildTx
forall era build.
TxMetadataInEra era
-> TxBodyContent build era -> TxBodyContent build era
setTxMetadata (TxMetadata -> TxMetadataInEra
TxMetadataInEra (TxMetadata -> TxMetadataInEra) -> TxMetadata -> TxMetadataInEra
forall a b. (a -> b) -> a -> b
$ Text -> TxMetadata
mkHydraHeadV1TxName Text
"ContestTx")
 where
  ClosedThreadOutput
    { $sel:closedThreadUTxO:ClosedThreadOutput :: ClosedThreadOutput -> (TxIn, TxOut CtxUTxO)
closedThreadUTxO = (TxIn
headInput, TxOut CtxUTxO
headOutputBefore)
    , [Party]
$sel:closedParties:ClosedThreadOutput :: ClosedThreadOutput -> [Party]
closedParties :: [Party]
closedParties
    , POSIXTime
$sel:closedContestationDeadline:ClosedThreadOutput :: ClosedThreadOutput -> POSIXTime
closedContestationDeadline :: POSIXTime
closedContestationDeadline
    , [PubKeyHash]
$sel:closedContesters:ClosedThreadOutput :: ClosedThreadOutput -> [PubKeyHash]
closedContesters :: [PubKeyHash]
closedContesters
    } = ClosedThreadOutput
closedThreadOutput

  headWitness :: BuildTxWith BuildTx (Witness WitCtxTxIn Era)
headWitness =
    Witness WitCtxTxIn Era
-> BuildTxWith BuildTx (Witness WitCtxTxIn Era)
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Witness WitCtxTxIn Era
 -> BuildTxWith BuildTx (Witness WitCtxTxIn Era))
-> Witness WitCtxTxIn Era
-> BuildTxWith BuildTx (Witness WitCtxTxIn Era)
forall a b. (a -> b) -> a -> b
$
      ScriptWitnessInCtx WitCtxTxIn
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn Era
forall ctx.
ScriptWitnessInCtx ctx -> ScriptWitness ctx -> Witness ctx
ScriptWitness ScriptWitnessInCtx WitCtxTxIn
forall ctx. IsScriptWitnessInCtx ctx => ScriptWitnessInCtx ctx
scriptWitnessInCtx (ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn Era)
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn Era
forall a b. (a -> b) -> a -> b
$
        TxIn
-> PlutusScript
-> ScriptDatum WitCtxTxIn
-> ScriptRedeemer
-> ScriptWitness WitCtxTxIn
forall ctx era lang.
(IsPlutusScriptLanguage lang, HasScriptLanguageInEra lang era) =>
TxIn
-> PlutusScript lang
-> ScriptDatum ctx
-> ScriptRedeemer
-> ScriptWitness ctx era
mkScriptReference TxIn
headScriptRef PlutusScript
headScript ScriptDatum WitCtxTxIn
InlineScriptDatum ScriptRedeemer
headRedeemer
  headScriptRef :: TxIn
headScriptRef =
    (TxIn, TxOut CtxUTxO) -> TxIn
forall a b. (a, b) -> a
fst (ScriptRegistry -> (TxIn, TxOut CtxUTxO)
headReference ScriptRegistry
scriptRegistry)
  headScript :: PlutusScript
headScript =
    forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript @PlutusScriptV2 SerialisedScript
Head.validatorScript
  headRedeemer :: ScriptRedeemer
headRedeemer =
    Input -> ScriptRedeemer
forall a. ToScriptData a => a -> ScriptRedeemer
toScriptData
      Head.Contest
        { $sel:signature:CollectCom :: [BuiltinByteString]
signature = MultiSignature (Snapshot Tx) -> [BuiltinByteString]
forall {k} (a :: k). MultiSignature a -> [BuiltinByteString]
toPlutusSignatures MultiSignature (Snapshot Tx)
sig
        }
  headOutputAfter :: TxOut CtxTx
headOutputAfter =
    (TxOutDatum CtxUTxO Era -> TxOutDatum CtxTx)
-> TxOut CtxUTxO -> TxOut CtxTx
forall ctx0 era ctx1.
(TxOutDatum ctx0 era -> TxOutDatum ctx1 era)
-> TxOut ctx0 era -> TxOut ctx1 era
modifyTxOutDatum (TxOutDatum CtxTx -> TxOutDatum CtxUTxO Era -> TxOutDatum CtxTx
forall a b. a -> b -> a
const TxOutDatum CtxTx
headDatumAfter) TxOut CtxUTxO
headOutputBefore

  contester :: PubKeyHash
contester = Hash PaymentKey -> PubKeyHash
toPlutusKeyHash (VerificationKey PaymentKey -> Hash PaymentKey
forall keyrole.
Key keyrole =>
VerificationKey keyrole -> Hash keyrole
verificationKeyHash VerificationKey PaymentKey
vk)

  onChainConstestationPeriod :: ContestationPeriod
onChainConstestationPeriod = ContestationPeriod -> ContestationPeriod
toChain ContestationPeriod
contestationPeriod

  newContestationDeadline :: POSIXTime
newContestationDeadline =
    if [PubKeyHash] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (PubKeyHash
contester PubKeyHash -> [PubKeyHash] -> [PubKeyHash]
forall a. a -> [a] -> [a]
: [PubKeyHash]
closedContesters) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Party] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Party]
closedParties
      then POSIXTime
closedContestationDeadline
      else POSIXTime -> ContestationPeriod -> POSIXTime
addContestationPeriod POSIXTime
closedContestationDeadline ContestationPeriod
onChainConstestationPeriod

  headDatumAfter :: TxOutDatum CtxTx
headDatumAfter =
    State -> TxOutDatum CtxTx
forall era a ctx.
(ToScriptData a, IsBabbageEraOnwards era) =>
a -> TxOutDatum ctx era
mkTxOutDatumInline
      Head.Closed
        { $sel:snapshotNumber:Initial :: Integer
snapshotNumber = SnapshotNumber -> Integer
forall a. Integral a => a -> Integer
toInteger SnapshotNumber
number
        , BuiltinByteString
$sel:utxoHash:Initial :: BuiltinByteString
utxoHash :: BuiltinByteString
utxoHash
        , $sel:parties:Initial :: [Party]
parties = [Party]
closedParties
        , $sel:contestationDeadline:Initial :: POSIXTime
contestationDeadline = POSIXTime
newContestationDeadline
        , $sel:contestationPeriod:Initial :: ContestationPeriod
contestationPeriod = ContestationPeriod
onChainConstestationPeriod
        , $sel:headId:Initial :: CurrencySymbol
headId = HeadId -> CurrencySymbol
headIdToCurrencySymbol HeadId
headId
        , $sel:contesters:Initial :: [PubKeyHash]
contesters = PubKeyHash
contester PubKeyHash -> [PubKeyHash] -> [PubKeyHash]
forall a. a -> [a] -> [a]
: [PubKeyHash]
closedContesters
        }
  utxoHash :: BuiltinByteString
utxoHash = ByteString -> BuiltinByteString
forall a arep. ToBuiltin a arep => a -> arep
toBuiltin (ByteString -> BuiltinByteString)
-> ByteString -> BuiltinByteString
forall a b. (a -> b) -> a -> b
$ forall tx. IsTx tx => UTxOType tx -> ByteString
hashUTxO @Tx UTxOType Tx
utxo

data FanoutTxError
  = CannotFindHeadOutputToFanout
  | MissingHeadDatumInFanout
  | WrongDatumInFanout
  | FailedToConvertFromScriptDataInFanout
  deriving stock (Int -> FanoutTxError -> ShowS
[FanoutTxError] -> ShowS
FanoutTxError -> String
(Int -> FanoutTxError -> ShowS)
-> (FanoutTxError -> String)
-> ([FanoutTxError] -> ShowS)
-> Show FanoutTxError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FanoutTxError -> ShowS
showsPrec :: Int -> FanoutTxError -> ShowS
$cshow :: FanoutTxError -> String
show :: FanoutTxError -> String
$cshowList :: [FanoutTxError] -> ShowS
showList :: [FanoutTxError] -> ShowS
Show)

-- | Create the fanout transaction, which distributes the closed state
-- accordingly. The head validator allows fanout only > deadline, so we need
-- to set the lower bound to be deadline + 1 slot.
fanoutTx ::
  -- | Published Hydra scripts to reference.
  ScriptRegistry ->
  -- | Snapshotted UTxO to fanout on layer 1
  UTxO ->
  -- | Everything needed to spend the Head state-machine output.
  (TxIn, TxOut CtxUTxO) ->
  -- | Contestation deadline as SlotNo, used to set lower tx validity bound.
  SlotNo ->
  -- | Minting Policy script, made from initial seed
  PlutusScript ->
  Tx
fanoutTx :: ScriptRegistry
-> UTxO' (TxOut CtxUTxO)
-> (TxIn, TxOut CtxUTxO)
-> SlotNo
-> PlutusScript
-> Tx
fanoutTx ScriptRegistry
scriptRegistry UTxO' (TxOut CtxUTxO)
utxo (TxIn
headInput, TxOut CtxUTxO
headOutput) SlotNo
deadlineSlotNo PlutusScript
headTokenScript =
  HasCallStack => TxBodyContent BuildTx -> Tx
TxBodyContent BuildTx -> Tx
unsafeBuildTransaction (TxBodyContent BuildTx -> Tx) -> TxBodyContent BuildTx -> Tx
forall a b. (a -> b) -> a -> b
$
    TxBodyContent BuildTx
emptyTxBody
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))]
-> TxBodyContent BuildTx -> TxBodyContent BuildTx
addInputs [(TxIn
headInput, BuildTxWith BuildTx (Witness WitCtxTxIn Era)
headWitness)]
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [TxIn] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addReferenceInputs [TxIn
headScriptRef]
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [TxOut CtxTx] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addOutputs [TxOut CtxTx]
orderedTxOutsToFanout
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& PlutusScript
-> MintAction
-> [(AssetName, Quantity)]
-> TxBodyContent BuildTx
-> TxBodyContent BuildTx
forall redeemer.
ToScriptData redeemer =>
PlutusScript
-> redeemer
-> [(AssetName, Quantity)]
-> TxBodyContent BuildTx
-> TxBodyContent BuildTx
burnTokens PlutusScript
headTokenScript MintAction
Burn [(AssetName, Quantity)]
headTokens
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& SlotNo -> TxBodyContent BuildTx -> TxBodyContent BuildTx
setValidityLowerBound (SlotNo
deadlineSlotNo SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
1)
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& TxMetadataInEra -> TxBodyContent BuildTx -> TxBodyContent BuildTx
forall era build.
TxMetadataInEra era
-> TxBodyContent build era -> TxBodyContent build era
setTxMetadata (TxMetadata -> TxMetadataInEra
TxMetadataInEra (TxMetadata -> TxMetadataInEra) -> TxMetadata -> TxMetadataInEra
forall a b. (a -> b) -> a -> b
$ Text -> TxMetadata
mkHydraHeadV1TxName Text
"FanoutTx")
 where
  headWitness :: BuildTxWith BuildTx (Witness WitCtxTxIn Era)
headWitness =
    Witness WitCtxTxIn Era
-> BuildTxWith BuildTx (Witness WitCtxTxIn Era)
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Witness WitCtxTxIn Era
 -> BuildTxWith BuildTx (Witness WitCtxTxIn Era))
-> Witness WitCtxTxIn Era
-> BuildTxWith BuildTx (Witness WitCtxTxIn Era)
forall a b. (a -> b) -> a -> b
$
      ScriptWitnessInCtx WitCtxTxIn
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn Era
forall ctx.
ScriptWitnessInCtx ctx -> ScriptWitness ctx -> Witness ctx
ScriptWitness ScriptWitnessInCtx WitCtxTxIn
forall ctx. IsScriptWitnessInCtx ctx => ScriptWitnessInCtx ctx
scriptWitnessInCtx (ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn Era)
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn Era
forall a b. (a -> b) -> a -> b
$
        TxIn
-> PlutusScript
-> ScriptDatum WitCtxTxIn
-> ScriptRedeemer
-> ScriptWitness WitCtxTxIn
forall ctx era lang.
(IsPlutusScriptLanguage lang, HasScriptLanguageInEra lang era) =>
TxIn
-> PlutusScript lang
-> ScriptDatum ctx
-> ScriptRedeemer
-> ScriptWitness ctx era
mkScriptReference TxIn
headScriptRef PlutusScript
headScript ScriptDatum WitCtxTxIn
InlineScriptDatum ScriptRedeemer
headRedeemer
  headScriptRef :: TxIn
headScriptRef =
    (TxIn, TxOut CtxUTxO) -> TxIn
forall a b. (a, b) -> a
fst (ScriptRegistry -> (TxIn, TxOut CtxUTxO)
headReference ScriptRegistry
scriptRegistry)
  headScript :: PlutusScript
headScript =
    forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript @PlutusScriptV2 SerialisedScript
Head.validatorScript
  headRedeemer :: ScriptRedeemer
headRedeemer =
    Input -> ScriptRedeemer
forall a. ToScriptData a => a -> ScriptRedeemer
toScriptData (Integer -> Input
Head.Fanout (Integer -> Input) -> Integer -> Input
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ UTxO' (TxOut CtxUTxO) -> Int
forall a. UTxO' a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length UTxO' (TxOut CtxUTxO)
utxo)

  headTokens :: [(AssetName, Quantity)]
headTokens =
    PlutusScript -> Value -> [(AssetName, Quantity)]
headTokensFromValue PlutusScript
headTokenScript (TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO
headOutput)

  orderedTxOutsToFanout :: [TxOut CtxTx]
orderedTxOutsToFanout =
    TxOut CtxUTxO -> TxOut CtxTx
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 -> TxOut CtxTx) -> [TxOut CtxUTxO] -> [TxOut CtxTx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxO' (TxOut CtxUTxO) -> [TxOut CtxUTxO]
forall a. UTxO' a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList UTxO' (TxOut CtxUTxO)
utxo

data AbortTxError
  = OverlappingInputs
  | CannotFindHeadOutputToAbort
  deriving stock (Int -> AbortTxError -> ShowS
[AbortTxError] -> ShowS
AbortTxError -> String
(Int -> AbortTxError -> ShowS)
-> (AbortTxError -> String)
-> ([AbortTxError] -> ShowS)
-> Show AbortTxError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AbortTxError -> ShowS
showsPrec :: Int -> AbortTxError -> ShowS
$cshow :: AbortTxError -> String
show :: AbortTxError -> String
$cshowList :: [AbortTxError] -> ShowS
showList :: [AbortTxError] -> ShowS
Show)

-- | Create transaction which aborts a head by spending the Head output and all
-- other "initial" outputs.
abortTx ::
  -- | Committed UTxOs to reimburse.
  UTxO ->
  -- | Published Hydra scripts to reference.
  ScriptRegistry ->
  -- | Party who's authorizing this transaction
  VerificationKey PaymentKey ->
  -- | Everything needed to spend the Head state-machine output.
  (TxIn, TxOut CtxUTxO) ->
  -- | Script for monetary policy to burn tokens
  PlutusScript ->
  -- | Data needed to spend the initial output sent to each party to the Head.
  -- Should contain the PT and is locked by initial script.
  Map TxIn (TxOut CtxUTxO) ->
  -- | Data needed to spend commit outputs.
  -- Should contain the PT and is locked by commit script.
  Map TxIn (TxOut CtxUTxO) ->
  Either AbortTxError Tx
abortTx :: UTxO' (TxOut CtxUTxO)
-> ScriptRegistry
-> VerificationKey PaymentKey
-> (TxIn, TxOut CtxUTxO)
-> PlutusScript
-> Map TxIn (TxOut CtxUTxO)
-> Map TxIn (TxOut CtxUTxO)
-> Either AbortTxError Tx
abortTx UTxO' (TxOut CtxUTxO)
committedUTxO ScriptRegistry
scriptRegistry VerificationKey PaymentKey
vk (TxIn
headInput, TxOut CtxUTxO
initialHeadOutput) PlutusScript
headTokenScript Map TxIn (TxOut CtxUTxO)
initialsToAbort Map TxIn (TxOut CtxUTxO)
commitsToAbort
  | Maybe (TxOut CtxUTxO) -> Bool
forall a. Maybe a -> Bool
isJust (Key (Map TxIn (TxOut CtxUTxO))
-> Map TxIn (TxOut CtxUTxO)
-> Maybe (Val (Map TxIn (TxOut CtxUTxO)))
forall t. StaticMap t => Key t -> t -> Maybe (Val t)
lookup Key (Map TxIn (TxOut CtxUTxO))
TxIn
headInput Map TxIn (TxOut CtxUTxO)
initialsToAbort) =
      AbortTxError -> Either AbortTxError Tx
forall a b. a -> Either a b
Left AbortTxError
OverlappingInputs
  | Bool
otherwise =
      Tx -> Either AbortTxError Tx
forall a b. b -> Either a b
Right (Tx -> Either AbortTxError Tx) -> Tx -> Either AbortTxError Tx
forall a b. (a -> b) -> a -> b
$
        HasCallStack => TxBodyContent BuildTx -> Tx
TxBodyContent BuildTx -> Tx
unsafeBuildTransaction (TxBodyContent BuildTx -> Tx) -> TxBodyContent BuildTx -> Tx
forall a b. (a -> b) -> a -> b
$
          TxBodyContent BuildTx
emptyTxBody
            TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))]
-> TxBodyContent BuildTx -> TxBodyContent BuildTx
addInputs ((TxIn
headInput, BuildTxWith BuildTx (Witness WitCtxTxIn Era)
headWitness) (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))
-> [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))]
-> [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))]
forall a. a -> [a] -> [a]
: [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))]
initialInputs [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))]
-> [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))]
-> [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))]
forall a. Semigroup a => a -> a -> a
<> [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))]
commitInputs)
            TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [TxIn] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addReferenceInputs [TxIn
initialScriptRef, TxIn
commitScriptRef, TxIn
headScriptRef]
            TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [TxOut CtxTx] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addOutputs [TxOut CtxTx]
reimbursedOutputs
            TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& PlutusScript
-> MintAction
-> [(AssetName, Quantity)]
-> TxBodyContent BuildTx
-> TxBodyContent BuildTx
forall redeemer.
ToScriptData redeemer =>
PlutusScript
-> redeemer
-> [(AssetName, Quantity)]
-> TxBodyContent BuildTx
-> TxBodyContent BuildTx
burnTokens PlutusScript
headTokenScript MintAction
Burn [(AssetName, Quantity)]
headTokens
            TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [Hash PaymentKey] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addExtraRequiredSigners [VerificationKey PaymentKey -> Hash PaymentKey
forall keyrole.
Key keyrole =>
VerificationKey keyrole -> Hash keyrole
verificationKeyHash VerificationKey PaymentKey
vk]
 where
  headWitness :: BuildTxWith BuildTx (Witness WitCtxTxIn Era)
headWitness =
    Witness WitCtxTxIn Era
-> BuildTxWith BuildTx (Witness WitCtxTxIn Era)
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Witness WitCtxTxIn Era
 -> BuildTxWith BuildTx (Witness WitCtxTxIn Era))
-> Witness WitCtxTxIn Era
-> BuildTxWith BuildTx (Witness WitCtxTxIn Era)
forall a b. (a -> b) -> a -> b
$
      ScriptWitnessInCtx WitCtxTxIn
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn Era
forall ctx.
ScriptWitnessInCtx ctx -> ScriptWitness ctx -> Witness ctx
ScriptWitness ScriptWitnessInCtx WitCtxTxIn
forall ctx. IsScriptWitnessInCtx ctx => ScriptWitnessInCtx ctx
scriptWitnessInCtx (ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn Era)
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn Era
forall a b. (a -> b) -> a -> b
$
        TxIn
-> PlutusScript
-> ScriptDatum WitCtxTxIn
-> ScriptRedeemer
-> ScriptWitness WitCtxTxIn
forall ctx era lang.
(IsPlutusScriptLanguage lang, HasScriptLanguageInEra lang era) =>
TxIn
-> PlutusScript lang
-> ScriptDatum ctx
-> ScriptRedeemer
-> ScriptWitness ctx era
mkScriptReference TxIn
headScriptRef PlutusScript
headScript ScriptDatum WitCtxTxIn
InlineScriptDatum ScriptRedeemer
headRedeemer
  headScriptRef :: TxIn
headScriptRef =
    (TxIn, TxOut CtxUTxO) -> TxIn
forall a b. (a, b) -> a
fst (ScriptRegistry -> (TxIn, TxOut CtxUTxO)
headReference ScriptRegistry
scriptRegistry)
  headScript :: PlutusScript
headScript =
    forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript @PlutusScriptV2 SerialisedScript
Head.validatorScript
  headRedeemer :: ScriptRedeemer
headRedeemer =
    Input -> ScriptRedeemer
forall a. ToScriptData a => a -> ScriptRedeemer
toScriptData Input
Head.Abort

  initialInputs :: [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))]
initialInputs = TxIn -> (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))
mkAbortInitial (TxIn -> (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era)))
-> [TxIn] -> [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn 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)
initialsToAbort

  commitInputs :: [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))]
commitInputs = TxIn -> (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))
mkAbortCommit (TxIn -> (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era)))
-> [TxIn] -> [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn 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)
commitsToAbort

  headTokens :: [(AssetName, Quantity)]
headTokens =
    PlutusScript -> Value -> [(AssetName, Quantity)]
headTokensFromValue PlutusScript
headTokenScript (Value -> [(AssetName, Quantity)])
-> Value -> [(AssetName, Quantity)]
forall a b. (a -> b) -> a -> b
$
      [Value] -> Value
forall a. Monoid a => [a] -> a
mconcat
        [ TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxUTxO
initialHeadOutput
        , (TxOut CtxUTxO -> Value) -> Map TxIn (TxOut CtxUTxO) -> Value
forall m a. Monoid m => (a -> m) -> Map TxIn a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue Map TxIn (TxOut CtxUTxO)
initialsToAbort
        , (TxOut CtxUTxO -> Value) -> Map TxIn (TxOut CtxUTxO) -> Value
forall m a. Monoid m => (a -> m) -> Map TxIn a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue Map TxIn (TxOut CtxUTxO)
commitsToAbort
        ]

  mkAbortInitial :: TxIn -> (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))
mkAbortInitial TxIn
initialInput = (TxIn
initialInput, BuildTxWith BuildTx (Witness WitCtxTxIn Era)
abortInitialWitness)
  abortInitialWitness :: BuildTxWith BuildTx (Witness WitCtxTxIn Era)
abortInitialWitness =
    Witness WitCtxTxIn Era
-> BuildTxWith BuildTx (Witness WitCtxTxIn Era)
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Witness WitCtxTxIn Era
 -> BuildTxWith BuildTx (Witness WitCtxTxIn Era))
-> Witness WitCtxTxIn Era
-> BuildTxWith BuildTx (Witness WitCtxTxIn Era)
forall a b. (a -> b) -> a -> b
$
      ScriptWitnessInCtx WitCtxTxIn
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn Era
forall ctx.
ScriptWitnessInCtx ctx -> ScriptWitness ctx -> Witness ctx
ScriptWitness ScriptWitnessInCtx WitCtxTxIn
forall ctx. IsScriptWitnessInCtx ctx => ScriptWitnessInCtx ctx
scriptWitnessInCtx (ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn Era)
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn Era
forall a b. (a -> b) -> a -> b
$
        TxIn
-> PlutusScript
-> ScriptDatum WitCtxTxIn
-> ScriptRedeemer
-> ScriptWitness WitCtxTxIn
forall ctx era lang.
(IsPlutusScriptLanguage lang, HasScriptLanguageInEra lang era) =>
TxIn
-> PlutusScript lang
-> ScriptDatum ctx
-> ScriptRedeemer
-> ScriptWitness ctx era
mkScriptReference TxIn
initialScriptRef PlutusScript
initialScript ScriptDatum WitCtxTxIn
InlineScriptDatum ScriptRedeemer
initialRedeemer
  initialScriptRef :: TxIn
initialScriptRef =
    (TxIn, TxOut CtxUTxO) -> TxIn
forall a b. (a, b) -> a
fst (ScriptRegistry -> (TxIn, TxOut CtxUTxO)
initialReference ScriptRegistry
scriptRegistry)
  initialScript :: PlutusScript
initialScript =
    forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript @PlutusScriptV2 SerialisedScript
Initial.validatorScript
  initialRedeemer :: ScriptRedeemer
initialRedeemer =
    Redeemer -> ScriptRedeemer
forall a. ToScriptData a => a -> ScriptRedeemer
toScriptData (Redeemer -> ScriptRedeemer) -> Redeemer -> ScriptRedeemer
forall a b. (a -> b) -> a -> b
$ InitialRedeemer -> Redeemer
Initial.redeemer InitialRedeemer
Initial.ViaAbort

  mkAbortCommit :: TxIn -> (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn Era))
mkAbortCommit TxIn
commitInput = (TxIn
commitInput, BuildTxWith BuildTx (Witness WitCtxTxIn Era)
abortCommitWitness)
  abortCommitWitness :: BuildTxWith BuildTx (Witness WitCtxTxIn Era)
abortCommitWitness =
    Witness WitCtxTxIn Era
-> BuildTxWith BuildTx (Witness WitCtxTxIn Era)
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Witness WitCtxTxIn Era
 -> BuildTxWith BuildTx (Witness WitCtxTxIn Era))
-> Witness WitCtxTxIn Era
-> BuildTxWith BuildTx (Witness WitCtxTxIn Era)
forall a b. (a -> b) -> a -> b
$
      ScriptWitnessInCtx WitCtxTxIn
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn Era
forall ctx.
ScriptWitnessInCtx ctx -> ScriptWitness ctx -> Witness ctx
ScriptWitness ScriptWitnessInCtx WitCtxTxIn
forall ctx. IsScriptWitnessInCtx ctx => ScriptWitnessInCtx ctx
scriptWitnessInCtx (ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn Era)
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn Era
forall a b. (a -> b) -> a -> b
$
        TxIn
-> PlutusScript
-> ScriptDatum WitCtxTxIn
-> ScriptRedeemer
-> ScriptWitness WitCtxTxIn
forall ctx era lang.
(IsPlutusScriptLanguage lang, HasScriptLanguageInEra lang era) =>
TxIn
-> PlutusScript lang
-> ScriptDatum ctx
-> ScriptRedeemer
-> ScriptWitness ctx era
mkScriptReference TxIn
commitScriptRef PlutusScript
commitScript ScriptDatum WitCtxTxIn
InlineScriptDatum ScriptRedeemer
commitRedeemer
  commitScriptRef :: TxIn
commitScriptRef =
    (TxIn, TxOut CtxUTxO) -> TxIn
forall a b. (a, b) -> a
fst (ScriptRegistry -> (TxIn, TxOut CtxUTxO)
commitReference ScriptRegistry
scriptRegistry)
  commitScript :: PlutusScript
commitScript =
    forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript @PlutusScriptV2 SerialisedScript
Commit.validatorScript
  commitRedeemer :: ScriptRedeemer
commitRedeemer =
    Redeemer -> ScriptRedeemer
forall a. ToScriptData a => a -> ScriptRedeemer
toScriptData (RedeemerType -> Redeemer
Commit.redeemer RedeemerType
Commit.ViaAbort)

  reimbursedOutputs :: [TxOut CtxTx]
reimbursedOutputs = TxOut CtxUTxO -> TxOut CtxTx
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 -> TxOut CtxTx)
-> ((TxIn, TxOut CtxUTxO) -> TxOut CtxUTxO)
-> (TxIn, TxOut CtxUTxO)
-> TxOut CtxTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxIn, TxOut CtxUTxO) -> TxOut CtxUTxO
forall a b. (a, b) -> b
snd ((TxIn, TxOut CtxUTxO) -> TxOut CtxTx)
-> [(TxIn, TxOut CtxUTxO)] -> [TxOut CtxTx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTxO' (TxOut CtxUTxO) -> [(TxIn, TxOut CtxUTxO)]
forall out. UTxO' out -> [(TxIn, out)]
UTxO.pairs UTxO' (TxOut CtxUTxO)
committedUTxO

-- * Observe Hydra Head transactions

-- | Generalised type for arbitrary Head observations on-chain.
data HeadObservation
  = NoHeadTx
  | Init InitObservation
  | Abort AbortObservation
  | Commit CommitObservation
  | CollectCom CollectComObservation
  | 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' (TxOut CtxUTxO) -> Tx -> HeadObservation
observeHeadTx NetworkId
networkId UTxO' (TxOut CtxUTxO)
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' (TxOut CtxUTxO) -> Tx -> Maybe AbortObservation
observeAbortTx UTxO' (TxOut CtxUTxO)
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' (TxOut CtxUTxO) -> Tx -> Maybe CommitObservation
observeCommitTx NetworkId
networkId UTxO' (TxOut CtxUTxO)
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' (TxOut CtxUTxO) -> Tx -> Maybe CollectComObservation
observeCollectComTx UTxO' (TxOut CtxUTxO)
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' (TxOut CtxUTxO) -> Tx -> Maybe CloseObservation
observeCloseTx UTxO' (TxOut CtxUTxO)
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' (TxOut CtxUTxO) -> Tx -> Maybe ContestObservation
observeContestTx UTxO' (TxOut CtxUTxO)
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' (TxOut CtxUTxO) -> Tx -> Maybe FanoutObservation
observeFanoutTx UTxO' (TxOut CtxUTxO)
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
headOut, State
headState) <-
    NotAnInitReason
-> Maybe (Word, TxOut CtxTx, State)
-> Either NotAnInitReason (Word, TxOut CtxTx, State)
forall {a} {b}. a -> Maybe b -> Either a b
maybeLeft NotAnInitReason
NoHeadOutput (Maybe (Word, TxOut CtxTx, State)
 -> Either NotAnInitReason (Word, TxOut CtxTx, State))
-> Maybe (Word, TxOut CtxTx, State)
-> Either NotAnInitReason (Word, TxOut CtxTx, State)
forall a b. (a -> b) -> a -> b
$
      ((Word, TxOut CtxTx) -> Maybe (Word, TxOut CtxTx, State))
-> [(Word, TxOut CtxTx)] -> Maybe (Word, TxOut CtxTx, State)
forall (t :: * -> *) a b.
Foldable t =>
(a -> Maybe b) -> t a -> Maybe b
findFirst (Word, TxOut CtxTx) -> Maybe (Word, TxOut CtxTx, State)
forall {a} {t} {era}.
FromData a =>
(t, TxOut CtxTx era) -> Maybe (t, TxOut CtxTx era, a)
matchHeadOutput [(Word, TxOut CtxTx)]
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 -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut CtxTx
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 -> TxOut CtxUTxO
forall era. TxOut CtxTx era -> TxOut CtxUTxO era
toCtxUTxOTxOut TxOut CtxTx
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 -> TxOut CtxTx era -> Bool
forall lang ctx era.
IsPlutusScriptLanguage lang =>
PlutusScript lang -> TxOut ctx era -> Bool
isScriptTxOut PlutusScript
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
<$> (ScriptRedeemer -> Maybe a
forall a. FromScriptData a => ScriptRedeemer -> Maybe a
fromScriptData (ScriptRedeemer -> Maybe a) -> Maybe ScriptRedeemer -> Maybe a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TxOut CtxTx era -> Maybe ScriptRedeemer
forall era. TxOut CtxTx era -> Maybe ScriptRedeemer
txOutScriptData TxOut CtxTx era
out)

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

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

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

  initials :: [(TxIn, TxOut CtxUTxO)]
initials =
    ((Word, TxOut CtxTx) -> (TxIn, TxOut CtxUTxO))
-> [(Word, TxOut CtxTx)] -> [(TxIn, TxOut CtxUTxO)]
forall a b. (a -> b) -> [a] -> [b]
map
      ((Word -> TxIn)
-> (TxOut CtxTx -> TxOut CtxUTxO)
-> (Word, TxOut CtxTx)
-> (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 -> TxOut CtxUTxO
forall era. TxOut CtxTx era -> TxOut CtxUTxO era
toCtxUTxOTxOut)
      [(Word, TxOut CtxTx)]
initialOutputs

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

  initialScript :: PlutusScript
initialScript = forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript @PlutusScriptV2 SerialisedScript
Initial.validatorScript

  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' (TxOut CtxUTxO)
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' (TxOut CtxUTxO) -> Tx -> Maybe CommitObservation
observeCommitTx NetworkId
networkId UTxO' (TxOut CtxUTxO)
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
commitOut) <- AddressInEra -> Tx -> Maybe (TxIn, TxOut CtxTx)
forall era.
AddressInEra era -> Tx era -> Maybe (TxIn, TxOut CtxTx era)
findTxOutByAddress AddressInEra
commitAddress Tx
tx
  ScriptRedeemer
dat <- TxOut CtxTx -> Maybe ScriptRedeemer
forall era. TxOut CtxTx era -> Maybe ScriptRedeemer
txOutScriptData TxOut CtxTx
commitOut
  (Party
onChainParty, [Commit]
onChainCommits, CurrencySymbol
headId) :: Commit.DatumType <- ScriptRedeemer -> Maybe DatumType
forall a. FromScriptData a => ScriptRedeemer -> Maybe a
fromScriptData ScriptRedeemer
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' (TxOut CtxUTxO)
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' (TxOut CtxUTxO) -> Maybe (UTxO' (TxOut CtxUTxO))
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTxO' (TxOut CtxUTxO) -> Maybe (UTxO' (TxOut CtxUTxO)))
-> ([(TxIn, TxOut CtxUTxO)] -> UTxO' (TxOut CtxUTxO))
-> [(TxIn, TxOut CtxUTxO)]
-> Maybe (UTxO' (TxOut CtxUTxO))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(TxIn, TxOut CtxUTxO)] -> UTxO' (TxOut CtxUTxO)
forall out. [(TxIn, out)] -> UTxO' out
UTxO.fromPairs ([(TxIn, TxOut CtxUTxO)] -> Maybe (UTxO' (TxOut CtxUTxO)))
-> [(TxIn, TxOut CtxUTxO)] -> Maybe (UTxO' (TxOut CtxUTxO))
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 -> 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
commitOut)
      , Party
$sel:party:CommitObservation :: Party
party :: Party
party
      , UTxO' (TxOut CtxUTxO)
$sel:committed:CommitObservation :: UTxO' (TxOut CtxUTxO)
committed :: UTxO' (TxOut CtxUTxO)
committed
      , $sel:headId:CommitObservation :: HeadId
headId = PolicyId -> HeadId
mkHeadId PolicyId
policyId
      }
 where
  isSpendingFromInitial :: Bool
  isSpendingFromInitial :: Bool
isSpendingFromInitial =
    (TxOut CtxUTxO -> Bool) -> UTxO' (TxOut CtxUTxO) -> 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' (TxOut CtxUTxO) -> Tx -> UTxO' (TxOut CtxUTxO)
resolveInputsUTxO UTxO' (TxOut CtxUTxO)
utxo Tx
tx)

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

  initialScript :: PlutusScript lang
initialScript = SerialisedScript -> PlutusScript lang
forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript SerialisedScript
Initial.validatorScript

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

  commitScript :: PlutusScript lang
commitScript = SerialisedScript -> PlutusScript lang
forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript SerialisedScript
Commit.validatorScript

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' (TxOut CtxUTxO) -> Tx -> Maybe CollectComObservation
observeCollectComTx UTxO' (TxOut CtxUTxO)
utxo Tx
tx = do
  let inputUTxO :: UTxO' (TxOut CtxUTxO)
inputUTxO = UTxO' (TxOut CtxUTxO) -> Tx -> UTxO' (TxOut CtxUTxO)
resolveInputsUTxO UTxO' (TxOut CtxUTxO)
utxo Tx
tx
  (TxIn
headInput, TxOut CtxUTxO
headOutput) <- forall lang.
IsPlutusScriptLanguage lang =>
UTxO' (TxOut CtxUTxO)
-> PlutusScript lang -> Maybe (TxIn, TxOut CtxUTxO)
findTxOutByScript @PlutusScriptV2 UTxO' (TxOut CtxUTxO)
inputUTxO PlutusScript
forall {lang}. PlutusScript lang
headScript
  Input
redeemer <- Tx -> TxIn -> Maybe Input
forall a. FromData a => Tx -> TxIn -> Maybe a
findRedeemerSpending Tx
tx TxIn
headInput
  ScriptRedeemer
oldHeadDatum <- TxOut CtxTx -> Maybe ScriptRedeemer
forall era. TxOut CtxTx era -> Maybe ScriptRedeemer
txOutScriptData (TxOut CtxTx -> Maybe ScriptRedeemer)
-> TxOut CtxTx -> Maybe ScriptRedeemer
forall a b. (a -> b) -> a -> b
$ TxOut CtxUTxO -> TxOut CtxTx
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 <- ScriptRedeemer -> Maybe State
forall a. FromScriptData a => ScriptRedeemer -> Maybe a
fromScriptData ScriptRedeemer
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]
$sel:parties:Initial :: State -> [Party]
parties :: [Party]
parties, ContestationPeriod
$sel:contestationPeriod:Initial :: State -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod}, Input
Head.CollectCom) -> do
      (TxIn
newHeadInput, TxOut CtxUTxO
newHeadOutput) <- forall lang.
IsPlutusScriptLanguage lang =>
UTxO' (TxOut CtxUTxO)
-> PlutusScript lang -> Maybe (TxIn, TxOut CtxUTxO)
findTxOutByScript @PlutusScriptV2 (Tx -> UTxO' (TxOut CtxUTxO)
utxoFromTx Tx
tx) PlutusScript
forall {lang}. PlutusScript lang
headScript
      ScriptRedeemer
newHeadDatum <- TxOut CtxTx -> Maybe ScriptRedeemer
forall era. TxOut CtxTx era -> Maybe ScriptRedeemer
txOutScriptData (TxOut CtxTx -> Maybe ScriptRedeemer)
-> TxOut CtxTx -> Maybe ScriptRedeemer
forall a b. (a -> b) -> a -> b
$ TxOut CtxUTxO -> TxOut CtxTx
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
<$> ScriptRedeemer -> Maybe ByteString
decodeUtxoHash ScriptRedeemer
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 :: ScriptRedeemer -> Maybe ByteString
decodeUtxoHash ScriptRedeemer
datum =
    case ScriptRedeemer -> Maybe State
forall a. FromScriptData a => ScriptRedeemer -> Maybe a
fromScriptData ScriptRedeemer
datum of
      Just Head.Open{BuiltinByteString
$sel:utxoHash:Initial :: State -> BuiltinByteString
utxoHash :: BuiltinByteString
utxoHash} -> ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ BuiltinByteString -> ByteString
forall arep a. FromBuiltin arep a => arep -> a
fromBuiltin BuiltinByteString
utxoHash
      Maybe State
_ -> Maybe ByteString
forall a. Maybe a
Nothing

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' (TxOut CtxUTxO) -> Tx -> Maybe CloseObservation
observeCloseTx UTxO' (TxOut CtxUTxO)
utxo Tx
tx = do
  let inputUTxO :: UTxO' (TxOut CtxUTxO)
inputUTxO = UTxO' (TxOut CtxUTxO) -> Tx -> UTxO' (TxOut CtxUTxO)
resolveInputsUTxO UTxO' (TxOut CtxUTxO)
utxo Tx
tx
  (TxIn
headInput, TxOut CtxUTxO
headOutput) <- forall lang.
IsPlutusScriptLanguage lang =>
UTxO' (TxOut CtxUTxO)
-> PlutusScript lang -> Maybe (TxIn, TxOut CtxUTxO)
findTxOutByScript @PlutusScriptV2 UTxO' (TxOut CtxUTxO)
inputUTxO PlutusScript
forall {lang}. PlutusScript lang
headScript
  Input
redeemer <- Tx -> TxIn -> Maybe Input
forall a. FromData a => Tx -> TxIn -> Maybe a
findRedeemerSpending Tx
tx TxIn
headInput
  ScriptRedeemer
oldHeadDatum <- TxOut CtxTx -> Maybe ScriptRedeemer
forall era. TxOut CtxTx era -> Maybe ScriptRedeemer
txOutScriptData (TxOut CtxTx -> Maybe ScriptRedeemer)
-> TxOut CtxTx -> Maybe ScriptRedeemer
forall a b. (a -> b) -> a -> b
$ TxOut CtxUTxO -> TxOut CtxTx
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 <- ScriptRedeemer -> Maybe State
forall a. FromScriptData a => ScriptRedeemer -> Maybe a
fromScriptData ScriptRedeemer
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{[Party]
$sel:parties:Initial :: State -> [Party]
parties :: [Party]
parties}, Head.Close{}) -> do
      (TxIn
newHeadInput, TxOut CtxUTxO
newHeadOutput) <- forall lang.
IsPlutusScriptLanguage lang =>
UTxO' (TxOut CtxUTxO)
-> PlutusScript lang -> Maybe (TxIn, TxOut CtxUTxO)
findTxOutByScript @PlutusScriptV2 (Tx -> UTxO' (TxOut CtxUTxO)
utxoFromTx Tx
tx) PlutusScript
forall {lang}. PlutusScript lang
headScript
      ScriptRedeemer
newHeadDatum <- TxOut CtxTx -> Maybe ScriptRedeemer
forall era. TxOut CtxTx era -> Maybe ScriptRedeemer
txOutScriptData (TxOut CtxTx -> Maybe ScriptRedeemer)
-> TxOut CtxTx -> Maybe ScriptRedeemer
forall a b. (a -> b) -> a -> b
$ TxOut CtxUTxO -> TxOut CtxTx
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 ScriptRedeemer -> Maybe State
forall a. FromScriptData a => ScriptRedeemer -> Maybe a
fromScriptData ScriptRedeemer
newHeadDatum of
        Just Head.Closed{POSIXTime
$sel:contestationDeadline:Initial :: State -> POSIXTime
contestationDeadline :: POSIXTime
contestationDeadline, Integer
$sel:snapshotNumber:Initial :: State -> Integer
snapshotNumber :: 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
fromChainSnapshot 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' (TxOut CtxUTxO) -> Tx -> Maybe ContestObservation
observeContestTx UTxO' (TxOut CtxUTxO)
utxo Tx
tx = do
  let inputUTxO :: UTxO' (TxOut CtxUTxO)
inputUTxO = UTxO' (TxOut CtxUTxO) -> Tx -> UTxO' (TxOut CtxUTxO)
resolveInputsUTxO UTxO' (TxOut CtxUTxO)
utxo Tx
tx
  (TxIn
headInput, TxOut CtxUTxO
headOutput) <- forall lang.
IsPlutusScriptLanguage lang =>
UTxO' (TxOut CtxUTxO)
-> PlutusScript lang -> Maybe (TxIn, TxOut CtxUTxO)
findTxOutByScript @PlutusScriptV2 UTxO' (TxOut CtxUTxO)
inputUTxO PlutusScript
forall {lang}. PlutusScript lang
headScript
  Input
redeemer <- Tx -> TxIn -> Maybe Input
forall a. FromData a => Tx -> TxIn -> Maybe a
findRedeemerSpending Tx
tx TxIn
headInput
  ScriptRedeemer
oldHeadDatum <- TxOut CtxTx -> Maybe ScriptRedeemer
forall era. TxOut CtxTx era -> Maybe ScriptRedeemer
txOutScriptData (TxOut CtxTx -> Maybe ScriptRedeemer)
-> TxOut CtxTx -> Maybe ScriptRedeemer
forall a b. (a -> b) -> a -> b
$ TxOut CtxUTxO -> TxOut CtxTx
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 <- ScriptRedeemer -> Maybe State
forall a. FromScriptData a => ScriptRedeemer -> Maybe a
fromScriptData ScriptRedeemer
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.Contest{}) -> do
      (TxIn
newHeadInput, TxOut CtxUTxO
newHeadOutput) <- forall lang.
IsPlutusScriptLanguage lang =>
UTxO' (TxOut CtxUTxO)
-> PlutusScript lang -> Maybe (TxIn, TxOut CtxUTxO)
findTxOutByScript @PlutusScriptV2 (Tx -> UTxO' (TxOut CtxUTxO)
utxoFromTx Tx
tx) PlutusScript
forall {lang}. PlutusScript lang
headScript
      ScriptRedeemer
newHeadDatum <- TxOut CtxTx -> Maybe ScriptRedeemer
forall era. TxOut CtxTx era -> Maybe ScriptRedeemer
txOutScriptData (TxOut CtxTx -> Maybe ScriptRedeemer)
-> TxOut CtxTx -> Maybe ScriptRedeemer
forall a b. (a -> b) -> a -> b
$ TxOut CtxUTxO -> TxOut CtxTx
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) = ScriptRedeemer -> (Integer, POSIXTime, [PubKeyHash])
decodeDatum ScriptRedeemer
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
fromChainSnapshot 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 :: ScriptRedeemer -> (Integer, POSIXTime, [PubKeyHash])
decodeDatum ScriptRedeemer
headDatum =
    case ScriptRedeemer -> Maybe State
forall a. FromScriptData a => ScriptRedeemer -> Maybe a
fromScriptData ScriptRedeemer
headDatum of
      Just Head.Closed{Integer
$sel:snapshotNumber:Initial :: State -> Integer
snapshotNumber :: Integer
snapshotNumber, POSIXTime
$sel:contestationDeadline:Initial :: State -> POSIXTime
contestationDeadline :: POSIXTime
contestationDeadline, [PubKeyHash]
$sel:contesters:Initial :: State -> [PubKeyHash]
contesters :: [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' (TxOut CtxUTxO) -> Tx -> Maybe FanoutObservation
observeFanoutTx UTxO' (TxOut CtxUTxO)
utxo Tx
tx = do
  let inputUTxO :: UTxO' (TxOut CtxUTxO)
inputUTxO = UTxO' (TxOut CtxUTxO) -> Tx -> UTxO' (TxOut CtxUTxO)
resolveInputsUTxO UTxO' (TxOut CtxUTxO)
utxo Tx
tx
  (TxIn
headInput, TxOut CtxUTxO
headOutput) <- forall lang.
IsPlutusScriptLanguage lang =>
UTxO' (TxOut CtxUTxO)
-> PlutusScript lang -> Maybe (TxIn, TxOut CtxUTxO)
findTxOutByScript @PlutusScriptV2 UTxO' (TxOut CtxUTxO)
inputUTxO PlutusScript
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' (TxOut CtxUTxO) -> Tx -> Maybe AbortObservation
observeAbortTx UTxO' (TxOut CtxUTxO)
utxo Tx
tx = do
  let inputUTxO :: UTxO' (TxOut CtxUTxO)
inputUTxO = UTxO' (TxOut CtxUTxO) -> Tx -> UTxO' (TxOut CtxUTxO)
resolveInputsUTxO UTxO' (TxOut CtxUTxO)
utxo Tx
tx
  (TxIn
headInput, TxOut CtxUTxO
headOutput) <- forall lang.
IsPlutusScriptLanguage lang =>
UTxO' (TxOut CtxUTxO)
-> PlutusScript lang -> Maybe (TxIn, TxOut CtxUTxO)
findTxOutByScript @PlutusScriptV2 UTxO' (TxOut CtxUTxO)
inputUTxO PlutusScript
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

mkHeadId :: PolicyId -> HeadId
mkHeadId :: PolicyId -> HeadId
mkHeadId = ByteString -> HeadId
UnsafeHeadId (ByteString -> HeadId)
-> (PolicyId -> ByteString) -> PolicyId -> HeadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PolicyId -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytes

headIdToCurrencySymbol :: HeadId -> CurrencySymbol
headIdToCurrencySymbol :: HeadId -> CurrencySymbol
headIdToCurrencySymbol (UnsafeHeadId ByteString
headId) = BuiltinByteString -> CurrencySymbol
CurrencySymbol (ByteString -> BuiltinByteString
forall a arep. ToBuiltin a arep => a -> arep
toBuiltin ByteString
headId)

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

assetNameToOnChainId :: AssetName -> OnChainId
assetNameToOnChainId :: AssetName -> OnChainId
assetNameToOnChainId (AssetName ByteString
bs) = ByteString -> OnChainId
UnsafeOnChainId ByteString
bs

onChainIdToAssetName :: OnChainId -> AssetName
onChainIdToAssetName :: OnChainId -> AssetName
onChainIdToAssetName = ByteString -> AssetName
AssetName (ByteString -> AssetName)
-> (OnChainId -> ByteString) -> OnChainId -> AssetName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnChainId -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytes

-- | Derive the 'OnChainId' from a Cardano 'PaymentKey'. The on-chain identifier
-- is the public key hash as it is also availble to plutus validators.
verificationKeyToOnChainId :: VerificationKey PaymentKey -> OnChainId
verificationKeyToOnChainId :: VerificationKey PaymentKey -> OnChainId
verificationKeyToOnChainId =
  ByteString -> OnChainId
UnsafeOnChainId (ByteString -> OnChainId)
-> (VerificationKey PaymentKey -> ByteString)
-> VerificationKey PaymentKey
-> OnChainId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuiltinByteString -> ByteString
forall arep a. FromBuiltin arep a => arep -> a
fromBuiltin (BuiltinByteString -> ByteString)
-> (VerificationKey PaymentKey -> BuiltinByteString)
-> VerificationKey PaymentKey
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PubKeyHash -> BuiltinByteString
getPubKeyHash (PubKeyHash -> BuiltinByteString)
-> (VerificationKey PaymentKey -> PubKeyHash)
-> VerificationKey PaymentKey
-> BuiltinByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash PaymentKey -> PubKeyHash
toPlutusKeyHash (Hash PaymentKey -> PubKeyHash)
-> (VerificationKey PaymentKey -> Hash PaymentKey)
-> VerificationKey PaymentKey
-> PubKeyHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VerificationKey PaymentKey -> Hash PaymentKey
forall keyrole.
Key keyrole =>
VerificationKey keyrole -> Hash keyrole
verificationKeyHash

-- * Helpers

headTokensFromValue :: PlutusScript -> Value -> [(AssetName, Quantity)]
headTokensFromValue :: PlutusScript -> Value -> [(AssetName, Quantity)]
headTokensFromValue PlutusScript
headTokenScript Value
v =
  [ (AssetName
assetName, Quantity
q)
  | (AssetId PolicyId
pid AssetName
assetName, Quantity
q) <- Value -> [(AssetId, Quantity)]
valueToList Value
v
  , PolicyId
pid PolicyId -> PolicyId -> Bool
forall a. Eq a => a -> a -> Bool
== Script PlutusScriptV2 -> PolicyId
forall lang. Script lang -> PolicyId
scriptPolicyId (PlutusScript -> Script PlutusScriptV2
PlutusScript PlutusScript
headTokenScript)
  ]

-- | Find first occurrence including a transformation.
findFirst :: Foldable t => (a -> Maybe b) -> t a -> Maybe b
findFirst :: forall (t :: * -> *) a b.
Foldable t =>
(a -> Maybe b) -> t a -> Maybe b
findFirst a -> Maybe b
fn = First b -> Maybe b
forall a. First a -> Maybe a
getFirst (First b -> Maybe b) -> (t a -> First b) -> t a -> Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> First b) -> t a -> First b
forall m a. Monoid m => (a -> m) -> t a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Maybe b -> First b
forall a. Maybe a -> First a
First (Maybe b -> First b) -> (a -> Maybe b) -> a -> First b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe b
fn)

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 -> [(AssetId, Quantity)]
valueToList (Value -> [(AssetId, Quantity)]) -> Value -> [(AssetId, Quantity)]
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