{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}

module Test.Cardano.Ledger.Binary.Cuddle (
  huddleDecoderEquivalenceSpec,
  huddleRoundTripCborSpec,
  huddleRoundTripAnnCborSpec,
  huddleAntiCborSpec,
  writeSpec,
  huddleRoundTripGenValidate,
  huddleRoundTripArbitraryValidate,
  specWithHuddle,
) where

import Cardano.Ledger.Binary (
  Annotator,
  DecCBOR,
  EncCBOR,
  Version,
  decodeFull',
  decodeFullAnnotator,
  decodeFullDecoder,
  encodeTerm,
  serialize',
  toPlainEncoding,
 )
import Cardano.Ledger.Binary.Decoding (label)
import Codec.CBOR.Cuddle.CBOR.Gen (generateFromName)
import Codec.CBOR.Cuddle.CBOR.Validator (validateCBOR)
import Codec.CBOR.Cuddle.CBOR.Validator.Trace (
  Evidenced (..),
  SValidity (..),
  TraceOptions (..),
  ValidationTrace,
  defaultTraceOptions,
  isValid,
  prettyValidationTrace,
 )
import Codec.CBOR.Cuddle.CDDL (Name (..))
import Codec.CBOR.Cuddle.CDDL.CTree (CTreeRoot)
import Codec.CBOR.Cuddle.CDDL.Resolve (MonoReferenced)
import qualified Codec.CBOR.Cuddle.CDDL.Resolve as Cuddle
import qualified Codec.CBOR.Cuddle.Huddle as Cuddle
import Codec.CBOR.Cuddle.IndexMappable
import Codec.CBOR.Cuddle.Pretty (PrettyStage)
import qualified Codec.CBOR.Encoding as CBOR
import Codec.CBOR.Pretty (prettyHexEnc)
import qualified Codec.CBOR.Pretty as CBOR
import qualified Codec.CBOR.Term as CBOR
import qualified Codec.CBOR.Write as C
import qualified Codec.CBOR.Write as CBOR
import Control.Monad (unless)
import Data.Data (Proxy (..))
import Data.Either (isLeft)
import qualified Data.Text as T
import GHC.Stack (HasCallStack)
import Prettyprinter (Pretty (pretty), defaultLayoutOptions, layoutPretty)
import qualified Prettyprinter.Render.Terminal as Ansi
import Prettyprinter.Render.Text (hPutDoc)
import System.Directory (createDirectoryIfMissing)
import System.FilePath (takeDirectory)
import System.IO (IOMode (..), hPutStrLn, withFile)
import Test.AntiGen (runAntiGen, tryZapAntiGen)
import Test.Cardano.Ledger.Binary (decoderEquivalenceExpectation)
import Test.Cardano.Ledger.Binary.RoundTrip (
  RoundTripFailure (RoundTripFailure),
  Trip (..),
  cborTrip,
  decodeAnnExtra,
  embedTripLabelExtra,
 )
import Test.Hspec (
  Expectation,
  Spec,
  SpecWith,
  beforeAll,
  describe,
  expectationFailure,
  it,
  shouldBe,
 )
import Test.QuickCheck (
  Arbitrary (..),
  Gen,
  Property,
  Testable (..),
  counterexample,
  discard,
  forAll,
 )

huddleDecoderEquivalenceSpec ::
  forall a.
  (HasCallStack, Eq a, Show a, DecCBOR a, DecCBOR (Annotator a)) =>
  -- | Serialization version
  Version ->
  -- | Name of the CDDL rule to test
  T.Text ->
  SpecWith (CTreeRoot MonoReferenced)
huddleDecoderEquivalenceSpec :: forall a.
(HasCallStack, Eq a, Show a, DecCBOR a, DecCBOR (Annotator a)) =>
Version -> Text -> SpecWith (CTreeRoot MonoReferenced)
huddleDecoderEquivalenceSpec Version
version Text
ruleName =
  let lbl :: Text
lbl = Proxy a -> Text
forall a. DecCBOR a => Proxy a -> Text
label (Proxy a -> Text) -> Proxy a -> Text
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a
   in String
-> (CTreeRoot MonoReferenced -> Property)
-> SpecWith (Arg (CTreeRoot MonoReferenced -> Property))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it (Text -> String
T.unpack Text
ruleName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
lbl) ((CTreeRoot MonoReferenced -> Property)
 -> SpecWith (Arg (CTreeRoot MonoReferenced -> Property)))
