{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}

module Test.Cardano.Ledger.Binary.Cuddle.GenerateCBOR (
  generateCBORMain,
) where

import Codec.CBOR.Cuddle.CBOR.Gen
import Codec.CBOR.Cuddle.CBOR.Validator
import Codec.CBOR.Cuddle.CBOR.Validator.Trace
import Codec.CBOR.Cuddle.CDDL
import Codec.CBOR.Cuddle.CDDL.Custom.Generator
import qualified Codec.CBOR.Cuddle.Huddle as Cuddle
import Codec.CBOR.Cuddle.IndexMappable
import qualified Codec.CBOR.Term as CBOR
import qualified Codec.CBOR.Write as CBOR
import Control.Monad (forM_, when)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base16 as Base16
import qualified Data.ByteString.Char8 as BS8
import Data.List (intercalate)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import Options.Applicative ((<**>))
import qualified Options.Applicative as Opt
import System.Exit (die)
import System.IO
import Test.AntiGen
import Test.Cardano.Ledger.Binary.Cuddle
import Test.QuickCheck (generate)
import Test.QuickCheck.Gen (unGen)
import Test.QuickCheck.Random (mkQCGen)

data GenerateCBOROpts = GenerateCBOROpts
  { GenerateCBOROpts -> Text
gcboEra :: !T.Text
  , GenerateCBOROpts -> [Text]
gcboRuleNames :: ![T.Text]
  , GenerateCBOROpts -> Maybe Int
gcboZap :: !(Maybe Int)
  , GenerateCBOROpts -> Int
gcboCount :: !Int
  , GenerateCBOROpts -> Maybe Int
gcboSeed :: !(Maybe Int)
  , GenerateCBOROpts -> Bool
gcboBinary :: !Bool
  , GenerateCBOROpts -> Int
gcboTries :: !Int
  , GenerateCBOROpts -> Bool
gcboVerbose :: !Bool
  }

readNonNegativeInt :: Opt.ReadM Int
readNonNegativeInt :: ReadM Int
readNonNegativeInt = do
  n <- ReadM Int
forall a. Read a => ReadM a
Opt.auto
  when (n < 0) $ Opt.readerError "Expected a nonnegative number"
  pure n

optsParser :: [String] -> Opt.Parser GenerateCBOROpts
optsParser :: [String] -> Parser GenerateCBOROpts
optsParser [String]
eras =
  Text
-> [Text]
-> Maybe Int
-> Int
-> Maybe Int
-> Bool
-> Int
-> Bool
-> GenerateCBOROpts
GenerateCBOROpts
    (Text
 -> [Text]
 -> Maybe Int
 -> Int
 -> Maybe Int
 -> Bool
 -> Int
 -> Bool
 -> GenerateCBOROpts)
-> Parser Text
-> Parser
     ([Text]
      -> Maybe Int
      -> Int
      -> Maybe Int
      -> Bool
      -> Int
      -> Bool
      -> GenerateCBOROpts)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mod OptionFields Text -> Parser Text
forall s. IsString s => Mod OptionFields s -> Parser s
Opt.strOption
      ( String -> Mod OptionFields Text
forall (f :: * -> *) a. HasName f => String -> Mod f a
Opt.long String
"era"
          Mod OptionFields Text
-> Mod OptionFields Text -> Mod OptionFields Text
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Text
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
Opt.metavar String
"ERA"
          Mod OptionFields Text
-> Mod OptionFields Text -> Mod OptionFields Text
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Text
forall (f :: * -> *) a. String -> Mod f a
Opt.help (String
"Era to generate CBOR for. One of: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
eras)
      )
    Parser
  ([Text]
   -> Maybe Int
   -> Int
   -> Maybe Int
   -> Bool
   -> Int
   -> Bool
   -> GenerateCBOROpts)
-> Parser [Text]
-> Parser
     (Maybe Int
      -> Int -> Maybe Int -> Bool -> Int -> Bool -> GenerateCBOROpts)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text -> Parser [Text]
