Validator.hs

{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}

module Test.Codec.CBOR.Cuddle.CDDL.Validator (
  spec,
  expectValid,
  expectInvalid,
  genAndValidateCddl,
  genAndValidateRule,
) where

import Codec.CBOR.Cuddle.CBOR.Gen (generateFromName)
import Codec.CBOR.Cuddle.CBOR.Validator (
  validateCBOR,
 )
import Codec.CBOR.Cuddle.CBOR.Validator.Trace (
  Evidenced (..),
  SValidity (..),
  ValidationTrace,
  defaultTraceOptions,
  prettyValidationTrace,
 )
import Codec.CBOR.Cuddle.CDDL (Name (..))
import Codec.CBOR.Cuddle.CDDL.CBORGenerator (CustomValidatorResult (..), GenEnv (..), runCBORGen)
import Codec.CBOR.Cuddle.CDDL.CTree (CTreeRoot (..))
import Codec.CBOR.Cuddle.CDDL.CTree qualified as CTree
import Codec.CBOR.Cuddle.CDDL.Postlude (appendPostlude)
import Codec.CBOR.Cuddle.CDDL.Resolve (MonoReferenced, fullResolveCDDL)
import Codec.CBOR.Cuddle.Huddle (
  Huddle,
  HuddleItem (..),
  Value (..),
  a,
  arr,
  collectFrom,
  int,
  toCDDL,
  withValidator,
  (=:=),
 )
import Codec.CBOR.Cuddle.IndexMappable (mapCDDLDropExt, mapIndex)
import Codec.CBOR.Cuddle.Parser (pCDDL)
import Codec.CBOR.Pretty (prettyHexEnc)
import Codec.CBOR.Term (Term (..), encodeTerm)
import Codec.CBOR.Write (toStrictByteString)
import Control.Monad (forM_)
import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as LBS
import Data.Containers.ListUtils (nubOrd, nubOrdOn)
import Data.Either (fromRight)
import Data.Map qualified as Map
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.IO qualified as T
import Data.Text.Lazy qualified as LT
import Paths_cuddle (getDataFileName)
import Prettyprinter (defaultLayoutOptions, layoutPretty)
import Prettyprinter.Render.Terminal (renderStrict)
import Test.AntiGen (runAntiGen)
import Test.Codec.CBOR.Cuddle.CDDL.Examples.Huddle (
  huddleArray,
  huddleMap,
  huddleRangeArray,
  huddleRangeMap,
 )
import Test.Hspec (
  Expectation,
  HasCallStack,
  Spec,
  describe,
  expectationFailure,
  it,
  runIO,
 )
import Test.Hspec.QuickCheck
import Test.QuickCheck (
  Arbitrary (..),
  Gen,
  NonNegative (..),
  choose,
  counterexample,
  elements,
  forAll,
  infiniteListOf,
  listOf,
  listOf1,
  oneof,
  scale,
  shuffle,
  vectorOf,
 )
import Text.Megaparsec (runParser)

-- | Test that a specific rule in a resolved CDDL generates valid values
genAndValidateRule :: String -> Name -> CTreeRoot MonoReferenced -> Spec
genAndValidateRule description name resolvedCddl =
  prop description $ do
    let
      genEnv =
        GenEnv
          { geRoot = mapIndex resolvedCddl
          , geTwiddle = True
          }
    cborTerm <- runAntiGen . runCBORGen genEnv $ generateFromName name
    let
      generatedCbor = toStrictByteString $ encodeTerm cborTerm
      res = validateCBOR generatedCbor name (mapIndex resolvedCddl)
      extraInfo =
        unlines
          [ "CBOR term:"
          , prettyHexEnc $ encodeTerm cborTerm
          ]
    pure . counterexample extraInfo $ expectValid res

-- | Test that all rules in a resolved CDDL generate valid values
genAndValidateCddl :: String -> CTreeRoot MonoReferenced -> Spec
genAndValidateCddl description resolvedCddl@(CTreeRoot m) = do
  let
    isRule CTree.Group {} = False
    isRule _ = True
  describe description $ do
    forM_ (Map.keys $ Map.filter isRule m) $ \name@(Name n) ->
      genAndValidateRule (T.unpack n) name resolvedCddl

