Snapshot number and utxo hash need not be in the redeemer on close/contest
+ Check presence of state token (ST) and that it's consistent against datum.
+ Reduce cost of `commitTx` by using the initial script as input reference.
+ Moved check to reimburse commits to head validator and ensure its completeness.
+ Remove snapshot number and utxo hash from Close and Contest reedemer as they
were already present in Closed datum.
- **BREAKING** Change the way tx validity and contestation deadline is constructed for close transactions:
+ There is a new hydra-node flag `--contestation-period` expressed in seconds
TxValidityNoUpperBound _ -> SNothing
TxValidityUpperBound _ s -> SJust s
}
fromLedgerValidityInterval ::
Ledger.ValidityInterval ->
(TxValidityLowerBound Era, TxValidityUpperBound Era)
fromLedgerValidityInterval validityInterval =
let Ledger.ValidityInterval{Ledger.invalidBefore = invalidBefore, Ledger.invalidHereafter = invalidHereAfter} = validityInterval
lowerBound = case invalidBefore of
SNothing -> TxValidityNoLowerBound
SJust s -> TxValidityLowerBound ValidityLowerBoundInBabbageEra s
upperBound = case invalidHereAfter of
SNothing -> TxValidityNoUpperBound ValidityNoUpperBoundInBabbageEra
SJust s -> TxValidityUpperBound ValidityUpperBoundInBabbageEra s
in (lowerBound, upperBound)
instance Arbitrary (TxValidityLowerBound Era) where
arbitrary =
computeFanOutCost :: IO [(NumUTxO, TxSize, MemUnit, CpuUnit, Lovelace)]
computeFanOutCost = do
interesting <- catMaybes <$> mapM compute [1, 2, 3, 5, 10, 50]
limit <- maybeToList . getFirst <$> foldMapM (fmap First . compute) [100, 99 .. 51]
interesting <- catMaybes <$> mapM compute [1, 2, 3, 5, 10, 20]
limit <- maybeToList . getFirst <$> foldMapM (fmap First . compute) [100, 99 .. 21]
pure $ interesting <> limit
where
compute numElems = do
, websockets
, yaml
build-tool-depends: hspec-discover:hspec-discover
build-tool-depends: hspec-discover:hspec-discover -any
ghc-options: -threaded -rtsopts
VerificationKey PaymentKey ->
-- | The snapshot to close with, can be either initial or confirmed one.
ClosingSnapshot ->
-- | 'Tx' validity lower bound
-- | Lower validity slot number, usually a current or quite recent slot number.
SlotNo ->
-- | Current slot and UTC time to compute the contestation deadline time.
-- | Upper validity slot and UTC time to compute the contestation deadline time.
PointInTime ->
-- | Everything needed to spend the Head state-machine output.
OpenThreadOutput ->
headRedeemer =
toScriptData
Head.Close
{ snapshotNumber
, utxoHash = toBuiltin utxoHashBytes
, signature
{ signature
}
headOutputAfter =
headRedeemer =
toScriptData
Head.Contest
{ snapshotNumber = toInteger number
, signature = toPlutusSignatures sig
, utxoHash
{ signature = toPlutusSignatures sig
}
headOutputAfter =
modifyTxOutDatum (const headDatumAfter) headOutputBefore
datum <- fromData $ toPlutusData oldHeadDatum
headId <- findStateToken headOutput
case (datum, redeemer) of
(Head.Open{parties}, Head.Close{snapshotNumber = onChainSnapshotNumber}) -> do
(Head.Open{parties}, Head.Close{}) -> do
(newHeadInput, newHeadOutput) <- findTxOutByScript @PlutusScriptV2 (utxoFromTx tx) headScript
newHeadDatum <- lookupScriptData tx newHeadOutput
closeContestationDeadline <- case fromData (toPlutusData newHeadDatum) of
Just Head.Closed{contestationDeadline} -> pure contestationDeadline
(closeContestationDeadline, onChainSnapshotNumber) <- case fromData (toPlutusData newHeadDatum) of
Just Head.Closed{contestationDeadline, snapshotNumber} -> pure (contestationDeadline, snapshotNumber)
_ -> Nothing
pure
CloseObservation
datum <- fromData $ toPlutusData oldHeadDatum
headId <- findStateToken headOutput
case (datum, redeemer) of
(Head.Closed{}, Head.Contest{snapshotNumber = onChainSnapshotNumber}) -> do
(Head.Closed{}, Head.Contest{}) -> do
(newHeadInput, newHeadOutput) <- findTxOutByScript @PlutusScriptV2 (utxoFromTx tx) headScript
newHeadDatum <- lookupScriptData tx newHeadOutput
let onChainSnapshotNumber = closedSnapshotNumber newHeadDatum
pure
ContestObservation
{ contestedThreadOutput =
where
headScript = fromPlutusScript Head.validatorScript
closedSnapshotNumber headDatum =
case fromData $ toPlutusData headDatum of
Just Head.Closed{snapshotNumber} -> snapshotNumber
_ -> error "wrong state in output datum"
data FanoutObservation = FanoutObservation
-- | Identify a fanout tx by lookup up the input spending the Head output and
genAbortMutation :: (Tx, UTxO) -> Gen SomeMutation
genAbortMutation (tx, _utxo) =
oneof
[ SomeMutation Nothing MutateParties . ChangeHeadDatum <$> do
[ SomeMutation Nothing MutateParties . ChangeInputHeadDatum <$> do
moreParties <- (: healthyParties) <$> arbitrary
c <- arbitrary
pure $ Head.Initial c (partyToChain <$> moreParties) (toPlutusCurrencySymbol $ headPolicyId testSeedInput)
import Hydra.Prelude hiding (label)
import Cardano.Api.UTxO as UTxO
import Cardano.Binary (serialize')
import Data.Maybe (fromJust)
import Hydra.Chain.Direct.Contract.Mutation (Mutation (..), SomeMutation (..), addParticipationTokens, changeHeadOutputDatum, genHash, replacePolicyIdWith)
import Hydra.Chain.Direct.Contract.Mutation (Mutation (..), SomeMutation (..), addParticipationTokens, changeHeadOutputDatum, genHash, replaceContestationDeadline, replaceHeadId, replaceParties, replacePolicyIdWith, replaceSnapshotNumber, replaceUtxoHash)
import Hydra.Chain.Direct.Fixture (genForParty, testNetworkId)
import qualified Hydra.Chain.Direct.Fixture as Fixture
import Hydra.Chain.Direct.TimeHandle (PointInTime)
import Hydra.Chain.Direct.Tx (ClosingSnapshot (..), OpenThreadOutput (..), UTxOHash (UTxOHash), closeTx, mkHeadId, mkHeadOutput)
import Hydra.ContestationPeriod (fromChain)
import qualified Hydra.Contract.HeadState as Head
import qualified Hydra.Data.Party as OnChain
import Hydra.Ledger (hashUTxO)
import Hydra.Ledger.Cardano (genOneUTxOFor, genVerificationKey)
import Hydra.Ledger.Cardano.Evaluate (genValidityBoundsFromContestationPeriod, slotNoToUTCTime)
import Hydra.Ledger.Cardano.Evaluate (genValidityBoundsFromContestationPeriod)
import Hydra.Party (Party, deriveParty, partyToChain)
import Hydra.Snapshot (Snapshot (..), SnapshotNumber)
import Plutus.Orphans ()
import Plutus.V2.Ledger.Api (toBuiltin, toData)
import Plutus.V1.Ledger.Time (DiffMilliSeconds (..), fromMilliSeconds)
import Plutus.V2.Ledger.Api (BuiltinByteString, POSIXTime, toBuiltin, toData)
import Test.Hydra.Fixture (aliceSk, bobSk, carolSk)
import Test.QuickCheck (arbitrarySizedNatural, choose, elements, oneof, suchThat)
import Test.QuickCheck.Instances ()
-- CloseTx
--
-- | Healthy close transaction for the generic case were we close a head
-- after one or more snapshot have been agreed upon between the members.
healthyCloseTx :: (Tx, UTxO)
healthyCloseTx =
(tx, lookupUTxO)
where
tx =
closeTx
somePartyCardanoVerificationKey
healthyClosingSnapshot
startSlot
pointInTime
closingSnapshot
healthyCloseLowerBoundSlot
healthyCloseUpperBoundPointInTime
openThreadOutput
(mkHeadId Fixture.testPolicyId)
-- here we need to pass in contestation period when generating start/end tx validity slots/time
-- since if tx validity bound difference is bigger than contestation period our close validator
-- will fail
(startSlot, pointInTime) =
genValidityBoundsFromContestationPeriod (fromChain healthyContestationPeriod) `generateWith` 42
lookupUTxO = UTxO.singleton (healthyOpenHeadTxIn, healthyOpenHeadTxOut)
headDatum = fromPlutusData $ toData healthyOpenHeadDatum
openThreadOutput =
OpenThreadOutput
{ openThreadUTxO = (healthyOpenHeadTxIn, healthyOpenHeadTxOut, headDatum)
, openParties = healthyOnChainParties
, openContestationPeriod = healthyContestationPeriod
}
closingSnapshot :: ClosingSnapshot
closingSnapshot =
CloseWithConfirmedSnapshot
{ snapshotNumber = healthySnapshotNumber
, closeUtxoHash = UTxOHash $ hashUTxO @Tx healthyCloseUTxO
, signatures = healthySignature healthySnapshotNumber
}
-- | Healthy close transaction for the specific case were we close a head
-- with the initial UtxO, that is, no snapshot have been agreed upon and
-- signed by the head members yet.
healthyCloseInitialTx :: (Tx, UTxO)
healthyCloseInitialTx =
(tx, lookupUTxO)
where
tx =
closeTx
somePartyCardanoVerificationKey
closingSnapshot
healthyCloseLowerBoundSlot
healthyCloseUpperBoundPointInTime
openThreadOutput
(mkHeadId Fixture.testPolicyId)
lookupUTxO = UTxO.singleton (healthyOpenHeadTxIn, healthyOpenHeadTxOut)
headDatum = fromPlutusData $ toData healthyCloseDatum
headDatum = fromPlutusData $ toData healthyOpenHeadDatum
openThreadOutput =
OpenThreadOutput
{ openThreadUTxO = (healthyOpenHeadTxIn, healthyOpenHeadTxOut, headDatum)
, openParties = healthyOnChainParties
, openContestationPeriod = healthyContestationPeriod
}
closingSnapshot :: ClosingSnapshot
closingSnapshot =
CloseWithInitialSnapshot
{ openUtxoHash = UTxOHash $ hashUTxO @Tx healthyUTxO
}
-- NOTE: We need to use the contestation period when generating start/end tx
-- validity slots/time since if tx validity bound difference is bigger than
-- contestation period our close validator will fail
healthyCloseLowerBoundSlot :: SlotNo
healthyCloseUpperBoundPointInTime :: PointInTime
(healthyCloseLowerBoundSlot, healthyCloseUpperBoundPointInTime) =
genValidityBoundsFromContestationPeriod (fromChain healthyContestationPeriod) `generateWith` 42
healthyOpenHeadTxIn :: TxIn
healthyOpenHeadTxIn = generateWith arbitrary 42
mkHeadOutput testNetworkId Fixture.testPolicyId headTxOutDatum
& addParticipationTokens healthyParties
where
headTxOutDatum = toUTxOContext (mkTxOutDatum healthyCloseDatum)
healthySlotNo :: SlotNo
healthySlotNo = arbitrary `generateWith` 42
healthyClosingSnapshot :: ClosingSnapshot
healthyClosingSnapshot =
CloseWithConfirmedSnapshot
{ snapshotNumber = healthySnapshotNumber
, closeUtxoHash = UTxOHash $ hashUTxO @Tx healthyCloseUTxO
, signatures = healthySignature healthySnapshotNumber
}
headTxOutDatum = toUTxOContext (mkTxOutDatum healthyOpenHeadDatum)
healthySnapshot :: Snapshot Tx
healthySnapshot =
healthySnapshotNumber :: SnapshotNumber
healthySnapshotNumber = 1
healthyCloseDatum :: Head.State
healthyCloseDatum =
healthyOpenHeadDatum :: Head.State
healthyOpenHeadDatum =
Head.Open
{ parties = healthyOnChainParties
, utxoHash = toBuiltin $ hashUTxO @Tx healthyUTxO
where
snapshot = healthySnapshot{number}
healthyContestationDeadline :: UTCTime
healthyContestationDeadline =
addUTCTime
(fromInteger healthyContestationPeriodSeconds)
(snd healthyCloseUpperBoundPointInTime)
healthyClosedUTxOHash :: BuiltinByteString
healthyClosedUTxOHash =
toBuiltin $ hashUTxO @Tx healthyClosedUTxO
healthyClosedUTxO :: UTxO
healthyClosedUTxO =
genOneUTxOFor somePartyCardanoVerificationKey `generateWith` 42
data CloseMutation
= MutateSignatureButNotSnapshotNumber
| MutateSnapshotNumberButNotSignature
| MutateSnapshotToIllFormedValue
| -- | Change the resulting snapshot number, this should make the signature
-- invalid.
MutateSnapshotNumberButNotSignature
| -- | This test the case when we have a non-initial utxo hash but the snapshot number is less than or equal to 0
MutateSnapshotNumberToLessThanZero
| MutateParties
| MutateRequiredSigner
| MutateCloseUTxOHash
| MutateValidityInterval
| MutateCloseContestationDeadline
| MutateCloseContestationDeadlineWithZero
| MutatePartiesInOutput
| MutateHeadIdInOutput
| InfiniteLowerBound
| InfiniteUpperBound
| -- | See spec: 5.5 rule 4 -> contestationDeadline = upperBound + contestationPeriod
MutateContestationDeadline
| -- | See spec: 5.5. rule 5 -> upperBound - lowerBound <= contestationPeriod
MutateValidityInterval
| MutateHeadId
deriving (Generic, Show, Enum, Bounded)
genCloseMutation :: (Tx, UTxO) -> Gen SomeMutation
genCloseMutation (tx, _utxo) =
-- FIXME: using 'closeRedeemer' here is actually too high-level and reduces
-- the power of the mutators, we should test at the level of the validator.
-- That is, using the on-chain types. 'closeRedeemer' is also not used
-- anywhere after changing this and can be moved into the closeTx
oneof
[ SomeMutation Nothing MutateSignatureButNotSnapshotNumber . ChangeHeadRedeemer <$> do
oneof
[ SomeMutation Nothing MutateOpenUTxOHash . ChangeOutput 0 <$> mutateUTxOHash
, SomeMutation Nothing MutateHeadTransition <$> do
changeRedeemer <- ChangeHeadRedeemer <$> (Head.Close 0 . toBuiltin <$> genHash <*> arbitrary)
changeRedeemer <- ChangeHeadRedeemer <$> (Head.Close <$> arbitrary)
differencCurrencySymbol <- arbitrary `suchThat` (/= toPlutusCurrencySymbol testPolicyId)
changeDatum <-
ChangeHeadDatum
ChangeInputHeadDatum
<$> ( Head.Open
<$> arbitrary
<*> arbitrary
moreParties <- (: healthyOnChainParties) <$> arbitrary
pure $
Changes
[ ChangeHeadDatum $ Head.Initial c moreParties (toPlutusCurrencySymbol testPolicyId)
[ ChangeInputHeadDatum $ Head.Initial c moreParties (toPlutusCurrencySymbol testPolicyId)
, ChangeOutput 0 $ mutatedPartiesHeadTxOut moreParties headTxOut
]
, SomeMutation Nothing MutateHeadId <$> do
addParticipationTokens,
changeHeadOutputDatum,
genHash,
replaceParties,
replacePolicyIdWith,
replaceSnapshotNumber,
replaceUtxoHash,
)
import Hydra.Chain.Direct.Fixture (genForParty, testNetworkId, testPolicyId)
import Hydra.Chain.Direct.Tx (ClosedThreadOutput (..), contestTx, mkHeadId, mkHeadOutput)
mutatedSignature <- arbitrary :: Gen (MultiSignature (Snapshot Tx))
pure $
Head.Contest
{ snapshotNumber = toInteger healthyContestSnapshotNumber
, utxoHash = healthyContestUTxOHash
, signature = toPlutusSignatures mutatedSignature
{ signature = toPlutusSignatures mutatedSignature
}
, SomeMutation Nothing MutateToNonNewerSnapshot . ChangeHeadRedeemer <$> do
, SomeMutation Nothing MutateToNonNewerSnapshot <$> do
mutatedSnapshotNumber <- choose (0, toInteger healthyClosedSnapshotNumber)
pure $
Head.Contest
{ snapshotNumber = mutatedSnapshotNumber
, utxoHash = healthyContestUTxOHash
, signature =
toPlutusSignatures $
healthySignature (fromInteger mutatedSnapshotNumber)
}
Changes
[ ChangeInputHeadDatum $
healthyClosedState & replaceSnapshotNumber mutatedSnapshotNumber
, ChangeHeadRedeemer $
Head.Contest
{ signature =
toPlutusSignatures $
healthySignature (fromInteger mutatedSnapshotNumber)
}
]
, SomeMutation Nothing MutateRequiredSigner <$> do
newSigner <- verificationKeyHash <$> genVerificationKey
pure $ ChangeRequiredSigners [newSigner]
, SomeMutation Nothing MutateContestUTxOHash . ChangeOutput 0 <$> do
mutateCloseUTxOHash
, SomeMutation Nothing MutateParties . ChangeHeadDatum <$> do
mutatedUTxOHash <- genHash `suchThat` ((/= healthyContestUTxOHash) . toBuiltin)
pure $
changeHeadOutputDatum
(const $ healthyClosedState & replaceUtxoHash (toBuiltin mutatedUTxOHash))
headTxOut
, SomeMutation Nothing MutateParties . ChangeInputHeadDatum <$> do
mutatedParties <- arbitrary `suchThat` (/= healthyOnChainParties)
pure $
Head.Closed
{ parties = mutatedParties
, utxoHash = healthyClosedUTxOHash
, snapshotNumber = fromIntegral healthyClosedSnapshotNumber
, contestationDeadline = arbitrary `generateWith` 42
, headId = toPlutusCurrencySymbol testPolicyId
}
healthyClosedState & replaceParties mutatedParties
, SomeMutation Nothing MutateValidityPastDeadline . ChangeValidityInterval <$> do
lb <- arbitrary
ub <- TxValidityUpperBound <$> arbitrary `suchThat` slotOverContestationDeadline
where
headTxOut = fromJust $ txOuts' tx !!? 0
mutateCloseUTxOHash :: Gen (TxOut CtxTx)
mutateCloseUTxOHash = do
mutatedUTxOHash <- genHash `suchThat` ((/= healthyContestUTxOHash) . toBuiltin)
pure $
changeHeadOutputDatum
( const $
Head.Closed
{ snapshotNumber = fromIntegral healthyContestSnapshotNumber
, utxoHash = toBuiltin mutatedUTxOHash
, parties = healthyOnChainParties
, contestationDeadline = arbitrary `generateWith` 42
, headId = toPlutusCurrencySymbol testPolicyId
}
)
headTxOut
slotOverContestationDeadline slotNo =
slotNoToUTCTime slotNo > healthyContestationDeadline
-- @
-- data Mutation
-- = ChangeHeadRedeemer Head.Input
-- | ChangeHeadDatum Head.State
-- | ChangeInputHeadDatum Head.State
-- ...
-- | Changes [Mutation]
-- @
-- , SomeMutation Nothing MutateOpenUtxoHash . ChangeOutput ...
-- , SomeMutation Nothing MutateHeadTransition <$> do
-- changeRedeemer <- ChangeHeadRedeemer <$> ...
-- changeDatum <- ChangeHeadDatum <$> ...
-- changeDatum <- ChangeInputHeadDatum <$> ...
-- pure $ Changes [changeRedeemer, changeDatum]
-- ]
-- @
import Hydra.Chain.Direct.Tx (assetNameFromVerificationKey)
import qualified Hydra.Contract.Head as Head
import qualified Hydra.Contract.HeadState as Head
import qualified Hydra.Data.Party as Data (Party)
import Hydra.Ledger.Cardano (genKeyPair, genOutput, genVerificationKey, renderTxWithUTxO)
import Hydra.Ledger.Cardano.Evaluate (evaluateTx)
import Hydra.Party (Party)
import Hydra.Prelude hiding (label)
import Plutus.Orphans ()
import Plutus.V2.Ledger.Api (fromData, toData)
import Plutus.V2.Ledger.Api (CurrencySymbol, POSIXTime, fromData, toData)
import qualified System.Directory.Internal.Prelude as Prelude
import Test.Hydra.Prelude
import Test.QuickCheck (
& propTransactionDoesNotValidate expectedError
& genericCoverTable [label]
& checkCoverage
& counterexample ("Original transaction: " <> renderTxWithUTxO utxo tx)
-- | A 'Property' checking some (transaction, UTxO) pair is invalid.
propTransactionDoesNotValidate :: Maybe Text -> (Tx, UTxO) -> Property
data Mutation
= -- | Changes the 'Head' script's redeemer to the given value.
ChangeHeadRedeemer Head.Input
| -- | Changes the 'Head' script's datum to the given value.
-- This modifies both the 'DatumHash' in the UTxO context and the
-- map of 'DatumHash' to 'Datum' in the transaction's witnesses.
ChangeHeadDatum Head.State
| -- | Changes the spent 'Head' script datum to the given value. This modifies
-- both the 'DatumHash' in the UTxO context and the map of 'DatumHash' to
-- 'Datum' in the transaction's witnesses.
ChangeInputHeadDatum Head.State
| -- | Adds given output to the transaction's outputs.
PrependOutput (TxOut CtxTx)
| -- | Removes given output from the transaction's outputs.
ChangeRequiredSigners [Hash PaymentKey]
| -- | Change the validity interval of the transaction.
ChangeValidityInterval (TxValidityLowerBound, TxValidityUpperBound)
| ChangeValidityLowerBound TxValidityLowerBound
| ChangeValidityUpperBound TxValidityUpperBound
| -- | Applies several mutations as a single atomic 'Mutation'.
-- This is useful to enable specific mutations that require consistent
-- change of more than one thing in the transaction and/or UTxO set, for
redeemers = alterRedeemers newHeadRedeemer scriptData
body' = ShelleyTxBody ledgerBody scripts redeemers mAuxData scriptValidity
in (Tx body' wits, utxo)
ChangeHeadDatum d' ->
ChangeInputHeadDatum d' ->
let datum = mkTxOutDatum d'
datumHash = mkTxOutDatumHash d'
-- change the lookup UTXO
ledgerBody
{ Ledger.reqSignerHashes = Set.fromList (toLedgerKeyHash <$> newSigners)
}
ChangeValidityInterval (lb, up) ->
ChangeValidityInterval (lowerBound, upperBound) ->
changeValidityInterval (Just lowerBound) (Just upperBound)
ChangeValidityLowerBound bound ->
changeValidityInterval (Just bound) Nothing
ChangeValidityUpperBound bound ->
changeValidityInterval Nothing (Just bound)
Changes mutations ->
foldr applyMutation (tx, utxo) mutations
where
changeValidityInterval lowerBound' upperBound' =
(Tx body' wits, utxo)
where
ShelleyTxBody ledgerBody scripts scriptData mAuxData scriptValidity = body
body' = ShelleyTxBody ledgerBody' scripts scriptData mAuxData scriptValidity
ledgerBody' =
ledgerBody
{ Ledger.txvldt = toLedgerValidityInterval (lb, up)
{ Ledger.txvldt =
toLedgerValidityInterval
( fromMaybe lowerBound lowerBound'
, fromMaybe upperBound upperBound'
)
}
Changes mutations ->
foldr applyMutation (tx, utxo) mutations
(lowerBound, upperBound) = fromLedgerValidityInterval ledgerValidityInterval
ledgerValidityInterval = Ledger.txvldt ledgerBody
--
-- Generators
(AssetId policyId t, q) | policyId == originalPolicyId -> (AssetId otherPolicyId t, q)
v -> v
in output{txOutValue = newValue}
replaceSnapshotNumber :: Head.SnapshotNumber -> Head.State -> Head.State
replaceSnapshotNumber snapshotNumber = \case
Head.Closed{parties, utxoHash, contestationDeadline, headId} ->
Head.Closed
{ Head.parties = parties
, Head.snapshotNumber = snapshotNumber
, Head.utxoHash = utxoHash
, Head.contestationDeadline = contestationDeadline
, Head.headId = headId
}
otherState -> otherState
replaceParties :: [Data.Party] -> Head.State -> Head.State
replaceParties parties = \case
Head.Initial{contestationPeriod, headId} ->
Head.Initial
{ Head.contestationPeriod = contestationPeriod
, Head.parties = parties
, Head.headId = headId
}
Head.Open{contestationPeriod, utxoHash, headId} ->
Head.Open
{ Head.contestationPeriod = contestationPeriod
, Head.parties = parties
, Head.utxoHash = utxoHash
, Head.headId = headId
}
Head.Closed{snapshotNumber, utxoHash, contestationDeadline, headId} ->
Head.Closed
{ Head.parties = parties
, Head.snapshotNumber = snapshotNumber
, Head.utxoHash = utxoHash
, Head.contestationDeadline = contestationDeadline
, Head.headId = headId
}
otherState -> otherState
replaceUtxoHash :: Head.Hash -> Head.State -> Head.State
replaceUtxoHash utxoHash = \case
Head.Open{contestationPeriod, parties, headId} ->
Head.Open
{ Head.contestationPeriod = contestationPeriod
, Head.parties = parties
, Head.utxoHash = utxoHash
, Head.headId = headId
}
Head.Closed{parties, snapshotNumber, contestationDeadline, headId} ->
Head.Closed
{ Head.parties = parties
, Head.snapshotNumber = snapshotNumber
, Head.utxoHash = utxoHash
, Head.contestationDeadline = contestationDeadline
, Head.headId = headId
}
otherState -> otherState
replaceContestationDeadline :: POSIXTime -> Head.State -> Head.State
replaceContestationDeadline contestationDeadline = \case
Head.Closed{snapshotNumber, utxoHash, parties, headId} ->
Head.Closed
{ snapshotNumber
, utxoHash
, parties
, contestationDeadline
, headId
}
otherState -> otherState
replaceHeadId :: CurrencySymbol -> Head.State -> Head.State
replaceHeadId headId = \case
Head.Initial{contestationPeriod, parties} ->
Head.Initial
{ Head.contestationPeriod = contestationPeriod
, Head.parties = parties
, Head.headId = headId
}
Head.Open{contestationPeriod, utxoHash, parties} ->
Head.Open
{ Head.contestationPeriod = contestationPeriod
, Head.parties = parties
, Head.utxoHash = utxoHash
, Head.headId = headId
}
Head.Closed{snapshotNumber, utxoHash, contestationDeadline, parties} ->
Head.Closed
{ Head.parties = parties
toPlutusTxOut,
)
import Hydra.Chain.Direct.Contract.Abort (genAbortMutation, healthyAbortTx, propHasCommit, propHasInitial)
import Hydra.Chain.Direct.Contract.Close (genCloseMutation, healthyCloseTx)
import Hydra.Chain.Direct.Contract.Close (genCloseInitialMutation, genCloseMutation, healthyCloseInitialTx, healthyCloseTx)
import Hydra.Chain.Direct.Contract.CollectCom (genCollectComMutation, healthyCollectComTx)
import Hydra.Chain.Direct.Contract.Commit (genCommitMutation, healthyCommitTx)
import Hydra.Chain.Direct.Contract.Contest (genContestMutation, healthyContestTx)
propTransactionValidates healthyCloseTx
prop "does not survive random adversarial mutations" $
propMutation healthyCloseTx genCloseMutation
describe "CloseInitial" $ do
prop "is healthy" $
propTransactionValidates healthyCloseInitialTx
prop "does not survive random adversarial mutations" $
propMutation healthyCloseInitialTx genCloseInitialMutation
describe "Contest" $ do
prop "is healthy" $
propTransactionValidates healthyContestTx
in action utxo tx
& label ("Fanout size: " <> prettyLength (countAssets $ txOuts' tx))
where
maxSupported = 67
maxSupported = 42
countAssets = getSum . foldMap (Sum . valueSize . txOutValue)
prettyLength len
| len > maxSupported = "> " <> show maxSupported <> " ???"
| len >= 50 = "50-" <> show maxSupported
| len >= 10 = "10-49"
| otherwise = "00-10"
| len >= 40 = "40-" <> show maxSupported
| len >= 10 = "10-40"
| len >= 1 = "1-10"
| otherwise = "0"
--
-- Generators
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-specialize #-}
module Hydra.Contract.Head where
module Hydra.Contract.Head (
DatumType,
RedeemerType,
headValidator,
hashPreSerializedCommits,
hashTxOuts,
verifyPartySignature,
verifySnapshotSignature,
compiledValidator,
validatorScript,
validatorHash,
) where
import PlutusTx.Prelude
import Hydra.Data.ContestationPeriod (ContestationPeriod, addContestationPeriod, milliseconds)
import Hydra.Data.Party (Party (vkey))
import Plutus.Extras (ValidatorType, scriptValidatorHash, wrapValidator)
import Plutus.V1.Ledger.Time (fromMilliSeconds)
import Plutus.V1.Ledger.Value (assetClass, assetClassValue, valueOf)
import Plutus.V2.Ledger.Api (
Address,
CurrencySymbol,
adaToken,
mkValidatorScript,
)
import Plutus.V2.Ledger.Contexts (findDatum, findDatumHash, findOwnInput, getContinuingOutputs)
import Plutus.V2.Ledger.Contexts (findDatum, findOwnInput, getContinuingOutputs)
import PlutusTx (CompiledCode)
import qualified PlutusTx
import qualified PlutusTx.AssocMap as Map
import qualified PlutusTx.Builtins as Builtins
-- REVIEW: Functions not re-exported "as V2", but using the same data types.
import Plutus.V1.Ledger.Time (fromMilliSeconds)
import Plutus.V1.Ledger.Value (assetClass, assetClassValue, valueOf)
type DatumType = State
type RedeemerType = Input
checkCollectCom ctx (contestationPeriod, parties, headId)
(Initial{parties, headId}, Abort) ->
checkAbort ctx headId parties
(Open{parties, utxoHash = initialUtxoHash, contestationPeriod, headId}, Close{snapshotNumber, utxoHash = closedUtxoHash, signature}) ->
checkClose ctx parties initialUtxoHash snapshotNumber closedUtxoHash signature contestationPeriod headId
(Closed{parties, snapshotNumber = closedSnapshotNumber, contestationDeadline, headId}, Contest{snapshotNumber = contestSnapshotNumber, utxoHash = contestUtxoHash, signature}) ->
checkContest ctx contestationDeadline parties closedSnapshotNumber contestSnapshotNumber contestUtxoHash signature headId
(Open{parties, utxoHash = initialUtxoHash, contestationPeriod, headId}, Close{signature}) ->
checkClose ctx parties initialUtxoHash signature contestationPeriod headId
(Closed{parties, snapshotNumber = closedSnapshotNumber, contestationDeadline, headId}, Contest{signature}) ->
checkContest ctx contestationDeadline parties closedSnapshotNumber signature headId
(Closed{utxoHash, contestationDeadline}, Fanout{numberOfFanoutOutputs}) ->
checkFanout utxoHash contestationDeadline numberOfFanoutOutputs ctx
_ ->
{-# INLINEABLE commitDatum #-}
-- | The close validator must verify that:
--
-- * Check that the closing tx validity is bounded by contestation period
-- Expressed in our spec as: `T_max <= T_min + CP`
--
-- * The closing snapshot number and signature is correctly signed
-- * Check that the deadline corresponds with tx validity and contestation period.
--
-- * The resulting closed state is consistent with the open state or the
-- closing snapshot, depending on snapshot number
-- * The resulting utxo hash is correctly signed or the initial utxo hash,
-- depending on snapshot number
--
-- * The transaction is performed (i.e. signed) by one of the head participants
--
ScriptContext ->
[Party] ->
BuiltinByteString ->
SnapshotNumber ->
BuiltinByteString ->
[Signature] ->
ContestationPeriod ->
CurrencySymbol ->
Bool
checkClose ctx parties initialUtxoHash snapshotNumber closedUtxoHash sig cperiod headPolicyId =
checkClose ctx parties initialUtxoHash sig cperiod headPolicyId =
hasBoundedValidity
&& checkDeadline
&& checkSnapshot
&& mustBeSignedByParticipant ctx headPolicyId
&& hasST headPolicyId outValue
&& mustNotChangeParameters
where
hasBoundedValidity = traceIfFalse "hasBoundedValidity check failed" $ tMax - tMin <= cp
hasBoundedValidity =
traceIfFalse "hasBoundedValidity check failed" $
tMax - tMin <= cp
outValue =
maybe mempty (txOutValue . txInInfoResolved) $ findOwnInput ctx
(closedSnapshotNumber, closedUtxoHash, parties', closedContestationDeadline, headId') =
-- XXX: fromBuiltinData is super big (and also expensive?)
case fromBuiltinData @DatumType $ getDatum (continuingDatum ctx) of
Just
Closed
{ snapshotNumber
, utxoHash
, parties = p
, contestationDeadline
, headId
} -> (snapshotNumber, utxoHash, p, contestationDeadline, headId)
_ -> traceError "wrong state in output datum"
checkSnapshot
| snapshotNumber == 0 =
let expectedOutputDatum =
Closed
{ parties
, snapshotNumber = 0
, utxoHash = initialUtxoHash
, contestationDeadline = makeContestationDeadline cperiod ctx
, headId = headPolicyId
}
in checkHeadOutputDatum ctx expectedOutputDatum
| snapshotNumber > 0 =
let expectedOutputDatum =
Closed
{ parties
, snapshotNumber
, utxoHash = closedUtxoHash
, contestationDeadline = makeContestationDeadline cperiod ctx
, headId = headPolicyId
}
in verifySnapshotSignature parties snapshotNumber closedUtxoHash sig
&& checkHeadOutputDatum ctx expectedOutputDatum
| otherwise = traceError "negative snapshot number"
| closedSnapshotNumber > 0 =
traceIfFalse "invalid snapshot signature" $
verifySnapshotSignature parties closedSnapshotNumber closedUtxoHash sig
| otherwise =
traceIfFalse "closed with non-initial hash" $
closedUtxoHash == initialUtxoHash
checkDeadline =
traceIfFalse "incorrect closed contestation deadline" $
closedContestationDeadline == makeContestationDeadline cperiod ctx
cp = fromMilliSeconds (milliseconds cperiod)
LowerBound (Finite t) _ -> t
_InfiniteBound -> traceError "infinite lower bound"
mustNotChangeParameters =
traceIfFalse "changed parameters" $
headId' == headPolicyId
&& parties' == parties
ScriptContext{scriptContextTxInfo = txInfo} = ctx
{-# INLINEABLE checkClose #-}
--
-- * The contest snapshot is correctly signed.
--
-- * The resulting closed state is consistent with the contested snapshot.
-- * No other parameters have changed.
--
-- * The transaction is performed before the deadline.
--
-- * The transaction is performed (i.e. signed) by one of the head participants
--
POSIXTime ->
[Party] ->
-- | Snapshot number of the closed state.
-- XXX: Having two snapshot numbers here is FRAGILE
SnapshotNumber ->
-- | Snapshot number of the contestin snapshot.
SnapshotNumber ->
BuiltinByteString ->
[Signature] ->
-- | Head id
CurrencySymbol ->
Bool
checkContest [email protected]{scriptContextTxInfo} contestationDeadline parties closedSnapshotNumber contestSnapshotNumber contestUtxoHash sig headPolicyId =
checkContest [email protected]{scriptContextTxInfo} contestationDeadline parties closedSnapshotNumber sig headId =
mustBeNewer
&& mustBeMultiSigned
&& checkHeadOutputDatum
ctx
(Closed{parties, snapshotNumber = contestSnapshotNumber, utxoHash = contestUtxoHash, contestationDeadline, headId = headPolicyId})
&& mustBeSignedByParticipant ctx headPolicyId
data Input
= CollectCom
| Close
{ snapshotNumber :: SnapshotNumber
, utxoHash :: Hash
, signature :: [Signature]
{ signature :: [Signature]
}
| Contest
{ snapshotNumber :: SnapshotNumber
, utxoHash :: Hash
, signature :: [Signature]
{ signature :: [Signature]
}
| Abort
| Fanout {numberOfFanoutOutputs :: Integer}
import qualified PlutusTx
import PlutusTx.Builtins (BuiltinByteString, fromBuiltin, toBuiltin)
import PlutusTx.IsData
import qualified PlutusTx.Prelude as PlutusTx
import Test.QuickCheck (vector)
-- | On-chain representation of a Hydra party.
-- always come from off-chain code via 'partyFromVerificationKeyBytes'.
newtype Party = UnsafeParty {vkey :: BuiltinByteString}
deriving stock (Eq, Generic)
deriving newtype (Show)
deriving newtype (Show, PlutusTx.Eq)
instance Arbitrary Party where
arbitrary = partyFromVerificationKeyBytes . BS.pack <$> vector 32
fix CI not running on bors branches
![iohk-bors[bot]](https://avatars.githubusercontent.com/in/17473?v=4&s=80)
5023: fix CI not running on bors branches r=disassembler a=dermetfan Looks like this was broken in #4930 as `prAndBorsIo` was added but not used. Also removed `nix` from the task name. I do not see what purpose it has and it makes the names unnecessarily long. Also we happen to need the old names in #5018. Co-authored-by: Robin Stumm <[email protected]>
I don't trust it. Compare these two runs: 1. https://github.com/input-output-hk/cardano-haskell-packages/actions/runs/4532746158/jobs/7984714895 2. https://github.com/input-output-hk/cardano-haskell-packages/actions/runs/4516172089/jobs/7954255360 The second is on the parent commit of the first, the commit itself is a no-op, and yet the derivations they build are not the same! Doing the same locally, I get a) a different derivation, but b) the same derivation for both. I conclude that what the CI is doing is questionable, the cache seems like the most likely source of pollution. I suspect whatever is causing this was also responsible for the no-op PR spending a lot of time building tons of stuff.
* Update readme (cli flags, comment dsl, new format) * Document the comment DSL * Document CLI flags * Mention new split rust/wasm output structure * Remove unsupported section (to handle in issues instead as this tends to get very outdated) * respond to comments + add supported.cddl * minor fixes for comment placement in supported.cddl + remove unsupported optional fixed value from example
Co-authored-by: Sebastien Guillemot <[email protected]>
5018: Use ouroboros-network-0.3.0.2 and ouroboros-network-framework-0.2.0.1 r=dermetfan a=coot Co-authored-by: Marcin Szamotulski <[email protected]> Co-authored-by: Samuel Leathers <[email protected]>
Waiting for a day, at a pace of one block every 20 seconds would generate 4320 blocks which takes forever to be created and processes, even in IO sim. We don't really observe the issue now because we cheat in the way we generate the block. This commit helps preparing for a more realistic block generation.
