diff --git a/Web/Scotty.hs b/Web/Scotty.hs index 414eb3f..cfb0729 100644 --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -25,7 +25,7 @@ module Web.Scotty , capture, regex, function, literal -- ** Accessing the Request and its fields , request, header, headers, body, bodyReader - , jsonData + , jsonData, formData -- ** Accessing Path, Form and Query Parameters , param, params , pathParam, captureParam, formParam, queryParam @@ -71,6 +71,7 @@ import Network.Wai (Application, Middleware, Request, StreamingBody) import Network.Wai.Handler.Warp (Port) import qualified Network.Wai.Parse as W +import Web.FormUrlEncoded (FromForm) import Web.Scotty.Internal.Types (ScottyT, ActionT, ErrorHandler, Param, RoutePattern, Options, defaultOptions, File, Kilobytes, ScottyState, defaultScottyState, ScottyException, StatusError(..), Content(..)) import UnliftIO.Exception (Handler(..), catch) import Web.Scotty.Cookie (setSimpleCookie,getCookie,getCookies,deleteCookie,makeSimpleCookie) @@ -276,6 +277,12 @@ bodyReader = Trans.bodyReader jsonData :: FromJSON a => ActionM a jsonData = Trans.jsonData +-- | Parse the request body as @x-www-form-urlencoded@ form data and return it. Raises an exception if parse is unsuccessful. +-- +-- NB: uses 'body' internally +formData :: FromForm a => ActionM a +formData = Trans.formData + -- | Get a parameter. First looks in captures, then form data, then query parameters. -- -- * Raises an exception which can be caught by 'catch' if parameter is not found. diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs index e739224..b80a165 100644 --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -23,6 +23,7 @@ module Web.Scotty.Action , liftAndCatchIO , json , jsonData + , formData , next , param , pathParam @@ -79,7 +80,9 @@ import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.CaseInsensitive as CI import Data.Traversable (for) +import qualified Data.HashMap.Strict as HashMap import Data.Int +import Data.List (foldl') import Data.Maybe (maybeToList) import qualified Data.Text as T import Data.Text.Encoding as STE @@ -101,6 +104,7 @@ import qualified Network.Wai.Parse as W (FileInfo(..), ParseRequestBodyOptions, import Numeric.Natural +import Web.FormUrlEncoded (Form(..), FromForm(..)) import Web.Scotty.Internal.Types import Web.Scotty.Util (mkResponse, addIfNotPresent, add, replace, lazyTextToStrictByteString, decodeUtf8Lenient) import UnliftIO.Exception (Handler(..), catch, catches, throwIO) @@ -168,6 +172,12 @@ scottyExceptionHandler = Handler $ \case , "Body: " <> bs , "Error: " <> BL.fromStrict (encodeUtf8 err) ] + MalformedForm err -> do + status status400 + raw $ BL.unlines + [ "formData: malformed" + , "Error: " <> BL.fromStrict (encodeUtf8 err) + ] PathParameterNotFound k -> do status status500 text $ T.unwords [ "Path parameter", k, "not found"] @@ -354,6 +364,27 @@ jsonData = do A.Error err -> throwIO $ FailedToParseJSON b $ T.pack err A.Success a -> return a +-- | Parse the request body as @x-www-form-urlencoded@ form data and return it. +-- +-- The form is parsed using 'urlDecodeAsForm'. If that returns 'Left', the +-- status is set to 400 and an exception is thrown. +formData :: (FromForm a, MonadUnliftIO m) => ActionT m a +formData = do + form <- paramListToForm <$> formParams + case fromForm form of + Left err -> throwIO $ MalformedForm err + Right value -> return value + where + -- This rather contrived implementation uses cons and reverse to avoid + -- quadratic complexity when constructing a Form from a list of Param. + -- It's equivalent to using HashMap.insertWith (++) which does have + -- quadratic complexity due to appending at the end of list. + paramListToForm :: [Param] -> Form + paramListToForm = Form . fmap reverse . foldl' (\f (k, v) -> HashMap.alter (prependValue v) k f) HashMap.empty + + prependValue :: a -> Maybe [a] -> Maybe [a] + prependValue v = Just . maybe [v] (v :) + -- | Get a parameter. First looks in captures, then form data, then query parameters. -- -- * Raises an exception which can be caught by 'catch' if parameter is not found. diff --git a/Web/Scotty/Internal/Types.hs b/Web/Scotty/Internal/Types.hs index d0e3571..588c0df 100644 --- a/Web/Scotty/Internal/Types.hs +++ b/Web/Scotty/Internal/Types.hs @@ -147,6 +147,7 @@ data ScottyException = RequestTooLarge | MalformedJSON LBS8.ByteString T.Text | FailedToParseJSON LBS8.ByteString T.Text + | MalformedForm T.Text | PathParameterNotFound T.Text | QueryParameterNotFound T.Text | FormFieldNotFound T.Text diff --git a/Web/Scotty/Trans.hs b/Web/Scotty/Trans.hs index 8188c0b..159b838 100644 --- a/Web/Scotty/Trans.hs +++ b/Web/Scotty/Trans.hs @@ -30,7 +30,7 @@ module Web.Scotty.Trans , capture, regex, function, literal -- ** Accessing the Request and its fields , request, Lazy.header, Lazy.headers, body, bodyReader - , jsonData + , jsonData, formData -- ** Accessing Path, Form and Query Parameters , param, params diff --git a/changelog.md b/changelog.md index 409c788..80575ef 100644 --- a/changelog.md +++ b/changelog.md @@ -2,6 +2,7 @@ * Fixed cookie example from `Cookie` module documentation. `getCookie` Function would return strict variant of `Text`. Will convert it into lazy variant using `fromStrict`. * Exposed simple functions of `Cookie` module via `Web.Scotty` & `Web.Scotty.Trans`. +* Add tests for URL encoding of query parameters and form parameters. Add `formData` action for decoding `FromForm` instances (#321). ### Breaking changes * Remove dependency on data-default class (#386). We have been exporting constants for default config values since 0.20, and this dependency was simply unnecessary. diff --git a/scotty.cabal b/scotty.cabal index bc85be8..bd311a2 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -77,6 +77,7 @@ Library case-insensitive >= 1.0.0.1 && < 1.3, cookie >= 0.4, exceptions >= 0.7 && < 0.11, + http-api-data >= 0.5.1, http-types >= 0.9.1 && < 0.13, monad-control >= 1.0.0.3 && < 1.1, mtl >= 2.1.2 && < 2.4, @@ -89,6 +90,7 @@ Library transformers >= 0.3.0.0 && < 0.7, transformers-base >= 0.4.1 && < 0.5, unliftio >= 0.2, + unordered-containers >= 0.2.10.0 && < 0.3, wai >= 3.0.0 && < 3.3, wai-extra >= 3.1.14, warp >= 3.0.13 @@ -114,6 +116,7 @@ test-suite spec directory, hspec == 2.*, hspec-wai >= 0.6.3, + http-api-data, http-types, lifted-base, network, diff --git a/test/Web/ScottySpec.hs b/test/Web/ScottySpec.hs index 80217af..0279adf 100644 --- a/test/Web/ScottySpec.hs +++ b/test/Web/ScottySpec.hs @@ -1,26 +1,31 @@ -{-# LANGUAGE OverloadedStrings, CPP, ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings, CPP, ScopedTypeVariables, DeriveGeneric #-} module Web.ScottySpec (main, spec) where import Test.Hspec -import Test.Hspec.Wai (with, request, get, post, put, patch, delete, options, (<:>), shouldRespondWith, postHtmlForm, matchHeaders, matchBody, matchStatus) +import Test.Hspec.Wai (WaiSession, with, request, get, post, put, patch, delete, options, (<:>), shouldRespondWith, matchHeaders, matchBody, matchStatus) import Test.Hspec.Wai.Extra (postMultipartForm, FileMeta(..)) import Control.Applicative import Control.Monad import Data.Char import Data.String +import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TLE import Data.Time (UTCTime(..)) import Data.Time.Calendar (fromGregorian) import Data.Time.Clock (secondsToDiffTime) +import GHC.Generics (Generic) + import Network.HTTP.Types import Network.Wai (Application, Request(queryString), responseLBS) import Network.Wai.Parse (defaultParseRequestBodyOptions) +import Network.Wai.Test (SResponse) import qualified Control.Exception.Lifted as EL import qualified Control.Exception as E +import Web.FormUrlEncoded (FromForm) import Web.Scotty as Scotty hiding (get, post, put, patch, delete, request, options) import qualified Web.Scotty as Scotty import qualified Web.Scotty.Cookie as SC (getCookie, setSimpleCookie, deleteCookie) @@ -30,6 +35,7 @@ import Control.Concurrent.Async (withAsync) import Control.Exception (bracketOnError) import qualified Data.ByteString as BS import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as LBS import Network.Socket (Family(..), SockAddr(..), Socket, SocketOption(..), SocketType(..), bind, close, connect, listen, maxListenQueue, setSocketOption, socket) import Network.Socket.ByteString (send, recv) import System.Directory (removeFile) @@ -41,6 +47,16 @@ main = hspec spec availableMethods :: [StdMethod] availableMethods = [GET, POST, HEAD, PUT, PATCH, DELETE, OPTIONS] +data SearchForm = SearchForm + { sfQuery :: Text + , sfYear :: Int + } deriving (Generic) + +instance FromForm SearchForm where + +postForm :: ByteString -> LBS.ByteString -> WaiSession st SResponse +postForm p = request "POST" p [("Content-Type","application/x-www-form-urlencoded")] + spec :: Spec spec = do let withApp = with . scottyApp @@ -255,6 +271,8 @@ spec = do withApp (Scotty.get "/search" $ queryParam "query" >>= text) $ do it "returns query parameter with given name" $ do get "/search?query=haskell" `shouldRespondWith` "haskell" + it "decodes URL-encoding" $ do + get "/search?query=Kurf%C3%BCrstendamm" `shouldRespondWith` "Kurfürstendamm" withApp (Scotty.matchAny "/search" (do v <- queryParam "query" json (v :: Int) )) $ do @@ -268,16 +286,28 @@ spec = do ) $ do it "catches a ScottyException" $ do get "/search?query=potato" `shouldRespondWith` 200 { matchBody = "z"} + + describe "formData" $ do + withApp (Scotty.post "/search" $ formData >>= (text . sfQuery)) $ do + it "decodes the form" $ do + postForm "/search" "sfQuery=Haskell&sfYear=2024" `shouldRespondWith` "Haskell" + + it "decodes URL-encoding" $ do + postForm "/search" "sfQuery=Kurf%C3%BCrstendamm&sfYear=2024" `shouldRespondWith` "Kurfürstendamm" + + it "returns 400 when the form is malformed" $ do + postForm "/search" "sfQuery=Haskell" `shouldRespondWith` 400 describe "formParam" $ do - let - postForm p bdy = request "POST" p [("Content-Type","application/x-www-form-urlencoded")] bdy withApp (Scotty.post "/search" $ formParam "query" >>= text) $ do it "returns form parameter with given name" $ do postForm "/search" "query=haskell" `shouldRespondWith` "haskell" it "replaces non UTF-8 bytes with Unicode replacement character" $ do postForm "/search" "query=\xe9" `shouldRespondWith` "\xfffd" + + it "decodes URL-encoding" $ do + postForm "/search" "query=Kurf%C3%BCrstendamm" `shouldRespondWith` "Kurfürstendamm" withApp (Scotty.post "/search" (do v <- formParam "query" json (v :: Int))) $ do @@ -354,7 +384,7 @@ spec = do describe "filesOpts" $ do let - postForm = postMultipartForm "/files" "ABC123" [ + postMpForm = postMultipartForm "/files" "ABC123" [ (FMFile "file1.txt", "text/plain;charset=UTF-8", "first_file", "xxx"), (FMFile "file2.txt", "text/plain;charset=UTF-8", "second_file", "yyy") ] @@ -364,13 +394,13 @@ spec = do withApp (Scotty.post "/files" processForm ) $ do it "loads uploaded files in memory" $ do - postForm `shouldRespondWith` 200 { matchBody = "2"} + postMpForm `shouldRespondWith` 200 { matchBody = "2"} context "preserves the body of a POST request even after 'next' (#147)" $ do withApp (do Scotty.post "/files" next Scotty.post "/files" processForm) $ do it "loads uploaded files in memory" $ do - postForm `shouldRespondWith` 200 { matchBody = "2"} + postMpForm `shouldRespondWith` 200 { matchBody = "2"} describe "text" $ do