forall a. Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
Opt.some
      ( Mod ArgumentFields Text -> Parser Text
forall s. IsString s => Mod ArgumentFields s -> Parser s
Opt.strArgument (Mod ArgumentFields Text -> Parser Text)
-> Mod ArgumentFields Text -> Parser Text
forall a b. (a -> b) -> a -> b
$
          String -> Mod ArgumentFields Text
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
Opt.metavar String
"RULE_NAME..."
            Mod ArgumentFields Text
-> Mod ArgumentFields Text -> Mod ArgumentFields Text
forall a. Semigroup a => a -> a -> a
<> String -> Mod ArgumentFields Text
forall (f :: * -> *) a. String -> Mod f a
Opt.help String
"CDDL rule names to generate CBOR for"
      )
    Parser
  (Maybe Int
   -> Int -> Maybe Int -> Bool -> Int -> Bool -> GenerateCBOROpts)
-> Parser (Maybe Int)
-> Parser
     (Int -> Maybe Int -> Bool -> Int -> Bool -> GenerateCBOROpts)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Int -> Parser (Maybe Int)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
Opt.optional
      ( ReadM Int -> Mod OptionFields Int -> Parser Int
forall a. ReadM a -> Mod OptionFields a -> Parser a
Opt.option ReadM Int
readNonNegativeInt (Mod OptionFields Int -> Parser Int)
-> Mod OptionFields Int -> Parser Int
forall a b. (a -> b) -> a -> b
$
          String -> Mod OptionFields Int
forall (f :: * -> *) a. HasName f => String -> Mod f a
Opt.long String
"zap"
            Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Int
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
Opt.metavar String
"N"
            Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Int
forall (f :: * -> *) a. String -> Mod f a
Opt.help String
"Generate corrupted (zapped) CBOR with N mistakes"
      )
    Parser
  (Int -> Maybe Int -> Bool -> Int -> Bool -> GenerateCBOROpts)
-> Parser Int
-> Parser (Maybe Int -> Bool -> Int -> Bool -> GenerateCBOROpts)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadM Int -> Mod OptionFields Int -> Parser Int
forall a. ReadM a -> Mod OptionFields a -> Parser a
Opt.option
      ReadM Int
readNonNegativeInt
      ( String -> Mod OptionFields Int
forall (f :: * -> *) a. HasName f => String -> Mod f a
Opt.long String
"count"
          Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields Int
forall (f :: * -> *) a. HasName f => Char -> Mod f a
Opt.short Char
'n'
          Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Int
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
Opt.metavar String
"N"
          Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> Int -> Mod OptionFields Int
forall (f :: * -> *) a. HasValue f => a -> Mod f a
Opt.value Int
1
          Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> Mod OptionFields Int
forall a (f :: * -> *). Show a => Mod f a
Opt.showDefault
          Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Int
forall (f :: * -> *) a. String -> Mod f a
Opt.help String
"Number of samples to generate per rule"
      )
    Parser (Maybe Int -> Bool -> Int -> Bool -> GenerateCBOROpts)
-> Parser (Maybe Int)
-> Parser (Bool -> Int -> Bool -> GenerateCBOROpts)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Int -> Parser (Maybe Int)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
Opt.optional
      ( ReadM Int -> Mod OptionFields Int -> Parser Int
forall a. ReadM a -> Mod OptionFields a -> Parser a
Opt.option ReadM Int
forall a. Read a => ReadM a
Opt.auto (Mod OptionFields Int -> Parser Int)
-> Mod OptionFields Int -> Parser Int
forall a b. (a -> b) -> a -> b
$
          String -> Mod OptionFields Int
forall (f :: * -> *) a. HasName f => String -> Mod f a
Opt.long String
"seed"
            Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Int
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
Opt.metavar String
"SEED"
            Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Int
forall (f :: * -> *) a. String -> Mod f a
Opt.help String
"Fixed random seed for reproducibility"
      )
    Parser (Bool -> Int -> Bool -> GenerateCBOROpts)
