[wip] - ShelleyTxSeq

Author: teodanciu

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

@@ -4,6 +4,7 @@
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
@@ -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, segwitTx, segwitTxXXX)
 import Cardano.Ledger.Slot (SlotNo (..))
 import Control.Monad (unless)
 import Data.ByteString (ByteString)
@@ -188,55 +191,104 @@ 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])
+
+instance
+  ( EraTx era
+  , DecCBOR (TxBody era)
+  , DecCBOR (TxWits era)
+  , DecCBOR (TxAuxData era)
+  ) =>
+  DecCBOR (ShelleyTxSeq era)
+  where
+  decCBOR = do
+    Annotated (bodies :: Seq (TxBody era)) bodiesBS <- decodeAnnotated decCBOR
+    let b = length bodies
+    Annotated (wits :: Seq (TxWits era)) witsBS <- decodeAnnotated decCBOR
+    Annotated (metadataMap :: Map Int (TxAuxData era)) metadataBS <-
+      decodeAnnotated decCBOR
+    let metadata = indexLookupSeq b metadataMap
+    let txs = StrictSeq.forceToStrict $ Seq.zipWith3 segwitTxXXX bodies wits metadata
+    pure $ TxSeq' txs bodiesBS witsBS metadataBS
 
 -- | The parts of the Tx in Blocks that have to have DecCBOR(Annotator x) instances.
 --   These are exactly the parts that are SafeToHash.
 -- | Decode a TxSeq, used in decoding a Block.
+txXXX ::
+  forall era.
+  ( EraTx era
+  , DecCBOR (TxBody era)
+  , DecCBOR (TxWits era)
+  , DecCBOR (TxAuxData era)
+  ) =>
+  Bool ->
+  forall s.
+  Decoder s (Annotator (ShelleyTxSeq era))
+txXXX _ = do
+  d <- decCBOR @(ShelleyTxSeq era)
+  pure undefined
+
 txSeqDecoder ::
   forall era.
-  EraTx era =>
+  ( EraTx era
+  , DecCBOR (TxBody era)
+  , DecCBOR (TxWits era)
+  , DecCBOR (TxAuxData era)
+  ) =>
   Bool ->
   forall s.
   Decoder s (Annotator (ShelleyTxSeq era))
-txSeqDecoder lax = do
-  (bodies, bodiesAnn) <- withSlice decCBOR
-  (wits, witsAnn) <- withSlice decCBOR
-  let b = length bodies
-      inRange x = (0 <= x) && (x <= (b - 1))
-      w = length wits
-  (metadata, metadataAnn) <- withSlice $
-    do
-      m <- decCBOR
-      unless -- TODO this PR introduces this new test, That didn't used to run in the Shelley
-        (lax || all inRange (Map.keysSet m)) -- Era,  Is it possible there might be some blocks, that should have been caught on the chain?
-        (fail ("Some Auxiliarydata index is not in the range: 0 .. " ++ show (b - 1)))
-      pure (constructMetadata @era b m)
+txSeqDecoder _ = do
+  d <- decCBOR @(ShelleyTxSeq era)
+  pure $ pure $ d
 
-  unless
-    (lax || b == w)
-    ( fail $
-        "different number of transaction bodies ("
-          <> show b
-          <> ") and witness sets ("
-          <> show w
-          <> ")"
-    )
+-- txSeqDecoder lax = do
+--   (bodies, bodiesAnn) <- withSlice decCBOR
+--   (wits, witsAnn) <- withSlice decCBOR
+--   let b = length bodies
+--       inRange x = (0 <= x) && (x <= (b - 1))
+--       w = length wits
+--   (metadata, metadataAnn) <- withSlice $
+--     do
+--       m <- decCBOR
+--       unless -- TODO this PR introduces this new test, That didn't used to run in the Shelley
+--         (lax || all inRange (Map.keysSet m)) -- Era,  Is it possible there might be some blocks, that should have been caught on the chain?
+--         (fail ("Some Auxiliarydata index is not in the range: 0 .. " ++ show (b - 1)))
+--       pure (constructMetadata @era b m)
 
