cuddle 1.8.0.0 → 1.8.1.0

raw patch · 10 files changed

+444/−40 lines, 10 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• cuddle.cabal +3/−1
• src/Codec/CBOR/Cuddle/CBOR/Canonical.hs +155/−0
• src/Codec/CBOR/Cuddle/CBOR/Gen.hs +3/−3
• src/Codec/CBOR/Cuddle/CBOR/Validator.hs +40/−21
• src/Codec/CBOR/Cuddle/CBOR/Validator/Trace.hs +13/−0
• src/Codec/CBOR/Cuddle/CDDL/CTree.hs +12/−9
• test/Main.hs +2/−0
• test/Test/Codec/CBOR/Cuddle/CBOR/Canonical.hs +117/−0
• test/Test/Codec/CBOR/Cuddle/CDDL/Validator.hs +92/−6

@@ -1,5 +1,12 @@ # Changelog for `cuddle` +## 1.8.1.0++* Fix map generator so that it does not generate duplicate keys+* Add `MapValidationDuplicateKeys`; validator now checks for duplicate elements+* Add `Codec.CBOR.Cuddle.CBOR.Canonical`+* Fix list validation of occurrence indicators inside a group referenced from an array+ ## 1.8.0.0  * Change `validateCBOR` return type to `Either ValidateCBORError (Evidenced ValidationTrace)`

@@ -1,6 +1,6 @@ cabal-version: 3.4 name: cuddle-version: 1.8.0.0+version: 1.8.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).@@ -38,6 +38,7 @@ library   import: warnings   exposed-modules:+    Codec.CBOR.Cuddle.CBOR.Canonical     Codec.CBOR.Cuddle.CBOR.Gen     Codec.CBOR.Cuddle.CBOR.Validator     Codec.CBOR.Cuddle.CBOR.Validator.Trace@@ -128,6 +129,7 @@    other-modules:     Paths_cuddle+    Test.Codec.CBOR.Cuddle.CBOR.Canonical     Test.Codec.CBOR.Cuddle.CDDL.Examples     Test.Codec.CBOR.Cuddle.CDDL.Examples.Huddle     Test.Codec.CBOR.Cuddle.CDDL.Gen

