Added custom generator to address, enabled some Huddle tests

eras/conway/impl/test/Test/Cardano/Ledger/Conway/Binary/CddlSpec.hs

@@ -15,11 +15,13 @@ import Cardano.Ledger.Conway.Governance (GovAction, ProposalProcedure, VotingPro
 import Cardano.Ledger.Conway.HuddleSpec (conwayCDDL)
 import Cardano.Ledger.Core
 import Cardano.Ledger.Plutus.Data (Data, Datum)
+import Test.Cardano.Ledger.Alonzo.Arbitrary (genNonEmptyRedeemers)
 import Test.Cardano.Ledger.Binary.Cuddle (
   huddleDecoderEquivalenceSpec,
   huddleRoundTripAnnCborSpec,
   huddleRoundTripArbitraryValidate,
   huddleRoundTripCborSpec,
+  huddleRoundTripGenValidate,
   specWithHuddle,
  )
 import Test.Cardano.Ledger.Common
@@ -38,7 +40,8 @@ spec = do
       -- TxBody
       huddleRoundTripAnnCborSpec @(TxBody TopTx ConwayEra) v "transaction_body"
       -- TODO enable this once map/list expansion has been optimized in cuddle
-      xdescribe "hangs" $ huddleRoundTripArbitraryValidate @(TxBody TopTx ConwayEra) v "transaction_body"
+      xdescribe "fix scripts" $
+        huddleRoundTripArbitraryValidate @(TxBody TopTx ConwayEra) v "transaction_body"
       huddleRoundTripCborSpec @(TxBody TopTx ConwayEra) v "transaction_body"
       -- AuxData
       huddleRoundTripAnnCborSpec @(TxAuxData ConwayEra) v "auxiliary_data"
@@ -57,7 +60,7 @@ spec = do
       -- TxOut
       huddleRoundTripCborSpec @(TxOut ConwayEra) v "transaction_output"
       -- TODO fails because of `address`
-      xdescribe "fix address" $ huddleRoundTripArbitraryValidate @(TxOut ConwayEra) v "transaction_output"
+      xdescribe "fix scripts" $ huddleRoundTripArbitraryValidate @(TxOut ConwayEra) v "transaction_output"
       -- Script
       huddleRoundTripAnnCborSpec @(Script ConwayEra) v "script"
       -- TODO fails because of `plutus_v1_script`
@@ -75,16 +78,13 @@ spec = do
       huddleRoundTripCborSpec @(TxWits ConwayEra) v "transaction_witness_set"
       -- PParamsUpdate
       huddleRoundTripCborSpec @(PParamsUpdate ConwayEra) v "protocol_param_update"
-      -- TODO enable this once map/list expansion has been optimized in cuddle
-      xdescribe "hangs" $
-        huddleRoundTripArbitraryValidate @(PParamsUpdate ConwayEra) v "protocol_param_update"
+      huddleRoundTripArbitraryValidate @(PParamsUpdate ConwayEra) v "protocol_param_update"
       -- CostModels
       huddleRoundTripCborSpec @CostModels v "cost_models"
       huddleRoundTripArbitraryValidate @CostModels v "cost_models"
       -- Redeemers
       huddleRoundTripAnnCborSpec @(Redeemers ConwayEra) v "redeemers"
-      -- TODO arbitrary can generate empty redeemers, which is not allowed in the CDDL
-      xdescribe "fix redeemers" $ huddleRoundTripArbitraryValidate @(Redeemers ConwayEra) v "redeemers"
+      huddleRoundTripGenValidate @(Redeemers ConwayEra) genNonEmptyRedeemers v "redeemers"
       huddleRoundTripCborSpec @(Redeemers ConwayEra) v "redeemers"
       -- Tx
       huddleRoundTripAnnCborSpec @(Tx TopTx ConwayEra) v "transaction"
@@ -96,17 +96,13 @@ spec = do
       huddleRoundTripArbitraryValidate @(VotingProcedure ConwayEra) v "voting_procedure"
       -- ProposalProcedure
       huddleRoundTripCborSpec @(ProposalProcedure ConwayEra) v "proposal_procedure"
-      -- TODO This fails because of the hard-coded `reward_account` in the CDDL
-      xdescribe "fix reward_account" $
-        huddleRoundTripArbitraryValidate @(ProposalProcedure ConwayEra) v "proposal_procedure"
+      huddleRoundTripArbitraryValidate @(ProposalProcedure ConwayEra) v "proposal_procedure"
       -- GovAction
       huddleRoundTripCborSpec @(GovAction ConwayEra) v "gov_action"
-      -- TODO enable this once map/list expansion has been optimized in cuddle
-      xdescribe "hangs" $ huddleRoundTripArbitraryValidate @(GovAction ConwayEra) v "gov_action"
+      huddleRoundTripArbitraryValidate @(GovAction ConwayEra) v "gov_action"
       -- TxCert
       huddleRoundTripCborSpec @(TxCert ConwayEra) v "certificate"
-      -- TODO this fails because of the hard-coded `unit_interval` in the CDDL
-      xdescribe "fix unit_interval" $ huddleRoundTripArbitraryValidate @(TxCert ConwayEra) v "certificate"
+      huddleRoundTripArbitraryValidate @(TxCert ConwayEra) v "certificate"
       describe "DecCBOR instances equivalence via CDDL" $ do
         huddleDecoderEquivalenceSpec @(TxBody TopTx ConwayEra) v "transaction_body"
         huddleDecoderEquivalenceSpec @(TxAuxData ConwayEra) v "auxiliary_data"

eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs

@@ -37,7 +37,7 @@ module Test.Cardano.Ledger.Conway.Arbitrary (
 ) where
 
 import Cardano.Ledger.Alonzo.Plutus.Evaluate (CollectError)
-import Cardano.Ledger.BaseTypes (StrictMaybe (..))
+import Cardano.Ledger.BaseTypes (ProtVer (..), StrictMaybe (..))
 import Cardano.Ledger.Conway (ApplyTxError (ConwayApplyTxError), ConwayEra, Tx (..))
 import Cardano.Ledger.Conway.Core
 import Cardano.Ledger.Conway.Genesis (ConwayGenesis (..))
@@ -505,8 +505,11 @@ instance
 genParameterChange :: Arbitrary (PParamsUpdate era) => Gen (GovAction era)
 genParameterChange = ParameterChange <$> arbitrary <*> arbitrary <*> arbitrary
 
-genHardForkInitiation :: Gen (GovAction era)
-genHardForkInitiation = HardForkInitiation <$> arbitrary <*> arbitrary
+genHardForkInitiation :: forall era. Era era => Gen (GovAction era)
+genHardForkInitiation =
+  HardForkInitiation
+    <$> arbitrary
+    <*> (ProtVer <$> elements [eraProtVerLow @era .. succ $ eraProtVerHigh @era] <*> arbitrary)
 
 genTreasuryWithdrawals :: Gen (GovAction era)
 genTreasuryWithdrawals = TreasuryWithdrawals <$> arbitrary <*> arbitrary

eras/dijkstra/impl/test/Test/Cardano/Ledger/Dijkstra/Binary/CddlSpec.hs

@@ -51,10 +51,8 @@ spec = do
       huddleRoundTripAnnCborSpec @(Data DijkstraEra) v "plutus_data"
       huddleRoundTripArbitraryValidate @(Data DijkstraEra) v "plutus_data"
       huddleRoundTripCborSpec @(Data DijkstraEra) v "plutus_data"
-      xdescribe "fix TxOut" $ do
+      xdescribe "fix Script" $ do
         huddleRoundTripCborSpec @(TxOut DijkstraEra) v "transaction_output"
-      -- TODO fails because of `address`
-      xdescribe "fix address" $
         huddleRoundTripArbitraryValidate @(TxOut DijkstraEra) v "transaction_output"
       xdescribe "fix Script" $ do
         huddleRoundTripAnnCborSpec @(Script DijkstraEra) v "script"
@@ -90,16 +88,13 @@ spec = do
       huddleRoundTripArbitraryValidate @(VotingProcedure DijkstraEra) v "voting_procedure"
       huddleRoundTripCborSpec @(ProposalProcedure DijkstraEra) v "proposal_procedure"
       -- TODO This fails because of the hard-coded `reward_account` in the CDDL
-      xdescribe "fix reward_account" $
-        huddleRoundTripArbitraryValidate @(ProposalProcedure DijkstraEra) v "proposal_procedure"
+      huddleRoundTripArbitraryValidate @(ProposalProcedure DijkstraEra) v "proposal_procedure"
       huddleRoundTripCborSpec @(GovAction DijkstraEra) v "gov_action"
       -- TODO enable this once map/list expansion has been optimized in cuddle
-      xdescribe "hangs" $ huddleRoundTripArbitraryValidate @(GovAction DijkstraEra) v "gov_action"
-      describe "TxCert" $ do
+      huddleRoundTripArbitraryValidate @(GovAction DijkstraEra) v "gov_action"
+      describe "fix TxCert" $ do
         huddleRoundTripCborSpec @(TxCert DijkstraEra) v "certificate"
-      -- TODO this fails because of the hard-coded `unit_interval` in the CDDL
-      xdescribe "fix unit_interval" $
-        huddleRoundTripArbitraryValidate @(TxCert DijkstraEra) v "certificate"
+      huddleRoundTripArbitraryValidate @(TxCert DijkstraEra) v "certificate"
       describe "DecCBOR instances equivalence via CDDL" $ do
         huddleDecoderEquivalenceSpec @(TxBody TopTx DijkstraEra) v "transaction_body"
         xdescribe "Fix decoder equivalence of TxAuxData" $ do

eras/shelley/impl/cardano-ledger-shelley.cabal

@@ -272,6 +272,5 @@ test-suite tests
     base,
     cardano-ledger-binary:testlib,
     cardano-ledger-core:{cardano-ledger-core, testlib},
-    cardano-ledger-shelley,
-    cardano-ledger-shelley:cddl,
+    cardano-ledger-shelley:{cardano-ledger-shelley, cddl},
     testlib,

eras/shelley/impl/test/Test/Cardano/Ledger/Shelley/Binary/CddlSpec.hs

@@ -33,8 +33,7 @@ spec =
     let v = eraProtVerLow @ShelleyEra
     specWithHuddle shelleyCDDL 100 $ do
       huddleRoundTripCborSpec @Addr v "address"
-      -- TODO re-enable this once we've removed the hard-coded definition for `address`
-      xdescribe "bad CDDL" $ huddleRoundTripArbitraryValidate @Addr v "address"
+      huddleRoundTripArbitraryValidate @Addr v "address"
       huddleRoundTripAnnCborSpec @BootstrapWitness v "bootstrap_witness"
       huddleRoundTripArbitraryValidate @BootstrapWitness v "bootstrap_witness"
       huddleRoundTripCborSpec @BootstrapWitness v "bootstrap_witness"

libs/cardano-ledger-binary/CHANGELOG.md

@@ -18,6 +18,7 @@
 
 ### `testlib`
 
+* Add `huddleRoundTripGenValidate`
 * Remove `Test.Cardano.Ledger.Binary.Cddl`
 * Add `ToExpr` instances to `DeserialiseFailure` and `DecoderError`
 * Remove `assertExprEqualWithMessage`

libs/cardano-ledger-binary/testlib/Test/Cardano/Ledger/Binary/Cuddle.hs

@@ -14,6 +14,7 @@ module Test.Cardano.Ledger.Binary.Cuddle (
   huddleRoundTripCborSpec,
   huddleRoundTripAnnCborSpec,
   writeSpec,
+  huddleRoundTripGenValidate,
   huddleRoundTripArbitraryValidate,
 ) where
 
@@ -71,7 +72,7 @@ import Test.Hspec (
   shouldBe,
  )
 import Test.Hspec.Core.Spec (Example (..), paramsQuickCheckArgs)
-import Test.QuickCheck (Arbitrary (..), Args (replay), Testable (..))
+import Test.QuickCheck (Arbitrary (..), Args (replay), Gen, Testable (..), forAll)
 import Test.QuickCheck.Random (QCGen, mkQCGen)
 import Text.Pretty.Simple (pShow)
 
@@ -237,21 +238,13 @@ cddlFailure encoding err =
       , "Generated diag: " <> CBOR.prettyHexEnc encoding
       ]
 
