wai-request-params (empty) → 1.0.0
raw patch · 7 files changed
+1222/−0 lines, 7 filesdep +aesondep +attoparsecdep +base
Dependencies added: aeson, attoparsec, base, bytestring, deepseq, hspec, http-types, scientific, string-conversions, text, time, uuid, vault, vector, wai, wai-extra, wai-request-params
Files
- LICENSE +21/−0
- Test/Spec.hs +1/−0
- Test/Wai/Request/Params/MiddlewareSpec.hs +156/−0
- Test/Wai/Request/ParamsSpec.hs +399/−0
- Wai/Request/Params.hs +477/−0
- Wai/Request/Params/Middleware.hs +98/−0
- wai-request-params.cabal +70/−0
+ LICENSE view
@@ -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.
+ Test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ Test/Wai/Request/Params/MiddlewareSpec.hs view
@@ -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)
+ Test/Wai/Request/ParamsSpec.hs view
@@ -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
+ Wai/Request/Params.hs view
@@ -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
+ Wai/Request/Params/Middleware.hs view
@@ -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
+ wai-request-params.cabal view
@@ -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