@@ -0,0 +1,155 @@+{-# LANGUAGE LambdaCase #-}++module Codec.CBOR.Cuddle.CBOR.Canonical (+  CanonicalTerm (..),+  NInt,+  toNInt,+  fromNInt,+  toCanonical,+  uintMax,+  nintMin,+) where++import Codec.CBOR.Term (Term (..))+import Data.Bifunctor (bimap)+import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Data.ByteString.Lazy qualified as BSL+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Text.Lazy qualified as TL+import Data.Word (Word64, Word8)+import GHC.Generics (Generic)+import Numeric.Half (Half, toHalf)+import Test.QuickCheck (Arbitrary (..))++-- | A negative integer in the range @[-2^64, -1]@: exactly the values+-- representable by CBOR major type 1 (RFC 8949 §3.1). The range is wider+-- than 'Int64' on the negative side, so it can't be stored as a plain+-- signed integer.+newtype NInt = NInt Word64+  deriving (Eq, Ord, Bounded)++instance Show NInt where+  showsPrec p x =+    showParen (p > 10) $ showString "toNInt " . showsPrec 11 (fromNInt x)++instance Arbitrary NInt where+  arbitrary = NInt <$> arbitrary++toNInt :: Integer -> Maybe NInt+toNInt x+  | x >= nintMin && x < 0 = Just . NInt . fromInteger $ x - nintMin+  | otherwise = Nothing++fromNInt :: NInt -> Integer+fromNInt (NInt n) = nintMin + toInteger n++-- | Convert a `cborg` @Term@ to a @CanonicalTerm@.+--+-- A CBOR map with duplicate keys is well-formed but invalid (RFC 8949 §5.6).+-- Canonicalizing such a map is not currently supported and raises an 'error'.+-- This only arises in the niche case of a duplicate-keyed map nested in a+-- position the validator does not otherwise reject (e.g. a map used as a map+-- key). If you hit this, please open an issue.+toCanonical :: Term -> CanonicalTerm+toCanonical = \case+  TInt i -> integerToCanonical $ toInteger i+  TInteger n -> integerToCanonical n+  TBytes bs -> CTBytes bs+  TBytesI bs -> CTBytes $ BSL.toStrict bs+  TString s -> CTString s+  TStringI s -> CTString $ TL.toStrict s+  TList ts -> mkList ts+  TListI ts -> mkList ts+  TMap kvs -> mkMap kvs+  TMapI kvs -> mkMap kvs+  TTagged 2 inner+    | Just bs <- tagBytes inner -> integerToCanonical $ bytesToUnsigned bs+  TTagged 3 inner+    | Just bs <- tagBytes inner -> integerToCanonical $ -1 - bytesToUnsigned bs+  TTagged w t -> CTTagged w $ toCanonical t+  TBool False -> CTSimple 20+  TBool True -> CTSimple 21+  TNull -> CTSimple 22+  TSimple w -> CTSimple w+  THalf f -> CTHalf $ toHalf f+  TFloat f -> CTFloat f+  TDouble d -> CTDouble d+  where+    mkMap kvs =+      let pairs = bimap toCanonical toCanonical <$> kvs+          m = Map.fromList pairs+       in if Map.size m == length pairs+            then CTMap m+            else+              error+                "toCanonical: encountered a map with duplicate keys, which is \+                \not currently supported. Please open an issue at \+                \https://github.com/input-output-hk/cuddle/issues"+    mkList ts = CTList $ toCanonical <$> ts+    tagBytes (TBytes bs) = Just bs+    tagBytes (TBytesI bs) = Just $ BSL.toStrict bs+    tagBytes _ = Nothing++integerToCanonical :: Integer -> CanonicalTerm+integerToCanonical n+  | n >= 0, n <= uintMax = CTInt $ fromInteger n+  | n < 0, n >= nintMin = CTNInt . NInt . fromInteger $ n - nintMin+  | n > uintMax = CTTagged 2 . CTBytes $ unsignedToBytes n+  | otherwise = CTTagged 3 . CTBytes . unsignedToBytes $ -1 - n++bytesToUnsigned :: ByteString -> Integer+bytesToUnsigned = BS.foldl' (\acc b -> acc * 256 + toInteger b) 0++unsignedToBytes :: Integer -> ByteString+unsignedToBytes = BS.pack . reverse . go+  where+    go 0 = []+    go n = let (d, r) = divMod n 256 in fromInteger r : go d++-- | A canonical representation of CBOR data items. Two 'CanonicalTerm's+-- compare equal exactly when the underlying CBOR items are equivalent+-- under the /extended generic data model/ of RFC 8949 §3.4.3 — the same+-- notion of equality that determines whether two map keys are duplicates+-- (RFC 8949 §3.1, §5.6).+--+-- Differences from 'Codec.CBOR.Term.Term':+--+-- * Major types 0 and 1 are split into 'CTInt' and 'CTNInt' (matching+--   the on-wire structure) instead of overlapping in 'TInt'/'TInteger'.+-- * Bignums (tags 2 and 3) whose value fits in @[-2^64, 2^64 - 1]@+--   are normalized into 'CTInt' / 'CTNInt' (RFC 8949 §3.4.3).+-- * Definite- and indefinite-length variants are merged: there is no+--   separate constructor for what 'Codec.CBOR.Term.TBytesI',+--   'Codec.CBOR.Term.TStringI', 'Codec.CBOR.Term.TListI',+--   'Codec.CBOR.Term.TMapI' represent.+-- * Maps use 'Data.Map.Strict.Map' rather than a list of pairs, so+--   key order is irrelevant.+-- * 'TBool' and 'TNull' are folded into 'CTSimple' (values 20, 21, 22+--   per RFC 8949 §3.3).+-- * 'THalf', 'TFloat', 'TDouble' remain distinct constructors: the+--   generic data model treats different float widths as distinct items+--   (RFC 8949 §2).+data CanonicalTerm+  = CTInt !Word64+  | CTNInt !NInt+  | CTBytes !ByteString+  | CTString !Text+  | CTList ![CanonicalTerm]+  | CTMap !(Map CanonicalTerm CanonicalTerm)+  | CTTagged !Word64 !CanonicalTerm+  | CTSimple !Word8+  | CTHalf !Half+  | CTFloat !Float+  | CTDouble !Double+  deriving (Generic, Eq, Ord, Show)++-- Bounds++uintMax :: Integer+uintMax = 2 ^ (64 :: Int) - 1++nintMin :: Integer+nintMin = -(2 ^ (64 :: Int))

@@ -23,6 +23,7 @@  #if MIN_VERSION_random(1,3,0) #endif+import Codec.CBOR.Cuddle.CBOR.Canonical (nintMin, toCanonical, uintMax) import Codec.CBOR.Cuddle.CDDL (   GRef (..),   Name (..),@@ -34,8 +35,6 @@ import Codec.CBOR.Cuddle.CDDL.CTree (   CTree (..),   PTerm (..),-  nintMin,-  uintMax,  ) import Codec.CBOR.Cuddle.CDDL.CTree qualified as CTree import Codec.CBOR.Cuddle.CDDL.CtlOp qualified as CtlOp@@ -366,12 +365,13 @@       Int -> Map.Map Term a -> CTree GenPhase -> CTree GenPhase -> CBORGen (Maybe (Term, Term))     tryGenKV nTries m kNode vNode = go nTries       where+        canonicalKeys = toCanonical <$> Map.keys m         unS (SingleTerm x) = x         unS x = error $ "Expected single, got " <> show x         go !n           | n > 0 = do               k <- unS <$> scale (`div` 2) (withAntiGen (withAnnotation "key") $ genForCTree kNode)-              if Map.notMember k m+              if toCanonical k `notElem` canonicalKeys                 then do                   v <- unS <$> scale (`div` 2) (withAntiGen (withAnnotation "value") $ genForCTree vNode)                   pure $ Just (k, v)

@@ -11,6 +11,7 @@   ValidateCBORError (..), ) where +import Codec.CBOR.Cuddle.CBOR.Canonical (CanonicalTerm, toCanonical) import Codec.CBOR.Cuddle.CBOR.Validator.Trace (   ControlInfo (..),   Evidenced (..),@@ -19,6 +20,7 @@   MapValidationTrace (..),   SValidity (..),   ValidationTrace (..),+  compareEvidencedProgress,   evidence,   isValid,   mapTrace,@@ -52,6 +54,8 @@ import Data.List.NonEmpty qualified as NE import Data.Map.Strict qualified as Map import Data.Maybe+import Data.Set (Set)+import Data.Set qualified as Set import Data.Text qualified as T import Data.Text.Encoding (encodeUtf8) import Data.Text.Lazy qualified as TL@@ -859,6 +863,12 @@       | otherwise = (evidence . ListValidationUnappliedRule $ mapIndex r, [])     validate f skipped tss@(t : ts) (r : rs) =       let+        orElse x@(Evidenced SValid _, _) _ = x+        orElse x@(ex, _) y@(ey, _) =+          case compareEvidencedProgress ex ey of+            GT -> x+            _ -> y+         consumeTerm ct g = case validateTerm cddl t ct of           Evidenced SValid trc -> first (mapTrace $ ListValidationConsume (mapIndex r) trc) $ g ts           Evidenced SInvalid trc -> (evidence $ ListValidationMissingRequired (mapIndex ct) trc, tss)@@ -883,14 +893,14 @@         validateRule =           \case             Occur ct oi -> case oi of-              OIOptional -> consume ct continue <> skipRule-              OIZeroOrMore -> consume ct (rewriteRule r) <> skipRule+              OIOptional -> consume ct continue `orElse` skipRule+              OIZeroOrMore -> consume ct (rewriteRule r) `orElse` skipRule               OIOneOrMore -> consume ct (rewriteRule (Occur ct OIZeroOrMore))               OIBounded lb ub ->                 let bounds = (lb, ub)                  in case boundPlacement 1 bounds Closed of                       BelowBounds -> consume ct (rewriteRule (Occur ct $ decrementBounds bounds))-                      WithinBounds -> consume ct (rewriteRule (Occur ct $ decrementBounds bounds)) <> skipRule+                      WithinBounds -> consume ct (rewriteRule (Occur ct $ decrementBounds bounds)) `orElse` skipRule                       AboveBounds                         | boundPlacement 0 (lb, ub) Closed == WithinBounds -> skipRule                         | otherwise -> error "Negative upper bound"@@ -913,14 +923,18 @@ validateMap cddl terms rule =   case rule of     Postlude PTAny -> terminal rule-    Map rules -> mapTrace MapTrace $ validate [] terms rules+    Map rules -> mapTrace MapTrace $ validate [] terms rules mempty     Choice opts -> validateChoice (validateMap cddl terms) opts     _ -> unapplicable rule   where     validate ::-      [CTree ValidatorPhase] -> [(Term, Term)] -> [CTree ValidatorPhase] -> Evidenced MapValidationTrace-    validate _ [] [] = evidence MapValidationDone-    validate exhausted (kv : _) [] =+      [CTree ValidatorPhase] ->+      [(Term, Term)] ->+      [CTree ValidatorPhase] ->+      Set CanonicalTerm ->+      Evidenced MapValidationTrace+    validate _ [] [] _ = evidence MapValidationDone+    validate exhausted (kv : _) [] _ =       let         unwrapOccur (Occur ct _) = ct         unwrapOccur ct = ct@@ -937,20 +951,25 @@           _ -> Just $ maximumBy (compare `on` (measureProgress . snd)) attempts        in         evidence $ MapValidationLeftoverKVs kv bestAttempt-    validate [] [] rs =+    validate [] [] rs _ =       case NE.nonEmpty $ filter (not . isOptional) rs of         Nothing -> evidence MapValidationDone         Just requiredRules -> evidence $ MapValidationUnappliedRules (mapIndex <$> requiredRules)-    validate exhausted kvs (r : rs) =+    validate exhausted kvs (r : rs) seen =       let         consume (KV k v _) f = case kvs of           ((tk, tv) : leftover) ->-            case validateTerm cddl tk k of-              Evidenced SValid kTrc ->-                case validateTerm cddl tv v of-                  Evidenced SValid vTrc -> mapTrace (MapValidationConsume (mapIndex r) kTrc vTrc) $ f leftover-                  Evidenced SInvalid vTrc -> evidence $ MapValidationInvalidValue (mapIndex r) kTrc vTrc-              Evidenced SInvalid _ -> evidence $ MapValidationUnappliedRules (NE.singleton $ mapIndex r)+            let+              cKey = toCanonical tk+             in+              case validateTerm cddl tk k of+                Evidenced SValid kTrc+                  | cKey `Set.notMember` seen ->+                      case validateTerm cddl tv v of+                        Evidenced SValid vTrc -> mapTrace (MapValidationConsume (mapIndex r) kTrc vTrc) $ f leftover (Set.insert cKey seen)+                        Evidenced SInvalid vTrc -> evidence $ MapValidationInvalidValue (mapIndex r) kTrc vTrc+                  | otherwise -> evidence $ MapValidationDuplicateKeys (mapIndex r) cKey kTrc+                Evidenced SInvalid _ -> evidence $ MapValidationUnappliedRules (NE.singleton $ mapIndex r)           [] -> error "No remaining KV pairs"         consume x _ = error $ "Unexpected value in map: " <> showSimple x         postponeRule l = validate (r : exhausted) l rs@@ -962,20 +981,20 @@           Occur ct oi ->             case oi of               OIOptional ->-                consume ct resetDropRule <> postponeRule kvs+                consume ct resetDropRule <> postponeRule kvs seen               OIZeroOrMore ->-                consume ct (rewriteRule r) <> postponeRule kvs+                consume ct (rewriteRule r) <> postponeRule kvs seen               OIOneOrMore ->-                consume ct (rewriteRule (Occur ct OIZeroOrMore)) <> postponeRule kvs+                consume ct (rewriteRule (Occur ct OIZeroOrMore)) <> postponeRule kvs seen               OIBounded mlb mub                 | Just lb <- mlb, Just ub <- mub, lb > ub -> error "Unsatisfiable range encountered"                 | otherwise -> case compare 0 <$> mub of-                    Just EQ -> dropRule kvs+                    Just EQ -> dropRule kvs seen                     Just GT -> error "Unsatisfiable range encountered"                     _ ->                       consume ct (rewriteRule (Occur ct $ decrementBounds (mlb, mub)))-                        <> postponeRule kvs-          _ -> consume r resetDropRule <> postponeRule kvs+                        <> postponeRule kvs seen+          _ -> consume r resetDropRule <> postponeRule kvs seen  -------------------------------------------------------------------------------- -- Choices

@@ -30,6 +30,7 @@   foldEvidenced, ) where +import Codec.CBOR.Cuddle.CBOR.Canonical (CanonicalTerm) import Codec.CBOR.Cuddle.CDDL (Name (..)) import Codec.CBOR.Cuddle.CDDL.CTree (CTree (..)) import Codec.CBOR.Cuddle.CDDL.CtlOp (CtlOp)@@ -152,6 +153,11 @@     ValidationTrace IsValid ->     MapValidationTrace v ->     MapValidationTrace v+  MapValidationDuplicateKeys ::+    CTree MonoSimplePhase ->+    CanonicalTerm ->+    ValidationTrace IsValid ->+    MapValidationTrace IsInvalid  deriving instance Show (MapValidationTrace v) @@ -255,6 +261,7 @@     MapValidationLeftoverKVs _ _ -> SInvalid     MapValidationUnappliedRules _ -> SInvalid     MapValidationInvalidValue {} -> SInvalid+    MapValidationDuplicateKeys {} -> SInvalid     MapValidationConsume _ _ _ x -> traceValidity x    measureProgress = \case@@ -266,6 +273,7 @@       measureProgress kTrc <> measureProgress vTrc <> measureProgress x     MapValidationInvalidValue _ kTrc vTrc ->       measureProgress kTrc <> measureProgress vTrc+    MapValidationDuplicateKeys _ _ trc -> measureProgress trc  evidence :: (Show (t v), IsValidationTrace t) => t v -> Evidenced t evidence x = Evidenced (traceValidity x) x@@ -380,6 +388,11 @@       , nestContainer $ prettyValidationTrace opts k       , "value:" <+> annotate (color Red) "(fail)"       , nestContainer $ prettyValidationTrace opts v+      ]+  MapValidationDuplicateKeys _ _ trc ->+    vsep+      [ "key: " <> annotate (color Red) "(duplicate)"+      , nestContainer $ prettyValidationTrace opts trc       ]   where     foldValid !n (MapValidationConsume _ _ _ c) = foldValid (n + 1) c

