defer form parsing

Web/Scotty/Action.hs

@@ -68,16 +68,17 @@ import           Control.Monad              (when)
 import           Control.Monad.IO.Class     (MonadIO(..))
 import UnliftIO (MonadUnliftIO(..))
 import           Control.Monad.Reader       (MonadReader(..), ReaderT(..))
-import Control.Monad.Trans.Resource (InternalState, withInternalState, runResourceT)
+import Control.Monad.Trans.Resource (withInternalState, runResourceT)
 
 import           Control.Concurrent.MVar
 
 import qualified Data.Aeson                 as A
-import Data.Bifunctor (bimap, first)
+-- import Data.Bifunctor (bimap, first)
 import Data.Bool (bool)
 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           Data.Int
 import           Data.Maybe                 (maybeToList)
 import qualified Data.Text                  as T
@@ -95,7 +96,7 @@ import           Network.HTTP.Types.Status
 #endif
 import           Network.Wai (Request, Response, StreamingBody, Application, requestHeaders)
 import Network.Wai.Handler.Warp (InvalidRequest(..))
-import qualified Network.Wai.Parse as W (File, Param, getRequestBodyType, BackEnd, lbsBackEnd, tempFileBackEnd, sinkRequestBody, RequestBodyType(..))
+import qualified Network.Wai.Parse as W (FileInfo(..), File, Param, getRequestBodyType, BackEnd, lbsBackEnd, tempFileBackEnd, sinkRequestBody, RequestBodyType(..))
 
 import           Numeric.Natural
 
@@ -177,13 +178,13 @@ scottyExceptionHandler = Handler $ \case
   FailedToParseParameter k v e -> do
     status status400
     text $ T.unwords [ "Failed to parse parameter", k, v, ":", e]
-  -- WarpRequestException we -> case we of
-  --   RequestHeaderFieldsTooLarge -> do
-  --     status status413
-  --   _ -> status status200 -- TODO XXXXXXXXXXX
-  -- WaiRequestParseException _ -> do
-  --   status status413
-  --   text "wai-extra says no" -- TODO XXXXXXXXXXXX
+  WarpRequestException we -> case we of
+    RequestHeaderFieldsTooLarge -> do
+      status status413
+    _ -> status status200 -- TODO XXXXXXXXXXX
+  WaiRequestParseException _ -> do
+    status status413
+    text "wai-extra says no" -- TODO XXXXXXXXXXXX
 
 -- | Uncaught exceptions turn into HTTP 500 Server Error codes
 someExceptionHandler :: MonadIO m => ErrorHandler m
@@ -268,31 +269,28 @@ finish = E.throw AEFinish
 request :: Monad m => ActionT m Request
 request = ActionT $ envReq <$> ask
 
