{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DuplicateRecordFields #-}
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)
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
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
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)
hydraMetadataLabel :: Word64
hydraMetadataLabel :: Word64
hydraMetadataLabel = Word64
55555
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)]
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
initTx ::
NetworkId ->
TxIn ->
[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)
commitTx ::
NetworkId ->
ScriptRegistry ->
HeadId ->
Party ->
UTxO' (TxOut CtxUTxO, Witness WitCtxTxIn) ->
(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
collectComTx ::
NetworkId ->
ScriptRegistry ->
VerificationKey PaymentKey ->
HeadId ->
HeadParameters ->
(TxIn, TxOut CtxUTxO) ->
Map TxIn (TxOut CtxUTxO) ->
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
data ClosingSnapshot
= CloseWithInitialSnapshot {ClosingSnapshot -> UTxOHash
openUtxoHash :: UTxOHash}
| CloseWithConfirmedSnapshot
{ ClosingSnapshot -> SnapshotNumber
snapshotNumber :: SnapshotNumber
, ClosingSnapshot -> UTxOHash
closeUtxoHash :: UTxOHash
,
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)
closeTx ::
ScriptRegistry ->
VerificationKey PaymentKey ->
ClosingSnapshot ->
SlotNo ->
PointInTime ->
OpenThreadOutput ->
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)
contestTx ::
ScriptRegistry ->
VerificationKey PaymentKey ->
Snapshot Tx ->
MultiSignature (Snapshot Tx) ->
PointInTime ->
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)
fanoutTx ::
ScriptRegistry ->
UTxO ->
(TxIn, TxOut CtxUTxO) ->
SlotNo ->
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)
abortTx ::
UTxO ->
ScriptRegistry ->
VerificationKey PaymentKey ->
(TxIn, TxOut CtxUTxO) ->
PlutusScript ->
Map TxIn (TxOut CtxUTxO) ->
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
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
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 InitObservation = InitObservation
{ InitObservation -> (TxIn, TxOut CtxUTxO)
initialThreadUTxO :: (TxIn, TxOut CtxUTxO)
, InitObservation -> [(TxIn, TxOut CtxUTxO)]
initials :: [(TxIn, TxOut CtxUTxO)]
, InitObservation -> HeadId
headId :: HeadId
,
InitObservation -> TxIn
seedTxIn :: TxIn
, InitObservation -> ContestationPeriod
contestationPeriod :: ContestationPeriod
, InitObservation -> [Party]
parties :: [Party]
,
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
observeInitTx ::
Tx ->
Either NotAnInitReason InitObservation
observeInitTx :: Tx -> Either NotAnInitReason InitObservation
observeInitTx Tx
tx = do
(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
(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)
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
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
, 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
]
data CommitObservation = CommitObservation
{ CommitObservation -> (TxIn, TxOut CtxUTxO)
commitOutput :: (TxIn, TxOut CtxUTxO)
, CommitObservation -> Party
party :: Party
, 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
observeCommitTx ::
NetworkId ->
UTxO ->
Tx ->
Maybe CommitObservation
observeCommitTx :: NetworkId -> UTxO' (TxOut CtxUTxO) -> Tx -> Maybe CommitObservation
observeCommitTx NetworkId
networkId UTxO' (TxOut CtxUTxO)
utxo Tx
tx = do
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
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
observeCollectComTx ::
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
observeCloseTx ::
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
observeContestTx ::
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
observeFanoutTx ::
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
observeAbortTx ::
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
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
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
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)
]
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
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