Merge pull request #176 from input-output-hk/ensemble/initial-validator
Initial Validator (commit case)
Initial Validator (commit case)
Hydra.BehaviorSpec
Hydra.Chain.Direct.Contract.Close
Hydra.Chain.Direct.Contract.CollectCom
Hydra.Chain.Direct.Contract.Commit
Hydra.Chain.Direct.Contract.FanOut
Hydra.Chain.Direct.Contract.Mutation
Hydra.Chain.Direct.ContractSpec
import Hydra.Snapshot (Snapshot (..))
import Ledger.Typed.Scripts (DatumType)
import Ledger.Value (AssetClass (..), currencyMPSHash)
import Ouroboros.Consensus.Util (eitherToMaybe)
import Plutus.V1.Ledger.Api (MintingPolicyHash, fromBuiltin, fromData)
import qualified Plutus.V1.Ledger.Api as Plutus
import Plutus.V1.Ledger.Value (assetClass, currencySymbol, tokenName)
unsafeBuildTransaction $
emptyTxBody
& addVkInputs [txIn]
& addOutputs (headOutput : map mkInitialOutput cardanoKeys)
& addOutputs (headOutput : map (mkInitialOutput networkId) cardanoKeys)
where
headOutput =
TxOut headAddress headValue headDatum
(contestationPeriodFromDiffTime contestationPeriod)
(map (partyFromVerKey . vkey) parties)
mkInitialOutput (toPlutusKeyHash . verificationKeyHash -> vkh) =
TxOut initialAddress initialValue (mkInitialDatum vkh)
initialScript =
fromPlutusScript Initial.validatorScript
mkInitialOutput :: NetworkId -> VerificationKey PaymentKey -> TxOut CtxTx Era
mkInitialOutput networkId (toPlutusKeyHash . verificationKeyHash -> pkh) =
TxOut initialAddress initialValue initialDatum
where
-- FIXME: should really be the minted PTs plus some ADA to make the ledger happy
initialValue =
lovelaceToTxOutValue $ Lovelace 2_000_000
initialAddress =
mkScriptAddress @PlutusScriptV1 networkId initialScript
mkInitialDatum =
mkTxOutDatum . Initial.datum
initialScript =
fromPlutusScript Initial.validatorScript
initialDatum =
mkTxOutDatum $ Initial.datum pkh
-- | Craft a commit transaction which includes the "committed" utxo as a datum.
--
unsafeBuildTransaction $
emptyTxBody
& addInputs [(initialInput, initialWitness)]
& addVkInputs [commit | Just (commit, _) <- [utxo]]
& addVkInputs (maybeToList mCommittedInput)
& addOutputs [commitOutput]
where
initialWitness =
initialDatum =
mkDatumForTxIn $ Initial.datum $ toPlutusKeyHash vkh
initialRedeemer =
mkRedeemerForTxIn $ Initial.redeemer ()
mkRedeemerForTxIn . Initial.redeemer $
Initial.Commit (toPlutusTxOutRef <$> mCommittedInput)
mCommittedInput =
fst <$> utxo
commitOutput =
TxOut commitAddress commitValue commitDatum
commitScript =
commitDatum =
mkTxOutDatum $ mkCommitDatum party (Head.validatorHash policyId) utxo
-- FIXME: WIP
mkCommitDatum :: Party -> Plutus.ValidatorHash -> Maybe (Api.TxIn, Api.TxOut Api.CtxUTxO Api.Era) -> Plutus.Datum
mkCommitDatum (partyFromVerKey . vkey -> party) headValidatorHash utxo =
Commit.datum (party, headValidatorHash, serializedUtxo)
where
serializedUtxo = case utxo of
Nothing ->
Nothing
Just (i, o) ->
Just
( Commit.SerializedTxOutRef (toBuiltin $ serialize' $ Api.toLedgerTxIn i)
, Commit.SerializedTxOut (toBuiltin $ serialize' $ Api.toLedgerTxOut o)
)
Just (_i, o) ->
Just $ Commit.SerializedTxOut (toBuiltin $ serialize' $ Api.toLedgerTxOut o)
-- | Create a transaction collecting all "committed" utxo and opening a Head,
-- i.e. driving the Head script state.
extractSerialisedTxOut d =
case fromData $ toPlutusData d of
Nothing -> error "SNAFU"
Just ((_, _, Just (_, o)) :: DatumType Commit.Commit) -> Just o
Just ((_, _, Just o) :: DatumType Commit.Commit) -> Just o
_ -> Nothing
utxoHash =
Head.hashPreSerializedCommits $
initialScript =
fromPlutusScript Initial.validatorScript
initialRedeemer =
mkRedeemerForTxIn $ Initial.redeemer ()
mkRedeemerForTxIn $ Initial.redeemer Initial.Abort
-- * Observe Hydra Head transactions
convertParty :: OnChain.Party -> Party
convertParty = Party . partyToVerKey
-- | Identify a commit tx by looking for an output which pays to v_commit.
-- | Identify a commit tx by:
--
-- - Find which 'initial' tx input is being consumed.
-- - Find the redeemer corresponding to that 'initial', which contains the tx
-- input of the committed utxo.
-- - Find the outputs which pays to the commit validator.
-- - Using the datum of that output, deserialize the comitted output.
-- - Reconstruct the committed Utxo from both values (tx input and output).
observeCommitTx ::
NetworkId ->
-- | Known (remaining) initial tx inputs.
[TxIn] ->
CardanoTx ->
Maybe (OnChainTx CardanoTx, (TxIn, TxOut CtxUTxO Era, ScriptData))
observeCommitTx networkId (getTxBody -> txBody) = do
observeCommitTx networkId initials (getTxBody -> txBody) = do
initialTxIn <- findInitialTxIn
mCommittedTxIn <- decodeInitialRedeemer initialTxIn
(commitIn, commitOut) <- findTxOutByAddress commitAddress txBody
dat <- getDatum commitOut
(party, _, committedUtxo) <- fromData @(DatumType Commit.Commit) $ toPlutusData dat
convertedUtxo <- convertUtxo committedUtxo
let onChainTx = OnCommitTx (convertParty party) convertedUtxo
pure (onChainTx, (commitIn, toCtxUTxOTxOut commitOut, dat))
-- TODO: This 'party' would be available from the spent 'initial' utxo (PT eventually)
(party, _, serializedTxOut) <- fromData @(DatumType Commit.Commit) $ toPlutusData dat
let mCommittedTxOut = convertTxOut serializedTxOut
comittedUtxo <-
case (mCommittedTxIn, mCommittedTxOut) of
(Nothing, Nothing) -> Just mempty
(Just i, Just o) -> Just $ Api.singletonUtxo (i, o)
(Nothing, Just{}) -> error "found commit with no redeemer out ref but with serialized output."
(Just{}, Nothing) -> error "found commit with redeemer out ref but with no serialized output."
let onChainTx = OnCommitTx (convertParty party) comittedUtxo
pure
( onChainTx
, (commitIn, toUtxoContext commitOut, dat)
)
where
convertUtxo :: Maybe (Commit.SerializedTxOutRef, Commit.SerializedTxOut) -> Maybe Utxo
convertUtxo = \case
Nothing -> Just mempty
Just (Commit.SerializedTxOutRef inBytes, Commit.SerializedTxOut outBytes) ->
findInitialTxIn =
case filterTxIn (`elem` initials) txBody of
[input] -> Just input
[] -> Nothing
_ -> error "transaction consuming more than one initial at once."
decodeInitialRedeemer =
findRedeemerSpending txBody >=> \case
Initial.Abort ->
Nothing
Initial.Commit{committedRef} ->
Just (Api.fromPlutusTxOutRef <$> committedRef)
convertTxOut :: Maybe Commit.SerializedTxOut -> Maybe (TxOut CtxUTxO Era)
convertTxOut = \case
Nothing -> Nothing
Just (Commit.SerializedTxOut outBytes) ->
-- XXX(SN): these errors might be more severe and we could throw an
-- exception here?
eitherToMaybe $ do
txIn <- fromLedgerTxIn <$> decodeFull' (fromBuiltin inBytes)
txOut <- fromLedgerTxOut <$> decodeFull' (fromBuiltin outBytes)
pure $ singletonUtxo (txIn, txOut)
case Api.fromLedgerTxOut <$> decodeFull' (fromBuiltin outBytes) of
Right result -> Just result
Left{} -> error "couldn't deserialize serialized output in commit's datum."
commitAddress = mkScriptAddress @PlutusScriptV1 networkId commitScript
Maybe (OnChainTx CardanoTx, OnChainHeadState)
observeCommit networkId tx = \case
Initial{threadOutput, initials, commits} -> do
(onChainTx, commitTriple) <- observeCommitTx networkId tx
(onChainTx, commitTriple) <- observeCommitTx networkId (initials <&> \(a, _, _) -> a) tx
-- NOTE(SN): A commit tx has been observed and thus we can remove all it's
-- inputs from our tracked initials
let commitIns = inputs tx
describeCardanoTx :: CardanoTx -> Text
describeCardanoTx (Tx body _wits) =
unlines $
[ show (getTxId body)
, " Inputs (" <> show (length inps) <> ")"
, " Outputs (" <> show (length outs) <> ")"
, " total number of assets: " <> show totalNumberOfAssets
, " Scripts (" <> show (length scripts) <> ")"
, " total size (bytes): " <> show totalScriptSize
]
<> datums
<> redeemers
[show (getTxId body)]
<> inputLines
<> outputLines
<> scriptLines
<> datumLines
<> redeemerLines
where
ShelleyTxBody _era lbody scripts scriptsData _auxData _validity = body
outs = Ledger.Alonzo.outputs' lbody
inps = Ledger.Alonzo.inputs' lbody
totalScriptSize = sum $ BL.length . serialize <$> scripts
TxBody TxBodyContent{txIns, txOuts} = body
inputLines =
" Input set (" <> show (length txIns) <> ")" :
((" - " <>) . renderTxIn . fst <$> txIns)
outputLines =
[ " Outputs (" <> show (length txOuts) <> ")"
, " total number of assets: " <> show totalNumberOfAssets
]
<> ((" - " <>) . prettyValue . txOutValue <$> txOuts)
totalNumberOfAssets =
sum $
[ foldl' (\n inner -> n + Map.size inner) 0 outer
| Ledger.Alonzo.TxOut _ (Ledger.Mary.Value _ outer) _ <- toList outs
]
datums = case scriptsData of
scriptLines =
[ " Scripts (" <> show (length scripts) <> ")"
, " total size (bytes): " <> show totalScriptSize
]
totalScriptSize = sum $ BL.length . serialize <$> scripts
datumLines = case scriptsData of
TxBodyNoScriptData -> []
(TxBodyScriptData _ (Ledger.Alonzo.TxDats dats) _) ->
" Datums (" <> show (length dats) <> ")" :
((" " <>) . showDatumAndHash <$> Map.toList dats)
((" - " <>) . showDatumAndHash <$> Map.toList dats)
showDatumAndHash (k, v) = show k <> " -> " <> show v
redeemers = case scriptsData of
redeemerLines = case scriptsData of
TxBodyNoScriptData -> []
(TxBodyScriptData _ _ re) ->
let rdmrs = Map.elems $ Ledger.Alonzo.unRedeemers re
in " Redeemers (" <> show (length rdmrs) <> ")" :
((" " <>) . show . fst <$> rdmrs)
((" - " <>) . show . fst <$> rdmrs)
-- | Create a zero-fee, payment cardano transaction.
mkSimpleCardanoTx ::
inputs (Tx (ShelleyTxBody _ body _ _ _ _) _) =
fromLedgerTxIn <$> toList (Ledger.Alonzo.inputs body)
-- | Filter txins of a transaction given the predicate.
filterTxIn :: (TxIn -> Bool) -> TxBody Era -> [TxIn]
filterTxIn fn (TxBody body) =
filter fn (fst <$> txIns body)
-- ** TxOut
-- XXX(SN): replace with Cardano.Api.TxBody.lovelaceToTxOutValue when available
lovelaceToTxOutValue :: Lovelace -> TxOutValue AlonzoEra
lovelaceToTxOutValue lovelace = TxOutValue MultiAssetInAlonzoEra (lovelaceToValue lovelace)
txOutAddress :: TxOut ctx Era -> AddressInEra Era
txOutAddress (TxOut addr _ _) =
addr
txOutValue :: TxOut ctx Era -> Value
txOutValue (TxOut _ value _) =
txOutValueToValue value
TxBodyNoScriptData -> mempty
TxBodyScriptData _ (Ledger.Alonzo.TxDats m) _ -> m
modifyTxOutDatum ::
(TxOutDatum ctx0 Era -> TxOutDatum ctx1 Era) ->
TxOut ctx0 Era ->
TxOut ctx1 Era
modifyTxOutDatum fn (TxOut addr value dat) =
TxOut addr value (fn dat)
modifyTxOutAddress ::
(AddressInEra Era -> AddressInEra Era) ->
TxOut ctx Era ->
TxOut ctx Era
modifyTxOutAddress fn (TxOut addr value dat) =
TxOut (fn addr) value dat
modifyTxOutValue ::
(Value -> Value) ->
modifyTxOutValue fn (TxOut addr value dat) =
TxOut addr (mkTxOutValue $ fn $ txOutValueToValue value) dat
modifyTxOutDatum ::
(TxOutDatum ctx0 Era -> TxOutDatum ctx1 Era) ->
TxOut ctx0 Era ->
TxOut ctx1 Era
modifyTxOutDatum fn (TxOut addr value dat) =
TxOut addr value (fn dat)
-- | Find first 'TxOut' which pays to given address and also return the
-- corresponding 'TxIn' to reference it.
findTxOutByAddress :: AddressInEra era -> TxBody era -> Maybe (TxIn, TxOut CtxTx era)
-- * Generators
genVerificationKey :: Gen (VerificationKey PaymentKey)
genVerificationKey = fst <$> genKeyPair
genKeyPair :: Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
genKeyPair = do
-- NOTE: not using 'genKeyDSIGN' purposely here, it is not pure and does not
output <- scale (const 1) $ genOutput vk
pure $ Utxo $ Map.singleton (fromLedgerTxIn input) output
-- | NOTE: See note on 'mkVkAddress' about 'NetworkId'.
genAddressInEra :: NetworkId -> Gen (AddressInEra Era)
genAddressInEra networkId =
mkVkAddress networkId <$> genVerificationKey
genValue :: Gen Value
genValue = txOutValue <$> (genKeyPair >>= (genOutput . fst))
TxIn
(TxId $ unsafeHashFromBytes $ Plutus.fromBuiltin bytes)
(TxIx $ fromIntegral ix)
toPlutusTxOutRef :: TxIn -> Plutus.TxOutRef
toPlutusTxOutRef = Ledger.txInfoIn' . toLedgerTxIn
-- ** TxOut
toLedgerTxOut :: TxOut CtxUTxO Era -> Ledger.TxOut (ShelleyLedgerEra Era)
-- | Mutation-based script validator tests for the commit transaction where a
-- 'healthyCommitTx' gets mutated by an arbitrary 'CommitMutation'.
module Hydra.Chain.Direct.Contract.Commit where
import Hydra.Prelude
-- Arbitrary VerificationKey instance
import Hydra.Chain.Direct.TxSpec ()
import Data.Maybe (fromJust)
import Hydra.Chain.Direct.Contract.Mutation (
Mutation (..),
SomeMutation (..),
)
import qualified Hydra.Chain.Direct.Fixture as Fixture
import Hydra.Chain.Direct.Tx (commitTx, mkInitialOutput)
import Hydra.Ledger.Cardano (
CardanoTx,
CtxUTxO,
Era,
PaymentKey,
TxIn,
TxOut (TxOut),
Utxo,
VerificationKey,
genAddressInEra,
genOutput,
genValue,
getOutputs,
lovelaceToValue,
mkTxOutValue,
modifyTxOutAddress,
modifyTxOutValue,
singletonUtxo,
toUtxoContext,
txOutAddress,
txOutValue,
verificationKeyHash,
)
import Hydra.Party (Party)
import Test.QuickCheck (oneof, suchThat)
--
-- CommitTx
--
healthyCommitTx :: (CardanoTx, Utxo)
healthyCommitTx =
(tx, lookupUtxo)
where
lookupUtxo =
singletonUtxo (initialInput, toUtxoContext initialOutput)
<> singletonUtxo healthyCommittedUtxo
tx =
commitTx
Fixture.testNetworkId
commitParty
(Just healthyCommittedUtxo)
(initialInput, initialPubKeyHash)
initialInput = generateWith arbitrary 42
initialOutput = mkInitialOutput Fixture.testNetworkId commitVerificationKey
initialPubKeyHash = verificationKeyHash commitVerificationKey
commitVerificationKey :: VerificationKey PaymentKey
commitVerificationKey = generateWith arbitrary 42
commitParty :: Party
commitParty = generateWith arbitrary 42
-- NOTE: An 8₳ output which is currently addressed to some arbitrary key.
healthyCommittedUtxo :: (TxIn, TxOut CtxUTxO Era)
healthyCommittedUtxo = flip generateWith 42 $ do
txIn <- arbitrary
txOut <- modifyTxOutValue (const $ lovelaceToValue 8_000_000) <$> (genOutput =<< arbitrary)
pure (txIn, txOut)
data CommitMutation
= MutateCommitOutputValue
| MutateCommittedValue
| MutateCommittedAddress
deriving (Generic, Show, Enum, Bounded)
genCommitMutation :: (CardanoTx, Utxo) -> Gen SomeMutation
genCommitMutation (tx, _utxo) =
oneof
[ SomeMutation MutateCommitOutputValue . ChangeOutput 0 <$> do
mutatedValue <- (mkTxOutValue <$> genValue) `suchThat` (/= commitOutputValue)
pure $ TxOut commitOutputAddress mutatedValue commitOutputDatum
, SomeMutation MutateCommittedValue <$> do
mutatedValue <- genValue `suchThat` (/= committedOutputValue)
let mutatedOutput = modifyTxOutValue (const mutatedValue) committedTxOut
pure $ ChangeInput committedTxIn mutatedOutput
, SomeMutation MutateCommittedAddress <$> do
mutatedAddress <- genAddressInEra Fixture.testNetworkId `suchThat` (/= committedAddress)
let mutatedOutput = modifyTxOutAddress (const mutatedAddress) committedTxOut
pure $ ChangeInput committedTxIn mutatedOutput
]
where
TxOut commitOutputAddress commitOutputValue commitOutputDatum =
fromJust $ getOutputs tx !!? 0
(committedTxIn, committedTxOut) = healthyCommittedUtxo
committedAddress = txOutAddress committedTxOut
committedOutputValue = txOutValue committedTxOut
propTransactionDoesNotValidate :: (CardanoTx, Utxo) -> Property
propTransactionDoesNotValidate (tx, lookupUtxo) =
let result = evaluateTx tx lookupUtxo
in counterexample "Should have not validated" $
case result of
Left _ ->
property True
Right redeemerReport ->
any isLeft (Map.elems redeemerReport)
& counterexample ("Tx: " <> toString (describeCardanoTx tx))
& counterexample ("Lookup utxo: " <> decodeUtf8 (encodePretty lookupUtxo))
& counterexample ("Redeemer report: " <> show redeemerReport)
in case result of
Left _ ->
property True
Right redeemerReport ->
any isLeft (Map.elems redeemerReport)
& counterexample ("Tx: " <> toString (describeCardanoTx tx))
& counterexample ("Lookup utxo: " <> decodeUtf8 (encodePretty lookupUtxo))
& counterexample ("Redeemer report: " <> show redeemerReport)
& counterexample "Phase-2 validation should have failed"
-- | A 'Property' checking some (transaction, UTxO) pair is valid.
propTransactionValidates :: (CardanoTx, Utxo) -> Property
propTransactionValidates (tx, lookupUtxo) =
let result = evaluateTx tx lookupUtxo
in counterexample "Should have validated" $
case result of
Left _ ->
property False
& counterexample ("Tx: " <> toString (describeCardanoTx tx))
& counterexample ("Lookup utxo: " <> decodeUtf8 (encodePretty lookupUtxo))
Right redeemerReport ->
all isRight (Map.elems redeemerReport)
& counterexample ("Tx: " <> toString (describeCardanoTx tx))
& counterexample ("Lookup utxo: " <> decodeUtf8 (encodePretty lookupUtxo))
& counterexample ("Redeemer report: " <> show redeemerReport)
in case result of
Left basicFailure ->
property False
& counterexample ("Tx: " <> toString (describeCardanoTx tx))
& counterexample ("Lookup utxo: " <> decodeUtf8 (encodePretty lookupUtxo))
& counterexample ("Phase-1 validation failed: " <> show basicFailure)
Right redeemerReport ->
all isRight (Map.elems redeemerReport)
& counterexample ("Tx: " <> toString (describeCardanoTx tx))
& counterexample ("Lookup utxo: " <> decodeUtf8 (encodePretty lookupUtxo))
& counterexample ("Redeemer report: " <> show redeemerReport)
& counterexample "Phase-2 validation failed"
-- * Mutations
import qualified Data.ByteString.Base16 as Base16
import Hydra.Chain.Direct.Contract.Close (genCloseMutation, healthyCloseTx)
import Hydra.Chain.Direct.Contract.CollectCom (genCollectComMutation, healthyCollectComTx)
import Hydra.Chain.Direct.Contract.Commit (genCommitMutation, healthyCommitTx)
import Hydra.Chain.Direct.Contract.FanOut (genFanoutMutation, healthyFanoutTx)
import Hydra.Chain.Direct.Contract.Mutation (
genListOfSigningKeys,
describe "TxOut hashing" $ do
modifyMaxSuccess (const 20) $
prop "OffChain.hashTxOuts == OnChain.hashTxOuts" prop_consistentOnAndOffChainHashOfTxOuts
describe "Commit" $ do
prop "is healthy" $
propTransactionValidates healthyCommitTx
prop "does not survive random adversarial mutations" $
propMutation healthyCommitTx genCommitMutation
describe "CollectCom" $ do
prop "is healthy" $
propTransactionValidates healthyCollectComTx
, fromPlutusData (toData commitDatum)
)
committedUtxo = maybe mempty singletonUtxo singleUtxo
in observeCommitTx testNetworkId tx
in observeCommitTx testNetworkId [fst initialIn] tx
=== Just (OnCommitTx{party, committed = committedUtxo}, expectedOutput)
& counterexample ("Tx: " <> show tx)
data Commit
newtype SerializedTxOutRef = SerializedTxOutRef BuiltinByteString
PlutusTx.unstableMakeIsData ''SerializedTxOutRef
newtype SerializedTxOut = SerializedTxOut BuiltinByteString
PlutusTx.unstableMakeIsData ''SerializedTxOut
-- TODO: Having the 'TxOutRef' on-chain is not necessary but it is convenient
-- for the off-chain code to reconstrut the commit UTXO.
--
-- Ideally, since the TxOutRef is already present in the redeemer for the
-- initial validator, the off-chain code could get it from there.
instance Eq SerializedTxOut where
SerializedTxOut bs == SerializedTxOut bs' = bs == bs'
-- TODO: Is the 'Party' here even used? If yes, why is it not a PubKeyHash /
-- cardano-credential?
instance Scripts.ValidatorTypes Commit where
type DatumType Commit = (Party, ValidatorHash, Maybe (SerializedTxOutRef, SerializedTxOut))
type DatumType Commit = (Party, ValidatorHash, Maybe SerializedTxOut)
type RedeemerType Commit = ()
validator :: DatumType Commit -> RedeemerType Commit -> ScriptContext -> Bool
validatorScript :: Script
validatorScript = unValidatorScript $ Scripts.validatorScript typedValidator
validatorHash :: ValidatorHash
validatorHash = Scripts.validatorHash typedValidator
address :: Address
address = scriptHashAddress $ Scripts.validatorHash typedValidator
address = scriptHashAddress validatorHash
datum :: DatumType Commit -> Datum
datum a = Datum (toBuiltinData a)
lookupCommit h = do
d <- getDatum <$> findDatum h txInfo
case fromBuiltinData @(DatumType Commit) d of
Just (_p, _, Just (_, o)) ->
Just (_p, _, Just o) ->
Just o
Just (_p, _, Nothing) ->
Nothing
import Ledger hiding (validatorHash)
import PlutusTx.Prelude
import Hydra.Contract.Commit (SerializedTxOut (..))
import qualified Hydra.Contract.Commit as Commit
import Hydra.Contract.Encoding (encodeTxOut)
import Ledger.Typed.Scripts (TypedValidator, ValidatorType, ValidatorTypes (..))
import qualified Ledger.Typed.Scripts as Scripts
import Plutus.Codec.CBOR.Encoding (encodingToBuiltinByteString)
import Plutus.V1.Ledger.Ada (fromValue, getLovelace)
import PlutusTx (CompiledCode)
import qualified PlutusTx
import PlutusTx.IsData.Class (ToData (..))
import PlutusTx.IsData.Class (ToData (..), fromBuiltinData)
data Initial
data InitialRedeemer
= Abort
| Commit
{ -- | Points to the committed Utxo.
committedRef :: Maybe TxOutRef
}
PlutusTx.unstableMakeIsData ''InitialRedeemer
instance Scripts.ValidatorTypes Initial where
type DatumType Initial = PubKeyHash
type RedeemerType Initial = ()
type RedeemerType Initial = InitialRedeemer
validator :: DatumType Initial -> RedeemerType Initial -> ScriptContext -> Bool
validator _datum _redeemer _ctx = True
validator ::
-- | Commit validator
ValidatorHash ->
-- | The Hydra party which committed
PubKeyHash ->
InitialRedeemer ->
ScriptContext ->
Bool
validator commitValidator _datum red context =
case red of
Abort -> True
Commit{committedRef} -> checkCommit commitValidator committedRef context
compiledValidator :: CompiledCode (ValidatorType Initial)
compiledValidator = $$(PlutusTx.compile [||validator||])
checkCommit ::
-- | Commit validator
ValidatorHash ->
Maybe TxOutRef ->
ScriptContext ->
Bool
checkCommit commitValidator committedRef [email protected]{scriptContextTxInfo = txInfo} =
checkCommittedValue && checkSerializedTxOut
where
checkCommittedValue =
traceIfFalse "commitLockedValue does not match" $
traceIfFalse ("commitLockedValue: " `appendString` debugValue commitLockedValue) $
traceIfFalse ("initialValue: " `appendString` debugValue initialValue) $
traceIfFalse ("comittedValue: " `appendString` debugValue committedValue) $
commitLockedValue == initialValue + committedValue
checkSerializedTxOut =
case (committedTxOut, commitLockedSerializedTxOut) of
(Nothing, Nothing) ->
True
(Nothing, Just{}) ->
traceError "nothing committed, but TxOut in output datum"
(Just{}, Nothing) ->
traceError "committed TxOut, but nothing in output datum"
(Just txOut, Just serializedTxOut) ->
traceIfFalse "mismatch committed TxOut in datum" $
SerializedTxOut (encodingToBuiltinByteString (encodeTxOut txOut)) == serializedTxOut
initialValue =
maybe mempty (txOutValue . txInInfoResolved) $ findOwnInput context
committedValue =
maybe mempty txOutValue committedTxOut
committedTxOut = do
ref <- committedRef
txInInfoResolved <$> findTxInByTxOutRef ref txInfo
commitLockedValue = valueLockedBy txInfo commitValidator
commitLockedSerializedTxOut =
case scriptOutputsAt commitValidator txInfo of
[(dh, _)] ->
case getDatum <$> findDatum dh txInfo of
Nothing -> traceError "expected optional commit datum"
(Just da) ->
case fromBuiltinData @(DatumType Commit.Commit) da of
Nothing -> traceError "expected commit datum type, got something else"
Just (_party, _headScriptHash, mSerializedTxOut) ->
mSerializedTxOut
_ -> traceError "expected single commit output"
debugValue = debugInteger . getLovelace . fromValue
-- | Show an 'Integer' as decimal number. This is very inefficient and only
-- should be used for debugging.
debugInteger :: Integer -> BuiltinString
debugInteger i
| i == 0 = "0"
| i == 1 = "1"
| i == 2 = "2"
| i == 3 = "3"
| i == 4 = "4"
| i == 5 = "5"
| i == 6 = "6"
| i == 7 = "7"
| i == 8 = "8"
| i == 9 = "9"
| i >= 10 = debugInteger (i `quotient` 10) `appendString` "0"
| otherwise = "-" `appendString` debugInteger (negate i)
{-# INLINEABLE debugInteger #-}
{- ORMOLU_DISABLE -}
typedValidator :: TypedValidator Initial
typedValidator = Scripts.mkTypedValidator @Initial
compiledValidator
$$(PlutusTx.compile [|| wrap ||])
typedValidator =
Scripts.mkTypedValidator @Initial
compiledValidator
$$(PlutusTx.compile [||wrap||])
where
wrap = Scripts.wrapValidator @(DatumType Initial) @(RedeemerType Initial)
{- ORMOLU_ENABLE -}
compiledValidator :: CompiledCode (ValidatorType Initial)
compiledValidator =
$$(PlutusTx.compile [||validator||])
`PlutusTx.applyCode` PlutusTx.liftCode Commit.validatorHash
-- | Get the actual plutus script. Mainly used to serialize and use in
-- transactions.
3885: Switch Babbage testnet to use example directory r=Jimbo4350 a=newhoggy Co-authored-by: John Ky <j[email protected]>
Fix Babbage era evaluateMinLovelaceOutput function
Fix the default protocol version for Babbage