@@ -3,8 +3,19 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -module Codec.CBOR.Cuddle.CDDL.CTree where+module Codec.CBOR.Cuddle.CDDL.CTree (+  XXCTree,+  CTree (..),+  traverseCTree,+  foldCTree,+  Node,+  CTreeRoot (..),+  PTerm (..),+  uintMax,+  nintMin,+) where +import Codec.CBOR.Cuddle.CBOR.Canonical (nintMin, uintMax) import Codec.CBOR.Cuddle.CDDL (Name, OccurrenceIndicator, RangeBound, Value) import Codec.CBOR.Cuddle.CDDL.CtlOp import Control.Monad.Identity (Identity (..))@@ -145,11 +156,3 @@   arbitrary = genericArbitraryU  instance Hashable PTerm---- Bounds--uintMax :: Integer-uintMax = 2 ^ (64 :: Int) - 1--nintMin :: Integer-nintMin = -(2 ^ (64 :: Int))

@@ -1,6 +1,7 @@ module Main (main) where  import System.IO (BufferMode (..), hSetBuffering, hSetEncoding, stdout, utf8)+import Test.Codec.CBOR.Cuddle.CBOR.Canonical qualified as Canonical import Test.Codec.CBOR.Cuddle.CDDL.Examples qualified as Examples import Test.Codec.CBOR.Cuddle.CDDL.GeneratorSpec qualified as Generator import Test.Codec.CBOR.Cuddle.CDDL.Parser (parserSpec)@@ -23,6 +24,7 @@   hSetBuffering stdout LineBuffering   hSetEncoding stdout utf8   hspecWith hspecConfig $ do+    describe "Canonical" Canonical.spec     describe "Parser" parserSpec     describe "Huddle" huddleSpec     describe "Examples" Examples.spec

