From 7e367cad98bf3be6cf864e8c4ac9542e5dfd9a2a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Joosep=20J=C3=A4=C3=A4ger?= Date: Mon, 6 Jul 2026 17:07:13 +0300 Subject: [PATCH 1/2] Upstream custom generator/validator helpers from cardano-ledger --- .../CBOR/Cuddle/CDDL/Custom/Generator.hs | 86 ++++++++++++++++- .../CBOR/Cuddle/CDDL/Custom/Validator.hs | 92 ++++++++++++++++++- 2 files changed, 175 insertions(+), 3 deletions(-) diff --git a/src/Codec/CBOR/Cuddle/CDDL/Custom/Generator.hs b/src/Codec/CBOR/Cuddle/CDDL/Custom/Generator.hs index 8647ecfa..a4b98248 100644 --- a/src/Codec/CBOR/Cuddle/CDDL/Custom/Generator.hs +++ b/src/Codec/CBOR/Cuddle/CDDL/Custom/Generator.hs @@ -14,18 +14,42 @@ module Codec.CBOR.Cuddle.CDDL.Custom.Generator ( withLocalGenBindings, disableTwiddle, enableTwiddle, + + -- * Lifted QuickCheck functions + arbitrary, + scale, + shuffle, + + -- * Custom generator helpers + antiVectorOfUnique, + antiVectorOfUniqueOn, + antiVectorOfUniqueBy, + genArrayTerm, + genBytesTerm, + genStringTerm, + genMapTerm, + ifTwiddle, ) where import Codec.CBOR.Cuddle.CDDL (GRef (..), Name (..)) import Codec.CBOR.Cuddle.CDDL.CTree (CTree, CTreeRoot (..), XXCTree) import Codec.CBOR.Cuddle.CDDL.Custom.Core (MonadCddl (..), RuleTerm) +import Codec.CBOR.Term (Term (..)) import Control.Monad.Reader (MonadReader (..), ReaderT (..), asks, mapReaderT) +import Data.ByteString (ByteString) +import Data.ByteString.Lazy qualified as LBS +import Data.Function (on) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Data.Text.Lazy qualified as LT import GHC.Generics (Generic) import Optics.Lens (Lens') -import Test.AntiGen (AntiGen) +import Test.AntiGen (AntiGen, faultyBool) +import Test.QuickCheck (Arbitrary, discard) +import Test.QuickCheck qualified as QC import Test.QuickCheck.GenT (MonadGen (..)) +import Test.QuickCheck.GenT qualified as GenT type data GenPhase @@ -101,3 +125,63 @@ data instance XXCTree GenPhase class HasGenerator a where generatorL :: Lens' a (Maybe (CBORGen RuleTerm)) + +-- Lifted Gen functions + +arbitrary :: forall a m. (MonadGen m, Arbitrary a) => m a +arbitrary = liftGen QC.arbitrary + +scale :: MonadGen m => (Int -> Int) -> m a -> m a +scale f m = sized $ \sz -> resize (f sz) m + +shuffle :: MonadGen m => [a] -> m [a] +shuffle = liftGen . QC.shuffle + +-- Term generators + +-- | Generate a list of @n@ pairwise-distinct elements. Discards the example if +-- the underlying generator could not produce enough distinct elements within +-- the per-element retry budget. +antiVectorOfUnique :: Eq a => Int -> AntiGen a -> AntiGen [a] +antiVectorOfUnique = antiVectorOfUniqueBy (==) + +-- | Like 'antiVectorOfUnique', but compares elements by a key projection. +antiVectorOfUniqueOn :: Eq b => (a -> b) -> Int -> AntiGen a -> AntiGen [a] +antiVectorOfUniqueOn key = antiVectorOfUniqueBy ((==) `on` key) + +-- | Like 'antiVectorOfUnique', but takes a user-supplied equivalence relation. +antiVectorOfUniqueBy :: (a -> a -> Bool) -> Int -> AntiGen a -> AntiGen [a] +antiVectorOfUniqueBy eq n gen = do + disallowDuplicates <- faultyBool True + let + triesPerElement = 10 :: Int + go _ 0 _ = discard + go m tries elems + | m > 0 = do + x <- gen + if disallowDuplicates && any (eq x) elems + then go m (tries - 1) elems + else go (m - 1) triesPerElement (x : elems) + | otherwise = pure elems + go n triesPerElement [] + +genArrayTerm :: [Term] -> CBORGen Term +genArrayTerm es = + ifTwiddle (GenT.elements [TList es, TListI es]) (pure $ TList es) + +genBytesTerm :: ByteString -> CBORGen Term +genBytesTerm bs = + ifTwiddle (GenT.elements [TBytes bs, TBytesI $ LBS.fromStrict bs]) (pure $ TBytes bs) + +genStringTerm :: T.Text -> CBORGen Term +genStringTerm t = + ifTwiddle (GenT.elements [TString t, TStringI $ LT.fromStrict t]) (pure $ TString t) + +genMapTerm :: [(Term, Term)] -> CBORGen Term +genMapTerm m = + ifTwiddle (GenT.elements [TMap m, TMapI m]) (pure $ TMap m) + +ifTwiddle :: CBORGen a -> CBORGen a -> CBORGen a +ifTwiddle yes no = do + twiddle <- asks (gcTwiddle . geConfig) + if twiddle then yes else no diff --git a/src/Codec/CBOR/Cuddle/CDDL/Custom/Validator.hs b/src/Codec/CBOR/Cuddle/CDDL/Custom/Validator.hs index 2fdd64a5..9f3f6ed5 100644 --- a/src/Codec/CBOR/Cuddle/CDDL/Custom/Validator.hs +++ b/src/Codec/CBOR/Cuddle/CDDL/Custom/Validator.hs @@ -1,5 +1,6 @@ {-# LANGUAGE TypeData #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} module Codec.CBOR.Cuddle.CDDL.Custom.Validator ( TermValidator, @@ -11,17 +12,38 @@ module Codec.CBOR.Cuddle.CDDL.Custom.Validator ( ValidateEnv (..), withLocalValidateBindings, runValidator, + + -- * Custom validator helpers + validateInt, + validateUInt, + validateNInt, + validateArrayTerm, + validateBytesTerm, + validateStringTerm, + validateMapTerm, + validateNonEmpty, + validateUnique, + validateUniqueOn, + unwrapSingle, ) where import Codec.CBOR.Cuddle.CDDL (GRef (..), Name (..)) -import Codec.CBOR.Cuddle.CDDL.CTree (CTree, CTreeRoot (..)) -import Codec.CBOR.Cuddle.CDDL.Custom.Core (MonadCddl (..), RuleTerm) +import Codec.CBOR.Cuddle.CDDL.CTree (CTree, CTreeRoot (..), nintMin, uintMax) +import Codec.CBOR.Cuddle.CDDL.Custom.Core (MonadCddl (..), RuleTerm (..)) import Codec.CBOR.Cuddle.CDDL.Custom.Generator (XXCTree) +import Codec.CBOR.Term (Term (..)) +import Control.Monad (unless) import Control.Monad.Reader (MonadReader (..), ReaderT (..), asks) +import Data.ByteString (ByteString) +import Data.ByteString.Lazy qualified as LBS +import Data.Containers.ListUtils (nubOrd) +import Data.Foldable (Foldable (..)) +import Data.List.NonEmpty (NonEmpty, nonEmpty) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Text (Text) import Data.Text qualified as T +import Data.Text.Lazy qualified as LT import GHC.Generics (Generic) import Optics.Lens (Lens') @@ -74,3 +96,69 @@ runValidator :: runValidator (Validator m) cddl = either CustomValidatorFailure (const CustomValidatorSuccess) $ runReaderT m ValidateEnv {veRoot = cddl, veLocal = Map.empty} + +-- * Helpers + +validateInt :: Term -> Validator Integer +validateInt (TInt (toInteger -> x)) + | x >= nintMin && x <= uintMax = pure x + | otherwise = fail "Number not in int range" +validateInt _ = fail "Expected int" + +validateUInt :: Term -> Validator Integer +validateUInt (TInt (toInteger -> x)) + | x >= 0 && x <= uintMax = pure x + | otherwise = fail "Number not in uint range" +validateUInt _ = fail "Expected uint" + +validateNInt :: Term -> Validator Integer +validateNInt (TInt (toInteger -> x)) + | x >= nintMin && x < 0 = pure x + | otherwise = fail "Number not in nint range" +validateNInt _ = fail "Expected nint" + +validateArrayTerm :: Term -> Validator [Term] +validateArrayTerm (TList xs) = pure xs +validateArrayTerm (TListI xs) = pure xs +validateArrayTerm _ = fail "Expected list" + +validateBytesTerm :: Term -> Validator ByteString +validateBytesTerm (TBytes bs) = pure bs +validateBytesTerm (TBytesI bs) = pure $ LBS.toStrict bs +validateBytesTerm _ = fail "Expected bytes" + +validateStringTerm :: Term -> Validator Text +validateStringTerm (TString x) = pure x +validateStringTerm (TStringI x) = pure $ LT.toStrict x +validateStringTerm _ = fail "Expected string" + +validateMapTerm :: Term -> Validator [(Term, Term)] +validateMapTerm (TMap xs) = pure xs +validateMapTerm (TMapI xs) = pure xs +validateMapTerm _ = fail "Expected map" + +-- | Fail if the collection is empty. A custom-validator stand-in for the CDDL +-- @1*@ (non-empty) occurrence constraint, which is no longer enforced once a +-- custom validator replaces the built-in array/map validation for a rule. +validateNonEmpty :: Foldable t => t a -> Validator (NonEmpty a) +validateNonEmpty = maybe (fail "Expected at least one element") pure . nonEmpty . toList + +-- | Fail unless all elements of the list are pairwise distinct. Intended for +-- custom validators of CDDL sets and of map keys: once a custom validator +-- replaces the built-in array/map validation for a rule, element/key +-- uniqueness is no longer enforced automatically and has to be asserted. +validateUnique :: Ord a => [a] -> Validator () +validateUnique = validateUniqueOn id + +-- | Like 'validateUnique', but compares elements by a key projection, e.g. +-- @'validateUniqueOn' fst@ over the entries of a map. +validateUniqueOn :: Ord b => (a -> b) -> [a] -> Validator () +validateUniqueOn key xs = + unless (length ks == length (nubOrd ks)) $ + fail "Expected all elements to be unique" + where + ks = map key xs + +unwrapSingle :: RuleTerm -> Validator Term +unwrapSingle (SingleTerm x) = pure x +unwrapSingle _ = fail "Expected a single term" From e2042621e9452772628693d55583d297f9f95dd6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Joosep=20J=C3=A4=C3=A4ger?= Date: Mon, 6 Jul 2026 17:45:58 +0300 Subject: [PATCH 2/2] Add tests --- CHANGELOG.md | 20 +++ cuddle.cabal | 2 + src/Codec/CBOR/Cuddle/CBOR/Canonical.hs | 7 +- .../CBOR/Cuddle/CDDL/Custom/Generator.hs | 34 +--- .../CBOR/Cuddle/CDDL/Custom/Validator.hs | 38 +++-- test/Main.hs | 5 + .../CBOR/Cuddle/CDDL/Custom/GeneratorSpec.hs | 112 +++++++++++++ .../CBOR/Cuddle/CDDL/Custom/ValidatorSpec.hs | 147 ++++++++++++++++++ test/Test/Codec/CBOR/Cuddle/CDDL/Validator.hs | 47 +++--- 9 files changed, 336 insertions(+), 76 deletions(-) create mode 100644 test/Test/Codec/CBOR/Cuddle/CDDL/Custom/GeneratorSpec.hs create mode 100644 test/Test/Codec/CBOR/Cuddle/CDDL/Custom/ValidatorSpec.hs diff --git a/CHANGELOG.md b/CHANGELOG.md index b3bb905b..25dfcdbf 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,26 @@ ## 1.8.1.0 +* Add custom generator/validator helpers: + - `arbitrary` (lifted to `MonadGen`) + - `scale` (lifted to `MonadGen`) + - `shuffle` (lifted to `MonadGen`) + - `genArrayTerm` + - `genBytesTerm` + - `genStringTerm` + - `genMapTerm` + - `ifTwiddle` + - `validateInt` + - `validateUInt` + - `validateNInt` + - `validateArrayTerm` + - `validateBytesTerm` + - `validateStringTerm` + - `validateMapTerm` + - `validateNonEmpty` + - `validateUniqueList` + - `unwrapSingle` +* Add `canonicalEq` * 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` diff --git a/cuddle.cabal b/cuddle.cabal index 8547e3bd..54067a34 100644 --- a/cuddle.cabal +++ b/cuddle.cabal @@ -130,6 +130,8 @@ test-suite cuddle-test other-modules: Paths_cuddle Test.Codec.CBOR.Cuddle.CBOR.Canonical + Test.Codec.CBOR.Cuddle.CDDL.Custom.GeneratorSpec + Test.Codec.CBOR.Cuddle.CDDL.Custom.ValidatorSpec 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 index 86a50434..305da18d 100644 --- a/src/Codec/CBOR/Cuddle/CBOR/Canonical.hs +++ b/src/Codec/CBOR/Cuddle/CBOR/Canonical.hs @@ -3,11 +3,12 @@ module Codec.CBOR.Cuddle.CBOR.Canonical ( CanonicalTerm (..), NInt, + toCanonical, toNInt, fromNInt, - toCanonical, uintMax, nintMin, + canonicalEq, ) where import Codec.CBOR.Term (Term (..)) @@ -15,6 +16,7 @@ import Data.Bifunctor (bimap) import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as BSL +import Data.Function (on) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Text (Text) @@ -153,3 +155,6 @@ uintMax = 2 ^ (64 :: Int) - 1 nintMin :: Integer nintMin = -(2 ^ (64 :: Int)) + +canonicalEq :: Term -> Term -> Bool +canonicalEq = (==) `on` toCanonical diff --git a/src/Codec/CBOR/Cuddle/CDDL/Custom/Generator.hs b/src/Codec/CBOR/Cuddle/CDDL/Custom/Generator.hs index a4b98248..0ab8fb36 100644 --- a/src/Codec/CBOR/Cuddle/CDDL/Custom/Generator.hs +++ b/src/Codec/CBOR/Cuddle/CDDL/Custom/Generator.hs @@ -21,9 +21,6 @@ module Codec.CBOR.Cuddle.CDDL.Custom.Generator ( shuffle, -- * Custom generator helpers - antiVectorOfUnique, - antiVectorOfUniqueOn, - antiVectorOfUniqueBy, genArrayTerm, genBytesTerm, genStringTerm, @@ -38,15 +35,14 @@ import Codec.CBOR.Term (Term (..)) import Control.Monad.Reader (MonadReader (..), ReaderT (..), asks, mapReaderT) import Data.ByteString (ByteString) import Data.ByteString.Lazy qualified as LBS -import Data.Function (on) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Text qualified as T import Data.Text.Lazy qualified as LT import GHC.Generics (Generic) import Optics.Lens (Lens') -import Test.AntiGen (AntiGen, faultyBool) -import Test.QuickCheck (Arbitrary, discard) +import Test.AntiGen (AntiGen) +import Test.QuickCheck (Arbitrary) import Test.QuickCheck qualified as QC import Test.QuickCheck.GenT (MonadGen (..)) import Test.QuickCheck.GenT qualified as GenT @@ -139,32 +135,6 @@ shuffle = liftGen . QC.shuffle -- Term generators --- | Generate a list of @n@ pairwise-distinct elements. Discards the example if --- the underlying generator could not produce enough distinct elements within --- the per-element retry budget. -antiVectorOfUnique :: Eq a => Int -> AntiGen a -> AntiGen [a] -antiVectorOfUnique = antiVectorOfUniqueBy (==) - --- | Like 'antiVectorOfUnique', but compares elements by a key projection. -antiVectorOfUniqueOn :: Eq b => (a -> b) -> Int -> AntiGen a -> AntiGen [a] -antiVectorOfUniqueOn key = antiVectorOfUniqueBy ((==) `on` key) - --- | Like 'antiVectorOfUnique', but takes a user-supplied equivalence relation. -antiVectorOfUniqueBy :: (a -> a -> Bool) -> Int -> AntiGen a -> AntiGen [a] -antiVectorOfUniqueBy eq n gen = do - disallowDuplicates <- faultyBool True - let - triesPerElement = 10 :: Int - go _ 0 _ = discard - go m tries elems - | m > 0 = do - x <- gen - if disallowDuplicates && any (eq x) elems - then go m (tries - 1) elems - else go (m - 1) triesPerElement (x : elems) - | otherwise = pure elems - go n triesPerElement [] - genArrayTerm :: [Term] -> CBORGen Term genArrayTerm es = ifTwiddle (GenT.elements [TList es, TListI es]) (pure $ TList es) diff --git a/src/Codec/CBOR/Cuddle/CDDL/Custom/Validator.hs b/src/Codec/CBOR/Cuddle/CDDL/Custom/Validator.hs index 9f3f6ed5..12bdc923 100644 --- a/src/Codec/CBOR/Cuddle/CDDL/Custom/Validator.hs +++ b/src/Codec/CBOR/Cuddle/CDDL/Custom/Validator.hs @@ -22,25 +22,25 @@ module Codec.CBOR.Cuddle.CDDL.Custom.Validator ( validateStringTerm, validateMapTerm, validateNonEmpty, - validateUnique, - validateUniqueOn, + validateUniqueList, unwrapSingle, ) where +import Codec.CBOR.Cuddle.CBOR.Canonical (toCanonical) import Codec.CBOR.Cuddle.CDDL (GRef (..), Name (..)) import Codec.CBOR.Cuddle.CDDL.CTree (CTree, CTreeRoot (..), nintMin, uintMax) import Codec.CBOR.Cuddle.CDDL.Custom.Core (MonadCddl (..), RuleTerm (..)) import Codec.CBOR.Cuddle.CDDL.Custom.Generator (XXCTree) import Codec.CBOR.Term (Term (..)) -import Control.Monad (unless) import Control.Monad.Reader (MonadReader (..), ReaderT (..), asks) +import Data.Bifunctor (Bifunctor (..)) import Data.ByteString (ByteString) import Data.ByteString.Lazy qualified as LBS -import Data.Containers.ListUtils (nubOrd) import Data.Foldable (Foldable (..)) import Data.List.NonEmpty (NonEmpty, nonEmpty) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map +import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T import Data.Text.Lazy qualified as LT @@ -133,8 +133,8 @@ validateStringTerm (TStringI x) = pure $ LT.toStrict x validateStringTerm _ = fail "Expected string" validateMapTerm :: Term -> Validator [(Term, Term)] -validateMapTerm (TMap xs) = pure xs -validateMapTerm (TMapI xs) = pure xs +validateMapTerm (TMap xs) = validateUniqueMap xs >> pure xs +validateMapTerm (TMapI xs) = validateUniqueMap xs >> pure xs validateMapTerm _ = fail "Expected map" -- | Fail if the collection is empty. A custom-validator stand-in for the CDDL @@ -143,21 +143,19 @@ validateMapTerm _ = fail "Expected map" validateNonEmpty :: Foldable t => t a -> Validator (NonEmpty a) validateNonEmpty = maybe (fail "Expected at least one element") pure . nonEmpty . toList --- | Fail unless all elements of the list are pairwise distinct. Intended for --- custom validators of CDDL sets and of map keys: once a custom validator --- replaces the built-in array/map validation for a rule, element/key --- uniqueness is no longer enforced automatically and has to be asserted. -validateUnique :: Ord a => [a] -> Validator () -validateUnique = validateUniqueOn id - --- | Like 'validateUnique', but compares elements by a key projection, e.g. --- @'validateUniqueOn' fst@ over the entries of a map. -validateUniqueOn :: Ord b => (a -> b) -> [a] -> Validator () -validateUniqueOn key xs = - unless (length ks == length (nubOrd ks)) $ - fail "Expected all elements to be unique" +validateUniqueMap :: [(Term, Term)] -> Validator () +validateUniqueMap xs + | Map.size m == length xs = pure () + | otherwise = fail "Map contains duplicate keys" where - ks = map key xs + m = Map.fromList $ first toCanonical <$> xs + +validateUniqueList :: [Term] -> Validator () +validateUniqueList xs + | Set.size s == length xs = pure () + | otherwise = fail "List contains duplicate keys" + where + s = Set.fromList $ toCanonical <$> xs unwrapSingle :: RuleTerm -> Validator Term unwrapSingle (SingleTerm x) = pure x diff --git a/test/Main.hs b/test/Main.hs index ee8eda82..5207ab7a 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -2,6 +2,8 @@ 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.Custom.GeneratorSpec qualified as CustomGenerator +import Test.Codec.CBOR.Cuddle.CDDL.Custom.ValidatorSpec qualified as CustomValidator 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) @@ -29,6 +31,9 @@ main = do describe "Huddle" huddleSpec describe "Examples" Examples.spec describe "Generator" Generator.spec + describe "Custom" $ do + describe "Generator" CustomGenerator.spec + describe "Validator" CustomValidator.spec describe "Pretty" $ do describe "Golden" PrettyGolden.spec describe "Roundtrip" roundtripSpec diff --git a/test/Test/Codec/CBOR/Cuddle/CDDL/Custom/GeneratorSpec.hs b/test/Test/Codec/CBOR/Cuddle/CDDL/Custom/GeneratorSpec.hs new file mode 100644 index 00000000..ca2e3503 --- /dev/null +++ b/test/Test/Codec/CBOR/Cuddle/CDDL/Custom/GeneratorSpec.hs @@ -0,0 +1,112 @@ +module Test.Codec.CBOR.Cuddle.CDDL.Custom.GeneratorSpec (spec) where + +import Codec.CBOR.Cuddle.CDDL.CTree (CTreeRoot (..)) +import Codec.CBOR.Cuddle.CDDL.Custom.Generator ( + CBORGen, + GenConfig (..), + genArrayTerm, + genBytesTerm, + genMapTerm, + genStringTerm, + ifTwiddle, + runCBORGen, + ) +import Codec.CBOR.Cuddle.CDDL.Custom.Generator qualified as Gen +import Codec.CBOR.Cuddle.CDDL.Custom.Validator ( + validateArrayTerm, + validateBytesTerm, + validateMapTerm, + validateStringTerm, + ) +import Codec.CBOR.Term (Term (..)) +import Data.ByteString qualified as BS +import Data.List (sort) +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Test.AntiGen (runAntiGen) +import Test.Codec.CBOR.Cuddle.CDDL.Custom.ValidatorSpec (succeedsWith) +import Test.Hspec (Spec, describe) +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck ( + Gen, + chooseInt, + classify, + total, + (===), + ) +import Test.QuickCheck.GenT qualified as GenT + +runCustomGen :: Bool -> CBORGen a -> Gen a +runCustomGen twiddle = + runAntiGen . runCBORGen GenConfig {gcRoot = CTreeRoot Map.empty, gcTwiddle = twiddle} + +isIndefinite :: Term -> Bool +isIndefinite TListI {} = True +isIndefinite TBytesI {} = True +isIndefinite TStringI {} = True +isIndefinite TMapI {} = True +isIndefinite _ = False + +spec :: Spec +spec = do + describe "term generators with twiddling disabled" $ do + prop "genArrayTerm yields a definite list" $ \is -> do + let ts = map TInt is + res <- runCustomGen False $ genArrayTerm ts + pure $ res === TList ts + prop "genBytesTerm yields definite bytes" $ \ws -> do + let bs = BS.pack ws + res <- runCustomGen False $ genBytesTerm bs + pure $ res === TBytes bs + prop "genStringTerm yields a definite string" $ \s -> do + let t = T.pack s + res <- runCustomGen False $ genStringTerm t + pure $ res === TString t + prop "genMapTerm yields a definite map" $ \(kvs :: [(Int, Int)]) -> do + let ts = [(TInt k, TInt v) | (k, v) <- kvs] + res <- runCustomGen False $ genMapTerm ts + pure $ res === TMap ts + prop "ifTwiddle takes the second branch" $ do + res <- runCustomGen False $ ifTwiddle (pure True) (pure False) + pure $ res === False + + describe "term generators with twiddling enabled" $ do + prop "genArrayTerm roundtrips through validateArrayTerm" $ \is -> do + let ts = map TInt is + res <- runCustomGen True $ genArrayTerm ts + pure + . classify (isIndefinite res) "indefinite" + $ validateArrayTerm res `succeedsWith` ts + prop "genBytesTerm roundtrips through validateBytesTerm" $ \ws -> do + let bs = BS.pack ws + res <- runCustomGen True $ genBytesTerm bs + pure + . classify (isIndefinite res) "indefinite" + $ validateBytesTerm res `succeedsWith` bs + prop "genStringTerm roundtrips through validateStringTerm" $ \s -> do + let t = T.pack s + res <- runCustomGen True $ genStringTerm t + pure + . classify (isIndefinite res) "indefinite" + $ validateStringTerm res `succeedsWith` t + prop "genMapTerm roundtrips through validateMapTerm" $ \(kvs :: [(Int, Int)]) -> do + let ts = [(TInt k, TInt v) | (k, v) <- kvs] + res <- runCustomGen True $ genMapTerm ts + pure + . classify (isIndefinite res) "indefinite" + $ validateMapTerm res `succeedsWith` ts + prop "ifTwiddle takes the first branch" $ do + res <- runCustomGen True $ ifTwiddle (pure True) (pure False) + pure $ res === True + + describe "lifted QuickCheck functions" $ do + prop "shuffle returns a permutation" $ \(xs :: [Int]) -> do + ys <- runCustomGen True $ Gen.shuffle xs + pure $ sort ys === sort xs + prop "scale sets the size seen by the generator" $ do + k <- chooseInt (0, 99) + sz <- runCustomGen True $ Gen.scale (const k) (GenT.sized pure) + pure $ sz === k + prop "arbitrary lifts into CBORGen" $ do + n <- runCustomGen True (Gen.arbitrary :: CBORGen Int) + pure . classify (n /= 0) "non-zero" $ total n diff --git a/test/Test/Codec/CBOR/Cuddle/CDDL/Custom/ValidatorSpec.hs b/test/Test/Codec/CBOR/Cuddle/CDDL/Custom/ValidatorSpec.hs new file mode 100644 index 00000000..b90c45fd --- /dev/null +++ b/test/Test/Codec/CBOR/Cuddle/CDDL/Custom/ValidatorSpec.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Codec.CBOR.Cuddle.CDDL.Custom.ValidatorSpec ( + spec, + succeedsWith, +) where + +import Codec.CBOR.Cuddle.CDDL.CTree (CTreeRoot (..)) +import Codec.CBOR.Cuddle.CDDL.Custom.Core (RuleTerm (..)) +import Codec.CBOR.Cuddle.CDDL.Custom.Validator ( + CustomValidatorResult (..), + Validator, + ValidatorPhase, + runValidator, + unwrapSingle, + validateArrayTerm, + validateBytesTerm, + validateInt, + validateMapTerm, + validateNInt, + validateNonEmpty, + validateStringTerm, + validateUInt, + validateUniqueList, + ) +import Codec.CBOR.Term (Term (..)) +import Control.Monad (unless, void) +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as LBS +import Data.List (nub) +import Data.List.NonEmpty qualified as NE +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Data.Text.Lazy qualified as LT +import Data.Word (Word8) +import Test.Codec.CBOR.Cuddle.CDDL.Validator () +import Test.Hspec (Spec, describe) +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck ( + Property, + counterexample, + forAll, + property, + shuffle, + (.&&.), + (===), + ) + +emptyRoot :: CTreeRoot ValidatorPhase +emptyRoot = CTreeRoot Map.empty + +-- | The validator succeeds and returns the expected value. +succeedsWith :: (Eq a, Show a) => Validator a -> a -> Property +succeedsWith v expected = runValidator checked emptyRoot === CustomValidatorSuccess + where + checked = do + x <- v + unless (x == expected) . fail $ "Unexpected result: " <> show x + +succeeds :: Validator a -> Bool +succeeds v = runValidator (void v) emptyRoot == CustomValidatorSuccess + +fails :: Validator a -> Property +fails v = + counterexample "Expected the validator to fail" . property . not $ succeeds v + +spec :: Spec +spec = do + describe "validateInt" $ do + prop "accepts any TInt and returns its value" $ \i -> + validateInt (TInt i) `succeedsWith` toInteger i + prop "rejects non-int terms" $ + fails (validateInt (TString "hi")) .&&. fails (validateInt (TList [])) + + describe "validateUInt" $ do + prop "accepts a TInt iff it is non-negative" $ \i -> + if i >= 0 + then validateUInt (TInt i) `succeedsWith` toInteger i + else fails (validateUInt (TInt i)) + prop "rejects non-int terms" $ + fails (validateUInt TNull) + + describe "validateNInt" $ do + prop "accepts a TInt iff it is negative" $ \i -> + if i < 0 + then validateNInt (TInt i) `succeedsWith` toInteger i + else fails (validateNInt (TInt i)) + prop "rejects non-int terms" $ + fails (validateNInt (TBytes "")) + + describe "validateArrayTerm" $ do + prop "accepts definite and indefinite lists" $ \is -> + let ts = map TInt is + in validateArrayTerm (TList ts) `succeedsWith` ts + .&&. validateArrayTerm (TListI ts) `succeedsWith` ts + prop "rejects non-list terms" $ \i -> + fails (validateArrayTerm (TInt i)) + + describe "validateBytesTerm" $ do + prop "accepts definite and indefinite bytes" $ \ws -> + let bs = BS.pack ws + in validateBytesTerm (TBytes bs) `succeedsWith` bs + .&&. validateBytesTerm (TBytesI $ LBS.fromStrict bs) `succeedsWith` bs + prop "converts chunked indefinite bytes to strict" $ \(chunks :: [[Word8]]) -> + validateBytesTerm (TBytesI . LBS.fromChunks $ map BS.pack chunks) + `succeedsWith` BS.pack (concat chunks) + prop "rejects non-bytes terms" $ + fails (validateBytesTerm (TString "hi")) + + describe "validateStringTerm" $ do + prop "accepts definite and indefinite strings" $ \s -> + let t = T.pack s + in validateStringTerm (TString t) `succeedsWith` t + .&&. validateStringTerm (TStringI $ LT.fromStrict t) `succeedsWith` t + prop "converts chunked indefinite strings to strict" $ \(chunks :: [String]) -> + validateStringTerm (TStringI . LT.fromChunks $ map T.pack chunks) + `succeedsWith` T.pack (concat chunks) + prop "rejects non-string terms" $ + fails (validateStringTerm (TBytes "hi")) + + describe "validateMapTerm" $ do + prop "accepts definite and indefinite maps" $ \(kvs :: [(Int, Int)]) -> + let ts = [(TInt k, TInt v) | (k, v) <- kvs] + in validateMapTerm (TMap ts) `succeedsWith` ts + .&&. validateMapTerm (TMapI ts) `succeedsWith` ts + prop "rejects non-map terms" $ + fails (validateMapTerm (TList [])) + + describe "validateNonEmpty" $ do + prop "succeeds on a non-empty list and preserves the elements" $ \x (xs :: [Int]) -> + fmap NE.toList (validateNonEmpty (x : xs)) `succeedsWith` (x : xs) + prop "fails on an empty list" $ + fails (validateNonEmpty ([] :: [Int])) + + describe "validateUnique" $ do + prop "agrees with a nub oracle" $ \(xs :: [Term]) -> + succeeds (validateUniqueList xs) === (nub xs == xs) + prop "fails whenever a duplicate is present" $ \x (xs :: [Term]) -> + forAll (shuffle (x : x : xs)) $ \ys -> + fails (validateUniqueList ys) + + describe "unwrapSingle" $ do + prop "returns the term inside a SingleTerm" $ \i -> + unwrapSingle (SingleTerm (TInt i)) `succeedsWith` TInt i + prop "rejects pair and group terms" $ \i -> + fails (unwrapSingle (PairTerm (TInt i) (TInt i))) + .&&. fails (unwrapSingle (GroupTerm [])) diff --git a/test/Test/Codec/CBOR/Cuddle/CDDL/Validator.hs b/test/Test/Codec/CBOR/Cuddle/CDDL/Validator.hs index dcc4d95a..16f955f6 100644 --- a/test/Test/Codec/CBOR/Cuddle/CDDL/Validator.hs +++ b/test/Test/Codec/CBOR/Cuddle/CDDL/Validator.hs @@ -1,6 +1,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Test.Codec.CBOR.Cuddle.CDDL.Validator ( spec, @@ -219,28 +220,28 @@ genBytesTerm x = elements [TBytes x, TBytesI $ LBS.fromStrict x] arbitraryByteString :: Gen ByteString arbitraryByteString = BS.pack <$> arbitrary -arbitraryTerm :: Gen Term -arbitraryTerm = - oneof - [ TInt <$> arbitrary - , TInteger <$> arbitrary - , TBytes . BS.pack <$> arbitrary - , TBytesI . LBS.pack <$> arbitrary - , TString . T.pack <$> arbitrary - , TStringI . LT.pack <$> arbitrary - , TList <$> listOf (scale (`div` 2) arbitraryTerm) - , TListI <$> listOf (scale (`div` 2) arbitraryTerm) - , TMap <$> listOf (scale (`div` 2) $ (,) <$> arbitraryTerm <*> arbitraryTerm) - , TMapI <$> listOf (scale (`div` 2) $ (,) <$> arbitraryTerm <*> arbitraryTerm) - , -- TODO properly implement tagged generation - -- , TTagged <$> arbitrary <*> arbitraryTerm - TBool <$> arbitrary - , pure TNull - , pure $ TSimple 23 -- TODO add other values once they are supported by cuddle - , THalf <$> arbitrary - , TFloat <$> arbitrary - , TDouble <$> arbitrary - ] +instance Arbitrary Term where + arbitrary = + oneof + [ TInt <$> arbitrary + , TInteger <$> arbitrary + , TBytes . BS.pack <$> arbitrary + , TBytesI . LBS.pack <$> arbitrary + , TString . T.pack <$> arbitrary + , TStringI . LT.pack <$> arbitrary + , TList <$> listOf (scale (`div` 2) arbitrary) + , TListI <$> listOf (scale (`div` 2) arbitrary) + , TMap <$> listOf (scale (`div` 2) $ (,) <$> arbitrary <*> arbitrary) + , TMapI <$> listOf (scale (`div` 2) $ (,) <$> arbitrary <*> arbitrary) + , -- TODO properly implement tagged generation + -- , TTagged <$> arbitrary <*> arbitrary + TBool <$> arbitrary + , pure TNull + , pure $ TSimple 23 -- TODO add other values once they are supported by cuddle + , THalf <$> arbitrary + , TFloat <$> arbitrary + , TDouble <$> arbitrary + ] genFullMap :: Gen Term genFullMap = do @@ -259,7 +260,7 @@ genFullMap = do <$> listOf ((,) <$> (genStringTerm . T.pack =<< arbitrary) <*> (TInt <$> arbitrary)) bytesFields <- nubOrdOn (toCanonical . fst) - <$> listOf1 ((,) <$> (genBytesTerm =<< arbitraryByteString) <*> arbitraryTerm) + <$> listOf1 ((,) <$> (genBytesTerm =<< arbitraryByteString) <*> arbitrary) allFields <- shuffle $ field1 : lField2 <> strFields <> bytesFields genMapTerm allFields