feat: testgen-hs – random Haskell CBOR error generator

flake.nix

@@ -37,9 +37,12 @@
         pkgs,
         ...
       }: {
-        packages =
+        packages = let
+          internal = inputs.self.internal.${system};
+        in
           {
-            default = inputs.self.internal.${system}.package;
+            default = internal.package;
+            inherit (internal) tx-build cardano-address testgen-hs;
           }
           // (inputs.nixpkgs.lib.optionalAttrs (system == "x86_64-linux") {
             default-x86_64-windows = inputs.self.internal.x86_64-windows.package;
@@ -49,7 +52,9 @@
 
         treefmt = {pkgs, ...}: {
           projectRootFile = "flake.nix";
-          programs.alejandra.enable = true;
+          programs.alejandra.enable = true; # Nix
+          programs.ormolu.enable = true; # Haskell
+          programs.cabal-fmt.enable = true;
           programs.prettier.enable = true;
           settings.formatter.prettier.options = [
             "--config"
@@ -60,7 +65,7 @@
           ];
           programs.rustfmt.enable = true;
           programs.yamlfmt.enable = true;
-          programs.taplo.enable = true;
+          programs.taplo.enable = true; # TOML
           programs.shfmt.enable = true;
         };
       };

nix/devshells.nix

@@ -50,6 +50,11 @@ in {
       category = "handy";
       package = internal.tx-build;
     }
+    {
+      category = "handy";
+      name = "testgen-hs";
+      package = internal.testgen-hs;
+    }
   ];
 
   language.c.compiler =

nix/internal/unix.nix