-huddleRoundTripArbitraryValidate ::
-  forall a.
-  ( DecCBOR a
-  , EncCBOR a
-  , Arbitrary a
-  , Show a
-  ) =>
-  Version ->
-  T.Text ->
-  SpecWith CuddleData
-huddleRoundTripArbitraryValidate version ruleName =
+huddleRoundTripGenValidate ::
+  forall a. (DecCBOR a, Show a, EncCBOR a) => Gen a -> Version -> T.Text -> SpecWith CuddleData
+huddleRoundTripGenValidate gen version ruleName =
   let lbl = label $ Proxy @a
    in describe "Encode an arbitrary value and check against CDDL"
         . it (T.unpack ruleName <> ": " <> T.unpack lbl)
-        $ \CuddleData {cddl} -> property $ \(val :: a) -> do
+        $ \CuddleData {cddl} -> property . forAll gen $ \(val :: a) -> do
           let
             bs = serialize' version val
             res = validateCBOR bs (Name ruleName) (mapIndex cddl)
@@ -280,6 +273,18 @@ huddleRoundTripArbitraryValidate version ruleName =
                           ]
                   _ -> pretty $ pShow err
 
+huddleRoundTripArbitraryValidate ::
+  forall a.
+  ( DecCBOR a
+  , EncCBOR a
+  , Arbitrary a
+  , Show a
+  ) =>
+  Version ->
+  T.Text ->
+  SpecWith CuddleData
+huddleRoundTripArbitraryValidate = huddleRoundTripGenValidate $ arbitrary @a
+
 --------------------------------------------------------------------------------
 -- Writing specs to a file
 --------------------------------------------------------------------------------