-> (CTreeRoot MonoReferenced -> Property)
-> SpecWith (Arg (CTreeRoot MonoReferenced -> Property))
forall a b. (a -> b) -> a -> b
$ \(CTreeRoot MonoReferenced -> CTreeRoot GenPhase
forall {k} (f :: k -> *) (i :: k) (j :: k).
IndexMappable f i j =>
f i -> f j
mapIndex -> CTreeRoot GenPhase
cddl) -> Gen Expectation -> Property
forall prop. Testable prop => prop -> Property
property (Gen Expectation -> Property) -> Gen Expectation -> Property
forall a b. (a -> b) -> a -> b
$ do
        term <- AntiGen Term -> Gen Term
forall a. AntiGen a -> Gen a
runAntiGen (AntiGen Term -> Gen Term)
-> (Name -> AntiGen Term) -> Name -> Gen Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => CTreeRoot GenPhase -> Name -> AntiGen Term
CTreeRoot GenPhase -> Name -> AntiGen Term
generateFromName CTreeRoot GenPhase
cddl (Name -> Gen Term) -> Name -> Gen Term
forall a b. (a -> b) -> a -> b
$ Text -> Name
Name Text
ruleName
        let encoding = Term -> Encoding
CBOR.encodeTerm Term
term
            initCborBytes = Encoding -> ByteString
CBOR.toLazyByteString Encoding
encoding
        pure $ decoderEquivalenceExpectation @a version initCborBytes

huddleRoundTripCborSpec ::
  forall a.
  (HasCallStack, Eq a, Show a, EncCBOR a, DecCBOR a) =>
  -- | Serialization version
  Version ->
  -- | Name of the CDDL rule to test
  T.Text ->
  SpecWith (CTreeRoot MonoReferenced)
huddleRoundTripCborSpec :: forall a.
(HasCallStack, Eq a, Show a, EncCBOR a, DecCBOR a) =>
Version -> Text -> SpecWith (CTreeRoot MonoReferenced)
huddleRoundTripCborSpec Version
version Text
ruleName =
  let lbl :: Text
lbl = Proxy a -> Text
forall a. DecCBOR a => Proxy a -> Text
label (Proxy a -> Text) -> Proxy a -> Text
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a
      trip :: Trip a a
trip = forall a b. (EncCBOR a, DecCBOR b) => Trip a b
cborTrip @a
   in String
-> SpecWith (CTreeRoot MonoReferenced)
-> SpecWith (CTreeRoot MonoReferenced)
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Generate bytestring from CDDL and decode -> encode" (SpecWith (CTreeRoot MonoReferenced)
 -> SpecWith (CTreeRoot MonoReferenced))
-> SpecWith (CTreeRoot MonoReferenced)
-> SpecWith (CTreeRoot MonoReferenced)
forall a b. (a -> b) -> a -> b
$
        String
-> (CTreeRoot MonoReferenced -> Property)
-> SpecWith (Arg (CTreeRoot MonoReferenced -> Property))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it (Text -> String
T.unpack Text
ruleName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
lbl) ((CTreeRoot MonoReferenced -> Property)
 -> SpecWith (Arg (CTreeRoot MonoReferenced -> Property)))
-> (CTreeRoot MonoReferenced -> Property)
-> SpecWith (Arg (CTreeRoot MonoReferenced -> Property))
forall a b. (a -> b) -> a -> b
$ \(CTreeRoot MonoReferenced -> CTreeRoot GenPhase
forall {k} (f :: k -> *) (i :: k) (j :: k).
IndexMappable f i j =>
f i -> f j
mapIndex -> CTreeRoot GenPhase
cddl) -> Gen Expectation -> Property
forall prop. Testable prop => prop -> Property
property (Gen Expectation -> Property) -> Gen Expectation -> Property
forall a b. (a -> b) -> a -> b
$ do
          term <- AntiGen Term -> Gen Term
forall a. AntiGen a -> Gen a
runAntiGen (AntiGen Term -> Gen Term)
-> (Name -> AntiGen Term) -> Name -> Gen Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => CTreeRoot GenPhase -> Name -> AntiGen Term
CTreeRoot GenPhase -> Name -> AntiGen Term
generateFromName CTreeRoot GenPhase
cddl (Name -> Gen Term) -> Name -> Gen Term
forall a b. (a -> b) -> a -> b
$ Text -> Name
Name Text
ruleName
          pure $ roundTripExample lbl version version trip term

