Make use of cuddle for validation

Author: jasagredo

cabal.project

@@ -16,7 +16,7 @@ index-state:
   -- Bump this if you need newer packages from Hackage
   , hackage.haskell.org 2025-05-15T07:59:00Z
   -- Bump this if you need newer packages from CHaP
-  , cardano-haskell-packages 2025-05-15T08:36:14Z
+  , cardano-haskell-packages 2025-05-15T10:30:42Z
 
 packages:
   ouroboros-consensus
@@ -68,7 +68,7 @@ if impl (ghc >= 9.12)
 source-repository-package
     type: git
     location: https://github.com/IntersectMBO/cardano-ledger
-    tag: d48965e0dc1a324f432f1ee01bc0cf2d60a8a702
+    tag: 3028f02583b22cd1d1039a42acfad94626bfa39c
     --sha256: sha256-UFIQ1qinge1TMtqU2e0Nyjdpj42yj+lLKrpnXeqo1mI=
     subdir:
       eras/allegra/impl
@@ -96,6 +96,11 @@ source-repository-package
       eras/byron/ledger/impl
       eras/byron/crypto
 
+source-repository-package
+  type: git
+  location: https://github.com/input-output-hk/cuddle
+  tag: 847e9c4fbacc261a2fb154d8d28e50227eaa9085
+
 allow-newer:
     ouroboros-consensus:cardano-ledger-core,
     ouroboros-consensus-cardano:cardano-ledger-byron,

ouroboros-consensus-cardano/cddl/pull-cddls.hs

@@ -1,18 +1,21 @@
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE CPP #-}
 -- |
 
 module Main (main) where
 
 import qualified Control.Monad as Monad
-import qualified Data.ByteString.Lazy as BL
-import qualified Data.ByteString.Lazy.UTF8 as BL8
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as BSL
+import qualified Data.ByteString.Char8 as BS8
 import           Data.Maybe (isNothing)
 import qualified Data.List as L
 import           Paths_ouroboros_consensus_cardano
 import qualified System.Directory as D
 import qualified System.Environment as E
-import           System.Exit (exitFailure)
+import           System.Exit
 import qualified System.FilePath as F
 import qualified System.Process.ByteString.Lazy as P
 import qualified Test.Cardano.Chain.Binary.Cddl as Byron
@@ -22,16 +25,43 @@ import qualified Test.Cardano.Ledger.Babbage.Binary.Cddl as Babbage
 import qualified Test.Cardano.Ledger.Conway.Binary.Cddl as Conway
 import qualified Test.Cardano.Ledger.Mary.Binary.Cddl as Mary
 import qualified Test.Cardano.Ledger.Shelley.Binary.Cddl as Shelley
+--import System.IO
+import Test.Tasty
+import Test.Tasty.HUnit
 
 main :: IO ()
 main = do
   probeTools
-  setupEnv
-  -- For now I just print this.
-  print =<< getCDDLs
+  setupCDDLCEnv
 
-setupEnv :: IO ()
-setupEnv = do
+  -- Only test the golden blocks
+  goldenBlocks <-
+      (map ("ouroboros-consensus-cardano/golden/cardano/disk" F.</>))
+    . filter (L.isPrefixOf "Block_")
+    <$> D.listDirectory "ouroboros-consensus-cardano/golden/cardano/disk/"
+
+  defaultMain
+    $ testGroup "Golden"
+      [ withResource
+         (cddlc "cddl/disk/block.cddl"
+          >>= fixupBlockCDDL
+          >>= BS.writeFile "block.cddl" . cddlSpec
+         )
+         (\() -> D.removeFile "block.cddl")
+         $ \_ -> testGroup "Blocks" $
+                   map (cuddleValidate "block.cddl" "cardanoBlock") goldenBlocks
+      ]
+
+
+cuddleValidate :: FilePath -> String -> FilePath -> TestTree
+cuddleValidate cddl rule cbor = testCase cbor $ do
+  (e, err, _) <- P.readProcessWithExitCode "cuddle" ["validate-cbor", "-c", cbor, "-r", rule, cddl] mempty
+  case e of
+    ExitSuccess -> pure ()
+    ExitFailure _ -> assertFailure $ BS8.unpack $ BSL.toStrict err
+
+setupCDDLCEnv :: IO ()
+setupCDDLCEnv = do
   byron   <- map takePath <$> Byron.readByronCddlFileNames
   shelley <- map takePath <$> Shelley.readShelleyCddlFileNames
   allegra <- map takePath <$> Allegra.readAllegraCddlFileNames