--- | Get list of uploaded (in-memory) files.
-files :: Monad m => ActionT m [File BL.ByteString]
-files = ActionT $ envFiles <$> ask
+-- | Get list of uploaded files.
+--
+-- NB! Loads all file contents in memory
+files :: MonadIO m => ActionT m [File BL.ByteString]
+files = do
+  (_, fs) <- formParamsAndFiles
+  for fs (\(fname, f) -> do
+                   bs <- liftIO $ BL.readFile (W.fileContent f)
+                   pure (fname, f{ W.fileContent = bs})
+                   )
+{-# DEPRECATED files "This function is retained for backward compatibility, but loading all file contents in memory is not a good idea, please use filesOpts instead" #-}
 
 -- | Get list of uploaded temp files and form parameters decoded from multipart payloads.
 --
--- NB the temp files are deleted when the continuation exits
+-- NB the temp files are deleted when the continuation exits.
 filesOpts :: MonadUnliftIO m =>
              ParseRequestBodyOptions
-          -> ([Param] -> [File FilePath] -> ActionT m b) -- ^ temp files validation, storage etc
-          -> ActionT m b
-filesOpts prbo io = do
-  req <- getRequest
-  runResourceT $ withInternalState $ \istate -> do
-    (ps, fs) <- liftIO $ sinkTempFiles istate prbo req
-    let
-      params' = bimap decodeUtf8Lenient decodeUtf8Lenient <$> ps
-      files' = first decodeUtf8Lenient <$> fs
-    io params' files'
-
-sinkTempFiles :: InternalState
-              -> ParseRequestBodyOptions
-              -> Request
-              -> IO ([W.Param], [W.File FilePath])
-sinkTempFiles istate o = parseRequestBodyEx o (W.tempFileBackEnd istate)
+          -> ([Param] -> [File FilePath] -> ActionT m a) -- ^ temp files validation, storage etc
+          -> ActionT m a
+filesOpts prbo io = runResourceT $ withInternalState $ \istate -> do
+  (ps, fs) <- formParamsAndFilesWith istate prbo
+  io ps fs
 
 
 
@@ -385,8 +383,14 @@ pathParam k = do
 -- * This function raises a code 400 also if the parameter is found, but 'parseParam' fails to parse to the correct type.
 --
 -- /Since: 0.20/
-formParam :: (Parsable a, MonadIO m) => T.Text -> ActionT m a
-formParam = paramWith FormFieldNotFound envFormParams
+formParam :: (MonadIO m, Parsable b) => T.Text -> ActionT m b
+formParam k = do
+  (ps, _) <- formParamsAndFiles
+  case lookup k ps of
+    Nothing -> throwIO $ FormFieldNotFound k
+    Just v -> case parseParam $ TL.fromStrict v of
+      Left e -> throwIO $ FailedToParseParameter k v (TL.toStrict e)
+      Right a -> pure a
 
 -- | Look up a query parameter.
 --
@@ -421,8 +425,14 @@ captureParamMaybe = paramWithMaybe envPathParams
 -- NB : Doesn't throw exceptions, so developers must 'raiseStatus' or 'throw' to signal something went wrong.
 --
 -- /Since: 0.21/
-formParamMaybe :: (Parsable a, Monad m) => T.Text -> ActionT m (Maybe a)
-formParamMaybe = paramWithMaybe envFormParams
+formParamMaybe :: (MonadIO m, Parsable a) =>
+                  T.Text -> ActionT m (Maybe a)
+formParamMaybe k = do
+  (ps, _) <- formParamsAndFiles
+  case lookup k ps of
+    Nothing -> pure Nothing
+    Just v -> either (const $ pure Nothing) (pure . Just) $ parseParam $ TL.fromStrict v
+
 
 -- | Look up a query parameter. Returns 'Nothing' if the parameter is not found or cannot be parsed at the right type.
 --
@@ -483,8 +493,9 @@ captureParams :: Monad m => ActionT m [Param]
 captureParams = paramsWith envPathParams
 
 -- | Get form parameters
-formParams :: Monad m => ActionT m [Param]
-formParams = paramsWith envFormParams
+formParams :: MonadIO m => ActionT m [Param]
+-- formParams = paramsWith envFormParams
+formParams = fst <$> formParamsAndFiles
 -- | Get query parameters
 queryParams :: Monad m => ActionT m [Param]
 queryParams = paramsWith envQueryParams
@@ -493,8 +504,9 @@ paramsWith :: Monad m => (ActionEnv -> a) -> ActionT m a
 paramsWith f = ActionT (f <$> ask)
 
 {-# DEPRECATED getParams "(#204) Not a good idea to treat all parameters identically" #-}
+-- | Returns path and query parameters as a single list
 getParams :: ActionEnv -> [Param]
-getParams e = envPathParams e <> envFormParams e <> envQueryParams e
+getParams e = envPathParams e <> [] <> envQueryParams e
 
 
 -- === access the fields of the Response being constructed

Web/Scotty/Body.hs

@@ -26,11 +26,10 @@ import qualified Network.Wai.Parse as W (File, Param, getRequestBodyType, BackEn
 import UnliftIO (MonadUnliftIO(..))
 import UnliftIO.Exception (Handler(..), catch, catches, throwIO)
 
-import           Web.Scotty.Action (Param)
-import           Web.Scotty.Internal.Types (BodyInfo(..), BodyChunkBuffer(..), BodyPartiallyStreamed(..), RouteOptions(..), File, ScottyException(..))
+import           Web.Scotty.Internal.Types (BodyInfo(..), BodyChunkBuffer(..), BodyPartiallyStreamed(..), RouteOptions(..), File, ScottyException(..), Param)
 import           Web.Scotty.Util (readRequestBody, decodeUtf8Lenient)
 
-import Web.Scotty.Internal.WaiParseSafe (parseRequestBodyEx, RequestParseException(..), ParseRequestBodyOptions(..))
+import Web.Scotty.Internal.WaiParseSafe (sinkRequestBodyEx, parseRequestBodyEx, RequestParseException(..), ParseRequestBodyOptions(..))
 
 -- | Make a new BodyInfo with readProgress at 0 and an empty BodyChunkBuffer.
 newBodyInfo :: (MonadIO m) => Request -> m BodyInfo
@@ -47,21 +46,53 @@ cloneBodyInfo (BodyInfo _ chunkBufferVar getChunk) = liftIO $ do
   return $ BodyInfo cleanReadProgressVar chunkBufferVar getChunk
 
 -- | Get the form params and files from the request.
--- Only reads the request body if the request is URL-encoded (= has 'application/x-www-form-urlencoded' MIME type)
-getFormParamsAndFilesAction :: Request -> BodyInfo -> RouteOptions -> IO ([Param], [File BL.ByteString])
-getFormParamsAndFilesAction req bodyInfo opts = do
+--
+-- NB : catches exceptions from 'warp' and 'wai-extra' and wraps them into 'ScottyException'
+getFormParamsAndFilesAction ::
+  InternalState
+  -> ParseRequestBodyOptions
+  -> Request -- ^ only used for its body type
+  -> BodyInfo -- ^ the request body contents are read from here
+  -> RouteOptions
+  -> IO ([Param], [File FilePath])
+getFormParamsAndFilesAction istate prbo req bodyInfo opts = do
   let
     bs2t = decodeUtf8Lenient
     convertBoth = bimap bs2t bs2t
     convertKey = first bs2t
-  case W.getRequestBodyType req of
-      Just W.UrlEncoded -> do
-        bs <- getBodyAction bodyInfo opts
-        let wholeBody = BL.toChunks bs
-        (formparams, fs) <- parseRequestBody wholeBody W.lbsBackEnd req -- NB this loads the whole body into memory
-        return (convertBoth <$> formparams, convertKey <$> fs)
-      _ -> return ([], [])
+  bs <- getBodyAction bodyInfo opts
+  let
+    wholeBody = BL.toChunks bs
+  (formparams, fs) <- parseRequestBodyExBS istate prbo wholeBody (W.getRequestBodyType req) `catches` handleWaiParseSafeExceptions
+  return (convertBoth <$> formparams, convertKey <$> fs)
+
+-- | Wrap exceptions from upstream libraries into 'ScottyException'
+handleWaiParseSafeExceptions :: MonadIO m => [Handler m a]
+handleWaiParseSafeExceptions = [h1, h2]
+  where
+    h1 = Handler (\ (e :: RequestParseException ) -> throwIO $ WaiRequestParseException e)
+    h2 = Handler (\(e :: Warp.InvalidRequest) -> throwIO $ WarpRequestException e)
 
+-- | Adapted from wai-extra's Network.Wai.Parse, modified to accept body as list of Bytestrings.
+-- Reason: WAI's requestBody is an IO action that returns the body as chunks. Once read,
+-- they can't be read again. We read them into a lazy Bytestring, so Scotty user can get
+-- the raw body, even if they also want to call wai-extra's parsing routines.
+parseRequestBodyExBS :: MonadIO m =>
+                        InternalState
+                     -> ParseRequestBodyOptions
+                     -> [B.ByteString]
+                     -> Maybe W.RequestBodyType
+                     -> m ([W.Param], [W.File FilePath])
+parseRequestBodyExBS istate o bl rty =
+    case rty of
+        Nothing -> return ([], [])
+        Just rbt -> do
+            mvar <- liftIO $ newMVar bl -- MVar is a bit of a hack so we don't have to inline
+                                        -- large portions of Network.Wai.Parse
+            let provider = modifyMVar mvar $ \bsold -> case bsold of
+                                                []     -> return ([], B.empty)
+                                                (b:bs) -> return (bs, b)
+            liftIO $ sinkRequestBodyEx o (W.tempFileBackEnd istate) rbt provider
 
 
 -- | Retrieve the entire body, using the cached chunks in the BodyInfo and reading any other
@@ -89,25 +120,5 @@ getBodyChunkAction (BodyInfo readProgress chunkBufferVar getChunk) =
          | hasFinished -> return (bcb, (index, mempty))
          | otherwise -> do
              newChunk <- getChunk
-             return (BodyChunkBuffer (newChunk == mempty) (chunks ++ [newChunk]), (index + 1, newChunk))
+             return (BodyChunkBuffer (B.null newChunk) (chunks ++ [newChunk]), (index + 1, newChunk))
 
-
--- Stolen from wai-extra's Network.Wai.Parse, modified to accept body as list of Bytestrings.
--- Reason: WAI's requestBody is an IO action that returns the body as chunks. Once read,
--- they can't be read again. We read them into a lazy Bytestring, so Scotty user can get
--- the raw body, even if they also want to call wai-extra's parsing routines.
-parseRequestBody :: MonadIO m
-                 => [B.ByteString]
-                 -> W.BackEnd y
-                 -> Request
-                 -> m ([W.Param], [W.File y])
-parseRequestBody bl s r =
-    case W.getRequestBodyType r of
-        Nothing -> return ([], [])
-        Just rbt -> do
-            mvar <- liftIO $ newMVar bl -- MVar is a bit of a hack so we don't have to inline
-                                        -- large portions of Network.Wai.Parse
-            let provider = modifyMVar mvar $ \bsold -> case bsold of
-                                                []     -> return ([], B.empty)
-                                                (b:bs) -> return (bs, b)
-            liftIO $ W.sinkRequestBody s rbt provider

Web/Scotty/Internal/Types.hs

@@ -98,12 +98,13 @@ data ScottyState m =
                 , handler :: Maybe (ErrorHandler m)
                 , routeOptions :: RouteOptions
                 , parseRequestBodyOpts :: WPS.ParseRequestBodyOptions
+                , resourcetState :: InternalState
                 }
 
 -- instance Default (ScottyState m) where
 --   def = defaultScottyState
 
-defaultScottyState :: ScottyState m
+defaultScottyState :: InternalState -> ScottyState m
 defaultScottyState = ScottyState [] [] Nothing defaultRouteOptions WPS.defaultParseRequestBodyOptions
 
 addMiddleware :: Wai.Middleware -> ScottyState m -> ScottyState m
@@ -171,18 +172,31 @@ type Param = (Text, Text)
 -- | Type parameter @t@ is the file content. Could be @()@ when not needed or a @FilePath@ for temp files instead.
 type File t = (Text, FileInfo t)
 
-data ActionEnv = Env { envReq       :: Request
+data ActionEnv = Env { envInternalState :: InternalState
+                     , envParseRequestBodyOpts :: WPS.ParseRequestBodyOptions
+                     , envReq       :: Request
                      , envPathParams :: [Param]
-                     , envFormParams    :: [Param]
                      , envQueryParams :: [Param]
+                     , envFormDataAction :: InternalState -> WPS.ParseRequestBodyOptions -> IO ([Param], [File FilePath])
                      , envBody      :: IO LBS8.ByteString
                      , envBodyChunk :: IO BS.ByteString
-                     , envFiles     :: [File LBS8.ByteString]
                      , envResponse :: TVar ScottyResponse
                      }
 
-getRequest :: Monad m => ActionT m Request
-getRequest = ActionT $ asks envReq
+formParamsAndFiles :: MonadIO m => ActionT m ([Param], [File FilePath])
+formParamsAndFiles = do
+  istate <- ActionT $ asks envInternalState
+  prbo <- ActionT $ asks envParseRequestBodyOpts
+  formParamsAndFilesWith istate prbo
+
+
+formParamsAndFilesWith :: MonadIO m =>
+                          InternalState
+                       -> WPS.ParseRequestBodyOptions
+                       -> ActionT m ([Param], [File FilePath])
+formParamsAndFilesWith istate prbo = do
+  act <- ActionT $ asks envFormDataAction
+  liftIO $ act istate prbo
 
 getResponse :: MonadIO m => ActionEnv -> m ScottyResponse
 getResponse ae = liftIO $ readTVarIO (envResponse ae)
@@ -231,6 +245,10 @@ defaultScottyResponse = SR status200 [] (ContentBuilder mempty)
 newtype ActionT m a = ActionT { runAM :: ReaderT ActionEnv m a }
   deriving newtype (Functor, Applicative, Monad, MonadIO, MonadTrans, MonadThrow, MonadCatch, MonadBase b, MonadBaseControl b, MonadTransControl, MonadUnliftIO)
 
+withActionEnv :: Monad m =>
+                 (ActionEnv -> ActionEnv) -> ActionT m a -> ActionT m a
+withActionEnv f (ActionT r) = ActionT $ local f r
+
 instance MonadReader r m => MonadReader r (ActionT m) where
   ask = ActionT $ lift ask
   local f = ActionT . mapReaderT (local f) . runAM

Web/Scotty/Internal/WaiParseSafe.hs

@@ -73,8 +73,6 @@ parseRequestBodyEx o s r =
         Just rbt -> sinkRequestBodyEx o s rbt (getRequestBodyChunk r)
 
 -- | Throws 'RequestParseException' if something goes wrong
---
--- since wai-extra-3.1.15 : throws 'RequestParseException' if something goes wrong
 sinkRequestBodyEx :: ParseRequestBodyOptions
                   -> BackEnd y
                   -> RequestBodyType