cuddle 1.1.0.0 → 1.1.1.0

raw patch · 4 files changed

+285/−38 lines, 4 filesnew-uploaderPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• cuddle.cabal +2/−1
• src/Codec/CBOR/Cuddle/CBOR/Validator.hs +41/−33
• test/Test/Codec/CBOR/Cuddle/CDDL/Validator.hs +236/−4

@@ -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`

@@ -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

@@ -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

@@ -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