genAndValidateFromFile :: FilePath -> Spec
genAndValidateFromFile path = do
  contents <- runIO $ T.readFile =<< getDataFileName path
  let
    cddl = fromRight (error "Failed to parse CDDL") $ runParser pCDDL path contents
    resolverError x =
      error $ "Failed to resolve the CDDL from file " <> show path <> ":\n" <> show x
    resolvedCddl =
      either resolverError id . fullResolveCDDL . appendPostlude $
        mapCDDLDropExt cddl
  genAndValidateCddl path resolvedCddl

genInfiniteUniqueList :: Ord a => Gen a -> Gen [a]
genInfiniteUniqueList = fmap nubOrd . infiniteListOf

genHuddleRangeMap :: (Int, Int) -> Gen Term
genHuddleRangeMap rng@(lo, hi) = do
  n <- choose rng
  let genKV = (,) <$> fmap TInt arbitrary <*> fmap TBool arbitrary
  genMapTerm . take n =<< scale (const $ max lo hi) (genInfiniteUniqueList genKV)

genHuddleArrayRequiredTerms :: Gen [Term]
genHuddleArrayRequiredTerms = do
  ints <- listOf1 $ TInt <$> arbitrary
  text <-
    oneof
      [ (: []) <$> (genStringTerm . T.pack =<< arbitrary)
      , pure []
      ]
  lastInt <- TInt . getNonNegative <$> arbitrary
  pure $ ints <> text <> [lastInt]

genHuddleArrayTerms :: Gen [Term]
genHuddleArrayTerms = do
  bools <- listOf $ TBool <$> arbitrary
  required <- genHuddleArrayRequiredTerms
  pure $ bools <> required

genHuddleArray :: Gen Term
genHuddleArray = genHuddleArrayTerms >>= genArrayTerm

genBadArrayReversed :: Gen Term
genBadArrayReversed = genHuddleArrayTerms >>= genArrayTerm . reverse . (TBool True :)

genBadArrayMissingLastInt :: Gen Term
genBadArrayMissingLastInt =
  genHuddleArrayTerms >>= genArrayTerm . reverse . dropWhile isNonNegativeInt . reverse
  where
    isNonNegativeInt (TInt x) | x >= 0 = True
    isNonNegativeInt _ = False

genHuddleRangeArray :: Gen Term
genHuddleRangeArray = do
  numInts <- choose (3, 4)
  ints <- vectorOf numInts $ TInt <$> arbitrary
  numBools <- choose (0, 3)
  bools <- vectorOf numBools $ TBool <$> arbitrary
  numTexts <- choose (3, 10)
  texts <- vectorOf numTexts $ genStringTerm . T.pack =<< arbitrary
  genArrayTerm $ ints <> bools <> texts

genArrayTerm :: [Term] -> Gen Term
genArrayTerm xs = elements [TList xs, TListI xs]

genMapTerm :: [(Term, Term)] -> Gen Term
genMapTerm x = elements [TMap x, TMapI x]

genStringTerm :: Text -> Gen Term
genStringTerm x = elements [TString x, TStringI (LT.fromStrict x)]

genBytesTerm :: ByteString -> Gen Term
genBytesTerm x = elements [TBytes x, TBytesI $ LBS.fromStrict x]

arbitraryByteString :: Gen ByteString
arbitraryByteString = BS.pack <$> arbitrary

arbitraryTerm :: Gen Term
arbitraryTerm =
  oneof
    [ TInt <$> arbitrary
    , TInteger <$> arbitrary
    , TBytes . BS.pack <$> arbitrary
    , TBytesI . LBS.pack <$> arbitrary
    , TString . T.pack <$> arbitrary
    , TStringI . LT.pack <$> arbitrary
    , TList <$> listOf (scale (`div` 2) arbitraryTerm)
    , TListI <$> listOf (scale (`div` 2) arbitraryTerm)
    , TMap <$> listOf (scale (`div` 2) $ (,) <$> arbitraryTerm <*> arbitraryTerm)
    , TMapI <$> listOf (scale (`div` 2) $ (,) <$> arbitraryTerm <*> arbitraryTerm)
    , -- TODO properly implement tagged generation
      -- , TTagged <$> arbitrary <*> arbitraryTerm
      TBool <$> arbitrary
    , pure TNull
    , pure $ TSimple 23 -- TODO add other values once they are supported by cuddle
    , THalf <$> arbitrary
    , TFloat <$> arbitrary
    , TDouble <$> arbitrary
    ]