-  let txns =
-        sequenceA $
-          StrictSeq.forceToStrict $
-            Seq.zipWith3 segwitTx bodies wits metadata
-  pure $ TxSeq' <$> txns <*> bodiesAnn <*> witsAnn <*> metadataAnn
+--   unless
+--     (lax || b == w)
+--     ( fail $
+--         "different number of transaction bodies ("
+--           <> show b
+--           <> ") and witness sets ("
+--           <> show w
+--           <> ")"
+--     )
 
-instance EraTx era => DecCBOR (Annotator (ShelleyTxSeq era)) where
+--   let txns =
+--         sequenceA $
+--           StrictSeq.forceToStrict $
+--             Seq.zipWith3 segwitTx bodies wits metadata
+--   pure $ TxSeq' <$> txns <*> bodiesAnn <*> witsAnn <*> metadataAnn
+
+instance
+  ( EraTx era
+  , DecCBOR (TxBody era)
+  , DecCBOR (TxWits era)
+  , DecCBOR (TxAuxData era)
+  ) =>
+  DecCBOR (Annotator (ShelleyTxSeq era))
+  where
   decCBOR = txSeqDecoder False
 
 slotToNonce :: SlotNo -> Nonce

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

@@ -13,6 +13,7 @@ module Cardano.Ledger.Shelley.Tx (
   sizeShelleyTxF,
   wireSizeShelleyTxF,
   segwitTx,
+  segwitTxXXX,
   mkBasicShelleyTx,
   shelleyMinFeeTx,
   witsFromTxWitnesses,

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

@@ -40,6 +40,7 @@ module Cardano.Ledger.Shelley.Tx.Internal (
   sizeShelleyTxF,
   wireSizeShelleyTxF,
   segwitTx,
+  segwitTxXXX,
   mkBasicShelleyTx,
   shelleyMinFeeTx,
   witsFromTxWitnesses,
@@ -398,6 +399,33 @@ segwitTx
           (maybeToStrictMaybe metadata)
           fullBytes
 
+segwitTxXXX ::
+  forall era.
+  EraTx era =>
+  TxBody era ->
+  TxWits era ->
+  Maybe (TxAuxData era) ->
+  ShelleyTx era
+segwitTxXXX
+  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
+
 -- ========================================
 
 -- | Minimum fee calculation

eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/LaxBlock.hs

@@ -20,7 +20,7 @@ import Cardano.Ledger.Binary (
   decodeRecordNamed,
  )
 import Cardano.Ledger.Block (Block (..))
-import Cardano.Ledger.Core (Era, EraSegWits (TxSeq), EraTx)
+import Cardano.Ledger.Core -- (Era, EraSegWits (TxSeq), EraTx)
 import Cardano.Ledger.Shelley.BlockChain (ShelleyTxSeq, txSeqDecoder)
 import Data.Typeable (Typeable)
 
@@ -41,6 +41,11 @@ blockDecoder ::
   ( EraTx era
   , TxSeq era ~ ShelleyTxSeq era
   , DecCBOR (Annotator h)
+  , DecCBOR h
+  , DecCBOR (TxBody era)
+  , DecCBOR (TxWits era)
+  , DecCBOR (TxAuxData era)
+  , DecCBOR (ShelleyTxSeq era)
   ) =>
   Bool ->
   forall s.
@@ -58,6 +63,11 @@ instance
   , Typeable h
   , TxSeq era ~ ShelleyTxSeq era
   , DecCBOR (Annotator h)
+  , DecCBOR h
+  , DecCBOR (TxBody era)
+  , DecCBOR (TxWits era)
+  , DecCBOR (TxAuxData era)
+  , DecCBOR (ShelleyTxSeq era)
   ) =>
   DecCBOR (Annotator (LaxBlock h era))
   where