@@ -0,0 +1,117 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.Codec.CBOR.Cuddle.CBOR.Canonical (spec) where++import Codec.CBOR.Cuddle.CBOR.Canonical (+  CanonicalTerm (..),+  fromNInt,+  nintMin,+  toCanonical,+  toNInt,+  uintMax,+ )+import Codec.CBOR.Term (Term (..))+import Data.ByteString qualified as BS+import Data.ByteString.Lazy qualified as BSL+import Data.Text.Lazy qualified as TL+import Data.Word (Word64)+import Test.Hspec+import Test.Hspec.QuickCheck (prop)+import Test.QuickCheck++spec :: Spec+spec = do+  describe "NInt" $ do+    it "toNInt accepts exactly [-2^64, -1]" $ do+      toNInt 0 `shouldBe` Nothing+      toNInt 1 `shouldBe` Nothing+      toNInt (nintMin - 1) `shouldBe` Nothing+      toNInt nintMin `shouldNotBe` Nothing+      toNInt (-1) `shouldNotBe` Nothing++    prop "toNInt . fromNInt = Just" $ \n ->+      toNInt (fromNInt n) === Just n++    it "boundary values roundtrip" $ do+      fmap fromNInt (toNInt (-1)) `shouldBe` Just (-1)+      fmap fromNInt (toNInt nintMin) `shouldBe` Just nintMin++    prop "Ord on NInt agrees with Ord on the represented Integer" $ \a b ->+      compare a b === compare (fromNInt a) (fromNInt b)++  describe "toCanonical" $ do+    describe "integer normalization" $ do+      prop "TInt and TInteger of the same value are equal" $ \i ->+        toCanonical (TInt i) === toCanonical (TInteger (toInteger i))++      prop "in-range positive bignum collapses to CTInt" $ \(w :: Word64) ->+        let n = toInteger w+         in toCanonical (TTagged 2 (TBytes (unsignedBE n)))+              === toCanonical (TInteger n)++      prop "in-range negative bignum collapses to CTNInt" $ \nint ->+        let n = fromNInt nint+         in toCanonical (TTagged 3 (TBytes (unsignedBE (-1 - n))))+              === toCanonical (TInteger n)++      it "bignum with leading zeros canonicalizes" $+        toCanonical (TTagged 2 (TBytes (BS.pack [0, 0, 5])))+          `shouldBe` CTInt 5++      prop "bignum from TBytesI matches TBytes" $ \(w :: Word64) ->+        let bs = unsignedBE (toInteger w)+         in toCanonical (TTagged 2 (TBytesI (BSL.fromStrict bs)))+              === toCanonical (TTagged 2 (TBytes bs))++      it "true bignum (above uintMax) stays tagged" $+        let n = uintMax + 1+         in toCanonical (TInteger n)+              `shouldBe` CTTagged 2 (CTBytes (unsignedBE n))++      it "true bignum (below nintMin) stays tagged" $+        let n = nintMin - 1+         in toCanonical (TInteger n)+              `shouldBe` CTTagged 3 (CTBytes (unsignedBE (-1 - n)))++    describe "definite/indefinite variants merge" $ do+      it "TBytes ≡ TBytesI" $+        toCanonical (TBytes "abc")+          `shouldBe` toCanonical (TBytesI (BSL.fromStrict "abc"))++      it "TString ≡ TStringI" $+        toCanonical (TString "abc")+          `shouldBe` toCanonical (TStringI (TL.fromStrict "abc"))++      it "TList ≡ TListI" $+        toCanonical (TList [TInt 1, TInt 2])+          `shouldBe` toCanonical (TListI [TInt 1, TInt 2])++      it "TMap ≡ TMapI" $+        toCanonical (TMap [(TInt 1, TInt 2)])+          `shouldBe` toCanonical (TMapI [(TInt 1, TInt 2)])++    describe "bool/null go through CTSimple" $ do+      it "TBool False ≡ TSimple 20" $+        toCanonical (TBool False) `shouldBe` toCanonical (TSimple 20)+      it "TBool True ≡ TSimple 21" $+        toCanonical (TBool True) `shouldBe` toCanonical (TSimple 21)+      it "TNull ≡ TSimple 22" $+        toCanonical TNull `shouldBe` toCanonical (TSimple 22)++    describe "maps" $ do+      it "key order is irrelevant" $+        toCanonical (TMap [(TInt 1, TInt 10), (TInt 2, TInt 20)])+          `shouldBe` toCanonical (TMap [(TInt 2, TInt 20), (TInt 1, TInt 10)])++    describe "floats stay distinct by width" $ do+      it "THalf 1.0 ≠ TFloat 1.0" $+        toCanonical (THalf 1.0) `shouldNotBe` toCanonical (TFloat 1.0)+      it "TFloat 1.0 ≠ TDouble 1.0" $+        toCanonical (TFloat 1.0) `shouldNotBe` toCanonical (TDouble 1.0)++-- | Encode a non-negative Integer as a big-endian byte string with no leading zeros.+unsignedBE :: Integer -> BS.ByteString+unsignedBE = BS.pack . reverse . go+  where+    go 0 = []+    go n = fromInteger (n `mod` 256) : go (n `div` 256)

