cuddle 1.4.0.0 → 1.5.0.0

raw patch · 6 files changed

+70/−34 lines, 6 filesdep ~QuickCheckPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: QuickCheck

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• cuddle.cabal +1/−1
• src/Codec/CBOR/Cuddle/CBOR/Gen.hs +12/−9
• src/Codec/CBOR/Cuddle/CBOR/Validator.hs +26/−11
• src/Codec/CBOR/Cuddle/CBOR/Validator/Trace.hs +13/−13
• test/Test/Codec/CBOR/Cuddle/CDDL/Validator.hs +12/−0

@@ -1,5 +1,11 @@ # Changelog for `cuddle` +## 1.5.0.0++* Fix custom validators not running when reached via type-specific validators+* Replace `TerminalRule (Maybe ControlInfo)` with `TerminalRule` and a new `ControlTrace` constructor+* Fix `InvalidTag` trace showing the bad tag as the expected value+ ## 1.4.0.0  * Changed `generateFromName` to return a `CBORGen` instead of `AntiGen`

@@ -1,6 +1,6 @@ cabal-version: 3.4 name: cuddle-version: 1.4.0.0+version: 1.5.0.0 synopsis: CDDL Generator and test utilities description:   Cuddle is a library for generating and manipulating [CDDL](https://datatracker.ietf.org/doc/html/rfc8610).

@@ -402,7 +402,10 @@     genNodes !i !m (n : ns) =       let         ann = withAntiGen (withAnnotation (T.pack $ show i))-        cont x y = scale (\s -> max 0 (s - 1)) $ genNodes (i + 1) x y+        -- A term was produced, advance the index+        next x y = scale (\s -> max 0 (s - 1)) $ genNodes (i + 1) x y+        -- No term was produced, keep the index+        same x y = scale (\s -> max 0 (s - 1)) $ genNodes i x y         optGenKV kNode vNode = sized $ \sz ->           frequency [(100, pure Nothing), (max 0 sz, ann $ tryGenKV 10 m kNode vNode)]        in@@ -410,19 +413,19 @@           KV kNode vNode _ -> do             mKV <- ann $ tryGenKV 100 m kNode vNode             case mKV of-              Just (k, v) -> cont (Map.insert k v m) ns+              Just (k, v) -> next (Map.insert k v m) ns               Nothing -> pure Nothing           Occur kv@(KV kNode vNode _) oi -> case oi of             OIOptional -> do               mt <- optGenKV kNode vNode               case mt of-                Just (k, v) -> cont (Map.insert k v m) ns-                Nothing -> cont m ns+                Just (k, v) -> next (Map.insert k v m) ns+                Nothing -> same m ns             OIZeroOrMore -> do               mt <- optGenKV kNode vNode               case mt of-                Just (k, v) -> cont (Map.insert k v m) (n : ns)-                Nothing -> cont m ns+                Just (k, v) -> next (Map.insert k v m) (n : ns)+                Nothing -> same m ns             OIOneOrMore -> genNodes i m (kv : Occur kv OIZeroOrMore : ns)             OIBounded mlb mub -> do               let@@ -432,12 +435,12 @@                 newHigh = clampedPred <$> mub                 res                   | maybe False (> 0) mlb = genNodes i m (kv : Occur kv (OIBounded newLow newHigh) : ns)-                  | maybe False (< 1) mub = genNodes i m ns+                  | maybe False (< 1) mub = same m ns                   | otherwise = do                       mt <- optGenKV kNode vNode                       case mt of-                        Just (k, v) -> cont (Map.insert k v m) (Occur kv (OIBounded newLow newHigh) : ns)-                        Nothing -> genNodes i m ns+                        Just (k, v) -> next (Map.insert k v m) (Occur kv (OIBounded newLow newHigh) : ns)+                        Nothing -> same m ns               res           node -> error $ "Unexpected node: " <> showSimple node   mItems <- genNodes 0 Map.empty $ sortOn (Down . elemsNeeded) nodes

@@ -22,7 +22,6 @@   isValid,   mapTrace,   showSimple,-  showValidationTrace,  ) import Codec.CBOR.Cuddle.CDDL hiding (CDDL, Group, Rule) import Codec.CBOR.Cuddle.CDDL.CBORGenerator (CBORValidator (..), CustomValidatorResult (..))@@ -79,10 +78,8 @@ validateTerm cddl term rule   | CTreeE (VRuleRef n) <- rule =       dereferenceAndValidate cddl n (validateTerm cddl term)-  | CTreeE (VValidator (CBORValidator validator) _) <- rule =-      case validator term of-        CustomValidatorSuccess -> evidence CustomSuccess-        CustomValidatorFailure err -> evidence $ CustomFailure err+  | CTreeE (VValidator v _) <- rule =+      runCustomValidator term v   | otherwise =       case term of         TInt i -> validateInteger cddl (fromIntegral i) rule@@ -104,8 +101,16 @@         TDouble d -> validateDouble cddl d rule  terminal :: CTree ValidatorStage -> Evidenced ValidationTrace-terminal = evidence . TerminalRule Nothing . mapIndex+terminal = evidence . TerminalRule . mapIndex +-- | Run a custom validator on a term. This is used by type-specific validators+-- when they encounter a 'VValidator' node after dereferencing a rule reference.+runCustomValidator :: Term -> CBORValidator -> Evidenced ValidationTrace+runCustomValidator term (CBORValidator validator) =+  case validator term of+    CustomValidatorSuccess -> evidence CustomSuccess+    CustomValidatorFailure err -> evidence $ CustomFailure err+ unapplicable :: CTree ValidatorStage -> Evidenced ValidationTrace unapplicable = evidence . UnapplicableRule . mapIndex @@ -132,6 +137,7 @@ validateInteger cddl i rule =   case rule of     CTreeE (VRuleRef n) -> dereferenceAndValidate cddl n $ validateInteger cddl i+    CTreeE (VValidator v _) -> runCustomValidator (TInteger i) v     -- echo "C24101" | xxd -r -p - example.cbor     -- echo "foo = int" > a.cddl     -- cddl a.cddl validate example.cbor@@ -301,6 +307,7 @@   CTree ValidatorStage ->   Evidenced ValidationTrace validateHalf cddl f (CTreeE (VRuleRef n)) = dereferenceAndValidate cddl n $ validateHalf cddl f+validateHalf _ f (CTreeE (VValidator v _)) = runCustomValidator (THalf f) v validateHalf cddl f rule =   case rule of     -- a = any@@ -351,6 +358,7 @@   Evidenced ValidationTrace validateFloat cddl f (CTreeE (VRuleRef n)) =   dereferenceAndValidate cddl n $ validateFloat cddl f+validateFloat _ f (CTreeE (VValidator v _)) = runCustomValidator (TFloat f) v validateFloat cddl f rule =   case rule of     -- a = any@@ -412,6 +420,7 @@   Evidenced ValidationTrace validateDouble cddl f (CTreeE (VRuleRef n)) =   dereferenceAndValidate cddl n $ validateDouble cddl f+validateDouble _ f (CTreeE (VValidator v _)) = runCustomValidator (TDouble f) v validateDouble cddl f rule =   case rule of     -- a = any@@ -481,6 +490,7 @@   Evidenced ValidationTrace validateBool cddl b (CTreeE (VRuleRef n)) =   dereferenceAndValidate cddl n $ validateBool cddl b+validateBool _ b (CTreeE (VValidator v _)) = runCustomValidator (TBool b) v validateBool cddl b rule =   case rule of     -- a = any@@ -526,6 +536,7 @@   Evidenced ValidationTrace validateSimple cddl i (CTreeE (VRuleRef n)) =   dereferenceAndValidate cddl n $ validateSimple cddl i+validateSimple _ i (CTreeE (VValidator v _)) = runCustomValidator (TSimple i) v validateSimple cddl 23 rule =   case rule of     -- a = any@@ -544,6 +555,7 @@ validateNull :: CTreeRoot ValidatorStage -> CTree ValidatorStage -> Evidenced ValidationTrace validateNull cddl (CTreeE (VRuleRef n)) =   dereferenceAndValidate cddl n $ validateNull cddl+validateNull _ (CTreeE (VValidator v _)) = runCustomValidator TNull v validateNull cddl rule =   case rule of     -- a = any@@ -561,6 +573,7 @@   CTreeRoot ValidatorStage -> BS.ByteString -> CTree ValidatorStage -> Evidenced ValidationTrace validateBytes cddl bs (CTreeE (VRuleRef n)) =   dereferenceAndValidate cddl n $ validateBytes cddl bs+validateBytes _ bs (CTreeE (VValidator v _)) = runCustomValidator (TBytes bs) v validateBytes cddl bs rule =   case rule of     -- a = any@@ -646,6 +659,7 @@   Evidenced ValidationTrace validateText cddl txt (CTreeE (VRuleRef n)) =   dereferenceAndValidate cddl n $ validateText cddl txt+validateText _ txt (CTreeE (VValidator v _)) = runCustomValidator (TString txt) v validateText cddl txt rule =   case rule of     -- a = any@@ -704,6 +718,7 @@   CTreeRoot ValidatorStage -> Word64 -> Term -> CTree ValidatorStage -> Evidenced ValidationTrace validateTagged cddl tag term (CTreeE (VRuleRef n)) =   dereferenceAndValidate cddl n $ validateTagged cddl tag term+validateTagged _ tag term (CTreeE (VValidator v _)) = runCustomValidator (TTagged tag term) v validateTagged cddl tag term rule =   case rule of     Postlude PTAny -> terminal rule@@ -711,7 +726,7 @@       -- If the tag does not match, this is a direct fail       if tag == tag'         then mapTrace (TagTrace tag) $ validateTerm cddl term rule'-        else evidence $ InvalidTag tag+        else evidence $ InvalidTag tag' tag     Choice opts -> validateChoice (validateTagged cddl tag term) opts     _ -> unapplicable rule @@ -757,6 +772,7 @@   Evidenced ValidationTrace validateList cddl terms (CTreeE (VRuleRef n)) =   dereferenceAndValidate cddl n $ validateList cddl terms+validateList _ terms (CTreeE (VValidator v _)) = runCustomValidator (TList terms) v validateList cddl terms rule =   case rule of     Postlude PTAny -> terminal rule@@ -842,6 +858,7 @@   Evidenced ValidationTrace validateMap cddl terms (CTreeE (VRuleRef n)) =   dereferenceAndValidate cddl n $ validateMap cddl terms+validateMap _ terms (CTreeE (VValidator v _)) = runCustomValidator (TMap terms) v validateMap cddl terms rule =   case rule of     Postlude PTAny -> terminal rule@@ -952,13 +969,11 @@ ctrlDispatch v Within tgt ctrl _ = ctrlAnd v tgt ctrl ctrlDispatch v op tgt ctrl vctrl =   case v tgt of-    Evidenced SValid (TerminalRule _ res)+    Evidenced SValid trc       | vctrl op ctrl ->-          evidence $ TerminalRule (Just (ControlInfo op (mapIndex ctrl))) res+          evidence $ ControlTrace (ControlInfo op (mapIndex ctrl)) trc       | otherwise ->           evidence $ UnsatisfiedControl op (mapIndex ctrl)-    Evidenced SValid trc ->-      error $ "Unexpected trace:\n\t" <> showValidationTrace trc     err -> err  --------------------------------------------------------------------------------

