traverse multipart req bodies only on demand

Web/Scotty/Action.hs

@@ -12,7 +12,7 @@ module Web.Scotty.Action
     , file
     , rawResponse
     , files
-    , filesTemp
+    -- , filesTemp
     , finish
     , header
     , headers
@@ -67,6 +67,7 @@ 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.Concurrent.MVar
 
@@ -91,15 +92,19 @@ import           Network.HTTP.Types
 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           Numeric.Natural
 
 import           Web.Scotty.Internal.Types
+import           Web.Scotty.Internal.WaiParseSafe (ParseRequestBodyOptions, RequestParseException(..), parseRequestBodyEx)
 import           Web.Scotty.Util (mkResponse, addIfNotPresent, add, replace, lazyTextToStrictByteString, decodeUtf8Lenient)
 import           UnliftIO.Exception (Handler(..), catch, catches, throwIO)
 
 import Network.Wai.Internal (ResponseReceived(..))
 
+
 -- | Evaluate a route, catch all exceptions (user-defined ones, internal and all remaining, in this order)
 --   and construct the 'Response'
 --
@@ -114,7 +119,9 @@ runAction mh env action = do
   ok <- flip runReaderT env $ runAM $ tryNext $ action `catches` concat
     [ [actionErrorHandler]
     , maybeToList mh
-    , [statusErrorHandler, scottyExceptionHandler, someExceptionHandler]
+    , [statusErrorHandler
+      , scottyExceptionHandler
+      , someExceptionHandler]
     ]
   res <- getResponse env
   return $ bool Nothing (Just $ mkResponse res) ok
@@ -170,12 +177,26 @@ 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
 
 -- | Uncaught exceptions turn into HTTP 500 Server Error codes
 someExceptionHandler :: MonadIO m => ErrorHandler m
 someExceptionHandler = Handler $ \case
   (_ :: E.SomeException) -> status status500
 
+-- warpInvalidRequestHandler :: MonadIO m => ErrorHandler m
+-- warpInvalidRequestHandler = Handler $ \case
+--   RequestHeaderFieldsTooLarge -> do
+--     status status413
+--   _ -> do
+--     status status200 -- TODO XXXXXXXXXXXXXX
+
 -- | Throw a "500 Server Error" 'StatusError', which can be caught with 'catch'.
 --
 -- Uncaught exceptions turn into HTTP 500 responses.
@@ -258,9 +279,26 @@ request = ActionT $ envReq <$> ask
 files :: Monad m => ActionT m [File BL.ByteString]
 files = ActionT $ envFiles <$> ask
 
--- | Get list of temp files decoded from multipart payloads.
-filesTemp :: Monad m => ActionT m [File FilePath]
-filesTemp = ActionT $ envTempFiles <$> ask
+-- | Get list of temp files and form parameters decoded from multipart payloads.
+--
+-- NB the temp files are deleted when the continuation exits
+filesOpts :: MonadUnliftIO m =>
+             ParseRequestBodyOptions
+          -> (([W.Param], [W.File FilePath]) -> ActionT m b) -- ^ temp files validation, storage etc
+          -> ActionT m b
+filesOpts prbo io = do
+  req <- getRequest
+  runResourceT $ withInternalState $ \istate -> do
+    out <- liftIO $ sinkTempFiles istate prbo req
+    io out
+
+sinkTempFiles :: InternalState
+              -> ParseRequestBodyOptions
+              -> Request
+              -> IO ([W.Param], [W.File FilePath])
+sinkTempFiles istate o = parseRequestBodyEx o (W.tempFileBackEnd istate)
+
+
 
 -- | Get a request header. Header name is case-insensitive.
 header :: (Monad m) => T.Text -> ActionT m (Maybe T.Text)
@@ -316,7 +354,7 @@ param :: (Parsable a, MonadIO m) => T.Text -> ActionT m a
 param k = do
     val <- ActionT $ (lookup k . getParams) <$> ask
     case val of
