Skip to content

Commit

Permalink
Addressed the comments and the TODOs of the group reviews
Browse files Browse the repository at this point in the history 
with (tim, alexi,joosep,tedora,aniket) including reverseOrdCond,
simplifying Term and Pred types, more robust combinators (using resize).
Better rewrite rules, improvements to soundness tests from Quviq
  • Loading branch information
@TimSheard
TimSheard committed Mar 21, 2023
1 parent 980db10 commit 974d3ad
Show file tree
Hide file tree
Showing 21 changed files with 2,031 additions and 2,503 deletions.
371 changes: 0 additions & 371 deletions eras/alonzo/test-suite/src/Test/Cardano/Ledger/Alonzo/Serialisation/Generators.hs
View file
Expand Up @@ -42,381 +42,10 @@ import Data.Maybe (catMaybes)
import Data.Typeable (Typeable)
import Test.Cardano.Ledger.Alonzo.Arbitrary ()
import Test.Cardano.Ledger.Binary.Twiddle

-- import Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes (Mock)
import Test.Cardano.Ledger.Shelley.Serialisation.EraIndepGenerators ()
import Test.Cardano.Ledger.Shelley.Serialisation.Generators ()
import Test.QuickCheck


instance Era era => Arbitrary (Data era) where
arbitrary = Data <$> arbitrary

instance Era era => Arbitrary (BinaryData era) where
arbitrary = dataToBinaryData <$> arbitrary

instance Arbitrary PV1.Data where
arbitrary = resize 5 (sized gendata)
where
gendata n
| n > 0 =
oneof
[ PV1.I <$> arbitrary
, PV1.B <$> arbitrary
, PV1.Map <$> listOf ((,) <$> gendata (n `div` 2) <*> gendata (n `div` 2))
, PV1.Constr
<$> fmap fromIntegral (arbitrary :: Gen Natural)
<*> listOf (gendata (n `div` 2))
, PV1.List <$> listOf (gendata (n `div` 2))
]
gendata _ = oneof [PV1.I <$> arbitrary, PV1.B <$> arbitrary]

instance
( Script era ~ AlonzoScript era
, Arbitrary (Script era)
, Era era
) =>
Arbitrary (AlonzoTxAuxData era)
where
arbitrary = mkAlonzoTxAuxData @[] <$> arbitrary <*> arbitrary

instance Arbitrary Tag where
arbitrary = elements [Spend, Mint, Cert, Rewrd]

instance Arbitrary RdmrPtr where
arbitrary = RdmrPtr <$> arbitrary <*> arbitrary

instance Arbitrary ExUnits where
arbitrary = ExUnits <$> genUnit <*> genUnit
where
genUnit = fromIntegral <$> choose (0, maxBound :: Int64)

instance (Era era) => Arbitrary (Redeemers era) where
arbitrary = Redeemers <$> arbitrary

instance
( Arbitrary (Script era)
, AlonzoScript era ~ Script era
, EraScript era
) =>
Arbitrary (AlonzoTxWits era)
where
arbitrary =
AlonzoTxWits
<$> arbitrary
<*> arbitrary
<*> genScripts
<*> genData
<*> arbitrary

keyBy :: Ord k => (a -> k) -> [a] -> Map k a
keyBy f xs = Map.fromList ((\x -> (f x, x)) <$> xs)

genScripts ::
forall era.
( Script era ~ AlonzoScript era
, EraScript era
, Arbitrary (AlonzoScript era)
) =>
Gen (Map (ScriptHash (EraCrypto era)) (Script era))
genScripts = keyBy (hashScript @era) <$> (arbitrary :: Gen [Script era])

genData :: forall era. Era era => Gen (TxDats era)
genData = TxDats . keyBy hashData <$> arbitrary

instance
( EraTxOut era
, Arbitrary (Value era)
) =>
Arbitrary (AlonzoTxOut era)
where
arbitrary =
AlonzoTxOut
<$> arbitrary
<*> scale (`div` 15) arbitrary
<*> arbitrary

