-
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.
Write test for TxWits deserialization and run it in each post-alonzo era
- Loading branch information
Showing
5 changed files
with
248 additions
and
0 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
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
238 changes: 238 additions & 0 deletions
238
eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Binary/TxWitsSpec.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 |
|---|---|---|
| @@ -0,0 +1,238 @@ | ||
| {-# LANGUAGE DataKinds #-} | ||
| {-# LANGUAGE FlexibleContexts #-} | ||
| {-# LANGUAGE GADTs #-} | ||
| {-# LANGUAGE LambdaCase #-} | ||
| {-# LANGUAGE OverloadedStrings #-} | ||
| {-# LANGUAGE ScopedTypeVariables #-} | ||
| {-# LANGUAGE TypeApplications #-} | ||
|
|
||
| module Test.Cardano.Ledger.Alonzo.Binary.TxWitsSpec (spec) where | ||
|
|
||
| import Cardano.Ledger.Alonzo.Core | ||
| import Cardano.Ledger.Alonzo.Scripts | ||
| import Cardano.Ledger.Alonzo.TxWits (AlonzoTxWits (..)) | ||
| import Cardano.Ledger.BaseTypes | ||
| import Cardano.Ledger.Binary (DeserialiseFailure (..)) | ||
| import Cardano.Ledger.Binary.Decoding | ||
| import Cardano.Ledger.Binary.Encoding | ||
| import Cardano.Ledger.Keys | ||
| import Cardano.Ledger.Plutus.Language | ||
| import Data.List (isPrefixOf) | ||
| import qualified Data.Map as Map | ||
| import qualified Data.Maybe as Maybe (mapMaybe) | ||
| import Data.Typeable | ||
| import Test.Cardano.Ledger.Alonzo.Arbitrary | ||
| import Test.Cardano.Ledger.Common | ||
|
|
||
| spec :: | ||
| forall era. | ||
| ( AlonzoEraScript era | ||
| , Script era ~ AlonzoScript era | ||
| ) => | ||
| Proxy era -> | ||
| Spec | ||
| spec pxy = do | ||
| describe "AlonzoTxWits deserialization" $ do | ||
| describe "plutus scripts" $ do | ||
| plutusScriptsProp @era pxy | ||
| describe "native scripts" $ do | ||
| nativeScriptsProp @era pxy | ||
| describe "vkeys" $ do | ||
| vkeysProp @era pxy | ||
|
|
||
| vkeysProp :: | ||
| forall era. | ||
| AlonzoEraScript era => | ||
| Proxy era -> | ||
| Spec | ||
| vkeysProp pxy = do | ||
| prop "fails to deserialize if empty, starting with Conway" $ | ||
| distinctProp -- .&. emptyProp | ||
| where | ||
| key :: Int = 0 | ||
| distinctProp = | ||
| forAllShow (genEncoding False) (showEnc pxy) $ | ||
| expectDeserialiseSuccess pxy | ||
|
|
||
| -- TODO: enable this after we enforce distinct entries for Annotator | ||
| -- duplicateProp = | ||
| -- forAllShow (genEncoding True) (showEnc pxy) $ | ||
| -- \enc -> | ||
| -- expectDeserialiseFailureFromVersion | ||
| -- pxy | ||
| -- (natVersion @9) | ||
| -- enc | ||
| -- "Final number of elements" | ||
|
|
||
| -- emptyProp = | ||
| -- let emptyScriptsEnc = encCBOR $ Map.singleton key (encCBOR ([] :: [Encoding])) | ||
| -- in property $ | ||
| -- expectDeserialiseFailureFromVersion | ||
| -- pxy | ||
| -- (natVersion @9) | ||
| -- emptyScriptsEnc | ||
| -- unexpectedEmptyError | ||
|
|
||
| genEncoding :: Bool -> Gen Encoding | ||
| genEncoding duplicate = do | ||
| sc <- arbitrary :: Gen (WitVKey 'Witness (EraCrypto era)) | ||
| let scs | ||
| | duplicate = [sc, sc] | ||
| | otherwise = [sc] | ||
|
|
||
| pure $ encCBOR $ Map.singleton key (encCBOR scs) | ||
|
|
||
| nativeScriptsProp :: | ||
| forall era. | ||
| ( AlonzoEraScript era | ||
| , Script era ~ AlonzoScript era | ||
| ) => | ||
| Proxy era -> | ||
| Spec | ||
| nativeScriptsProp pxy = do | ||
| prop "fails to deserialize if empty, starting with Conway" $ | ||
| distinctProp .&. emptyProp | ||
| where | ||
| key :: Int = 1 | ||
| distinctProp = | ||
| forAllShow (genEncoding False) (showEnc pxy) $ | ||
| expectDeserialiseSuccess pxy | ||
|
|
||
| -- TODO: enable this after we enforce distinct entries for Annotator | ||
| -- duplicateProp = | ||
| -- forAllShow (genEncoding True) (showEnc pxy) $ | ||
| -- \enc -> | ||
| -- expectDeserialiseFailureFromVersion | ||
| -- pxy | ||
| -- (natVersion @9) | ||
| -- enc | ||
| -- unexpectedDuplicatesError | ||
|
|
||
| emptyProp = | ||
| let emptyScriptsEnc = encCBOR $ Map.singleton key (encCBOR ([] :: [Encoding])) | ||
| in property $ | ||
| expectDeserialiseFailureFromVersion | ||
| pxy | ||
| (natVersion @9) | ||
| emptyScriptsEnc | ||
| unexpectedEmptyError | ||
|
|
||
| genEncoding :: Bool -> Gen Encoding | ||
| genEncoding duplicate = do | ||
| sc <- genNativeScript @era | ||
| let scs | ||
| | duplicate = [sc, sc] | ||
| | otherwise = [sc] | ||
|
|
||
| let natives = Maybe.mapMaybe getNativeScript scs | ||
| pure $ encCBOR $ Map.singleton key (encCBOR natives) | ||
|
|
||
| plutusScriptsProp :: | ||
| forall era. | ||
| ( AlonzoEraScript era | ||
| , Script era ~ AlonzoScript era | ||
| ) => | ||
| Proxy era -> | ||
| Spec | ||
| plutusScriptsProp pxy = do | ||
| prop "fails to deserialize if empty or if it contains duplicates, starting with Conway" $ | ||
| conjoin $ | ||
| [ distinctProp | ||
| , duplicateProp | ||
| , emptyProp | ||
| ] | ||
| <*> [minBound .. eraMaxLanguage @era] | ||
| where | ||
| distinctProp lang = | ||
| forAllShow (genEncoding lang False) (showEnc pxy) $ | ||
| expectDeserialiseSuccess pxy | ||
|
|
||
| duplicateProp lang = | ||
| forAllShow (genEncoding lang True) (showEnc pxy) $ | ||
| \enc -> | ||
| expectDeserialiseFailureFromVersion | ||
| pxy | ||
| (natVersion @9) | ||
| enc | ||
| unexpectedDuplicatesError | ||
|
|
||
| emptyProp lang = | ||
| let emptyScriptsEnc = encCBOR $ Map.singleton (keys lang) (encCBOR ([] :: [Encoding])) | ||
| in property $ | ||
| expectDeserialiseFailureFromVersion | ||
| pxy | ||
| (natVersion @9) | ||
| emptyScriptsEnc | ||
| unexpectedEmptyError | ||
|
|
||
| genEncoding :: Language -> Bool -> Gen Encoding | ||
| genEncoding lang duplicate = do | ||
| sc <- genPlutusScript @era lang | ||
| let scs | ||
| | duplicate = [sc, sc] | ||
| | otherwise = [sc] | ||
| let plutusBins = withSLanguage lang $ \slang -> | ||
| Maybe.mapMaybe | ||
| (\x -> plutusBinary <$> (toPlutusScript x >>= toPlutusSLanguage slang)) | ||
| scs | ||
| pure $ encCBOR $ Map.singleton (keys lang) (encCBOR plutusBins) | ||
| keys PlutusV1 = 3 :: Int | ||
| keys PlutusV2 = 6 | ||
| keys PlutusV3 = 7 | ||
|
|
||
| unexpectedEmptyError :: String | ||
| unexpectedEmptyError = "Empty list" | ||
|
|
||
| unexpectedDuplicatesError :: String | ||
| unexpectedDuplicatesError = "Final number of elements" | ||
|
|
||
| expectDeserialiseSuccess :: | ||
| forall era. | ||
| (AlonzoEraScript era, HasCallStack) => | ||
| Proxy era -> | ||
| Encoding -> | ||
| IO () | ||
| expectDeserialiseSuccess _ enc = | ||
| encodeAndCheckDecoded @era enc $ | ||
| \decoded -> void $ expectRight decoded | ||
|
|
||
| expectDeserialiseFailureFromVersion :: | ||
| forall era. | ||
| (AlonzoEraScript era, HasCallStack) => | ||
| Proxy era -> | ||
| Version -> | ||
| Encoding -> | ||
| String -> | ||
| IO () | ||
| expectDeserialiseFailureFromVersion _ v enc errMsgPrefix = | ||
| encodeAndCheckDecoded @era enc $ | ||
| \decoded -> do | ||
| if eraProtVerHigh @era < v | ||
| then void $ expectRight decoded | ||
| else expectDeserialiseFailure (void decoded) errMsgPrefix | ||
|
|
||
| expectDeserialiseFailure :: | ||
| (HasCallStack, Show t) => | ||
| Either DecoderError t -> | ||
| String -> | ||
| IO () | ||
| expectDeserialiseFailure e errMsgPrefix = do | ||
| res <- expectLeft e | ||
| res `shouldSatisfy` \case | ||
| DecoderErrorDeserialiseFailure _ (DeserialiseFailure _ errMsg) -> | ||
| errMsgPrefix `isPrefixOf` errMsg | ||
| _ -> False | ||
|
|
||
| encodeAndCheckDecoded :: | ||
| forall era. | ||
| AlonzoEraScript era => | ||
| Encoding -> | ||
| (Either DecoderError (Annotator (AlonzoTxWits era)) -> IO ()) -> | ||
| IO () | ||
| encodeAndCheckDecoded enc check = do | ||
| let ver = eraProtVerHigh @era | ||
| bytes = serialize ver enc | ||
| check (decodeFull @(Annotator (AlonzoTxWits era)) ver bytes) | ||
|
|
||
| showEnc :: forall era. Era era => Proxy era -> Encoding -> String | ||
| showEnc _ enc = show $ toPlainEncoding (eraProtVerHigh @era) enc |
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