huddleRoundTripAnnCborSpec ::
  forall a.
  (HasCallStack, Eq a, Show a, EncCBOR a, DecCBOR (Annotator a)) =>
  -- | Serialization version
  Version ->
  -- | Name of the CDDL rule to test
  T.Text ->
  SpecWith (CTreeRoot MonoReferenced)
huddleRoundTripAnnCborSpec :: forall a.
(HasCallStack, Eq a, Show a, EncCBOR a, DecCBOR (Annotator a)) =>
Version -> Text -> SpecWith (CTreeRoot MonoReferenced)
huddleRoundTripAnnCborSpec Version
version Text
ruleName =
  let lbl :: Text
lbl = Proxy (Annotator a) -> Text
forall a. DecCBOR a => Proxy a -> Text
label (Proxy (Annotator a) -> Text) -> Proxy (Annotator a) -> Text
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(Annotator a)
      trip :: Trip a (Annotator a)
trip = forall a b. (EncCBOR a, DecCBOR b) => Trip a b
cborTrip @a
   in String
-> (CTreeRoot MonoReferenced -> Property)
-> SpecWith (Arg (CTreeRoot MonoReferenced -> Property))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it (Text -> String
T.unpack Text
ruleName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
lbl) ((CTreeRoot MonoReferenced -> Property)
 -> SpecWith (Arg (CTreeRoot MonoReferenced -> Property)))
-> (CTreeRoot MonoReferenced -> Property)
-> SpecWith (Arg (CTreeRoot MonoReferenced -> Property))
forall a b. (a -> b) -> a -> b
$ \(CTreeRoot MonoReferenced -> CTreeRoot GenPhase
forall {k} (f :: k -> *) (i :: k) (j :: k).
IndexMappable f i j =>
f i -> f j
mapIndex -> CTreeRoot GenPhase
cddl) -> Gen Expectation -> Property
forall prop. Testable prop => prop -> Property
property (Gen Expectation -> Property) -> Gen Expectation -> Property
forall a b. (a -> b) -> a -> b
$ do
        term <- AntiGen Term -> Gen Term
forall a. AntiGen a -> Gen a
runAntiGen (AntiGen Term -> Gen Term)
-> (Name -> AntiGen Term) -> Name -> Gen Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => CTreeRoot GenPhase -> Name -> AntiGen Term
CTreeRoot GenPhase -> Name -> AntiGen Term
generateFromName CTreeRoot GenPhase
cddl (Name -> Gen Term) -> Name -> Gen Term
forall a b. (a -> b) -> a -> b
$ Text -> Name
Name Text
ruleName
        pure $ roundTripAnnExample lbl version version trip term

huddleAntiCborSpec ::
  forall a.
  DecCBOR a =>
  Version ->
  T.Text ->
  SpecWith (CTreeRoot MonoReferenced)
huddleAntiCborSpec :: forall a.
DecCBOR a =>
Version -> Text -> SpecWith (CTreeRoot MonoReferenced)
huddleAntiCborSpec Version
version Text
ruleName =
  let lbl :: Text
lbl = Proxy a -> Text
forall a. DecCBOR a => Proxy a -> Text
label (Proxy a -> Text) -> Proxy a -> Text
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a
   in String
-> SpecWith (CTreeRoot MonoReferenced)
-> SpecWith (CTreeRoot MonoReferenced)
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Decoding fails when term is zapped"
        (SpecWith (CTreeRoot MonoReferenced)
 -> SpecWith (CTreeRoot MonoReferenced))
-> ((CTreeRoot MonoReferenced -> Property)
    -> SpecWith (CTreeRoot MonoReferenced))
-> (CTreeRoot MonoReferenced -> Property)
-> SpecWith (CTreeRoot MonoReferenced)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String
-> (CTreeRoot MonoReferenced -> Property)
-> SpecWith (Arg (CTreeRoot MonoReferenced -> Property))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it (Text -> String
T.unpack Text
ruleName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
lbl)
        ((CTreeRoot MonoReferenced -> Property)
 -> SpecWith (CTreeRoot MonoReferenced))
-> (CTreeRoot MonoReferenced -> Property)
-> SpecWith (CTreeRoot MonoReferenced)
forall a b. (a -> b) -> a -> b
$ \CTreeRoot MonoReferenced
cddl -> forall prop. Testable prop => prop -> Property
property @(Gen Property) (Gen Property -> Property) -> Gen Property -> Property
forall a b. (a -> b) -> a -> b
$ do
          mTerm <- Int -> AntiGen Term -> Gen (Maybe Term)