-        Nothing -> raiseStatus status500 $ "Param: " <> k <> " not found!" -- FIXME
+        Nothing -> raiseStatus status500 $ "Param: " <> k <> " not found!"
         Just v  -> either (const next) return $ parseParam (TL.fromStrict v)
 {-# DEPRECATED param "(#204) Not a good idea to treat all parameters identically. Use captureParam, formParam and queryParam instead. "#-}
 

Web/Scotty/Body.hs

@@ -1,5 +1,6 @@
-{-# LANGUAGE FlexibleContexts, FlexibleInstances, RecordWildCards,
-             OverloadedStrings, MultiWayIf #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# language OverloadedStrings #-}
+{-# language ScopedTypeVariables #-}
 module Web.Scotty.Body (
   newBodyInfo,
   cloneBodyInfo
@@ -13,21 +14,23 @@ module Web.Scotty.Body (
 
 import           Control.Concurrent.MVar
 import           Control.Monad.IO.Class
-import           Control.Exception (catch)
 import Control.Monad.Trans.Resource (InternalState)
 import Data.Bifunctor (first, bimap)
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as BL
-import           Data.Maybe
 import qualified GHC.Exception as E (throw)
 import           Network.Wai (Request(..), getRequestBodyChunk)
+import qualified Network.Wai.Handler.Warp as Warp (InvalidRequest(..))
 import qualified Network.Wai.Parse as W (File, Param, getRequestBodyType, BackEnd, lbsBackEnd, tempFileBackEnd, sinkRequestBody, RequestBodyType(..))
+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)
-import           Web.Scotty.Util (readRequestBody, strictByteStringToLazyText, decodeUtf8Lenient)
+import           Web.Scotty.Internal.Types (BodyInfo(..), BodyChunkBuffer(..), BodyPartiallyStreamed(..), RouteOptions(..), File, ScottyException(..))
+import           Web.Scotty.Util (readRequestBody, decodeUtf8Lenient)
 
-import Web.Scotty.Internal.WaiParseSafe (parseRequestBodyEx, defaultParseRequestBodyOptions, RequestParseException(..), ParseRequestBodyOptions(..))
+import Web.Scotty.Internal.WaiParseSafe (parseRequestBodyEx, RequestParseException(..), ParseRequestBodyOptions(..))
 
 -- | Make a new BodyInfo with readProgress at 0 and an empty BodyChunkBuffer.
 newBodyInfo :: (MonadIO m) => Request -> m BodyInfo
@@ -44,30 +47,22 @@ cloneBodyInfo (BodyInfo _ chunkBufferVar getChunk) = liftIO $ do
   return $ BodyInfo cleanReadProgressVar chunkBufferVar getChunk
 
 -- | Get the form params and files from the request.
--- Only reads the whole body if the request is URL-encoded
-getFormParamsAndFilesAction :: InternalState -> ParseRequestBodyOptions -> Request -> BodyInfo -> RouteOptions -> IO ([Param], [File BL.ByteString], [File FilePath])
-getFormParamsAndFilesAction istate prbo req bodyInfo opts = do
+-- 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
   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, [])
-    Just (W.Multipart _) -> do
-      (formparams, fs) <- sinkTempFiles istate prbo req
-      return (convertBoth <$> formparams, [], convertKey <$> fs)
-    Nothing -> do
-      return ([], [], [])
+      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 ([], [])
+
 
-sinkTempFiles :: InternalState -- global, to be initialized with the server
-              -> ParseRequestBodyOptions -- " " with user input
-              -> Request
-              -> IO ([W.Param], [W.File FilePath])
-sinkTempFiles istate o = parseRequestBodyEx o (W.tempFileBackEnd istate)
 
 -- | Retrieve the entire body, using the cached chunks in the BodyInfo and reading any other
 -- chunks if they still exist.

Web/Scotty/Internal/Types.hs

@@ -38,17 +38,17 @@ import           Network.HTTP.Types
 
 import           Network.Wai hiding (Middleware, Application)
 import qualified Network.Wai as Wai
-import           Network.Wai.Handler.Warp (Settings, defaultSettings)
+import qualified Network.Wai.Handler.Warp as W (Settings, defaultSettings, InvalidRequest(..))
 import           Network.Wai.Parse (FileInfo)
 
 import UnliftIO.Exception (Handler(..), catch, catches)
 
-import Web.Scotty.Internal.WaiParseSafe (ParseRequestBodyOptions(..), defaultParseRequestBodyOptions)
+import qualified Web.Scotty.Internal.WaiParseSafe as WPS (ParseRequestBodyOptions(..), defaultParseRequestBodyOptions, RequestParseException(..))
 
 
 --------------------- Options -----------------------
 data Options = Options { verbose :: Int -- ^ 0 = silent, 1(def) = startup banner
-                       , settings :: Settings -- ^ Warp 'Settings'
+                       , settings :: W.Settings -- ^ Warp 'Settings'
                                               -- Note: to work around an issue in warp,
                                               -- the default FD cache duration is set to 0
                                               -- so changes to static files are always picked
@@ -61,7 +61,7 @@ instance Default Options where
   def = defaultOptions
 
 defaultOptions :: Options
-defaultOptions = Options 1 defaultSettings
+defaultOptions = Options 1 W.defaultSettings
 
 newtype RouteOptions = RouteOptions { maxRequestBodySize :: Maybe Kilobytes -- max allowed request size in KB
                                     }
@@ -97,15 +97,14 @@ data ScottyState m =
                 , routes :: [BodyInfo -> Middleware m]
                 , handler :: Maybe (ErrorHandler m)
                 , routeOptions :: RouteOptions
-                , parseRequestBodyOpts :: ParseRequestBodyOptions
-                , resourcetState :: InternalState
+                , parseRequestBodyOpts :: WPS.ParseRequestBodyOptions
                 }
 
 -- instance Default (ScottyState m) where
 --   def = defaultScottyState
 
-defaultScottyState :: InternalState -> ScottyState m
-defaultScottyState = ScottyState [] [] Nothing defaultRouteOptions defaultParseRequestBodyOptions
+defaultScottyState :: ScottyState m
+defaultScottyState = ScottyState [] [] Nothing defaultRouteOptions WPS.defaultParseRequestBodyOptions
 
 addMiddleware :: Wai.Middleware -> ScottyState m -> ScottyState m
 addMiddleware m s@(ScottyState {middlewares = ms}) = s { middlewares = m:ms }
@@ -161,14 +160,16 @@ data ScottyException
   | QueryParameterNotFound Text
   | FormFieldNotFound Text
   | FailedToParseParameter Text Text Text
+  | WarpRequestException W.InvalidRequest -- from warp
+  | WaiRequestParseException WPS.RequestParseException -- from wai-extra
   deriving (Show, Typeable)
 instance E.Exception ScottyException
 
 ------------------ Scotty Actions -------------------
 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)
--- type FileTemp = (Text, FileInfo FilePath)
 
 data ActionEnv = Env { envReq       :: Request
                      , envPathParams :: [Param]
@@ -177,10 +178,12 @@ data ActionEnv = Env { envReq       :: Request
                      , envBody      :: IO LBS8.ByteString
                      , envBodyChunk :: IO BS.ByteString
                      , envFiles     :: [File LBS8.ByteString]
-                     , envTempFiles :: [File FilePath]
                      , envResponse :: TVar ScottyResponse
                      }
 
+getRequest :: Monad m => ActionT m Request
+getRequest = ActionT $ asks envReq
+
 getResponse :: MonadIO m => ActionEnv -> m ScottyResponse
 getResponse ae = liftIO $ readTVarIO (envResponse ae)
 

Web/Scotty/Internal/WaiParseSafe.hs

@@ -9,8 +9,8 @@ module Web.Scotty.Internal.WaiParseSafe where
 import Network.Wai.Parse (getRequestBodyType, fileContent, File, FileInfo(..), Param, BackEnd, RequestBodyType(..))
 
 import qualified Control.Exception as E
-import Control.Monad (guard, unless, when)
-import Control.Monad.Trans.Resource (InternalState, allocate, register, release, runInternalState)
+import Control.Monad (unless, when)
+-- import Control.Monad.Trans.Resource (InternalState, allocate, register, release, runInternalState)
 import Data.Bifunctor (bimap)
 import qualified Data.ByteString as S
 import qualified Data.ByteString.Char8 as S8
@@ -160,18 +160,18 @@ takeLines''
     -> Maybe Int
     -> Source
     -> IO [S.ByteString]
-takeLines'' lines lineLength maxLines src = do
+takeLines'' lns lineLength maxLines src = do
     case maxLines of
         Just maxLines' ->
-            when (length lines > maxLines') $
-                E.throwIO $ TooManyHeaderLines (length lines)
+            when (length lns > maxLines') $
+                E.throwIO $ TooManyHeaderLines (length lns)
         Nothing -> return ()
     res <- takeLine lineLength src
     case res of
-        Nothing -> return lines
+        Nothing -> return lns
         Just l
-            | S.null l -> return lines
-            | otherwise -> takeLines'' (l:lines) lineLength maxLines src
+            | S.null l -> return lns
+            | otherwise -> takeLines'' (l:lns) lineLength maxLines src
 
 
 

Web/Scotty/Route.hs

@@ -80,7 +80,7 @@ options = addroute OPTIONS
 
 -- | Add a route that matches regardless of the HTTP verb.
 matchAny :: (MonadUnliftIO m) => RoutePattern -> ActionT m () -> ScottyT m ()
-matchAny pat action = ScottyT $ MS.modify $ \s -> addRoute (route (resourcetState s) (parseRequestBodyOpts s) (routeOptions s) (handler s) Nothing pat action) s
+matchAny pat action = ScottyT $ MS.modify $ \s -> addRoute (route (routeOptions s) (handler s) Nothing pat action) s
 
 -- | Specify an action to take if nothing else is found. Note: this _always_ matches,
 -- so should generally be the last route specified.
@@ -104,14 +104,12 @@ let server = S.get "/foo/:bar" (S.pathParam "bar" >>= S.text)
 -}
 addroute :: (MonadUnliftIO m) => StdMethod -> RoutePattern -> ActionT m () -> ScottyT m ()
 addroute method pat action = ScottyT $ MS.modify $ \s ->
-  addRoute (route (resourcetState s) (parseRequestBodyOpts s) (routeOptions s) (handler s) (Just method) pat action) s
+  addRoute (route (routeOptions s) (handler s) (Just method) pat action) s
 
 route :: (MonadUnliftIO m) =>
-         InternalState
-      -> ParseRequestBodyOptions
-      -> RouteOptions
+         RouteOptions
       -> Maybe (ErrorHandler m) -> Maybe StdMethod -> RoutePattern -> ActionT m () -> BodyInfo -> Middleware m
-route istate prbo opts h method pat action bodyInfo app req =
+route opts h method pat action bodyInfo app req =
   let tryNext = app req
       -- We match all methods in the case where 'method' is 'Nothing'.
       -- See https://github.com/scotty-web/scotty/issues/196 and 'matchAny'
@@ -129,7 +127,7 @@ route istate prbo opts h method pat action bodyInfo app req =
               -- without messing up the state of the original BodyInfo.
               clonedBodyInfo <- cloneBodyInfo bodyInfo
 
-              env <- mkEnv istate prbo clonedBodyInfo req captures opts
+              env <- mkEnv clonedBodyInfo req captures opts
               res <- runAction h env action
               maybe tryNext return res
             Nothing -> tryNext
@@ -159,19 +157,17 @@ path = T.cons '/' . T.intercalate "/" . pathInfo
 
 -- | Parse the request and construct the initial 'ActionEnv' with a default 200 OK response
 mkEnv :: MonadIO m =>
-         InternalState
-      -> ParseRequestBodyOptions
-      -> BodyInfo
+         BodyInfo
       -> Request
       -> [Param]
       -> RouteOptions
       -> m ActionEnv
-mkEnv istate prbo bodyInfo req captureps opts = do
-  (formps, bodyFiles, tempFiles) <- liftIO $ getFormParamsAndFilesAction istate prbo req bodyInfo opts
+mkEnv bodyInfo req captureps opts = do
+  (formps, bodyFiles) <- liftIO $ getFormParamsAndFilesAction req bodyInfo opts
   let
     queryps = parseEncodedParams $ queryString req
   responseInit <- liftIO $ newTVarIO defaultScottyResponse
-  return $ Env req captureps formps queryps (getBodyAction bodyInfo opts) (getBodyChunkAction bodyInfo) bodyFiles tempFiles responseInit
+  return $ Env req captureps formps queryps (getBodyAction bodyInfo opts) (getBodyChunkAction bodyInfo) bodyFiles responseInit
 
 
 parseEncodedParams :: Query -> [Param]