genFullMap :: Gen Term
genFullMap = do
  field1 <- do
    es <- listOf $ TInt . getNonNegative <$> arbitrary
    pure (TInt 1, TList es)
  lField2 <-
    oneof
      [ do
          b <- arbitrary
          pure [(TInt 2, TBool b)]
      , pure []
      ]
  strFields <-
    nubOrdOn fst <$> listOf ((,) <$> (genStringTerm . T.pack =<< arbitrary) <*> (TInt <$> arbitrary))
  bytesFields <-
    nubOrdOn fst
      <$> listOf1 ((,) <$> (genBytesTerm =<< arbitraryByteString) <*> arbitraryTerm)
  allFields <- shuffle $ field1 : lField2 <> strFields <> bytesFields
  genMapTerm allFields

genBadMapInvalidIndex :: Gen Term
genBadMapInvalidIndex =
  pure $
    TMap
      [ (TInt 1, TList [])
      , (TInt 99, TList [])
      , (TBytes "foo", TBytes "bar")
      ]

validateHuddle ::
  HasCallStack =>
  Huddle ->
  Name ->
  Term ->
  Evidenced ValidationTrace
validateHuddle huddle name term = do
  let
    resolvedCddl = case fullResolveCDDL . mapCDDLDropExt $ toCDDL huddle of
      Right root -> root
      Left err -> error $ show err
    bs = toStrictByteString $ encodeTerm term
  validateCBOR bs name (mapIndex resolvedCddl)

expectValid :: Evidenced ValidationTrace -> Expectation
expectValid (Evidenced SValid _) = pure ()
expectValid (Evidenced SInvalid t) =
  expectationFailure . T.unpack $
    "Expected a success, got failure:\n"
      <> renderStrict (layoutPretty defaultLayoutOptions $ prettyValidationTrace defaultTraceOptions t)

expectInvalid :: Evidenced ValidationTrace -> Expectation
expectInvalid (Evidenced SValid t) =
  expectationFailure . T.unpack $
    "Expected a failure, but got success:\n"
      <> renderStrict (layoutPretty defaultLayoutOptions $ prettyValidationTrace defaultTraceOptions t)
expectInvalid _ = pure ()

stringValidator :: Term -> CustomValidatorResult
stringValidator (TString _) = CustomValidatorSuccess
stringValidator (TStringI _) = CustomValidatorSuccess
stringValidator t = CustomValidatorFailure $ "Expected a string, got\n" <> T.pack (show t)

bytesValidator :: Term -> CustomValidatorResult
bytesValidator (TBytes _) = CustomValidatorSuccess
bytesValidator (TBytesI _) = CustomValidatorSuccess
bytesValidator t = CustomValidatorFailure $ "Expected bytes, got\n" <> T.pack (show t)