forall a. Int -> AntiGen a -> Gen (Maybe a)
tryZapAntiGen Int
1 (AntiGen Term -> Gen (Maybe Term))
-> (Name -> AntiGen Term) -> Name -> Gen (Maybe Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => CTreeRoot GenPhase -> Name -> AntiGen Term
CTreeRoot GenPhase -> Name -> AntiGen Term
generateFromName (CTreeRoot MonoReferenced -> CTreeRoot GenPhase
forall {k} (f :: k -> *) (i :: k) (j :: k).
IndexMappable f i j =>
f i -> f j
mapIndex CTreeRoot MonoReferenced
cddl) (Name -> Gen (Maybe Term)) -> Name -> Gen (Maybe Term)
forall a b. (a -> b) -> a -> b
$ Text -> Name
Name Text
ruleName
          case mTerm of
            Just Term
term -> do
              let
                encoding :: Encoding
encoding = Version -> Encoding -> Encoding
toPlainEncoding Version
version (Encoding -> Encoding) -> Encoding -> Encoding
forall a b. (a -> b) -> a -> b
$ Term -> Encoding
encodeTerm Term
term
                bs :: ByteString
bs = Encoding -> ByteString
C.toStrictByteString Encoding
encoding
              case HasCallStack =>
ByteString
-> Name -> CTreeRoot ValidatorStage -> Evidenced ValidationTrace
ByteString
-> Name -> CTreeRoot ValidatorStage -> Evidenced ValidationTrace
validateCBOR ByteString
bs (Text -> Name
Name Text
ruleName) (CTreeRoot MonoReferenced -> CTreeRoot ValidatorStage
forall {k} (f :: k -> *) (i :: k) (j :: k).
IndexMappable f i j =>
f i -> f j
mapIndex CTreeRoot MonoReferenced
cddl) of
                Evidenced SValidity v
SInvalid ValidationTrace v
trc -> do
                  let
                    errMsg :: String
errMsg =
                      [String] -> String
unlines
                        [ String
"Generated term:"
                        , Encoding -> String
prettyHexEnc Encoding
encoding
                        , String
forall a. Monoid a => a
mempty
                        , String
"Validation result:"
                        , Text -> String
T.unpack (Text -> String)
-> (Doc AnsiStyle -> Text) -> Doc AnsiStyle -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleDocStream AnsiStyle -> Text
Ansi.renderStrict (SimpleDocStream AnsiStyle -> Text)
-> (Doc AnsiStyle -> SimpleDocStream AnsiStyle)
-> Doc AnsiStyle
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc AnsiStyle -> SimpleDocStream AnsiStyle
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
defaultLayoutOptions (Doc AnsiStyle -> String) -> Doc AnsiStyle -> String
forall a b. (a -> b) -> a -> b
$
                            TraceOptions -> ValidationTrace v -> Doc AnsiStyle
forall (v :: Validity).
TraceOptions -> ValidationTrace v -> Doc AnsiStyle
prettyValidationTrace (TraceOptions
defaultTraceOptions {toFoldValid = True}) ValidationTrace v
trc
                        , String
forall a. Monoid a => a
mempty
                        , String
"Decoding succeeded, expected failure"
                        ]
                  Property -> Gen Property
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> Gen Property)
-> (Either DecoderError a -> Property)
-> Either DecoderError a
-> Gen Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
errMsg (Bool -> Property)
-> (Either DecoderError a -> Bool)
-> Either DecoderError a
-> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either DecoderError a -> Bool
forall a b. Either a b -> Bool
isLeft (Either DecoderError a -> Gen Property)
-> Either DecoderError a -> Gen Property
forall a b. (a -> b) -> a -> b
$ forall a.
DecCBOR a =>
Version -> ByteString -> Either DecoderError a
decodeFull' @a Version
version ByteString
bs
                Evidenced SValidity v
SValid ValidationTrace v
_ -> Gen Property
forall a. a
discard
            Maybe Term
Nothing -> Gen Property
forall a. a
discard

specWithHuddle :: Cuddle.Huddle -> SpecWith (CTreeRoot MonoReferenced) -> Spec
specWithHuddle :: Huddle -> SpecWith (CTreeRoot MonoReferenced) -> Spec
specWithHuddle Huddle
h =
  IO (CTreeRoot MonoReferenced)
