diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +The MIT License (MIT) + +Copyright (c) 2020 digitally induced GmbH + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/Test/Spec.hs b/Test/Spec.hs new file mode 100644 --- /dev/null +++ b/Test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/Test/Wai/Request/Params/MiddlewareSpec.hs b/Test/Wai/Request/Params/MiddlewareSpec.hs new file mode 100644 --- /dev/null +++ b/Test/Wai/Request/Params/MiddlewareSpec.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE OverloadedStrings #-} +module Wai.Request.Params.MiddlewareSpec where + +import Prelude +import Test.Hspec +import Data.String.Conversions (cs) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as LBS +import Network.Wai +import Network.Wai.Test +import Network.HTTP.Types +import qualified Data.Vault.Lazy as Vault +import qualified Network.Wai.Parse as WaiParse + +import Wai.Request.Params.Middleware (requestBodyMiddleware, RequestBody(..), requestBodyVaultKey) +import Wai.Request.Params (allParams) + +-- | An app that extracts the parsed RequestBody from the vault and returns info about it +inspectBodyApp :: Application +inspectBodyApp req respond = do + let body = Vault.lookup requestBodyVaultKey (vault req) + case body of + Just (FormBody params files _rawPayload) -> + respond $ responseLBS status200 [] (cs $ "FormBody params=" <> show (length params) <> " files=" <> show (length files)) + Just (JSONBody jsonPayload _) -> + respond $ responseLBS status200 [] (cs $ "JSONBody payload=" <> show jsonPayload) + Nothing -> + respond $ responseLBS status200 [] "no body in vault" + +-- | An app that reads the rawPayload from the middleware-parsed body. +-- This simulates what getRequestBody does: it accesses parsedBody.rawPayload. +rereadBodyApp :: Application +rereadBodyApp req respond = do + let body = Vault.lookup requestBodyVaultKey (vault req) + case body of + Just rb -> respond $ responseLBS status200 [] (rawPayload rb) + Nothing -> respond $ responseLBS status200 [] "" + +-- | An app that returns all params (body + query string) via allParams +inspectAllParamsApp :: Application +inspectAllParamsApp req respond = do + let body = Vault.lookup requestBodyVaultKey (vault req) + case body of + Just requestBody -> + let params = allParams requestBody req + in respond $ responseLBS status200 [] (cs $ show params) + Nothing -> + respond $ responseLBS status200 [] "no body in vault" + +app :: Application +app = requestBodyMiddleware WaiParse.defaultParseRequestBodyOptions inspectBodyApp + +makeRequest :: ByteString -> [(HeaderName, ByteString)] -> Session SResponse +makeRequest method headers = srequest $ SRequest req "" + where + req = defaultRequest + { requestMethod = method + , requestHeaders = headers + } + +makeRequestWithBody :: ByteString -> [(HeaderName, ByteString)] -> LBS.ByteString -> Session SResponse +makeRequestWithBody method headers body = srequest $ SRequest req body + where + req = defaultRequest + { requestMethod = method + , requestHeaders = headers + } + +spec :: Spec +spec = do + describe "requestBodyMiddleware" $ do + describe "skips body parsing for bodyless methods" $ do + it "returns empty FormBody for GET requests" $ do + response <- runSession (makeRequest "GET" []) app + cs (simpleBody response) `shouldBe` ("FormBody params=0 files=0" :: String) + + it "returns empty FormBody for HEAD requests" $ do + response <- runSession (makeRequest "HEAD" []) app + cs (simpleBody response) `shouldBe` ("FormBody params=0 files=0" :: String) + + it "returns empty FormBody for DELETE requests" $ do + response <- runSession (makeRequest "DELETE" []) app + cs (simpleBody response) `shouldBe` ("FormBody params=0 files=0" :: String) + + it "returns empty FormBody for OPTIONS requests" $ do + response <- runSession (makeRequest "OPTIONS" []) app + cs (simpleBody response) `shouldBe` ("FormBody params=0 files=0" :: String) + + describe "parses body for methods that have one" $ do + it "parses form body for POST requests" $ do + let body = "name=test&value=123" + response <- runSession (makeRequestWithBody "POST" [(hContentType, "application/x-www-form-urlencoded")] body) app + cs (simpleBody response) `shouldBe` ("FormBody params=2 files=0" :: String) + + it "parses form body for PUT requests" $ do + let body = "name=test" + response <- runSession (makeRequestWithBody "PUT" [(hContentType, "application/x-www-form-urlencoded")] body) app + cs (simpleBody response) `shouldBe` ("FormBody params=1 files=0" :: String) + + it "parses form body for PATCH requests" $ do + let body = "name=test" + response <- runSession (makeRequestWithBody "PATCH" [(hContentType, "application/x-www-form-urlencoded")] body) app + cs (simpleBody response) `shouldBe` ("FormBody params=1 files=0" :: String) + + it "parses JSON body for POST requests" $ do + let body = "{\"name\": \"test\"}" + response <- runSession (makeRequestWithBody "POST" [(hContentType, "application/json")] body) app + cs (simpleBody response) `shouldBe` ("JSONBody payload=Just (Object (fromList [(\"name\",String \"test\")]))" :: String) + + it "parses JSON body when Content-Type includes charset parameter" $ do + let body = "{\"name\": \"test\"}" + response <- runSession (makeRequestWithBody "POST" [(hContentType, "application/json; charset=utf-8")] body) app + cs (simpleBody response) `shouldBe` ("JSONBody payload=Just (Object (fromList [(\"name\",String \"test\")]))" :: String) + + it "does not parse as JSON when Content-Type is a non-JSON type starting with application/json" $ do + let body = "{\"name\": \"test\"}" + response <- runSession (makeRequestWithBody "POST" [(hContentType, "application/jsonFOO")] body) app + cs (simpleBody response) `shouldBe` ("FormBody params=0 files=0" :: String) + + it "returns JSONBody with Nothing payload for invalid JSON POST" $ do + let body = "not valid json{{" + response <- runSession (makeRequestWithBody "POST" [(hContentType, "application/json")] body) app + cs (simpleBody response) `shouldBe` ("JSONBody payload=Nothing" :: String) + + it "returns FormBody for POST without Content-Type" $ do + let body = "{\"name\": \"test\"}" + response <- runSession (makeRequestWithBody "POST" [] body) app + cs (simpleBody response) `shouldBe` ("FormBody params=0 files=0" :: String) + + it "returns JSONBody with Nothing payload for empty body with application/json" $ do + let body = "" + response <- runSession (makeRequestWithBody "POST" [(hContentType, "application/json")] body) app + cs (simpleBody response) `shouldBe` ("JSONBody payload=Nothing" :: String) + + describe "raw body preservation (getRequestBody)" $ do + it "preserves raw body for form-encoded POST requests" $ do + let body = "name=test&value=123" + let rereadApp = requestBodyMiddleware WaiParse.defaultParseRequestBodyOptions rereadBodyApp + response <- runSession (makeRequestWithBody "POST" [(hContentType, "application/x-www-form-urlencoded")] body) rereadApp + simpleBody response `shouldBe` body + + it "preserves raw body for POST with non-JSON Content-Type" $ do + let body = "key1=val1" + let rereadApp = requestBodyMiddleware WaiParse.defaultParseRequestBodyOptions rereadBodyApp + response <- runSession (makeRequestWithBody "POST" [(hContentType, "application/x-www-form-urlencoded")] body) rereadApp + simpleBody response `shouldBe` body + + describe "query string params" $ do + it "preserves query params on GET requests even though body parsing is skipped" $ do + let allParamsApp = requestBodyMiddleware WaiParse.defaultParseRequestBodyOptions inspectAllParamsApp + let req = defaultRequest + { requestMethod = "GET" + , queryString = [("foo", Just "bar"), ("baz", Just "qux")] + } + response <- runSession (srequest $ SRequest req "") allParamsApp + cs (simpleBody response) `shouldBe` ("[(\"foo\",Just \"bar\"),(\"baz\",Just \"qux\")]" :: String) diff --git a/Test/Wai/Request/ParamsSpec.hs b/Test/Wai/Request/ParamsSpec.hs new file mode 100644 --- /dev/null +++ b/Test/Wai/Request/ParamsSpec.hs @@ -0,0 +1,399 @@ +{-# LANGUAGE OverloadedStrings #-} +{-| +Module: Test.Wai.Request.ParamsSpec +Copyright: (c) digitally induced GmbH, 2020 +-} +module Wai.Request.ParamsSpec where + +import Prelude +import Test.Hspec +import Wai.Request.Params +import qualified Data.Vault.Lazy as Vault +import qualified Data.Aeson as Aeson +import qualified Data.UUID as UUID +import qualified Network.Wai as Wai +import qualified GHC.IO as IO +import Data.Scientific (Scientific) +import Data.Time.Clock (UTCTime) +import Data.Time.LocalTime (LocalTime, TimeOfDay) +import Data.Time.Calendar (Day) +import Data.ByteString (ByteString) +import Data.Text (Text) +import qualified Data.Text as Text +import Data.UUID (UUID) +import Data.String.Conversions (cs) +import Data.Maybe (fromJust) + +spec :: Spec +spec = do + describe "Wai.Request.Params" $ do + describe "param" $ do + it "should parse valid input" $ do + let (requestBody, request) = createRequestWithParams [("page", "1")] + (param @Int requestBody request "page") `shouldBe` 1 + + it "should fail on empty input" $ do + let (requestBody, request) = createRequestWithParams [("page", "")] + (IO.evaluate (param @Int requestBody request "page")) `shouldThrow` (== ParamCouldNotBeParsedException { name = "page", parserError = "has to be an integer" }) + + it "should fail if param not provided" $ do + let (requestBody, request) = createRequestWithParams [] + (IO.evaluate (param @Int requestBody request "page")) `shouldThrow` (== ParamNotFoundException { name = "page" }) + + it "should fail with a parser error on invalid input" $ do + let (requestBody, request) = createRequestWithParams [("page", "NaN")] + (IO.evaluate (param @Int requestBody request "page")) `shouldThrow` (== ParamCouldNotBeParsedException { name = "page", parserError = "has to be an integer" }) + + describe "paramOrNothing" $ do + it "should parse valid input" $ do + let (requestBody, request) = createRequestWithParams [("referredBy", "776ab71d-327f-41b3-90a8-7b5a251c4b88")] + (paramOrNothing @UUID requestBody request "referredBy") `shouldBe` (Just (uuid "776ab71d-327f-41b3-90a8-7b5a251c4b88")) + + it "should return Nothing on empty input" $ do + let (requestBody, request) = createRequestWithParams [("referredBy", "")] + (paramOrNothing @UUID requestBody request "referredBy") `shouldBe` Nothing + + it "should return Nothing if param not provided" $ do + let (requestBody, request) = createRequestWithParams [] + (paramOrNothing @UUID requestBody request "referredBy") `shouldBe` Nothing + + it "should fail with a parser error on invalid input" $ do + let (requestBody, request) = createRequestWithParams [("referredBy", "not a uuid")] + (IO.evaluate (paramOrNothing @UUID requestBody request "referredBy")) `shouldThrow` (== ParamCouldNotBeParsedException { name = "referredBy", parserError = "has to be an UUID" }) + + describe "paramOrDefault" $ do + it "should parse valid input" $ do + let (requestBody, request) = createRequestWithParams [("page", "1")] + (paramOrDefault @Int requestBody request 0 "page") `shouldBe` 1 + + it "should return default value on empty input" $ do + let (requestBody, request) = createRequestWithParams [("page", "")] + (paramOrDefault @Int requestBody request 10 "page") `shouldBe` 10 + + it "should return default value if param not provided" $ do + let (requestBody, request) = createRequestWithParams [] + (paramOrDefault @Int requestBody request 10 "page") `shouldBe` 10 + + it "should fail with a parser error on invalid input" $ do + let (requestBody, request) = createRequestWithParams [("page", "NaN")] + (IO.evaluate (paramOrDefault @Int requestBody request 10 "page")) `shouldThrow` (== ParamCouldNotBeParsedException { name = "page", parserError = "has to be an integer" }) + + + describe "paramList" $ do + it "should parse valid input" $ do + let (requestBody, request) = createRequestWithParams [("ingredients", "milk"), ("ingredients", "egg")] + (paramList @Text requestBody request "ingredients") `shouldBe` ["milk", "egg"] + + it "should fail on invalid input" $ do + let (requestBody, request) = createRequestWithParams [("numbers", "1"), ("numbers", "NaN")] + (IO.evaluate (paramList @Int requestBody request "numbers")) `shouldThrow` (errorCall "param: Parameter 'numbers' is invalid") + + it "should deal with empty input" $ do + let (requestBody, request) = createRequestWithParams [] + (paramList @Int requestBody request "numbers") `shouldBe` [] + + describe "paramListOrNothing" $ do + it "should parse valid input" $ do + let (requestBody, request) = createRequestWithParams [("ingredients", "milk"), ("ingredients", ""), ("ingredients", "egg")] + (paramListOrNothing @Text requestBody request "ingredients") `shouldBe` [Just "milk", Nothing, Just "egg"] + + it "should not fail on invalid input" $ do + let (requestBody, request) = createRequestWithParams [("numbers", "1"), ("numbers", "NaN")] + (paramListOrNothing @Int requestBody request "numbers") `shouldBe` [Just 1, Nothing] + + it "should deal with empty input" $ do + let (requestBody, request) = createRequestWithParams [] + (paramListOrNothing @Int requestBody request "numbers") `shouldBe` [] + + describe "hasParam" $ do + it "returns True if param given" $ do + let (requestBody, request) = createRequestWithParams [("a", "test")] + hasParam requestBody request "a" `shouldBe` True + + it "returns True if param given but empty" $ do + let (requestBody, request) = createRequestWithParams [("a", "")] + hasParam requestBody request "a" `shouldBe` True + + it "returns False if param missing" $ do + let (requestBody, request) = createRequestWithParams [] + hasParam requestBody request "a" `shouldBe` False + + describe "ParamReader" $ do + describe "ByteString" $ do + it "should handle text input" $ do + (readParameter @ByteString "test") `shouldBe` (Right "test") + it "should handle JSON strings" $ do + (readParameterJSON @ByteString (json "\"test\"")) `shouldBe` (Right ("test" :: ByteString)) + + it "should fail on other JSON input" $ do + (readParameterJSON @ByteString (json "1")) `shouldBe` (Left ("Expected String" :: ByteString)) + + describe "Int" $ do + it "should accept numeric input" $ do + (readParameter @Int "1337") `shouldBe` (Right 1337) + + it "should accept negative numbers" $ do + (readParameter @Int "-1337") `shouldBe` (Right (-1337)) + + it "should accept JSON numerics " $ do + (readParameterJSON @Int (json "1337")) `shouldBe` (Right 1337) + + it "should fail on other JSON input " $ do + (readParameterJSON @Int (json "true")) `shouldBe` (Left "Expected Int") + + describe "Integer" $ do + it "should accept numeric input" $ do + (readParameter @Integer "1337") `shouldBe` (Right 1337) + + it "should accept negative numbers" $ do + (readParameter @Integer "-1337") `shouldBe` (Right (-1337)) + + it "should accept JSON numerics " $ do + (readParameterJSON @Integer (json "1337")) `shouldBe` (Right 1337) + + it "should fail on other JSON input " $ do + (readParameterJSON @Integer (json "true")) `shouldBe` (Left "Expected Integer") + (readParameterJSON @Integer (json "\"1\"")) `shouldBe` (Left "Expected Integer") + + + describe "Double" $ do + it "should accept integer input" $ do + (readParameter @Double "1337") `shouldBe` (Right 1337) + + it "should accept floating point input" $ do + (readParameter @Double "1.2") `shouldBe` (Right 1.2) + (readParameter @Double "1.2345679") `shouldBe` (Right 1.2345679) + + it "should accept JSON integer input" $ do + (readParameterJSON @Double (json "1337")) `shouldBe` (Right 1337) + + it "should accept JSON floating point input" $ do + (readParameterJSON @Double (json "1.2")) `shouldBe` (Right 1.2) + + it "should fail on other JSON input " $ do + (readParameterJSON @Double (json "true")) `shouldBe` (Left "Expected Double") + (readParameterJSON @Double (json "\"1\"")) `shouldBe` (Left "Expected Double") + + describe "Scientific" $ do + it "should accept integer input" $ do + (readParameter @Scientific "1337") `shouldBe` (Right 1337) + + it "should accept floating point input" $ do + (readParameter @Scientific "1.2") `shouldBe` (Right 1.2) + (readParameter @Scientific "1.2345679") `shouldBe` (Right 1.2345679) + let x = "1e-1024" -- -1024 is smaller than minimal Double exponent of -1021 + y = "1.0e-1024" + (show <$> readParameter @Scientific x) `shouldBe` (Right y) + + it "should accept JSON integer input" $ do + (readParameterJSON @Scientific (json "1337")) `shouldBe` (Right 1337) + + it "should accept JSON floating point input" $ do + (readParameterJSON @Scientific (json "1.2")) `shouldBe` (Right 1.2) + + it "should fail on other JSON input " $ do + (readParameterJSON @Scientific (json "true")) `shouldBe` (Left "Expected Scientific") + (readParameterJSON @Scientific (json "\"1\"")) `shouldBe` (Left "Expected Scientific") + + describe "Float" $ do + it "should accept integer input" $ do + (readParameter @Float "1337") `shouldBe` (Right 1337) + + it "should accept floating point input" $ do + (readParameter @Float "1.2") `shouldBe` (Right 1.2) + (readParameter @Float "1.2345679") `shouldBe` (Right 1.2345679) + + it "should accept JSON integer input" $ do + (readParameterJSON @Float (json "1337")) `shouldBe` (Right 1337) + + it "should accept JSON floating point input" $ do + (readParameterJSON @Float (json "1.2")) `shouldBe` (Right 1.2) + + it "should fail on other JSON input " $ do + (readParameterJSON @Float (json "true")) `shouldBe` (Left "Expected Float") + (readParameterJSON @Float (json "\"1\"")) `shouldBe` (Left "Expected Float") + + describe "Text" $ do + it "should handle text input" $ do + (readParameter @Text "test") `shouldBe` (Right "test") + + it "should handle JSON strings" $ do + (readParameterJSON @Text (json "\"test\"")) `shouldBe` (Right ("test")) + + it "should fail on other JSON input" $ do + (readParameterJSON @Text (json "1")) `shouldBe` (Left ("Expected String")) + + describe "CSV" $ do + it "should handle empty input" $ do + (readParameter @[Int] "") `shouldBe` (Right []) + + it "should handle a single value" $ do + (readParameter @[Int] "1") `shouldBe` (Right [1]) + + it "should handle comma separated values" $ do + (readParameter @[Int] "1,2,3") `shouldBe` (Right [1,2,3]) + + it "should fail if a single value is invalid" $ do + (readParameter @[Int] "1,a,3") `shouldBe` (Left "has to be an integer") + + it "should handle JSON arrays" $ do + (readParameterJSON @[Int] (json "[1,2,3]")) `shouldBe` (Right [1,2,3]) + + it "should fail on JSON input that is not an array" $ do + (readParameterJSON @[Int] (json "true")) `shouldBe` (Left "Expected Array") + + describe "Bool" $ do + it "should accept 'on' as True" $ do + (readParameter @Bool "on") `shouldBe` (Right True) + + it "should accept 'true' as True" $ do + (readParameter @Bool "true") `shouldBe` (Right True) + (readParameter @Bool "TruE") `shouldBe` (Right True) + + it "should accept everything else as false input" $ do + (readParameter @Bool "off") `shouldBe` (Right False) + (readParameter @Bool "false") `shouldBe` (Right False) + (readParameter @Bool "invalid") `shouldBe` (Right False) + + describe "UUID" $ do + it "should accept UUID values" $ do + (readParameter @UUID "6188329c-6bad-47f6-800c-2fd19ce0b2df") `shouldBe` (Right (uuid "6188329c-6bad-47f6-800c-2fd19ce0b2df")) + (readParameter @UUID "a020ba17-a94e-453f-9414-c54aa30caa54") `shouldBe` (Right (uuid "a020ba17-a94e-453f-9414-c54aa30caa54")) + + it "should fail on invalid values" $ do + (readParameter @UUID "not a uuid") `shouldBe` (Left "has to be an UUID") + + it "should accept JSON UUIDs" $ do + (readParameterJSON @UUID (json "\"6188329c-6bad-47f6-800c-2fd19ce0b2df\"")) `shouldBe` (Right (uuid "6188329c-6bad-47f6-800c-2fd19ce0b2df")) + + it "should fail on invalid JSON input" $ do + (readParameterJSON @UUID (json "\"not a uuid\"")) `shouldBe` (Left "Invalid UUID") + (readParameterJSON @UUID (json "false")) `shouldBe` (Left "Expected String with an UUID") + + describe "UTCTime" $ do + it "should accept timestamps" $ do + (tshow (readParameter @UTCTime "2020-11-08T12:03:35Z")) `shouldBe` ("Right 2020-11-08 12:03:35 UTC") + + it "should accept datetime-local format" $ do + (tshow (readParameter @UTCTime "2020-11-08T12:03")) `shouldBe` ("Right 2020-11-08 12:03:00 UTC") + + it "should accept datetime-local format with seconds (no Z)" $ do + (tshow (readParameter @UTCTime "2020-11-08T12:03:35")) `shouldBe` ("Right 2020-11-08 12:03:35 UTC") + + it "should accept fractional seconds without Z" $ do + (tshow (readParameter @UTCTime "2020-11-08T12:03:35.123")) `shouldBe` ("Right 2020-11-08 12:03:35.123 UTC") + + it "should accept dates" $ do + (tshow (readParameter @UTCTime "2020-11-08")) `shouldBe` ("Right 2020-11-08 00:00:00 UTC") + + it "should fail on invalid inputs" $ do + (readParameter @UTCTime "not a timestamp") `shouldBe` (Left "has to be a valid date and time, e.g. 2020-11-08T12:03:35Z or 2020-11-08T12:03") + + it "should accept JSON strings" $ do + (tshow (readParameterJSON @UTCTime (json "\"2020-11-08T12:03:35Z\""))) `shouldBe` ("Right 2020-11-08 12:03:35 UTC") + + it "should accept JSON datetime-local strings" $ do + (tshow (readParameterJSON @UTCTime (json "\"2020-11-08T12:03\""))) `shouldBe` ("Right 2020-11-08 12:03:00 UTC") + + it "should accept JSON datetime-local strings with seconds (no Z)" $ do + (tshow (readParameterJSON @UTCTime (json "\"2020-11-08T12:03:35\""))) `shouldBe` ("Right 2020-11-08 12:03:35 UTC") + + it "should accept fractional seconds without Z via JSON" $ do + (tshow (readParameterJSON @UTCTime (json "\"2020-11-08T12:03:35.123\""))) `shouldBe` ("Right 2020-11-08 12:03:35.123 UTC") + + describe "LocalTime" $ do + it "should accept timestamps" $ do + (tshow (readParameter @LocalTime "2020-11-08T12:03:35Z")) `shouldBe` ("Right 2020-11-08 12:03:35") + + it "should accept datetime-local format" $ do + (tshow (readParameter @LocalTime "2020-11-08T12:03")) `shouldBe` ("Right 2020-11-08 12:03:00") + + it "should accept datetime-local format with seconds (no Z)" $ do + (tshow (readParameter @LocalTime "2020-11-08T12:03:35")) `shouldBe` ("Right 2020-11-08 12:03:35") + + it "should accept fractional seconds without Z" $ do + (tshow (readParameter @LocalTime "2020-11-08T12:03:35.123")) `shouldBe` ("Right 2020-11-08 12:03:35.123") + + it "should accept dates" $ do + (tshow (readParameter @LocalTime "2020-11-08")) `shouldBe` ("Right 2020-11-08 00:00:00") + + it "should fail on invalid inputs" $ do + (readParameter @LocalTime "not a timestamp") `shouldBe` (Left "has to be a valid date and time, e.g. 2020-11-08T12:03:35Z or 2020-11-08T12:03") + + it "should accept JSON strings" $ do + (tshow (readParameterJSON @LocalTime (json "\"2020-11-08T12:03:35Z\""))) `shouldBe` ("Right 2020-11-08 12:03:35") + + it "should accept JSON datetime-local strings" $ do + (tshow (readParameterJSON @LocalTime (json "\"2020-11-08T12:03\""))) `shouldBe` ("Right 2020-11-08 12:03:00") + + it "should accept JSON datetime-local strings with seconds (no Z)" $ do + (tshow (readParameterJSON @LocalTime (json "\"2020-11-08T12:03:35\""))) `shouldBe` ("Right 2020-11-08 12:03:35") + + it "should accept fractional seconds without Z via JSON" $ do + (tshow (readParameterJSON @LocalTime (json "\"2020-11-08T12:03:35.123\""))) `shouldBe` ("Right 2020-11-08 12:03:35.123") + + describe "Day" $ do + it "should accept dates" $ do + (tshow (readParameter @Day "2020-11-08")) `shouldBe` ("Right 2020-11-08") + + it "should fail on invalid inputs" $ do + (readParameter @Day "not a timestamp") `shouldBe` (Left "has to be a date, e.g. 2020-11-08") + + it "should accept JSON strings" $ do + (tshow (readParameterJSON @Day (json "\"2020-11-08\""))) `shouldBe` ("Right 2020-11-08") + + describe "TimeOfDay" $ do + it "should accept time values" $ do + (tshow (readParameter @TimeOfDay "12:00:00")) `shouldBe` ("Right 12:00:00") + + it "should fail on invalid inputs" $ do + (readParameter @TimeOfDay "not a time") `shouldBe` (Left "has to be time in the format hh:mm:ss") + (readParameter @TimeOfDay "25:00:00") `shouldBe` (Left "has to be time in the format hh:mm:ss") + + it "should accept JSON strings" $ do + (tshow (readParameterJSON @TimeOfDay (json "\"13:37:00\""))) `shouldBe` ("Right 13:37:00") + + describe "Maybe" $ do + it "should accept values" $ do + (readParameter @(Maybe Int) "1") `shouldBe` (Right (Just 1)) + (readParameter @(Maybe Text) "hello") `shouldBe` (Right (Just "hello")) + + 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 "")) + (readParameter @(Maybe ByteString) "") `shouldBe` (Right (Just "")) + + it "should handle empty Bool as False" $ do + (readParameter @(Maybe Bool) "") `shouldBe` (Right (Just False)) + + it "should deal with parser errors" $ do + (readParameter @(Maybe Int) "not a number") `shouldBe` (Left "has to be an integer") + +createRequestWithParams :: [(ByteString, ByteString)] -> (RequestBody, Wai.Request) +createRequestWithParams params = + let + requestBody = FormBody { params, files = [], rawPayload = "" } + request = Wai.defaultRequest { Wai.vault = Vault.insert requestBodyVaultKey requestBody Vault.empty } + in (requestBody, request) + +createRequestWithJson :: Text -> (RequestBody, Wai.Request) +createRequestWithJson params = + let + requestBody = JSONBody { jsonPayload = Just (json params), rawPayload = cs params } + request = Wai.defaultRequest { Wai.vault = Vault.insert requestBodyVaultKey requestBody Vault.empty } + in (requestBody, request) + +json :: Text -> Aeson.Value +json string = + let (Just value) :: Maybe Aeson.Value = Aeson.decode (cs string) + in value + +tshow :: Show a => a -> Text +tshow = Text.pack . show + +uuid :: Text -> UUID +uuid = fromJust . UUID.fromText diff --git a/Wai/Request/Params.hs b/Wai/Request/Params.hs new file mode 100644 --- /dev/null +++ b/Wai/Request/Params.hs @@ -0,0 +1,477 @@ +{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleContexts, AllowAmbiguousTypes, FlexibleInstances, IncoherentInstances, UndecidableInstances, PolyKinds, BlockArguments, DataKinds #-} + +{-| +Module: Wai.Request.Params +Description: Generic parameter parsing for WAI requests +Copyright: (c) digitally induced GmbH, 2020 + +This module provides generic parameter parsing functionality for WAI requests, +supporting both form-encoded and JSON request bodies. + +All functions take explicit 'RequestBody' and 'Request' parameters, making this +module suitable for use outside of IHP. +-} +module Wai.Request.Params +( -- * Reading parameters + param +, paramOrNothing +, paramOrDefault +, paramOrError +, paramList +, paramListOrNothing +, hasParam +, queryOrBodyParam +, allParams + -- * ParamReader typeclass +, ParamReader (..) + -- * Exceptions +, ParamException (..) + -- * Helper functions for custom ParamReader instances +, enumParamReader +, enumParamReaderJSON + -- * Re-exports from Middleware +, RequestBody (..) +, requestBodyVaultKey +) where + +import Prelude +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as Char8 +import Data.Text (Text) +import Data.UUID (UUID) +import qualified Data.UUID as UUID +import Data.Time.Clock (UTCTime) +import Data.Time.LocalTime (LocalTime, TimeOfDay) +import Data.Time.Calendar (Day) +import Data.Time.Format (parseTimeM, defaultTimeLocale, ParseTime) +import Control.Applicative ((<|>)) +import qualified Data.Attoparsec.ByteString.Char8 as Attoparsec +import qualified GHC.Float as Float +import qualified Control.Exception as Exception +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.KeyMap as Aeson +import qualified Data.Aeson.Key as Aeson +import qualified Data.Scientific as Scientific +import qualified Data.Vector as Vector +import qualified Control.DeepSeq as DeepSeq +import Text.Read (readMaybe) +import qualified Data.Either as Either +import qualified Network.Wai as Wai +import Data.Maybe (isJust, fromMaybe, mapMaybe) +import Data.Char (toLower) +import Data.String.Conversions (cs) +import GHC.TypeLits (TypeError, ErrorMessage (Text), Symbol) + +import Wai.Request.Params.Middleware (RequestBody (..), requestBodyVaultKey) + +-- | Returns a query or body parameter from a request. The raw string +-- value is parsed before returning it. So the return value type depends on what +-- you expect (e.g. can be Int, Text, UUID, Bool, some custom type). +-- +-- When the parameter is missing or cannot be parsed, an exception is thrown. +-- Use 'paramOrDefault' when you want to get a default value instead of an exception, +-- or 'paramOrNothing' to get @Nothing@ when the parameter is missing. +-- +-- You can define a custom parameter parser by defining a 'ParamReader' instance. +-- +-- __Example:__ +-- +-- > let maxItems :: Int = param requestBody request "maxItems" +-- +param :: ParamReader valueType => RequestBody -> Wai.Request -> ByteString -> valueType +param !requestBody !request !name = case paramOrError requestBody request name of + Left exception -> Exception.throw exception + Right value -> value +{-# INLINABLE param #-} + +-- | Similar to 'param' but works with multiple params. Useful when working with checkboxes. +-- +-- Given a query like: +-- +-- > ingredients=milk&ingredients=egg +-- +-- This will return @["milk", "egg"]@ for @paramList requestBody request "ingredients"@ +-- +-- When no parameter with the name is given, an empty list is returned. +-- When a value cannot be parsed, this function will fail similar to 'param'. +paramList :: forall valueType. (DeepSeq.NFData valueType, ParamReader valueType) => RequestBody -> Wai.Request -> ByteString -> [valueType] +paramList requestBody request name = + allParams requestBody request + |> filter (\(paramName, _) -> paramName == name) + |> mapMaybe (\(_, paramValue) -> paramValue) + |> map (readParameter @valueType) + |> map (Either.fromRight (error (paramParserErrorMessage name))) + |> DeepSeq.force +{-# INLINABLE paramList #-} + +-- | Similar to 'paramOrNothing' but works with multiple params. This is useful when submitting multiple +-- input fields with the same name, and some may be empty. +-- +-- Given a query like (note the @ingredients@ in the middle that has no value): +-- +-- > ingredients=milk&ingredients&ingredients=egg +-- +-- This will return @[Just "milk", Nothing, Just "egg"]@ +-- +-- When no parameter with the name is given, an empty list is returned. +paramListOrNothing :: forall valueType. (DeepSeq.NFData valueType, ParamReader valueType) => RequestBody -> Wai.Request -> ByteString -> [Maybe valueType] +paramListOrNothing requestBody request name = + allParams requestBody request + |> filter (\(paramName, _) -> paramName == name) + |> mapMaybe (\(_, paramValue) -> paramValue) + |> map (\paramValue -> if paramValue == "" then Left "Empty ByteString" else readParameter @valueType paramValue) + |> map (\value -> case value of + Left _ -> Nothing + Right val -> Just val + ) + |> DeepSeq.force +{-# INLINABLE paramListOrNothing #-} + +paramParserErrorMessage :: ByteString -> String +paramParserErrorMessage name = "param: Parameter '" <> cs name <> "' is invalid" + +-- | Thrown when a parameter is missing when calling 'param' or related functions +data ParamException + = ParamNotFoundException { name :: ByteString } + | ParamCouldNotBeParsedException { name :: ByteString, parserError :: ByteString } + deriving (Show, Eq) + +instance Exception.Exception ParamException where + displayException (ParamNotFoundException { name }) = "param: Parameter '" <> cs name <> "' not found" + displayException (ParamCouldNotBeParsedException { name, parserError }) = "param: Parameter '" <> cs name <> "' could not be parsed, " <> cs parserError + +-- | Returns @True@ when a parameter is given in the request via the query or request body. +-- +-- Use 'paramOrDefault' when you want to use this for providing a default value. +hasParam :: RequestBody -> Wai.Request -> ByteString -> Bool +hasParam requestBody request = isJust . queryOrBodyParam requestBody request +{-# INLINABLE hasParam #-} + +-- | Like 'param', but returns a default value when the parameter is missing instead of throwing +-- an exception. +-- +-- Use 'paramOrNothing' when you want to get @Maybe@. +paramOrDefault :: ParamReader a => RequestBody -> Wai.Request -> a -> ByteString -> a +paramOrDefault requestBody request !defaultValue = fromMaybe defaultValue . paramOrNothing requestBody request +{-# INLINABLE paramOrDefault #-} + +-- | Like 'param', but returns @Nothing@ when the parameter is missing instead of throwing +-- an exception. +-- +-- Use 'paramOrDefault' when you want to deal with a default value. +paramOrNothing :: forall paramType. ParamReader (Maybe paramType) => RequestBody -> Wai.Request -> ByteString -> Maybe paramType +paramOrNothing requestBody request !name = + case paramOrError requestBody request name of + Left ParamNotFoundException {} -> Nothing + Left otherException -> Exception.throw otherException + Right value -> value +{-# INLINABLE paramOrNothing #-} + +-- | Like 'param', but returns @Left "Some error message"@ if the parameter is missing or invalid +paramOrError :: forall paramType. ParamReader paramType => RequestBody -> Wai.Request -> ByteString -> Either ParamException paramType +paramOrError !requestBody !request !name = + case requestBody of + FormBody {} -> case queryOrBodyParam requestBody request name of + Just value -> case readParameter @paramType value of + Left parserError -> Left ParamCouldNotBeParsedException { name, parserError } + Right value' -> Right value' + Nothing -> Left ParamNotFoundException { name } + JSONBody { jsonPayload } -> case jsonPayload of + (Just (Aeson.Object hashMap)) -> case Aeson.lookup (Aeson.fromText $ cs name) hashMap of + 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 #-} + +-- | Returns a parameter without any parsing. Returns @Nothing@ when the parameter is missing. +queryOrBodyParam :: RequestBody -> Wai.Request -> ByteString -> Maybe ByteString +queryOrBodyParam requestBody request !name = join (lookup name (allParams requestBody request)) +{-# INLINABLE queryOrBodyParam #-} + +-- | Returns all params available in the request +allParams :: RequestBody -> Wai.Request -> [(ByteString, Maybe ByteString)] +allParams requestBody request = case requestBody of + FormBody { params, files } -> concat [(map (\(a, b) -> (a, Just b)) params), (Wai.queryString request)] + JSONBody { jsonPayload } -> error "allParams: Not supported for JSON requests" + +-- | Input parser for 'param'. +-- +-- Parses the input bytestring. Returns @Left "some error"@ when there is an error parsing the value. +-- Returns @Right value@ when the parsing succeeded. +class ParamReader a where + -- | The error messages here should be human-readable, as they're visible e.g. in forms + readParameter :: ByteString -> Either ByteString a + -- | The error messages here are directed at other developers, so they can be a bit more technical than 'readParameter' errors + readParameterJSON :: Aeson.Value -> Either ByteString a + readParameterJSON = enumParamReaderJSON + +instance ParamReader ByteString where + {-# INLINABLE readParameter #-} + readParameter byteString = pure byteString + + readParameterJSON (Aeson.String bytestring) = Right (cs bytestring) + readParameterJSON _ = Left "Expected String" + +instance ParamReader Int where + {-# INLINABLE readParameter #-} + readParameter byteString = + case Attoparsec.parseOnly ((Attoparsec.signed Attoparsec.decimal) <* Attoparsec.endOfInput) byteString of + Right value -> Right value + Left _ -> Left "has to be an integer" + + readParameterJSON (Aeson.Number number) = + case Scientific.floatingOrInteger number of + Left _ -> Left "Expected Int" + Right int -> Right int + readParameterJSON _ = Left "Expected Int" + +instance ParamReader Integer where + {-# INLINABLE readParameter #-} + readParameter byteString = + case Attoparsec.parseOnly ((Attoparsec.signed Attoparsec.decimal) <* Attoparsec.endOfInput) byteString of + Right value -> Right value + Left _ -> Left "has to be an integer" + + readParameterJSON (Aeson.Number number) = + case Scientific.floatingOrInteger number of + Left _ -> Left "Expected Integer" + Right integer -> Right integer + readParameterJSON _ = Left "Expected Integer" + +instance ParamReader Double where + {-# INLINABLE readParameter #-} + readParameter byteString = + case Attoparsec.parseOnly (Attoparsec.double <* Attoparsec.endOfInput) byteString of + Right value -> Right value + Left _ -> Left "has to be a number with decimals" + + readParameterJSON (Aeson.Number number) = + case Scientific.floatingOrInteger number of + Left double -> Right double + Right integer -> Right (fromIntegral integer) + readParameterJSON _ = Left "Expected Double" + +instance ParamReader Scientific.Scientific where + {-# INLINABLE readParameter #-} + readParameter byteString = + case Attoparsec.parseOnly (Attoparsec.scientific <* Attoparsec.endOfInput) byteString of + Right value -> Right value + Left _ -> Left "has to be a number with decimals" + + readParameterJSON (Aeson.Number number) = Right number + readParameterJSON _ = Left "Expected Scientific" + +instance ParamReader Float where + {-# INLINABLE readParameter #-} + readParameter byteString = + case Attoparsec.parseOnly (Attoparsec.double <* Attoparsec.endOfInput) byteString of + Right value -> Right (Float.double2Float value) + Left _ -> Left "has to be a number with decimals" + + readParameterJSON (Aeson.Number number) = + case Scientific.floatingOrInteger number of + Left double -> Right double + Right integer -> Right (fromIntegral integer) + readParameterJSON _ = Left "Expected Float" + +instance ParamReader Text where + {-# INLINABLE readParameter #-} + readParameter byteString = pure (cs byteString) + + readParameterJSON (Aeson.String text) = Right text + readParameterJSON _ = Left "Expected String" + +-- | Parses comma separated input like @userIds=1,2,3@ +-- +-- __Example:__ +-- +-- >>> readParameter @[Int] "1,2,3" +-- Right [1,2,3] +instance ParamReader value => ParamReader [value] where + {-# INLINABLE readParameter #-} + readParameter byteString = + byteString + |> Char8.split ',' + |> map readParameter + |> Either.partitionEithers + |> \case + ([], values) -> Right values + ((first:_), _) -> Left first + + readParameterJSON (Aeson.Array values) = + values + |> Vector.toList + |> map readParameterJSON + |> Either.partitionEithers + |> \case + ([], values') -> Right values' + ((first:_), _) -> Left first + readParameterJSON _ = Left "Expected Array" + +-- | Parses a boolean. +-- +-- Html form checkboxes usually use @on@ or @off@ for representation. These +-- values are supported here. +-- +-- - @"on"@ maps to @True@ (HTML checkbox default) +-- - @"true"@ (case-insensitive) maps to @True@ +-- - Everything else maps to @False@ +instance ParamReader Bool where + {-# INLINABLE readParameter #-} + readParameter value + | value == "on" = pure True + | map toLower (cs value) == "true" = pure True + | otherwise = pure False + + readParameterJSON (Aeson.Bool bool) = Right bool + readParameterJSON _ = Left "Expected Bool" + +instance ParamReader UUID where + {-# INLINABLE readParameter #-} + readParameter byteString = + case UUID.fromASCIIBytes byteString of + Just uuid -> pure uuid + Nothing -> Left "has to be an UUID" + + readParameterJSON (Aeson.String string) = + case UUID.fromText string of + Just uuid -> pure uuid + Nothing -> Left "Invalid UUID" + readParameterJSON _ = Left "Expected String with an UUID" + +-- | Accepts values such as @2020-11-08T12:03:35Z@, @2020-11-08T12:03:35.123@ (fractional seconds without Z), +-- @2020-11-08T12:03:35@ (seconds without Z), @2020-11-08T12:03@ (datetime-local), or @2020-11-08@ +instance ParamReader UTCTime where + {-# INLINABLE readParameter #-} + readParameter = readDateTimeParameter + readParameterJSON (Aeson.String string) = readParameter (cs string) + readParameterJSON _ = Left "Expected String" + +-- | Accepts values such as @2020-11-08T12:03:35Z@, @2020-11-08T12:03:35.123@ (fractional seconds without Z), +-- @2020-11-08T12:03:35@ (seconds without Z), @2020-11-08T12:03@ (datetime-local), or @2020-11-08@ +instance ParamReader LocalTime where + {-# INLINABLE readParameter #-} + readParameter = readDateTimeParameter + readParameterJSON (Aeson.String string) = readParameter (cs string) + readParameterJSON _ = Left "Expected String" + +-- | Shared parser for 'UTCTime' and 'LocalTime'. Tries ISO 8601 with Z, +-- fractional seconds with Z, fractional seconds without Z, seconds without Z, +-- datetime-local (no seconds), and date-only formats. +readDateTimeParameter :: ParseTime a => ByteString -> Either ByteString a +readDateTimeParameter "" = Left "This field cannot be empty" +readDateTimeParameter byteString = + case parseTimeM True defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" input + <|> parseTimeM True defaultTimeLocale "%Y-%m-%dT%H:%M:%S%Q" input + <|> parseTimeM True defaultTimeLocale "%Y-%m-%dT%H:%M:%S" input + <|> parseTimeM True defaultTimeLocale "%Y-%m-%dT%H:%M" input + <|> parseTimeM True defaultTimeLocale "%Y-%-m-%-d" input + of + Just value -> Right value + Nothing -> Left "has to be a valid date and time, e.g. 2020-11-08T12:03:35Z or 2020-11-08T12:03" + where + input = cs byteString + +-- | Accepts values such as @2020-11-08@ +instance ParamReader Day where + {-# INLINABLE readParameter #-} + readParameter "" = Left "This field cannot be empty" + readParameter byteString = + let + input = (cs byteString) + date = parseTimeM True defaultTimeLocale "%Y-%-m-%-d" input + in case date of + Just value -> Right value + Nothing -> Left "has to be a date, e.g. 2020-11-08" + + readParameterJSON (Aeson.String string) = readParameter (cs string) + readParameterJSON _ = Left "Expected String" + +instance ParamReader TimeOfDay where + {-# INLINABLE readParameter #-} + readParameter "" = Left "This field cannot be empty" + readParameter byteString = + let + input = (cs byteString) + in case readMaybe input of + Just value -> Right value + Nothing -> Left "has to be time in the format hh:mm:ss" + + readParameterJSON (Aeson.String string) = readParameter (cs string) + readParameterJSON _ = Left "Expected String" + +instance ParamReader param => ParamReader (Maybe param) where + {-# INLINABLE readParameter #-} + readParameter paramValue = + case (readParameter paramValue) :: Either ByteString param of + Right value -> Right (Just value) + Left _ | paramValue == "" -> Right Nothing + Left err -> Left err + + readParameterJSON value = + case (readParameterJSON value) :: Either ByteString param of + Right value' -> Right (Just value') + Left _ | value == (Aeson.String "") -> Right Nothing + Left err -> Left err + +-- | Custom error hint when the 'param' is called with do-notation +-- +-- __Example:__ +-- +-- > action Example = do +-- > myParam <- param requestBody request "hello" +-- +-- Now a custom type error will be shown telling the user to use @let myParam = param ...@ instead of do-notation. +instance (TypeError ('Text ("Use 'let x = param requestBody request \"..\"' instead of 'x <- param requestBody request \"..\"'" :: Symbol))) => ParamReader (IO param) where + readParameter _ = error "Unreachable" + readParameterJSON _ = error "Unreachable" + +-- | Can be used as a default implementation for 'readParameter' for enum structures +-- +-- __Example:__ +-- +-- > data Color = Yellow | Red | Blue deriving (Enum) +-- > +-- > instance ParamReader Color where +-- > readParameter = enumParamReader @Color inputValueForColor +-- > readParameterJSON = enumParamReaderJSON +-- > +-- > inputValueForColor :: Color -> Text +-- > inputValueForColor = Text.pack . show +-- +-- Note: This requires providing an @inputValue@ function to convert enum values to Text. +enumParamReader :: forall parameter. (Enum parameter, Bounded parameter) => (parameter -> Text) -> ByteString -> Either ByteString parameter +enumParamReader toText string = + case filter (\value -> toText value == string') allEnumValues of + (value:_) -> Right value + [] -> Left "Invalid value" + where + string' = cs string + +-- | Used as a default implementation for 'readParameterJSON' +-- +-- __Example:__ +-- +-- > data Color = Yellow | Red | Blue deriving (Enum) +-- > +-- > instance ParamReader Color where +-- > readParameter = enumParamReader +-- > readParameterJSON = enumParamReaderJSON +enumParamReaderJSON :: forall parameter. (ParamReader parameter) => Aeson.Value -> Either ByteString parameter +enumParamReaderJSON (Aeson.String string) = readParameter (cs string) +enumParamReaderJSON _ = Left "enumParamReaderJSON: Invalid value, expected a string but got something else" + +-- Helpers + +(|>) :: a -> (a -> b) -> b +(|>) a f = f a +infixl 1 |> + +allEnumValues :: forall a. (Enum a, Bounded a) => [a] +allEnumValues = [minBound..maxBound] + +join :: Maybe (Maybe a) -> Maybe a +join (Just (Just x)) = Just x +join _ = Nothing diff --git a/Wai/Request/Params/Middleware.hs b/Wai/Request/Params/Middleware.hs new file mode 100644 --- /dev/null +++ b/Wai/Request/Params/Middleware.hs @@ -0,0 +1,98 @@ +{-| +Module: Wai.Request.Params.Middleware +Description: Middleware that parses the request body and stores it in the request vault +Copyright: (c) digitally induced GmbH, 2024 + +This middleware parses the HTTP request body (either as JSON or form data) +and stores it in the WAI request vault for later access via request.parsedBody. +-} +module Wai.Request.Params.Middleware +( requestBodyMiddleware + -- * RequestBody type +, RequestBody (..) +, requestBodyVaultKey + -- * Type alias +, Respond +) where + +import Prelude +import Network.Wai +import Network.HTTP.Types.Header (hContentType) +import Network.HTTP.Types.Method (methodGet, methodHead, methodDelete, methodOptions) +import qualified Network.Wai.Parse as WaiParse +import qualified Data.Aeson as Aeson +import qualified Data.Vault.Lazy as Vault +import System.IO.Unsafe (unsafePerformIO) +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy as LBS +import Network.Wai.Parse (File, Param) +import Data.IORef (newIORef, atomicModifyIORef') + +-- | Type alias for WAI respond function +type Respond = Response -> IO ResponseReceived + +-- | Represents the parsed HTTP request body +data RequestBody + -- | A form body with URL-encoded or multipart params and files + = FormBody { params :: [Param], files :: [File LBS.ByteString], rawPayload :: LBS.ByteString } + -- | A JSON body + | JSONBody { jsonPayload :: Maybe Aeson.Value, rawPayload :: LBS.ByteString } + +-- | Vault key for storing the parsed request body +requestBodyVaultKey :: Vault.Key RequestBody +requestBodyVaultKey = unsafePerformIO Vault.newKey +{-# NOINLINE requestBodyVaultKey #-} + +-- | Middleware that parses the request body and stores it in the request vault. +-- +-- Takes 'parseRequestBodyOptions' as an explicit parameter to avoid depending +-- on FrameworkConfig being in the vault. +-- +-- After this middleware runs, you can access the parsed body via: +-- +-- > request.parsedBody +-- +requestBodyMiddleware :: WaiParse.ParseRequestBodyOptions -> Middleware +requestBodyMiddleware parseRequestBodyOptions app req respond = do + let method = requestMethod req + requestBody <- if method == methodGet || method == methodHead || method == methodDelete || method == methodOptions + then pure (FormBody [] [] LBS.empty) + else do + -- Always read the raw body first so it's available via getRequestBody + rawPayload <- strictRequestBody req + let contentType = lookup hContentType (requestHeaders req) + case contentType of + Just ct | isJsonContentType ct -> do + let jsonPayload = Aeson.decode rawPayload + pure JSONBody { jsonPayload, rawPayload } + _ -> do + -- WAI's request body is a stream that can only be read + -- once — each getRequestBodyChunk call pops the next + -- chunk and removes it. Since strictRequestBody above + -- already consumed the stream, we create a new body + -- reader backed by an IORef holding the already-read + -- chunks. Each time the form parser calls + -- getRequestBodyChunk, it pops the next chunk from the + -- IORef, effectively "replaying" the original bytes. + -- This is the standard WAI pattern for replaying a + -- consumed request body, see: + -- https://discourse.haskell.org/t/how-to-rebuild-the-request-body-after-reading-it-in-wai-middleware/13150 + ref <- newIORef (LBS.toChunks rawPayload) + let bodyReader = atomicModifyIORef' ref $ \chunks -> case chunks of + [] -> ([], BS.empty) + (c:cs) -> (cs, c) + let req' = setRequestBodyChunks bodyReader req + (params, files) <- WaiParse.parseRequestBodyEx parseRequestBodyOptions WaiParse.lbsBackEnd req' + pure FormBody { params, files, rawPayload } + + let req' = req { vault = Vault.insert requestBodyVaultKey requestBody (vault req) } + app req' respond + +-- | Checks if a Content-Type header value indicates JSON. +-- +-- Matches @application/json@ exactly, or @application/json@ followed by +-- a semicolon and parameters (e.g. @application/json; charset=utf-8@). +isJsonContentType :: BS.ByteString -> Bool +isJsonContentType ct = + ct == BS.pack "application/json" + || BS.pack "application/json;" `BS.isPrefixOf` ct diff --git a/wai-request-params.cabal b/wai-request-params.cabal new file mode 100644 --- /dev/null +++ b/wai-request-params.cabal @@ -0,0 +1,70 @@ +cabal-version: 2.2 +name: wai-request-params +version: 1.0.0 +synopsis: Generic parameter parsing for WAI requests +description: A standalone parameter parsing library for WAI requests, supporting form-encoded and JSON request bodies. +license: MIT +license-file: LICENSE +author: digitally induced GmbH +maintainer: hello@digitallyinduced.com +homepage: https://ihp.digitallyinduced.com/ +bug-reports: https://github.com/digitallyinduced/ihp/issues +copyright: (c) digitally induced GmbH +category: Web +build-type: Simple + +library + default-language: GHC2021 + ghc-options: -Werror=incomplete-patterns -Werror=unused-imports -Werror=missing-fields + hs-source-dirs: . + exposed-modules: + Wai.Request.Params + , Wai.Request.Params.Middleware + build-depends: + base >= 4.17.0 && < 4.22 + , wai + , wai-extra + , aeson + , attoparsec + , bytestring + , text + , uuid + , time + , scientific + , vault + , deepseq + , string-conversions + , vector + , http-types + default-extensions: + OverloadedStrings + , RecordWildCards + , LambdaCase + +test-suite spec + default-language: GHC2021 + type: exitcode-stdio-1.0 + hs-source-dirs: Test + main-is: Spec.hs + other-modules: + Wai.Request.ParamsSpec + , Wai.Request.Params.MiddlewareSpec + build-depends: + base >= 4.17.0 && < 4.22 + , wai-request-params + , hspec + , wai + , wai-extra + , vault + , aeson + , uuid + , text + , bytestring + , scientific + , time + , string-conversions + , http-types + +source-repository head + type: git + location: https://github.com/digitallyinduced/ihp