Merge pull request #2274 from input-output-hk/jc/fix-alonzo-block-cbor

fix alonzo block serialization

alonzo/impl/src/Cardano/Ledger/Alonzo.hs

@@ -214,6 +214,7 @@ instance CC.Crypto c => EraModule.SupportsSegWit (AlonzoEra c) where
   fromTxSeq = Alonzo.txSeqTxns
   toTxSeq = Alonzo.TxSeq
   hashTxSeq = Alonzo.hashTxSeq
+  numSegComponents = 4
 
 instance API.PraosCrypto c => API.ShelleyBasedEra (AlonzoEra c)
 

alonzo/impl/src/Cardano/Ledger/Alonzo/TxSeq.hs

@@ -271,8 +271,10 @@ nonValidatingIndices (StrictSeq.fromStrict -> xs) =
 --
 -- This function operates much as the inverse of 'nonValidatingIndices'.
 alignedValidFlags :: Int -> [Int] -> Seq.Seq IsValidating
-alignedValidFlags n [] = Seq.replicate n $ IsValidating True
-alignedValidFlags n (x : xs) =
-  Seq.replicate (n - x) (IsValidating True)
-    Seq.>< IsValidating False
-    Seq.<| alignedValidFlags (n - x - 1) xs
+alignedValidFlags = alignedValidFlags' (-1)
+  where
+    alignedValidFlags' _ n [] = Seq.replicate n $ IsValidating True
+    alignedValidFlags' prev n (x : xs) =
+      Seq.replicate (x - prev - 1) (IsValidating True)
+        Seq.>< IsValidating False
+        Seq.<| alignedValidFlags' x (n - (x - prev)) xs

alonzo/test/test/Test/Cardano/Ledger/Alonzo/Serialisation/Tripping.hs

@@ -17,10 +17,12 @@ import Cardano.Ledger.Alonzo.Scripts (Script)
 import Cardano.Ledger.Alonzo.Tx (CostModel, WitnessPPData)
 import Cardano.Ledger.Alonzo.TxBody (TxBody)
 import Cardano.Ledger.Alonzo.TxWitness
+import qualified Cardano.Ledger.Tx as LTX
 import qualified Data.ByteString as BS (ByteString)
 import qualified Data.ByteString.Base16.Lazy as Base16
 import qualified Data.ByteString.Lazy.Char8 as BSL
 import qualified PlutusTx as Plutus
+import Shelley.Spec.Ledger.BlockChain (Block)
 import Shelley.Spec.Ledger.Metadata (Metadata)
 import Test.Cardano.Ledger.Alonzo.Serialisation.Generators ()
 import Test.Cardano.Ledger.ShelleyMA.Serialisation.Coders (roundTrip, roundTripAnn)
@@ -111,5 +113,9 @@ tests =
       testProperty "Script" $
         trippingAnn @(Script (AlonzoEra C_Crypto)),
       testProperty "WitnessPPData" $
-        trippingAnn @(WitnessPPData (AlonzoEra C_Crypto))
+        trippingAnn @(WitnessPPData (AlonzoEra C_Crypto)),
+      testProperty "alonzo/Tx" $
+        trippingAnn @(LTX.Tx (AlonzoEra C_Crypto)),
+      testProperty "alonzo/Block" $
+        trippingAnn @(Block (AlonzoEra C_Crypto))
     ]

cardano-ledger-core/src/Cardano/Ledger/Era.hs

@@ -51,6 +51,7 @@ import Data.Sequence.Strict (StrictSeq)
 import Data.Set (Set)
 import Data.Typeable (Typeable)
 import Data.Void (Void, absurd)
+import Data.Word (Word64)
 import GHC.Records (HasField (..))
 
 --------------------------------------------------------------------------------
@@ -133,6 +134,9 @@ class SupportsSegWit era where
     TxSeq era ->
     Hash.Hash (CryptoClass.HASH (Crypto era)) EraIndependentBlockBody
 
+  -- | The number of segregated components
+  numSegComponents :: Word64
+
 --------------------------------------------------------------------------------
 -- Era translation
 --------------------------------------------------------------------------------

example-shelley/src/Cardano/Ledger/Example.hs