-> SpecWith (CTreeRoot MonoReferenced) -> Spec
forall a. HasCallStack => IO a -> SpecWith a -> Spec
beforeAll (IO (CTreeRoot MonoReferenced)
 -> SpecWith (CTreeRoot MonoReferenced) -> Spec)
-> IO (CTreeRoot MonoReferenced)
-> SpecWith (CTreeRoot MonoReferenced)
-> Spec
forall a b. (a -> b) -> a -> b
$
    let cddl :: CDDL HuddleStage
cddl = Huddle -> CDDL HuddleStage
Cuddle.toCDDL Huddle
h
        rCddl :: Either NameResolutionFailure (CTreeRoot MonoReferenced)
rCddl = CDDL CTreePhase
-> Either NameResolutionFailure (CTreeRoot MonoReferenced)
Cuddle.fullResolveCDDL (CDDL HuddleStage -> CDDL CTreePhase
forall i j.
(IndexMappable XXType2 i j, IndexMappable XTerm i j,
 IndexMappable XRule i j) =>
CDDL i -> CDDL j
mapCDDLDropExt CDDL HuddleStage
cddl)
     in case Either NameResolutionFailure (CTreeRoot MonoReferenced)
rCddl of
          Right CTreeRoot MonoReferenced
ct ->
            CTreeRoot MonoReferenced -> IO (CTreeRoot MonoReferenced)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CTreeRoot MonoReferenced
ct
          Left NameResolutionFailure
nrf -> String -> IO (CTreeRoot MonoReferenced)
forall a. HasCallStack => String -> a
error (String -> IO (CTreeRoot MonoReferenced))
-> String -> IO (CTreeRoot MonoReferenced)
forall a b. (a -> b) -> a -> b
$ NameResolutionFailure -> String
forall a. Show a => a -> String
show NameResolutionFailure
nrf

-- | Verify that random data generated is:
--
-- * Decoded successfully into a Haskell type using the decoder in `Trip` and the version
--   supplied
--
-- * When reencoded produces a valid `FlatTerm`
--
-- * When decoded again from the bytes produced by the encoder matches the type exactly
--   when it was decoded from random bytes
roundTripExample ::
  (HasCallStack, Show a, Eq a) =>
  T.Text ->
  -- | Version to use for decoding
  Version ->
  -- | Version to use for encoding
  Version ->
  -- | Decode/encoder that needs tsting
  Trip a a ->
  -- | Randomly generated data and the CDDL spec
  CBOR.Term ->
  Expectation
roundTripExample :: forall a.
(HasCallStack, Show a, Eq a) =>
Text -> Version -> Version -> Trip a a -> Term -> Expectation
roundTripExample Text
lbl Version
encVersion Version
decVersion trip :: Trip a a
trip@Trip {forall s. Decoder s a
tripDecoder :: forall s. Decoder s a
tripDecoder :: forall a b. Trip a b -> forall s. Decoder s b
tripDecoder} Term
term =
  let
    encoding :: Encoding
encoding = Term -> Encoding
CBOR.encodeTerm Term
term
    initCborBytes :: ByteString
initCborBytes = Encoding -> ByteString
CBOR.toLazyByteString Encoding
encoding
    mkFailure :: Maybe ByteString
-> Maybe String
-> Maybe DecoderError
-> Maybe DecoderError
-> RoundTripFailure
mkFailure =
      Version
-> Version
-> Encoding
-> ByteString
-> Maybe ByteString
-> Maybe String
-> Maybe DecoderError
-> Maybe DecoderError
-> RoundTripFailure
RoundTripFailure Version
encVersion Version
decVersion Encoding
encoding ByteString
initCborBytes
   in
    case Version
-> Text
-> (forall s. Decoder s a)
-> ByteString
-> Either DecoderError a
forall a.
Version
-> Text
-> (forall s. Decoder s a)
-> ByteString
-> Either DecoderError a
decodeFullDecoder Version
decVersion Text
lbl Decoder s a
forall s. Decoder s a
tripDecoder ByteString
initCborBytes of
      Left DecoderError
decErr -> HasCallStack => Encoding -> RoundTripFailure -> Expectation
Encoding -> RoundTripFailure -> Expectation
cddlFailure Encoding
encoding (RoundTripFailure -> Expectation)
-> RoundTripFailure -> Expectation
forall a b. (a -> b) -> a -> b
$ Maybe ByteString
-> Maybe String
-> Maybe DecoderError
-> Maybe DecoderError
-> RoundTripFailure
mkFailure Maybe ByteString
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing Maybe DecoderError
forall a. Maybe a
Nothing (DecoderError -> Maybe DecoderError
forall a. a -> Maybe a
Just DecoderError
decErr)
      Right a
