Non-Annotator DecCBOR instances

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,17 @@ instance Era era => DecCBOR (Annotator (TimelockRaw era)) where
       decRaw 5 = Ann (SumD TimeExpire <! From)
       decRaw n = Invalid n
 
+instance Era era => DecCBOR (TimelockRaw era) where
+  decCBOR = decode (Summands "TimelockRaw" decRaw)
+    where
+      decRaw 0 = SumD Signature <! From
+      decRaw 1 = SumD AllOf <! D decCBOR
+      decRaw 2 = SumD AnyOf <! D decCBOR
+      decRaw 3 = SumD MOfN <! From <! D decCBOR
+      decRaw 4 = SumD TimeStart <! From
+      decRaw 5 = SumD TimeExpire <! From
+      decRaw n = Invalid n
+
 -- =================================================================
 -- Native Scripts are Memoized TimelockRaw.
 -- The patterns give the appearence that the mutual recursion is not present.
@@ -222,6 +233,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
 

eras/shelley/impl/src/Cardano/Ledger/Shelley/Scripts.hs

@@ -34,22 +34,26 @@ 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 (
   EqRaw (..),
   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 "MultiSigRaw" $ 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

eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx/Internal.hs

@@ -322,12 +322,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
+        <! From
+        <! From
+        <! D (maybeToStrictMaybe <$> decodeNullMaybe decCBOR)
 
 deriving via
   Mem (ShelleyTxRaw era)
   instance
     EraTx era => 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

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

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.

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
+        "ShelleyTxWitsRaw"
+        (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

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

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
@@ -134,6 +136,37 @@ instance
         1 -- header
           + fromIntegral (numSegComponents @era)
 
+data BlockRaw h era = BlockRaw !h !(TxSeq era)
+
+instance
+  forall h era.
+  ( 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
+  forall h era.
+  ( EraSegWits era
+  , DecCBOR h
+  , DecCBOR (TxSeq era)
+  ) =>
+  DecCBOR (Block h era)
+  where
+  decCBOR = do
+    mb <- decodeMemoized (decCBOR @(BlockRaw h era))
+    let (Memo (BlockRaw h txSeq) bs) = mb
+    pure $ Block' h txSeq (BSL.fromStrict (SBS.fromShort bs))
+
 bheader ::
   Block h era ->
   h

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,33 @@ 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) $
+    do
+      key <- decCBOR
+      sig <- decodeSignedDSIGN
+      cc <- decCBOR
+      BootstrapWitnessRaw key sig cc <$> decCBOR
+
+instance DecCBOR BootstrapWitness where
+  decCBOR = do
+    mb <- decodeMemoized (decCBOR @BootstrapWitnessRaw)
+    let (Memo (BootstrapWitnessRaw k s c a) bs) = mb
+    pure $ BootstrapWitness' k s c a (LBS.fromStrict (SBS.fromShort bs))
 
 -- | Rebuild the addrRoot of the corresponding address.
 bootstrapWitKeyHash ::

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,24 @@ 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 "WitVKeyRaw" (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
+    mb <- decodeMemoized (decCBOR @(WitVKeyRaw kr))
+    let (Memo (WitVKeyRaw k s kh) bs) = mb
+    pure $ WitVKeyInternal k s kh (BSL.fromStrict (SBS.fromShort bs))
+
 instance Typeable kr => EqRaw (WitVKey kr) where
   eqRaw = eqWitVKeyRaw
 

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