{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Test.Cardano.Ledger.CanonicalState.Conformance (
  propReferenceAcceptsCBOR,
  FailureInfo (..),
  Direction (..),
) where

import Codec.CBOR.Cuddle.CBOR.Gen (generateFromName)
import Codec.CBOR.Cuddle.CBOR.Validator (validateCBOR)
import Codec.CBOR.Cuddle.CBOR.Validator.Trace (Evidenced (..), SValidity (..), showValidationTrace)
import Codec.CBOR.Cuddle.CDDL (Name (..))
import Codec.CBOR.Cuddle.CDDL.CTree (CTreeRoot)
import Codec.CBOR.Cuddle.CDDL.Custom.Generator (GenConfig (..), runCBORGen)
import Codec.CBOR.Cuddle.CDDL.Resolve (MonoReferenced)
import Codec.CBOR.Cuddle.IndexMappable (mapIndex)
import Codec.CBOR.Term (encodeTerm)
import Codec.CBOR.Write (toStrictByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base16 as Base16
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Test.AntiGen (runAntiGen)
import Test.QuickCheck (generate)

-- | Direction of conformance test
data Direction
  = -- | Reference CDDL generated the CBOR, Huddle validated it
    HuddleValidating
  | -- | Huddle generated the CBOR, Reference CDDL validated it
    ReferenceValidating
  deriving (Int -> Direction -> ShowS
[Direction] -> ShowS
Direction -> String
(Int -> Direction -> ShowS)
-> (Direction -> String)
-> ([Direction] -> ShowS)
-> Show Direction
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Direction -> ShowS
showsPrec :: Int -> Direction -> ShowS
$cshow :: Direction -> String
show :: Direction -> String
$cshowList :: [Direction] -> ShowS
showList :: [Direction] -> ShowS
Show, Direction -> Direction -> Bool
(Direction -> Direction -> Bool)
-> (Direction -> Direction -> Bool) -> Eq Direction
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Direction -> Direction -> Bool
== :: Direction -> Direction -> Bool
$c/= :: Direction -> Direction -> Bool
/= :: Direction -> Direction -> Bool
Eq)

-- | Information about a validation failure
data FailureInfo = FailureInfo
  { FailureInfo -> Direction
failDirection :: Direction
  , FailureInfo -> Text
failCborHex :: Text
  , FailureInfo -> Text
failErrorMessage :: Text
  }
  deriving (Int -> FailureInfo -> ShowS
[FailureInfo] -> ShowS
FailureInfo -> String
(Int -> FailureInfo -> ShowS)
-> (FailureInfo -> String)
-> ([FailureInfo] -> ShowS)
-> Show FailureInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FailureInfo -> ShowS
showsPrec :: Int -> FailureInfo -> ShowS
$cshow :: FailureInfo -> String
show :: FailureInfo -> String
$cshowList :: [FailureInfo] -> ShowS
showList :: [FailureInfo] -> ShowS
Show, FailureInfo -> FailureInfo -> Bool
(FailureInfo -> FailureInfo -> Bool)
-> (FailureInfo -> FailureInfo -> Bool) -> Eq FailureInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FailureInfo -> FailureInfo -> Bool
== :: FailureInfo -> FailureInfo -> Bool
$c/= :: FailureInfo -> FailureInfo -> Bool
/= :: FailureInfo -> FailureInfo -> Bool
Eq)

generateCBORFromCDDL ::
  -- | CDDL spec
  CTreeRoot MonoReferenced ->
  IO BS.ByteString
generateCBORFromCDDL :: CTreeRoot MonoReferenced -> IO ByteString
generateCBORFromCDDL CTreeRoot MonoReferenced
spec = do
  term <-
    Gen Term -> IO Term
forall a. Gen a -> IO a
generate (Gen Term -> IO Term)
-> (AntiGen Term -> Gen Term) -> AntiGen Term -> IO Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AntiGen Term -> Gen Term
forall a. AntiGen a -> Gen a
runAntiGen (AntiGen Term -> IO Term) -> AntiGen Term -> IO Term
forall a b. (a -> b) -> a -> b
$
      GenConfig -> CBORGen Term -> AntiGen Term
forall a. GenConfig -> CBORGen a -> AntiGen a
runCBORGen (GenConfig {gcTwiddle :: Bool
gcTwiddle = Bool
False, gcRoot :: CTreeRoot GenPhase
gcRoot = CTreeRoot MonoReferenced -> CTreeRoot GenPhase
forall {k} (f :: k -> *) (i :: k) (j :: k).
IndexMappable f i j =>
f i -> f j
mapIndex CTreeRoot MonoReferenced
spec}) (CBORGen Term -> AntiGen Term)
-> (Name -> CBORGen Term) -> Name -> AntiGen Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Name -> CBORGen Term
Name -> CBORGen Term
generateFromName (Name -> AntiGen Term) -> Name -> AntiGen Term
forall a b. (a -> b) -> a -> b
$
        Text -> Name
Name (String -> Text
T.pack String
"record_entry")
  pure $ toStrictByteString $ encodeTerm term

-- | Test if a reference CDDL accepts CBOR generated from another spec
propReferenceAcceptsCBOR ::
  -- | CDDL spec to generate CBOR from
  CTreeRoot MonoReferenced ->
  -- | Reference CDDL spec to validate against
  CTreeRoot MonoReferenced ->
  -- | Direction of testing
  Direction ->
  IO (Either FailureInfo ())
propReferenceAcceptsCBOR :: CTreeRoot MonoReferenced
-> CTreeRoot MonoReferenced
-> Direction
-> IO (Either FailureInfo ())
propReferenceAcceptsCBOR CTreeRoot MonoReferenced
genSpec CTreeRoot MonoReferenced
validateSpec Direction
direction = do
  cbor <- CTreeRoot MonoReferenced -> IO ByteString
generateCBORFromCDDL CTreeRoot MonoReferenced
genSpec

  let result = HasCallStack =>
ByteString
-> Name
-> CTreeRoot ValidatorPhase
-> Either ValidateCBORError (Evidenced ValidationTrace)
ByteString
-> Name
-> CTreeRoot ValidatorPhase
-> Either ValidateCBORError (Evidenced ValidationTrace)
validateCBOR ByteString
cbor (Text -> Name
Name (String -> Text
T.pack String
"record_entry")) (CTreeRoot MonoReferenced -> CTreeRoot ValidatorPhase
forall {k} (f :: k -> *) (i :: k) (j :: k).
IndexMappable f i j =>
f i -> f j
mapIndex CTreeRoot MonoReferenced
validateSpec)
  case result of
    Left ValidateCBORError
e -> Either FailureInfo () -> IO (Either FailureInfo ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either FailureInfo () -> IO (Either FailureInfo ()))
-> Either FailureInfo () -> IO (Either FailureInfo ())
forall a b. (a -> b) -> a -> b
$ FailureInfo -> Either FailureInfo ()
forall a b. a -> Either a b
Left (FailureInfo -> Either FailureInfo ())
-> FailureInfo -> Either FailureInfo ()
forall a b. (a -> b) -> a -> b
$ Direction -> Text -> Text -> FailureInfo
FailureInfo Direction
direction (ByteString -> Text
TE.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
Base16.encode ByteString
cbor) (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ValidateCBORError -> String
forall a. Show a => a -> String
show ValidateCBORError
e)
    Right (Evidenced SValidity v
SValid ValidationTrace v
_) ->
      Either FailureInfo () -> IO (Either FailureInfo ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either FailureInfo () -> IO (Either FailureInfo ()))
-> Either FailureInfo () -> IO (Either FailureInfo ())
forall a b. (a -> b) -> a -> b
$ () -> Either FailureInfo ()
forall a b. b -> Either a b
Right ()
    Right (Evidenced SValidity v
SInvalid ValidationTrace v
trc) ->
      Either FailureInfo () -> IO (Either FailureInfo ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either FailureInfo () -> IO (Either FailureInfo ()))
-> Either FailureInfo () -> IO (Either FailureInfo ())
forall a b. (a -> b) -> a -> b
$
        FailureInfo -> Either FailureInfo ()
forall a b. a -> Either a b
Left (FailureInfo -> Either FailureInfo ())
-> FailureInfo -> Either FailureInfo ()
forall a b. (a -> b) -> a -> b
$
          Direction -> Text -> Text -> FailureInfo
FailureInfo Direction
direction (ByteString -> Text
TE.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
Base16.encode ByteString
cbor) (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ValidationTrace v -> String
forall (v :: Validity). ValidationTrace v -> String
showValidationTrace ValidationTrace v
trc)