val ->
        case Text
-> Version
-> Version
-> Trip a a
-> a
-> Either RoundTripFailure (a, Encoding, ByteString)
forall a b.
Eq b =>
Text
-> Version
-> Version
-> Trip a b
-> a
-> Either RoundTripFailure (b, Encoding, ByteString)
embedTripLabelExtra Text
lbl Version
encVersion Version
decVersion Trip a a
trip a
val of
          Right (a
val', Encoding
_encoding, ByteString
_encodedBytes) ->
            a
val' a -> a -> Expectation
forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` a
val
          Left RoundTripFailure
embedErr -> HasCallStack => Encoding -> RoundTripFailure -> Expectation
Encoding -> RoundTripFailure -> Expectation
cddlFailure Encoding
encoding RoundTripFailure
embedErr

-- | Same as `roundTripExample`, but works for decoders that are wrapped into
-- `Annotator`
roundTripAnnExample ::
  (HasCallStack, Show a, Eq a) =>
  T.Text ->
  -- | Version to use for decoding
  Version ->
  -- | Version to use for encoding
  Version ->
  -- | Decode/encoder that needs tsting
  Trip a (Annotator a) ->
  -- | Randomly generated data and the CDDL spec
  CBOR.Term ->
  Expectation
roundTripAnnExample :: forall a.
(HasCallStack, Show a, Eq a) =>
Text
-> Version
-> Version
-> Trip a (Annotator a)
-> Term
-> Expectation
roundTripAnnExample Text
lbl Version
encVersion Version
decVersion Trip {a -> Encoding
tripEncoder :: a -> Encoding
tripEncoder :: forall a b. Trip a b -> a -> Encoding
tripEncoder, forall s. Decoder s (Annotator a)
tripDecoder :: forall a b. Trip a b -> forall s. Decoder s b
tripDecoder :: forall s. Decoder s (Annotator a)
tripDecoder} Term
term =
  let
    encoding :: Encoding
encoding = Term -> Encoding
CBOR.encodeTerm Term
term
    initCborBytes :: ByteString
initCborBytes = Encoding -> ByteString
CBOR.toLazyByteString Encoding
encoding
    mkFailure :: Maybe ByteString
-> Maybe String
-> Maybe DecoderError
-> Maybe DecoderError
-> RoundTripFailure
mkFailure =
      Version
-> Version
-> Encoding
-> ByteString
-> Maybe ByteString
-> Maybe String
-> Maybe DecoderError
-> Maybe DecoderError
-> RoundTripFailure
RoundTripFailure Version
encVersion Version
decVersion Encoding
encoding ByteString
initCborBytes
   in
    case Version
-> Text
-> (forall s. Decoder s (Annotator a))
-> ByteString
-> Either DecoderError a
forall a.
Version
-> Text
-> (forall s. Decoder s (Annotator a))
-> ByteString
-> Either DecoderError a
decodeFullAnnotator Version
decVersion Text
lbl Decoder s (Annotator a)
forall s. Decoder s (Annotator a)
tripDecoder ByteString
initCborBytes of
      Left DecoderError
decErr -> HasCallStack => Encoding -> RoundTripFailure -> Expectation
Encoding -> RoundTripFailure -> Expectation
cddlFailure Encoding
encoding (RoundTripFailure -> Expectation)
-> RoundTripFailure -> Expectation
forall a b. (a -> b) -> a -> b
$ Maybe ByteString
-> Maybe String
-> Maybe DecoderError
-> Maybe DecoderError
-> RoundTripFailure
mkFailure Maybe ByteString
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing Maybe DecoderError
forall a. Maybe a
Nothing (DecoderError -> Maybe DecoderError
forall a. a -> Maybe a
Just DecoderError
decErr)
      Right a
val ->
        let enc :: Encoding
enc = Version -> Encoding -> Encoding
toPlainEncoding Version
encVersion (Encoding -> Encoding) -> Encoding -> Encoding
forall a b. (a -> b) -> a -> b
$ a -> Encoding
tripEncoder a
val
         in case Text
-> Version
-> Version
-> (forall s. Decoder s (Annotator a))
-> Encoding
-> Either RoundTripFailure (a, ByteString)
forall t.
Text
-> Version
-> Version
-> (forall s. Decoder s (Annotator t))
-> Encoding
-> Either RoundTripFailure (t, ByteString)
decodeAnnExtra Text
lbl Version
encVersion Version
decVersion Decoder s (Annotator a)
forall s. Decoder s (Annotator a)
tripDecoder Encoding
enc of
              Right (a
val', ByteString
_encodedBytes) ->
                a
val' a -> a -> Expectation
forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` a
val
              Left RoundTripFailure