@@ -58,7 +88,7 @@ setupEnv = do
 
   E.setEnv "CDDL_INCLUDE_PATH" (include_path <> ":")
 
-newtype CDDLSpec = CDDLSpec BL.ByteString deriving Show
+newtype CDDLSpec = CDDLSpec { cddlSpec :: BS.ByteString } deriving Show
 
 data CDDLs = CDDLs {
     diskBlockCDDL :: CDDLSpec
@@ -83,42 +113,71 @@ data CDDLs = CDDLs {
   , ntcTxMonitorSlotNoCDDL :: CDDLSpec
   } deriving Show
 
-getCDDLs :: IO CDDLs
-getCDDLs = CDDLs
-  -- Disk
-  <$> cddlc "cddl/disk/block.cddl"
-  <*> cddlc "cddl/disk/snapshot.cddl"
-
-  -- Node to node
-  -- -- BlockFetch
-  <*> cddlc "cddl/node-to-node/blockfetch/block.cddl"
-  <*> cddlc "cddl/node-to-node/blockfetch/point.cddl"
-
-  -- -- ChainSync
-  <*> cddlc "cddl/node-to-node/chainsync/header.cddl"
-  <*> cddlc "cddl/node-to-node/chainsync/point.cddl"
-  <*> cddlc "cddl/node-to-node/chainsync/tip.cddl"
-
-  -- -- TxSubmission2
-  <*> cddlc "cddl/node-to-node/txsubmission2/ticketno.cddl"
-  <*> cddlc "cddl/node-to-node/txsubmission2/tx.cddl"
-  <*> cddlc "cddl/node-to-node/txsubmission2/txid.cddl"
-
-  -- Node to client
-  -- -- LocalStateQuery
-  <*> cddlc "cddl/node-to-client/localstatequery/query.cddl"
-  <*> cddlc "cddl/node-to-client/localstatequery/result.cddl"
-
-  -- -- TxMonitor
-  <*> cddlc "cddl/node-to-client/txmonitor/tx.cddl"
-  <*> cddlc "cddl/node-to-client/txmonitor/txid.cddl"
-  <*> cddlc "cddl/node-to-client/txmonitor/slotno.cddl"
+-- getCDDLs :: IO CDDLs
+-- getCDDLs = CDDLs
+--   -- Disk
+--   <$> cddlc "cddl/disk/block.cddl"
+--   <*> cddlc "cddl/disk/snapshot.cddl"
+
+--   -- Node to node
+--   -- -- BlockFetch
+--   <*> cddlc "cddl/node-to-node/blockfetch/block.cddl"
+--   <*> cddlc "cddl/node-to-node/blockfetch/point.cddl"
+
+--   -- -- ChainSync
+--   <*> cddlc "cddl/node-to-node/chainsync/header.cddl"
+--   <*> cddlc "cddl/node-to-node/chainsync/point.cddl"
+--   <*> cddlc "cddl/node-to-node/chainsync/tip.cddl"
+
+--   -- -- TxSubmission2
+--   <*> cddlc "cddl/node-to-node/txsubmission2/ticketno.cddl"
+--   <*> cddlc "cddl/node-to-node/txsubmission2/tx.cddl"
+--   <*> cddlc "cddl/node-to-node/txsubmission2/txid.cddl"
+
+--   -- Node to client
+--   -- -- LocalStateQuery
+--   <*> cddlc "cddl/node-to-client/localstatequery/query.cddl"
+--   <*> cddlc "cddl/node-to-client/localstatequery/result.cddl"
+
+--   -- -- TxMonitor
+--   <*> cddlc "cddl/node-to-client/txmonitor/tx.cddl"
+--   <*> cddlc "cddl/node-to-client/txmonitor/txid.cddl"
+--   <*> cddlc "cddl/node-to-client/txmonitor/slotno.cddl"
+
+fixupBlockCDDL :: CDDLSpec -> IO CDDLSpec
+fixupBlockCDDL spec = do
+    let fp = "block-temp.cddl"
+    BS.writeFile fp . cddlSpec $ spec
+    -- This is wrong, both the metadata_hash of a pool and a transaction body
+    -- point to this type, but only the latter must be 32B.
+    sed fp ["-i", "s/\\(metadata_hash = \\)/\\1 bytes ;/g"]
+    -- For plutus, the type is actually `bytes`, but the distinct construct is
+    -- for forcing generation of different values.
+    sed fp ["-i", "s/\\(conway\\.distinct_VBytes = \\)/\\1 bytes ;\\//g"]
+    -- These 3 below are hardcoded for generation. See cardano-ledger#5054
+    sed fp ["-i", "s/\\([yaoye]\\.address = \\)/\\1 bytes ;/g"]
+    sed fp ["-i", "s/\\(reward_account = \\)/\\1 bytes ;/g"]
+    sed fp ["-i", "-z", "s/unit_interval = #6\\.30(\\[\\n\\s*1,\\n\\s*2,\\n\\])/unit_interval = #6.30([uint, uint])/g"]
+    r <- BS.readFile fp
+    D.removeFile fp
+    pure (CDDLSpec r)
+
+-- -- | Some CDDLs in the ledger are wrong or misleading. This step is to
+-- -- sed-replace to fix them until e.g. cardano-ledger#5054.
+-- fixup :: CDDLs -> IO CDDLs
+-- fixup CDDLs {..} = do
+--   diskBlockCDDL' <- fixupBlockCDDL diskBlockCDDL
+--   pure CDDLs {diskBlockCDDL = diskBlockCDDL', ..}
+
+sed :: FilePath -> [String] -> IO ()
+sed fp args =
+  Monad.void $ P.readProcessWithExitCode "sed" (args ++ [fp]) mempty
 
 cddlc :: FilePath -> IO CDDLSpec
 cddlc dataFile = do
   putStrLn $ "Generating: " <> dataFile
   path <- getDataFileName dataFile
-  (_, cddl, err) <-
+  (_, BSL.toStrict -> cddl, BSL.toStrict -> err) <-
 #ifdef POSIX
     P.readProcessWithExitCode "cddlc" ["-u", "-2", "-t", "cddl", path] mempty
 #else
@@ -129,7 +188,7 @@ cddlc dataFile = do
     prefix <- E.getEnv "MSYSTEM_PREFIX"
     P.readProcessWithExitCode "ruby" [prefix F.</> "bin/cddlc", "-u", "-2", "-t", "cddl", path] mempty
 #endif
-  Monad.unless (BL.null err) $ red $ BL8.toString err
+  Monad.unless (BS.null err) $ red $ BS8.unpack err
   return $ CDDLSpec cddl
  where
   red s = putStrLn $ "\ESC[31m" <> s <> "\ESC[0m"
@@ -177,7 +236,7 @@ probeTools = do
   rubyExe <- D.findExecutable "ruby"
   if (isNothing rubyExe)
   then do
-    putStrLn "not found!\nPlease install ruby and the `cddl` and `cddlc` gems"
+    putStrLn "not found!\nPlease install ruby"
     exitFailure
   else
     putStrLn "found"

ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal

@@ -136,15 +136,15 @@ library
     cardano-crypto,
     cardano-crypto-class ^>=2.2,
     cardano-crypto-wrapper,
-    cardano-ledger-allegra ^>=1.7,
-    cardano-ledger-alonzo ^>=1.13,
-    cardano-ledger-api ^>=1.11,
-    cardano-ledger-babbage ^>=1.11,
-    cardano-ledger-binary ^>=1.6,
+    cardano-ledger-allegra ^>=1.8,
+    cardano-ledger-alonzo ^>=1.14,
+    cardano-ledger-api ^>=1.12,
+    cardano-ledger-babbage ^>=1.12,
+    cardano-ledger-binary ^>=1.7,
     cardano-ledger-byron ^>=1.1,
     cardano-ledger-conway ^>=1.19,
     cardano-ledger-core ^>=1.17,
-    cardano-ledger-mary ^>=1.8,
+    cardano-ledger-mary ^>=1.9,
     cardano-ledger-shelley ^>=1.16,
     cardano-prelude,
     cardano-protocol-tpraos ^>=1.4,
@@ -744,11 +744,13 @@ executable gen-header
   autogen-modules:
     Paths_ouroboros_consensus_cardano
 
-executable pull-cddls
+test-suite cddl-compliance
   import: common-exe
+  type: exitcode-stdio-1.0
   hs-source-dirs: cddl
   main-is: pull-cddls.hs
   other-modules: Paths_ouroboros_consensus_cardano
+  build-tool-depends: cuddle:cuddle
   build-depends:
     base,
     bytestring,
@@ -762,4 +764,5 @@ executable pull-cddls
     directory,
     filepath,
     process-extras,
-    utf8-string,
+    tasty-hunit,
+    tasty,