-
Notifications
You must be signed in to change notification settings - Fork 23
/
Generators.hs
1214 lines (1086 loc) · 50.2 KB
/
Generators.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
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | This module implements QuickCheck generators for types that are commonly used in tests.
module Generators where
import Test.QuickCheck
import Control.Monad
import qualified Data.ByteString as BS
import qualified Data.ByteString.Short as BSS
import qualified Data.Map.Strict as Map
import Data.Ratio
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import Data.Singletons
import qualified Data.Text as Text
import qualified Data.Text.Encoding as TE
import qualified Data.Vector as Vec
import Data.Word
import System.IO.Unsafe
import System.Random
import Concordium.Common.Time
import Concordium.Constants
import qualified Concordium.Crypto.BlockSignature as BlockSig
import qualified Concordium.Crypto.BlsSignature as Bls
import Concordium.Crypto.DummyData
import Concordium.Crypto.EncryptedTransfers
import Concordium.Crypto.FFIDataTypes
import Concordium.Crypto.Proofs
import qualified Concordium.Crypto.SHA256 as SHA256
import Concordium.Crypto.SignatureScheme
import qualified Concordium.Crypto.VRF as VRF
import Concordium.Genesis.Parameters
import Concordium.ID.DummyData
import Concordium.ID.Types
import Concordium.Types
import Concordium.Types.Conditionally
import Concordium.Types.Execution
import Concordium.Types.Parameters
import Concordium.Types.Transactions
import Concordium.Types.Updates
import qualified Concordium.Wasm as Wasm
import qualified Data.FixedByteString as FBS
genAmount :: Gen Amount
genAmount = Amount <$> arbitrary
genAttributeValue :: Gen AttributeValue
genAttributeValue = AttributeValue . BSS.pack <$> (vector =<< choose (0, 31))
genDlogProof :: Gen Dlog25519Proof
genDlogProof = fst . randomProof . mkStdGen <$> resize 100000 arbitrary
genAccountOwnershipProof :: Gen AccountOwnershipProof
genAccountOwnershipProof = do
n <- choose (1, 255)
AccountOwnershipProof
<$> replicateM
n
( do
keyIndex <- KeyIndex <$> arbitrary
proof <- genDlogProof
return (keyIndex, proof)
)
genAggregationVerifyKeyAndProof :: Gen (BakerAggregationVerifyKey, BakerAggregationProof)
genAggregationVerifyKeyAndProof = do
c <- arbitrary
sk <- secretBlsKeyGen
-- FIXME: The use of unsafePerformIO here is wrong, but I'm in a hurry.
-- The randomness is used to get the zero-knowledge property
-- We need to expose a deterministic "prove" function from rust that takes a seed.
return (Bls.derivePublicKey sk, unsafePerformIO $ Bls.proveKnowledgeOfSK (BS.pack c) sk)
genAccountAddress :: Gen AccountAddress
genAccountAddress = AccountAddress . FBS.pack <$> vector accountAddressSize
genAccountAliases :: AccountAddress -> Gen AccountAddress
genAccountAliases (AccountAddress addr) = do
suffix <- vector 3
return $ AccountAddress . FBS.pack $ (take accountAddressPrefixSize (FBS.unpack addr) ++ suffix)
genCAddress :: Gen ContractAddress
genCAddress = ContractAddress <$> (ContractIndex <$> arbitrary) <*> (ContractSubindex <$> arbitrary)
genModuleRef :: Gen ModuleRef
genModuleRef = ModuleRef . SHA256.hash . BS.pack <$> vector 32
-- These generators name contracts as numbers to make sure the names are valid.
genInitName :: Gen Wasm.InitName
genInitName =
Wasm.InitName . Text.pack . ("init_" ++) . show <$> (arbitrary :: Gen Word)
genReceiveName :: Gen Wasm.ReceiveName
genReceiveName = do
contract <- show <$> (arbitrary :: Gen Word)
receive <- show <$> (arbitrary :: Gen Word)
return . Wasm.ReceiveName . Text.pack $ receive ++ "." ++ contract
genParameter :: Gen Wasm.Parameter
genParameter = do
n <- choose (0, 1000)
Wasm.Parameter . BSS.pack <$> vector n
-- | Generate a 'UrlText' that is a UTF-8 encoded string of no more than 'maxUrlTextLength' bytes.
genUrlText :: Gen UrlText
genUrlText =
UrlText
<$> suchThat
(Text.pack <$> scale (min (fromIntegral maxUrlTextLength)) (listOf arbitrary))
((<= fromIntegral maxUrlTextLength) . BS.length . TE.encodeUtf8)
-- | Generate an 'AmountFraction' in the range [0,1].
genAmountFraction :: Gen AmountFraction
genAmountFraction = makeAmountFraction <$> arbitrary `suchThat` (<= 100000)
-- | Generate a 'CapitalBound', in the range (0,1]. (0 is not a valid 'CapitalBound'.)
genCapitalBound :: Gen CapitalBound
genCapitalBound = CapitalBound . makeAmountFraction <$> arbitrary `suchThat` (\x -> x <= 100000 && x > 0)
genInclusiveRangeOfAmountFraction :: Gen (InclusiveRange AmountFraction)
genInclusiveRangeOfAmountFraction = do
(irMin, irMax) <-
((,) <$> genAmountFraction <*> genAmountFraction)
`suchThat` (\(i0, i1) -> i0 <= i1)
return InclusiveRange{..}
-- | Generate payloads that are valid for the given protocol version.
-- This includes all payload types except encrypted transfers (with and without memo) and
-- transfer to public.
genPayload :: ProtocolVersion -> Gen Payload
genPayload pv =
oneof $
[ genPayloadDeployModule pv,
genPayloadInitContract,
genPayloadUpdate,
genPayloadTransfer,
genPayloadUpdateCredentials,
genPayloadUpdateCredentialKeys,
genPayloadRegisterData,
genPayloadTransferWithSchedule
]
++ [genPayloadTransferToEncrypted | pv < P7]
++ (if pv >= P2 then [genTransferWithMemo, genTransferWithScheduleAndMemo] else [])
++ if pv < P4
then
[ genPayloadAddBaker,
genPayloadRemoveBaker,
genPayloadUpdateBakerStake,
genPayloadUpdateBakerRestateEarnings,
genPayloadUpdateBakerKeys
]
else
[ genPayloadConfigureBaker pv,
genPayloadConfigureDelegation
]
-- | Generate payloads that are valid for some protocol version, but may not be valid for all.
genPayloadUnsafe :: Gen Payload
genPayloadUnsafe =
oneof $
[ -- All module version are supported at P4.
genPayloadDeployModule P4,
genPayloadInitContract,
genPayloadUpdate,
genPayloadTransfer,
genPayloadUpdateCredentials,
genPayloadUpdateCredentialKeys,
genPayloadRegisterData,
genPayloadTransferWithSchedule,
genPayloadTransferToEncrypted,
genTransferWithMemo,
genTransferWithScheduleAndMemo,
genPayloadAddBaker,
genPayloadRemoveBaker,
genPayloadUpdateBakerStake,
genPayloadUpdateBakerRestateEarnings,
genPayloadUpdateBakerKeys,
genPayloadConfigureDelegation
]
++ [genPayloadConfigureBaker pv | pv <- [P4, P5, P6, P7, P8]]
genPayloadUpdateCredentials :: Gen Payload
genPayloadUpdateCredentials = do
maxNumCredentials <- choose (0, 255)
indices <- Set.fromList . map CredentialIndex <$> replicateM maxNumCredentials (choose (0, 255))
-- the actual number of key indices. Duplicate key indices might have been generated.
let numCredentials = Set.size indices
credentials <- replicateM numCredentials genCredentialDeploymentInformation
ucNewThreshold <- AccountThreshold <$> choose (1, 255) -- since we are only updating there is no requirement that the threshold is less than the amount of credentials
toRemoveLen <- choose (0, 30)
ucRemoveCredIds <- replicateM toRemoveLen genCredentialId
return UpdateCredentials{ucNewCredInfos = Map.fromList (zip (Set.toList indices) credentials), ..}
genByteString :: Gen BS.ByteString
genByteString = do
n <- choose (0, 1000)
BS.pack <$> vector n
genPayloadDeployModule :: ProtocolVersion -> Gen Payload
genPayloadDeployModule pv =
let genV0 = DeployModule . Wasm.WasmModuleV0 . Wasm.WasmModuleV . Wasm.ModuleSource <$> Generators.genByteString
genV1 = DeployModule . Wasm.WasmModuleV1 . Wasm.WasmModuleV . Wasm.ModuleSource <$> Generators.genByteString
in if pv <= P3 -- protocol versions <= 3 only allow version 0 Wasm modules.
then genV0
else oneof [genV0, genV1]
genPayloadInitContract :: Gen Payload
genPayloadInitContract = do
icAmount <- Amount <$> arbitrary
icModRef <- genModuleRef
icInitName <- genInitName
icParam <- genParameter
return InitContract{..}
genPayloadUpdate :: Gen Payload
genPayloadUpdate = do
uAmount <- Amount <$> arbitrary
uAddress <- genCAddress
uMessage <- genParameter
uReceiveName <- genReceiveName
return Update{..}
genPayloadTransfer :: Gen Payload
genPayloadTransfer = do
a <- genAccountAddress
amnt <- Amount <$> arbitrary
return $ Transfer a amnt
genPayloadAddBaker :: Gen Payload
genPayloadAddBaker = do
abElectionVerifyKey <- VRF.publicKey <$> arbitrary
abSignatureVerifyKey <- BlockSig.verifyKey <$> genBlockKeyPair
(abAggregationVerifyKey, abProofAggregation) <- genAggregationVerifyKeyAndProof
abProofSig <- genDlogProof
abProofElection <- genDlogProof
abBakingStake <- arbitrary
abRestakeEarnings <- arbitrary
return AddBaker{..}
genPayloadRemoveBaker :: Gen Payload
genPayloadRemoveBaker = return RemoveBaker
genPayloadUpdateBakerStake :: Gen Payload
genPayloadUpdateBakerStake = UpdateBakerStake <$> arbitrary
genPayloadUpdateBakerRestateEarnings :: Gen Payload
genPayloadUpdateBakerRestateEarnings = UpdateBakerRestakeEarnings <$> arbitrary
genPayloadUpdateBakerKeys :: Gen Payload
genPayloadUpdateBakerKeys = do
ubkElectionVerifyKey <- VRF.publicKey <$> arbitrary
ubkSignatureVerifyKey <- BlockSig.verifyKey <$> genBlockKeyPair
(ubkAggregationVerifyKey, ubkProofAggregation) <- genAggregationVerifyKeyAndProof
ubkProofSig <- genDlogProof
ubkProofElection <- genDlogProof
return UpdateBakerKeys{..}
genPayloadUpdateCredentialKeys :: Gen Payload
genPayloadUpdateCredentialKeys = do
uckKeys <- genCredentialPublicKeys
uckCredId <- genCredentialId
return UpdateCredentialKeys{..}
genPayloadTransferToEncrypted :: Gen Payload
genPayloadTransferToEncrypted = TransferToEncrypted . Amount <$> arbitrary
genPayloadRegisterData :: Gen Payload
genPayloadRegisterData = do
n <- chooseInt (0, maxRegisteredDataSize)
rdData <- RegisteredData . BSS.pack <$> vectorOf n arbitrary
return RegisterData{..}
genPayloadConfigureBaker :: ProtocolVersion -> Gen Payload
genPayloadConfigureBaker pv = do
cbCapital <- arbitrary
cbRestakeEarnings <- arbitrary
cbOpenForDelegation <- liftArbitrary $ elements [OpenForAll, ClosedForNew, ClosedForAll]
cbKeysWithProofs <- liftArbitrary $ do
sigPair <- (,) <$> (BlockSig.verifyKey <$> genBlockKeyPair) <*> genDlogProof
elecPair <- (,) <$> (VRF.publicKey <$> arbitrary) <*> genDlogProof
aggPair <- genAggregationVerifyKeyAndProof
return
BakerKeysWithProofs
{ bkwpElectionVerifyKey = fst elecPair,
bkwpProofElection = snd elecPair,
bkwpSignatureVerifyKey = fst sigPair,
bkwpProofSig = snd sigPair,
bkwpAggregationVerifyKey = fst aggPair,
bkwpProofAggregation = snd aggPair
}
cbMetadataURL <- liftArbitrary genUrlText
cbTransactionFeeCommission <- liftArbitrary genAmountFraction
cbBakingRewardCommission <- liftArbitrary genAmountFraction
cbFinalizationRewardCommission <- liftArbitrary genAmountFraction
cbSuspend <-
if supportsValidatorSuspension (accountVersionFor pv)
then arbitrary
else return Nothing
return ConfigureBaker{..}
genPayloadTransferWithSchedule :: Gen Payload
genPayloadTransferWithSchedule = do
twsTo <- genAccountAddress
len <- chooseBoundedIntegral (0, 255)
twsSchedule :: [(Timestamp, Amount)] <- vectorOf len $ do
ts <- genTimestamp
amnt <- Amount <$> arbitrary
return (ts, amnt)
return $ TransferWithSchedule{..}
genTransferWithMemo :: Gen Payload
genTransferWithMemo = do
twmToAddress <- genAccountAddress
twmMemo <- genMemo
twmAmount <- Amount <$> arbitrary
return TransferWithMemo{..}
genTransferWithScheduleAndMemo :: Gen Payload
genTransferWithScheduleAndMemo = do
twswmTo <- genAccountAddress
twswmMemo <- genMemo
len <- chooseBoundedIntegral (0, 255)
twswmSchedule :: [(Timestamp, Amount)] <- vectorOf len $ do
ts <- genTimestamp
amnt <- Amount <$> arbitrary
return (ts, amnt)
return TransferWithScheduleAndMemo{..}
genDelegationTarget :: Gen DelegationTarget
genDelegationTarget =
oneof [return DelegatePassive, DelegateToBaker . BakerId . AccountIndex <$> arbitrary]
genPayloadConfigureDelegation :: Gen Payload
genPayloadConfigureDelegation = do
cdCapital <- arbitrary
cdRestakeEarnings <- arbitrary
cdDelegationTarget <- liftArbitrary $ genDelegationTarget
return ConfigureDelegation{..}
genCredentialId :: Gen CredentialRegistrationID
genCredentialId = RegIdCred . generateGroupElementFromSeed globalContext <$> arbitrary
genSignThreshold :: Gen SignatureThreshold
genSignThreshold = SignatureThreshold <$> choose (1, 255)
-- | Simply generate a few 'ElgamalCipher' values for testing purposes.
elgamalCiphers :: Vec.Vector ElgamalCipher
elgamalCiphers = unsafePerformIO $ Vec.replicateM 200 generateElgamalCipher
{-# NOINLINE elgamalCiphers #-}
genElgamalCipher :: Gen ElgamalCipher
genElgamalCipher = do
i <- choose (0, Vec.length elgamalCiphers - 1)
return $ elgamalCiphers Vec.! i
-- generate an increasing list of key indices, at least 1
genIndices :: Gen [KeyIndex]
genIndices = do
maxLen <- choose (1 :: Int, 255)
let go is _ 0 = return is
go is nextIdx n = do
nextIndex <- choose (nextIdx, 255)
if nextIndex == 255
then return (KeyIndex nextIndex : is)
else go (KeyIndex nextIndex : is) (nextIndex + 1) (n - 1)
reverse <$> go [] 0 maxLen
genAccountKeysMap :: Gen (Map.Map KeyIndex VerifyKey)
genAccountKeysMap = do
indexList <- genIndices
mapList <- forM indexList $ \idx -> do
kp <- genSigSchemeKeyPair
return (idx, correspondingVerifyKey kp)
return $ Map.fromList mapList
genCredentialPublicKeys :: Gen CredentialPublicKeys
genCredentialPublicKeys = do
credKeys <- genAccountKeysMap
credThreshold <- genSignThreshold
return CredentialPublicKeys{..}
genPolicy :: Gen Policy
genPolicy = do
let ym = YearMonth <$> choose (1000, 9999) <*> choose (1, 12)
pValidTo <- ym
pCreatedAt <- ym
let pItems = Map.empty
return Policy{..}
genCredentialDeploymentInformation :: Gen CredentialDeploymentInformation
genCredentialDeploymentInformation = do
cdvPublicKeys <- genCredentialPublicKeys
cdvCredId <- RegIdCred . generateGroupElementFromSeed globalContext <$> arbitrary
cdvIpId <- IP_ID <$> arbitrary
cdvArData <-
Map.fromList
<$> listOf
( do
ardName <- do
n <- arbitrary
if n == 0 then return (ArIdentity 1) else return (ArIdentity n)
ardIdCredPubShare <- AREnc <$> genElgamalCipher
return (ardName, ChainArData{..})
)
cdvThreshold <- Threshold <$> choose (1, max 1 (fromIntegral (length cdvArData)))
cdvPolicy <- genPolicy
cdiProofs <- do
l <- choose (0, 10000)
Proofs . BSS.pack <$> vector l
let cdiValues = CredentialDeploymentValues{..}
return CredentialDeploymentInformation{..}
genCommissionRates :: Gen CommissionRates
genCommissionRates =
CommissionRates <$> genAmountFraction <*> genAmountFraction <*> genAmountFraction
genCommissionRanges :: Gen CommissionRanges
genCommissionRanges =
CommissionRanges
<$> genInclusiveRangeOfAmountFraction
<*> genInclusiveRangeOfAmountFraction
<*> genInclusiveRangeOfAmountFraction
genChainParametersV0 :: Gen (ChainParameters' 'ChainParametersV0)
genChainParametersV0 = do
_cpConsensusParameters <- ConsensusParametersV0 <$> genElectionDifficulty
_cpExchangeRates <- genExchangeRates
_cpCooldownParameters <- genCooldownParametersV0
let _cpTimeParameters = NoParam
_cpAccountCreationLimit <- arbitrary
_cpRewardParameters <- genRewardParameters
_cpFoundationAccount <- AccountIndex <$> arbitrary
_cpPoolParameters <- genPoolParametersV0
let _cpFinalizationCommitteeParameters = NoParam
let _cpValidatorScoreParameters = NoParam
return ChainParameters{..}
genChainParametersV1 :: Gen (ChainParameters' 'ChainParametersV1)
genChainParametersV1 = do
_cpConsensusParameters <- ConsensusParametersV0 <$> genElectionDifficulty
_cpExchangeRates <- genExchangeRates
_cpCooldownParameters <- genCooldownParametersV1
_cpTimeParameters <- SomeParam <$> genTimeParametersV1
_cpAccountCreationLimit <- arbitrary
_cpRewardParameters <- genRewardParameters
_cpFoundationAccount <- AccountIndex <$> arbitrary
_cpPoolParameters <- genPoolParametersV1
let _cpFinalizationCommitteeParameters = NoParam
let _cpValidatorScoreParameters = NoParam
return ChainParameters{..}
genFinalizationCommitteeParameters :: Gen FinalizationCommitteeParameters
genFinalizationCommitteeParameters = do
_fcpMinFinalizers <- choose (20, 100)
_fcpMaxFinalizers <- choose (100, 800)
_fcpFinalizerRelativeStakeThreshold <- arbitrary
return FinalizationCommitteeParameters{..}
genConsensusParametersV1 ::
Gen (ConsensusParameters' 'ConsensusParametersVersion1)
genConsensusParametersV1 = do
_cpTimeoutParameters <- genTimeoutParameters
_cpMinBlockTime <- genDuration
_cpBlockEnergyLimit <- Energy <$> arbitrary
_cpFinalizationCommitteeParameters <- genFinalizationCommitteeParameters
return ConsensusParametersV1{..}
genChainParametersV2 :: Gen (ChainParameters' 'ChainParametersV2)
genChainParametersV2 = do
_cpConsensusParameters <- genConsensusParametersV1
_cpExchangeRates <- genExchangeRates
_cpCooldownParameters <- genCooldownParametersV1
_cpTimeParameters <- SomeParam <$> genTimeParametersV1
_cpAccountCreationLimit <- arbitrary
_cpRewardParameters <- genRewardParameters
_cpFoundationAccount <- AccountIndex <$> arbitrary
_cpPoolParameters <- genPoolParametersV1
_cpFinalizationCommitteeParameters <- SomeParam <$> genFinalizationCommitteeParameters
let _cpValidatorScoreParameters = NoParam
return ChainParameters{..}
genValidatorScoreParameters :: Gen ValidatorScoreParameters
genValidatorScoreParameters = do
_vspMaxMissedRounds <- arbitrary
return ValidatorScoreParameters{..}
genChainParametersV3 :: Gen (ChainParameters' 'ChainParametersV3)
genChainParametersV3 = do
_cpConsensusParameters <- genConsensusParametersV1
_cpExchangeRates <- genExchangeRates
_cpCooldownParameters <- genCooldownParametersV1
_cpTimeParameters <- SomeParam <$> genTimeParametersV1
_cpAccountCreationLimit <- arbitrary
_cpRewardParameters <- genRewardParameters
_cpFoundationAccount <- AccountIndex <$> arbitrary
_cpPoolParameters <- genPoolParametersV1
_cpFinalizationCommitteeParameters <- SomeParam <$> genFinalizationCommitteeParameters
_cpValidatorScoreParameters <- SomeParam <$> genValidatorScoreParameters
return ChainParameters{..}
genGenesisChainParametersV0 :: Gen (GenesisChainParameters' 'ChainParametersV0)
genGenesisChainParametersV0 = do
gcpConsensusParameters <- ConsensusParametersV0 <$> genElectionDifficulty
gcpExchangeRates <- genExchangeRates
gcpCooldownParameters <- genCooldownParametersV0
let gcpTimeParameters = NoParam
gcpAccountCreationLimit <- arbitrary
gcpRewardParameters <- genRewardParameters
gcpFoundationAccount <- genAccountAddress
gcpPoolParameters <- genPoolParametersV0
let gcpFinalizationCommitteeParameters = NoParam
let gcpValidatorScoreParameters = NoParam
return GenesisChainParameters{..}
genGenesisChainParametersV1 :: Gen (GenesisChainParameters' 'ChainParametersV1)
genGenesisChainParametersV1 = do
gcpConsensusParameters <- ConsensusParametersV0 <$> genElectionDifficulty
gcpExchangeRates <- genExchangeRates
gcpCooldownParameters <- genCooldownParametersV1
gcpTimeParameters <- SomeParam <$> genTimeParametersV1
gcpAccountCreationLimit <- arbitrary
gcpRewardParameters <- genRewardParameters
gcpFoundationAccount <- genAccountAddress
gcpPoolParameters <- genPoolParametersV1
let gcpFinalizationCommitteeParameters = NoParam
let gcpValidatorScoreParameters = NoParam
return GenesisChainParameters{..}
genGenesisChainParametersV2 :: Gen (GenesisChainParameters' 'ChainParametersV2)
genGenesisChainParametersV2 = do
gcpConsensusParameters <- genConsensusParametersV1
gcpExchangeRates <- genExchangeRates
gcpCooldownParameters <- genCooldownParametersV1
gcpTimeParameters <- SomeParam <$> genTimeParametersV1
gcpAccountCreationLimit <- arbitrary
gcpRewardParameters <- genRewardParameters
gcpFoundationAccount <- genAccountAddress
gcpPoolParameters <- genPoolParametersV1
gcpFinalizationCommitteeParameters <- SomeParam <$> genFinalizationCommitteeParameters
let gcpValidatorScoreParameters = NoParam
return GenesisChainParameters{..}
genGenesisChainParametersV3 :: Gen (GenesisChainParameters' 'ChainParametersV3)
genGenesisChainParametersV3 = do
gcpConsensusParameters <- genConsensusParametersV1
gcpExchangeRates <- genExchangeRates
gcpCooldownParameters <- genCooldownParametersV1
gcpTimeParameters <- SomeParam <$> genTimeParametersV1
gcpAccountCreationLimit <- arbitrary
gcpRewardParameters <- genRewardParameters
gcpFoundationAccount <- genAccountAddress
gcpPoolParameters <- genPoolParametersV1
gcpFinalizationCommitteeParameters <- SomeParam <$> genFinalizationCommitteeParameters
gcpValidatorScoreParameters <- SomeParam <$> genValidatorScoreParameters
return GenesisChainParameters{..}
genCooldownParametersV0 :: Gen (CooldownParameters' 'CooldownParametersVersion0)
genCooldownParametersV0 = CooldownParametersV0 <$> arbitrary
genCooldownParametersV1 :: Gen (CooldownParameters' 'CooldownParametersVersion1)
genCooldownParametersV1 =
CooldownParametersV1 <$> (DurationSeconds <$> arbitrary) <*> (DurationSeconds <$> arbitrary)
genRewardPeriodLength :: Gen RewardPeriodLength
genRewardPeriodLength = RewardPeriodLength <$> choose (1, maxBound) -- to make sure that reward period length is >= 1
genTimeParametersV1 :: Gen TimeParameters
genTimeParametersV1 = TimeParametersV1 <$> genRewardPeriodLength <*> genMintRate
genPoolParametersV0 :: Gen (PoolParameters' 'PoolParametersVersion0)
genPoolParametersV0 = PoolParametersV0 <$> arbitrary
genPoolParametersV1 :: Gen (PoolParameters' 'PoolParametersVersion1)
genPoolParametersV1 = do
_ppPassiveCommissions <- genCommissionRates
_ppCommissionBounds <- genCommissionRanges
_ppMinimumEquityCapital <- genAmount
_ppCapitalBound <- genCapitalBound
_ppLeverageBound <- genLeverageFactor
return PoolParametersV1{..}
genRewardParameters :: forall cpv. (IsChainParametersVersion cpv) => Gen (RewardParameters cpv)
genRewardParameters = withCPVConstraints (chainParametersVersion @cpv) $ do
_rpMintDistribution <- genMintDistribution
_rpTransactionFeeDistribution <- genTransactionFeeDistribution
_rpGASRewards <- genGASRewards
return RewardParameters{..}
genDuration :: Gen Duration
genDuration = Duration <$> arbitrary
-- | x > 1
genTimeoutIncrease :: Gen (Ratio Word64)
genTimeoutIncrease = do
den <- choose (1, maxBound - 1)
num <- choose (den + 1, maxBound)
return $ num % den
-- | x > 0 || x < 1
genTimeoutDecrease :: Gen (Ratio Word64)
genTimeoutDecrease = do
num <- choose (1, maxBound)
den <- choose (num + 1, maxBound)
return $ num % den
genTimeoutParameters :: Gen TimeoutParameters
genTimeoutParameters = do
_tpTimeoutBase <- genDuration
_tpTimeoutIncrease <- genTimeoutIncrease
_tpTimeoutDecrease <- genTimeoutDecrease
return TimeoutParameters{..}
transactionTypes :: [TransactionType]
transactionTypes =
[ TTDeployModule,
TTInitContract,
TTUpdate,
TTTransfer,
TTAddBaker,
TTRemoveBaker,
TTUpdateBakerStake,
TTUpdateBakerRestakeEarnings,
TTUpdateBakerKeys,
TTUpdateCredentialKeys,
TTEncryptedAmountTransfer,
TTTransferToEncrypted,
TTTransferToPublic,
TTTransferWithSchedule,
TTUpdateCredentials,
TTRegisterData,
TTTransferWithMemo,
TTEncryptedAmountTransferWithMemo,
TTTransferWithScheduleAndMemo,
TTConfigureBaker,
TTConfigureDelegation
]
instance Arbitrary TransactionType where
arbitrary = elements transactionTypes
instance Arbitrary OpenStatus where
arbitrary = elements [OpenForAll, ClosedForNew, ClosedForAll]
genEncryptedAmount :: Gen EncryptedAmount
genEncryptedAmount = EncryptedAmount <$> genElgamalCipher <*> genElgamalCipher
genAccountEncryptedAmount :: Gen AccountEncryptedAmount
genAccountEncryptedAmount = do
_selfAmount <- genEncryptedAmount
_startIndex <- EncryptedAmountAggIndex <$> arbitrary
len <- choose (0, 100)
_incomingEncryptedAmounts <- Seq.replicateM len genEncryptedAmount
numAgg <- arbitrary
aggAmount <- genEncryptedAmount
if numAgg == Just 1 || numAgg == Just 0
then return AccountEncryptedAmount{_aggregatedAmount = Nothing, ..}
else return AccountEncryptedAmount{_aggregatedAmount = (aggAmount,) <$> numAgg, ..}
genContractEvent :: Gen Wasm.ContractEvent
genContractEvent = Wasm.ContractEvent . BSS.pack <$> arbitrary
genAddress :: Gen Address
genAddress = oneof [AddressAccount <$> genAccountAddress, AddressContract <$> genCAddress]
genTransactionTime :: Gen TransactionTime
genTransactionTime = TransactionTime <$> arbitrary
genTimestamp :: Gen Timestamp
genTimestamp = Timestamp <$> arbitrary
genRegisteredData :: Gen RegisteredData
genRegisteredData = do
len <- choose (0, maxRegisteredDataSize)
RegisteredData . BSS.pack <$> vector len
genMemo :: Gen Memo
genMemo = do
len <- choose (0, maxMemoSize)
Memo . BSS.pack <$> vector len
genBakerId :: Gen BakerId
genBakerId = BakerId . AccountIndex <$> arbitrary
genDelegatorId :: Gen DelegatorId
genDelegatorId = DelegatorId . AccountIndex <$> arbitrary
genWasmVersion :: SProtocolVersion pv -> Gen Wasm.WasmVersion
genWasmVersion spv
| supportsV1Contracts spv = elements [Wasm.V0, Wasm.V1]
| otherwise = return Wasm.V0
genEvent :: (IsProtocolVersion pv) => SProtocolVersion pv -> Gen Event
genEvent spv =
oneof
( [ ModuleDeployed <$> genModuleRef,
ContractInitialized <$> genModuleRef <*> genCAddress <*> genAmount <*> genInitName <*> genWasmVersion spv <*> listOf genContractEvent <*> pure CFalse,
Updated <$> genCAddress <*> genAddress <*> genAmount <*> genParameter <*> genReceiveName <*> genWasmVersion spv <*> listOf genContractEvent,
Transferred <$> genAddress <*> genAmount <*> genAddress,
AccountCreated <$> genAccountAddress,
CredentialDeployed <$> genCredentialId <*> genAccountAddress,
genBakerAdded,
BakerRemoved <$> genBakerId <*> genAccountAddress,
BakerStakeIncreased <$> genBakerId <*> genAccountAddress <*> genAmount,
BakerStakeDecreased <$> genBakerId <*> genAccountAddress <*> genAmount,
BakerSetRestakeEarnings <$> genBakerId <*> genAccountAddress <*> arbitrary,
genBakerKeysUpdated,
CredentialKeysUpdated <$> genCredentialId,
NewEncryptedAmount <$> genAccountAddress <*> (EncryptedAmountIndex <$> arbitrary) <*> genEncryptedAmount,
EncryptedAmountsRemoved <$> genAccountAddress <*> genEncryptedAmount <*> genEncryptedAmount <*> (EncryptedAmountAggIndex <$> arbitrary),
AmountAddedByDecryption <$> genAccountAddress <*> genAmount,
EncryptedSelfAmountAdded <$> genAccountAddress <*> genEncryptedAmount <*> genAmount,
UpdateEnqueued <$> genTransactionTime <*> genUpdatePayload (sChainParametersVersionFor spv),
genTransferredWithSchedule,
genCredentialsUpdated,
DataRegistered <$> genRegisteredData
]
++ maybeMemo
++ maybeV1ContractEvents
++ maybeDelegationEvents
++ maybeUpgrade
++ maybeSuspendEvents
)
where
maybeUpgrade = if supportsUpgradableContracts spv then [Upgraded <$> genCAddress <*> genModuleRef <*> genModuleRef] else []
maybeMemo = if supportsMemo spv then [TransferMemo <$> genMemo] else []
maybeV1ContractEvents =
if supportsV1Contracts spv
then
[ Interrupted <$> genCAddress <*> listOf genContractEvent,
Resumed <$> genCAddress <*> arbitrary
]
else []
maybeDelegationEvents =
if protocolSupportsDelegation spv
then
[ BakerSetOpenStatus <$> genBakerId <*> genAccountAddress <*> arbitrary,
BakerSetMetadataURL <$> genBakerId <*> genAccountAddress <*> genUrlText,
BakerSetTransactionFeeCommission <$> genBakerId <*> genAccountAddress <*> genAmountFraction,
BakerSetBakingRewardCommission <$> genBakerId <*> genAccountAddress <*> genAmountFraction,
BakerSetFinalizationRewardCommission <$> genBakerId <*> genAccountAddress <*> genAmountFraction,
DelegationStakeIncreased <$> genDelegatorId <*> genAccountAddress <*> genAmount,
DelegationStakeDecreased <$> genDelegatorId <*> genAccountAddress <*> genAmount,
DelegationSetRestakeEarnings <$> genDelegatorId <*> genAccountAddress <*> arbitrary,
DelegationSetDelegationTarget <$> genDelegatorId <*> genAccountAddress <*> genDelegationTarget,
DelegationAdded <$> genDelegatorId <*> genAccountAddress,
DelegationRemoved <$> genDelegatorId <*> genAccountAddress
]
else []
maybeSuspendEvents =
if protocolSupportsSuspend spv
then
[ BakerSuspended <$> genBakerId <*> genAccountAddress,
BakerResumed <$> genBakerId <*> genAccountAddress
]
else []
genBakerAdded = do
ebaBakerId <- genBakerId
ebaAccount <- genAccountAddress
ebaSignKey <- BlockSig.verifyKey <$> genBlockKeyPair
ebaElectionKey <- VRF.publicKey <$> arbitrary
(ebaAggregationKey, _) <- genAggregationVerifyKeyAndProof
ebaStake <- arbitrary
ebaRestakeEarnings <- arbitrary
return BakerAdded{..}
genBakerKeysUpdated = do
ebkuBakerId <- genBakerId
ebkuAccount <- genAccountAddress
ebkuSignKey <- BlockSig.verifyKey <$> genBlockKeyPair
ebkuElectionKey <- VRF.publicKey <$> arbitrary
(ebkuAggregationKey, _) <- genAggregationVerifyKeyAndProof
return BakerKeysUpdated{..}
genTransferredWithSchedule = do
etwsFrom <- genAccountAddress
etwsTo <- genAccountAddress
etwsAmount <- listOf ((,) <$> genTimestamp <*> genAmount)
return TransferredWithSchedule{..}
genCredentialsUpdated = do
cuAccount <- genAccountAddress
cuNewCredIds <- listOf genCredentialId
cuRemovedCredIds <- listOf genCredentialId
cuNewThreshold <- AccountThreshold <$> choose (1, maxBound)
return CredentialsUpdated{..}
instance Arbitrary RejectReason where
arbitrary =
oneof
[ return ModuleNotWF,
ModuleHashAlreadyExists <$> genModuleRef,
InvalidAccountReference <$> genAccountAddress,
InvalidInitMethod <$> genModuleRef <*> genInitName,
InvalidReceiveMethod <$> genModuleRef <*> genReceiveName,
InvalidModuleReference <$> genModuleRef,
InvalidContractAddress <$> genCAddress,
return RuntimeFailure,
AmountTooLarge <$> genAddress <*> genAmount,
return SerializationFailure,
return OutOfEnergy,
RejectedInit <$> arbitrary,
RejectedReceive <$> arbitrary <*> genCAddress <*> genReceiveName <*> genParameter,
return InvalidProof,
AlreadyABaker <$> genBakerId,
NotABaker <$> genAccountAddress,
return InsufficientBalanceForBakerStake,
return StakeUnderMinimumThresholdForBaking,
return BakerInCooldown,
DuplicateAggregationKey . fst <$> genAggregationVerifyKeyAndProof,
return NonExistentCredentialID,
return KeyIndexAlreadyInUse,
return InvalidAccountThreshold,
return InvalidCredentialKeySignThreshold,
return InvalidEncryptedAmountTransferProof,
return InvalidTransferToPublicProof,
EncryptedAmountSelfTransfer <$> genAccountAddress,
return InvalidIndexOnEncryptedTransfer,
return ZeroScheduledAmount,
return NonIncreasingSchedule,
return FirstScheduledReleaseExpired,
ScheduledSelfTransfer <$> genAccountAddress,
return InvalidCredentials,
DuplicateCredIDs <$> listOf genCredentialId,
NonExistentCredIDs <$> listOf genCredentialId,
return RemoveFirstCredential,
return CredentialHolderDidNotSign,
return NotAllowedMultipleCredentials,
return NotAllowedToReceiveEncrypted,
return NotAllowedToHandleEncrypted,
return MissingBakerAddParameters,
return FinalizationRewardCommissionNotInRange,
return BakingRewardCommissionNotInRange,
return TransactionFeeCommissionNotInRange,
return AlreadyADelegator,
return InsufficientBalanceForDelegationStake,
return MissingDelegationAddParameters,
return InsufficientDelegationStake,
return DelegatorInCooldown,
NotADelegator <$> genAccountAddress,
DelegationTargetNotABaker <$> genBakerId,
return StakeOverMaximumThresholdForPool,
return PoolWouldBecomeOverDelegated,
return PoolClosed
]
genValidResult :: (IsProtocolVersion pv) => SProtocolVersion pv -> Gen ValidResult
genValidResult spv =
oneof
[ TxSuccess <$> (liftArbitrary $ genEvent spv),
TxReject <$> arbitrary
]
genTransactionSummary :: (IsProtocolVersion pv) => SProtocolVersion pv -> Gen TransactionSummary
genTransactionSummary spv = do
tsSender <- oneof [return Nothing, Just <$> genAccountAddress]
tsHash <- TransactionHashV0 . SHA256.Hash . FBS.pack <$> vector 32
tsCost <- genAmount
tsEnergyCost <- Energy <$> arbitrary
tsType <-
oneof
[ TSTAccountTransaction <$> arbitrary,
TSTCredentialDeploymentTransaction <$> elements [Initial, Normal],
TSTUpdateTransaction <$> arbitraryBoundedEnum
]
tsResult <- genValidResult spv
tsIndex <- TransactionIndex <$> arbitrary
return TransactionSummary{..}
schemes :: [SchemeId]
schemes = [Ed25519]
verifyKeys :: Vec.Vector VerifyKey
verifyKeys = unsafePerformIO $ Vec.replicateM 200 (correspondingVerifyKey <$> newKeyPair Ed25519)
{-# NOINLINE verifyKeys #-}
genVerifyKey :: Gen VerifyKey
genVerifyKey = do
i <- choose (0, Vec.length verifyKeys - 1)
return $ verifyKeys Vec.! i
genSchemeId :: Gen SchemeId
genSchemeId = elements schemes
genTransactionHeader :: Gen TransactionHeader
genTransactionHeader = do
thSender <- genAccountAddress
thPayloadSize <- PayloadSize <$> choose (0, maxPayloadSize SP4)
thNonce <- Nonce <$> arbitrary
thEnergyAmount <- Energy <$> arbitrary
thExpiry <- TransactionTime <$> arbitrary
return $ TransactionHeader{..}
genAccountTransaction :: Gen AccountTransaction
genAccountTransaction = do
atrHeader <- genTransactionHeader
atrPayload <- EncodedPayload . BSS.pack <$> vector (fromIntegral (thPayloadSize atrHeader))
numCredentials <- choose (1, 255)
allKeys <- replicateM numCredentials $ do
numKeys <- choose (1, 255)
credentialSignatures <- replicateM numKeys $ do
idx <- KeyIndex <$> arbitrary
sLen <- choose (50, 70)
sig <- Signature . BSS.pack <$> vector sLen
return (idx, sig)
(,Map.fromList credentialSignatures) . CredentialIndex <$> arbitrary
let atrSignature = TransactionSignature (Map.fromList allKeys)
return $! makeAccountTransaction atrSignature atrHeader atrPayload
genTransaction :: Gen Transaction
genTransaction = do
wmdData <- genAccountTransaction
wmdArrivalTime <- TransactionTime <$> arbitrary
return $ addMetadata NormalTransaction wmdArrivalTime wmdData
genInitialCredentialDeploymentInformation :: Gen InitialCredentialDeploymentInfo
genInitialCredentialDeploymentInformation = do
icdvAccount <- genCredentialPublicKeys
icdvRegId <- RegIdCred . generateGroupElementFromSeed globalContext <$> arbitrary
icdvIpId <- IP_ID <$> arbitrary
icdvPolicy <- genPolicy
let icdiValues = InitialCredentialDeploymentValues{..}
icdiSig <- IpCdiSignature . BSS.pack <$> vector 64
return InitialCredentialDeploymentInfo{..}
genAccountCredentialWithProofs :: Gen AccountCredentialWithProofs
genAccountCredentialWithProofs =
oneof
[ NormalACWP <$> genCredentialDeploymentInformation,
InitialACWP <$> genInitialCredentialDeploymentInformation
]
genCredentialDeploymentWithMeta :: Gen CredentialDeploymentWithMeta
genCredentialDeploymentWithMeta = do
credential <- genAccountCredentialWithProofs
messageExpiry <- TransactionTime <$> arbitrary
wmdArrivalTime <- TransactionTime <$> arbitrary
return $ addMetadata CredentialDeployment wmdArrivalTime AccountCreation{..}
genBlockItem :: Gen BlockItem
genBlockItem =
oneof
[ normalTransaction <$> genTransaction,
credentialDeployment <$> genCredentialDeploymentWithMeta
]
genElectionDifficulty :: Gen ElectionDifficulty
genElectionDifficulty = makeElectionDifficulty <$> arbitrary `suchThat` (< 100000)
genAuthorizations :: forall auv. (IsAuthorizationsVersion auv) => Gen (Authorizations auv)
genAuthorizations = do
size <- getSize
nKeys <- choose (1, min 65535 (1 + size))
asKeys <- Vec.fromList . fmap correspondingVerifyKey <$> vectorOf nKeys genSigSchemeKeyPair
let genAccessStructure = do
asnKeys <- choose (1, nKeys)
accessPublicKeys <- Set.fromList . take asnKeys <$> shuffle [0 .. fromIntegral nKeys - 1]
accessThreshold <- UpdateKeysThreshold <$> choose (1, fromIntegral asnKeys)
return AccessStructure{..}
asEmergency <- genAccessStructure
asProtocol <- genAccessStructure
asParamConsensusParameters <- genAccessStructure
asParamEuroPerEnergy <- genAccessStructure
asParamMicroGTUPerEuro <- genAccessStructure
asParamFoundationAccount <- genAccessStructure
asParamMintDistribution <- genAccessStructure
asParamTransactionFeeDistribution <- genAccessStructure
asParamGASRewards <- genAccessStructure
asPoolParameters <- genAccessStructure
asAddAnonymityRevoker <- genAccessStructure
asAddIdentityProvider <- genAccessStructure
asCooldownParameters <- conditionallyA (sSupportsCooldownParametersAccessStructure (sing @auv)) genAccessStructure
asTimeParameters <- conditionallyA (sSupportsTimeParameters (sing @auv)) genAccessStructure
return Authorizations{..}
genProtocolUpdate :: Gen ProtocolUpdate
genProtocolUpdate = do
puMessage <- Text.pack <$> arbitrary
puSpecificationURL <- Text.pack <$> arbitrary
puSpecificationHash <- SHA256.hash . BS.pack <$> arbitrary
puSpecificationAuxiliaryData <- BS.pack <$> arbitrary
return ProtocolUpdate{..}
genMintRate :: Gen MintRate
genMintRate = do
mrExponent <- arbitrary
mrMantissa <- choose (0, fromIntegral (min (toInteger (maxBound :: Word32)) (10 ^ mrExponent)))
return MintRate{..}
genRatioOfWord64 :: Gen (Ratio Word64)
genRatioOfWord64 = do
num <- choose (1, maxBound)
den <- choose (1, maxBound)
return $ num % den
genLeverageFactor :: Gen LeverageFactor
genLeverageFactor =