/
Close.hs
282 lines (249 loc) · 11.2 KB
/
Close.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Hydra.Chain.Direct.Contract.Close where
import Hydra.Cardano.Api
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.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 Hydra.Contract.HeadTokens (headPolicyId)
import Hydra.Crypto (HydraKey, MultiSignature, aggregate, sign, toPlutusSignatures)
import Hydra.Data.ContestationPeriod (posixFromUTCTime)
import qualified Hydra.Data.ContestationPeriod as OnChain
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.Party (Party, deriveParty, partyToChain)
import Hydra.Snapshot (Snapshot (..), SnapshotNumber)
import Plutus.Orphans ()
import Plutus.V2.Ledger.Api (BuiltinByteString, toBuiltin, toData)
import Test.Hydra.Fixture (aliceSk, bobSk, carolSk)
import Test.QuickCheck (arbitrarySizedNatural, choose, elements, oneof, suchThat)
import Test.QuickCheck.Instances ()
--
-- CloseTx
--
healthyCloseTx :: (Tx, UTxO)
healthyCloseTx =
(tx, lookupUTxO)
where
tx =
closeTx
somePartyCardanoVerificationKey
healthyClosingSnapshot
healthyCloseLowerBoundSlot
healthyCloseUpperBoundPointInTime
openThreadOutput
(mkHeadId Fixture.testPolicyId)
lookupUTxO = UTxO.singleton (healthyOpenHeadTxIn, healthyOpenHeadTxOut)
headDatum = fromPlutusData $ toData healthyCloseDatum
openThreadOutput =
OpenThreadOutput
{ openThreadUTxO = (healthyOpenHeadTxIn, healthyOpenHeadTxOut, headDatum)
, openParties = healthyOnChainParties
, openContestationPeriod = healthyContestationPeriod
}
-- 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
healthyOpenHeadTxOut :: TxOut CtxUTxO
healthyOpenHeadTxOut =
mkHeadOutput testNetworkId Fixture.testPolicyId headTxOutDatum
& addParticipationTokens healthyParties
where
headTxOutDatum = toUTxOContext (mkTxOutDatum healthyCloseDatum)
-- FIXME: This is not a healthy value anyhow related to the 'healthyCloseTx' above
brokenSlotNo :: SlotNo
brokenSlotNo = arbitrary `generateWith` 42
healthyClosingSnapshot :: ClosingSnapshot
healthyClosingSnapshot =
CloseWithConfirmedSnapshot
{ snapshotNumber = healthySnapshotNumber
, closeUtxoHash = UTxOHash $ hashUTxO @Tx healthyCloseUTxO
, signatures = healthySignature healthySnapshotNumber
}
healthySnapshot :: Snapshot Tx
healthySnapshot =
Snapshot
{ number = healthySnapshotNumber
, utxo = healthyCloseUTxO
, confirmed = []
}
healthyCloseUTxO :: UTxO
healthyCloseUTxO =
(genOneUTxOFor somePartyCardanoVerificationKey `suchThat` (/= healthyUTxO))
`generateWith` 42
healthySnapshotNumber :: SnapshotNumber
healthySnapshotNumber = 1
healthyCloseDatum :: Head.State
healthyCloseDatum =
Head.Open
{ parties = healthyOnChainParties
, utxoHash = toBuiltin $ hashUTxO @Tx healthyUTxO
, contestationPeriod = healthyContestationPeriod
, headId = toPlutusCurrencySymbol Fixture.testPolicyId
}
healthyContestationPeriod :: OnChain.ContestationPeriod
healthyContestationPeriod = OnChain.contestationPeriodFromDiffTime $ fromInteger healthyContestationPeriodSeconds
healthyContestationPeriodSeconds :: Integer
healthyContestationPeriodSeconds = 10
healthyUTxO :: UTxO
healthyUTxO = genOneUTxOFor somePartyCardanoVerificationKey `generateWith` 42
somePartyCardanoVerificationKey :: VerificationKey PaymentKey
somePartyCardanoVerificationKey = flip generateWith 42 $ do
genForParty genVerificationKey <$> elements healthyParties
healthySigningKeys :: [SigningKey HydraKey]
healthySigningKeys = [aliceSk, bobSk, carolSk]
healthyParties :: [Party]
healthyParties = deriveParty <$> healthySigningKeys
healthyOnChainParties :: [OnChain.Party]
healthyOnChainParties = partyToChain <$> healthyParties
healthySignature :: SnapshotNumber -> MultiSignature (Snapshot Tx)
healthySignature number = aggregate [sign sk snapshot | sk <- healthySigningKeys]
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
| -- | Change the resulting snapshot number, this should make the signature
-- invalid.
MutateSnapshotNumberButNotSignature
| MutateSnapshotToIllFormedValue
| MutateParties
| MutateRequiredSigner
| MutateCloseUTxOHash
| MutateValidityInterval
| MutateCloseContestationDeadline
| MutateCloseContestationDeadlineWithZero
| MutateHeadId
deriving (Generic, Show, Enum, Bounded)
genCloseMutation :: (Tx, UTxO) -> Gen SomeMutation
genCloseMutation (tx, _utxo) =
oneof
[ SomeMutation Nothing MutateSignatureButNotSnapshotNumber . ChangeHeadRedeemer <$> do
Head.Close . toPlutusSignatures <$> (arbitrary :: Gen (MultiSignature (Snapshot Tx)))
, SomeMutation (Just "invalid snapshot signature") MutateSnapshotNumberButNotSignature <$> do
mutatedSnapshotNumber <- arbitrarySizedNatural `suchThat` (\n -> n /= healthySnapshotNumber && n > 0)
let newClosedState =
Head.Closed
{ snapshotNumber = toInteger mutatedSnapshotNumber
, utxoHash = Head.utxoHash healthyCloseDatum
, parties = Head.parties healthyCloseDatum
, contestationDeadline = posixFromUTCTime healthyContestationDeadline
, headId = Head.headId healthyCloseDatum
}
pure $ ChangeOutput 0 $ changeHeadOutputDatum (const newClosedState) headTxOut
, SomeMutation Nothing MutateSnapshotToIllFormedValue <$> do
mutatedSnapshotNumber <- arbitrary `suchThat` (< 0)
let mutatedSignature =
aggregate [sign sk $ serialize' mutatedSnapshotNumber | sk <- healthySigningKeys]
pure $
Changes
[ ChangeInputHeadDatum $
Head.Closed
{ snapshotNumber = mutatedSnapshotNumber
, utxoHash = healthyClosedUTxOHash
, parties = healthyOnChainParties
, contestationDeadline = posixFromUTCTime healthyContestationDeadline
, headId = toPlutusCurrencySymbol Fixture.testPolicyId
}
, ChangeHeadRedeemer $
Head.Close
{ signature = toPlutusSignatures mutatedSignature
}
]
, SomeMutation Nothing MutateParties . ChangeInputHeadDatum <$> do
mutatedParties <- arbitrary `suchThat` (/= healthyOnChainParties)
pure $
Head.Open
{ parties = mutatedParties
, utxoHash = ""
, contestationPeriod = healthyContestationPeriod
, headId = toPlutusCurrencySymbol Fixture.testPolicyId
}
, SomeMutation Nothing MutateRequiredSigner <$> do
newSigner <- verificationKeyHash <$> genVerificationKey
pure $ ChangeRequiredSigners [newSigner]
, SomeMutation Nothing MutateCloseUTxOHash . ChangeOutput 0 <$> mutateCloseUTxOHash
, SomeMutation (Just "incorrect closed contestation deadline") MutateCloseContestationDeadline . ChangeOutput 0
<$> (mutateClosedContestationDeadline =<< arbitrary @Integer `suchThat` (/= healthyContestationPeriodSeconds))
, SomeMutation Nothing MutateCloseContestationDeadlineWithZero . ChangeOutput 0 <$> mutateClosedContestationDeadline 0
, SomeMutation Nothing MutateValidityInterval . ChangeValidityInterval <$> do
lb <- arbitrary
ub <- arbitrary `suchThat` (/= TxValidityUpperBound brokenSlotNo)
pure (lb, ub)
, -- try to change a tx so that lower bound is higher than the upper bound
SomeMutation Nothing MutateValidityInterval . ChangeValidityInterval <$> do
lb <- arbitrary
ub <- (lb -) <$> choose (0, lb)
pure (TxValidityLowerBound (SlotNo lb), TxValidityUpperBound (SlotNo ub))
, SomeMutation Nothing MutateHeadId <$> do
otherHeadId <- headPolicyId <$> arbitrary `suchThat` (/= Fixture.testSeedInput)
pure $
Changes
[ ChangeOutput 0 (replacePolicyIdWith Fixture.testPolicyId otherHeadId headTxOut)
, ChangeInput
healthyOpenHeadTxIn
(replacePolicyIdWith Fixture.testPolicyId otherHeadId healthyOpenHeadTxOut)
(Just $ toScriptData healthyCloseDatum)
]
]
where
headTxOut = fromJust $ txOuts' tx !!? 0
mutateCloseUTxOHash :: Gen (TxOut CtxTx)
mutateCloseUTxOHash = do
mutatedUTxOHash <- genHash
pure $ changeHeadOutputDatum (mutateHash mutatedUTxOHash) headTxOut
mutateHash mutatedUTxOHash = \case
Head.Closed{snapshotNumber, parties, contestationDeadline, headId} ->
Head.Closed
{ snapshotNumber
, utxoHash = toBuiltin mutatedUTxOHash
, parties
, contestationDeadline
, headId
}
st -> error $ "unexpected state " <> show st
-- In case contestation period param is 'Nothing' we will generate arbitrary value
mutateClosedContestationDeadline :: Integer -> Gen (TxOut CtxTx)
mutateClosedContestationDeadline contestationPeriodSeconds = do
-- NOTE: we need to be sure the generated contestation period is large enough to have an impact on the on-chain
-- deadline computation, which means having a resolution of seconds instead of the default picoseconds
pure $ changeHeadOutputDatum (mutateContestationDeadline contestationPeriodSeconds) headTxOut
mutateContestationDeadline contestationPeriod = \case
Head.Closed{snapshotNumber, utxoHash, parties} ->
Head.Closed
{ snapshotNumber
, utxoHash
, parties
, contestationDeadline =
let closingTime = slotNoToUTCTime brokenSlotNo
in posixFromUTCTime $ addUTCTime (fromInteger contestationPeriod) closingTime
, headId = toPlutusCurrencySymbol Fixture.testPolicyId
}
st -> error $ "unexpected state " <> show st