Fixed fill not able to deal with certain JSON bodies

The previous implementation of `fill` only worked with JSON bodies of the following form:

{"key": "value"}

It failed for requests where the value was not encoded as a string, such as these:

{"boolField": true}
{"intField": 1337}

This was caused by the implementation of fill using `paramOrNothing` to check for the existence of a parameter in the request. This has worked fine for url encoded request bodies as there the input has no type and can always be parsed as a string (e.g. `1337` can always be parsed as a string, while in json requests we have type information and only accept `"string"` as a string and raising an error for `1337` because it's a number)

IHP/Controller/Param.hs

@@ -228,6 +228,7 @@ paramOrError !name =
                     Just value -> case readParameterJSON @paramType value of
                         Left parserError -> Left ParamCouldNotBeParsedException { name, parserError }
                         Right value -> Right value
+                    Nothing -> Left ParamNotFoundException { name }
                 _ -> Left ParamNotFoundException { name }
 {-# INLINABLE paramOrError #-}
 
@@ -559,12 +560,10 @@ instance (FillParams rest record
     ) => FillParams (fieldName:rest) record where
     fill !record = do
         let name :: ByteString = cs $! (symbolVal (Proxy @fieldName))
-        case paramOrNothing name of
-            Just !paramValue ->
-                case readParameter paramValue of
-                    Left !error -> fill @rest (attachFailure (Proxy @fieldName) (cs error) record)
-                    Right !(value :: fieldType) -> fill @rest (setField @fieldName value record)
-            Nothing -> fill @rest record
+        case paramOrError name of
+            Right !(value :: fieldType) -> fill @rest (setField @fieldName value record)
+            Left ParamCouldNotBeParsedException { parserError } -> fill @rest (attachFailure (Proxy @fieldName) (cs parserError) record)
+            Left ParamNotFoundException {} -> fill @rest record
     {-# INLINABLE fill #-}
 
 ifValid :: (HasField "meta" model ModelSupport.MetaBag) => (Either model model -> IO r) -> model -> IO r

Test/Controller/ParamSpec.hs

@@ -323,6 +323,7 @@ tests = do
                 it "should handle empty input as Nothing" do
                     (readParameter @(Maybe Int) "") `shouldBe` (Right Nothing)
                     (readParameter @(Maybe UUID) "") `shouldBe` (Right Nothing)
+                    (readParameterJSON @(Maybe Bool) "") `shouldBe` (Right Nothing)
 
                 it "should handle empty Text as Just" do
                     (readParameter @(Maybe Text) "") `shouldBe` (Right (Just ""))
@@ -353,13 +354,66 @@ tests = do
                     (readParameterJSON @Color (json "\"\"")) `shouldBe` (Left "Invalid value")
                     (readParameterJSON @Color (json "1337")) `shouldBe` (Left "enumParamReaderJSON: Invalid value, expected a string but got something else")
 
+        describe "fill" do
+            it "should fill provided values if valid" do
+                let ?context = createControllerContextWithParams [("boolField", "on"), ("colorField", "Red")]
+
+                let emptyRecord = FillRecord { boolField = False, colorField = Yellow, meta = def }
+                let expectedRecord = FillRecord { boolField = True, colorField = Red, meta = def { touchedFields = ["colorField", "boolField"] } }
+
+                let filledRecord = emptyRecord |> fill @["boolField", "colorField"]
+                filledRecord `shouldBe` expectedRecord
+
+            it "should not touch fields if a field is missing" do
+                let ?context = createControllerContextWithParams [("colorField", "Red")]
+
+                let emptyRecord = FillRecord { boolField = False, colorField = Yellow, meta = def }
+                let expectedRecord = FillRecord { boolField = False, colorField = Red, meta = def { touchedFields = ["colorField"] } }
+
+                let filledRecord = emptyRecord |> fill @["boolField", "colorField"]
+                filledRecord `shouldBe` expectedRecord
+
+            it "should add validation errors if the parsing fails" do
+                let ?context = createControllerContextWithParams [("colorField", "invalid color")]
+
+                let emptyRecord = FillRecord { boolField = False, colorField = Yellow, meta = def }
+                let expectedRecord = FillRecord { boolField = False, colorField = Yellow, meta = def { annotations = [("colorField", "Invalid value")] } }
+
+                let filledRecord = emptyRecord |> fill @["boolField", "colorField"]
+                filledRecord `shouldBe` expectedRecord
+
+            it "should deal with json values" do
+                let ?context = createControllerContextWithJson "{\"colorField\":\"Red\",\"boolField\":true}"
+
+                let emptyRecord = FillRecord { boolField = False, colorField = Yellow, meta = def }
+                let expectedRecord = FillRecord { boolField = True, colorField = Red, meta = def { touchedFields = ["colorField", "boolField"] } }
+
+                let filledRecord = emptyRecord |> fill @["boolField", "colorField"]
+                filledRecord `shouldBe` expectedRecord
+
+            it "should deal with empty json values" do
+                let ?context = createControllerContextWithJson "{}"
+
+                let emptyRecord = FillRecord { boolField = False, colorField = Yellow, meta = def }
+                let expectedRecord = FillRecord { boolField = False, colorField = Yellow, meta = def }
+
+                let filledRecord = emptyRecord |> fill @["boolField", "colorField"]
+                filledRecord `shouldBe` expectedRecord
+
 createControllerContextWithParams params =
         let
             requestBody = FormBody { params, files = [] }
             request = Wai.defaultRequest
             requestContext = RequestContext { request, respond = error "respond", requestBody, vault = error "vault", frameworkConfig = error "frameworkConfig" }
         in FrozenControllerContext { requestContext, customFields = TypeMap.empty }
 
+createControllerContextWithJson params =
+        let
+            requestBody = JSONBody { jsonPayload = Just (json params), rawPayload = cs params }
+            request = Wai.defaultRequest
+            requestContext = RequestContext { request, respond = error "respond", requestBody, vault = error "vault", frameworkConfig = error "frameworkConfig" }
+        in FrozenControllerContext { requestContext, customFields = TypeMap.empty }
+
 json :: Text -> Aeson.Value
 json string =
     let (Just value) :: Maybe Aeson.Value = Aeson.decode (cs string)
@@ -370,3 +424,16 @@ instance ParamReader Color where
     readParameter = enumParamReader
     readParameterJSON = enumParamReaderJSON
 instance InputValue Color where inputValue = tshow
+
+
+data FillRecord = FillRecord { boolField :: Bool, colorField :: Color, meta :: MetaBag }
+    deriving (Show, Eq)
+
+instance SetField "boolField" FillRecord Bool where
+    setField value record = record { boolField = value } |> modify #meta (modify #touchedFields ("boolField":))
+
+instance SetField "colorField" FillRecord Color where
+    setField value record = record { colorField = value } |> modify #meta (modify #touchedFields ("colorField":))
+
+instance SetField "meta" FillRecord MetaBag where
+    setField value record = record { meta = value }