spec :: Spec
spec = describe "Validator" $ do
  describe "Generate and validate from file" $ do
    genAndValidateFromFile "example/cddl-files/basic_assign.cddl"
    genAndValidateFromFile "example/cddl-files/conway.cddl"
    genAndValidateFromFile "example/cddl-files/costmdls_min.cddl"
    genAndValidateFromFile "example/cddl-files/issue80-min.cddl"
    genAndValidateFromFile "example/cddl-files/pretty.cddl"
    genAndValidateFromFile "example/cddl-files/shelley.cddl"
    genAndValidateFromFile "example/cddl-files/validator.cddl"
  describe "Term tests" $ do
    describe "Maps and arrays" $ do
      describe "Positive" $ do
        prop "Validates a full map" . forAll genFullMap $
          expectValid . validateHuddle huddleMap "a"
        prop "Validates array" . forAll genHuddleArray $
          expectValid . validateHuddle huddleArray "a"
        prop "Validates map with correct number of range elements"
          . forAll (genHuddleRangeMap (5, 10))
          $ expectValid . validateHuddle huddleRangeMap "a"
        prop "Validates array with ranges" . forAll genHuddleRangeArray $
          expectValid . validateHuddle huddleRangeArray "a"
      describe "Negative" $ do
        prop "Fails to validate a map with an unexpected index"
          . forAll genBadMapInvalidIndex
          $ expectInvalid . validateHuddle huddleMap "a"
        prop "Fails to validate reversed array" . forAll genBadArrayReversed $
          expectInvalid . validateHuddle huddleArray "a"
        prop "Fails to validate array with missing non-negative int at the end"
          . forAll genBadArrayMissingLastInt
          $ expectInvalid . validateHuddle huddleArray "a"
        prop "Fails to validate map with too few range elements"
          . forAll (genHuddleRangeMap (0, 4))
          $ expectInvalid . validateHuddle huddleRangeMap "a"
        prop "Fails to validate map with too many range elements"
          . forAll (genHuddleRangeMap (11, 20))
          $ expectInvalid . validateHuddle huddleRangeMap "a"

    describe "Bignums" $ do
      let
        bignum = 2 ^ (64 :: Int) :: Integer
        bignumCBOR = toStrictByteString . encodeTerm $ TInteger bignum
        resolveCDDL cddlText =
          let cddl = fromRight (error "Failed to parse CDDL") $ runParser pCDDL "" cddlText
           in either (error . show) id . fullResolveCDDL . appendPostlude $ mapCDDLDropExt cddl
      it "Validates a bignum >= 2^64 against biguint" $
        expectValid $
          validateCBOR bignumCBOR "a" (mapIndex $ resolveCDDL "a = biguint")
      it "Validates a bignum >= 2^64 against bigint" $
        expectValid $
          validateCBOR bignumCBOR "a" (mapIndex $ resolveCDDL "a = bigint")
      it "Validates a bignum >= 2^64 against integer" $
        expectValid $
          validateCBOR bignumCBOR "a" (mapIndex $ resolveCDDL "a = integer")
      it "Rejects a bignum >= 2^64 against int" $
        expectInvalid $
          validateCBOR bignumCBOR "a" (mapIndex $ resolveCDDL "a = int")
      it "Rejects a bignum >= 2^64 against uint" $
        expectInvalid $
          validateCBOR bignumCBOR "a" (mapIndex $ resolveCDDL "a = uint")

  describe "Custom validator" $ do
    describe "Positive" $ do
      prop "Validates with custom validator" $ do
        term <- genStringTerm . T.pack =<< arbitrary
        num <- arbitrary
        let
          huddle =
            collectFrom
              [ HIRule . withValidator stringValidator $ "a" =:= int num
              ]
        pure . expectValid $ validateHuddle huddle "a" term
      prop "Validates with custom validator behind a reference" $ do
        stringTerm <- genStringTerm . T.pack =<< arbitrary
        arrTerm <- genArrayTerm [stringTerm]
        num <- arbitrary
        let
          ruleA = withValidator stringValidator $ "a" =:= int num
          huddle =
            collectFrom
              [ HIRule ruleA
              , HIRule $ "b" =:= arr [a ruleA]
              ]
        pure . expectValid $ validateHuddle huddle "b" arrTerm
    describe "Negative" $ do
      prop "Fails if term is valid against the Huddle, but not the custom validator" $ do
        stringTerm <- genStringTerm . T.pack =<< arbitrary
        let
          huddle =
            collectFrom
              [ HIRule . withValidator bytesValidator $ "a" =:= VText
              ]
        pure . expectInvalid $ validateHuddle huddle "a" stringTerm
      prop "Fails if term is valid against the Huddle, but not the custom validator, behind a reference" $ do
        stringTerm <- genStringTerm . T.pack =<< arbitrary
        let
          ruleA = withValidator bytesValidator $ "a" =:= VText
          ruleB = "b" =:= arr [a ruleA]
          huddle =
            collectFrom
              [ HIRule ruleA
              , HIRule ruleB
              ]
        pure . expectInvalid $ validateHuddle huddle "a" stringTerm