instance
(EraTxOut era, Arbitrary (TxOut era), Arbitrary (PParamsUpdate era)) =>
Arbitrary (AlonzoTxBody era)
where
arbitrary =
AlonzoTxBody
<$> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> scale (`div` 15) arbitrary
<*> arbitrary
<*> scale (`div` 15) (genMintValues @(EraCrypto era))
<*> arbitrary
<*> arbitrary
<*> arbitrary

deriving newtype instance Arbitrary IsValid

instance
( Arbitrary (TxBody era)
, Arbitrary (TxWits era)
, Arbitrary (TxAuxData era)
) =>
Arbitrary (AlonzoTx era)
where
arbitrary =
AlonzoTx
<$> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary

instance Era era => Arbitrary (AlonzoScript era) where
arbitrary = do
lang <- arbitrary -- The language is not present in the Script serialization
frequency
[ (1, pure (alwaysSucceeds lang 1))
, (1, pure (alwaysFails lang 1))
, (10, TimelockScript <$> arbitrary)
]

-- ==========================
--

instance Arbitrary Language where
arbitrary = elements nonNativeLanguages

instance Arbitrary Prices where
arbitrary = Prices <$> arbitrary <*> arbitrary

genValidCostModel :: Language -> Gen CostModel
genValidCostModel lang = do
newParamValues <- (vectorOf (costModelParamsCount lang) (arbitrary :: Gen Integer))
pure $ fromRight (error "Corrupt cost model") (mkCostModel lang newParamValues)

genValidCostModelPair :: Language -> Gen (Language, CostModel)
genValidCostModelPair lang = (,) lang <$> genValidCostModel lang

-- | This Arbitrary instance assumes the inflexible deserialization
-- scheme prior to version 9.
instance Arbitrary CostModels where
arbitrary = do
langs <- sublistOf nonNativeLanguages
cms <- mapM genValidCostModelPair langs
pure $ CostModels (Map.fromList cms) mempty mempty

listAtLeast :: Int -> Gen [Integer]
listAtLeast x = do
y <- getNonNegative <$> arbitrary
replicateM (x + y) arbitrary

