URL-decoding query and form parameters + decoding FormData

Web/Scotty.hs

@@ -25,7 +25,7 @@
     , 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.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)
@@ -156,14 +157,14 @@
 --
 -- Uncaught exceptions turn into HTTP 500 responses.
 raise :: Text -> ActionM a
 raise = Trans.raise
 {-# DEPRECATED raise "Throw an exception instead" #-}
 
 -- | Throw a 'StatusError' exception that has an associated HTTP error code and can be caught with 'catch'.
 --
 -- Uncaught exceptions turn into HTTP responses corresponding to the given status.
 raiseStatus :: Status -> Text -> ActionM a
 raiseStatus = Trans.raiseStatus
 {-# DEPRECATED raiseStatus "Use status, text, and finish instead" #-}
 
 -- | Throw an exception which can be caught within the scope of the current Action with 'catch'.
@@ -213,7 +214,7 @@
 --
 -- > raise JustKidding `catch` (\msg -> text msg)
 rescue :: E.Exception e => ActionM a -> (e -> ActionM a) -> ActionM a
 rescue = Trans.rescue
 {-# DEPRECATED rescue "Use catch instead" #-}
 
 -- | Like 'liftIO', but catch any IO exceptions and turn them into Scotty exceptions.
@@ -276,6 +277,12 @@
 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 @@
     , liftAndCatchIO
     , json
     , jsonData
+    , formData
     , next
     , param
     , pathParam
@@ -79,7 +80,9 @@
 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,8 +104,9 @@
 
 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)
 import           System.IO (hPutStrLn, stderr)
 
@@ -132,7 +136,7 @@
 -- | Catches 'StatusError' and produces an appropriate HTTP response.
 statusErrorHandler :: MonadIO m => ErrorHandler m
 statusErrorHandler = Handler $ \case
   StatusError s e -> do
     status s
     let code = T.pack $ show $ statusCode s
     let msg = decodeUtf8Lenient $ statusMessage s
@@ -168,6 +172,12 @@
       , "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"]
@@ -217,7 +227,7 @@
 --
 -- Uncaught exceptions turn into HTTP responses corresponding to the given status.
 raiseStatus :: Monad m => Status -> T.Text -> ActionT m a
 raiseStatus s = E.throw . StatusError s
 {-# DEPRECATED raiseStatus "Use status, text, and finish instead" #-}
 
 -- | Throw an exception which can be caught within the scope of the current Action with 'catch'.
@@ -354,6 +364,27 @@
         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

@@ -22,7 +22,7 @@
 import           Control.Monad.IO.Class (MonadIO(..))
 import UnliftIO (MonadUnliftIO(..))
 import           Control.Monad.Reader (MonadReader(..), ReaderT, asks, mapReaderT)
 import           Control.Monad.State.Strict (State, StateT(..))
 import           Control.Monad.Trans.Class (MonadTrans(..))
 import           Control.Monad.Trans.Control (MonadBaseControl, MonadTransControl)
 import qualified Control.Monad.Trans.Resource as RT (InternalState, InvalidAccess)
@@ -147,6 +147,7 @@
   = 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 @@
     , 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
@@ -133,7 +133,7 @@
            -> (m W.Response -> IO W.Response) -- ^ Run monad 'm' into 'IO', called at each action.
            -> ScottyT m ()
            -> n W.Application
 scottyAppT options runActionToIO defs = do
     let s = execState (runReaderT (runS defs) options) defaultScottyState
     let rapp req callback = do
           bodyInfo <- newBodyInfo req

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