From 746150c9a1e66fc83c171c6aa37090ea8b1b9d4e Mon Sep 17 00:00:00 2001 From: Magesh B Date: Thu, 24 Sep 2026 02:23:54 +0530 Subject: [PATCH] webapi-contract: an optional param is present by its own key, not by a sibling it prefixes The presence tests in FromParam (Maybe a, Either a b, lists, Set and MultiSet elements, a sum's constructor) took `submap key kvs`, a raw byte-prefix lookup: `page :: Maybe Int` saw `pageSize=20` as its own params, found no `page` and failed NotFound "page"; `ids :: Maybe [Int]` became `Just []` beside `idsFilter`; `inner :: Maybe Inner` failed NotFound "inner.x" beside `innerMost`. Callers renamed fields to dodge it (zenbridge#2241: `partnerQualifier` for `partnerAddressQualifier`, `multiFileIds` for `fileIds`). subParams key: the key itself and the keys nested under it (`key.`), the top level (the empty key) everything. Tests: the three cases above fail before the change, pass after; round trip unchanged. Co-Authored-By: Claude Opus 5.5 (1M context) --- webapi-contract/src/WebApi/Param.hs | 35 ++++++++++++++------- webapi-contract/tests/Param.hs | 49 +++++++++++++++++++++++++++++ 2 files changed, 72 insertions(+), 12 deletions(-) diff --git a/webapi-contract/src/WebApi/Param.hs b/webapi-contract/src/WebApi/Param.hs index 939b1f0..b3307a8 100644 --- a/webapi-contract/src/WebApi/Param.hs +++ b/webapi-contract/src/WebApi/Param.hs @@ -1506,7 +1506,7 @@ instance FromParam par a => FromParam par (Maybe a) where False -> case (fromParam pt key kvs' :: Validation [ParamErr] a) of Validation (Right val) -> Validation $ Right $ Just val Validation (Left errs) -> Validation $ Left errs - where kvs' = submap key kvs + where kvs' = subParams key kvs instance (FromParam par a, FromParam par b) => FromParam par (Either a b) where fromParam pt key kvs = case Trie.null kvsL of @@ -1514,8 +1514,8 @@ instance (FromParam par a, FromParam par b) => FromParam par (Either a b) where True -> Validation $ Left [ParseErr key "Unable to cast to Either"] False -> Right <$> fromParam pt keyR kvsR False -> Left <$> fromParam pt keyL kvsL - where kvsL = submap keyL kvs - kvsR = submap keyR kvs + where kvsL = subParams keyL kvs + kvsR = subParams keyR kvs keyL = (key `nest` "Left") keyR = (key `nest` "Right") @@ -1588,10 +1588,10 @@ instance (FromParam par a) => FromParam par [a] where False -> let pars = Prelude.map (\(nkey, kv) -> fromParam pt nkey kv :: Validation [ParamErr] a) kvitems in catValidations pars - where kvs' = submap key kvs + where kvs' = subParams key kvs kvitems = Prelude.takeWhile (not . Prelude.null . snd) (Prelude.map (\ix -> let ixkey = key `nest` (ASCII.pack $ show ix) - in (ixkey, submap ixkey kvs')) [(0 :: Word) .. 2000]) + in (ixkey, subParams ixkey kvs')) [(0 :: Word) .. 2000]) instance KnownSymbol s => FromParam 'QueryParam (Choice s) where fromParam pt key kvs = case lookupParam pt key kvs of @@ -1631,22 +1631,22 @@ fromParamToSetLike key kvs' = in catValidations pars instance (DecodeParam a, Ord a) => FromParam 'QueryParam (Set a) where - fromParam _ key kvs = Set.fromList <$> fromParamToSetLike key (catMaybes $ Trie.elems $ submap key kvs) + fromParam _ key kvs = Set.fromList <$> fromParamToSetLike key (catMaybes $ Trie.elems $ subParams key kvs) instance (DecodeParam a, Ord a) => FromParam 'FormParam (Set a) where - fromParam _ key kvs = Set.fromList <$> fromParamToSetLike key (Trie.elems $ submap key kvs) + fromParam _ key kvs = Set.fromList <$> fromParamToSetLike key (Trie.elems $ subParams key kvs) instance (DecodeParam a, Ord a) => FromParam 'Cookie (Set a) where - fromParam _ key kvs = Set.fromList <$> fromParamToSetLike key (Trie.elems $ submap key kvs) + fromParam _ key kvs = Set.fromList <$> fromParamToSetLike key (Trie.elems $ subParams key kvs) instance (DecodeParam a, Ord a) => FromParam 'QueryParam (MultiSet a) where - fromParam _ key kvs = (MultiSet . MultiSet.fromList) <$> fromParamToSetLike key (catMaybes $ Trie.elems $ submap key kvs) + fromParam _ key kvs = (MultiSet . MultiSet.fromList) <$> fromParamToSetLike key (catMaybes $ Trie.elems $ subParams key kvs) instance (DecodeParam a, Ord a) => FromParam 'FormParam (MultiSet a) where - fromParam _ key kvs = (MultiSet . MultiSet.fromList) <$> fromParamToSetLike key (Trie.elems $ submap key kvs) + fromParam _ key kvs = (MultiSet . MultiSet.fromList) <$> fromParamToSetLike key (Trie.elems $ subParams key kvs) instance (DecodeParam a, Ord a) => FromParam 'Cookie (MultiSet a) where - fromParam _ key kvs = (MultiSet . MultiSet.fromList) <$> fromParamToSetLike key (Trie.elems $ submap key kvs) + fromParam _ key kvs = (MultiSet . MultiSet.fromList) <$> fromParamToSetLike key (Trie.elems $ subParams key kvs) instance (DecodeParam a) => FromParam 'QueryParam (OptValue a) where fromParam pt key kvs = case lookupParam pt key kvs of @@ -1935,6 +1935,17 @@ nest s1 s2 | SB.null s1 = s2 lookupParam :: Proxy (parK :: ParamK) -> ByteString -> Trie (DeSerializedData parK) -> Maybe (DeSerializedData parK) lookupParam _ key kvs = Trie.lookup key kvs +-- | The params of the given key: the key itself and the keys nested under +-- it ('nest'), never a sibling key it merely prefixes — @page@'s params do +-- not include @pageSize@. The empty key (the top level) is every param. +-- +-- > subParams "page" [("page", 1), ("page.x", 2), ("pageSize", 3)] == [("page", 1), ("page.x", 2)] +subParams :: ByteString -> Trie a -> Trie a +subParams key kvs + | SB.null key = kvs + | otherwise = maybe nested (\v -> Trie.insert key v nested) (Trie.lookup key kvs) + where nested = submap (key <> ".") kvs + data ParamAcc = ParamAcc { index :: Int, isSum :: Bool } deriving (Show, Eq) @@ -2055,7 +2066,7 @@ instance (GFromParam f parK, Constructor t) => GFromParam (M1 C t f) parK where gfromParam pt pfx pa psett kvs = let conN = ASCII.pack (conName (undefined :: (M1 C t f) a)) in case isSum pa of - True -> case Trie.null $ submap (pfx `nest` conN) kvs of + True -> case Trie.null $ subParams (pfx `nest` conN) kvs of False -> M1 <$> gfromParam pt (pfx `nest` conN) pa psett kvs True -> Validation $ Left [] False -> M1 <$> gfromParam pt pfx pa psett kvs diff --git a/webapi-contract/tests/Param.hs b/webapi-contract/tests/Param.hs index 5f4521e..672e2f6 100644 --- a/webapi-contract/tests/Param.hs +++ b/webapi-contract/tests/Param.hs @@ -3,14 +3,20 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} module Param where +import GHC.Generics (Generic) import Hedgehog import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import Test.Tasty import Test.Tasty.Hedgehog +import Test.Tasty.HUnit import WebApi.Param test_ParamRoundTrip :: TestTree @@ -47,6 +53,49 @@ test_ParamRoundTrip = ] ] +-- | Two optional fields where one name is a byte-prefix of the other: the +-- presence test of @page@ must not see @pageSize@. +data Paging = Paging + { page :: Maybe Int + , pageSize :: Maybe Int + , ids :: Maybe [Int] + , idsFilter :: Maybe Int + , inner :: Maybe Inner + , innerMost :: Maybe Int + } + deriving stock (Show, Eq, Generic) + deriving anyclass (FromParam 'QueryParam, ToParam 'QueryParam) + +newtype Inner = Inner { x :: Int } + deriving stock (Show, Eq, Generic) + deriving anyclass (FromParam 'QueryParam, ToParam 'QueryParam) + +noPaging :: Paging +noPaging = Paging Nothing Nothing Nothing Nothing Nothing Nothing + +test_ParamPresence :: TestTree +test_ParamPresence = + testGroup + "an optional param is present by its own key, not by a sibling it prefixes" + [ testCase "pageSize alone leaves page absent" $ + getValidation (fromQueryParam [("pageSize", Just "20")]) @?= Right noPaging {pageSize = Just 20} + , testCase "page alone" $ + getValidation (fromQueryParam [("page", Just "2")]) @?= Right noPaging {page = Just 2} + , testCase "page and pageSize" $ + getValidation (fromQueryParam [("page", Just "2"), ("pageSize", Just "20")]) @?= Right noPaging {page = Just 2, pageSize = Just 20} + , testCase "a sibling does not make a list present" $ + getValidation (fromQueryParam [("idsFilter", Just "5")]) @?= Right noPaging {idsFilter = Just 5} + , testCase "a list by its nested keys" $ + getValidation (fromQueryParam [("ids.0", Just "1"), ("ids.1", Just "2")]) @?= Right noPaging {ids = Just [1, 2]} + , testCase "a nested record by its nested keys, beside a sibling it prefixes" $ + getValidation (fromQueryParam [("inner.x", Just "7"), ("innerMost", Just "8")]) @?= Right noPaging {inner = Just (Inner 7), innerMost = Just 8} + , testCase "a sibling does not make a nested record present" $ + getValidation (fromQueryParam [("innerMost", Just "8")]) @?= Right noPaging {innerMost = Just 8} + , testCase "round trip" $ + let v = Paging (Just 1) (Just 2) (Just [3, 4]) (Just 5) (Just (Inner 6)) (Just 7) + in getValidation (fromQueryParam (toQueryParam v)) @?= Right v + ] + maxBoundOf :: forall a gen. (Bounded a, MonadGen gen) => (Range a -> gen a) -> gen a maxBoundOf gen = gen (Range.singleton $ maxBound @a)