-
Notifications
You must be signed in to change notification settings - Fork 158
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Merge pull request #1966 from input-output-hk/uroboros/shelley-ma-ser…
…ialize-generators Serialisation generators for Mary/Allegra
- Loading branch information
Showing
11 changed files
with
977 additions
and
815 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
159 changes: 129 additions & 30 deletions
159
shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/ShelleyMA/Serialisation/Generators.hs
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -1,51 +1,150 @@ | ||
{-# LANGUAGE TypeApplications #-} | ||
{-# LANGUAGE ScopedTypeVariables #-} | ||
{-# LANGUAGE AllowAmbiguousTypes #-} | ||
{-# LANGUAGE BangPatterns #-} | ||
{-# LANGUAGE ConstraintKinds #-} | ||
{-# LANGUAGE DataKinds #-} | ||
{-# LANGUAGE FlexibleContexts #-} | ||
{-# LANGUAGE FlexibleInstances #-} | ||
{-# LANGUAGE NamedFieldPuns #-} | ||
{-# LANGUAGE OverloadedStrings #-} | ||
{-# LANGUAGE PatternSynonyms #-} | ||
{-# LANGUAGE QuantifiedConstraints #-} | ||
{-# LANGUAGE Rank2Types #-} | ||
{-# LANGUAGE RankNTypes #-} | ||
{-# LANGUAGE ScopedTypeVariables #-} | ||
{-# LANGUAGE TypeApplications #-} | ||
{-# LANGUAGE TypeFamilies #-} | ||
{-# LANGUAGE UndecidableInstances #-} | ||
{-# OPTIONS_GHC -Wno-orphans #-} | ||
|
||
{-# OPTIONS_GHC -Wno-orphans #-} -- orphan Arbitrary instances | ||
|
||
-- | This module is usually imported for its Arbitrary instances | ||
module Test.Cardano.Ledger.ShelleyMA.Serialisation.Generators where | ||
module Test.Cardano.Ledger.ShelleyMA.Serialisation.Generators | ||
( sizedTimelock, | ||
maxTimelockDepth, | ||
) | ||
where | ||
|
||
import Cardano.Slotting.Slot (SlotNo (..)) | ||
import Cardano.Ledger.Era(Era(..)) | ||
import Cardano.Ledger.ShelleyMA.Timelocks | ||
( Timelock (RequireSignature, RequireAllOf, RequireAnyOf, RequireMOf, RequireTimeExpire, RequireTimeStart), | ||
import Cardano.Binary | ||
( toCBOR, | ||
) | ||
import Cardano.Crypto.Hash (HashAlgorithm, hashWithSerialiser) | ||
import qualified Cardano.Crypto.Hash as Hash | ||
import Cardano.Ledger.Allegra (AllegraEra) | ||
import qualified Cardano.Ledger.Core as Abstract | ||
import Cardano.Ledger.Era (Era) | ||
import Cardano.Ledger.Mary (MaryEra) | ||
import qualified Cardano.Ledger.Mary.Value as Mary (AssetID (..), PolicyID (..), Value (..)) | ||
import Cardano.Ledger.Shelley (ShelleyBased) | ||
import qualified Cardano.Ledger.ShelleyMA.Rules.Utxo as MA.STS | ||
import qualified Cardano.Ledger.ShelleyMA.Scripts as MA (Timelock (..)) | ||
import Cardano.Ledger.ShelleyMA.Timelocks (Timelock (..), ValidityInterval) | ||
import qualified Cardano.Ledger.ShelleyMA.TxBody as MA (TxBody (..)) | ||
import Data.Coerce (coerce) | ||
import Data.Sequence.Strict (fromList) | ||
import Shelley.Spec.Ledger.Keys (KeyHash (..)) | ||
import Shelley.Spec.Ledger.BaseTypes (StrictMaybe (SJust, SNothing)) | ||
import Test.Shelley.Spec.Ledger.Serialisation.Generators(mkDummyHash) -- imports arbitray instance for MultiSig | ||
import Test.Tasty.QuickCheck hiding (scale) | ||
import Generic.Random (genericArbitraryU) | ||
import Shelley.Spec.Ledger.API hiding (SignedDSIGN, TxBody (..)) | ||
import Test.QuickCheck | ||
( Arbitrary, | ||
arbitrary, | ||
choose, | ||
genericShrink, | ||
listOf, | ||
oneof, | ||
resize, | ||
shrink, | ||
) | ||
import Test.Shelley.Spec.Ledger.ConcreteCryptoTypes (Mock) | ||
import Test.Shelley.Spec.Ledger.Serialisation.EraIndepGenerators () | ||
import Test.Tasty.QuickCheck (Gen) | ||
|
||
{------------------------------------------------------------------------------- | ||
ShelleyMAEra Generators | ||
-- ================================================================ | ||
Generators used for roundtrip tests, generated values are not | ||
necessarily valid | ||
-------------------------------------------------------------------------------} | ||
|
||
-- ================================================================================ | ||
-- Some generators for Timelock | ||
mkDummyHash :: forall h a. HashAlgorithm h => Int -> Hash.Hash h a | ||
mkDummyHash = coerce . hashWithSerialiser @h toCBOR | ||
|
||
genSlot :: Gen (StrictMaybe SlotNo) | ||
genSlot = oneof [ pure SNothing, (SJust . SlotNo) <$> choose (0,10)] | ||
genTxBody :: | ||
( ShelleyBased era, | ||
Arbitrary (Abstract.Value era), | ||
Arbitrary (TxOut era), | ||
Arbitrary (DCert era), | ||
Arbitrary (Wdrl era), | ||
Arbitrary (Update era) | ||
) => | ||
Gen (MA.TxBody era) | ||
genTxBody = | ||
MA.TxBody | ||
<$> arbitrary | ||
<*> arbitrary | ||
<*> arbitrary | ||
<*> arbitrary | ||
<*> arbitrary | ||
<*> arbitrary | ||
<*> arbitrary | ||
<*> arbitrary | ||
<*> arbitrary | ||
|
||
maxTimelockDepth :: Int | ||
maxTimelockDepth = 3 | ||
|
||
maxTimelockListLens :: Int | ||
maxTimelockListLens = 5 | ||
|
||
sizedTimelock :: (Era era) => Int -> Gen (Timelock era) | ||
sizedTimelock 0 = (RequireSignature . KeyHash . mkDummyHash) <$> arbitrary | ||
sizedTimelock :: | ||
Era era => | ||
Int -> | ||
Gen (Timelock era) | ||
sizedTimelock 0 = (MA.RequireSignature . KeyHash . mkDummyHash) <$> arbitrary | ||
sizedTimelock n = | ||
oneof | ||
[ (RequireSignature . KeyHash . mkDummyHash) <$> arbitrary, | ||
RequireAllOf <$> (fromList <$> resize maxTimelockListLens (listOf (sizedTimelock (n -1)))), | ||
RequireAnyOf <$> (fromList <$> resize maxTimelockListLens (listOf (sizedTimelock (n -1)))), | ||
do subs <- resize maxTimelockListLens (listOf (sizedTimelock (n -1))) | ||
let i = length subs | ||
RequireMOf <$> choose (0,i) <*> pure (fromList subs), | ||
RequireTimeStart <$> genSlot, | ||
RequireTimeExpire <$> genSlot | ||
[ (MA.RequireSignature . KeyHash . mkDummyHash) <$> arbitrary, | ||
MA.RequireAllOf <$> (fromList <$> resize maxTimelockListLens (listOf (sizedTimelock (n -1)))), | ||
MA.RequireAnyOf <$> (fromList <$> resize maxTimelockListLens (listOf (sizedTimelock (n -1)))), | ||
do | ||
subs <- resize maxTimelockListLens (listOf (sizedTimelock (n -1))) | ||
let i = length subs | ||
MA.RequireMOf <$> choose (0, i) <*> pure (fromList subs), | ||
RequireTimeStart <$> arbitrary, | ||
RequireTimeExpire <$> arbitrary | ||
] | ||
|
||
instance (Era era) => Arbitrary (Timelock era) where | ||
{------------------------------------------------------------------------------- | ||
MaryEra Generators | ||
-------------------------------------------------------------------------------} | ||
|
||
instance Mock c => Arbitrary (MA.TxBody (MaryEra c)) where | ||
arbitrary = genTxBody | ||
|
||
instance Mock c => Arbitrary (Timelock (MaryEra c)) where | ||
arbitrary = sizedTimelock maxTimelockDepth | ||
|
||
instance Mock c => Arbitrary (Mary.PolicyID (MaryEra c)) where | ||
arbitrary = Mary.PolicyID <$> arbitrary | ||
|
||
instance Mock c => Arbitrary (Mary.Value (MaryEra c)) where | ||
arbitrary = Mary.Value <$> arbitrary <*> arbitrary | ||
|
||
instance Arbitrary Mary.AssetID where | ||
arbitrary = Mary.AssetID <$> arbitrary | ||
|
||
instance Mock c => Arbitrary (MA.STS.UtxoPredicateFailure (MaryEra c)) where | ||
arbitrary = genericArbitraryU | ||
|
||
{------------------------------------------------------------------------------- | ||
AllegraEra Generators | ||
-------------------------------------------------------------------------------} | ||
|
||
instance Mock c => Arbitrary (MA.TxBody (AllegraEra c)) where | ||
arbitrary = genTxBody | ||
|
||
instance Mock c => Arbitrary (Timelock (AllegraEra c)) where | ||
arbitrary = sizedTimelock maxTimelockDepth | ||
|
||
instance Arbitrary ValidityInterval where | ||
arbitrary = genericArbitraryU | ||
shrink = genericShrink | ||
|
||
instance Mock c => Arbitrary (MA.STS.UtxoPredicateFailure (AllegraEra c)) where | ||
arbitrary = genericArbitraryU |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Oops, something went wrong.