@@ -125,6 +125,33 @@ in rec {
       ln -sf $out/libexec/cardano-address $out/bin/
     '';
 
+  testgen-hs = let
+    patched-flake = let
+      unpatched = inputs.cardano-node;
+    in
+      (import inputs.flake-compat {
+        src = {
+          outPath = toString (pkgs.runCommandNoCC "source" {} ''
+            cp -r ${unpatched} $out
+            chmod -R +w $out
+            cd $out
+            echo ${lib.escapeShellArg (builtins.toJSON [targetSystem])} $out/nix/supported-systems.nix
+            cp -r ${../../testgen-hs} ./testgen-hs
+            sed -r '/^packages:/ a\  testgen-hs' -i cabal.project
+            sed -r 's/other-modules:\s*/                    , /g' -i cardano-submit-api/cardano-submit-api.cabal
+          '');
+          inherit (unpatched) rev shortRev lastModified lastModifiedDate;
+        };
+      })
+      .defaultNix;
+  in
+    {
+      x86_64-linux = patched-flake.hydraJobs.x86_64-linux.musl.testgen-hs;
+      x86_64-darwin = patched-flake.packages.x86_64-darwin.testgen-hs;
+      aarch64-darwin = patched-flake.packages.aarch64-darwin.testgen-hs;
+    }
+    .${targetSystem};
+
   tx-build = let
     onPath = with pkgs; [
       bash

testgen-hs/CLI.hs

@@ -0,0 +1,149 @@
+module CLI
+  ( Command (..),
+    GenerateOptions (..),
+    Seed (..),
+    GenSize (..),
+    NumCases (..),
+    TypeCommand (..),
+    parse,
+  )
+where
+
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Base16 as Base16
+import qualified Data.ByteString.Char8 as BS8
+import Options.Applicative as O
+
+data Command = Generate GenerateOptions | Deserialize ByteString deriving (Show)
+
+data GenerateOptions = GenerateOptions (Maybe Seed) GenSize NumCases TypeCommand deriving (Show)
+
+newtype Seed = Seed Int deriving (Show)
+
+newtype GenSize = GenSize Int deriving (Show)
+
+newtype NumCases = NumCases Int deriving (Show)
+
+data TypeCommand
+  = GHCInteger
+  | DataText
+  | ExampleADT
+  | ApplyTxErr'Byron
+  | ApplyTxErr'Shelley
+  | ApplyTxErr'Allegra
+  | ApplyTxErr'Mary
+  | ApplyTxErr'Alonzo
+  | ApplyTxErr'Babbage
+  | ApplyTxErr'Conway
+  deriving (Show)
+
+parse :: IO Command
+parse = execParser opts
+
+-------------------------------------------------------------------------------------
+
+opts :: ParserInfo Command
+opts =
+  info
+    (commandParser <**> helper)
+    ( fullDesc
+        <> progDesc "Test case generator for cross-checking CBOR (de)serializers"
+    )
+
+commandParser :: Parser Command
+commandParser =
+  subparser
+    ( mempty
+        <> ( command
+               "generate"
+               ( info
+                   ( Generate
+                       <$> optionsParser
+                         <**> helper
+                   )
+                   (progDesc "Generate random CBOR test cases")
+               )
+           )
+        <> ( command
+               "deserialize"
+               ( info
+                   ( Deserialize
+                       <$> argument (eitherReader parseHex) (metavar "CBOR_HEX")
+                         <**> helper
+                   )
+                   (progDesc "Deserialize CBOR of ‘HardForkApplyTxErr’ that you got from cardano-node")
+               )
+           )
+    )
+
+optionsParser :: Parser GenerateOptions
+optionsParser =
+  GenerateOptions
+    <$> optional
+      ( Seed
+          <$> option
+            auto
+            ( long "seed"
+                <> short 's'
+                <> metavar "SEED"
+                <> help "Random seed integer (UNIX timestamp by default)"
+            )
+      )
+    <*> ( GenSize
+            <$> option
+              auto
+              ( long "generator-size"
+                  <> short 'g'
+                  <> metavar "SIZE"
+                  <> value 300
+                  <> help "Set the relative ‘size’ of the test cases"
+              )
+        )
+    <*> ( NumCases
+            <$> option
+              positive
+              ( long "number"
+                  <> short 'n'
+                  <> metavar "NUM"
+                  <> value 10
+                  <> help "How many test cases to generate"
+              )
+        )
+    <*> typeCommandParser
+
+positive :: ReadM Int
+positive = do
+  n <- auto
+  if n > 0
+    then return n
+    else readerError "NUM must be positive"
+
+typeCommandParser :: Parser TypeCommand
+typeCommandParser =
+  subparser
+    ( mempty
+        <> mkTypeCommand ApplyTxErr'Byron
+        <> mkTypeCommand ApplyTxErr'Shelley
+        <> mkTypeCommand ApplyTxErr'Allegra
+        <> mkTypeCommand ApplyTxErr'Mary
+        <> mkTypeCommand ApplyTxErr'Alonzo
+        <> mkTypeCommand ApplyTxErr'Babbage
+        <> mkTypeCommand ApplyTxErr'Conway
+        <> mkTypeCommand GHCInteger
+        <> mkTypeCommand DataText
+        <> mkTypeCommand ExampleADT
+    )
+
+mkTypeCommand :: TypeCommand -> Mod CommandFields TypeCommand
+mkTypeCommand cmd =
+  command
+    (replaceQuotes . show $ cmd)
+    (info (pure cmd) (progDesc ("Generate CBOR of " ++ show cmd)))
+  where
+    replaceQuotes = ((\c -> if c == '\'' then '_' else c) <$>)
+
+-- | Parse a hex-encoded ByteString – e.g. CBOR
+parseHex :: String -> Either String ByteString
+parseHex hexInput =
+  let bsInput = BS8.pack hexInput
+   in Base16.decode bsInput

testgen-hs/Deserialize.hs

@@ -0,0 +1,36 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Deserialize (deserialize) where
+
+import Cardano.Api.Orphans ()
+import qualified Cardano.Chain.Slotting as CCS
+import qualified Codec.CBOR.Decoding as C
+import qualified Codec.CBOR.Read as C
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Base16 as B16
+import qualified Data.ByteString.Lazy as BL
+import qualified Ouroboros.Consensus.Cardano.Block as OCCB
+import Ouroboros.Consensus.Cardano.Node as OCCN
+import qualified Ouroboros.Consensus.HardFork.Combinator.Mempool as OCHCM
+import Ouroboros.Consensus.HardFork.Combinator.Serialisation.SerialiseNodeToClient ()
+import qualified Ouroboros.Consensus.Node.ProtocolInfo as OCNPI
+import qualified Ouroboros.Consensus.Node.Serialisation as OCNS
+import Test.Consensus.Cardano.Generators ()
+
+deserialize :: ByteString -> Either String (OCHCM.HardForkApplyTxErr (OCCB.CardanoEras OCCB.StandardCrypto))
+deserialize cbor =
+  case C.deserialiseFromBytes hfcEnvelopeDecoder (BL.fromStrict cbor) of
+    Left err -> Left (show err)
+    Right ("", ok) -> Right ok
+    Right (remainder, _) -> Left ("Deserialization successful, but the following bytes remained: " <> (show . B16.encode . BL.toStrict) remainder)
+
+hfcEnvelopeDecoder :: forall s. C.Decoder s (OCHCM.HardForkApplyTxErr (OCCB.CardanoEras OCCB.StandardCrypto))
+hfcEnvelopeDecoder =
+  OCNS.decodeNodeToClient
+    @(OCCB.HardForkBlock (OCCB.CardanoEras OCCB.StandardCrypto))
+    @(OCHCM.HardForkApplyTxErr (OCCB.CardanoEras OCCB.StandardCrypto))
+    codecConfig
+    OCCN.CardanoNodeToClientVersion12
+  where
+    byronEpochSlots = CCS.EpochSlots 21600 -- probably safe to hardcode in Conway…?
+    codecConfig = OCNPI.pClientInfoCodecConfig (OCCN.protocolClientInfoCardano byronEpochSlots)