-
Notifications
You must be signed in to change notification settings - Fork 211
/
DelegationSpec.hs
405 lines (350 loc) · 14 KB
/
DelegationSpec.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
405
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Cardano.Wallet.Primitive.AddressDiscovery.DelegationSpec where
import Cardano.Address.Derivation
( XPub )
import Cardano.Wallet.Primitive.AddressDerivation
( Depth (..)
, DerivationType (..)
, HardDerivation (..)
, KeyFingerprint (..)
, MkKeyFingerprint (..)
, MkKeyFingerprint
, RewardAccount (..)
, RewardAccount
, SoftDerivation (..)
, ToRewardAccount (..)
)
import Cardano.Wallet.Primitive.AddressDiscovery.Delegation
import Cardano.Wallet.Primitive.Types.Address
( Address (..) )
import Cardano.Wallet.Primitive.Types.Coin
( Coin (..) )
import Cardano.Wallet.Primitive.Types.Hash
( Hash (..) )
import Cardano.Wallet.Primitive.Types.Tx
( TxIn (..), TxOut )
import Control.Arrow
( first, second )
import Control.Monad.Trans.Class
( lift )
import Control.Monad.Trans.State.Strict
import Crypto.Hash.Utils
( blake2b224 )
import Data.Either
( isRight )
import Data.Map
( Map )
import Data.Maybe
( isNothing )
import Data.Set
( Set )
import GHC.Generics
( Generic )
import Prelude
import Quiet
( Quiet (..) )
import Test.Hspec
import Test.QuickCheck
( Arbitrary (..)
, NonNegative (..)
, counterexample
, cover
, forAllShow
, frequency
, genericShrink
, label
, property
, sublistOf
, (===)
)
import Test.QuickCheck.Arbitrary.Generic
( genericArbitrary )
import qualified Data.ByteString.Char8 as B8
import qualified Data.Map as Map
import qualified Data.Map.Internal as Map
import qualified Data.Set as Set
spec :: Spec
spec = do
let acc = toRewardAccount @StakeKey' . toEnum
let regAndDeleg i = applyTx $ Tx
[ RegisterKey $ acc i
, Delegate $ acc i
] [] []
let s0 = initialDelegationState accK
describe "initialDelegationState" $ do
it "presentableKeys is [0]" $ do
(presentableKeys s0) `shouldBe` [toEnum 0]
it "usableKeys is [0]" $ do
usableKeys s0 `shouldBe` [toEnum 0]
it "key 0 is allowed to be registered" $ do
pendingWith "todo"
it "no key can be de-registered" $ do
pendingWith "todo"
let s1 = regAndDeleg 0 s0
describe "registering and delegating key 0" $ do
it "presentableKeys == [0, 1]" $ do
(presentableKeys s1) `shouldBe` [toEnum 0, toEnum 1]
it "usableKeys is still [0]" $ do
usableKeys s1 `shouldBe` [toEnum 0]
let s2 = regAndDeleg 1 s1
describe "registering and delegating key 1" $ do
it "presentableKeys == [0, 1, 2]" $ do
(presentableKeys s2) `shouldBe` [toEnum 0, toEnum 1, toEnum 2]
it "usableKeys == [0, 1]" $ do
usableKeys s2 `shouldBe` [toEnum 0, toEnum 1]
it "key 2 is allowed to be registered" $ do
pendingWith "todo"
it "key 1 is allowed to be de-registered" $ do
pendingWith "todo"
let s3 = regAndDeleg 5 s2
describe "Impossible gaps in stake keys (shouldn't happen unless\
\ someone manually constructs txs to mess with the on-chain state)" $ do
it "presentableKeys == [0, 1, 2] (doesn't find 5)" $ do
(presentableKeys s3) `shouldBe`
[toEnum 0, toEnum 1, toEnum 2]
it "usableKeys == [0, 1]" $ do
usableKeys s3 `shouldBe` [toEnum 0, toEnum 1]
it "key 2 is allowed to be registered" $ do
pendingWith "todo"
it "key 1 is allowed to be de-registered" $ do
pendingWith "think through"
it "key 5 is allowed to be de-registered" $ do
pendingWith "think through"
it "(presentableKeys s) are consequtive" $ property $ \cmds -> do
let ((s, _ledger), _chain) = applyCmds cmds
let keys = map fromEnum $ usableKeys s
--counterexample ("Keys: " <> show keys)
isConsecutiveRange keys
it "adversaries can't affect usableKeys" $ property $ \cmds -> do
counterexample "\nstate /= state without adversarial cmds" $ do
let usableKeys' = usableKeys . fst . fst . applyCmds
usableKeys' cmds
=== usableKeys' (filter (not . isAdversarial) cmds)
it "cmds and (cmdsFromChain (chainFromCmds cmds)) produce the same state"
$ property $ \cmds -> do
let ((s, _ledger), txs) = applyCmds (filter (not . isAdversarial) cmds)
let ((s', _ledger), _txs) = applyCmds $ cmdsFromChain txs
-- Hack to allow isKey0Reg to differ. @cmdsFromChain@ won't be able
-- to generate @CmdOldWalletToggleFirstKey@.
-- This could be fixed. We can also question whether this test
-- actually is useful...?
s' === s { isKey0Reg = isKey0Reg s' }
it "(apply (cmds <> CmdSetPortfolioOf 0) s0) === s0"
$ property $ \cmds -> do
let ((s, _ledger), _chain) = applyCmds (cmds ++ [CmdSetPortfolioOf 0])
-- NOTE: It wouldn't be wrong to allow presentableKeys to show keys
-- registered but not delegating. But we don't really expect such
-- cases to happen, so there's no need.
--
-- Because of this, we can just check for direct equality here:
s === s0
describe "Mock ledger" $ do
it "accepts all generated mock chains" $ property $ \cmds -> do
let chain = chainFromCmds cmds
let l = applyLedger chain initialLedger
let showTxs txs =
"\nTxs:\n" <> unlines (map show txs) <> "\n"
case l of
Right _ -> label "chain valid according to ledger" True
Left e -> counterexample (showTxs chain)
$ counterexample e False
describe "Dropped or re-ordered transactions" $ do
it "chain valid to ledger => activeKeys == regs ledger" $ property $ \cmds -> do
let chain = chainFromCmds cmds
let showTxs txs =
"\nTxs:\n" <> unlines (map show txs) <> "\n"
forAllShow (sublistOf chain) showTxs $ \subChain -> do
let s = apply subChain s0
let l = applyLedger subChain initialLedger
cover 0.5 (isRight l) "valid chain" $
case l of
Right (Ledger regs _) -> counterexample
"valid chain => expecting the wallet's activeKeys \
\to match all registered keys in the ledger" $
Set.fromList (fmap toRewardAccount (activeKeys s))
=== regs
Left _ -> property True
accK :: StakeKey' 'AccountK XPub
accK = StakeKey' 0
apply :: [Tx] -> DelegationState StakeKey' -> DelegationState StakeKey'
apply txs s = foldl (flip applyTx) s txs
txid :: Tx -> Hash "Tx"
txid = Hash . blake2b224 . B8.pack . show
applyLedger
:: [Tx]
-> Ledger
-> Either String Ledger
applyLedger txs = execStateT (mapM_ ledgerApplyTx' txs)
where
ledgerApplyTx' c = do
l <- get
l' <- lift (ledgerApplyTx c l)
put l'
isConsecutiveRange :: (Eq a, Num a) => [a] -> Bool
isConsecutiveRange [_] = True
isConsecutiveRange [] = True
isConsecutiveRange (a:b:t)
| b == a + 1 = isConsecutiveRange (b:t)
| otherwise = False
--
-- Mock Stake Keys
--
-- | Mock key type for testing.
--
-- FIXME: We should do /some/ testing with @ShelleyKey@ though.
newtype StakeKey' (depth :: Depth) key = StakeKey' Word
deriving newtype (Eq, Enum, Ord, Show, Bounded)
type StakeKey = StakeKey' 'AddressK XPub
instance ToRewardAccount StakeKey' where
toRewardAccount (StakeKey' i) = RewardAccount . B8.pack $ show i
someRewardAccount = error "todo: this should take ix, presumably?"
instance HardDerivation StakeKey' where
type AddressIndexDerivationType StakeKey' = 'Soft
deriveAccountPrivateKey _ _ _ = error "todo"
deriveAddressPrivateKey _ _ _ _ = error "todo"
instance SoftDerivation StakeKey' where
deriveAddressPublicKey _acc _role i = StakeKey' $ toEnum $ fromEnum i
instance MkKeyFingerprint StakeKey' Address where
paymentKeyFingerprint (Address addr) = Right $ KeyFingerprint addr
instance MkKeyFingerprint StakeKey' (StakeKey' 'AddressK XPub) where
paymentKeyFingerprint k = Right $ KeyFingerprint $ "addr" <> unRewardAccount (toRewardAccount k)
--
-- Mock chain of delegation certificates
--
instance Arbitrary RewardAccount where
arbitrary = toRewardAccount @StakeKey' <$> arbitrary
instance Arbitrary Cert where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary (StakeKey' depth key) where
arbitrary = StakeKey' <$> arbitrary
--
-- Mock chain data
--
data Cmd
= CmdSetPortfolioOf Int
-- ^ Calls @setPortfolioOf@ which registers or de-registers keys to reach
-- the new target.
--
-- If the target is already met, the command has no effect.
--
-- Delegation certificates are /not/ generated for existing keys.
--
-- TODO: Also test arbitrary re-delegations.
| CmdOldWalletToggleFirstKey
-- ^ A wallet implementation without multi-stake-key support could decide
-- to either
-- 1. register stake-key 0 witout adding a pointer UTxO
-- 2. de-register stake-key 0 despite despite e.g. key 1 being active
-- depending on whether it is registered or not.
--
-- Having a "toggle"-command instead of two separate commands, makes
-- generating valid arbitrary values easier.
| CmdAdversarialReg RewardAccount
-- ^ Someone could pay 2 ada to (re-)register your stake key. Your wallet
-- shouldn't be affected negatively from it.
deriving (Generic, Eq)
isAdversarial :: Cmd -> Bool
isAdversarial (CmdSetPortfolioOf _) = False
isAdversarial (CmdAdversarialReg _) = True
isAdversarial CmdOldWalletToggleFirstKey = False
instance Show Cmd where
show (CmdSetPortfolioOf n) = "CmdSetPortfolioOf " <> show n
show (CmdAdversarialReg (RewardAccount a)) = "CmdAdversarialReg " <> B8.unpack a
show CmdOldWalletToggleFirstKey = "CmdOldWalletToggleFirstKey"
instance Arbitrary Cmd where
-- We don't want to generate too many adversarial registrations (we don't
-- expect them to happen in reality), but at least some, and enough to cause
-- consistent failures if something is wrong.
arbitrary = frequency
[ (98, CmdSetPortfolioOf . getNonNegative <$> arbitrary)
, (0, CmdAdversarialReg <$> arbitrary) -- TODO: Re-enable
, (2, pure CmdOldWalletToggleFirstKey)
]
shrink = genericShrink
cmdsFromChain :: [Tx] -> [Cmd]
cmdsFromChain =
map (CmdSetPortfolioOf . length . activeKeys)
. scanl (flip applyTx) (initialDelegationState accK)
chainFromCmds :: [Cmd] -> [Tx]
chainFromCmds = snd . applyCmds
applyCmds :: [Cmd] -> ((DelegationState StakeKey', Ledger), [Tx])
applyCmds = second reverse . foldl step ((s0, initialLedger), [])
where
-- TODO: Would be nice to have some abstraction to remove the boilerplate
-- here. Maybe StateT or some Foldable thing.
step ((s, l), accTxs) (CmdSetPortfolioOf n) = case setPortfolioOf s mkAddr (acctIsReg l) n of
Just tx -> ((applyTx tx s, applyLedger' tx l), tx:accTxs)
Nothing -> ((s, l), accTxs)
step ((s,l), accTxs) (CmdAdversarialReg k) =
let tx = Tx [RegisterKey k] [] []
in ((s,applyLedger' tx l), tx:accTxs)
step ((s, l@(Ledger regs _)), accTxs) CmdOldWalletToggleFirstKey =
let
key0 = toRewardAccount (keyAtIx s minBound)
isReg = key0 `Set.member` regs
tx = Tx [if isReg then DeRegisterKey key0 else RegisterKey key0] [] []
in ((applyTx tx s, applyLedger' tx l), tx:accTxs)
s0 = initialDelegationState accK
applyLedger' tx l = either (error . show) id $ ledgerApplyTx tx l
mkAddr k = Address $ "addr" <> unRewardAccount (toRewardAccount k)
--
-- Mock ledger
--
data Ledger = Ledger
{ regs :: Set RewardAccount
, utxos :: Map TxIn TxOut
} deriving (Show, Eq)
initialLedger :: Ledger
initialLedger = Ledger Set.empty Map.empty
acctIsReg :: Ledger -> RewardAccount -> Bool
acctIsReg l a = a `Set.member` (regs l)
ledgerApplyTx :: Tx -> Ledger -> Either String Ledger
ledgerApplyTx tx l' =
(foldl (\x y -> x >>= ledgerApplyCert y) (Right l') (certs tx))
>>= ledgerApplyInsOus
where
ledgerApplyInsOus :: Ledger -> Either String Ledger
ledgerApplyInsOus (Ledger r utxo) =
let
-- TODO: There could be duplicates, which we should forbid
ins = Set.fromList $ map fst $ inputs tx
h = txid tx
newOuts = Map.fromList $
zipWith
(curry $ first (TxIn h))
[0 ..]
(outputs tx)
canSpend = ins `Set.isSubsetOf` Map.keysSet utxo
in
if canSpend
then Right $ Ledger r $ Map.union newOuts $ utxo `Map.withoutKeys` ins
else Left "invalid utxo spending"
ledgerApplyCert :: Cert -> Ledger -> Either String Ledger
ledgerApplyCert (Delegate k) l
| k `Set.member` (regs l)
= pure l
| otherwise
= Left $ "Can't delegate: " <> show k <> " not in " <> show l
ledgerApplyCert (RegisterKey k) l
| k `Set.member` (regs l)
= Left $ "Can't register: " <> show k <> " already in: " <> show l
| otherwise
= pure $ l { regs = Set.insert k (regs l) }
ledgerApplyCert (DeRegisterKey k) l
| k `Set.member` (regs l)
= pure $ l { regs = Set.delete k (regs l) }
| otherwise
= Left $ "Can't deregister: " <> show k <> " not in " <> show l