-> Parser Bool -> Parser (Int -> Bool -> GenerateCBOROpts)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod FlagFields Bool -> Parser Bool
Opt.switch
      ( String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
Opt.long String
"binary"
          Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
Opt.help String
"Output raw CBOR bytes instead of hex encoding"
      )
    Parser (Int -> Bool -> GenerateCBOROpts)
-> Parser Int -> Parser (Bool -> GenerateCBOROpts)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadM Int -> Mod OptionFields Int -> Parser Int
forall a. ReadM a -> Mod OptionFields a -> Parser a
Opt.option
      ReadM Int
readNonNegativeInt
      ( String -> Mod OptionFields Int
forall (f :: * -> *) a. HasName f => String -> Mod f a
Opt.long String
"tries"
          Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields Int
forall (f :: * -> *) a. HasName f => Char -> Mod f a
Opt.short Char
't'
          Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Int
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
Opt.metavar String
"N"
          Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> Int -> Mod OptionFields Int
forall (f :: * -> *) a. HasValue f => a -> Mod f a
Opt.value Int
50
          Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> Mod OptionFields Int
forall a (f :: * -> *). Show a => Mod f a
Opt.showDefault
          Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Int
forall (f :: * -> *) a. String -> Mod f a
Opt.help String
"Number of retries for failed sample generations"
      )
    Parser (Bool -> GenerateCBOROpts)
-> Parser Bool -> Parser GenerateCBOROpts
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod FlagFields Bool -> Parser Bool
Opt.switch
      ( String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
Opt.long String
"verbose"
          Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
Opt.help String
"More verbose output"
      )

generateCBORMain :: Map T.Text Cuddle.Huddle -> IO ()
generateCBORMain :: Map Text Huddle -> IO ()
generateCBORMain Map Text Huddle
eraCDDLs = do
  opts <-
    ParserInfo GenerateCBOROpts -> IO GenerateCBOROpts
forall a. ParserInfo a -> IO a
Opt.execParser (ParserInfo GenerateCBOROpts -> IO GenerateCBOROpts)
-> ParserInfo GenerateCBOROpts -> IO GenerateCBOROpts
forall a b. (a -> b) -> a -> b
$
      Parser GenerateCBOROpts
-> InfoMod GenerateCBOROpts -> ParserInfo GenerateCBOROpts
forall a. Parser a -> InfoMod a -> ParserInfo a
Opt.info
        ([String] -> Parser GenerateCBOROpts
optsParser [String]
eraNames Parser GenerateCBOROpts
-> Parser (GenerateCBOROpts -> GenerateCBOROpts)
-> Parser GenerateCBOROpts
forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> Parser (GenerateCBOROpts -> GenerateCBOROpts)
forall a. Parser (a -> a)
Opt.helper)
        ( InfoMod GenerateCBOROpts
forall a. InfoMod a
Opt.fullDesc
            InfoMod GenerateCBOROpts
-> InfoMod GenerateCBOROpts -> InfoMod GenerateCBOROpts
forall a. Semigroup a => a -> a -> a
<> String -> InfoMod GenerateCBOROpts
forall a. String -> InfoMod a
Opt.progDesc String
"Generate CBOR data from Cardano Ledger CDDL rules"
            InfoMod GenerateCBOROpts
-> InfoMod GenerateCBOROpts -> InfoMod GenerateCBOROpts
forall a. Semigroup a => a -> a -> a
<> String -> InfoMod GenerateCBOROpts
forall a. String -> InfoMod a
Opt.header String
"generate-cbor - CBOR data generator from Cardano Ledger CDDL specifications"
        )
  huddle <- case Map.lookup (gcboEra opts) eraCDDLs of
    Maybe Huddle
Nothing ->
      String -> IO Huddle