embedErr -> HasCallStack => Encoding -> RoundTripFailure -> Expectation
Encoding -> RoundTripFailure -> Expectation
cddlFailure Encoding
encoding RoundTripFailure
embedErr

cddlFailure :: HasCallStack => CBOR.Encoding -> RoundTripFailure -> Expectation
cddlFailure :: HasCallStack => Encoding -> RoundTripFailure -> Expectation
cddlFailure Encoding
encoding RoundTripFailure
err =
  HasCallStack => String -> Expectation
String -> Expectation
expectationFailure (String -> Expectation) -> String -> Expectation
forall a b. (a -> b) -> a -> b
$
    [String] -> String
unlines
      [ String
"Failed Cddl RoundTrip verification:"
      , RoundTripFailure -> String
forall a. Show a => a -> String
show RoundTripFailure
err
      , String
"Generated diag: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Encoding -> String
CBOR.prettyHexEnc Encoding
encoding
      ]

showValidationTrace :: Evidenced ValidationTrace -> String
showValidationTrace :: Evidenced ValidationTrace -> String
showValidationTrace (Evidenced SValidity v
_ ValidationTrace v
t) =
  Text -> String
T.unpack (Text -> String)
-> (Doc AnsiStyle -> Text) -> Doc AnsiStyle -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleDocStream AnsiStyle -> Text
Ansi.renderStrict (SimpleDocStream AnsiStyle -> Text)
-> (Doc AnsiStyle -> SimpleDocStream AnsiStyle)
-> Doc AnsiStyle
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc AnsiStyle -> SimpleDocStream AnsiStyle
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
defaultLayoutOptions (Doc AnsiStyle -> String) -> Doc AnsiStyle -> String
forall a b. (a -> b) -> a -> b
$
    TraceOptions -> ValidationTrace v -> Doc AnsiStyle
forall (v :: Validity).
TraceOptions -> ValidationTrace v -> Doc AnsiStyle
prettyValidationTrace TraceOptions
defaultTraceOptions ValidationTrace v
t

huddleRoundTripGenValidate ::
  forall a.
  (DecCBOR a, Show a, EncCBOR a) => Gen a -> Version -> T.Text -> SpecWith (CTreeRoot MonoReferenced)
huddleRoundTripGenValidate :: forall a.
(DecCBOR a, Show a, EncCBOR a) =>
Gen a -> Version -> Text -> SpecWith (CTreeRoot MonoReferenced)
huddleRoundTripGenValidate Gen a
gen Version
version Text
ruleName =
  let lbl :: Text
lbl = Proxy a -> Text
forall a. DecCBOR a => Proxy a -> Text
label (Proxy a -> Text) -> Proxy a -> Text
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a
   in String
-> SpecWith (CTreeRoot MonoReferenced)
-> SpecWith (CTreeRoot MonoReferenced)
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Encode an arbitrary value and check against CDDL"
        (SpecWith (CTreeRoot MonoReferenced)
 -> SpecWith (CTreeRoot MonoReferenced))
-> ((CTreeRoot MonoReferenced -> Property)
    -> SpecWith (CTreeRoot MonoReferenced))
-> (CTreeRoot MonoReferenced -> Property)
-> SpecWith (CTreeRoot MonoReferenced)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String
-> (CTreeRoot MonoReferenced -> Property)
-> SpecWith (Arg (CTreeRoot MonoReferenced -> Property))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it (Text -> String
T.unpack Text
ruleName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
lbl)
        ((CTreeRoot MonoReferenced -> Property)
 -> SpecWith (CTreeRoot MonoReferenced))
-> (CTreeRoot MonoReferenced -> Property)
-> SpecWith (CTreeRoot MonoReferenced)
forall a b. (a -> b) -> a -> b
$ \CTreeRoot MonoReferenced
cddl -> Property -> Property
forall prop. Testable prop => prop -> Property
property (Property -> Property)
-> ((a -> Expectation) -> Property)
-> (a -> Expectation)
-> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Gen a -> (a -> Expectation) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen a
gen ((a -> Expectation) -> Property) -> (a -> Expectation) -> Property
forall a b. (a -> b) -> a -> b
$
          \(a
val :: a) -> do
            let
              bs :: ByteString