genCostModelValues :: Language -> Gen (Word8, [Integer])
genCostModelValues lang =
(lang',)
<$> oneof
[ listAtLeast (costModelParamsCount lang) -- Valid Cost Model for known language
, take tooFew <$> arbitrary -- Invalid Cost Model for known language
]
where
lang' = fromIntegral (fromEnum lang)
tooFew = costModelParamsCount lang - 1

genUnknownCostModelValues :: Gen (Word8, [Integer])
genUnknownCostModelValues = do
lang <- chooseInt (firstInvalid, fromIntegral (maxBound :: Word8))
vs <- arbitrary
return (fromIntegral . fromEnum $ lang, vs)
where
firstInvalid = fromEnum (maxBound :: Language) + 1

genUnknownCostModels :: Gen (Map Word8 [Integer])
genUnknownCostModels = Map.fromList <$> listOf genUnknownCostModelValues

genKnownCostModels :: Gen (Map Word8 [Integer])
genKnownCostModels = do
langs <- sublistOf nonNativeLanguages
cms <- mapM genCostModelValues langs
return $ Map.fromList cms

-- | This Arbitrary instance assumes the flexible deserialization
-- scheme of 'CostModels' starting at version 9.
newtype FlexibleCostModels = FlexibleCostModels CostModels
deriving (Show, Eq, Ord)
deriving newtype (EncCBOR, DecCBOR)

instance Arbitrary FlexibleCostModels where
arbitrary = do
known <- genKnownCostModels
unknown <- genUnknownCostModels
let cms = known `Map.union` unknown
pure . FlexibleCostModels $ mkCostModelsLenient cms

instance Arbitrary (AlonzoPParams Identity era) where
arbitrary =
AlonzoPParams
<$> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary

deriving instance Arbitrary OrdExUnits

instance Arbitrary (AlonzoPParams StrictMaybe era) where
arbitrary =
AlonzoPParams
<$> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary

instance Arbitrary FailureDescription where
arbitrary = PlutusFailure <$> (pack <$> arbitrary) <*> arbitrary

instance Arbitrary TagMismatchDescription where
arbitrary =
oneof [pure PassedUnexpectedly, FailedUnexpectedly <$> ((:|) <$> arbitrary <*> arbitrary)]

instance
(Era era, Arbitrary (PPUPPredFailure era)) =>
Arbitrary (AlonzoUtxosPredFailure era)
where
arbitrary =
oneof
[ ValidationTagMismatch <$> arbitrary <*> arbitrary
, UpdateFailure <$> arbitrary
]

instance
( EraTxOut era
, Arbitrary (Value era)
, Arbitrary (TxOut era)
, Arbitrary (PredicateFailure (EraRule "UTXOS" era))
) =>
Arbitrary (AlonzoUtxoPredFailure era)
where
arbitrary =
oneof
[ BadInputsUTxO <$> arbitrary
, OutsideValidityIntervalUTxO <$> arbitrary <*> arbitrary
, MaxTxSizeUTxO <$> arbitrary <*> arbitrary
, pure InputSetEmptyUTxO
, FeeTooSmallUTxO <$> arbitrary <*> arbitrary
, ValueNotConservedUTxO <$> arbitrary <*> arbitrary
, OutputTooSmallUTxO <$> arbitrary
, UtxosFailure <$> arbitrary
, WrongNetwork <$> arbitrary <*> arbitrary
, WrongNetworkWithdrawal <$> arbitrary <*> arbitrary
, OutputBootAddrAttrsTooBig <$> arbitrary
, pure TriesToForgeADA
, OutputTooBigUTxO <$> arbitrary
, InsufficientCollateral <$> arbitrary <*> arbitrary
, ScriptsNotPaidUTxO <$> arbitrary
, ExUnitsTooBigUTxO <$> arbitrary <*> arbitrary
, CollateralContainsNonADA <$> arbitrary
]

instance
( Era era
, Arbitrary (PredicateFailure (EraRule "UTXO" era))
) =>
Arbitrary (AlonzoUtxowPredFailure era)
where
arbitrary =
oneof
[ ShelleyInAlonzoUtxowPredFailure <$> arbitrary
, MissingRedeemers <$> arbitrary
, MissingRequiredDatums <$> arbitrary <*> arbitrary
, PPViewHashesDontMatch <$> arbitrary <*> arbitrary
]

instance Crypto c => Arbitrary (ScriptPurpose c) where
arbitrary =
oneof
[ Minting <$> arbitrary
, Spending <$> arbitrary
, Rewarding <$> arbitrary
, Certifying <$> arbitrary
]

instance
( AlonzoEraPParams era
, Arbitrary (PParams era)
) =>
Arbitrary (ScriptIntegrity era)
where
arbitrary =
ScriptIntegrity
<$> arbitrary
<*> genData
-- FIXME: why singleton? We should generate empty as well as many value sets
<*> (Set.singleton <$> (getLanguageView @era <$> arbitrary <*> arbitrary))

instance
Era era =>
Arbitrary (Datum era)
where
arbitrary =
oneof
[ pure NoDatum
, DatumHash <$> arbitrary
, Datum . dataToBinaryData <$> arbitrary
]

deriving instance Arbitrary CoinPerWord

instance Arbitrary AlonzoGenesis where
arbitrary =
AlonzoGenesis
<$> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitrary

instance (Era era, Val (Value era)) => Twiddle (AlonzoTxOut era) where
twiddle v = twiddle v . toTerm v

Expand Down

0 comments on commit 974d3ad

Please sign in to comment.