forall a. String -> IO a
die (String -> IO Huddle) -> String -> IO Huddle
forall a b. (a -> b) -> a -> b
$
        String
"Unknown era: "
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack (GenerateCBOROpts -> Text
gcboEra GenerateCBOROpts
opts)
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\nSupported eras: "
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
eraNames
    Just Huddle
h -> Huddle -> IO Huddle
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Huddle
h
  case resolveHuddle huddle of
    Left String
err -> String -> IO ()
forall a. String -> IO a
die (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Failed to resolve CDDL: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
err
    Right CTreeRoot MonoReferenced
root -> do
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GenerateCBOROpts -> Bool
gcboBinary GenerateCBOROpts
opts) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> Bool -> IO ()
hSetBinaryMode Handle
stdout Bool
True
      let env :: HuddleEnv
env = HuddleEnv {heTwiddle :: Bool
heTwiddle = Bool
True, heRoot :: CTreeRoot MonoReferenced
heRoot = CTreeRoot MonoReferenced
root}
          multipleRules :: Bool
multipleRules = [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (GenerateCBOROpts -> [Text]
gcboRuleNames GenerateCBOROpts
opts) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
      [Text] -> (Text -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (GenerateCBOROpts -> [Text]
gcboRuleNames GenerateCBOROpts
opts) ((Text -> IO ()) -> IO ()) -> (Text -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Text
ruleName -> do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
multipleRules Bool -> Bool -> Bool
&& Bool -> Bool
not (GenerateCBOROpts -> Bool
gcboBinary GenerateCBOROpts
opts)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
            String
"# " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
ruleName
        [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. GenerateCBOROpts -> Int
gcboCount GenerateCBOROpts
opts Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> GenerateCBOROpts -> HuddleEnv -> Text -> Int -> IO ()
emitSample Int
0 GenerateCBOROpts
opts HuddleEnv
env Text
ruleName
  where
    eraNames :: [String]
eraNames = (Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack (Map Text Huddle -> [Text]
forall k a. Map k a -> [k]
Map.keys Map Text Huddle
eraCDDLs)

emitSample :: Int -> GenerateCBOROpts -> HuddleEnv -> T.Text -> Int -> IO ()
emitSample :: Int -> GenerateCBOROpts -> HuddleEnv -> Text -> Int -> IO ()
emitSample Int
tries GenerateCBOROpts
opts HuddleEnv
env Text
ruleName Int
sampleIx
  | Int
tries Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> GenerateCBOROpts -> Int
gcboTries GenerateCBOROpts
opts =
      String -> IO ()
dieWithInfo (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"failed to generate a sample after " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (GenerateCBOROpts -> Int
gcboTries GenerateCBOROpts
opts Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" attempts"
  | Bool
otherwise = do
      let cborGen :: AntiGen Term
cborGen = GenConfig -> CBORGen Term -> AntiGen Term
forall a. GenConfig -> CBORGen a -> AntiGen a
runCBORGen (HuddleEnv -> GenConfig
toGenConfig HuddleEnv
env) (HasCallStack => Name -> CBORGen Term
Name -> CBORGen Term
generateFromName (Text -> Name
Name Text
ruleName))
          gen :: Gen (ZapResult Term)
gen = Int -> AntiGen Term -> Gen (ZapResult Term)
forall a. Int -> AntiGen a -> Gen (ZapResult a)
zapAntiGenResult (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (GenerateCBOROpts -> Maybe Int
gcboZap GenerateCBOROpts
opts)) AntiGen Term
cborGen
          retry :: IO ()
retry = Int -> GenerateCBOROpts -> HuddleEnv -> Text -> Int -> IO ()
emitSample (Int
tries Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) GenerateCBOROpts
opts HuddleEnv
env Text
ruleName Int
sampleIx
      ZapResult {zrValue, zrZapped} <- case GenerateCBOROpts -> Maybe Int
gcboSeed GenerateCBOROpts
opts of
        Maybe Int
Nothing -> Gen (ZapResult Term) -> IO (ZapResult Term)
forall a. Gen a -> IO a
generate Gen (ZapResult Term)
gen
        Just Int
seed -> ZapResult Term -> IO (ZapResult Term)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ZapResult Term -> IO (ZapResult Term))
-> ZapResult Term -> IO (ZapResult Term)
forall a b. (a -> b) -> a -> b
$ Gen (ZapResult Term) -> QCGen -> Int -> ZapResult Term
forall a. Gen a -> QCGen -> Int -> a
unGen Gen (ZapResult Term)
gen (Int -> QCGen
mkQCGen (Int
seed Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sampleIx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ GenerateCBOROpts -> Int
gcboCount GenerateCBOROpts
opts Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
tries)) Int
30
      let
        bs = Encoding -> ByteString
CBOR.toStrictByteString (Term -> Encoding
CBOR.encodeTerm Term
zrValue)
        outputBinary
          | GenerateCBOROpts -> Bool
gcboBinary GenerateCBOROpts
opts = Handle -> ByteString -> IO ()
BS.hPut Handle
stdout ByteString
bs
          | Bool
otherwise = ByteString -> IO ()
BS8.putStrLn (ByteString -> ByteString
Base16.encode ByteString
bs)
        validationResult = HasCallStack =>
ByteString
-> Name
-> CTreeRoot ValidatorPhase
-> Either ValidateCBORError (Evidenced ValidationTrace)
ByteString
-> Name
-> CTreeRoot ValidatorPhase
-> Either ValidateCBORError (Evidenced ValidationTrace)
validateCBOR ByteString
bs (Text -> Name
Name Text
ruleName) (CTreeRoot MonoReferenced -> CTreeRoot ValidatorPhase
forall {k} (f :: k -> *) (i :: k) (j :: k).
IndexMappable f i j =>
f i -> f j
mapIndex (HuddleEnv -> CTreeRoot MonoReferenced
heRoot HuddleEnv
env))
      case gcboZap opts of
        Just Int
nZaps
          | Int
nZaps Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 -> IO ()
outputBinary
          | Int
zrZapped Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
nZaps ->
              String -> IO ()
warn String
"Warning: not enough decision points for the zapper to zap, retrying" IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
retry
          | Bool
otherwise -> case Either ValidateCBORError (Evidenced ValidationTrace)
validationResult of
              Left (RuleDoesNotExist Name
n) -> String -> IO ()
dieWithInfo (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Failed to validate because rule does not exist: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Name -> String
forall a. Show a => a -> String
show Name
n
              Left (LeftoverBytes ByteString
_) ->
                String -> IO ()
warn String
"Warning: leftover bytes after decoding generated CBOR, retrying" IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
retry
              Left (DecodingFailed DeserialiseFailure
e) ->
                String -> IO ()
warn (String
"Warning: failed to decode generated CBOR, retrying (" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> DeserialiseFailure -> String
forall a. Show a => a -> String
show DeserialiseFailure
e String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")") IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
retry
              Right (Evidenced SValidity v
SValid ValidationTrace v
_) ->
                String -> IO ()
warn String
"Warning: zapper failed to generate an invalid value, retrying" IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
retry
              Right (Evidenced SValidity v
SInvalid ValidationTrace v
_) -> IO ()
outputBinary
        Maybe Int
Nothing -> IO ()
outputBinary
  where
    extraInfo :: String
extraInfo = String
"\n(rule: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
ruleName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", index: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
sampleIx String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")"
    warn :: String -> IO ()
warn String
msg
      | GenerateCBOROpts -> Bool
gcboVerbose GenerateCBOROpts
opts =
          Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
msg String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
extraInfo
      | Bool
otherwise = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    dieWithInfo :: String -> IO ()
dieWithInfo String
msg =
      String -> IO ()
forall a. String -> IO a
die (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
msg String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
extraInfo