/
ScriptsSpec.hs
404 lines (368 loc) · 14.7 KB
/
ScriptsSpec.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
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Cardano.Wallet.Primitive.ScriptsSpec
( spec
, genScript
) where
import Prelude
import Cardano.Address.Derivation
( XPub )
import Cardano.Address.Script
( KeyHash (..), Script (..), ScriptHash, toScriptHash )
import Cardano.Wallet.Primitive.AddressDerivation
( Depth (..)
, DerivationType (..)
, Index (..)
, NetworkDiscriminant (..)
, SoftDerivation
, WalletKey (..)
, deriveVerificationKey
, hashVerificationKey
)
import Cardano.Wallet.Primitive.AddressDerivation.Shelley
( ShelleyKey (..) )
import Cardano.Wallet.Primitive.AddressDerivationSpec
()
import Cardano.Wallet.Primitive.AddressDiscovery.Sequential
( AddressPoolGap (..)
, DerivationPrefix (..)
, SeqState (..)
, VerificationKeyPool (..)
, coinTypeAda
, defaultAddressPoolGap
, emptyPendingIxs
, getAddressPoolGap
, mkAddressPool
, newVerificationKeyPool
, purposeCIP1852
, purposeCIP1852
, verPoolIndexedKeys
, verPoolKnownScripts
)
import Cardano.Wallet.Primitive.Scripts
( isShared, retrieveAllVerKeyHashes )
import Cardano.Wallet.Primitive.Types.Address
( AddressState (..) )
import Cardano.Wallet.Unsafe
( unsafeXPub )
import Data.Map.Strict
( Map )
import Data.Ord
( Down (..) )
import Data.Set
( Set )
import Data.Word
( Word32 )
import Numeric.Natural
( Natural )
import Test.Hspec
( Spec, describe, it )
import Test.QuickCheck
( Arbitrary (..)
, Gen
, Positive (..)
, Property
, arbitrarySizedNatural
, choose
, elements
, oneof
, property
, scale
, shrinkIntegral
, sized
, vectorOf
, (.&&.)
, (===)
, (==>)
)
import qualified Data.ByteString.Char8 as B8
import qualified Data.List as L
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
spec :: Spec
spec = do
describe "isShared" $ do
it "script composed with all of our verification keys should discover them all"
(property prop_scriptFromOurVerKeys)
it "script composed with not our verification keys should not be discovered"
(property prop_scriptFromNotOurVerKeys)
it "the same script discovered twice should have the same knownScripts imprint"
(property prop_scriptDiscoveredTwice)
it "knownScripts of the sequential state is populated properly"
(property prop_scriptUpdatesStateProperly)
it "scripts with our verification keys are discovered properly"
(property prop_scriptsDiscovered)
it "scripts with two account key verification keys are discovered properly"
(property prop_scriptDiscoveredByTwo)
it "discovering our verification keys make them mark Used"
(property prop_markingDiscoveredVerKeys)
it "discovering works after pool extension"
(property prop_poolExtension)
it "before and after discovery pool number of last consequitive Unused keys stays the same"
(property prop_unusedVerKeysConstant)
it "discovered verification keys in scripts are consistent between knownScripts and indexedKeys"
(property prop_verKeysConsistent)
prop_scriptFromOurVerKeys
:: AccountXPubWithScripts
-> Property
prop_scriptFromOurVerKeys (AccountXPubWithScripts accXPub' scripts') = do
let (script:_) = scripts'
let scriptKeyHashes = retrieveAllVerKeyHashes script
let seqState = initializeState accXPub'
let (ourSharedKeys, _) = isShared script seqState
L.sort (L.nub $ map hashVerificationKey ourSharedKeys) ===
L.sort (L.nub scriptKeyHashes)
prop_scriptFromNotOurVerKeys
:: ShelleyKey 'AccountK XPub
-> AccountXPubWithScripts
-> Property
prop_scriptFromNotOurVerKeys accXPub' (AccountXPubWithScripts _accXPub scripts') = do
let (script:_) = scripts'
let seqState = initializeState accXPub'
let (ourSharedKeys, _) = isShared script seqState
ourSharedKeys === []
prop_scriptUpdatesStateProperly
:: AccountXPubWithScripts
-> Property
prop_scriptUpdatesStateProperly (AccountXPubWithScripts accXPub' scripts') = do
let (script:_) = scripts'
let sciptKeyHashes = retrieveAllVerKeyHashes script
let seqState = initializeState accXPub'
let (_, seqState') = isShared script seqState
let expected =
if L.length sciptKeyHashes == 0 then
Nothing
else Just (Set.fromList (L.nub sciptKeyHashes))
scriptKeyHashesInMap script accXPub' seqState' === expected
prop_scriptDiscoveredTwice
:: AccountXPubWithScripts
-> Property
prop_scriptDiscoveredTwice (AccountXPubWithScripts accXPub' scripts') = do
let (script:_) = scripts'
let seqState = initializeState accXPub'
let (_, seqState') = isShared script seqState
let (_, seqState'') = isShared script seqState'
seqState' === seqState''
prop_scriptsDiscovered
:: AccountXPubWithScripts
-> Property
prop_scriptsDiscovered (AccountXPubWithScripts accXPub' scripts') = do
let seqState0 = initializeState accXPub'
let seqState = foldr (\script s -> snd $ isShared script s) seqState0 scripts'
let scriptHashes = Set.fromList $ Map.keys $ getKnownScripts seqState
let scriptsWithKeyHashes =
L.filter (\s -> L.length (retrieveAllVerKeyHashes s) > 0) scripts'
scriptHashes === Set.fromList (map toScriptHash scriptsWithKeyHashes)
prop_scriptDiscoveredByTwo
:: TwoAccountXPubsWithScript
-> Property
prop_scriptDiscoveredByTwo (TwoAccountXPubsWithScript accXPub' accXPub'' script) = do
let seqState0' = initializeState accXPub'
let seqState0'' = initializeState accXPub''
let (_, seqState') = isShared script seqState0'
let (_, seqState'') = isShared script seqState0''
let sciptKeyHashes = retrieveAllVerKeyHashes script
let scriptKeyHashes' = scriptKeyHashesInMap script accXPub' seqState'
let scriptKeyHashes'' = scriptKeyHashesInMap script accXPub'' seqState''
let expected =
if L.length sciptKeyHashes == 0 then
Nothing
else Just (Set.fromList (L.nub sciptKeyHashes))
(scriptKeyHashes' <> scriptKeyHashes'') === expected
prop_markingDiscoveredVerKeys
:: AccountXPubWithScripts
-> Property
prop_markingDiscoveredVerKeys (AccountXPubWithScripts accXPub' scripts') = do
let (script:_) = scripts'
let sciptKeyHashes = retrieveAllVerKeyHashes script
let seqState = initializeState accXPub'
let (_, SeqState _ _ _ _ _ verKeyPool) =
isShared script seqState
let ourKeys = verPoolIndexedKeys verKeyPool
let discoveredKeyMap =
Map.filterWithKey (\k _ -> k `elem` sciptKeyHashes) ourKeys
let addressStatesToCheck =
map (\(_, (_, isUsed)) -> isUsed) $ Map.toList discoveredKeyMap
L.all (== Used) addressStatesToCheck === True
prop_poolExtension
:: AccountXPubWithScriptExtension
-> Property
prop_poolExtension (AccountXPubWithScriptExtension accXPub' scripts') =
all (\s -> L.length (retrieveAllVerKeyHashes s) > 0) scripts' ==>
scriptHashes == Set.fromList (map toScriptHash scripts') .&&.
seqState3 == seqState0
where
seqState0 = initializeState accXPub'
[script1,script2] = scripts'
seqState1 = snd $ isShared script1 seqState0
seqState2 = snd $ isShared script2 seqState1
seqState3 = snd $ isShared script2 seqState0
scriptHashes = Set.fromList $ Map.keys $ getKnownScripts seqState2
prop_unusedVerKeysConstant
:: AccountXPubWithScripts
-> Property
prop_unusedVerKeysConstant (AccountXPubWithScripts accXPub' scripts') = do
let (script:_) = scripts'
let seqState = initializeState accXPub'
let (_, seqState') = isShared script seqState
let lastUnusedKeys =
L.takeWhile (\(_,isUsed) -> isUsed == Unused) .
L.sortOn (Down . fst) .
Map.elems .
getVerKeyMap
L.length (lastUnusedKeys seqState) === L.length (lastUnusedKeys seqState')
prop_verKeysConsistent
:: AccountXPubWithScripts
-> Property
prop_verKeysConsistent (AccountXPubWithScripts accXPub' scripts') = do
let seqState0 = initializeState accXPub'
let seqState = foldr (\script s -> snd $ isShared script s) seqState0 scripts'
let verKeyIxs = L.nub $ concat $ Map.elems $ getKnownScripts seqState
let verKeyHashes = Map.keys $ Map.filter (\(_, isUsed) -> isUsed == Used) $
getVerKeyMap seqState
Set.fromList verKeyHashes === Set.fromList (map (deriveKeyHash accXPub') verKeyIxs)
data AccountXPubWithScripts = AccountXPubWithScripts
{ accXPub :: ShelleyKey 'AccountK XPub
, scripts :: [Script KeyHash]
} deriving (Eq, Show)
data AccountXPubWithScriptExtension = AccountXPubWithScriptExtension
{ accXPub :: ShelleyKey 'AccountK XPub
, scripts :: [Script KeyHash]
} deriving (Eq, Show)
data TwoAccountXPubsWithScript = TwoAccountXPubsWithScript
{ accXPub1 :: ShelleyKey 'AccountK XPub
, accXPub2 :: ShelleyKey 'AccountK XPub
, scripts :: Script KeyHash
} deriving (Eq, Show)
defaultPrefix :: DerivationPrefix
defaultPrefix = DerivationPrefix
( purposeCIP1852
, coinTypeAda
, minBound
)
deriveKeyHash
:: (SoftDerivation k, WalletKey k)
=> k 'AccountK XPub
-> Index 'Soft 'ScriptK
-> KeyHash
deriveKeyHash accXPub' =
hashVerificationKey . (deriveVerificationKey accXPub')
dummyRewardAccount :: ShelleyKey 'AddressK XPub
dummyRewardAccount = ShelleyKey $ unsafeXPub $ B8.replicate 64 '0'
initializeState
:: ShelleyKey 'AccountK XPub
-> SeqState 'Mainnet ShelleyKey
initializeState accXPub' =
let intPool = mkAddressPool accXPub' defaultAddressPoolGap []
extPool = mkAddressPool accXPub' defaultAddressPoolGap []
sPool = newVerificationKeyPool accXPub' defaultAddressPoolGap
in SeqState intPool extPool emptyPendingIxs dummyRewardAccount defaultPrefix sPool
getKnownScripts
:: SeqState 'Mainnet ShelleyKey
-> Map ScriptHash [Index 'Soft 'ScriptK]
getKnownScripts (SeqState _ _ _ _ _ verKeyPool) =
verPoolKnownScripts verKeyPool
getVerKeyMap
:: SeqState 'Mainnet ShelleyKey
-> Map KeyHash (Index 'Soft 'ScriptK, AddressState)
getVerKeyMap (SeqState _ _ _ _ _ verKeyPool) =
verPoolIndexedKeys verKeyPool
scriptKeyHashesInMap
:: Script KeyHash
-> ShelleyKey 'AccountK XPub
-> SeqState 'Mainnet ShelleyKey
-> Maybe (Set KeyHash)
scriptKeyHashesInMap script' accXPub' s =
Set.fromList . map (deriveKeyHash accXPub') <$>
Map.lookup (toScriptHash script') (getKnownScripts s)
{-------------------------------------------------------------------------------
Arbitrary Instances
-------------------------------------------------------------------------------}
instance Arbitrary Natural where
shrink = shrinkIntegral
arbitrary = arbitrarySizedNatural
genScript :: [KeyHash] -> Gen (Script KeyHash)
genScript keyHashes = scale (`div` 3) $ sized scriptTree
where
scriptTree 0 = oneof
[ RequireSignatureOf <$> elements keyHashes
, ActiveFromSlot <$> arbitrary
, ActiveUntilSlot <$> arbitrary
]
scriptTree n = do
Positive m <- arbitrary
let n' = n `div` (m + 1)
scripts' <- vectorOf m (scriptTree n')
let hasTimelocks = \case
ActiveFromSlot _ -> True
ActiveUntilSlot _ -> True
_ -> False
let scriptsWithValidTimelocks = case L.partition hasTimelocks scripts' of
([], rest) -> rest
([ActiveFromSlot s1, ActiveUntilSlot s2], rest) ->
if s2 <= s1 then
rest ++ [ActiveFromSlot s2, ActiveUntilSlot s1]
else
scripts'
([ActiveUntilSlot s2, ActiveFromSlot s1], rest) ->
if s2 <= s1 then
rest ++ [ActiveFromSlot s2, ActiveUntilSlot s1]
else
scripts'
([ActiveFromSlot _], _) -> scripts'
([ActiveUntilSlot _], _) -> scripts'
(_,rest) -> rest
case fromIntegral (L.length (filter (not . hasTimelocks) scriptsWithValidTimelocks)) of
0 -> scriptTree 0
num -> do
atLeast <- choose (1, num)
elements
[ RequireAllOf scriptsWithValidTimelocks
, RequireAnyOf scriptsWithValidTimelocks
, RequireSomeOf atLeast scriptsWithValidTimelocks
]
prepareVerKeys
:: ShelleyKey 'AccountK XPub
-> [Word32]
-> [ShelleyKey 'ScriptK XPub]
prepareVerKeys accXPub' =
let minIndex = getIndex @'Soft minBound
in map (\ix -> deriveVerificationKey accXPub' (toEnum (fromInteger $ toInteger $ minIndex + ix)))
instance Arbitrary AccountXPubWithScripts where
arbitrary = do
accXPub' <- arbitrary
let g = getAddressPoolGap defaultAddressPoolGap
kNum <- choose (2, g - 1)
let verKeyHashes = map hashVerificationKey (prepareVerKeys accXPub' [0 .. kNum])
scriptsNum <- choose (1,10)
AccountXPubWithScripts accXPub' <$> vectorOf scriptsNum (genScript verKeyHashes)
instance Arbitrary AccountXPubWithScriptExtension where
arbitrary = do
accXPub' <- arbitrary
-- the first script is expected to trigger extension to scriptPool
let g = getAddressPoolGap defaultAddressPoolGap
scriptTipping <-
genScript (hashVerificationKey <$> (prepareVerKeys accXPub' [g - 1]))
-- the next script is using extended indices that were not possible to be discovered
-- earlier, but are supposed to be discovered now
kNum <- choose (2,8)
let verKeysNext = prepareVerKeys accXPub' [g .. g + kNum]
scriptNext <- genScript (hashVerificationKey <$> verKeysNext)
pure $ AccountXPubWithScriptExtension accXPub' [scriptTipping, scriptNext]
instance Arbitrary TwoAccountXPubsWithScript where
arbitrary = do
accXPub1' <- arbitrary
accXPub2' <- arbitrary
let g = getAddressPoolGap defaultAddressPoolGap
kNum <- choose (1, g - 1)
let verKeyHashes accXPub' =
map hashVerificationKey (prepareVerKeys accXPub' [0 .. kNum])
let bothVerKeyHashes =
verKeyHashes accXPub1' ++ verKeyHashes accXPub2'
TwoAccountXPubsWithScript accXPub1' accXPub2' <$> genScript bothVerKeyHashes