diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,11 @@ # Changelog for `cuddle` +## 1.1.1.0 + +* Removed traces from `Codec.CBOR.Cuddle.CBOR.Validator` +* Add `isCBORTermResultValid` +* Add `Eq` instance to `XTerm ValidatorStage`, `XXCTree ValidatorStage` and `CBORTermResult` + ## 1.1.0.0 * Change the type of field of `T2Group` to `GroupDef` diff --git a/cuddle.cabal b/cuddle.cabal --- a/cuddle.cabal +++ b/cuddle.cabal @@ -1,6 +1,6 @@ cabal-version: 3.4 name: cuddle -version: 1.1.0.0 +version: 1.1.1.0 synopsis: CDDL Generator and test utilities description: Cuddle is a library for generating and manipulating [CDDL](https://datatracker.ietf.org/doc/html/rfc8610). @@ -133,6 +133,7 @@ default-language: GHC2021 autogen-modules: Paths_cuddle + other-modules: Paths_cuddle Test.Codec.CBOR.Cuddle.CDDL.Examples diff --git a/src/Codec/CBOR/Cuddle/CBOR/Validator.hs b/src/Codec/CBOR/Cuddle/CBOR/Validator.hs --- a/src/Codec/CBOR/Cuddle/CBOR/Validator.hs +++ b/src/Codec/CBOR/Cuddle/CBOR/Validator.hs @@ -6,6 +6,7 @@ module Codec.CBOR.Cuddle.CBOR.Validator ( validateCBOR, + isCBORTermResultValid, CDDLResult (..), CBORTermResult (..), ValidatorStage, @@ -28,7 +29,6 @@ import Data.Text qualified as T import Data.Text.Lazy qualified as TL import Data.Word -import Debug.Trace (trace, traceShow) import GHC.Float import GHC.Stack (HasCallStack) import Text.Regex.TDFA @@ -36,10 +36,10 @@ type data ValidatorStage data instance XTerm ValidatorStage = ValidatorXTerm - deriving (Show) + deriving (Show, Eq) newtype instance XXCTree ValidatorStage = VRuleRef Name - deriving (Show) + deriving (Show, Eq) instance IndexMappable CTreeRoot MonoReferenced ValidatorStage where mapIndex (CTreeRoot m) = CTreeRoot $ mapIndex <$> m @@ -57,7 +57,7 @@ { ctrTerm :: Term , ctrResult :: CDDLResult } - deriving (Show) + deriving (Show, Eq) data CDDLResult = -- | The rule was valid @@ -111,8 +111,12 @@ String -- | Rule we are trying Rule - deriving (Show) + deriving (Show, Eq) +isCBORTermResultValid :: CBORTermResult -> Bool +isCBORTermResultValid (CBORTermResult _ Valid {}) = True +isCBORTermResultValid _ = False + data ANonMatchedItem = ANonMatchedItem { anmiKey :: Term , anmiValue :: Term @@ -120,14 +124,14 @@ -- ^ For all the tried rules, either the key failed or the key succeeded and -- the value failed } - deriving (Show) + deriving (Show, Eq) data AMatchedItem = AMatchedItem { amiKey :: Term , amiValue :: Term , amiRule :: Rule } - deriving (Show) + deriving (Show, Eq) -------------------------------------------------------------------------------- -- Main entry point @@ -683,13 +687,13 @@ OIOneOrMore -> case validateTermInList (t : ts) ct of (Valid {}, leftover) -> validate leftover (Occur ct OIZeroOrMore : rs) (err, _) -> err - OIBounded _ (Just ub) | ub < 0 -> trace ("out of bounds: " <> show ub) $ ListExpansionFail rule [] [] + OIBounded _ (Just ub) | ub < 0 -> ListExpansionFail rule [] [] OIBounded lb ub | (Valid {}, leftover) <- validateTermInList (t : ts) ct -> validate leftover (Occur ct (decrementBounds lb ub) : rs) | isWithinBoundsInclusive 0 lb ub -> validate (t : ts) rs - | otherwise -> trace "foo" $ UnapplicableRule "validateList" r + | otherwise -> UnapplicableRule "validateList" r _ -> case validateTermInList (t : ts) (resolveIfRef cddl r) of (Valid {}, leftover) -> validate leftover rs (err, _) -> err @@ -708,7 +712,7 @@ -------------------------------------------------------------------------------- -- Maps -validateMap :: CDDL -> [(Term, Term)] -> Rule -> CDDLResult +validateMap :: HasCallStack => CDDL -> [(Term, Term)] -> Rule -> CDDLResult validateMap cddl terms rule = case resolveIfRef cddl rule of Postlude PTAny -> Valid rule @@ -718,37 +722,44 @@ where validate :: [Rule] -> [(Term, Term)] -> [Rule] -> CDDLResult validate [] [] [] = Valid rule - validate exhausted _ [] = trace (unlines $ show <$> exhausted) $ MapExpansionFail rule [] [] + validate _ _ [] = MapExpansionFail rule [] [] validate [] [] (r : rs) | isOptional r = validate [] [] rs | otherwise = UnapplicableRule "validateMap" r - validate exhausted ((k, v) : ts) (r : rs) = case r of + validate exhausted kvs (r : rs) = case r of Occur ct oi -> case oi of OIOptional - | (Valid {}, leftover) <- validateKVInMap ((k, v) : ts) ct + | (Valid {}, leftover) <- validateKVInMap kvs ct , res@Valid {} <- validate [] leftover (exhausted <> rs) -> res - | otherwise -> validate (r : exhausted) ((k, v) : ts) rs + | otherwise -> validate (r : exhausted) kvs rs OIZeroOrMore - | (Valid {}, leftover) <- validateKVInMap ((k, v) : ts) ct + | (Valid {}, leftover) <- validateKVInMap kvs ct , res@Valid {} <- validate [] leftover (r : exhausted <> rs) -> res - | otherwise -> validate (r : exhausted) ((k, v) : ts) rs - OIOneOrMore -> case validateKVInMap ((k, v) : ts) ct of - (Valid {}, leftover) -> validate [] leftover (Occur ct OIZeroOrMore : exhausted <> rs) - (err, _) -> err - OIBounded _ (Just ub) | 0 > ub -> traceShow ub $ MapExpansionFail rule [] [] - OIBounded lb ub - | (Valid {}, leftover) <- validateKVInMap ((k, v) : ts) ct - , not (isWithinBoundsInclusive 0 lb ub) -> - validate [] leftover (Occur ct (decrementBounds lb ub) : exhausted <> rs) - | isWithinBoundsInclusive 0 lb ub && not (isValidTerm ((k, v) : ts) ct) -> - validate (r : exhausted) ((k, v) : ts) rs - | otherwise -> UnapplicableRule "validateMap" r - _ -> case validateKVInMap ((k, v) : ts) r of + | otherwise -> validate (r : exhausted) kvs rs + OIOneOrMore + | (Valid {}, leftover) <- validateKVInMap kvs ct + , res@Valid {} <- validate [] leftover (Occur ct OIZeroOrMore : exhausted <> rs) -> + res + | otherwise -> validate (r : exhausted) kvs rs + OIBounded mlb mub + | Just lb <- mlb, Just ub <- mub, lb > ub -> error "Unsatisfiable range encountered" + | otherwise -> case compare 0 <$> mub of + Just EQ -> validate exhausted kvs rs + Just GT -> error "Unsatisfiable range encountered" + _ + | (Valid {}, leftover) <- validateKVInMap kvs ct + , res@Valid {} <- + validate + [] + leftover + (Occur ct (decrementBounds mlb mub) : exhausted <> rs) -> + res + | otherwise -> validate (r : exhausted) kvs rs + _ -> case validateKVInMap kvs r of (Valid {}, leftover) -> validate [] leftover (exhausted <> rs) - (err, _) -> err - validate _ _ _ = error "Impossible happened" + _ -> validate (r : exhausted) kvs rs validateKVInMap ((tk, tv) : ts) (KV k v _) = case (validateTerm cddl tk k, validateTerm cddl tv v) of (CBORTermResult _ Valid {}, CBORTermResult _ x@Valid {}) -> (x, ts) @@ -756,9 +767,6 @@ (CBORTermResult _ err, _) -> (err, ts) validateKVInMap [] _ = error "No remaining KV pairs" validateKVInMap _ x = error $ "Unexpected value in map: " <> show x - isValidTerm ts r = case validateKVInMap ts r of - (Valid {}, _) -> True - _ -> False -------------------------------------------------------------------------------- -- Choices diff --git a/test/Test/Codec/CBOR/Cuddle/CDDL/Validator.hs b/test/Test/Codec/CBOR/Cuddle/CDDL/Validator.hs --- a/test/Test/Codec/CBOR/Cuddle/CDDL/Validator.hs +++ b/test/Test/Codec/CBOR/Cuddle/CDDL/Validator.hs @@ -1,4 +1,6 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} module Test.Codec.CBOR.Cuddle.CDDL.Validator (spec) where @@ -6,6 +8,7 @@ import Codec.CBOR.Cuddle.CBOR.Validator ( CBORTermResult (..), CDDLResult (..), + isCBORTermResultValid, validateCBOR, ) import Codec.CBOR.Cuddle.CDDL (Name (..)) @@ -13,20 +16,63 @@ import Codec.CBOR.Cuddle.CDDL.CTree qualified as CTree import Codec.CBOR.Cuddle.CDDL.Postlude (appendPostlude) import Codec.CBOR.Cuddle.CDDL.Resolve (fullResolveCDDL) +import Codec.CBOR.Cuddle.Huddle ( + Huddle, + HuddleItem (..), + Value (..), + a, + arr, + asKey, + collectFrom, + idx, + mp, + opt, + toCDDL, + (+>), + (<+), + (=:=), + (==>), + ) import Codec.CBOR.Cuddle.IndexMappable (mapCDDLDropExt, mapIndex) import Codec.CBOR.Cuddle.Parser (pCDDL) -import Codec.CBOR.Term (encodeTerm) +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 Test.Hspec (Spec, describe, runIO, shouldSatisfy) +import Test.Hspec ( + Spec, + describe, + runIO, + shouldSatisfy, + ) import Test.Hspec.QuickCheck -import Test.QuickCheck (counterexample, noShrinking) +import Test.QuickCheck ( + Arbitrary (..), + Gen, + NonNegative (..), + choose, + counterexample, + elements, + forAll, + infiniteListOf, + listOf, + listOf1, + noShrinking, + oneof, + scale, + shuffle, + vectorOf, + ) import Test.QuickCheck.Random (mkQCGen) import Text.Megaparsec (runParser) import Text.Pretty.Simple (pShow) @@ -64,8 +110,163 @@ CBORTermResult _ Valid {} -> True _ -> False +huddleMap :: Huddle +huddleMap = + collectFrom + [ HIRule $ + "a" + =:= mp + [ idx 1 ==> arr [0 <+ a VUInt] + , 1 <+ asKey VBytes ==> VAny + , opt $ idx 2 ==> VBool + , 0 <+ asKey VText ==> VInt + ] + ] + +huddleRangeMap :: Huddle +huddleRangeMap = + collectFrom + [ HIRule $ + "a" + =:= mp + [ 5 <+ asKey VInt ==> VBool +> 10 + ] + ] + +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) + +huddleArray :: Huddle +huddleArray = + collectFrom + [ HIRule $ + "a" + =:= arr + [ 0 <+ a VBool + , 1 <+ a VInt + , opt $ a VText + , a VUInt + ] + ] + +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 + +huddleRangeArray :: Huddle +huddleRangeArray = + collectFrom + [ HIRule $ + "a" + =:= arr + [ opt $ a VInt + , 2 <+ a VInt +> 3 + , a VBool +> 3 + , 3 <+ a VText + ] + ] + +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 + +-- TODO make this complete +arbitraryTerm :: Gen Term +arbitraryTerm = oneof [TBool <$> arbitrary, TInt <$> arbitrary, TString . T.pack <$> 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 :: Term -> Huddle -> Name -> CBORTermResult +validateHuddle term huddle name = 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) + spec :: 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" @@ -74,3 +275,34 @@ genAndValidateFromFile "example/cddl-files/pretty.cddl" genAndValidateFromFile "example/cddl-files/shelley.cddl" genAndValidateFromFile "example/cddl-files/validator.cddl" + describe "Term tests" $ do + describe "Positive" $ do + prop "Validates a full map" . forAll genFullMap $ \cbor -> + validateHuddle cbor huddleMap "a" `shouldSatisfy` isCBORTermResultValid + prop "Validates array" . forAll genHuddleArray $ \cbor -> + validateHuddle cbor huddleArray "a" `shouldSatisfy` isCBORTermResultValid + prop "Validates map with correct number of range elements" + . forAll (genHuddleRangeMap (5, 10)) + $ \cbor -> + validateHuddle cbor huddleRangeMap "a" `shouldSatisfy` isCBORTermResultValid + prop "Validates array with ranges" . forAll genHuddleRangeArray $ \cbor -> + validateHuddle cbor huddleRangeArray "a" `shouldSatisfy` isCBORTermResultValid + describe "Negative" $ do + prop "Fails to validate a map with an unexpected index" + . forAll genBadMapInvalidIndex + $ \cbor -> + validateHuddle cbor huddleMap "a" `shouldSatisfy` not . isCBORTermResultValid + prop "Fails to validate reversed array" . forAll genBadArrayReversed $ \cbor -> + validateHuddle cbor huddleArray "a" `shouldSatisfy` not . isCBORTermResultValid + prop "Fails to validate array with missing non-negative int at the end" + . forAll genBadArrayMissingLastInt + $ \cbor -> + validateHuddle cbor huddleArray "a" `shouldSatisfy` not . isCBORTermResultValid + prop "Fails to validate map with too few range elements" + . forAll (genHuddleRangeMap (0, 4)) + $ \cbor -> + validateHuddle cbor huddleRangeMap "a" `shouldSatisfy` not . isCBORTermResultValid + prop "Fails to validate map with too many range elements" + . forAll (genHuddleRangeMap (11, 20)) + $ \cbor -> + validateHuddle cbor huddleRangeMap "a" `shouldSatisfy` not . isCBORTermResultValid