libs/cardano-ledger-core/CHANGELOG.md

@@ -127,6 +127,7 @@
 
 ### `cddl`
 
+* Add `pickOne`, `genBytesTerm`, `genStringTerm`, `genArrayTerm`
 * Re-export necessary functionality from `cuddle` for use in the eras, crucially hiding `(=:=)` and `(=:~)`.
 * Change `HuddleRule` and related typeclasses to imply their name using the type-level string via a `Proxy`.
 * Add `HuddleRule1` typeclass.

libs/cardano-ledger-core/cardano-ledger-core.cabal

@@ -184,9 +184,14 @@ library cddl
 
   build-depends:
     base,
+    bytestring,
+    cardano-ledger-binary,
     cardano-ledger-core,
+    cborg,
     cuddle >=1.1,
     heredoc,
+    mempack,
+    random,
     text,
 
 library testlib

libs/cardano-ledger-core/cddl/Cardano/Ledger/Core/HuddleSpec.hs

@@ -1,9 +1,11 @@
+{-# LANGUAGE BinaryLiterals #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MonoLocalBinds #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
@@ -18,10 +20,21 @@ import Cardano.Ledger.BaseTypes (getVersion)
 import Cardano.Ledger.Core (ByronEra, eraProtVerHigh, eraProtVerLow)
 import Cardano.Ledger.Huddle
 import Codec.CBOR.Cuddle.CDDL (Name (..))
+import Codec.CBOR.Cuddle.CDDL.CBORGenerator (WrappedTerm (..))
 import Codec.CBOR.Cuddle.Huddle
+import Codec.CBOR.Term (Term (..))
+import Control.Monad (join, replicateM)
+import Data.Bits (Bits (..))
+import qualified Data.ByteString as BS
+import Data.MemPack (VarLen (..), packByteString)
 import Data.Proxy (Proxy (..))
 import qualified Data.Text as T
-import Data.Word (Word64)
+import Data.Word (Word32, Word64)
+import System.Random.Stateful (
+  Uniform (..),
+  UniformRange (..),
+  uniformByteStringM,
+ )
 import Text.Heredoc
 import Prelude hiding ((/))
 
@@ -46,9 +59,7 @@ instance Era era => HuddleRule "positive_word32" era where
 instance Era era => HuddleRule "unit_interval" era where
   huddleRuleNamed pname _ =
     comment
-      [str|The real unit_interval is: #6.30([uint, uint])
-          |
-          |A unit interval is a number in the range between 0 and 1, which
+      [str|A unit interval is a number in the range between 0 and 1, which
           |means there are two extra constraints:
           |  1. numerator <= denominator
           |  2. denominator > 0
@@ -61,8 +72,25 @@ instance Era era => HuddleRule "unit_interval" era where
           |our encoders/decoders. Which means we cannot use the actual
           |definition here and we hard code the value to 1/2
           |]
-      $ pname
-        =.= tag 30 (arr [1, 2])
+      . withGenerator generator
+      $ pname =.= tag 30 (arr [a VUInt, a VUInt])
+    where
+      generator g = do
+        let genUnitInterval64 l u = do
+              d <- max 1 <$> uniformRM (l, u) g
+              n <- uniformRM (l, d) g
+              pure (n, d)
+            max64 = toInteger (maxBound @Word64)
+        (n, d) <-
+          join $
+            pickOne
+              [ genUnitInterval64 0 max64
+              , genUnitInterval64 0 1000
+              , genUnitInterval64 (max64 - 1000) max64
+              ]
+              g
+        S . TTagged 30
+          <$> genArrayTerm [TInteger $ toInteger n, TInteger $ toInteger d] g
 
 instance Era era => HuddleRule "nonnegative_interval" era where
   huddleRuleNamed pname p =
@@ -150,9 +178,7 @@ instance Era era => HuddleRule "positive_coin" era where
 instance Era era => HuddleRule "address" era where
   huddleRuleNamed pname _ =
     comment
-      [str|address = bytes
-          |
-          |address format:
+      [str|address format:
           |  [ 8 bit header | payload ];
           |
           |shelley payment addresses:
@@ -183,27 +209,46 @@ instance Era era => HuddleRule "address" era where
           |     1111: account address: scripthash28
           |1001-1101: future formats
           |]
-      $ pname
-        =.= bstr
-          "001000000000000000000000000000000000000000000000000000000011000000000000000000000000000000000000000000000000000000"
-        / bstr
-          "102000000000000000000000000000000000000000000000000000000022000000000000000000000000000000000000000000000000000000"
-        / bstr
-          "203000000000000000000000000000000000000000000000000000000033000000000000000000000000000000000000000000000000000000"
-        / bstr
-          "304000000000000000000000000000000000000000000000000000000044000000000000000000000000000000000000000000000000000000"
-        / bstr "405000000000000000000000000000000000000000000000000000000087680203"
-        / bstr "506000000000000000000000000000000000000000000000000000000087680203"
-        / bstr "6070000000000000000000000000000000000000000000000000000000"
-        / bstr "7080000000000000000000000000000000000000000000000000000000"
+      . withGenerator generator
+      $ pname =.= VBytes
+    where
+      generator g = do
+        stakeRef <- uniformRM (0, 0b11) g
+        let
+          stakeRefMask = stakeRef `shiftL` 5 -- 0b0xx00000
+          mkMask mask isMask = if isMask then mask else 0
+        isPaymentScriptMask <- mkMask 0b00010000 <$> uniformM g
+        isMainnetMask <- mkMask 0b00000001 <$> uniformM g
+        let
+          header = stakeRefMask .|. isPaymentScriptMask .|. isMainnetMask
+          genHash28 = uniformByteStringM 28 g
+          genVar32 = VarLen <$> uniformM @Word32 g
+        stakeCred <- case stakeRef of
+          0b00 -> genHash28 -- staking payment hash
+          0b01 -> genHash28 -- staking script hash
+          0b10 -> do
+            -- Ptr
+            ptr <- replicateM 3 genVar32
+            pure $ foldMap packByteString ptr
+          _ -> pure mempty
+        paymentCred <- genHash28
+        -- TODO use genBytesTerm once indefinite bytestring decoding has been fixed
+        let bytesTerm = TBytes . BS.cons header $ paymentCred <> stakeCred
+        pure $ S bytesTerm
 
 instance Era era => HuddleRule "reward_account" era where
-  huddleRuleNamed pname _ =
-    comment
-      "reward_account = bytes"
-      $ pname
-        =.= bstr "E090000000000000000000000000000000000000000000000000000000"
-        / bstr "F0A0000000000000000000000000000000000000000000000000000000"
+  huddleRuleNamed pname _ = withGenerator generator $ pname =.= VBytes
+    where
+      generator g = do
+        isMainnet <- uniformM g
+        isScript <- uniformM g
+        let
+          mainnetMask | isMainnet = 0b00000001 | otherwise = 0x00
+          scriptMask | isScript = 0b00010000 | otherwise = 0x00
+          header = 0b11100000 .|. mainnetMask .|. scriptMask
+        payload <- uniformByteStringM 28 g
+        let term = TBytes $ BS.cons header payload
+        pure $ S term
 
 instance Era era => HuddleRule "transaction_index" era where
   huddleRuleNamed pname _ = pname =.= VUInt `sized` (2 :: Word64)