@@ -151,6 +151,7 @@ instance CryptoClass.Crypto c => SupportsSegWit (ExampleEra c) where
   fromTxSeq = Shelley.txSeqTxns
   toTxSeq = Shelley.TxSeq
   hashTxSeq = Shelley.bbHash
+  numSegComponents = 3
 
 instance CryptoClass.Crypto c => ValidateAuxiliaryData (ExampleEra c) c where
   hashAuxiliaryData metadata = AuxiliaryDataHash (makeHashWithExplicitProxys (Proxy @c) index metadata)

shelley-ma/impl/src/Cardano/Ledger/ShelleyMA.hs

@@ -192,6 +192,7 @@ instance
   fromTxSeq = Shelley.txSeqTxns
   toTxSeq = Shelley.TxSeq
   hashTxSeq = Shelley.bbHash
+  numSegComponents = 3
 
 instance
   ( CryptoClass.Crypto c,

shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Shelley.hs

@@ -117,6 +117,7 @@ instance CryptoClass.Crypto c => SupportsSegWit (ShelleyEra c) where
   fromTxSeq = Shelley.txSeqTxns
   toTxSeq = Shelley.TxSeq
   hashTxSeq = bbHash
+  numSegComponents = 3
 
 instance CryptoClass.Crypto c => ValidateAuxiliaryData (ShelleyEra c) c where
   validateAuxiliaryData (Metadata m) = all validMetadatum m

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/BlockChain.hs

@@ -679,17 +679,23 @@ instance
   fromCBOR = txSeqDecoder False
 
 instance
+  forall era.
   ( BlockAnn era,
     ValidateScript era,
+    Era.SupportsSegWit era,
     FromCBOR (Annotator (Era.TxSeq era))
   ) =>
   FromCBOR (Annotator (Block era))
   where
   fromCBOR = annotatorSlice $
-    decodeRecordNamed "Block" (const 4) $ do
+    decodeRecordNamed "Block" (const blockSize) $ do
       header <- fromCBOR
       txns <- fromCBOR
       pure $ Block' <$> header <*> txns
+    where
+      blockSize =
+        1 -- header
+          + fromIntegral (Era.numSegComponents @era)
 
 -- | A block in which we do not validate the matched encoding of parts of the
 --   segwit. TODO This is purely a test concern, and as such should be moved out

shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Serialisation/EraIndepGenerators.hs

@@ -45,11 +45,10 @@ import Cardano.Ledger.Coin (DeltaCoin (..))
 import qualified Cardano.Ledger.Core as Core
 import Cardano.Ledger.Crypto (DSIGN)
 import qualified Cardano.Ledger.Crypto as CC (Crypto)
-import Cardano.Ledger.Era (Crypto, Era, ValidateScript)
+import Cardano.Ledger.Era (Crypto, Era, SupportsSegWit (..), ValidateScript)
 import Cardano.Ledger.SafeHash (HasAlgorithm, SafeHash, unsafeMakeSafeHash)
 import Cardano.Ledger.Shelley.Constraints
-  ( UsesAuxiliary,
-    UsesScript,
+  ( UsesScript,
     UsesTxBody,
     UsesTxOut,
     UsesValue,
@@ -125,23 +124,18 @@ import qualified Shelley.Spec.Ledger.STS.Ppup as STS
 import qualified Shelley.Spec.Ledger.STS.Prtcl as STS (PrtclState)
 import qualified Shelley.Spec.Ledger.STS.Tickn as STS
 import qualified Shelley.Spec.Ledger.STS.Utxow as STS
+import Shelley.Spec.Ledger.Serialization (ToCBORGroup)
 import Shelley.Spec.Ledger.Tx (WitnessSetHKD (WitnessSet), hashScript)
 import Test.QuickCheck (Arbitrary, arbitrary, genericShrink, listOf, oneof, recursivelyShrink, resize, shrink, vectorOf)
 import Test.QuickCheck.Gen (chooseAny)
 import Test.Shelley.Spec.Ledger.ConcreteCryptoTypes (Mock)
 import Test.Shelley.Spec.Ledger.Generator.Constants (defaultConstants)
 import Test.Shelley.Spec.Ledger.Generator.Core
-  ( KeySpace (KeySpace_),
-    PreAlonzo,
-    geKeySpace,
-    ksCoreNodes,
-    mkBlock,
-    mkBlockHeader,
+  ( mkBlockHeader,
     mkOCert,
   )
 import Test.Shelley.Spec.Ledger.Generator.EraGen (EraGen)
-import Test.Shelley.Spec.Ledger.Generator.Presets (coreNodeKeys, genEnv)
-import Test.Shelley.Spec.Ledger.Generator.ScriptClass (ScriptClass)
+import Test.Shelley.Spec.Ledger.Generator.Presets (coreNodeKeys)
 import Test.Shelley.Spec.Ledger.Serialisation.Generators.Bootstrap
   ( genBootstrapAddress,
     genSignature,
@@ -772,12 +766,13 @@ instance
   shrink _ = []
 
 genTx ::
-  ( UsesTxBody era,
-    UsesAuxiliary era,
+  ( Era era,
     Arbitrary (Core.TxBody era),
     Arbitrary (Core.AuxiliaryData era),
-    ToCBOR (Core.Witnesses era),
-    Arbitrary (Core.Witnesses era)
+    Arbitrary (Core.Witnesses era),
+    ToCBOR (Core.AuxiliaryData era), -- for Tx Pattern
+    ToCBOR (Core.TxBody era), -- for Tx Pattern
+    ToCBOR (Core.Witnesses era) -- for Tx Pattern
   ) =>
   Gen (Tx era)
 genTx =
@@ -788,69 +783,35 @@ genTx =
 
 genBlock ::
   forall era.
-  ( UsesTxBody era,
-    UsesAuxiliary era,
-    PreAlonzo era,
-    ScriptClass era,
+  ( Era era,
+    ToCBORGroup (TxSeq era),
     Mock (Crypto era),
-    Arbitrary (Core.Witnesses era),
-    Arbitrary (Core.TxBody era),
-    Arbitrary (Core.AuxiliaryData era)
+    Arbitrary (TxInBlock era)
   ) =>
   Gen (Block era)
-genBlock = do
-  let KeySpace_ {ksCoreNodes} = geKeySpace (genEnv p)
-  prevHash <- arbitrary :: Gen (HashHeader (Crypto era))
-  allPoolKeys <- elements (map snd ksCoreNodes)
-  txs <- listOf (genTx @era)
-  curSlotNo <- SlotNo <$> choose (0, 10)
-  curBlockNo <- BlockNo <$> choose (0, 100)
-  epochNonce <- arbitrary :: Gen Nonce
-  let kesPeriod = 1
-      keyRegKesPeriod = 1
-      ocert = mkOCert allPoolKeys 1 (KESPeriod kesPeriod)
-  return $
-    mkBlock
-      prevHash
-      allPoolKeys
-      txs
-      curSlotNo
-      curBlockNo
-      epochNonce
-      kesPeriod
-      keyRegKesPeriod
-      ocert
-  where
-    p :: Proxy era
-    p = Proxy
+genBlock = Block <$> arbitrary <*> (toTxSeq @era <$> arbitrary)
 
 instance
-  ( UsesTxBody era,
-    UsesScript era,
-    UsesAuxiliary era,
-    PreAlonzo era,
-    Mock (Crypto era),
-    ValidateScript era,
+  ( Era era,
     Arbitrary (Core.TxBody era),
     Arbitrary (Core.Value era),
     Arbitrary (Core.AuxiliaryData era),
-    Arbitrary (Core.Script era)
+    Arbitrary (Core.Script era),
+    Arbitrary (Core.Witnesses era),
+    ToCBOR (Core.AuxiliaryData era), -- for Tx Pattern
+    ToCBOR (Core.TxBody era), -- for Tx Pattern
+    ToCBOR (Core.Witnesses era) -- for Tx Pattern
   ) =>
   Arbitrary (Tx era)
   where
   arbitrary = genTx
 
 instance
   ( UsesTxBody era,
-    UsesAuxiliary era,
-    PreAlonzo era,
-    EraGen era,
+    ToCBORGroup (TxSeq era),
+    SupportsSegWit era,
     Mock (Crypto era),
-    ValidateScript era,
-    Arbitrary (Core.TxBody era),
-    Arbitrary (Core.Value era),
-    Arbitrary (Core.AuxiliaryData era),
-    Arbitrary (Core.Script era)
+    Arbitrary (TxInBlock era)
   ) =>
   Arbitrary (Block era)
   where