Merge pull request #3288 from input-output-hk/lehins/shelley-arbitrary

Shelley arbitrary
IntersectMBO · Feb 10, 2023 · 1c2f8aa · 1c2f8aa
2 parents d85a46a + 6fd538e
commit 1c2f8aa
Show file tree

Hide file tree

Showing 20 changed files with 458 additions and 419 deletions.
diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/PParams.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/PParams.hs
@@ -70,9 +70,7 @@ import qualified Cardano.Ledger.BaseTypes as BT (ProtVer (..))
 import Cardano.Ledger.Binary (
   Encoding,
   FromCBOR (..),
-  FromCBORGroup (..),
   ToCBOR (..),
-  ToCBORGroup (..),
   encodeFoldableAsDefLenList,
   encodeFoldableAsIndefLenList,
   encodeMapLen,
@@ -303,7 +301,7 @@ instance Era era => ToCBOR (AlonzoPParams Identity era) where
           !> To appTau
           !> To appD
           !> To appExtraEntropy
-          !> E toCBORGroup appProtocolVersion
+          !> To appProtocolVersion
           !> To appMinPoolCost
           -- new/updated for alonzo
           !> To appCoinsPerUTxOWord
@@ -333,7 +331,7 @@ instance Era era => FromCBOR (AlonzoPParams Identity era) where
         <! From -- appTau
         <! From -- appD
         <! From -- appExtraEntropy
-        <! D fromCBORGroup -- appProtocolVersion
+        <! From -- appProtocolVersion
         <! From -- appMinPoolCost
         -- new/updated for alonzo
         <! From -- appCoinsPerUTxOWord

diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Translation.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Translation.hs
@@ -71,12 +71,7 @@ instance Crypto c => TranslateEra (AlonzoEra c) Core.PParams where
 
 newtype Tx era = Tx {unTx :: Core.Tx era}
 
-instance
-  ( Crypto c
-  , Core.Tx (AlonzoEra c) ~ AlonzoTx (AlonzoEra c)
-  ) =>
-  TranslateEra (AlonzoEra c) Tx
-  where
+instance Crypto c => TranslateEra (AlonzoEra c) Tx where
   type TranslationError (AlonzoEra c) Tx = DecoderError
   translateEra _ctxt (Tx tx) = do
     -- Note that this does not preserve the hidden bytes field of the transaction.

diff --git a/eras/alonzo/test-suite/src/Test/Cardano/Ledger/Alonzo/Serialisation/Generators.hs b/eras/alonzo/test-suite/src/Test/Cardano/Ledger/Alonzo/Serialisation/Generators.hs
@@ -180,7 +180,7 @@ instance
       <*> arbitrary
 
 instance
-  (EraTxOut era, Arbitrary (TxOut era), Mock (EraCrypto era)) =>
+  (EraTxOut era, Arbitrary (TxOut era), Mock (EraCrypto era), Arbitrary (PParamsUpdate era)) =>
   Arbitrary (AlonzoTxBody era)
   where
   arbitrary =

diff --git a/eras/alonzo/test-suite/test/Test/Cardano/Ledger/Alonzo/Serialisation/Tripping.hs b/eras/alonzo/test-suite/test/Test/Cardano/Ledger/Alonzo/Serialisation/Tripping.hs
@@ -35,12 +35,16 @@ tests =
   testGroup
     "Alonzo CBOR round-trip"
     [ testProperty "alonzo/Script" $
-        roundTripAnnExpectation @(Script Alonzo)
+        roundTripAnnRangeExpectation @(Script Alonzo)
+          (eraProtVerLow @Alonzo)
+          (eraProtVerHigh @Alonzo)
     , skip $
         testProperty "alonzo/Script twiddled" $
           roundTripAnnTwiddledProperty @(Script Alonzo) eqAlonzoScriptRaw
     , testProperty "alonzo/Data" $
-        roundTripAnnExpectation @(Data Alonzo)
+        roundTripAnnRangeExpectation @(Data Alonzo)
+          (eraProtVerLow @Alonzo)
+          (eraProtVerHigh @Alonzo)
     , skip $
         testProperty "alonzo/Data twiddled" $
           roundTripAnnTwiddledProperty @(Data Alonzo) (zipMemoRawType (===))
@@ -50,11 +54,17 @@ tests =
         testProperty "alonzo/BinaryData twiddled" $
           roundTripTwiddledProperty @(BinaryData Alonzo)
     , testProperty "alonzo/TxAuxData" $
-        roundTripAnnExpectation @(ShelleyTxAuxData Alonzo)
+        roundTripAnnRangeExpectation @(ShelleyTxAuxData Alonzo)
+          (eraProtVerLow @Alonzo)
+          (eraProtVerHigh @Alonzo)
     , testProperty "alonzo/AlonzoTxWits" $
-        roundTripAnnExpectation @(AlonzoTxWits Alonzo)
+        roundTripAnnRangeExpectation @(AlonzoTxWits Alonzo)
+          (eraProtVerLow @Alonzo)
+          (eraProtVerHigh @Alonzo)
     , testProperty "alonzo/TxBody" $
-        roundTripAnnExpectation @(TxBody Alonzo)
+        roundTripAnnRangeExpectation @(TxBody Alonzo)
+          (eraProtVerLow @Alonzo)
+          (eraProtVerHigh @Alonzo)
     , skip $
         testProperty "alonzo/TxBody twiddled" $
           roundTripAnnTwiddledProperty @(TxBody Alonzo) (zipMemoRawType (===))
@@ -65,19 +75,25 @@ tests =
     , testProperty "alonzo/PParamsUpdate" $
         roundTripCborExpectation @(PParamsUpdate Alonzo)
     , testProperty "alonzo/AuxiliaryData" $
-        roundTripAnnExpectation @(TxAuxData Alonzo)
+        roundTripAnnRangeExpectation @(TxAuxData Alonzo)
+          (eraProtVerLow @Alonzo)
+          (eraProtVerHigh @Alonzo)
     , testProperty "alonzo/AlonzoUtxowPredFailure" $
         roundTripCborExpectation @(AlonzoUtxowPredFailure Alonzo)
     , testProperty "alonzo/AlonzoUtxoPredFailure" $
         roundTripCborExpectation @(AlonzoUtxoPredFailure Alonzo)
     , testProperty "alonzo/AlonzoUtxosPredFailure" $
         roundTripCborExpectation @(AlonzoUtxosPredFailure Alonzo)
     , testProperty "Script" $
-        roundTripAnnExpectation @(Script Alonzo)
+        roundTripAnnRangeExpectation @(Script Alonzo)
     , testProperty "alonzo/Tx" $
-        roundTripAnnExpectation @(Tx Alonzo)
+        roundTripAnnRangeExpectation @(Tx Alonzo)
+          (eraProtVerLow @Alonzo)
+          (eraProtVerHigh @Alonzo)
     , testProperty "alonzo/Block" $
-        roundTripAnnExpectation @(Block (BHeader StandardCrypto) Alonzo)
+        roundTripAnnRangeExpectation @(Block (BHeader StandardCrypto) Alonzo)
+          (eraProtVerLow @Alonzo)
+          (eraProtVerHigh @Alonzo)
     ]
   where
     skip _ = testProperty "Test skipped" True
diff --git a/eras/alonzo/test-suite/test/Test/Cardano/Ledger/Alonzo/Translation.hs b/eras/alonzo/test-suite/test/Test/Cardano/Ledger/Alonzo/Translation.hs
@@ -14,31 +14,27 @@ module Test.Cardano.Ledger.Alonzo.Translation (
 where
 
 import Cardano.Ledger.Alonzo (Alonzo)
-import Cardano.Ledger.Alonzo.Genesis (AlonzoGenesis (..))
-import qualified Cardano.Ledger.Alonzo.Translation as Translation (Tx (..))
-import Cardano.Ledger.Alonzo.Tx (toCBORForSizeComputation)
-import Cardano.Ledger.Binary (ToCBOR (..))
-import Cardano.Ledger.Core
+import Cardano.Ledger.BaseTypes hiding ((==>))
 import Cardano.Ledger.Mary (Mary)
-import qualified Cardano.Ledger.Shelley.API as API
-import Data.Typeable (Typeable)
+import Cardano.Ledger.Shelley.Core
+import Cardano.Ledger.Shelley.PParams
+import Lens.Micro
 import Test.Cardano.Ledger.AllegraEraGen ()
 import Test.Cardano.Ledger.Binary.RoundTrip
 import Test.Cardano.Ledger.Shelley.Generator.ShelleyEraGen ()
 import Test.Cardano.Ledger.Shelley.Serialisation.EraIndepGenerators ()
 import Test.Cardano.Ledger.Shelley.Serialisation.Generators ()
 import Test.Cardano.Ledger.ShelleyMA.Serialisation.Generators ()
-import Test.Cardano.Ledger.TranslationTools
+import Test.QuickCheck ((==>))
+import Test.QuickCheck.Monadic
 import Test.Tasty (TestTree, testGroup)
-import Test.Tasty.HUnit (Assertion)
-import Test.Tasty.QuickCheck (Arbitrary, testProperty)
+import Test.Tasty.QuickCheck (testProperty)
 
 tests :: TestTree
 tests =
   testGroup
     "Translation"
-    [ alonzoTranslationTests
-    , alonzoEncodeDecodeTests
+    [ alonzoEncodeDecodeTests
     ]
 
 alonzoEncodeDecodeTests :: TestTree
@@ -50,59 +46,24 @@ alonzoEncodeDecodeTests =
           (eraProtVerLow @Mary)
           (eraProtVerLow @Alonzo)
           (\_ _ -> pure ())
-    , testProperty "decoding txbody" $
-        embedTripAnnExpectation @(TxBody Mary) @(TxBody Alonzo)
-          (eraProtVerLow @Mary)
-          (eraProtVerLow @Alonzo)
-          (\_ _ -> pure ())
+    , testProperty "decoding txbody" $ \txBody ->
+        let hasDeprecatedField =
+              case txBody ^. updateTxBodyL of
+                SNothing -> False
+                SJust (Update (ProposedPPUpdates ups) _) ->
+                  any (\ppu -> isSJust (ppu ^. ppuMinUTxOValueL)) ups
+         in not hasDeprecatedField ==>
+              monadicIO
+                ( run $
+                    embedTripAnnExpectation @(TxBody Mary) @(TxBody Alonzo)
+                      (eraProtVerLow @Mary)
+                      (eraProtVerLow @Alonzo)
+                      (\_ _ -> pure ())
+                      txBody
+                )
     , testProperty "decoding witnesses" $
         embedTripAnnExpectation @(TxWits Mary) @(TxWits Alonzo)
           (eraProtVerLow @Mary)
           (eraProtVerLow @Alonzo)
           (\_ _ -> pure ())
     ]
-
-alonzoTranslationTests :: TestTree
-alonzoTranslationTests =
-  testGroup
-    "Alonzo translation binary compatibiliby tests"
-    [ testProperty "Tx compatibility" testTx
-    , testProperty "ProposedPPUpdates compatibility" (test @API.ProposedPPUpdates)
-    , testProperty "ShelleyPPUPState compatibility" (test @API.ShelleyPPUPState)
-    , testProperty "UTxO compatibility" (test @API.UTxO)
-    , testProperty "UTxOState compatibility" (test @API.UTxOState)
-    , testProperty "LedgerState compatibility" (test @API.LedgerState)
-    ]
-
-deriving newtype instance
-  (Arbitrary (Tx era)) =>
-  Arbitrary (Translation.Tx era)
-
-deriving newtype instance
-  (Typeable era, ToCBOR (Tx era)) =>
-  ToCBOR (Translation.Tx era)
-
-deriving newtype instance
-  (Show (Tx era)) =>
-  Show (Translation.Tx era)
-
-dummyAlonzoGenesis :: AlonzoGenesis
-dummyAlonzoGenesis = error "Undefined AlonzoGenesis"
-
-test ::
-  forall f.
-  ( ToCBOR (f Mary)
-  , ToCBOR (f Alonzo)
-  , TranslateEra Alonzo f
-  , Show (TranslationError Alonzo f)
-  ) =>
-  f Mary ->
-  Assertion
-test = translateEraToCBOR ([] :: [Alonzo]) dummyAlonzoGenesis
-
-testTx :: Translation.Tx Mary -> Assertion
-testTx =
-  translateEraEncoding @Alonzo
-    dummyAlonzoGenesis
-    (toCBORForSizeComputation . Translation.unTx)
-    toCBOR
diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Translation.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Translation.hs
@@ -30,6 +30,7 @@ import Cardano.Ledger.Shelley.API (
  )
 import qualified Cardano.Ledger.Shelley.API as API
 import qualified Data.Map.Strict as Map
+import Lens.Micro
 
 --------------------------------------------------------------------------------
 -- Translation from Alonzo to Babbage
@@ -66,23 +67,18 @@ instance
 
 newtype Tx era = Tx {unTx :: Core.Tx era}
 
-instance
-  ( Crypto c
-  , Tx (BabbageEra c) ~ AlonzoTx (BabbageEra c)
-  ) =>
-  TranslateEra (BabbageEra c) Tx
-  where
+instance Crypto c => TranslateEra (BabbageEra c) Tx where
   type TranslationError (BabbageEra c) Tx = DecoderError
   translateEra _ctxt (Tx tx) = do
     -- Note that this does not preserve the hidden bytes field of the transaction.
     -- This is under the premise that this is irrelevant for TxInBlocks, which are
     -- not transmitted as contiguous chunks.
-    txBody <- translateEraThroughCBOR "TxBody" $ Alonzo.body tx
-    txWits <- translateEraThroughCBOR "TxWitness" $ Alonzo.wits tx
-    auxData <- case Alonzo.auxiliaryData tx of
+    txBody <- translateEraThroughCBOR "TxBody" $ tx ^. bodyTxL
+    txWits <- translateEraThroughCBOR "TxWitness" $ tx ^. witsTxL
+    auxData <- case tx ^. auxDataTxL of
       SNothing -> pure SNothing
       SJust auxData -> SJust <$> translateEraThroughCBOR "AuxData" auxData
-    let validating = Alonzo.isValid tx
+    let validating = tx ^. Alonzo.isValidTxL
     pure $ Tx $ AlonzoTx txBody txWits validating auxData
 
 --------------------------------------------------------------------------------

diff --git a/eras/babbage/test-suite/src/Test/Cardano/Ledger/Babbage/Serialisation/Generators.hs b/eras/babbage/test-suite/src/Test/Cardano/Ledger/Babbage/Serialisation/Generators.hs
@@ -59,6 +59,7 @@ instance
   , Arbitrary (TxOut era)
   , Arbitrary (Value era)
   , Arbitrary (Script era)
+  , Arbitrary (PParamsUpdate era)
   ) =>
   Arbitrary (BabbageTxBody era)
   where

diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Translation.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Translation.hs
@@ -15,15 +15,14 @@ module Cardano.Ledger.Conway.Translation where
 
 import Cardano.Ledger.Allegra.Scripts (translateTimelock)
 import Cardano.Ledger.Alonzo.Scripts (AlonzoScript (..))
-import qualified Cardano.Ledger.Alonzo.Tx as Alonzo
+import Cardano.Ledger.Alonzo.Tx (AlonzoEraTx (..))
 import Cardano.Ledger.Babbage (BabbageEra)
-import Cardano.Ledger.Babbage.Tx (AlonzoTx (..))
 import Cardano.Ledger.Babbage.TxBody (BabbageTxOut (..), Datum (..))
 import Cardano.Ledger.Binary (DecoderError)
+import Cardano.Ledger.Conway.Core hiding (Tx)
 import Cardano.Ledger.Conway.Era (ConwayEra)
 import Cardano.Ledger.Conway.Scripts ()
 import Cardano.Ledger.Conway.Tx ()
-import Cardano.Ledger.Core hiding (Tx)
 import qualified Cardano.Ledger.Core as Core (Tx)
 import Cardano.Ledger.Crypto (Crypto)
 import Cardano.Ledger.Shelley.API (
@@ -35,9 +34,9 @@ import Cardano.Ledger.Shelley.API (
   UTxOState (..),
  )
 import qualified Cardano.Ledger.Shelley.API as API
-import Cardano.Ledger.Shelley.Core hiding (Tx)
 import Data.Coerce
 import qualified Data.Map.Strict as Map
+import Lens.Micro
 
 --------------------------------------------------------------------------------
 -- Translation from Babbage to Conway
@@ -71,24 +70,24 @@ instance Crypto c => TranslateEra (ConwayEra c) NewEpochState where
 
 newtype Tx era = Tx {unTx :: Core.Tx era}
 
-instance
-  ( Crypto c
-  , Tx (ConwayEra c) ~ AlonzoTx (ConwayEra c)
-  ) =>
-  TranslateEra (ConwayEra c) Tx
-  where
+instance Crypto c => TranslateEra (ConwayEra c) Tx where
   type TranslationError (ConwayEra c) Tx = DecoderError
   translateEra _ctxt (Tx tx) = do
     -- Note that this does not preserve the hidden bytes field of the transaction.
     -- This is under the premise that this is irrelevant for TxInBlocks, which are
     -- not transmitted as contiguous chunks.
-    txBody <- translateEraThroughCBOR "TxBody" $ Alonzo.body tx
-    txWits <- translateEraThroughCBOR "TxWitness" $ Alonzo.wits tx
-    auxData <- case Alonzo.auxiliaryData tx of
+    txBody <- translateEraThroughCBOR "TxBody" $ tx ^. bodyTxL
+    txWits <- translateEraThroughCBOR "TxWitness" $ tx ^. witsTxL
+    auxData <- case tx ^. auxDataTxL of
       SNothing -> pure SNothing
       SJust auxData -> SJust <$> translateEraThroughCBOR "AuxData" auxData
-    let validating = Alonzo.isValid tx
-    pure $ Tx $ AlonzoTx txBody txWits validating auxData
+    let isValidTx = tx ^. isValidTxL
+        newTx =
+          mkBasicTx txBody
+            & witsTxL .~ txWits
+            & isValidTxL .~ isValidTx
+            & auxDataTxL .~ auxData
+    pure $ Tx newTx
 
 --------------------------------------------------------------------------------
 -- Auxiliary instances and functions

diff --git a/eras/shelley-ma/test-suite/src/Test/Cardano/Ledger/ShelleyMA/Serialisation/Generators.hs b/eras/shelley-ma/test-suite/src/Test/Cardano/Ledger/ShelleyMA/Serialisation/Generators.hs
@@ -140,7 +140,7 @@ instance
   arbitrary = genericArbitraryU
 
 instance
-  (EraTxOut era, Mock (EraCrypto era), Arbitrary (TxOut era)) =>
+  (EraTxOut era, Mock (EraCrypto era), Arbitrary (TxOut era), Arbitrary (PParamsUpdate era)) =>
   Arbitrary (AllegraTxBody era)
   where
   arbitrary =
@@ -159,7 +159,7 @@ instance
 -------------------------------------------------------------------------------}
 
 instance
-  (EraTxOut era, Mock (EraCrypto era), Arbitrary (TxOut era)) =>
+  (EraTxOut era, Mock (EraCrypto era), Arbitrary (TxOut era), Arbitrary (PParamsUpdate era)) =>
   Arbitrary (MaryTxBody era)
   where
   arbitrary =

diff --git a/eras/shelley-ma/test-suite/src/Test/Cardano/Ledger/TranslationTools.hs b/eras/shelley-ma/test-suite/src/Test/Cardano/Ledger/TranslationTools.hs
@@ -17,7 +17,7 @@ import Cardano.Ledger.Binary (
   serializeEncoding',
  )
 import Cardano.Ledger.Core
-import Cardano.Ledger.TreeDiff (diffExpr)
+import Cardano.Ledger.TreeDiff (diffExprNoColor)
 import Control.Monad
 import Control.Monad.Except (runExcept)
 import GHC.Stack
@@ -55,7 +55,7 @@ translateEraEncoding tc encodeThisEra encodePreviousEra x =
         serializeEncoding' (eraProtVerLow @era) (encodeThisEra $ translateEraPartial @era tc x)
    in unless (previousEra == currentEra) $
         assertFailure $
-          diffExpr (CBORBytes previousEra) (CBORBytes currentEra)
+          diffExprNoColor (CBORBytes previousEra) (CBORBytes currentEra)
 
 -- Tests that the serializing before translation or after translating
 -- does not change the result