diff --git a/eras/allegra/impl/CHANGELOG.md b/eras/allegra/impl/CHANGELOG.md index 450deb1721d..3f7851ca622 100644 --- a/eras/allegra/impl/CHANGELOG.md +++ b/eras/allegra/impl/CHANGELOG.md @@ -2,6 +2,10 @@ ## 1.7.0.0 +* Add `DecCBOR` instances for: + * `Timelock` + * `AllegraTxAuxData` + * `AllegraTxBody` * Converted `CertState` to a type family * Made the fields of predicate failures and environments lazy * Add `Era era` constraint to `NoThunks` instance for `TimeLock` diff --git a/eras/allegra/impl/src/Cardano/Ledger/Allegra/Scripts.hs b/eras/allegra/impl/src/Cardano/Ledger/Allegra/Scripts.hs index d2b6ca945db..6c938b6c8b1 100644 --- a/eras/allegra/impl/src/Cardano/Ledger/Allegra/Scripts.hs +++ b/eras/allegra/impl/src/Cardano/Ledger/Allegra/Scripts.hs @@ -76,6 +76,7 @@ import Cardano.Ledger.MemoBytes ( MemoBytes (Memo), Memoized (..), byteCountMemoBytes, + decodeMemoized, getMemoRawType, mkMemoBytes, mkMemoizedEra, @@ -189,9 +190,8 @@ instance Era era => EncCBOR (TimelockRaw era) where TimeStart m -> Sum TimeStart 4 !> To m TimeExpire m -> Sum TimeExpire 5 !> To m --- This instance allows us to derive instance DecCBOR (Annotator (Timelock crypto)). --- Since Timelock is a newtype around (Memo (Timelock crypto)). - +-- This instance allows us to derive instance DecCBOR (Annotator (Timelock era)). +-- Since Timelock is a newtype around (Memo (Timelock era)). instance Era era => DecCBOR (Annotator (TimelockRaw era)) where decCBOR = decode (Summands "TimelockRaw" decRaw) where @@ -204,6 +204,16 @@ instance Era era => DecCBOR (Annotator (TimelockRaw era)) where decRaw 5 = Ann (SumD TimeExpire DecCBOR (TimelockRaw era) where + decCBOR = decode $ Summands "TimelockRaw" $ \case + 0 -> SumD Signature SumD AllOf SumD AnyOf SumD MOfN SumD TimeStart SumD TimeExpire Invalid n + -- ================================================================= -- Native Scripts are Memoized TimelockRaw. -- The patterns give the appearence that the mutual recursion is not present. @@ -222,6 +232,9 @@ instance Era era => MemPack (Timelock era) where instance Era era => NoThunks (Timelock era) instance Era era => EncCBOR (Timelock era) +instance Era era => DecCBOR (Timelock era) where + decCBOR = TimelockConstr <$> decodeMemoized decCBOR + instance Memoized (Timelock era) where type RawType (Timelock era) = TimelockRaw era diff --git a/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxAuxData.hs b/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxAuxData.hs index b887b9c84c9..ea99db6e5a7 100644 --- a/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxAuxData.hs +++ b/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxAuxData.hs @@ -122,7 +122,7 @@ instance NFData (AllegraTxAuxDataRaw era) newtype AllegraTxAuxData era = AuxiliaryDataWithBytes (MemoBytes (AllegraTxAuxDataRaw era)) deriving (Generic) - deriving newtype (Eq, ToCBOR, SafeToHash) + deriving newtype (Eq, ToCBOR, SafeToHash, DecCBOR) instance Memoized (AllegraTxAuxData era) where type RawType (AllegraTxAuxData era) = AllegraTxAuxDataRaw era @@ -172,7 +172,7 @@ instance Era era => DecCBOR (Annotator (AllegraTxAuxDataRaw era)) where TypeListLen -> decodeFromList TypeListLen64 -> decodeFromList TypeListLenIndef -> decodeFromList - _ -> error "Failed to decode AuxiliaryData" + _ -> fail "Failed to decode AuxiliaryDataRaw" where decodeFromMap = decode @@ -187,6 +187,30 @@ instance Era era => DecCBOR (Annotator (AllegraTxAuxDataRaw era)) where <*! D (sequence <$> decCBOR) ) +instance Era era => DecCBOR (AllegraTxAuxDataRaw era) where + decCBOR = + peekTokenType >>= \case + TypeMapLen -> decodeFromMap + TypeMapLen64 -> decodeFromMap + TypeMapLenIndef -> decodeFromMap + TypeListLen -> decodeFromList + TypeListLen64 -> decodeFromList + TypeListLenIndef -> decodeFromList + _ -> fail "Failed to decode AuxiliaryDataRaw" + where + decodeFromMap = + decode + ( Emit AllegraTxAuxDataRaw + DecCBOR (Annotator (AlonzoScript era)) where {-# INLINE decodeScript #-} {-# INLINE decCBOR #-} +instance AlonzoEraScript era => DecCBOR (AlonzoScript era) where + decCBOR = decode (Summands "AlonzoScript" decodeScript) + where + decodeScript = \case + 0 -> SumD TimelockScript decodePlutus SPlutusV1 + 2 -> decodePlutus SPlutusV2 + 3 -> decodePlutus SPlutusV3 + n -> Invalid n + decodePlutus slang = + SumD PlutusScript + DecCBOR (AlonzoTx era) + where + decCBOR = + decode $ + RecD AlonzoTx + Tx era -> Tx era -> Bool alonzoEqTxRaw tx1 tx2 = shelleyEqTxRaw tx1 tx2 && (tx1 ^. isValidTxL == tx2 ^. isValidTxL) diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxAuxData.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxAuxData.hs index 3df8fcba175..2113f2880f2 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxAuxData.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxAuxData.hs @@ -59,6 +59,7 @@ import Cardano.Ledger.BaseTypes (ProtVer) import Cardano.Ledger.Binary ( Annotator (..), DecCBOR (..), + Decoder, EncCBOR (..), ToCBOR, TokenType (..), @@ -183,16 +184,10 @@ getAlonzoTxAuxDataScripts AlonzoTxAuxData {atadTimelock = timelocks, atadPlutus instance Era era => DecCBOR (Annotator (AlonzoTxAuxDataRaw era)) where decCBOR = - peekTokenType >>= \case - TypeMapLen -> decodeShelley - TypeMapLen64 -> decodeShelley - TypeMapLenIndef -> decodeShelley - TypeListLen -> decodeShelleyMA - TypeListLen64 -> decodeShelleyMA - TypeListLenIndef -> decodeShelleyMA - TypeTag -> decodeAlonzo - TypeTag64 -> decodeAlonzo - _ -> fail "Failed to decode AlonzoTxAuxData" + decodeTxAuxDataByTokenType @(Annotator (AlonzoTxAuxDataRaw era)) + decodeShelley + decodeAllegra + decodeAlonzo where decodeShelley = decode @@ -201,7 +196,7 @@ instance Era era => DecCBOR (Annotator (AlonzoTxAuxDataRaw era)) where <*! Ann (Emit StrictSeq.empty) <*! Ann (Emit Map.empty) ) - decodeShelleyMA = + decodeAllegra = decode ( Ann (RecD AlonzoTxAuxDataRaw) <*! Ann From @@ -214,13 +209,6 @@ instance Era era => DecCBOR (Annotator (AlonzoTxAuxDataRaw era)) where TagD 259 $ SparseKeyed "AlonzoTxAuxData" (pure emptyAuxData) auxDataField [] - addPlutusScripts lang scripts ad = - case NE.nonEmpty scripts of - Nothing -> ad - Just neScripts -> - -- Avoid leaks by deepseq, since non empty list is lazy. - neScripts `deepseq` ad {atadrPlutus = Map.insert lang neScripts $ atadrPlutus ad} - auxDataField :: Word -> Field (Annotator (AlonzoTxAuxDataRaw era)) auxDataField 0 = fieldA (\x ad -> ad {atadrMetadata = x}) From auxDataField 1 = @@ -232,6 +220,53 @@ instance Era era => DecCBOR (Annotator (AlonzoTxAuxDataRaw era)) where auxDataField 4 = fieldA (addPlutusScripts PlutusV3) (D (guardPlutus PlutusV3 >> decCBOR)) auxDataField n = field (\_ t -> t) (Invalid n) +instance Era era => DecCBOR (AlonzoTxAuxDataRaw era) where + decCBOR = + decodeTxAuxDataByTokenType @(AlonzoTxAuxDataRaw era) + decodeShelley + decodeAllegra + decodeAlonzo + where + decodeShelley = + decode + (Emit AlonzoTxAuxDataRaw Field (AlonzoTxAuxDataRaw era) + auxDataField 0 = field (\x ad -> ad {atadrMetadata = x}) From + auxDataField 1 = field (\x ad -> ad {atadrTimelock = atadrTimelock ad <> x}) From + auxDataField 2 = field (addPlutusScripts PlutusV1) (D (guardPlutus PlutusV1 >> decCBOR)) + auxDataField 3 = field (addPlutusScripts PlutusV2) (D (guardPlutus PlutusV2 >> decCBOR)) + auxDataField 4 = field (addPlutusScripts PlutusV3) (D (guardPlutus PlutusV3 >> decCBOR)) + auxDataField n = field (\_ t -> t) (Invalid n) + +decodeTxAuxDataByTokenType :: forall t s. Decoder s t -> Decoder s t -> Decoder s t -> Decoder s t +decodeTxAuxDataByTokenType decodeShelley decodeAllegra decodeAlonzo = + peekTokenType >>= \case + TypeMapLen -> decodeShelley + TypeMapLen64 -> decodeShelley + TypeMapLenIndef -> decodeShelley + TypeListLen -> decodeAllegra + TypeListLen64 -> decodeAllegra + TypeListLenIndef -> decodeAllegra + TypeTag -> decodeAlonzo + TypeTag64 -> decodeAlonzo + _ -> fail "Failed to decode AlonzoTxAuxData" + +addPlutusScripts :: Language -> [PlutusBinary] -> AlonzoTxAuxDataRaw era -> AlonzoTxAuxDataRaw era +addPlutusScripts lang scripts ad = + case NE.nonEmpty scripts of + Nothing -> ad + Just neScripts -> + -- Avoid leaks by deepseq, since non empty list is lazy. + neScripts `deepseq` ad {atadrPlutus = Map.insert lang neScripts $ atadrPlutus ad} + emptyAuxData :: AlonzoTxAuxDataRaw era emptyAuxData = AlonzoTxAuxDataRaw mempty mempty mempty @@ -240,7 +275,7 @@ emptyAuxData = AlonzoTxAuxDataRaw mempty mempty mempty newtype AlonzoTxAuxData era = AlonzoTxAuxDataConstr (MemoBytes (AlonzoTxAuxDataRaw era)) deriving (Generic) - deriving newtype (ToCBOR, SafeToHash) + deriving newtype (ToCBOR, SafeToHash, DecCBOR) instance Memoized (AlonzoTxAuxData era) where type RawType (AlonzoTxAuxData era) = AlonzoTxAuxDataRaw era diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody/Internal.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody/Internal.hs index e28af0b94cb..7417a22ad91 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody/Internal.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody/Internal.hs @@ -401,6 +401,10 @@ deriving via (Era era, DecCBOR (TxOut era), DecCBOR (TxCert era), DecCBOR (PParamsUpdate era)) => DecCBOR (Annotator (AlonzoTxBody era)) +deriving newtype instance + (Era era, DecCBOR (TxOut era), DecCBOR (TxCert era), DecCBOR (PParamsUpdate era)) => + DecCBOR (AlonzoTxBody era) + pattern AlonzoTxBody :: forall era. (EraTxOut era, EraTxCert era) => diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxSeq/Internal.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxSeq/Internal.hs index a2ddb84f4dd..137553e0959 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxSeq/Internal.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxSeq/Internal.hs @@ -32,9 +32,11 @@ import qualified Cardano.Crypto.Hash as Hash import Cardano.Ledger.Alonzo.Era import Cardano.Ledger.Alonzo.Tx (AlonzoEraTx (..), IsValid (..), alonzoSegwitTx) import Cardano.Ledger.Binary ( + Annotated (..), Annotator, DecCBOR (..), EncCBORGroup (..), + decodeAnnotated, encCBOR, encodeFoldableEncoder, encodeFoldableMapEncoder, @@ -44,14 +46,15 @@ import Cardano.Ledger.Binary ( withSlice, ) import Cardano.Ledger.Core -import Cardano.Ledger.Shelley.BlockChain (constructMetadata) +import Cardano.Ledger.Shelley.BlockChain (constructMetadata, indexLookupSeq) import Control.Monad (unless) import Data.ByteString (ByteString) import Data.ByteString.Builder (shortByteString, toLazyByteString) import qualified Data.ByteString.Lazy as BSL import Data.Coerce (coerce) import qualified Data.Map.Strict as Map -import Data.Maybe.Strict (strictMaybeToMaybe) +import Data.Maybe.Strict (maybeToStrictMaybe, strictMaybeToMaybe) +import Data.Monoid (All (..)) import Data.Proxy (Proxy (..)) import qualified Data.Sequence as Seq import Data.Sequence.Strict (StrictSeq) @@ -182,37 +185,37 @@ hashAlonzoTxSeq (AlonzoTxSeqRaw _ bodies ws md vs) = instance AlonzoEraTx era => DecCBOR (Annotator (AlonzoTxSeq era)) where decCBOR = do (bodies, bodiesAnn) <- withSlice decCBOR - (ws, witsAnn) <- withSlice decCBOR - let b = length bodies - inRange x = (0 <= x) && (x <= (b - 1)) - w = length ws + (wits, witsAnn) <- withSlice decCBOR + let bodiesLength = length bodies + inRange x = (0 <= x) && (x <= (bodiesLength - 1)) + witsLength = length wits (auxData, auxDataAnn) <- withSlice $ do - m <- decCBOR + auxDataMap <- decCBOR unless - (all inRange (Map.keysSet m)) + (getAll (Map.foldMapWithKey (\k _ -> All (inRange k)) auxDataMap)) ( fail ( "Some Auxiliarydata index is not in the range: 0 .. " - ++ show (b - 1) + ++ show (bodiesLength - 1) ) ) - pure (constructMetadata b m) + pure (constructMetadata bodiesLength auxDataMap) (isValIdxs, isValAnn) <- withSlice decCBOR - let vs = alignedValidFlags b isValIdxs + let validFlags = alignedValidFlags bodiesLength isValIdxs unless - (b == w) + (bodiesLength == witsLength) ( fail $ "different number of transaction bodies (" - <> show b + <> show bodiesLength <> ") and witness sets (" - <> show w + <> show witsLength <> ")" ) unless (all inRange isValIdxs) ( fail ( "Some IsValid index is not in the range: 0 .. " - ++ show (b - 1) + ++ show (bodiesLength - 1) ++ ", " ++ show isValIdxs ) @@ -221,7 +224,7 @@ instance AlonzoEraTx era => DecCBOR (Annotator (AlonzoTxSeq era)) where let txns = sequenceA $ StrictSeq.forceToStrict $ - Seq.zipWith4 alonzoSegwitTx bodies ws vs auxData + Seq.zipWith4 alonzoSegwitTx bodies wits validFlags auxData pure $ AlonzoTxSeqRaw <$> txns @@ -230,6 +233,65 @@ instance AlonzoEraTx era => DecCBOR (Annotator (AlonzoTxSeq era)) where <*> auxDataAnn <*> isValAnn +instance + ( AlonzoEraTx era + , DecCBOR (TxBody era) + , DecCBOR (TxWits era) + , DecCBOR (TxAuxData era) + ) => + DecCBOR (AlonzoTxSeq era) + where + decCBOR = do + Annotated bodies bodiesBytes <- decodeAnnotated decCBOR + Annotated wits witsBytes <- decodeAnnotated decCBOR + Annotated auxDataMap auxDataBytes <- decodeAnnotated decCBOR + let bodiesLength = length bodies + inRange x = (0 <= x) && (x <= (bodiesLength - 1)) + witsLength = length wits + unless + (getAll (Map.foldMapWithKey (\k _ -> All (inRange k)) auxDataMap)) + ( fail + ( "Some Auxiliarydata index is not in the range: 0 .. " + ++ show (bodiesLength - 1) + ) + ) + let auxData = indexLookupSeq bodiesLength auxDataMap + Annotated isValidIdxs isValidBytes <- decodeAnnotated decCBOR + let validFlags = alignedValidFlags bodiesLength isValidIdxs + unless + (bodiesLength == witsLength) + ( fail $ + "different number of transaction bodies (" + <> show bodiesLength + <> ") and witness sets (" + <> show witsLength + <> ")" + ) + unless + (all inRange isValidIdxs) + ( fail + ( "Some IsValid index is not in the range: 0 .. " + ++ show (bodiesLength - 1) + ++ ", " + ++ show isValidIdxs + ) + ) + let mkTx body wit isValid aData = + mkBasicTx body + & witsTxL .~ wit + & auxDataTxL .~ maybeToStrictMaybe aData + & isValidTxL .~ isValid + let txs = + StrictSeq.forceToStrict $ + Seq.zipWith4 mkTx bodies wits validFlags auxData + pure $ + AlonzoTxSeqRaw + txs + bodiesBytes + witsBytes + auxDataBytes + isValidBytes + -------------------------------------------------------------------------------- -- Internal utility functions -------------------------------------------------------------------------------- diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs index 4a6b175ad9b..328e3f95653 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs @@ -171,7 +171,7 @@ instance Memoized (Redeemers era) where -- Since the 'Redeemers' exist outside of the transaction body, -- this is how we ensure that they are not manipulated. newtype Redeemers era = RedeemersConstr (MemoBytes (RedeemersRaw era)) - deriving newtype (Generic, ToCBOR, SafeToHash, Typeable) + deriving newtype (Generic, ToCBOR, SafeToHash, Typeable, DecCBOR) deriving newtype instance AlonzoEraScript era => Eq (Redeemers era) deriving newtype instance AlonzoEraScript era => NFData (Redeemers era) @@ -205,6 +205,9 @@ unRedeemers = unRedeemersRaw . getMemoRawType nullRedeemers :: Redeemers era -> Bool nullRedeemers = Map.null . unRedeemers +emptyTxWitness :: AlonzoEraScript era => AlonzoTxWitsRaw era +emptyTxWitness = AlonzoTxWitsRaw mempty mempty mempty mempty emptyRedeemers + emptyRedeemers :: AlonzoEraScript era => Redeemers era emptyRedeemers = Redeemers mempty @@ -333,12 +336,22 @@ instance Era era => DecCBOR (Annotator (TxDatsRaw era)) where (mapTraverseableDecoderA (decodeList decCBOR) (TxDatsRaw . Map.fromElems hashData)) {-# INLINE decCBOR #-} +instance Era era => DecCBOR (TxDatsRaw era) where + decCBOR = + ifDecoderVersionAtLeast + (natVersion @9) + ( allowTag setTag + >> TxDatsRaw . Map.fromElems hashData . NE.toList <$> decodeNonEmptyList decCBOR + ) + (TxDatsRaw . Map.fromElems hashData <$> decodeList decCBOR) + {-# INLINE decCBOR #-} + -- | Note that 'TxDats' are based on 'MemoBytes' since we must preserve -- the original bytes for the 'Cardano.Ledger.Alonzo.Tx.ScriptIntegrity'. -- Since the 'TxDats' exist outside of the transaction body, -- this is how we ensure that they are not manipulated. newtype TxDats era = TxDatsConstr (MemoBytes (TxDatsRaw era)) - deriving newtype (SafeToHash, ToCBOR, Eq, NoThunks, NFData) + deriving newtype (SafeToHash, ToCBOR, Eq, NoThunks, NFData, DecCBOR) deriving (Generic) instance Memoized (TxDats era) where @@ -600,6 +613,40 @@ instance AlonzoEraScript era => DecCBOR (Annotator (RedeemersRaw era)) where {-# INLINE decodeElement #-} {-# INLINE decCBOR #-} +instance AlonzoEraScript era => DecCBOR (RedeemersRaw era) where + decCBOR = + ifDecoderVersionAtLeast + (natVersion @9) + ( peekTokenType >>= \case + TypeMapLenIndef -> decodeMapRedeemers + TypeMapLen -> decodeMapRedeemers + _ -> decodeListRedeemers + ) + (RedeemersRaw . Map.fromList <$> decodeList decodeElement) + where + decodeMapRedeemers :: Decoder s (RedeemersRaw era) + decodeMapRedeemers = + RedeemersRaw . Map.fromList . NE.toList <$> do + (_, xs) <- decodeListLikeWithCount decodeMapLenOrIndef (:) $ \_ -> do + ptr <- decCBOR + (annData, exUnits) <- decCBOR + pure (ptr, (annData, exUnits)) + case NE.nonEmpty xs of + Nothing -> fail "Expected redeemers map to be non-empty" + Just neList -> pure $ NE.reverse neList + decodeListRedeemers :: Decoder s (RedeemersRaw era) + decodeListRedeemers = + RedeemersRaw . Map.fromList . NE.toList + <$> decodeNonEmptyList decodeElement + decodeElement :: Decoder s (PlutusPurpose AsIx era, (Data era, ExUnits)) + decodeElement = do + decodeRecordNamed + "Redeemer" + (\(rdmrPtr, _) -> fromIntegral (listLen rdmrPtr) + 2) + $ (,) <$> decCBORGroup <*> ((,) <$> decCBOR <*> decCBOR) + {-# INLINE decodeElement #-} + {-# INLINE decCBOR #-} + -- | Encodes memoized bytes created upon construction. instance AlonzoEraScript era => EncCBOR (Redeemers era) @@ -608,10 +655,13 @@ deriving via instance AlonzoEraScript era => DecCBOR (Annotator (Redeemers era)) +deriving via + Mem (AlonzoTxWitsRaw era) + instance + AlonzoEraScript era => DecCBOR (Annotator (AlonzoTxWits era)) + instance - ( AlonzoEraScript era - , EncCBOR (Data era) - ) => + AlonzoEraScript era => DecCBOR (Annotator (AlonzoTxWitsRaw era)) where decCBOR = @@ -622,8 +672,6 @@ instance txWitnessField [] where - emptyTxWitness = AlonzoTxWitsRaw mempty mempty mempty mempty emptyRedeemers - txWitnessField :: Word -> Field (Annotator (AlonzoTxWitsRaw era)) txWitnessField 0 = fieldAA @@ -673,59 +721,120 @@ instance where pairDecoder :: Decoder s (Annotator (ScriptHash, Script era)) pairDecoder = fmap (asHashedPair . fromNativeScript) <$> decCBOR - - addScripts :: - Map ScriptHash (Script era) -> - AlonzoTxWitsRaw era -> - AlonzoTxWitsRaw era - addScripts scriptWitnesses txWits = - txWits - { atwrScriptTxWits = scriptWitnesses <> atwrScriptTxWits txWits - } - {-# INLINE addScripts #-} - - decodePlutus :: - PlutusLanguage l => - SLanguage l -> - Decode ('Closed 'Dense) (Map ScriptHash (Script era)) - decodePlutus slang = - D $ - ifDecoderVersionAtLeast - (natVersion @9) - (scriptDecoderV9 (fromPlutusScript <$> decodePlutusScript slang)) - (scriptDecoder (fromPlutusScript <$> decodePlutusScript slang)) - {-# INLINE decodePlutus #-} - - scriptDecoderV9 :: - Decoder s (Script era) -> - Decoder s (Map ScriptHash (Script era)) - scriptDecoderV9 decodeScript = do - allowTag setTag - scriptMap <- decodeMapLikeEnforceNoDuplicates decodeListLenOrIndef $ do - asHashedPair <$> decodeScript - when (Map.null scriptMap) $ fail "Empty list of scripts is not allowed" - pure scriptMap - {-# INLINE scriptDecoderV9 #-} - - scriptDecoder :: - Decoder s (Script era) -> - Decoder s (Map ScriptHash (Script era)) - scriptDecoder decodeScript = - fmap Map.fromList $ - decodeList $ - asHashedPair <$> decodeScript - {-# INLINE scriptDecoder #-} - - asHashedPair script = - let !scriptHash = hashScript @era script - in (scriptHash, script) - {-# INLINE asHashedPair #-} {-# INLINE decCBOR #-} -deriving via - Mem (AlonzoTxWitsRaw era) - instance - AlonzoEraScript era => DecCBOR (Annotator (AlonzoTxWits era)) +instance + ( AlonzoEraScript era + , DecCBOR (NativeScript era) + ) => + DecCBOR (AlonzoTxWitsRaw era) + where + decCBOR = + decode $ + SparseKeyed + "AlonzoTxWits" + emptyTxWitness + txWitnessField + [] + where + txWitnessField :: Word -> Field (AlonzoTxWitsRaw era) + txWitnessField 0 = + field + (\x wits -> wits {atwrAddrTxWits = x}) + ( D $ + ifDecoderVersionAtLeast + (natVersion @9) + ( allowTag setTag + >> Set.fromList . NE.toList <$> decodeNonEmptyList decCBOR + ) + (Set.fromList <$> decodeList decCBOR) + ) + txWitnessField 1 = field addScripts (D nativeScriptsDecoder) + txWitnessField 2 = + field + (\x wits -> wits {atwrBootAddrTxWits = x}) + ( D $ + ifDecoderVersionAtLeast + (natVersion @9) + ( allowTag setTag + >> Set.fromList . NE.toList <$> decodeNonEmptyList decCBOR + ) + (Set.fromList <$> decodeList decCBOR) + ) + txWitnessField 3 = field addScripts (decodePlutus SPlutusV1) + txWitnessField 4 = field (\x wits -> wits {atwrDatsTxWits = x}) From + txWitnessField 5 = field (\x wits -> wits {atwrRdmrsTxWits = x}) From + txWitnessField 6 = field addScripts (decodePlutus SPlutusV2) + txWitnessField 7 = field addScripts (decodePlutus SPlutusV3) + txWitnessField n = field (\_ t -> t) (Invalid n) + + nativeScriptsDecoder :: Decoder s (Map ScriptHash (Script era)) + nativeScriptsDecoder = + ifDecoderVersionAtLeast + (natVersion @9) + ( allowTag setTag + >> Map.fromList . NE.toList <$> decodeNonEmptyList pairDecoder + ) + (Map.fromList <$> decodeList pairDecoder) + where + pairDecoder :: Decoder s (ScriptHash, Script era) + pairDecoder = asHashedPair @era . fromNativeScript <$> decCBOR + +deriving newtype instance + ( AlonzoEraScript era + , DecCBOR (NativeScript era) + ) => + DecCBOR (AlonzoTxWits era) + +addScripts :: + Map ScriptHash (Script era) -> + AlonzoTxWitsRaw era -> + AlonzoTxWitsRaw era +addScripts scriptWitnesses txWits = + txWits + { atwrScriptTxWits = scriptWitnesses <> atwrScriptTxWits txWits + } +{-# INLINE addScripts #-} + +decodePlutus :: + (AlonzoEraScript era, PlutusLanguage l) => + SLanguage l -> + Decode ('Closed 'Dense) (Map ScriptHash (Script era)) +decodePlutus slang = + D $ + ifDecoderVersionAtLeast + (natVersion @9) + (scriptDecoderV9 (fromPlutusScript <$> decodePlutusScript slang)) + (scriptDecoder (fromPlutusScript <$> decodePlutusScript slang)) +{-# INLINE decodePlutus #-} + +scriptDecoderV9 :: + EraScript era => + Decoder s (Script era) -> + Decoder s (Map ScriptHash (Script era)) +scriptDecoderV9 decodeScript = do + allowTag setTag + scriptMap <- decodeMapLikeEnforceNoDuplicates decodeListLenOrIndef $ do + asHashedPair <$> decodeScript + when (Map.null scriptMap) $ fail "Empty list of scripts is not allowed" + pure scriptMap +{-# INLINE scriptDecoderV9 #-} + +scriptDecoder :: + EraScript era => + Decoder s (Script era) -> + Decoder s (Map ScriptHash (Script era)) +scriptDecoder decodeScript = + fmap Map.fromList $ + decodeList $ + asHashedPair <$> decodeScript +{-# INLINE scriptDecoder #-} + +asHashedPair :: forall era. EraScript era => Script era -> (ScriptHash, Script era) +asHashedPair script = + let !scriptHash = hashScript @era script + in (scriptHash, script) +{-# INLINE asHashedPair #-} alonzoEqTxWitsRaw :: AlonzoEraTxWits era => TxWits era -> TxWits era -> Bool alonzoEqTxWitsRaw txWits1 txWits2 = diff --git a/eras/alonzo/impl/test/Test/Cardano/Ledger/Alonzo/Binary/CddlSpec.hs b/eras/alonzo/impl/test/Test/Cardano/Ledger/Alonzo/Binary/CddlSpec.hs index ebc091646d3..b9cff6a3590 100644 --- a/eras/alonzo/impl/test/Test/Cardano/Ledger/Alonzo/Binary/CddlSpec.hs +++ b/eras/alonzo/impl/test/Test/Cardano/Ledger/Alonzo/Binary/CddlSpec.hs @@ -13,10 +13,12 @@ import Test.Cardano.Ledger.Alonzo.Binary.Cddl (readAlonzoCddlFiles) import Test.Cardano.Ledger.Alonzo.CDDL (alonzoCDDL) import Test.Cardano.Ledger.Binary.Cddl ( beforeAllCddlFile, + cddlDecoderEquivalenceSpec, cddlRoundTripAnnCborSpec, cddlRoundTripCborSpec, ) import Test.Cardano.Ledger.Binary.Cuddle ( + huddleDecoderEquivalenceSpec, huddleRoundTripAnnCborSpec, huddleRoundTripCborSpec, specWithHuddle, @@ -30,24 +32,54 @@ spec = describe "Ruby-based" $ beforeAllCddlFile 3 readAlonzoCddlFiles $ do cddlRoundTripCborSpec @(Value AlonzoEra) v "coin" cddlRoundTripAnnCborSpec @(TxBody AlonzoEra) v "transaction_body" + cddlRoundTripCborSpec @(TxBody AlonzoEra) v "transaction_body" cddlRoundTripAnnCborSpec @(TxAuxData AlonzoEra) v "auxiliary_data" + cddlRoundTripCborSpec @(TxAuxData AlonzoEra) v "auxiliary_data" cddlRoundTripAnnCborSpec @(Timelock AlonzoEra) v "native_script" + cddlRoundTripCborSpec @(Timelock AlonzoEra) v "native_script" cddlRoundTripAnnCborSpec @(Data AlonzoEra) v "plutus_data" + cddlRoundTripCborSpec @(Data AlonzoEra) v "plutus_data" cddlRoundTripCborSpec @(TxOut AlonzoEra) v "transaction_output" cddlRoundTripAnnCborSpec @(AlonzoTxWits AlonzoEra) v "transaction_witness_set" + cddlRoundTripCborSpec @(AlonzoTxWits AlonzoEra) v "transaction_witness_set" cddlRoundTripCborSpec @(PParamsUpdate AlonzoEra) v "protocol_param_update" cddlRoundTripAnnCborSpec @(Redeemers AlonzoEra) v "[* redeemer]" + cddlRoundTripCborSpec @(Redeemers AlonzoEra) v "[* redeemer]" cddlRoundTripAnnCborSpec @(Tx AlonzoEra) v "transaction" + cddlRoundTripCborSpec @(Tx AlonzoEra) v "transaction" cddlRoundTripCborSpec @CostModels v "cost_models" + describe "DecCBOR instances equivalence via CDDL" $ do + cddlDecoderEquivalenceSpec @(TxBody AlonzoEra) v "transaction_body" + cddlDecoderEquivalenceSpec @(TxAuxData AlonzoEra) v "auxiliary_data" + cddlDecoderEquivalenceSpec @(Timelock AlonzoEra) v "native_script" + cddlDecoderEquivalenceSpec @(Data AlonzoEra) v "plutus_data" + cddlDecoderEquivalenceSpec @(AlonzoTxWits AlonzoEra) v "transaction_witness_set" + cddlDecoderEquivalenceSpec @(Redeemers AlonzoEra) v "[* redeemer]" + cddlDecoderEquivalenceSpec @(Tx AlonzoEra) v "transaction" describe "Huddle" $ specWithHuddle alonzoCDDL 100 $ do huddleRoundTripCborSpec @(Value AlonzoEra) v "coin" huddleRoundTripAnnCborSpec @(TxBody AlonzoEra) v "transaction_body" + huddleRoundTripCborSpec @(TxBody AlonzoEra) v "transaction_body" huddleRoundTripAnnCborSpec @(TxAuxData AlonzoEra) v "auxiliary_data" + huddleRoundTripCborSpec @(TxAuxData AlonzoEra) v "auxiliary_data" huddleRoundTripAnnCborSpec @(Timelock AlonzoEra) v "native_script" + huddleRoundTripCborSpec @(Timelock AlonzoEra) v "native_script" huddleRoundTripAnnCborSpec @(Data AlonzoEra) v "plutus_data" + huddleRoundTripCborSpec @(Data AlonzoEra) v "plutus_data" huddleRoundTripCborSpec @(TxOut AlonzoEra) v "transaction_output" huddleRoundTripAnnCborSpec @(AlonzoTxWits AlonzoEra) v "transaction_witness_set" + huddleRoundTripCborSpec @(AlonzoTxWits AlonzoEra) v "transaction_witness_set" huddleRoundTripCborSpec @(PParamsUpdate AlonzoEra) v "protocol_param_update" huddleRoundTripAnnCborSpec @(Redeemers AlonzoEra) v "redeemers" + huddleRoundTripCborSpec @(Redeemers AlonzoEra) v "redeemers" huddleRoundTripAnnCborSpec @(Tx AlonzoEra) v "transaction" + huddleRoundTripCborSpec @(Tx AlonzoEra) v "transaction" huddleRoundTripCborSpec @CostModels v "cost_models" + describe "DecCBOR instances equivalence via CDDL" $ do + huddleDecoderEquivalenceSpec @(TxBody AlonzoEra) v "transaction_body" + huddleDecoderEquivalenceSpec @(TxAuxData AlonzoEra) v "auxiliary_data" + huddleDecoderEquivalenceSpec @(Timelock AlonzoEra) v "native_script" + huddleDecoderEquivalenceSpec @(Data AlonzoEra) v "plutus_data" + huddleDecoderEquivalenceSpec @(AlonzoTxWits AlonzoEra) v "transaction_witness_set" + huddleDecoderEquivalenceSpec @(Redeemers AlonzoEra) v "redeemers" + huddleDecoderEquivalenceSpec @(Tx AlonzoEra) v "transaction" diff --git a/eras/alonzo/impl/test/Test/Cardano/Ledger/Alonzo/BinarySpec.hs b/eras/alonzo/impl/test/Test/Cardano/Ledger/Alonzo/BinarySpec.hs index 5ff5e42a329..610a83482c3 100644 --- a/eras/alonzo/impl/test/Test/Cardano/Ledger/Alonzo/BinarySpec.hs +++ b/eras/alonzo/impl/test/Test/Cardano/Ledger/Alonzo/BinarySpec.hs @@ -4,11 +4,16 @@ module Test.Cardano.Ledger.Alonzo.BinarySpec (spec) where import Cardano.Ledger.Alonzo import Cardano.Ledger.Alonzo.Genesis +import Cardano.Ledger.Alonzo.TxWits (Redeemers, TxDats) import Test.Cardano.Ledger.Alonzo.Arbitrary () import Test.Cardano.Ledger.Alonzo.Binary.RoundTrip (roundTripAlonzoCommonSpec) import Test.Cardano.Ledger.Alonzo.TreeDiff () import Test.Cardano.Ledger.Common import Test.Cardano.Ledger.Core.Binary (BinaryUpgradeOpts (..), specUpgrade) +import Test.Cardano.Ledger.Core.Binary as Binary ( + decoderEquivalenceCoreEraTypesSpec, + decoderEquivalenceEraSpec, + ) import Test.Cardano.Ledger.Core.Binary.RoundTrip (roundTripEraSpec) spec :: Spec @@ -22,3 +27,7 @@ spec = do roundTripAlonzoCommonSpec @AlonzoEra -- AlonzoGenesis only makes sense in Alonzo era roundTripEraSpec @AlonzoEra @AlonzoGenesis + describe "DecCBOR instances equivalence" $ do + Binary.decoderEquivalenceCoreEraTypesSpec @AlonzoEra + decoderEquivalenceEraSpec @AlonzoEra @(TxDats AlonzoEra) + decoderEquivalenceEraSpec @AlonzoEra @(Redeemers AlonzoEra) diff --git a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Arbitrary.hs b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Arbitrary.hs index 6a8afbd5a84..f89f9f5e00d 100644 --- a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Arbitrary.hs +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Arbitrary.hs @@ -66,13 +66,7 @@ import Cardano.Ledger.Alonzo.TxWits ( TxDats (TxDats), ) import Cardano.Ledger.BaseTypes (StrictMaybe (..)) -import Cardano.Ledger.Plutus.Data ( - BinaryData, - Data (..), - Datum (..), - dataToBinaryData, - hashData, - ) +import Cardano.Ledger.Plutus.Data (hashData) import Cardano.Ledger.Plutus.ExUnits (ExUnits (..)) import Cardano.Ledger.Plutus.Language ( Language (..), @@ -92,7 +86,6 @@ import Data.Text (pack) import Data.Word import Generic.Random (genericArbitraryU) import Numeric.Natural (Natural) -import qualified PlutusLedgerApi.V1 as PV1 import Test.Cardano.Ledger.Common import Test.Cardano.Ledger.Core.Arbitrary ( genValidAndUnknownCostModels, @@ -102,28 +95,6 @@ import Test.Cardano.Ledger.Core.Arbitrary ( import Test.Cardano.Ledger.Mary.Arbitrary () import Test.Cardano.Ledger.Plutus (alwaysFailsPlutus, alwaysSucceedsPlutus) -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 ( Arbitrary (AlonzoScript era) , AlonzoEraScript era @@ -445,17 +416,6 @@ instance -- 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 diff --git a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Binary/RoundTrip.hs b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Binary/RoundTrip.hs index 232bd231b74..443d6e9e5c0 100644 --- a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Binary/RoundTrip.hs +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Binary/RoundTrip.hs @@ -14,6 +14,7 @@ module Test.Cardano.Ledger.Alonzo.Binary.RoundTrip ( ) where import Cardano.Ledger.Alonzo (AlonzoEra) +import Cardano.Ledger.Binary (DecCBOR) import Cardano.Ledger.CertState import Cardano.Ledger.Compactible import Cardano.Ledger.Core @@ -51,6 +52,11 @@ roundTripAlonzoCommonSpec :: , RuleListEra era , EraCertState era , Arbitrary (CertState era) + , DecCBOR (Script era) + , DecCBOR (TxAuxData era) + , DecCBOR (TxWits era) + , DecCBOR (TxBody era) + , DecCBOR (Tx era) ) => Spec roundTripAlonzoCommonSpec = do @@ -64,6 +70,7 @@ roundTripAlonzoEraTypesSpec :: roundTripAlonzoEraTypesSpec = do describe "Alonzo era types" $ do roundTripAnnEraTypeSpec @era @Data + roundTripEraTypeSpec @era @Data roundTripEraTypeSpec @era @BinaryData -- CostModel serialization changes drastically for Conway, which requires a different -- QuickCheck generator, hence Arbitrary can't be reused diff --git a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Translation/TranslationInstance.hs b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Translation/TranslationInstance.hs index 129b86173ec..2ee2b3ebd42 100644 --- a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Translation/TranslationInstance.hs +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Translation/TranslationInstance.hs @@ -35,6 +35,7 @@ import Cardano.Ledger.Binary.Coders ( decode, encode, (!>), + ( + DecCBOR (TranslationInstance era) + where + decCBOR = + decode $ + RecD TranslationInstance + pure ()) + , testProperty "decoding auxilliary" $ + embedTripExpectation @(TxAuxData MaryEra) @(TxAuxData AlonzoEra) + (eraProtVerLow @MaryEra) + (eraProtVerLow @AlonzoEra) + cborTrip + (\_ _ -> pure ()) , testProperty "decoding txbody" $ \txBody -> let hasDeprecatedField = case txBody ^. updateTxBodyL of @@ -53,16 +59,28 @@ alonzoEncodeDecodeTests = any (\ppu -> isSJust (ppu ^. ppuMinUTxOValueL)) ups in not hasDeprecatedField ==> monadicIO - ( run $ + ( run $ do embedTripAnnExpectation @(TxBody MaryEra) @(TxBody AlonzoEra) (eraProtVerLow @MaryEra) (eraProtVerLow @AlonzoEra) (\_ _ -> pure ()) txBody + embedTripExpectation @(TxBody MaryEra) @(TxBody AlonzoEra) + (eraProtVerLow @MaryEra) + (eraProtVerLow @AlonzoEra) + cborTrip + (\_ _ -> pure ()) + txBody ) - , testProperty "decoding witnesses" $ + , testProperty "decoding witnesses (Annotator)" $ embedTripAnnExpectation @(TxWits MaryEra) @(TxWits AlonzoEra) (eraProtVerLow @MaryEra) (eraProtVerLow @AlonzoEra) (\_ _ -> pure ()) + , testProperty "decoding witnesses" $ + embedTripExpectation @(TxWits MaryEra) @(TxWits AlonzoEra) + (eraProtVerLow @MaryEra) + (eraProtVerLow @AlonzoEra) + cborTrip + (\_ _ -> pure ()) ] diff --git a/eras/babbage/impl/CHANGELOG.md b/eras/babbage/impl/CHANGELOG.md index 6f7f4ab1a0a..d339386f9a5 100644 --- a/eras/babbage/impl/CHANGELOG.md +++ b/eras/babbage/impl/CHANGELOG.md @@ -2,6 +2,7 @@ ## 1.11.0.0 +* Add `DecCBOR` instance for `BabbageTxBody` * Converted `CertState` to a type family * Made the fields of predicate failures and environments lazy * Add `MemPack` instance for `BabbageTxOut` and `PlutusScript BabbageEra` diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxBody/Internal.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxBody/Internal.hs index e6b0081fd6e..7ade3d21c87 100644 --- a/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxBody/Internal.hs +++ b/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxBody/Internal.hs @@ -236,6 +236,14 @@ deriving instance newtype BabbageTxBody era = TxBodyConstr (MemoBytes (BabbageTxBodyRaw era)) deriving newtype (Generic, SafeToHash, ToCBOR) +deriving newtype instance + ( Era era + , DecCBOR (TxOut era) + , DecCBOR (TxCert era) + , DecCBOR (PParamsUpdate era) + ) => + DecCBOR (BabbageTxBody era) + instance Memoized (BabbageTxBody era) where type RawType (BabbageTxBody era) = BabbageTxBodyRaw era diff --git a/eras/babbage/impl/test/Test/Cardano/Ledger/Babbage/Binary/CddlSpec.hs b/eras/babbage/impl/test/Test/Cardano/Ledger/Babbage/Binary/CddlSpec.hs index fc4034cc1fa..90a32809380 100644 --- a/eras/babbage/impl/test/Test/Cardano/Ledger/Babbage/Binary/CddlSpec.hs +++ b/eras/babbage/impl/test/Test/Cardano/Ledger/Babbage/Binary/CddlSpec.hs @@ -13,10 +13,12 @@ import Test.Cardano.Ledger.Babbage.Binary.Cddl (readBabbageCddlFiles) import Test.Cardano.Ledger.Babbage.CDDL (babbageCDDL) import Test.Cardano.Ledger.Binary.Cddl ( beforeAllCddlFile, + cddlDecoderEquivalenceSpec, cddlRoundTripAnnCborSpec, cddlRoundTripCborSpec, ) import Test.Cardano.Ledger.Binary.Cuddle ( + huddleDecoderEquivalenceSpec, huddleRoundTripAnnCborSpec, huddleRoundTripCborSpec, specWithHuddle, @@ -30,28 +32,62 @@ spec = describe "Ruby-based" $ beforeAllCddlFile 3 readBabbageCddlFiles $ do cddlRoundTripCborSpec @(Value BabbageEra) v "coin" cddlRoundTripAnnCborSpec @(TxBody BabbageEra) v "transaction_body" + cddlRoundTripCborSpec @(TxBody BabbageEra) v "transaction_body" cddlRoundTripAnnCborSpec @(TxAuxData BabbageEra) v "auxiliary_data" + cddlRoundTripCborSpec @(TxAuxData BabbageEra) v "auxiliary_data" cddlRoundTripAnnCborSpec @(Timelock BabbageEra) v "native_script" + cddlRoundTripCborSpec @(Timelock BabbageEra) v "native_script" cddlRoundTripAnnCborSpec @(Data BabbageEra) v "plutus_data" + cddlRoundTripCborSpec @(Data BabbageEra) v "plutus_data" cddlRoundTripCborSpec @(TxOut BabbageEra) v "transaction_output" cddlRoundTripAnnCborSpec @(Script BabbageEra) v "script" + cddlRoundTripCborSpec @(Script BabbageEra) v "script" cddlRoundTripCborSpec @(Datum BabbageEra) v "datum_option" cddlRoundTripAnnCborSpec @(TxWits BabbageEra) v "transaction_witness_set" + cddlRoundTripCborSpec @(TxWits BabbageEra) v "transaction_witness_set" cddlRoundTripCborSpec @(PParamsUpdate BabbageEra) v "protocol_param_update" cddlRoundTripCborSpec @CostModels v "cost_models" cddlRoundTripAnnCborSpec @(Redeemers BabbageEra) v "redeemers" + cddlRoundTripCborSpec @(Redeemers BabbageEra) v "redeemers" cddlRoundTripAnnCborSpec @(Tx BabbageEra) v "transaction" + cddlRoundTripCborSpec @(Tx BabbageEra) v "transaction" + describe "DecCBOR instances equivalence via CDDL" $ do + cddlDecoderEquivalenceSpec @(TxBody BabbageEra) v "transaction_body" + cddlDecoderEquivalenceSpec @(TxAuxData BabbageEra) v "auxiliary_data" + cddlDecoderEquivalenceSpec @(Timelock BabbageEra) v "native_script" + cddlDecoderEquivalenceSpec @(Data BabbageEra) v "plutus_data" + cddlDecoderEquivalenceSpec @(Script BabbageEra) v "script" + cddlDecoderEquivalenceSpec @(TxWits BabbageEra) v "transaction_witness_set" + cddlDecoderEquivalenceSpec @(Redeemers BabbageEra) v "redeemers" + cddlDecoderEquivalenceSpec @(Tx BabbageEra) v "transaction" describe "Huddle" $ specWithHuddle babbageCDDL 100 $ do huddleRoundTripCborSpec @(Value BabbageEra) v "coin" huddleRoundTripAnnCborSpec @(TxBody BabbageEra) v "transaction_body" + huddleRoundTripCborSpec @(TxBody BabbageEra) v "transaction_body" huddleRoundTripAnnCborSpec @(TxAuxData BabbageEra) v "auxiliary_data" + huddleRoundTripCborSpec @(TxAuxData BabbageEra) v "auxiliary_data" huddleRoundTripAnnCborSpec @(Timelock BabbageEra) v "native_script" + huddleRoundTripCborSpec @(Timelock BabbageEra) v "native_script" huddleRoundTripAnnCborSpec @(Data BabbageEra) v "plutus_data" + huddleRoundTripCborSpec @(Data BabbageEra) v "plutus_data" huddleRoundTripCborSpec @(TxOut BabbageEra) v "transaction_output" huddleRoundTripAnnCborSpec @(Script BabbageEra) v "script" + huddleRoundTripCborSpec @(Script BabbageEra) v "script" huddleRoundTripCborSpec @(Datum BabbageEra) v "datum_option" huddleRoundTripAnnCborSpec @(TxWits BabbageEra) v "transaction_witness_set" + huddleRoundTripCborSpec @(TxWits BabbageEra) v "transaction_witness_set" huddleRoundTripCborSpec @(PParamsUpdate BabbageEra) v "protocol_param_update" huddleRoundTripCborSpec @CostModels v "cost_models" huddleRoundTripAnnCborSpec @(Redeemers BabbageEra) v "redeemers" + huddleRoundTripCborSpec @(Redeemers BabbageEra) v "redeemers" huddleRoundTripAnnCborSpec @(Tx BabbageEra) v "transaction" + huddleRoundTripCborSpec @(Tx BabbageEra) v "transaction" + describe "DecCBOR instances equivalence via CDDL" $ do + huddleDecoderEquivalenceSpec @(TxBody BabbageEra) v "transaction_body" + huddleDecoderEquivalenceSpec @(TxAuxData BabbageEra) v "auxiliary_data" + huddleDecoderEquivalenceSpec @(Timelock BabbageEra) v "native_script" + huddleDecoderEquivalenceSpec @(Data BabbageEra) v "plutus_data" + huddleDecoderEquivalenceSpec @(Script BabbageEra) v "script" + huddleDecoderEquivalenceSpec @(TxWits BabbageEra) v "transaction_witness_set" + huddleDecoderEquivalenceSpec @(Redeemers BabbageEra) v "redeemers" + huddleDecoderEquivalenceSpec @(Tx BabbageEra) v "transaction" diff --git a/eras/babbage/impl/test/Test/Cardano/Ledger/Babbage/BinarySpec.hs b/eras/babbage/impl/test/Test/Cardano/Ledger/Babbage/BinarySpec.hs index fc9fd8ae0c0..1cccbe22a33 100644 --- a/eras/babbage/impl/test/Test/Cardano/Ledger/Babbage/BinarySpec.hs +++ b/eras/babbage/impl/test/Test/Cardano/Ledger/Babbage/BinarySpec.hs @@ -5,6 +5,7 @@ module Test.Cardano.Ledger.Babbage.BinarySpec (spec) where +import Cardano.Ledger.Alonzo.TxWits (Redeemers, TxDats) import Cardano.Ledger.Babbage import Data.Default (def) import Test.Cardano.Ledger.Alonzo.Binary.RoundTrip (roundTripAlonzoCommonSpec) @@ -12,6 +13,10 @@ import Test.Cardano.Ledger.Babbage.Arbitrary () import Test.Cardano.Ledger.Babbage.TreeDiff () import Test.Cardano.Ledger.Common import Test.Cardano.Ledger.Core.Binary (specUpgrade) +import Test.Cardano.Ledger.Core.Binary as Binary ( + decoderEquivalenceCoreEraTypesSpec, + decoderEquivalenceEraSpec, + ) import Test.Cardano.Ledger.Core.Binary.RoundTrip (RuleListEra (..)) spec :: Spec @@ -19,6 +24,10 @@ spec = do specUpgrade @BabbageEra def describe "RoundTrip" $ do roundTripAlonzoCommonSpec @BabbageEra + describe "DecCBOR instances equivalence" $ do + Binary.decoderEquivalenceCoreEraTypesSpec @BabbageEra + decoderEquivalenceEraSpec @BabbageEra @(TxDats BabbageEra) + decoderEquivalenceEraSpec @BabbageEra @(Redeemers BabbageEra) instance RuleListEra BabbageEra where type diff --git a/eras/babbage/test-suite/test/Test/Cardano/Ledger/Babbage/Serialisation/Tripping.hs b/eras/babbage/test-suite/test/Test/Cardano/Ledger/Babbage/Serialisation/Tripping.hs index 39bed6e58a2..bd0aeef15b3 100644 --- a/eras/babbage/test-suite/test/Test/Cardano/Ledger/Babbage/Serialisation/Tripping.hs +++ b/eras/babbage/test-suite/test/Test/Cardano/Ledger/Babbage/Serialisation/Tripping.hs @@ -27,8 +27,12 @@ tests = roundTripCborRangeExpectation @(BabbageUtxoPredFailure BabbageEra) (eraProtVerLow @BabbageEra) (eraProtVerHigh @BabbageEra) - , testProperty "babbage/Block" $ + , testProperty "babbage/Block (Annotator)" $ roundTripAnnRangeExpectation @(Block (BHeader StandardCrypto) BabbageEra) (eraProtVerLow @BabbageEra) (eraProtVerHigh @BabbageEra) + , testProperty "babbage/Block" $ + roundTripCborRangeExpectation @(Block (BHeader StandardCrypto) BabbageEra) + (eraProtVerLow @BabbageEra) + (eraProtVerHigh @BabbageEra) ] diff --git a/eras/conway/impl/CHANGELOG.md b/eras/conway/impl/CHANGELOG.md index b8cac3ef476..9231dcc6a18 100644 --- a/eras/conway/impl/CHANGELOG.md +++ b/eras/conway/impl/CHANGELOG.md @@ -2,6 +2,7 @@ ## 1.19.0.0 +* Add `DecCBOR` instance for `ConwayTxBody` * Converted `CertState` to a type family * Remove `ConwayMempoolPredFailure` and `ConwayMempoolEvent` * Switch to `MEMPOOL` rule to be the entry point for `ApplyTx` instead of `LEDGER` and invert their diff --git a/eras/conway/impl/cardano-ledger-conway.cabal b/eras/conway/impl/cardano-ledger-conway.cabal index d2f98fd09cf..51857d45c8f 100644 --- a/eras/conway/impl/cardano-ledger-conway.cabal +++ b/eras/conway/impl/cardano-ledger-conway.cabal @@ -265,7 +265,7 @@ test-suite tests cardano-ledger-alonzo, cardano-ledger-alonzo:testlib, cardano-ledger-babbage, - cardano-ledger-binary:testlib, + cardano-ledger-binary:{cardano-ledger-binary, testlib}, cardano-ledger-conway, cardano-ledger-core, cardano-ledger-core:testlib, diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/TxBody/Internal.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/TxBody/Internal.hs index ed543cc42df..bf612496c90 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/TxBody/Internal.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/TxBody/Internal.hs @@ -267,6 +267,14 @@ instance newtype ConwayTxBody era = TxBodyConstr (MemoBytes (ConwayTxBodyRaw era)) deriving (Generic, SafeToHash, ToCBOR) +deriving newtype instance + ( EraPParams era + , DecCBOR (TxOut era) + , ShelleyEraTxCert era + , TxCert era ~ ConwayTxCert era + ) => + DecCBOR (ConwayTxBody era) + deriving instance (EraPParams era, NoThunks (TxOut era)) => NoThunks (ConwayTxBody era) diff --git a/eras/conway/impl/test/Test/Cardano/Ledger/Conway/Binary/CddlSpec.hs b/eras/conway/impl/test/Test/Cardano/Ledger/Conway/Binary/CddlSpec.hs index cd3cca37b1a..b4e45ad2482 100644 --- a/eras/conway/impl/test/Test/Cardano/Ledger/Conway/Binary/CddlSpec.hs +++ b/eras/conway/impl/test/Test/Cardano/Ledger/Conway/Binary/CddlSpec.hs @@ -12,10 +12,12 @@ import Cardano.Ledger.Core import Cardano.Ledger.Plutus.Data (Data, Datum) import Test.Cardano.Ledger.Binary.Cddl ( beforeAllCddlFile, + cddlDecoderEquivalenceSpec, cddlRoundTripAnnCborSpec, cddlRoundTripCborSpec, ) import Test.Cardano.Ledger.Binary.Cuddle ( + huddleDecoderEquivalenceSpec, huddleRoundTripAnnCborSpec, huddleRoundTripCborSpec, specWithHuddle, @@ -32,37 +34,71 @@ spec = do cddlRoundTripCborSpec @(Value ConwayEra) v "positive_coin" cddlRoundTripCborSpec @(Value ConwayEra) v "value" cddlRoundTripAnnCborSpec @(TxBody ConwayEra) v "transaction_body" + cddlRoundTripCborSpec @(TxBody ConwayEra) v "transaction_body" cddlRoundTripAnnCborSpec @(TxAuxData ConwayEra) v "auxiliary_data" + cddlRoundTripCborSpec @(TxAuxData ConwayEra) v "auxiliary_data" cddlRoundTripAnnCborSpec @(Timelock ConwayEra) v "native_script" + cddlRoundTripCborSpec @(Timelock ConwayEra) v "native_script" cddlRoundTripAnnCborSpec @(Data ConwayEra) v "plutus_data" + cddlRoundTripCborSpec @(Data ConwayEra) v "plutus_data" cddlRoundTripCborSpec @(TxOut ConwayEra) v "transaction_output" cddlRoundTripAnnCborSpec @(Script ConwayEra) v "script" + cddlRoundTripCborSpec @(Script ConwayEra) v "script" cddlRoundTripCborSpec @(Datum ConwayEra) v "datum_option" cddlRoundTripAnnCborSpec @(TxWits ConwayEra) v "transaction_witness_set" + cddlRoundTripCborSpec @(TxWits ConwayEra) v "transaction_witness_set" cddlRoundTripCborSpec @(PParamsUpdate ConwayEra) v "protocol_param_update" cddlRoundTripCborSpec @CostModels v "cost_models" cddlRoundTripAnnCborSpec @(Redeemers ConwayEra) v "redeemers" + cddlRoundTripCborSpec @(Redeemers ConwayEra) v "redeemers" cddlRoundTripAnnCborSpec @(Tx ConwayEra) v "transaction" + cddlRoundTripCborSpec @(Tx ConwayEra) v "transaction" cddlRoundTripCborSpec @(VotingProcedure ConwayEra) v "voting_procedure" cddlRoundTripCborSpec @(ProposalProcedure ConwayEra) v "proposal_procedure" cddlRoundTripCborSpec @(GovAction ConwayEra) v "gov_action" cddlRoundTripCborSpec @(TxCert ConwayEra) v "certificate" + describe "DecCBOR instances equivalence via CDDL" $ do + cddlDecoderEquivalenceSpec @(TxBody ConwayEra) v "transaction_body" + cddlDecoderEquivalenceSpec @(TxAuxData ConwayEra) v "auxiliary_data" + cddlDecoderEquivalenceSpec @(Timelock ConwayEra) v "native_script" + cddlDecoderEquivalenceSpec @(Data ConwayEra) v "plutus_data" + cddlDecoderEquivalenceSpec @(Script ConwayEra) v "script" + cddlDecoderEquivalenceSpec @(TxWits ConwayEra) v "transaction_witness_set" + cddlDecoderEquivalenceSpec @(Redeemers ConwayEra) v "redeemers" + cddlDecoderEquivalenceSpec @(Tx ConwayEra) v "transaction" describe "Huddle" $ specWithHuddle conwayCDDL 100 $ do huddleRoundTripCborSpec @(Value ConwayEra) v "positive_coin" huddleRoundTripCborSpec @(Value ConwayEra) v "value" huddleRoundTripAnnCborSpec @(TxBody ConwayEra) v "transaction_body" + huddleRoundTripCborSpec @(TxBody ConwayEra) v "transaction_body" huddleRoundTripAnnCborSpec @(TxAuxData ConwayEra) v "auxiliary_data" + huddleRoundTripCborSpec @(TxAuxData ConwayEra) v "auxiliary_data" huddleRoundTripAnnCborSpec @(Timelock ConwayEra) v "native_script" + huddleRoundTripCborSpec @(Timelock ConwayEra) v "native_script" huddleRoundTripAnnCborSpec @(Data ConwayEra) v "plutus_data" + huddleRoundTripCborSpec @(Data ConwayEra) v "plutus_data" huddleRoundTripCborSpec @(TxOut ConwayEra) v "transaction_output" huddleRoundTripAnnCborSpec @(Script ConwayEra) v "script" + huddleRoundTripCborSpec @(Script ConwayEra) v "script" huddleRoundTripCborSpec @(Datum ConwayEra) v "datum_option" huddleRoundTripAnnCborSpec @(TxWits ConwayEra) v "transaction_witness_set" + huddleRoundTripCborSpec @(TxWits ConwayEra) v "transaction_witness_set" huddleRoundTripCborSpec @(PParamsUpdate ConwayEra) v "protocol_param_update" huddleRoundTripCborSpec @CostModels v "cost_models" huddleRoundTripAnnCborSpec @(Redeemers ConwayEra) v "redeemers" + huddleRoundTripCborSpec @(Redeemers ConwayEra) v "redeemers" huddleRoundTripAnnCborSpec @(Tx ConwayEra) v "transaction" + huddleRoundTripCborSpec @(Tx ConwayEra) v "transaction" huddleRoundTripCborSpec @(VotingProcedure ConwayEra) v "voting_procedure" huddleRoundTripCborSpec @(ProposalProcedure ConwayEra) v "proposal_procedure" huddleRoundTripCborSpec @(GovAction ConwayEra) v "gov_action" huddleRoundTripCborSpec @(TxCert ConwayEra) v "certificate" + describe "DecCBOR instances equivalence via CDDL" $ do + huddleDecoderEquivalenceSpec @(TxBody ConwayEra) v "transaction_body" + huddleDecoderEquivalenceSpec @(TxAuxData ConwayEra) v "auxiliary_data" + huddleDecoderEquivalenceSpec @(Timelock ConwayEra) v "native_script" + huddleDecoderEquivalenceSpec @(Data ConwayEra) v "plutus_data" + huddleDecoderEquivalenceSpec @(Script ConwayEra) v "script" + huddleDecoderEquivalenceSpec @(TxWits ConwayEra) v "transaction_witness_set" + huddleDecoderEquivalenceSpec @(Redeemers ConwayEra) v "redeemers" + huddleDecoderEquivalenceSpec @(Tx ConwayEra) v "transaction" diff --git a/eras/conway/impl/test/Test/Cardano/Ledger/Conway/BinarySpec.hs b/eras/conway/impl/test/Test/Cardano/Ledger/Conway/BinarySpec.hs index a0f4476e4a5..7358ca1f9d0 100644 --- a/eras/conway/impl/test/Test/Cardano/Ledger/Conway/BinarySpec.hs +++ b/eras/conway/impl/test/Test/Cardano/Ledger/Conway/BinarySpec.hs @@ -1,18 +1,28 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} module Test.Cardano.Ledger.Conway.BinarySpec (spec) where +import Cardano.Ledger.Alonzo.TxWits (Redeemers, TxDats) +import Cardano.Ledger.Binary import Cardano.Ledger.Conway import Cardano.Ledger.Conway.Genesis import Cardano.Ledger.Conway.Governance +import Cardano.Ledger.Core import Data.Default (def) +import Data.Proxy +import Data.Typeable (typeRep) +import Test.Cardano.Ledger.Binary (decoderEquivalenceExpectation) import Test.Cardano.Ledger.Binary.RoundTrip import Test.Cardano.Ledger.Common import Test.Cardano.Ledger.Conway.Arbitrary () import Test.Cardano.Ledger.Conway.Binary.RoundTrip (roundTripConwayCommonSpec) import Test.Cardano.Ledger.Conway.TreeDiff () import Test.Cardano.Ledger.Core.Binary (specUpgrade) +import Test.Cardano.Ledger.Core.Binary as Binary (decoderEquivalenceCoreEraTypesSpec) import Test.Cardano.Ledger.Core.Binary.RoundTrip (roundTripEraSpec) spec :: Spec @@ -29,3 +39,18 @@ spec = do roundTripConwayCommonSpec @ConwayEra -- ConwayGenesis only makes sense in Conway era roundTripEraSpec @ConwayEra @ConwayGenesis + describe "DecCBOR instances equivalence" $ do + Binary.decoderEquivalenceCoreEraTypesSpec @ConwayEra + decoderEquivalenceLenientSpec @(TxDats ConwayEra) + decoderEquivalenceLenientSpec @(Redeemers ConwayEra) + where + -- The expectation used in this spec allows for the deserialization to fail, in which case + -- it only checks that it fails for both decoders. + -- This is necessary because for some arbitrarily generated values, the deserialization fails + -- starting with Conway (for example: empty TxDats or Redeemers) + decoderEquivalenceLenientSpec :: + forall t. (Arbitrary t, Eq t, EncCBOR t, DecCBOR t, DecCBOR (Annotator t), Show t) => Spec + decoderEquivalenceLenientSpec = + prop (show (typeRep $ Proxy @t)) $ property $ \(x :: t) -> + forM_ [eraProtVerLow @ConwayEra .. eraProtVerHigh @ConwayEra] $ \v -> + decoderEquivalenceExpectation @t v (serialize v x) diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Binary/RoundTrip.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Binary/RoundTrip.hs index 83dc0a75c06..77695bd2a05 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Binary/RoundTrip.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Binary/RoundTrip.hs @@ -13,6 +13,7 @@ module Test.Cardano.Ledger.Conway.Binary.RoundTrip ( ) where import Cardano.Ledger.BaseTypes (StrictMaybe) +import Cardano.Ledger.Binary (DecCBOR) import Cardano.Ledger.Compactible import Cardano.Ledger.Conway (ConwayEra) import Cardano.Ledger.Conway.Governance @@ -45,6 +46,11 @@ roundTripConwayCommonSpec :: , RuleListEra era , EraCertState era , Arbitrary (CertState era) + , DecCBOR (Script era) + , DecCBOR (TxAuxData era) + , DecCBOR (TxWits era) + , DecCBOR (TxBody era) + , DecCBOR (Tx era) ) => Spec roundTripConwayCommonSpec = do diff --git a/eras/mary/impl/CHANGELOG.md b/eras/mary/impl/CHANGELOG.md index 51c4087b2cf..5960e3809c3 100644 --- a/eras/mary/impl/CHANGELOG.md +++ b/eras/mary/impl/CHANGELOG.md @@ -2,6 +2,7 @@ ## 1.8.0.0 +* Add `DecCBOR` instance for `MaryTxBody` * Converted `CertState` to a type family * Add `MemPack` instance for `CompactValue` and `CompactForm MaryValue` * Deprecate `Mary` type synonym diff --git a/eras/mary/impl/src/Cardano/Ledger/Mary/TxBody/Internal.hs b/eras/mary/impl/src/Cardano/Ledger/Mary/TxBody/Internal.hs index acfda9ab446..10280fe47c1 100644 --- a/eras/mary/impl/src/Cardano/Ledger/Mary/TxBody/Internal.hs +++ b/eras/mary/impl/src/Cardano/Ledger/Mary/TxBody/Internal.hs @@ -148,6 +148,8 @@ deriving via instance MaryEraTxBody era => DecCBOR (Annotator (MaryTxBody era)) +deriving newtype instance MaryEraTxBody era => DecCBOR (MaryTxBody era) + type instance MemoHashIndex (MaryTxBodyRaw era) = EraIndependentTxBody instance Era era => HashAnnotated (MaryTxBody era) EraIndependentTxBody where diff --git a/eras/mary/impl/test/Test/Cardano/Ledger/Mary/Binary/CddlSpec.hs b/eras/mary/impl/test/Test/Cardano/Ledger/Mary/Binary/CddlSpec.hs index 9a079b803da..83f2e9af325 100644 --- a/eras/mary/impl/test/Test/Cardano/Ledger/Mary/Binary/CddlSpec.hs +++ b/eras/mary/impl/test/Test/Cardano/Ledger/Mary/Binary/CddlSpec.hs @@ -7,6 +7,7 @@ import Cardano.Ledger.Core import Cardano.Ledger.Mary (MaryEra) import Test.Cardano.Ledger.Binary.Cddl ( beforeAllCddlFile, + cddlDecoderEquivalenceSpec, cddlRoundTripAnnCborSpec, cddlRoundTripCborSpec, ) @@ -22,10 +23,24 @@ spec = describe "Ruby-based" $ beforeAllCddlFile 3 readMaryCddlFiles $ do cddlRoundTripCborSpec @(Value MaryEra) v "value" cddlRoundTripAnnCborSpec @(TxBody MaryEra) v "transaction_body" + cddlRoundTripCborSpec @(TxBody MaryEra) v "transaction_body" cddlRoundTripAnnCborSpec @(Script MaryEra) v "native_script" + cddlRoundTripCborSpec @(Script MaryEra) v "native_script" cddlRoundTripAnnCborSpec @(TxAuxData MaryEra) v "auxiliary_data" + cddlRoundTripCborSpec @(TxAuxData MaryEra) v "auxiliary_data" + describe "DecCBOR instances equivalence via CDDL" $ do + cddlDecoderEquivalenceSpec @(TxBody MaryEra) v "transaction_body" + cddlDecoderEquivalenceSpec @(Script MaryEra) v "native_script" + cddlDecoderEquivalenceSpec @(TxAuxData MaryEra) v "auxiliary_data" describe "Huddle" $ specWithHuddle maryCDDL 100 $ do huddleRoundTripCborSpec @(Value MaryEra) v "value" huddleRoundTripAnnCborSpec @(TxBody MaryEra) v "transaction_body" + huddleRoundTripCborSpec @(TxBody MaryEra) v "transaction_body" huddleRoundTripAnnCborSpec @(TxAuxData MaryEra) v "auxiliary_data" + huddleRoundTripCborSpec @(TxAuxData MaryEra) v "auxiliary_data" huddleRoundTripAnnCborSpec @(Script MaryEra) v "native_script" + huddleRoundTripCborSpec @(Script MaryEra) v "native_script" + describe "DecCBOR instances equivalence via CDDL" $ do + huddleDecoderEquivalenceSpec @(TxBody MaryEra) v "transaction_body" + huddleDecoderEquivalenceSpec @(Script MaryEra) v "native_script" + huddleDecoderEquivalenceSpec @(TxAuxData MaryEra) v "auxiliary_data" diff --git a/eras/mary/impl/test/Test/Cardano/Ledger/Mary/BinarySpec.hs b/eras/mary/impl/test/Test/Cardano/Ledger/Mary/BinarySpec.hs index 88d62a076a3..45cbe31284a 100644 --- a/eras/mary/impl/test/Test/Cardano/Ledger/Mary/BinarySpec.hs +++ b/eras/mary/impl/test/Test/Cardano/Ledger/Mary/BinarySpec.hs @@ -9,6 +9,7 @@ import Cardano.Ledger.Mary import Data.Default (def) import Test.Cardano.Ledger.Common import Test.Cardano.Ledger.Core.Binary (specUpgrade) +import Test.Cardano.Ledger.Core.Binary as Binary (decoderEquivalenceCoreEraTypesSpec) import Test.Cardano.Ledger.Core.Binary.RoundTrip (RuleListEra (..)) import Test.Cardano.Ledger.Mary.Arbitrary () import Test.Cardano.Ledger.Mary.TreeDiff () @@ -19,6 +20,8 @@ spec = do specUpgrade @MaryEra def describe "RoundTrip" $ do roundTripShelleyCommonSpec @MaryEra + describe "DecCBOR instances equivalence" $ do + Binary.decoderEquivalenceCoreEraTypesSpec @MaryEra instance RuleListEra MaryEra where type diff --git a/eras/shelley-ma/test-suite/test/Test/Cardano/Ledger/Allegra/Translation.hs b/eras/shelley-ma/test-suite/test/Test/Cardano/Ledger/Allegra/Translation.hs index b47eac16312..92380a12d4f 100644 --- a/eras/shelley-ma/test-suite/test/Test/Cardano/Ledger/Allegra/Translation.hs +++ b/eras/shelley-ma/test-suite/test/Test/Cardano/Ledger/Allegra/Translation.hs @@ -28,12 +28,20 @@ allegraEncodeDecodeTests = testGroup "encoded shelley types can be decoded as allegra types" [ testProperty - "decoding auxiliary data" + "decoding auxiliary data (Annotator)" ( embedTripAnnExpectation @(TxAuxData ShelleyEra) @(TxAuxData AllegraEra) (eraProtVerLow @ShelleyEra) (eraProtVerLow @AllegraEra) (\_ _ -> pure ()) ) + , testProperty + "decoding auxiliary data" + ( embedTripExpectation @(TxAuxData ShelleyEra) @(TxAuxData AllegraEra) + (eraProtVerLow @ShelleyEra) + (eraProtVerLow @AllegraEra) + cborTrip + (\_ _ -> pure ()) + ) ] allegraTranslationTests :: TestTree diff --git a/eras/shelley-ma/test-suite/test/Test/Cardano/Ledger/Mary/Translation.hs b/eras/shelley-ma/test-suite/test/Test/Cardano/Ledger/Mary/Translation.hs index 480b17efdd8..e64203c988b 100644 --- a/eras/shelley-ma/test-suite/test/Test/Cardano/Ledger/Mary/Translation.hs +++ b/eras/shelley-ma/test-suite/test/Test/Cardano/Ledger/Mary/Translation.hs @@ -33,12 +33,20 @@ maryEncodeDecodeTests = testGroup "encoded allegra types can be decoded as mary types" [ testProperty - "decoding metadata" + "decoding metadata (Annotator)" ( embedTripAnnExpectation @(TxAuxData AllegraEra) @(TxAuxData MaryEra) (eraProtVerLow @AllegraEra) (eraProtVerLow @MaryEra) (\_ _ -> pure ()) ) + , testProperty + "decoding metadata" + ( embedTripExpectation @(TxAuxData AllegraEra) @(TxAuxData MaryEra) + (eraProtVerLow @AllegraEra) + (eraProtVerLow @MaryEra) + cborTrip + (\_ _ -> pure ()) + ) ] maryTranslationTests :: TestTree diff --git a/eras/shelley-ma/test-suite/test/Test/Cardano/Ledger/ShelleyMA/Serialisation/Golden/Encoding.hs b/eras/shelley-ma/test-suite/test/Test/Cardano/Ledger/ShelleyMA/Serialisation/Golden/Encoding.hs index 1aa4ae1c8b6..cb73846a6a3 100644 --- a/eras/shelley-ma/test-suite/test/Test/Cardano/Ledger/ShelleyMA/Serialisation/Golden/Encoding.hs +++ b/eras/shelley-ma/test-suite/test/Test/Cardano/Ledger/ShelleyMA/Serialisation/Golden/Encoding.hs @@ -22,7 +22,7 @@ import Cardano.Ledger.Allegra.Scripts ( import Cardano.Ledger.Allegra.TxAuxData (pattern AllegraTxAuxData) import Cardano.Ledger.Allegra.TxBody (AllegraTxBody (..)) import Cardano.Ledger.BaseTypes (Network (..), StrictMaybe (..)) -import Cardano.Ledger.Binary (ToCBOR) +import Cardano.Ledger.Binary (DecCBOR, ToCBOR) import Cardano.Ledger.Coin (Coin (..)) import Cardano.Ledger.Credential (Credential (..), StakeReference (..)) import Cardano.Ledger.Mary (MaryEra) @@ -124,7 +124,13 @@ testUpdate = -- == Golden Tests Common to Allegra and Mary == -- ============================================= -scriptGoldenTest :: forall era. (AllegraEraScript era, ToCBOR (NativeScript era)) => TestTree +scriptGoldenTest :: + forall era. + ( AllegraEraScript era + , ToCBOR (NativeScript era) + , DecCBOR (NativeScript era) + ) => + TestTree scriptGoldenTest = let kh0 = hashKey . snd . mkGenKey $ RawSeed 0 0 0 0 0 :: KeyHash 'Witness kh1 = hashKey . snd . mkGenKey $ RawSeed 1 1 1 1 1 :: KeyHash 'Witness diff --git a/eras/shelley-ma/test-suite/test/Test/Cardano/Ledger/ShelleyMA/Serialisation/Timelocks.hs b/eras/shelley-ma/test-suite/test/Test/Cardano/Ledger/ShelleyMA/Serialisation/Timelocks.hs index 633c46e9162..c2e785bbce3 100644 --- a/eras/shelley-ma/test-suite/test/Test/Cardano/Ledger/ShelleyMA/Serialisation/Timelocks.hs +++ b/eras/shelley-ma/test-suite/test/Test/Cardano/Ledger/ShelleyMA/Serialisation/Timelocks.hs @@ -20,6 +20,7 @@ import Cardano.Ledger.Allegra.Scripts ( pattern RequireTimeExpire, pattern RequireTimeStart, ) +import Cardano.Ledger.Binary (natVersion) import Cardano.Ledger.Core import Cardano.Ledger.Mary (MaryEra) import Cardano.Ledger.Shelley (ShelleyEra) @@ -29,7 +30,13 @@ import Cardano.Ledger.Shelley.Scripts ( ) import Cardano.Slotting.Slot (SlotNo (..)) import Data.Sequence.Strict (fromList) -import Test.Cardano.Ledger.Binary.RoundTrip (embedTripAnnExpectation, roundTripAnnExpectation) +import Test.Cardano.Ledger.Binary.RoundTrip ( + cborTrip, + embedTripAnnExpectation, + embedTripExpectation, + roundTripAnnExpectation, + roundTripCborRangeExpectation, + ) import Test.Cardano.Ledger.Binary.TreeDiff (HexBytes (HexBytes), expectExprEqual) import Test.Cardano.Ledger.Mary.Arbitrary () import Test.Cardano.Ledger.Shelley.Serialisation.Generators () @@ -55,15 +62,29 @@ timelockTests :: TestTree timelockTests = testGroup "Timelock tests" - $ ( testCase "Timelock examples roundtrip - Allegra" . roundTripAnnExpectation + $ ( testCase "Timelock examples roundtrip - Allegra (Annotator)" . roundTripAnnExpectation <$> [s1 @AllegraEra, s2 @AllegraEra, s3 @AllegraEra] ) - ++ ( testCase "Timelock examples roundtrip - Mary" . roundTripAnnExpectation + ++ ( testCase "Timelock examples roundtrip - Allegra" + . roundTripCborRangeExpectation (natVersion @2) maxBound + <$> [s1 @AllegraEra, s2 @AllegraEra, s3 @AllegraEra] + ) + ++ ( testCase "Timelock examples roundtrip - Mary (Annotator)" . roundTripAnnExpectation <$> [s1 @MaryEra, s2 @MaryEra, s3 @MaryEra] ) - ++ [ testProperty "roundtripTimelock prop - Allegra" $ roundTripAnnExpectation @(Timelock AllegraEra) - , testProperty "roundtripTimelock prop - Mary" $ roundTripAnnExpectation @(Timelock MaryEra) - , testProperty "MultiSig deserialises as Timelock" $ + ++ ( testCase "Timelock examples roundtrip - Mary" + . roundTripCborRangeExpectation (natVersion @2) maxBound + <$> [s1 @MaryEra, s2 @MaryEra, s3 @MaryEra] + ) + ++ [ testProperty "roundtripTimelock prop - Allegra (Annotator)" $ + roundTripAnnExpectation @(Timelock AllegraEra) + , testProperty "roundtripTimelock prop - Allegra" $ + roundTripCborRangeExpectation @(Timelock AllegraEra) (natVersion @2) maxBound + , testProperty "roundtripTimelock prop - Mary (Annotator)" $ + roundTripAnnExpectation @(Timelock MaryEra) + , testProperty "roundtripTimelock prop - Mary" $ + roundTripCborRangeExpectation @(Timelock MaryEra) (natVersion @2) maxBound + , testProperty "MultiSig deserialises as Timelock (Annotator)" $ embedTripAnnExpectation @(MultiSig ShelleyEra) @(Timelock AllegraEra) (eraProtVerHigh @ShelleyEra) @@ -71,4 +92,13 @@ timelockTests = ( \timelock multiSig -> expectExprEqual (HexBytes (originalBytes timelock)) (HexBytes (originalBytes multiSig)) ) + , testProperty "MultiSig deserialises as Timelock" $ + embedTripExpectation @(MultiSig ShelleyEra) + @(Timelock AllegraEra) + (eraProtVerHigh @ShelleyEra) + (eraProtVerLow @AllegraEra) + cborTrip + ( \timelock multiSig -> + expectExprEqual (HexBytes (originalBytes timelock)) (HexBytes (originalBytes multiSig)) + ) ] diff --git a/eras/shelley/impl/CHANGELOG.md b/eras/shelley/impl/CHANGELOG.md index afbf6042ca4..328ef2252a5 100644 --- a/eras/shelley/impl/CHANGELOG.md +++ b/eras/shelley/impl/CHANGELOG.md @@ -2,6 +2,15 @@ ## 1.16.0.0 +* Add `DecCBOR` instances for: + * `ShelleyTxWits` + * `ShelleyTxAuxData` + * `ShelleyTxBody` + * `ShelleyTx` + * `ShelleyTxSeq` +* Add `indexLookupSeq` +* Add `segWitTx` +* Rename `segwitTx` to `segWitAnnTx` * Converted `CertState` to a type family * Restrict the monad of `applyTx` and `reapllyTx` to `Either` from abstract `MonadError` * Remove `applyTxOpts` in favor of new `applyTxValidation` function in `ApplyTx` diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/BlockChain.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/BlockChain.hs index 499b8e9db19..ab30b8f05e7 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/BlockChain.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/BlockChain.hs @@ -19,6 +19,7 @@ module Cardano.Ledger.Shelley.BlockChain ( ShelleyTxSeq (ShelleyTxSeq, txSeqTxns', TxSeq'), constructMetadata, + indexLookupSeq, txSeqTxns, bbHash, bBodySize, @@ -39,11 +40,13 @@ import Cardano.Ledger.BaseTypes ( strictMaybeToMaybe, ) import Cardano.Ledger.Binary ( + Annotated (..), Annotator (..), DecCBOR (decCBOR), Decoder, EncCBOR (..), EncCBORGroup (..), + decodeAnnotated, encodeFoldableEncoder, encodeFoldableMapEncoder, encodePreEncoded, @@ -52,7 +55,7 @@ import Cardano.Ledger.Binary ( ) import Cardano.Ledger.Core import Cardano.Ledger.Shelley.Era (ShelleyEra) -import Cardano.Ledger.Shelley.Tx (ShelleyTx, segwitTx) +import Cardano.Ledger.Shelley.Tx (ShelleyTx, segWitAnnTx, segWitTx) import Cardano.Ledger.Slot (SlotNo (..)) import Control.Monad (unless) import Data.ByteString (ByteString) @@ -60,6 +63,7 @@ import qualified Data.ByteString.Lazy as BSL import Data.Coerce (coerce) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map +import Data.Monoid (All (..)) import Data.Sequence (Seq) import qualified Data.Sequence as Seq import Data.Sequence.Strict (StrictSeq) @@ -188,14 +192,16 @@ bbHash (TxSeq' _ bodies wits md) = hashPart = Hash.hashToBytes . hashStrict . BSL.toStrict -- | Given a size and a mapping from indices to maybe metadata, --- return a sequence whose size is the size paramater and +-- return a sequence whose size is the size parameter and -- whose non-Nothing values correspond to the values in the mapping. constructMetadata :: - forall era. Int -> Map Int (Annotator (TxAuxData era)) -> Seq (Maybe (Annotator (TxAuxData era))) -constructMetadata n md = fmap (`Map.lookup` md) (Seq.fromList [0 .. n - 1]) +constructMetadata = indexLookupSeq + +indexLookupSeq :: Int -> Map Int a -> Seq (Maybe a) +indexLookupSeq n md = fmap (`Map.lookup` md) (Seq.fromList [0 .. n - 1]) -- | The parts of the Tx in Blocks that have to have DecCBOR(Annotator x) instances. -- These are exactly the parts that are SafeToHash. @@ -233,12 +239,45 @@ txSeqDecoder lax = do let txns = sequenceA $ StrictSeq.forceToStrict $ - Seq.zipWith3 segwitTx bodies wits metadata + Seq.zipWith3 segWitAnnTx bodies wits metadata pure $ TxSeq' <$> txns <*> bodiesAnn <*> witsAnn <*> metadataAnn instance EraTx era => DecCBOR (Annotator (ShelleyTxSeq era)) where decCBOR = txSeqDecoder False +instance + ( EraTx era + , DecCBOR (TxBody era) + , DecCBOR (TxWits era) + , DecCBOR (TxAuxData era) + ) => + DecCBOR (ShelleyTxSeq era) + where + decCBOR = do + Annotated bodies bodiesBytes <- decodeAnnotated decCBOR + Annotated wits witsBytes <- decodeAnnotated decCBOR + Annotated auxDataMap auxDataBytes <- decodeAnnotated decCBOR + let bodiesLength = length bodies + let inRange x = (0 <= x) && (x <= (bodiesLength - 1)) + unless + (getAll (Map.foldMapWithKey (\k _ -> All (inRange k)) auxDataMap)) + (fail ("Some Auxiliarydata index is not in the range: 0 .. " ++ show (bodiesLength - 1))) + let auxData = indexLookupSeq bodiesLength auxDataMap + let witsLength = length wits + unless + (bodiesLength == witsLength) + ( fail $ + "different number of transaction bodies (" + <> show bodiesLength + <> ") and witness sets (" + <> show witsLength + <> ")" + ) + let txs = + StrictSeq.forceToStrict $ + Seq.zipWith3 segWitTx bodies wits auxData + pure $ TxSeq' txs bodiesBytes witsBytes auxDataBytes + slotToNonce :: SlotNo -> Nonce slotToNonce (SlotNo s) = mkNonceFromNumber s diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Scripts.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Scripts.hs index e228cf9fcff..32ddd364f6e 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Scripts.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Scripts.hs @@ -34,15 +34,18 @@ module Cardano.Ledger.Shelley.Scripts ( ) where -import Cardano.Ledger.BaseTypes (invalidKey) import Cardano.Ledger.Binary ( Annotator (..), DecCBOR (decCBOR), EncCBOR (..), ToCBOR, decodeRecordSum, + invalidKey, + ) +import Cardano.Ledger.Binary.Coders ( + Encode (Sum, To), + (!>), ) -import Cardano.Ledger.Binary.Coders (Encode (..), (!>)) import Cardano.Ledger.Core import Cardano.Ledger.Keys.WitVKey (witVKeyHash) import Cardano.Ledger.MemoBytes ( @@ -50,6 +53,7 @@ import Cardano.Ledger.MemoBytes ( Mem, MemoBytes, Memoized (..), + decodeMemoized, getMemoRawType, memoBytesEra, pattern Memo, @@ -188,6 +192,18 @@ pattern RequireMOf n ms <- (getRequireMOf -> Just (n, ms)) -- | Encodes memoized bytes created upon construction. instance Era era => EncCBOR (MultiSig era) +instance Era era => DecCBOR (MultiSig era) where + decCBOR = MultiSigConstr <$> decodeMemoized decCBOR + +instance Era era => DecCBOR (MultiSigRaw era) where + decCBOR = decodeRecordSum "MultiSig" $ do + \case + 0 -> (,) 2 . RequireSignature' . KeyHash <$> decCBOR + 1 -> (,) 2 . RequireAllOf' <$> decCBOR + 2 -> (,) 2 . RequireAnyOf' <$> decCBOR + 3 -> (,) 3 <$> (RequireMOf' <$> decCBOR <*> decCBOR) + k -> invalidKey k + instance Era era => DecCBOR (Annotator (MultiSigRaw era)) where decCBOR = decodeRecordSum "MultiSig" $ \case diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx.hs index cbd8cef60ac..37d5514969f 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx.hs @@ -12,7 +12,8 @@ module Cardano.Ledger.Shelley.Tx ( auxDataShelleyTxL, sizeShelleyTxF, wireSizeShelleyTxF, - segwitTx, + segWitAnnTx, + segWitTx, mkBasicShelleyTx, shelleyMinFeeTx, witsFromTxWitnesses, diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx/Internal.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx/Internal.hs index 980b758f467..f0967c0fa30 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx/Internal.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx/Internal.hs @@ -39,7 +39,8 @@ module Cardano.Ledger.Shelley.Tx.Internal ( auxDataShelleyTxL, sizeShelleyTxF, wireSizeShelleyTxF, - segwitTx, + segWitAnnTx, + segWitTx, mkBasicShelleyTx, shelleyMinFeeTx, witsFromTxWitnesses, @@ -53,6 +54,7 @@ import Cardano.Ledger.Binary ( EncCBOR (encCBOR), ToCBOR, decodeNullMaybe, + decodeNullStrictMaybe, encodeNullMaybe, runAnnotator, ) @@ -322,12 +324,34 @@ instance ( sequence . maybeToStrictMaybe <$> decodeNullMaybe decCBOR ) +instance + ( Era era + , DecCBOR (TxBody era) + , DecCBOR (TxWits era) + , DecCBOR (TxAuxData era) + ) => + DecCBOR (ShelleyTxRaw era) + where + decCBOR = + decode $ + RecD ShelleyTxRaw + DecCBOR (Annotator (ShelleyTx era)) +deriving newtype instance + ( Era era + , DecCBOR (TxBody era) + , DecCBOR (TxWits era) + , DecCBOR (TxAuxData era) + ) => + DecCBOR (ShelleyTx era) + -- | Construct a Tx containing the explicit serialised bytes. -- -- This function is marked as unsafe since it makes no guarantee that the @@ -348,33 +372,54 @@ unsafeConstructTxWithBytes b w a bytes = TxConstr (mkMemoBytes (ShelleyTxRaw b w -- Segregated witness -------------------------------------------------------------------------------- -segwitTx :: +segWitAnnTx :: forall era. EraTx era => Annotator (TxBody era) -> Annotator (TxWits era) -> Maybe (Annotator (TxAuxData era)) -> Annotator (ShelleyTx era) -segwitTx - bodyAnn - witsAnn - metaAnn = Annotator $ \bytes -> - let body' = runAnnotator bodyAnn bytes - witnessSet = runAnnotator witsAnn bytes - metadata = flip runAnnotator bytes <$> metaAnn - wrappedMetadataBytes = case metadata of - Nothing -> Plain.serialize Plain.encodeNull - Just b -> Plain.serialize b - fullBytes = - Plain.serialize (Plain.encodeListLen 3) - <> Plain.serialize body' - <> Plain.serialize witnessSet - <> wrappedMetadataBytes - in unsafeConstructTxWithBytes - body' - witnessSet - (maybeToStrictMaybe metadata) - fullBytes +segWitAnnTx bodyAnn witsAnn metaAnn = Annotator $ \bytes -> + let body' = runAnnotator bodyAnn bytes + witnessSet = runAnnotator witsAnn bytes + metadata = flip runAnnotator bytes <$> metaAnn + wrappedMetadataBytes = case metadata of + Nothing -> Plain.serialize Plain.encodeNull + Just b -> Plain.serialize b + fullBytes = + Plain.serialize (Plain.encodeListLen 3) + <> Plain.serialize body' + <> Plain.serialize witnessSet + <> wrappedMetadataBytes + in unsafeConstructTxWithBytes + body' + witnessSet + (maybeToStrictMaybe metadata) + fullBytes + +segWitTx :: + forall era. + EraTx era => + TxBody era -> + TxWits era -> + Maybe (TxAuxData era) -> + ShelleyTx era +segWitTx body' witnessSet metadata = + let + wrappedMetadataBytes = case metadata of + Nothing -> Plain.serialize Plain.encodeNull + Just b -> Plain.serialize b + fullBytes = + Plain.serialize (Plain.encodeListLen 3) + <> Plain.serialize body' + <> Plain.serialize witnessSet + <> wrappedMetadataBytes + in + unsafeConstructTxWithBytes + body' + witnessSet + (maybeToStrictMaybe metadata) + fullBytes -- ======================================== diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxAuxData.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxAuxData.hs index ac37102c896..cd38f651940 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxAuxData.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxAuxData.hs @@ -82,7 +82,7 @@ deriving via newtype ShelleyTxAuxData era = AuxiliaryDataConstr (MemoBytes (ShelleyTxAuxDataRaw era)) deriving (Eq, Show, Generic) - deriving newtype (NFData, Plain.ToCBOR, SafeToHash) + deriving newtype (NFData, Plain.ToCBOR, SafeToHash, DecCBOR) instance Memoized (ShelleyTxAuxData era) where type RawType (ShelleyTxAuxData era) = ShelleyTxAuxDataRaw era diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxBody.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxBody.hs index bed981ead62..24896a930c8 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxBody.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxBody.hs @@ -310,6 +310,14 @@ deriving via instance EraTxBody era => DecCBOR (Annotator (ShelleyTxBody era)) +deriving newtype instance + ( Era era + , DecCBOR (PParamsUpdate era) + , DecCBOR (TxOut era) + , DecCBOR (TxCert era) + ) => + DecCBOR (ShelleyTxBody era) + -- | Pattern for use by external users pattern ShelleyTxBody :: forall era. diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxWits.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxWits.hs index 2d2e2940561..633d7e3a6f6 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxWits.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxWits.hs @@ -62,6 +62,7 @@ import Cardano.Ledger.MemoBytes ( Mem, MemoBytes, Memoized (..), + decodeMemoized, getMemoRawType, lensMemoRawType, mkMemoizedEra, @@ -124,6 +125,9 @@ instance instance EraScript era => NoThunks (ShelleyTxWits era) +instance (EraScript era, DecCBOR (Script era)) => DecCBOR (ShelleyTxWits era) where + decCBOR = ShelleyTxWitsConstr <$> decodeMemoized decCBOR + -- ======================================================= -- Accessors -- ======================================================= @@ -224,11 +228,38 @@ deriving via instance EraScript era => DecCBOR (Annotator (ShelleyTxWits era)) +instance forall era. (EraScript era, DecCBOR (Script era)) => DecCBOR (ShelleyTxWitsRaw era) where + decCBOR = + decode $ + SparseKeyed + "ShelleyTxWits" + (ShelleyTxWitsRaw mempty mempty mempty) + witField + [] + where + witField :: Word -> Field (ShelleyTxWitsRaw era) + witField 0 = + field + (\x wits -> wits {addrWits' = x}) + (D $ withIgnoreSigOrd <$> decodeList decCBOR) + witField 1 = + field + (\x wits -> wits {scriptWits' = x}) + (D $ Map.fromElems (hashScript @era) <$> decodeList decCBOR) + witField 2 = + field + (\x wits -> wits {bootWits' = x}) + (D $ Set.fromList <$> decodeList decCBOR) + witField n = field (\_ wits -> wits) (Invalid n) + -- | This type is only used to preserve the old buggy behavior where signature -- was ignored in the `Ord` instance for `WitVKey`s. newtype IgnoreSigOrd kr = IgnoreSigOrd {unIgnoreSigOrd :: WitVKey kr} deriving (Eq) +withIgnoreSigOrd :: Typeable kr => [WitVKey kr] -> Set (WitVKey kr) +withIgnoreSigOrd = Set.map unIgnoreSigOrd . Set.fromList . fmap IgnoreSigOrd + instance Typeable kr => Ord (IgnoreSigOrd kr) where compare (IgnoreSigOrd w1) (IgnoreSigOrd w2) = compare (witVKeyHash w1) (witVKeyHash w2) @@ -252,7 +283,7 @@ decodeWits = ( D $ mapTraverseableDecoderA (decodeList decCBOR) - (Set.map unIgnoreSigOrd . Set.fromList . fmap IgnoreSigOrd) + withIgnoreSigOrd ) witField 1 = fieldAA diff --git a/eras/shelley/impl/test/Test/Cardano/Ledger/Shelley/Binary/CddlSpec.hs b/eras/shelley/impl/test/Test/Cardano/Ledger/Shelley/Binary/CddlSpec.hs index dcffdf6d7b0..e8488b567d0 100644 --- a/eras/shelley/impl/test/Test/Cardano/Ledger/Shelley/Binary/CddlSpec.hs +++ b/eras/shelley/impl/test/Test/Cardano/Ledger/Shelley/Binary/CddlSpec.hs @@ -19,10 +19,12 @@ import Cardano.Ledger.Shelley.API ( import Cardano.Ledger.TxIn (TxIn) import Test.Cardano.Ledger.Binary.Cddl ( beforeAllCddlFile, + cddlDecoderEquivalenceSpec, cddlRoundTripAnnCborSpec, cddlRoundTripCborSpec, ) import Test.Cardano.Ledger.Binary.Cuddle ( + huddleDecoderEquivalenceSpec, huddleRoundTripAnnCborSpec, huddleRoundTripCborSpec, specWithHuddle, @@ -37,34 +39,58 @@ spec = let v = eraProtVerLow @ShelleyEra describe "Ruby-based" $ beforeAllCddlFile 3 readShelleyCddlFiles $ do cddlRoundTripAnnCborSpec @BootstrapWitness v "bootstrap_witness" + cddlRoundTripCborSpec @BootstrapWitness v "bootstrap_witness" cddlRoundTripCborSpec @Addr v "address" cddlRoundTripCborSpec @RewardAccount v "reward_account" cddlRoundTripCborSpec @(Credential 'Staking) v "stake_credential" cddlRoundTripAnnCborSpec @(TxBody ShelleyEra) v "transaction_body" + cddlRoundTripCborSpec @(TxBody ShelleyEra) v "transaction_body" cddlRoundTripCborSpec @(TxOut ShelleyEra) v "transaction_output" cddlRoundTripCborSpec @StakePoolRelay v "relay" cddlRoundTripCborSpec @(TxCert ShelleyEra) v "certificate" cddlRoundTripCborSpec @TxIn v "transaction_input" cddlRoundTripAnnCborSpec @(TxAuxData ShelleyEra) v "transaction_metadata" + cddlRoundTripCborSpec @(TxAuxData ShelleyEra) v "transaction_metadata" cddlRoundTripAnnCborSpec @(MultiSig ShelleyEra) v "multisig_script" + cddlRoundTripCborSpec @(MultiSig ShelleyEra) v "multisig_script" cddlRoundTripCborSpec @(Update ShelleyEra) v "update" cddlRoundTripCborSpec @(ProposedPPUpdates ShelleyEra) v "proposed_protocol_parameter_updates" cddlRoundTripCborSpec @(PParamsUpdate ShelleyEra) v "protocol_param_update" cddlRoundTripAnnCborSpec @(Tx ShelleyEra) v "transaction" + cddlRoundTripCborSpec @(Tx ShelleyEra) v "transaction" + describe "DecCBOR instances equivalence via CDDL" $ do + cddlDecoderEquivalenceSpec @BootstrapWitness v "bootstrap_witness" + cddlDecoderEquivalenceSpec @(TxBody ShelleyEra) v "transaction_body" + cddlDecoderEquivalenceSpec @(TxAuxData ShelleyEra) v "transaction_metadata" + cddlDecoderEquivalenceSpec @(MultiSig ShelleyEra) v "multisig_script" + cddlDecoderEquivalenceSpec @(Tx ShelleyEra) v "transaction" + describe "Huddle" $ specWithHuddle shelleyCDDL 100 $ do huddleRoundTripCborSpec @Addr v "address" huddleRoundTripAnnCborSpec @BootstrapWitness v "bootstrap_witness" + huddleRoundTripCborSpec @BootstrapWitness v "bootstrap_witness" huddleRoundTripCborSpec @RewardAccount v "reward_account" huddleRoundTripCborSpec @(Credential 'Staking) v "stake_credential" huddleRoundTripAnnCborSpec @(TxBody ShelleyEra) v "transaction_body" + huddleRoundTripCborSpec @(TxBody ShelleyEra) v "transaction_body" huddleRoundTripCborSpec @(TxOut ShelleyEra) v "transaction_output" huddleRoundTripCborSpec @StakePoolRelay v "relay" huddleRoundTripCborSpec @(TxCert ShelleyEra) v "certificate" huddleRoundTripCborSpec @TxIn v "transaction_input" huddleRoundTripAnnCborSpec @(TxAuxData ShelleyEra) v "transaction_metadata" + huddleRoundTripCborSpec @(TxAuxData ShelleyEra) v "transaction_metadata" huddleRoundTripAnnCborSpec @(MultiSig ShelleyEra) v "multisig_script" + huddleRoundTripCborSpec @(MultiSig ShelleyEra) v "multisig_script" huddleRoundTripCborSpec @(Update ShelleyEra) v "update" huddleRoundTripCborSpec @(ProposedPPUpdates ShelleyEra) v "proposed_protocol_parameter_updates" huddleRoundTripCborSpec @(PParamsUpdate ShelleyEra) v "protocol_param_update" huddleRoundTripAnnCborSpec @(Tx ShelleyEra) v "transaction" + huddleRoundTripCborSpec @(Tx ShelleyEra) v "transaction" huddleRoundTripAnnCborSpec @(TxWits ShelleyEra) v "transaction_witness_set" + huddleRoundTripCborSpec @(TxWits ShelleyEra) v "transaction_witness_set" + describe "DecCBOR instances equivalence via CDDL" $ do + huddleDecoderEquivalenceSpec @BootstrapWitness v "bootstrap_witness" + huddleDecoderEquivalenceSpec @(TxBody ShelleyEra) v "transaction_body" + huddleDecoderEquivalenceSpec @(TxAuxData ShelleyEra) v "transaction_metadata" + huddleDecoderEquivalenceSpec @(MultiSig ShelleyEra) v "multisig_script" + huddleDecoderEquivalenceSpec @(Tx ShelleyEra) v "transaction" diff --git a/eras/shelley/impl/test/Test/Cardano/Ledger/Shelley/BinarySpec.hs b/eras/shelley/impl/test/Test/Cardano/Ledger/Shelley/BinarySpec.hs index c976de634a1..7c0b24c9a1a 100644 --- a/eras/shelley/impl/test/Test/Cardano/Ledger/Shelley/BinarySpec.hs +++ b/eras/shelley/impl/test/Test/Cardano/Ledger/Shelley/BinarySpec.hs @@ -1,6 +1,10 @@ +{-# LANGUAGE TypeApplications #-} + module Test.Cardano.Ledger.Shelley.BinarySpec (spec) where +import Cardano.Ledger.Shelley (ShelleyEra) import Test.Cardano.Ledger.Common +import Test.Cardano.Ledger.Core.Binary as Binary (decoderEquivalenceCoreEraTypesSpec) import qualified Test.Cardano.Ledger.Shelley.Binary.GoldenSpec as Golden import qualified Test.Cardano.Ledger.Shelley.Binary.RoundTripSpec as RoundTrip @@ -8,3 +12,4 @@ spec :: Spec spec = do Golden.spec RoundTrip.spec + Binary.decoderEquivalenceCoreEraTypesSpec @ShelleyEra diff --git a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Binary/RoundTrip.hs b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Binary/RoundTrip.hs index 6ac8345eb0f..5c0a63142e0 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Binary/RoundTrip.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Binary/RoundTrip.hs @@ -46,6 +46,11 @@ roundTripShelleyCommonSpec :: , RuleListEra era , EraCertState era , Arbitrary (CertState era) + , DecCBOR (Script era) + , DecCBOR (TxAuxData era) + , DecCBOR (TxWits era) + , DecCBOR (TxBody era) + , DecCBOR (Tx era) ) => Spec roundTripShelleyCommonSpec = do diff --git a/eras/shelley/test-suite/CHANGELOG.md b/eras/shelley/test-suite/CHANGELOG.md index 24117be6e2a..195b3e789b0 100644 --- a/eras/shelley/test-suite/CHANGELOG.md +++ b/eras/shelley/test-suite/CHANGELOG.md @@ -2,6 +2,7 @@ ## 1.6.0.0 +* Add `DecCBOR` instance for `LaxBlock` * Add `genCoreNodeKeys` and `genIssuerKeys` * Move `VRFNatVal` into `cardano-protocol-tpraos:testlib` * Account for removal of crypto parametrization diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/LaxBlock.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/LaxBlock.hs index db07bfb0340..744e9707983 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/LaxBlock.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/LaxBlock.hs @@ -30,6 +30,13 @@ import Data.Typeable (Typeable) newtype LaxBlock h era = LaxBlock (Block h era) deriving (ToCBOR) +deriving newtype instance + ( EraSegWits era + , DecCBOR (TxSeq era) + , DecCBOR h + ) => + DecCBOR (LaxBlock h era) + blockDecoder :: ( EraTx era , TxSeq era ~ ShelleyTxSeq era diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Serialisation/GoldenUtils.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Serialisation/GoldenUtils.hs index 14e7b808b3e..5ecc949f722 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Serialisation/GoldenUtils.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Serialisation/GoldenUtils.hs @@ -42,7 +42,7 @@ import Data.String (fromString) import GHC.Stack import qualified Prettyprinter as Pretty import Test.Cardano.Ledger.Binary.TreeDiff (ansiDocToString, diffExpr) -import Test.Tasty (TestTree) +import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (Assertion, assertFailure, testCase, (@?=)) expectDecodingSuccess :: (HasCallStack, Show a, Eq a) => (a -> Either DecoderError a) -> a -> IO () @@ -139,17 +139,21 @@ checkEncodingCBOR v name x t = in checkEncodingWithRoundtrip v encCBOR d roundTripSuccess name x t checkEncodingCBORAnnotated :: - (HasCallStack, DecCBOR (Annotator a), ToCBOR a, Show a, Eq a) => + (HasCallStack, DecCBOR (Annotator a), DecCBOR a, ToCBOR a, Show a, Eq a) => Version -> String -> a -> ToTokens -> TestTree checkEncodingCBORAnnotated v name x t = - let d = decodeFullAnnotator v (fromString name) decCBOR - in checkEncodingWithRoundtrip v (fromPlainEncoding . toCBOR) d roundTripSuccess name x annTokens - where - annTokens = T $ TkEncoded $ serialize' v t + let dAnn = decodeFullAnnotator v (fromString name) decCBOR + d = decodeFullDecoder v (fromString name) decCBOR + annTokens = T $ TkEncoded $ serialize' v t + in testGroup + "with and without Annotator" + [ checkEncodingWithRoundtrip v (fromPlainEncoding . toCBOR) dAnn roundTripSuccess name x annTokens + , checkEncodingWithRoundtrip v (fromPlainEncoding . toCBOR) d roundTripSuccess name x annTokens + ] data ToTokens where T :: (Tokens -> Tokens) -> ToTokens diff --git a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Serialisation/Tripping/CBOR.hs b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Serialisation/Tripping/CBOR.hs index b7ef5734fde..33ac3de67b7 100644 --- a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Serialisation/Tripping/CBOR.hs +++ b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Serialisation/Tripping/CBOR.hs @@ -34,8 +34,10 @@ testCoreTypes :: TestTree testCoreTypes = testGroup "Core Types" - [ testProperty "Header" $ + [ testProperty "Header (Annotator)" $ roundTripAnnExpectation @(TP.BHeader StandardCrypto) + , testProperty "Header" $ + roundTripCborRangeExpectation @(TP.BHeader StandardCrypto) minBound maxBound , testProperty "Block Header Hash" $ roundTripExpectation @TP.HashHeader cborTrip , testProperty "Protocol State" $ @@ -46,10 +48,14 @@ tests :: TestTree tests = testGroup "Serialisation roundtrip Property Tests" - [ testProperty "Block" $ + [ testProperty "Block (Annotator)" $ roundTripAnnRangeExpectation @(Block (TP.BHeader StandardCrypto) ShelleyEra) (eraProtVerLow @ShelleyEra) (eraProtVerHigh @ShelleyEra) + , testProperty "Block" $ + roundTripCborRangeExpectation @(Block (TP.BHeader StandardCrypto) ShelleyEra) + (eraProtVerLow @ShelleyEra) + (eraProtVerHigh @ShelleyEra) , testProperty "LEDGER Predicate Failures" $ roundTripExpectation @[STS.PredicateFailure (STS.ShelleyLEDGERS ShelleyEra)] cborTrip , testCoreTypes diff --git a/libs/cardano-ledger-binary/CHANGELOG.md b/libs/cardano-ledger-binary/CHANGELOG.md index 68750f3a809..3266e6aaf4f 100644 --- a/libs/cardano-ledger-binary/CHANGELOG.md +++ b/libs/cardano-ledger-binary/CHANGELOG.md @@ -2,6 +2,7 @@ ## 1.6.0.0 +* Add `ToCBOR` instance for `PV1.Data` * Add `DecCBOR` instance for `Annotated a ByteString` * Add `originalBytesExpectedFailureMessage` needed for testing * Add `decodeListLikeWithCountT` @@ -31,6 +32,12 @@ ### `testlib` +* Add: + * `decoderEquivalenceSpec` + * `decoderEquivalenceExpectation` + * `decoderEquivalenceProp` + * `cddlDecoderEquivalenceSpec` + * `huddleDecoderEquivalenceSpec` * Re-export types `Doc` and `AnsiStyle` in `Test.Cardano.Ledger.Binary.TreeDiff` * `diffExpr` and `diffExprCompact` changed type signature * Add `diffExprString` and `diffExprCompactString`, which replace the old implementations diff --git a/libs/cardano-ledger-binary/cardano-ledger-binary.cabal b/libs/cardano-ledger-binary/cardano-ledger-binary.cabal index a447131395a..513636fe4c5 100644 --- a/libs/cardano-ledger-binary/cardano-ledger-binary.cabal +++ b/libs/cardano-ledger-binary/cardano-ledger-binary.cabal @@ -84,6 +84,7 @@ library library testlib exposed-modules: + Test.Cardano.Ledger.Binary Test.Cardano.Ledger.Binary.Arbitrary Test.Cardano.Ledger.Binary.Cddl Test.Cardano.Ledger.Binary.Cuddle diff --git a/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Encoding/EncCBOR.hs b/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Encoding/EncCBOR.hs index 24984e3c47a..35892ad1eed 100644 --- a/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Encoding/EncCBOR.hs +++ b/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Encoding/EncCBOR.hs @@ -17,6 +17,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoStarIsType #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Cardano.Ledger.Binary.Encoding.EncCBOR ( EncCBOR (..), @@ -1062,8 +1063,10 @@ deriving instance EncCBOR EpochInterval -- Plutus -------------------------------------------------------------------------------- -instance EncCBOR PV1.Data where - encCBOR = fromPlainEncoding . Serialise.encode +instance Plain.ToCBOR PV1.Data where + toCBOR = Serialise.encode + +instance EncCBOR PV1.Data instance EncCBOR PV1.ScriptContext where encCBOR = encCBOR . PV3.toData diff --git a/libs/cardano-ledger-binary/testlib/Test/Cardano/Ledger/Binary.hs b/libs/cardano-ledger-binary/testlib/Test/Cardano/Ledger/Binary.hs new file mode 100644 index 00000000000..63054a2c19a --- /dev/null +++ b/libs/cardano-ledger-binary/testlib/Test/Cardano/Ledger/Binary.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Test.Cardano.Ledger.Binary ( + decoderEquivalenceSpec, + decoderEquivalenceExpectation, + decoderEquivalenceProp, +) where + +import Cardano.Ledger.Binary +import Control.Monad (forM_) +import qualified Data.ByteString.Lazy as BSL +import Data.Proxy +import qualified Data.Text as T +import Data.Typeable +import Test.Cardano.Ledger.Binary.RoundTrip (embedTripAnnExpectation) +import Test.Hspec +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck hiding (label) + +-- | Generates arbitrary values, encodes them, and verifies that +-- decoding with `DecCBOR (Annotator)` produces the same result as decoding with `DecCBOR`. +decoderEquivalenceSpec :: + forall t. + ( Eq t + , ToCBOR t + , DecCBOR (Annotator t) + , Arbitrary t + , Show t + ) => + Version -> + Version -> + Spec +decoderEquivalenceSpec fromVersion toVersion = + let lbl = show (typeRep $ Proxy @t) + in prop lbl (decoderEquivalenceProp @t fromVersion toVersion) + +decoderEquivalenceProp :: + forall t. + ( Eq t + , ToCBOR t + , DecCBOR (Annotator t) + , Show t + ) => + Version -> + Version -> + t -> + Property +decoderEquivalenceProp fromVersion toVersion t = + property $ + forM_ [fromVersion .. toVersion] $ \version -> + embedTripAnnExpectation version version shouldBe t + +decoderEquivalenceExpectation :: + forall t. + ( Eq t + , DecCBOR t + , DecCBOR (Annotator t) + , Show t + ) => + Version -> + BSL.ByteString -> + Expectation +decoderEquivalenceExpectation version bs = do + let decAnn = decodeFullAnnotator @t version (T.pack (show (typeRep $ Proxy @t))) decCBOR bs + dec = decodeFull @t version bs + case (decAnn, dec) of + -- we only check in case of successful deserialisation, + -- because some arbitrary instances generate data that fails serialisation for some protocols + -- (for example, TxDats in Conway) + (Right _, Right _) -> decAnn `shouldBe` dec + (Left _, Left _) -> pure () + _ -> + expectationFailure $ + "Decoding result: " ++ show dec ++ " did not match the one via Annotator: " ++ show decAnn diff --git a/libs/cardano-ledger-binary/testlib/Test/Cardano/Ledger/Binary/Cddl.hs b/libs/cardano-ledger-binary/testlib/Test/Cardano/Ledger/Binary/Cddl.hs index aa854b6a4cb..39a60d8bf84 100644 --- a/libs/cardano-ledger-binary/testlib/Test/Cardano/Ledger/Binary/Cddl.hs +++ b/libs/cardano-ledger-binary/testlib/Test/Cardano/Ledger/Binary/Cddl.hs @@ -8,6 +8,7 @@ {-# LANGUAGE TypeApplications #-} module Test.Cardano.Ledger.Binary.Cddl ( + cddlDecoderEquivalenceSpec, cddlRoundTripCborSpec, cddlRoundTripExpectation, cddlRoundTripAnnCborSpec, @@ -44,6 +45,7 @@ import System.Process.Typed ( readProcess, setStdin, ) +import Test.Cardano.Ledger.Binary (decoderEquivalenceExpectation) import Test.Cardano.Ledger.Binary.RoundTrip import Test.Hspec import UnliftIO.Temporary (withTempFile) @@ -120,6 +122,30 @@ withCddlVarFile varName CddlData {..} roundTripTest = do , cddlVarDiagCbor = diagCbor } +-- | Using the supplied `CddlData` inside the `SpecWith`, generate random data +-- and verify that decoding with `DecCBOR (Annotator)` produces the same result +-- as decoding with `DecCBOR`. +cddlDecoderEquivalenceSpec :: + forall a. + ( HasCallStack + , Eq a + , Show a + , DecCBOR a + , DecCBOR (Annotator a) + ) => + -- | Serialization version + Version -> + -- | Name of the CDDL variable to test + T.Text -> + SpecWith CddlData +cddlDecoderEquivalenceSpec version varName = + let lbl = label $ Proxy @a + in it (T.unpack $ varName <> ": " <> lbl) $ \cddlData -> + withCddlVarFile varName cddlData $ \CddlVarFile {..} -> do + forM_ cddlVarDiagCbor $ \diagCbor -> do + Cbor cbor <- diagCborToCbor diagCbor + decoderEquivalenceExpectation @a version cbor + -- | Using the supplied `CddlData` inside the `SpecWith` generate random data and run the -- `cddlRoundTripExpectation` for the supplied CDDL variable cddlRoundTripCborSpec :: diff --git a/libs/cardano-ledger-binary/testlib/Test/Cardano/Ledger/Binary/Cuddle.hs b/libs/cardano-ledger-binary/testlib/Test/Cardano/Ledger/Binary/Cuddle.hs index afbf4c0d069..bf74332bb22 100644 --- a/libs/cardano-ledger-binary/testlib/Test/Cardano/Ledger/Binary/Cuddle.hs +++ b/libs/cardano-ledger-binary/testlib/Test/Cardano/Ledger/Binary/Cuddle.hs @@ -7,6 +7,7 @@ {-# LANGUAGE TypeFamilies #-} module Test.Cardano.Ledger.Binary.Cuddle ( + huddleDecoderEquivalenceSpec, specWithHuddle, huddleRoundTripCborSpec, huddleRoundTripAnnCborSpec, @@ -42,6 +43,7 @@ import GHC.Stack (HasCallStack) import Prettyprinter (Pretty (pretty)) import Prettyprinter.Render.Text (hPutDoc) import System.IO (IOMode (..), hPutStrLn, withFile) +import Test.Cardano.Ledger.Binary (decoderEquivalenceExpectation) import Test.Cardano.Ledger.Binary.RoundTrip ( RoundTripFailure (RoundTripFailure), Trip (..), @@ -78,6 +80,23 @@ instance Example (a -> Seeded Expectation) where example a = runSeeded (e a) qcGen in evaluateExample example params hook +huddleDecoderEquivalenceSpec :: + forall a. + (HasCallStack, Eq a, Show a, DecCBOR a, DecCBOR (Annotator a)) => + -- | Serialization version + Version -> + -- | Name of the CDDL rule to test + T.Text -> + SpecWith CuddleData +huddleDecoderEquivalenceSpec version ruleName = + let lbl = label $ Proxy @a + in it (T.unpack ruleName <> ": " <> T.unpack lbl) $ + \cddlData -> + withGenTerm cddlData (Cuddle.Name ruleName) $ \term -> do + let encoding = CBOR.encodeTerm term + initCborBytes = CBOR.toLazyByteString encoding + decoderEquivalenceExpectation @a version initCborBytes + huddleRoundTripCborSpec :: forall a. (HasCallStack, Eq a, Show a, EncCBOR a, DecCBOR a) => diff --git a/libs/cardano-ledger-core/CHANGELOG.md b/libs/cardano-ledger-core/CHANGELOG.md index 9db56b1385e..edc80543e54 100644 --- a/libs/cardano-ledger-core/CHANGELOG.md +++ b/libs/cardano-ledger-core/CHANGELOG.md @@ -2,6 +2,12 @@ ## 1.17.0.0 +* Add DecCBOR instances for: + * `PlutusData` + * `Data` + * `BootstrapWitness` + * `WitVKey` + * `Block` * Converted `CertState` to a type family * Remove `applySTSValidateSuchThat` and `applySTSNonStatic` as redundant. * Move `AccountState` to `Cardano.Ledger.State` from `cardano-ledger-shelley` @@ -101,6 +107,9 @@ ### `testlib` +* Add `Arbitrary` instance for `PV1.Data` +* Add `Arbitrary` instances for `Data`, `BinaryData` and `Datum` +* Add `decoderEquivalenceEraSpec` * Converted `CertState` to a type family * Re-export `KeyPair`, `mkAddr` and `mkCredential` from `Test.Cardano.Ledger.Imp.Common` * Add `MakeStakeReference` and `MakeCredential` diff --git a/libs/cardano-ledger-core/cardano-ledger-core.cabal b/libs/cardano-ledger-core/cardano-ledger-core.cabal index 69e683dbea1..49fb2b05df8 100644 --- a/libs/cardano-ledger-core/cardano-ledger-core.cabal +++ b/libs/cardano-ledger-core/cardano-ledger-core.cabal @@ -288,6 +288,7 @@ test-suite tests containers, genvalidity, genvalidity-scientific, + plutus-ledger-api, quickcheck-instances, scientific, testlib, diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Block.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Block.hs index 7f16dd04268..1f9ebcd175a 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Block.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Block.hs @@ -34,8 +34,10 @@ import Cardano.Ledger.Binary ( ) import qualified Cardano.Ledger.Binary.Plain as Plain import Cardano.Ledger.Core +import Cardano.Ledger.MemoBytes (MemoBytes (Memo), decodeMemoized) import Cardano.Ledger.TxIn (TxIn (..)) import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Short as SBS import Data.Foldable (toList) import Data.Set (Set) import qualified Data.Set as Set @@ -117,7 +119,6 @@ instance (EraTx era, Typeable h) => Plain.ToCBOR (Block h era) where toCBOR (Block' _ _ blockBytes) = Plain.encodePreEncoded $ BSL.toStrict blockBytes instance - forall h era. ( EraSegWits era , DecCBOR (Annotator h) , Typeable h @@ -134,6 +135,34 @@ instance 1 -- header + fromIntegral (numSegComponents @era) +data BlockRaw h era = BlockRaw !h !(TxSeq era) + +instance + ( EraSegWits era + , DecCBOR h + , DecCBOR (TxSeq era) + ) => + DecCBOR (BlockRaw h era) + where + decCBOR = + decodeRecordNamed "Block" (const blockSize) $ do + header <- decCBOR + txns <- decCBOR + pure $ BlockRaw header txns + where + blockSize = 1 + fromIntegral (numSegComponents @era) + +instance + ( EraSegWits era + , DecCBOR h + , DecCBOR (TxSeq era) + ) => + DecCBOR (Block h era) + where + decCBOR = do + Memo (BlockRaw h txSeq) bs <- decodeMemoized (decCBOR @(BlockRaw h era)) + pure $ Block' h txSeq (BSL.fromStrict (SBS.fromShort bs)) + bheader :: Block h era -> h diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Keys/Bootstrap.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Keys/Bootstrap.hs index 3ae83c4783b..ffa72f595bc 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Keys/Bootstrap.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Keys/Bootstrap.hs @@ -60,10 +60,15 @@ import Cardano.Ledger.Keys.Internal ( VKey (..), verifySignedDSIGN, ) -import Cardano.Ledger.MemoBytes (EqRaw (..)) +import Cardano.Ledger.MemoBytes ( + EqRaw (..), + MemoBytes (Memo), + decodeMemoized, + ) import Control.DeepSeq (NFData) import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Short as SBS import Data.Coerce (coerce) import Data.Maybe (fromMaybe) import Data.Ord (comparing) @@ -125,13 +130,29 @@ instance EncCBOR BootstrapWitness instance DecCBOR (Annotator BootstrapWitness) where decCBOR = annotatorSlice $ - decodeRecordNamed "BootstrapWitness" (const 4) $ - do - key <- decCBOR - sig <- decodeSignedDSIGN - cc <- decCBOR - attributes <- decCBOR - pure . pure $ BootstrapWitness' key sig cc attributes + decodeRecordNamed "BootstrapWitness" (const 4) $ do + key <- decCBOR + sig <- decodeSignedDSIGN + cc <- decCBOR + attributes <- decCBOR + pure . pure $ BootstrapWitness' key sig cc attributes + +data BootstrapWitnessRaw + = BootstrapWitnessRaw + !(VKey 'Witness) + !(SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody)) + !ChainCode + !ByteString + +instance DecCBOR BootstrapWitnessRaw where + decCBOR = + decodeRecordNamed "BootstrapWitnessRaw" (const 4) $ + BootstrapWitnessRaw <$> decCBOR <*> decodeSignedDSIGN <*> decCBOR <*> decCBOR + +instance DecCBOR BootstrapWitness where + decCBOR = do + Memo (BootstrapWitnessRaw k s c a) bs <- decodeMemoized (decCBOR @BootstrapWitnessRaw) + pure $ BootstrapWitness' k s c a (LBS.fromStrict (SBS.fromShort bs)) -- | Rebuild the addrRoot of the corresponding address. bootstrapWitKeyHash :: diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Keys/WitVKey.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Keys/WitVKey.hs index 2c8f784b837..a4bce94d167 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Keys/WitVKey.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Keys/WitVKey.hs @@ -28,8 +28,10 @@ import Cardano.Ledger.Binary ( EncCBOR (..), ToCBOR (..), annotatorSlice, + decodeRecordNamed, fromPlainDecoder, ) +import qualified Cardano.Ledger.Binary.Crypto (decodeSignedDSIGN) import qualified Cardano.Ledger.Binary.Plain as Plain import Cardano.Ledger.Hashes ( EraIndependentTxBody, @@ -40,9 +42,10 @@ import Cardano.Ledger.Hashes ( hashTxBodySignature, ) import Cardano.Ledger.Keys.Internal (DSIGN, KeyRole (..), VKey, asWitness) -import Cardano.Ledger.MemoBytes (EqRaw (..)) +import Cardano.Ledger.MemoBytes (EqRaw (..), MemoBytes (Memo), decodeMemoized) import Control.DeepSeq import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Short as SBS import Data.Ord (comparing) import Data.Typeable (Typeable) import GHC.Generics (Generic) @@ -97,6 +100,23 @@ instance Typeable kr => DecCBOR (Annotator (WitVKey kr)) where {-# INLINE mkWitVKey #-} {-# INLINE decCBOR #-} +data WitVKeyRaw kr + = WitVKeyRaw + !(VKey kr) + !(SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody)) + (KeyHash 'Witness) + +instance Typeable kr => DecCBOR (WitVKeyRaw kr) where + decCBOR = decodeRecordNamed "WitVKey" (const 2) $ do + key <- decCBOR + sig <- Cardano.Ledger.Binary.Crypto.decodeSignedDSIGN + pure $ WitVKeyRaw key sig (asWitness $ hashKey key) + +instance Typeable kr => DecCBOR (WitVKey kr) where + decCBOR = do + Memo (WitVKeyRaw k s kh) bs <- decodeMemoized (decCBOR @(WitVKeyRaw kr)) + pure $ WitVKeyInternal k s kh (BSL.fromStrict (SBS.fromShort bs)) + instance Typeable kr => EqRaw (WitVKey kr) where eqRaw = eqWitVKeyRaw diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/MemoBytes/Internal.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/MemoBytes/Internal.hs index f05e776127d..7728e3f2b17 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/MemoBytes/Internal.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/MemoBytes/Internal.hs @@ -246,7 +246,7 @@ class Memoized t where MemoBytes (RawType t) getMemoBytes = coerce - -- | This is a coercion from the MemoBytes to the momoized type. This implementation + -- | This is a coercion from the MemoBytes to the memoized type. This implementation -- cannot be changed since `warpMemoBytes` is not exported, therefore it will only work -- on newtypes around `MemoBytes` wrapMemoBytes :: MemoBytes (RawType t) -> t diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Data.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Data.hs index 175058b0bbc..40f4c6f7f63 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Data.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Data.hs @@ -94,9 +94,12 @@ instance Typeable era => EncCBOR (PlutusData era) where instance Typeable era => DecCBOR (Annotator (PlutusData era)) where decCBOR = pure <$> fromPlainDecoder Cborg.decode +instance Typeable era => DecCBOR (PlutusData era) where + decCBOR = fromPlainDecoder Cborg.decode + newtype Data era = DataConstr (MemoBytes (PlutusData era)) deriving (Eq, Generic) - deriving newtype (SafeToHash, ToCBOR, NFData) + deriving newtype (SafeToHash, ToCBOR, NFData, DecCBOR) -- | Encodes memoized bytes created upon construction. instance Typeable era => EncCBOR (Data era) diff --git a/libs/cardano-ledger-core/test/Test/Cardano/Ledger/BinarySpec.hs b/libs/cardano-ledger-core/test/Test/Cardano/Ledger/BinarySpec.hs index bfbf5d96675..586f40e41dc 100644 --- a/libs/cardano-ledger-core/test/Test/Cardano/Ledger/BinarySpec.hs +++ b/libs/cardano-ledger-core/test/Test/Cardano/Ledger/BinarySpec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeApplications #-} module Test.Cardano.Ledger.BinarySpec (spec) where @@ -11,6 +12,8 @@ import Cardano.Ledger.Hashes (EraIndependentData, SafeHash, ScriptHash) import Cardano.Ledger.Keys import Cardano.Ledger.TxIn import Cardano.Ledger.UMap (RDPair) +import qualified PlutusLedgerApi.V1 as PV1 +import Test.Cardano.Ledger.Binary (decoderEquivalenceSpec) import Test.Cardano.Ledger.Binary.RoundTrip import Test.Cardano.Ledger.Common import Test.Cardano.Ledger.Core.Arbitrary () @@ -36,6 +39,7 @@ spec = do roundTripCborSpec @CertIx roundTripCborSpec @Anchor roundTripAnnCborSpec @BootstrapWitness + roundTripCborSpec @BootstrapWitness roundTripCborSpec @TxId roundTripCborSpec @GenDelegPair roundTripCborSpec @GenDelegs @@ -44,3 +48,8 @@ spec = do roundTripCborSpec @RDPair roundTripCborSpec @ScriptHash roundTripCborSpec @(SafeHash EraIndependentData) + + describe "DecCBOR instances equivalence" $ do + decoderEquivalenceSpec @BootstrapWitness minBound maxBound + decoderEquivalenceSpec @(WitVKey 'Witness) minBound maxBound + decoderEquivalenceSpec @PV1.Data minBound maxBound diff --git a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Arbitrary.hs b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Arbitrary.hs index 3cb70fa7bb7..533afbc996d 100644 --- a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Arbitrary.hs +++ b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Arbitrary.hs @@ -102,6 +102,7 @@ import Cardano.Ledger.Plutus.CostModels ( mkCostModelsLenient, updateCostModels, ) +import Cardano.Ledger.Plutus.Data (BinaryData, Data (..), Datum (..), dataToBinaryData) import Cardano.Ledger.Plutus.ExUnits (ExUnits (..), Prices (..)) import Cardano.Ledger.Plutus.Language (Language (..), nonNativeLanguages) import Cardano.Ledger.PoolParams ( @@ -137,6 +138,8 @@ import qualified Data.VMap as VMap import Data.Word (Word16, Word64, Word8) import GHC.Stack import Generic.Random (genericArbitraryU) +import Numeric.Natural (Natural) +import qualified PlutusLedgerApi.V1 as PV1 import System.Random.Stateful (StatefulGen, uniformRM) import qualified Test.Cardano.Chain.Common.Gen as Byron import Test.Cardano.Ledger.Binary.Arbitrary @@ -883,6 +886,36 @@ instance Arbitrary Prices where instance Arbitrary CostModel where arbitrary = elements nonNativeLanguages >>= genValidCostModel +instance Era era => Arbitrary (Data era) where + arbitrary = Data <$> arbitrary + +instance Era era => Arbitrary (BinaryData era) where + arbitrary = dataToBinaryData <$> arbitrary + +instance Era era => Arbitrary (Datum era) where + arbitrary = + oneof + [ pure NoDatum + , DatumHash <$> arbitrary + , Datum . 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)) + ] + | otherwise = oneof [PV1.I <$> arbitrary, PV1.B <$> arbitrary] + genValidCostModel :: Language -> Gen CostModel genValidCostModel lang = do newParamValues <- vectorOf (costModelParamsCount lang) arbitrary diff --git a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Binary.hs b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Binary.hs index 78e794460c0..203bd609868 100644 --- a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Binary.hs +++ b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Binary.hs @@ -6,15 +6,23 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -module Test.Cardano.Ledger.Core.Binary where +module Test.Cardano.Ledger.Core.Binary ( + BinaryUpgradeOpts (..), + decoderEquivalenceCoreEraTypesSpec, + specUpgrade, + decoderEquivalenceEraSpec, +) where -import Cardano.Ledger.Binary (decNoShareCBOR, encodeMemPack) +import Cardano.Ledger.Binary (Annotator, DecCBOR, ToCBOR, decNoShareCBOR, encodeMemPack) import Cardano.Ledger.Core import Cardano.Ledger.MemoBytes (EqRaw (eqRaw)) +import Cardano.Ledger.Plutus (Data) import Data.Default (Default (def)) import qualified Prettyprinter as Pretty +import Test.Cardano.Ledger.Binary (decoderEquivalenceSpec) import Test.Cardano.Ledger.Binary.RoundTrip import Test.Cardano.Ledger.Common +import Test.Cardano.Ledger.Core.Arbitrary () import Test.Cardano.Ledger.TreeDiff (AnsiStyle, Doc) data BinaryUpgradeOpts = BinaryUpgradeOpts @@ -77,10 +85,11 @@ specTxAuxDataUpgrade :: , Arbitrary (TxAuxData (PreviousEra era)) , HasCallStack , ToExpr (TxAuxData era) + , DecCBOR (TxAuxData era) ) => Spec -specTxAuxDataUpgrade = - prop "upgradeTxAuxData is preserved through serialization" $ \prevTxAuxData -> do +specTxAuxDataUpgrade = do + prop "upgradeTxAuxData is preserved through serialization (Annotator)" $ \prevTxAuxData -> do case embedTripAnn (eraProtVerHigh @(PreviousEra era)) (eraProtVerLow @era) prevTxAuxData of Left err -> expectationFailure $ @@ -89,17 +98,27 @@ specTxAuxDataUpgrade = Right (curTxAuxData :: TxAuxData era) -> do let upgradedTxAuxData = upgradeTxAuxData prevTxAuxData expectRawEqual "TxAuxData" curTxAuxData upgradedTxAuxData + prop "upgradeTxAuxData is preserved through serialization" $ \prevTxAuxData -> do + case embedTrip (eraProtVerHigh @(PreviousEra era)) (eraProtVerLow @era) cborTrip prevTxAuxData of + Left err -> + expectationFailure $ + "Expected to deserialize: =======================================================\n" + ++ show err + Right (curTxAuxData :: TxAuxData era) -> do + let upgradedTxAuxData = upgradeTxAuxData prevTxAuxData + expectRawEqual "TxAuxData" curTxAuxData upgradedTxAuxData specScriptUpgrade :: forall era. ( EraScript (PreviousEra era) , EraScript era , Arbitrary (Script (PreviousEra era)) + , DecCBOR (Script era) , HasCallStack ) => Spec -specScriptUpgrade = - prop "upgradeScript is preserved through serialization" $ \prevScript -> do +specScriptUpgrade = do + prop "upgradeScript is preserved through serialization (Annotator)" $ \prevScript -> do case embedTripAnn (eraProtVerHigh @(PreviousEra era)) (eraProtVerLow @era) prevScript of Left err -> expectationFailure $ @@ -107,6 +126,14 @@ specScriptUpgrade = ++ show err Right (curScript :: Script era) -> curScript `shouldBe` upgradeScript prevScript + prop "upgradeScript is preserved through serialization" $ \prevScript -> do + case embedTrip (eraProtVerHigh @(PreviousEra era)) (eraProtVerLow @era) cborTrip prevScript of + Left err -> + expectationFailure $ + "Expected to deserialize: =======================================================\n" + ++ show err + Right (curScript :: Script era) -> + curScript `shouldBe` upgradeScript prevScript specTxWitsUpgrade :: forall era. @@ -115,10 +142,11 @@ specTxWitsUpgrade :: , Arbitrary (TxWits (PreviousEra era)) , HasCallStack , ToExpr (TxWits era) + , DecCBOR (TxWits era) ) => Spec -specTxWitsUpgrade = - prop "upgradeTxWits is preserved through serialization" $ \prevTxWits -> do +specTxWitsUpgrade = do + prop "upgradeTxWits is preserved through serialization (Annotator)" $ \prevTxWits -> do case embedTripAnn (eraProtVerHigh @(PreviousEra era)) (eraProtVerLow @era) prevTxWits of Left err -> expectationFailure $ @@ -127,6 +155,15 @@ specTxWitsUpgrade = Right (curTxWits :: TxWits era) -> do let upgradedTxWits = upgradeTxWits prevTxWits expectRawEqual "TxWits" curTxWits upgradedTxWits + prop "upgradeTxWits is preserved through serialization" $ \prevTxWits -> do + case embedTrip (eraProtVerHigh @(PreviousEra era)) (eraProtVerLow @era) cborTrip prevTxWits of + Left err -> + expectationFailure $ + "Expected to deserialize: =======================================================\n" + ++ show err + Right (curTxWits :: TxWits era) -> do + let upgradedTxWits = upgradeTxWits prevTxWits + expectRawEqual "TxWits" curTxWits upgradedTxWits specTxBodyUpgrade :: forall era. @@ -135,10 +172,11 @@ specTxBodyUpgrade :: , Arbitrary (TxBody (PreviousEra era)) , HasCallStack , ToExpr (TxBody era) + , DecCBOR (TxBody era) ) => Spec -specTxBodyUpgrade = - prop "upgradeTxBody is preserved through serialization" $ \prevTxBody -> do +specTxBodyUpgrade = do + prop "upgradeTxBody is preserved through serialization (Annotator)" $ \prevTxBody -> do case embedTripAnn (eraProtVerHigh @(PreviousEra era)) (eraProtVerLow @era) prevTxBody of Left err | Right _ <- upgradeTxBody prevTxBody -> @@ -151,6 +189,19 @@ specTxBodyUpgrade = | Right upgradedTxBody <- upgradeTxBody prevTxBody -> expectRawEqual "TxBody" curTxBody upgradedTxBody | otherwise -> expectationFailure "Expected upgradeTxBody to succeed" + prop "upgradeTxBody is preserved through serialization" $ \prevTxBody -> do + case embedTrip (eraProtVerHigh @(PreviousEra era)) (eraProtVerLow @era) cborTrip prevTxBody of + Left err + | Right _ <- upgradeTxBody prevTxBody -> + -- We expect deserialization to succeed, when upgrade is possible + expectationFailure $ + "Expected to deserialize: =======================================================\n" + ++ show err + | otherwise -> pure () -- Both upgrade and deserializer fail successfully + Right (curTxBody :: TxBody era) + | Right upgradedTxBody <- upgradeTxBody prevTxBody -> + expectRawEqual "TxBody" curTxBody upgradedTxBody + | otherwise -> expectationFailure "Expected upgradeTxBody to succeed" specTxUpgrade :: forall era. @@ -159,10 +210,11 @@ specTxUpgrade :: , Arbitrary (Tx (PreviousEra era)) , HasCallStack , ToExpr (Tx era) + , DecCBOR (Tx era) ) => Spec -specTxUpgrade = - prop "upgradeTx is preserved through serialization" $ \prevTx -> do +specTxUpgrade = do + prop "upgradeTx is preserved through serialization (Annotator)" $ \prevTx -> do case embedTripAnn (eraProtVerHigh @(PreviousEra era)) (eraProtVerLow @era) prevTx of Left err | Right _ <- upgradeTx prevTx -> @@ -175,6 +227,19 @@ specTxUpgrade = | Right upgradedTx <- upgradeTx prevTx -> expectRawEqual "Tx" curTx upgradedTx | otherwise -> expectationFailure "Expected upgradeTx to succeed" + prop "upgradeTx is preserved through serialization" $ \prevTx -> do + case embedTrip (eraProtVerHigh @(PreviousEra era)) (eraProtVerLow @era) cborTrip prevTx of + Left err + | Right _ <- upgradeTx prevTx -> + -- We expect deserialization to succeed, when upgrade is possible + expectationFailure $ + "Expected to deserialize: =======================================================\n" + ++ show err + | otherwise -> pure () -- Both upgrade and deserializer fail successfully + Right (curTx :: Tx era) + | Right upgradedTx <- upgradeTx prevTx -> + expectRawEqual "Tx" curTx upgradedTx + | otherwise -> expectationFailure "Expected upgradeTx to succeed" specUpgrade :: forall era. @@ -192,6 +257,11 @@ specUpgrade :: , ToExpr (TxBody era) , ToExpr (TxWits era) , ToExpr (TxAuxData era) + , DecCBOR (TxAuxData era) + , DecCBOR (Script era) + , DecCBOR (TxWits era) + , DecCBOR (TxBody era) + , DecCBOR (Tx era) ) => BinaryUpgradeOpts -> Spec @@ -223,3 +293,35 @@ expectRawEqual thing expected actual = [ Pretty.hsep ["Expected raw representation of", thing, "to be equal:"] , Pretty.indent 2 $ diffExpr expected actual ] + +decoderEquivalenceEraSpec :: + forall era t. + ( Era era + , Eq t + , ToCBOR t + , DecCBOR (Annotator t) + , Arbitrary t + , Show t + ) => + Spec +decoderEquivalenceEraSpec = decoderEquivalenceSpec @t (eraProtVerLow @era) (eraProtVerHigh @era) + +decoderEquivalenceCoreEraTypesSpec :: + forall era. + ( EraTx era + , Arbitrary (Tx era) + , Arbitrary (TxBody era) + , Arbitrary (TxWits era) + , Arbitrary (TxAuxData era) + , Arbitrary (Script era) + , HasCallStack + ) => + Spec +decoderEquivalenceCoreEraTypesSpec = + describe "DecCBOR instances equivalence" $ do + decoderEquivalenceEraSpec @era @(Data era) + decoderEquivalenceEraSpec @era @(Script era) + decoderEquivalenceEraSpec @era @(TxAuxData era) + decoderEquivalenceEraSpec @era @(TxWits era) + decoderEquivalenceEraSpec @era @(TxBody era) + decoderEquivalenceEraSpec @era @(Tx era) diff --git a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Binary/RoundTrip.hs b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Binary/RoundTrip.hs index 96b1374da60..de2204ac405 100644 --- a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Binary/RoundTrip.hs +++ b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Binary/RoundTrip.hs @@ -201,6 +201,11 @@ roundTripCoreEraTypesSpec :: , Arbitrary (PParams era) , Arbitrary (PParamsUpdate era) , Arbitrary (CertState era) + , DecCBOR (Script era) + , DecCBOR (TxAuxData era) + , DecCBOR (TxWits era) + , DecCBOR (TxBody era) + , DecCBOR (Tx era) , HasCallStack ) => Spec @@ -213,10 +218,15 @@ roundTripCoreEraTypesSpec = do roundTripEraSpec @era @(PParams era) roundTripEraSpec @era @(PParamsUpdate era) roundTripAnnEraSpec @era @(Script era) + roundTripEraSpec @era @(Script era) roundTripAnnEraSpec @era @(TxAuxData era) + roundTripEraSpec @era @(TxAuxData era) roundTripAnnEraSpec @era @(TxWits era) + roundTripEraSpec @era @(TxWits era) roundTripAnnEraSpec @era @(TxBody era) + roundTripEraSpec @era @(TxBody era) roundTripAnnEraSpec @era @(Tx era) + roundTripEraSpec @era @(Tx era) prop ("MemPack/CBOR Roundtrip " <> show (typeRep $ Proxy @(TxOut era))) $ roundTripRangeExpectation @(TxOut era) (mkTrip encodeMemPack decNoShareCBOR) @@ -225,6 +235,7 @@ roundTripCoreEraTypesSpec = do roundTripShareEraSpec @era @(CertState era) describe "Core State Types" $ do roundTripAnnEraSpec @era @BootstrapWitness + roundTripEraSpec @era @BootstrapWitness roundTripShareEraSpec @era @SnapShots roundTripShareEraTypeSpec @era @DState roundTripShareEraTypeSpec @era @PState diff --git a/libs/cardano-protocol-tpraos/CHANGELOG.md b/libs/cardano-protocol-tpraos/CHANGELOG.md index 3b1647a52d6..a98eedcd913 100644 --- a/libs/cardano-protocol-tpraos/CHANGELOG.md +++ b/libs/cardano-protocol-tpraos/CHANGELOG.md @@ -2,6 +2,7 @@ ## 1.4.0.0 +* Add `DecCBOR` instance for `BHeader` * Converted `CertState` to a type family * Made the fields of predicate failures and environments lazy * Move `Crypto` and `StandardCrypto` definitions from `cardano-ledger-core` into new diff --git a/libs/cardano-protocol-tpraos/cardano-protocol-tpraos.cabal b/libs/cardano-protocol-tpraos/cardano-protocol-tpraos.cabal index 78fb184f812..5e2906c7ec3 100644 --- a/libs/cardano-protocol-tpraos/cardano-protocol-tpraos.cabal +++ b/libs/cardano-protocol-tpraos/cardano-protocol-tpraos.cabal @@ -95,7 +95,10 @@ test-suite tests type: exitcode-stdio-1.0 main-is: Main.hs hs-source-dirs: test - other-modules: Test.Cardano.Protocol.Binary.CddlSpec + other-modules: + Test.Cardano.Protocol.Binary.BinarySpec + Test.Cardano.Protocol.Binary.CddlSpec + default-language: Haskell2010 ghc-options: -Wall @@ -112,7 +115,10 @@ test-suite tests build-depends: base, bytestring, + cardano-ledger-allegra:{cardano-ledger-allegra, testlib}, + cardano-ledger-alonzo:{cardano-ledger-alonzo, testlib}, cardano-ledger-binary:{cardano-ledger-binary, testlib}, cardano-ledger-core:{cardano-ledger-core, testlib}, + cardano-ledger-mary:{cardano-ledger-mary, testlib}, cardano-ledger-shelley:{cardano-ledger-shelley, testlib}, - cardano-protocol-tpraos, + cardano-protocol-tpraos:{cardano-protocol-tpraos, testlib}, diff --git a/libs/cardano-protocol-tpraos/src/Cardano/Protocol/TPraos/BHeader.hs b/libs/cardano-protocol-tpraos/src/Cardano/Protocol/TPraos/BHeader.hs index c344d51d2fe..72af3f50b7b 100644 --- a/libs/cardano-protocol-tpraos/src/Cardano/Protocol/TPraos/BHeader.hs +++ b/libs/cardano-protocol-tpraos/src/Cardano/Protocol/TPraos/BHeader.hs @@ -90,6 +90,7 @@ import Cardano.Ledger.Hashes ( hashKey, ) import Cardano.Ledger.Keys (VKey) +import Cardano.Ledger.MemoBytes (MemoBytes (Memo), decodeMemoized) import Cardano.Ledger.NonIntegral (CompareResult (..), taylorExpCmp) import Cardano.Ledger.Slot (BlockNo (..), SlotNo (..)) import Cardano.Protocol.Crypto @@ -100,6 +101,7 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Builder as BS import qualified Data.ByteString.Builder.Extra as BS import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Short as SBS import Data.Typeable import Data.Word (Word32, Word64) import GHC.Generics (Generic) @@ -292,6 +294,18 @@ instance Crypto c => DecCBOR (Annotator (BHeader c)) where sig <- decodeSignedKES pure $ pure $ BHeader' bhb sig . BSL.toStrict +data BHeaderRaw c = BHeaderRaw !(BHBody c) !(KES.SignedKES (KES c) (BHBody c)) + +instance Crypto c => DecCBOR (BHeaderRaw c) where + decCBOR = + decodeRecordNamed "HeaderRaw" (const 2) $ + BHeaderRaw <$> decCBOR <*> decodeSignedKES + +instance Crypto c => DecCBOR (BHeader c) where + decCBOR = do + Memo (BHeaderRaw bhb sig) bs <- decodeMemoized decCBOR + pure $ BHeader' bhb sig (SBS.fromShort bs) + -- | Hash a given block header bhHash :: Crypto c => BHeader c -> HashHeader bhHash bh = HashHeader . Hash.castHash . hashEncCBOR version $ bh diff --git a/libs/cardano-protocol-tpraos/test/Main.hs b/libs/cardano-protocol-tpraos/test/Main.hs index dd17f62b0cc..70d39f2f92f 100644 --- a/libs/cardano-protocol-tpraos/test/Main.hs +++ b/libs/cardano-protocol-tpraos/test/Main.hs @@ -1,6 +1,7 @@ module Main where import Test.Cardano.Ledger.Common +import qualified Test.Cardano.Protocol.Binary.BinarySpec as Binary import qualified Test.Cardano.Protocol.Binary.CddlSpec as Cddl main :: IO () @@ -8,3 +9,4 @@ main = ledgerTestMain $ describe "TPraos" $ do Cddl.spec + Binary.spec diff --git a/libs/cardano-protocol-tpraos/test/Test/Cardano/Protocol/Binary/BinarySpec.hs b/libs/cardano-protocol-tpraos/test/Test/Cardano/Protocol/Binary/BinarySpec.hs new file mode 100644 index 00000000000..cd8a8d6aec3 --- /dev/null +++ b/libs/cardano-protocol-tpraos/test/Test/Cardano/Protocol/Binary/BinarySpec.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Test.Cardano.Protocol.Binary.BinarySpec (spec) where + +import Cardano.Ledger.Allegra (AllegraEra) +import Cardano.Ledger.Alonzo (AlonzoEra) +import Cardano.Ledger.Block +import Cardano.Ledger.Core +import Cardano.Ledger.Mary (MaryEra) +import Cardano.Ledger.Shelley (ShelleyEra) +import Cardano.Protocol.Crypto +import Cardano.Protocol.TPraos.BHeader (BHeader) +import Data.Proxy +import Data.Typeable (typeRep) +import Test.Cardano.Ledger.Allegra.Arbitrary () +import Test.Cardano.Ledger.Alonzo.Arbitrary () +import Test.Cardano.Ledger.Binary (decoderEquivalenceProp, decoderEquivalenceSpec) +import Test.Cardano.Ledger.Common +import Test.Cardano.Ledger.Mary.Arbitrary () +import Test.Cardano.Protocol.TPraos.Arbitrary () + +spec :: Spec +spec = do + describe "DecCBOR instances equivalence" $ do + decoderEquivalenceSpec @(BHeader StandardCrypto) minBound maxBound + blockEraSpec @ShelleyEra + blockEraSpec @AllegraEra + blockEraSpec @MaryEra + blockEraSpec @AlonzoEra + +blockEraSpec :: + forall era. + ( EraSegWits era + , Arbitrary (Tx era) + ) => + Spec +blockEraSpec = + prop (show (typeRep $ Proxy @(Block (BHeader StandardCrypto) era))) $ + withMaxSuccess 3 $ + decoderEquivalenceProp @(Block (BHeader StandardCrypto) era) + (eraProtVerLow @era) + (eraProtVerHigh @era) diff --git a/libs/cardano-protocol-tpraos/test/Test/Cardano/Protocol/Binary/CddlSpec.hs b/libs/cardano-protocol-tpraos/test/Test/Cardano/Protocol/Binary/CddlSpec.hs index 21fc43c0477..0f7b96f6d9c 100644 --- a/libs/cardano-protocol-tpraos/test/Test/Cardano/Protocol/Binary/CddlSpec.hs +++ b/libs/cardano-protocol-tpraos/test/Test/Cardano/Protocol/Binary/CddlSpec.hs @@ -14,11 +14,14 @@ import Cardano.Protocol.TPraos.OCert (OCert) import qualified Data.ByteString.Lazy as BSL import Test.Cardano.Ledger.Binary.Cddl ( beforeAllCddlFile, + cddlDecoderEquivalenceSpec, cddlRoundTripAnnCborSpec, cddlRoundTripCborSpec, ) +import Test.Cardano.Ledger.Binary.Cuddle import Test.Cardano.Ledger.Common import Test.Cardano.Ledger.Shelley.Binary.Cddl (readShelleyCddlFiles) +import Test.Cardano.Ledger.Shelley.CDDL (shelleyCDDL) spec :: Spec spec = @@ -28,9 +31,16 @@ spec = specForEra :: forall era. Era era => IO [BSL.ByteString] -> Int -> Spec specForEra readCddlFiles n = do - describe (eraName @era) $ + describe (eraName @era) $ do + let v = eraProtVerLow @era beforeAllCddlFile n readCddlFiles $ do - let v = eraProtVerLow @era cddlRoundTripAnnCborSpec @(BHeader StandardCrypto) v "header" + cddlRoundTripCborSpec @(BHeader StandardCrypto) v "header" cddlRoundTripCborSpec @(BHBody StandardCrypto) v "header_body" cddlRoundTripCborSpec @(CBORGroup (OCert StandardCrypto)) v "[ operational_cert ]" + -- TODO: add Huddle round trip tests + describe "DecCBOR instances equivalence via CDDL" $ do + cddlDecoderEquivalenceSpec @(BHeader StandardCrypto) v "header" + describe "DecCBOR instances equivalence via CDDL - Huddle" $ do + specWithHuddle shelleyCDDL 100 $ do + huddleDecoderEquivalenceSpec @(BHeader StandardCrypto) v "header"