URL-decoding query and form parameters + decoding FormData (scotty-…

…web#392)

* Add tests for url-decoding in query and form parameters

* Add formData for parsing forms into records

* Also add some tests for formData

* Add test for url-encoding in formData

* move postForm helper function to top level

* implement `formData` through `formParams`

* Add `unordered-containers` dependency for working with `HashMap`

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.

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.

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

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

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.

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,

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