diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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)` 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.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 diff --git a/src/Codec/CBOR/Cuddle/CBOR/Canonical.hs b/src/Codec/CBOR/Cuddle/CBOR/Canonical.hs new file mode 100644 --- /dev/null +++ b/src/Codec/CBOR/Cuddle/CBOR/Canonical.hs @@ -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)) diff --git a/src/Codec/CBOR/Cuddle/CBOR/Gen.hs b/src/Codec/CBOR/Cuddle/CBOR/Gen.hs --- a/src/Codec/CBOR/Cuddle/CBOR/Gen.hs +++ b/src/Codec/CBOR/Cuddle/CBOR/Gen.hs @@ -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) 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 @@ -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 diff --git a/src/Codec/CBOR/Cuddle/CBOR/Validator/Trace.hs b/src/Codec/CBOR/Cuddle/CBOR/Validator/Trace.hs --- a/src/Codec/CBOR/Cuddle/CBOR/Validator/Trace.hs +++ b/src/Codec/CBOR/Cuddle/CBOR/Validator/Trace.hs @@ -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 diff --git a/src/Codec/CBOR/Cuddle/CDDL/CTree.hs b/src/Codec/CBOR/Cuddle/CDDL/CTree.hs --- a/src/Codec/CBOR/Cuddle/CDDL/CTree.hs +++ b/src/Codec/CBOR/Cuddle/CDDL/CTree.hs @@ -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)) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 diff --git a/test/Test/Codec/CBOR/Cuddle/CBOR/Canonical.hs b/test/Test/Codec/CBOR/Cuddle/CBOR/Canonical.hs new file mode 100644 --- /dev/null +++ b/test/Test/Codec/CBOR/Cuddle/CBOR/Canonical.hs @@ -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) 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 @@ -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