@@ -170,7 +170,8 @@  data ValidationTrace (v :: Validity) where   UnapplicableRule :: CTree ValidatorStageSimple -> ValidationTrace IsInvalid-  TerminalRule :: Maybe ControlInfo -> CTree ValidatorStageSimple -> ValidationTrace IsValid+  TerminalRule :: CTree ValidatorStageSimple -> ValidationTrace IsValid+  ControlTrace :: ControlInfo -> ValidationTrace IsValid -> ValidationTrace IsValid   ReferenceRule :: Name -> ValidationTrace v -> ValidationTrace v   CustomFailure :: Text -> ValidationTrace IsInvalid   CustomSuccess :: ValidationTrace IsValid@@ -179,7 +180,7 @@   ListTrace :: ListValidationTrace v -> ValidationTrace v   MapTrace :: MapValidationTrace v -> ValidationTrace v   TagTrace :: Word64 -> ValidationTrace v -> ValidationTrace v-  InvalidTag :: Word64 -> ValidationTrace IsInvalid+  InvalidTag :: Word64 -> Word64 -> ValidationTrace IsInvalid  deriving instance Show (ValidationTrace v) @@ -283,6 +284,7 @@   traceValidity = \case     CustomSuccess {} -> SValid     TerminalRule {} -> SValid+    ControlTrace {} -> SValid     ChoiceBranch {} -> SValid     UnapplicableRule {} -> SInvalid     CustomFailure {} -> SInvalid@@ -296,6 +298,7 @@   measureProgress = \case     TerminalRule {} -> Progress 1 0     CustomSuccess -> Progress 1 0+    ControlTrace _ x -> measureProgress x     ChoiceBranch _ x -> measureProgress x     UnapplicableRule {} -> mempty     CustomFailure {} -> mempty@@ -473,15 +476,12 @@ prettyValidationTrace :: TraceOptions -> ValidationTrace v -> Doc AnsiStyle prettyValidationTrace opts = \case   UnapplicableRule x -> annotate (color Red) $ vsep ["failed to apply: ", indent 2 $ pretty x]-  TerminalRule mCi x -> case mCi of-    Just ci ->-      vsep-        [ appMsg-        , nestContainer $ "ctrl:" <+> annotate (color Yellow) ("." <> pretty ci)-        ]-    Nothing -> appMsg-    where-      appMsg = "app: " <> annotate (color Green) (pretty x)+  TerminalRule x -> "app: " <> annotate (color Green) (pretty x)+  ControlTrace ci x ->+    vsep+      [ prettyValidationTrace opts x+      , nestContainer $ "ctrl:" <+> annotate (color Yellow) ("." <> pretty ci)+      ]   ChoiceBranch i c ->     vsep       [ "choice (idx: " <> pretty i <> ")"@@ -515,8 +515,8 @@       [ "tag:" <+> annotate (color Green) ("#6." <> pretty t)       , nestContainer $ prettyValidationTrace opts x       ]-  InvalidTag t ->-    "expected tag #6." <> pretty t+  InvalidTag expected actual ->+    "expected tag #6." <> pretty expected <> ", got #6." <> pretty actual  showValidationTrace :: ValidationTrace v -> String showValidationTrace =

@@ -39,6 +39,7 @@   withValidator,   (=:=),  )+import Codec.CBOR.Cuddle.Huddle qualified as H import Codec.CBOR.Cuddle.IndexMappable (mapCDDLDropExt, mapIndex) import Codec.CBOR.Cuddle.Parser (pCDDL) import Codec.CBOR.Pretty (prettyHexEnc)@@ -373,6 +374,17 @@               [ HIRule ruleA               , HIRule $ "b" =:= arr [a ruleA]               ]+        pure . expectValid $ validateHuddle huddle "b" arrTerm+      prop "Validates with custom validator in a choice within a group" $ do+        bs <- BS.pack <$> listOf1 arbitrary+        let+          ruleA = withValidator bytesValidator $ "a" =:= VText+          huddle =+            collectFrom+              [ HIRule ruleA+              , HIRule $ "b" =:= arr [0, a (ruleA H./ VNil)]+              ]+        arrTerm <- genArrayTerm [TInt 0, TBytes bs]         pure . expectValid $ validateHuddle huddle "b" arrTerm     describe "Negative" $ do       prop "Fails if term is valid against the Huddle, but not the custom validator" $ do