@@ -11,6 +11,7 @@   validateCBOR_, ) where +import Codec.CBOR.Cuddle.CBOR.Canonical (toCanonical) import Codec.CBOR.Cuddle.CBOR.Gen (generateFromName) import Codec.CBOR.Cuddle.CBOR.Validator (   ValidatorPhase,@@ -32,6 +33,8 @@ import Codec.CBOR.Cuddle.CDDL.Postlude (appendPostlude) import Codec.CBOR.Cuddle.CDDL.Resolve (MonoReferenced, fullResolveCDDL) import Codec.CBOR.Cuddle.Huddle (+  CanQuantify (..),+  GroupDef,   Huddle,   HuddleItem (..),   Value (..),@@ -39,9 +42,11 @@   arr,   collectFrom,   int,+  opt,   toCDDL,   withValidator,   (=:=),+  (=:~),  ) import Codec.CBOR.Cuddle.Huddle qualified as H import Codec.CBOR.Cuddle.IndexMappable (mapCDDLDropExt, mapIndex)@@ -53,7 +58,7 @@ 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.Containers.ListUtils (nubOrdOn) import Data.Either (fromRight) import Data.Map qualified as Map import Data.Text (Text)@@ -149,14 +154,15 @@         mapCDDLDropExt cddl   genAndValidateCddl path resolvedCddl -genInfiniteUniqueList :: Ord a => Gen a -> Gen [a]-genInfiniteUniqueList = fmap nubOrd . infiniteListOf+genInfiniteUniqueListOn :: Ord b => (a -> b) -> Gen a -> Gen [a]+genInfiniteUniqueListOn f = fmap (nubOrdOn f) . 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)+  genMapTerm . take n+    =<< scale (const $ max lo hi) (genInfiniteUniqueListOn (toCanonical . fst) genKV)  genHuddleArrayRequiredTerms :: Gen [Term] genHuddleArrayRequiredTerms = do@@ -249,9 +255,10 @@       , pure []       ]   strFields <--    nubOrdOn fst <$> listOf ((,) <$> (genStringTerm . T.pack =<< arbitrary) <*> (TInt <$> arbitrary))+    nubOrdOn (toCanonical . fst)+      <$> listOf ((,) <$> (genStringTerm . T.pack =<< arbitrary) <*> (TInt <$> arbitrary))   bytesFields <--    nubOrdOn fst+    nubOrdOn (toCanonical . fst)       <$> listOf1 ((,) <$> (genBytesTerm =<< arbitraryByteString) <*> arbitraryTerm)   allFields <- shuffle $ field1 : lField2 <> strFields <> bytesFields   genMapTerm allFields@@ -340,6 +347,85 @@         prop "Fails to validate map with too many range elements"           . forAll (genHuddleRangeMap (11, 20))           $ expectInvalid . validateHuddle huddleRangeMap "a"++    -- Regression tests showing that optional ('?') validation is broken when+    -- the optional element is inside a group (`grp` / `=:~`) that is itself+    -- referenced inside an array. When the optional element is absent,+    -- `consumeGroup` receives a corrupted leftover-term list (due to `(<>)`+    -- on the result tuple accumulating terms from the failed consume path),+    -- causing the continuation to see phantom extra terms and report them as+    -- `ListValidationLeftoverTerms` instead of succeeding.+    describe "Group" $ do+      describe "Optional inside a group referenced from an array" $ do+        let+          -- @+          --   root = [innerGrp, int]+          --   innerGrp = (int, ? bool)+          -- @+          -- => [int, ? bool, int]+          optionalInGroupHuddle :: Huddle+          optionalInGroupHuddle =+            let+              innerGrp :: GroupDef+              innerGrp = "innerGrp" =:~ [a VInt, opt $ a VBool]+             in+              collectFrom+                [ HIRule $ "root" =:= arr [a innerGrp, a VInt]+                ]+        it "Validates when optional entry is present" $+          expectValid $+            validateHuddle optionalInGroupHuddle "root" (TList [TInt 1, TBool True, TInt 2])+        it "Validates when optional entry is absent" $+          expectValid $+            validateHuddle optionalInGroupHuddle "root" (TList [TInt 1, TInt 2])+      describe "ZeroOrMore (*) inside a group referenced from an array" $ do+        let+          -- @+          --   root = [zeroOrMoreGrp, text]+          --   zeroOrMoreGrp = (* bool, int)+          -- @+          -- => [* bool, int, text]+          zeroOrMoreInGroupHuddle :: Huddle+          zeroOrMoreInGroupHuddle =+            let+              zeroOrMoreGrp :: GroupDef+              zeroOrMoreGrp = "zeroOrMoreGrp" =:~ [0 <+ a VBool, a VInt]+             in+              collectFrom+                [ HIRule $ "root" =:= arr [a zeroOrMoreGrp, a VText]+                ]++        it "Validates when zero-or-more entry has elements" $+          expectValid $+            validateHuddle+              zeroOrMoreInGroupHuddle+              "root"+              (TList [TBool True, TBool False, TInt 42, TString "hi"])+        it "Validates when zero-or-more entry has zero elements" $+          expectValid $+            validateHuddle zeroOrMoreInGroupHuddle "root" (TList [TInt 42, TString "hi"])+      describe "Bounded (n..m) inside a group referenced from an array" $ do+        -- @+        --   root = [boundedGrp, text]+        --   boundedGrp = (0..2 bool, int)+        -- @+        -- => [0..2 bool, int, text]+        let boundedInGroupHuddle :: Huddle+            boundedInGroupHuddle =+              let boundedGrp :: GroupDef+                  boundedGrp = "boundedGrp" =:~ [0 <+ a VBool +> 2, a VInt]+               in collectFrom+                    [ HIRule $ "root" =:= arr [a boundedGrp, a VText]+                    ]+        it "Validates when bounded entry has elements (within bounds)" $+          expectValid $+            validateHuddle+              boundedInGroupHuddle+              "root"+              (TList [TBool True, TInt 42, TString "hi"])+        it "Validates when bounded entry has zero elements (lower bound is 0)" $+          expectValid $+            validateHuddle boundedInGroupHuddle "root" (TList [TInt 42, TString "hi"])      describe "Bignums" $ do       let