webapi-contract: an optional param is present by its own key, not by a sibling it prefixes

webapi-contract/src/WebApi/Param.hs

@@ -1506,16 +1506,16 @@ 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
     True -> case Trie.null kvsR of
       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

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)