bs = Version -> a -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
serialize' Version
version a
val
              res :: Evidenced ValidationTrace
res = HasCallStack =>
ByteString
-> Name -> CTreeRoot ValidatorStage -> Evidenced ValidationTrace
ByteString
-> Name -> CTreeRoot ValidatorStage -> Evidenced ValidationTrace
validateCBOR ByteString
bs (Text -> Name
Name Text
ruleName) (CTreeRoot MonoReferenced -> CTreeRoot ValidatorStage
forall {k} (f :: k -> *) (i :: k) (j :: k).
IndexMappable f i j =>
f i -> f j
mapIndex CTreeRoot MonoReferenced
cddl)
            Bool -> Expectation -> Expectation
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Evidenced ValidationTrace -> Bool
forall (t :: Validity -> *). Evidenced t -> Bool
isValid Evidenced ValidationTrace
res) (Expectation -> Expectation)
-> (String -> Expectation) -> String -> Expectation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => String -> Expectation
String -> Expectation
expectationFailure (String -> Expectation) -> String -> Expectation
forall a b. (a -> b) -> a -> b
$
              String
"CBOR Validation failed\nError:\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Evidenced ValidationTrace -> String
showValidationTrace Evidenced ValidationTrace
res

huddleRoundTripArbitraryValidate ::
  forall a.
  ( DecCBOR a
  , EncCBOR a
  , Arbitrary a
  , Show a
  ) =>
  Version ->
  T.Text ->
  SpecWith (CTreeRoot MonoReferenced)
huddleRoundTripArbitraryValidate :: forall a.
(DecCBOR a, EncCBOR a, Arbitrary a, Show a) =>
Version -> Text -> SpecWith (CTreeRoot MonoReferenced)
huddleRoundTripArbitraryValidate = Gen a -> Version -> Text -> SpecWith (CTreeRoot MonoReferenced)
forall a.
(DecCBOR a, Show a, EncCBOR a) =>
Gen a -> Version -> Text -> SpecWith (CTreeRoot MonoReferenced)
huddleRoundTripGenValidate (Gen a -> Version -> Text -> SpecWith (CTreeRoot MonoReferenced))
-> Gen a -> Version -> Text -> SpecWith (CTreeRoot MonoReferenced)
forall a b. (a -> b) -> a -> b
$ forall a. Arbitrary a => Gen a
arbitrary @a

--------------------------------------------------------------------------------
-- Writing specs to a file
--------------------------------------------------------------------------------

-- | Write a Huddle specification to a file at the given path
writeSpec :: Cuddle.Huddle -> FilePath -> IO ()
writeSpec :: Huddle -> String -> Expectation
writeSpec Huddle
hddl String
path = do
  let cddl :: CDDL HuddleStage
cddl = Huddle -> CDDL HuddleStage
Cuddle.toCDDLNoRoot Huddle
hddl
  Bool -> String -> Expectation
createDirectoryIfMissing Bool
True (String -> String
takeDirectory String
path)
  String -> IOMode -> (Handle -> Expectation) -> Expectation
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
path IOMode
WriteMode ((Handle -> Expectation) -> Expectation)
-> (Handle -> Expectation) -> Expectation
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
    Handle -> String -> Expectation
hPutStrLn
      Handle
h
      String
"; This file was auto-generated using generate-cddl. Please do not modify it directly!\n"
    Handle -> Doc (ZonkAny 0) -> Expectation
forall ann. Handle -> Doc ann -> Expectation
hPutDoc Handle
h (CDDL PrettyStage -> Doc (ZonkAny 0)
forall a ann. Pretty a => a -> Doc ann
forall ann. CDDL PrettyStage -> Doc ann
pretty (forall {k} (f :: k -> *) (i :: k) (j :: k).
IndexMappable f i j =>
f i -> f j
forall (f :: * -> *) i j. IndexMappable f i j => f i -> f j
mapIndex @_ @_ @PrettyStage CDDL HuddleStage
cddl))
    -- Write an empty line at the end of the file
    Handle -> String -> Expectation
hPutStrLn Handle
h String
""
  -- Write log to stdout
  String -> Expectation
putStrLn (String -> Expectation) -> String -> Expectation
forall a b. (a -> b) -> a -> b
$ String
"Generated CDDL file at: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
path