Add CanonicalTerm, fix duplicate keys handling in map generator/validator

CHANGELOG.md

@@ -1,5 +1,11 @@
 # 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`
+
 ## 1.8.0.0
 
 * Change `validateCBOR` return type to `Either ValidateCBORError (Evidenced ValidationTrace)`

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 @@ common warnings
 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 @@ test-suite cuddle-test
 
   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

src/Codec/CBOR/Cuddle/CBOR/Canonical.hs

@@ -0,0 +1,144 @@
+{-# LANGUAGE LambdaCase #-}
+
+module Codec.CBOR.Cuddle.CBOR.Canonical (
+  CanonicalTerm (..),
+  NInt,
+  toNInt,
+  fromNInt,
+  toCanonical,
+  uintMax,
+  nintMin,
+) where
+
+import Codec.CBOR.Term (Term (..))
+import Control.Monad (guard)
+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@.
+-- Will return `Nothing` if any map contains duplicate elements.
+toCanonical :: Term -> Maybe CanonicalTerm
+toCanonical = \case
+  TInt i -> pure . integerToCanonical $ toInteger i
+  TInteger n -> pure $ integerToCanonical n
+  TBytes bs -> pure $ CTBytes bs
+  TBytesI bs -> pure . CTBytes $ BSL.toStrict bs
+  TString s -> pure $ CTString s
+  TStringI s -> pure . 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 -> pure . integerToCanonical $ bytesToUnsigned bs
+  TTagged 3 inner
+    | Just bs <- tagBytes inner -> pure . integerToCanonical $ -1 - bytesToUnsigned bs
+  TTagged w t -> CTTagged w <$> toCanonical t
+  TBool False -> pure $ CTSimple 20
+  TBool True -> pure $ CTSimple 21
+  TNull -> pure $ CTSimple 22
+  TSimple w -> pure $ CTSimple w
+  THalf f -> pure . CTHalf $ toHalf f
+  TFloat f -> pure $ CTFloat f
+  TDouble d -> pure $ CTDouble d
+  where
+    mkMap kvs = do
+      pairs <- traverse (\(k, v) -> (,) <$> toCanonical k <*> toCanonical v) kvs
+      let m = Map.fromList pairs
+      CTMap m <$ guard (Map.size m == length pairs)
+    mkList ts = CTList <$> traverse 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 = fromInteger (n `mod` 256) : go (n `div` 256)
+
+-- | 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))

src/Codec/CBOR/Cuddle/CBOR/Gen.hs

@@ -23,6 +23,7 @@ module Codec.CBOR.Cuddle.CBOR.Gen (
 
 #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 (
 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
@@ -371,7 +370,7 @@ genMap nodes = do
         go !n
           | n > 0 = do
               k <- unS <$> scale (`div` 2) (withAntiGen (withAnnotation "key") $ genForCTree kNode)
-              if Map.notMember k m
+              if toCanonical k `notElem` (toCanonical <$> Map.keys m)
                 then do
                   v <- unS <$> scale (`div` 2) (withAntiGen (withAnnotation "value") $ genForCTree vNode)
                   pure $ Just (k, v)

src/Codec/CBOR/Cuddle/CBOR/Validator.hs

@@ -11,6 +11,7 @@ module Codec.CBOR.Cuddle.CBOR.Validator (
   ValidateCBORError (..),
 ) where
 
+import Codec.CBOR.Cuddle.CBOR.Canonical (CanonicalTerm, toCanonical)
 import Codec.CBOR.Cuddle.CBOR.Validator.Trace (
   ControlInfo (..),
   Evidenced (..),
@@ -52,6 +53,8 @@ import Data.List.NonEmpty (NonEmpty (..))
 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
@@ -913,14 +916,18 @@ validateMap cddl terms (CTreeE (VValidator v _)) = runCustomValidator cddl (Sing
 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 +944,28 @@ validateMap cddl terms rule =
           _ -> 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 =
+                fromMaybe
+                  (error "IMPOSSIBLE: key validated but failed to canonicalize\nPlease make a bug report")
+                  (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 +977,20 @@ validateMap cddl terms rule =
           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

src/Codec/CBOR/Cuddle/CBOR/Validator/Trace.hs

@@ -30,6 +30,7 @@ module Codec.CBOR.Cuddle.CBOR.Validator.Trace (
   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 @@ data MapValidationTrace (v :: Validity) where
     ValidationTrace IsValid ->
     MapValidationTrace v ->
     MapValidationTrace v
+  MapValidationDuplicateKeys ::
+    CTree MonoSimplePhase ->
+    CanonicalTerm ->
+    ValidationTrace IsValid ->
+    MapValidationTrace IsInvalid
 
 deriving instance Show (MapValidationTrace v)
 
@@ -255,6 +261,7 @@ instance IsValidationTrace MapValidationTrace where
     MapValidationLeftoverKVs _ _ -> SInvalid
     MapValidationUnappliedRules _ -> SInvalid
     MapValidationInvalidValue {} -> SInvalid
+    MapValidationDuplicateKeys {} -> SInvalid
     MapValidationConsume _ _ _ x -> traceValidity x
 
   measureProgress = \case
@@ -266,6 +273,7 @@ instance IsValidationTrace MapValidationTrace where
       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
@@ -381,6 +389,11 @@ prettyMapValidationResult opts@TraceOptions {..} = \case
       , "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
     foldValid !n t =

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 @@ instance Arbitrary PTerm where
   arbitrary = genericArbitraryU
 
 instance Hashable PTerm
-
--- Bounds
-
-uintMax :: Integer
-uintMax = 2 ^ (64 :: Int) - 1
-
-nintMin :: Integer
-nintMin = -(2 ^ (64 :: Int))