WIP

Web/Scotty.hs

@@ -230,8 +230,8 @@ redirect = Trans.redirect
 request :: ActionM Request
 request = Trans.request
 
--- | Get list of uploaded files.
-files :: ActionM [File]
+-- | Get list of in-memory files.
+files :: ActionM [File ByteString]
 files = Trans.files
 
 -- | Get a request header. Header name is case-insensitive.

Web/Scotty/Action.hs

@@ -12,6 +12,7 @@ module Web.Scotty.Action
     , file
     , rawResponse
     , files
+    , filesTemp
     , finish
     , header
     , headers
@@ -253,10 +254,14 @@ finish = E.throw AEFinish
 request :: Monad m => ActionT m Request
 request = ActionT $ envReq <$> ask
 
--- | Get list of uploaded files.
-files :: Monad m => ActionT m [File]
+-- | Get list of in-memory files.
+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 a request header. Header name is case-insensitive.
 header :: (Monad m) => T.Text -> ActionT m (Maybe T.Text)
 header k = do

Web/Scotty/Body.hs

@@ -7,21 +7,28 @@ module Web.Scotty.Body (
   , getFormParamsAndFilesAction
   , getBodyAction
   , getBodyChunkAction
+  -- wai-extra
+  , RequestParseException(..)
   ) where
 
 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.Parse as W (File, Param, getRequestBodyType, BackEnd, lbsBackEnd, sinkRequestBody)
+import qualified Network.Wai.Parse as W (File, Param, getRequestBodyType, BackEnd, lbsBackEnd, tempFileBackEnd, sinkRequestBody, RequestBodyType(..))
 import           Web.Scotty.Action (Param)
-import           Web.Scotty.Internal.Types (BodyInfo(..), BodyChunkBuffer(..), BodyPartiallyStreamed(..), RouteOptions(..))
+import           Web.Scotty.Internal.Types (BodyInfo(..), BodyChunkBuffer(..), BodyPartiallyStreamed(..), RouteOptions(..), File)
 import           Web.Scotty.Util (readRequestBody, strictByteStringToLazyText, decodeUtf8Lenient)
 
+import Web.Scotty.Internal.WaiParseSafe (parseRequestBodyEx, defaultParseRequestBodyOptions, RequestParseException(..), ParseRequestBodyOptions(..))
+
 -- | Make a new BodyInfo with readProgress at 0 and an empty BodyChunkBuffer.
 newBodyInfo :: (MonadIO m) => Request -> m BodyInfo
 newBodyInfo req = liftIO $ do
@@ -36,21 +43,31 @@ cloneBodyInfo (BodyInfo _ chunkBufferVar getChunk) = liftIO $ do
   cleanReadProgressVar <- newMVar 0
   return $ BodyInfo cleanReadProgressVar chunkBufferVar getChunk
 
--- | Get the form params and files from the request. Requires reading the whole body.
-getFormParamsAndFilesAction :: Request -> BodyInfo -> RouteOptions -> IO ([Param], [W.File BL.ByteString])
-getFormParamsAndFilesAction req bodyInfo opts = do
-  let shouldParseBody = isJust $ W.getRequestBodyType req
-
-  if shouldParseBody
-    then
-    do
+-- | 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
+  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
-      let convert (k, v) = (decodeUtf8Lenient k, decodeUtf8Lenient v)
-      return (convert <$> formparams, fs)
-    else
-    return ([], [])
+      return (convertBoth <$> formparams, convertKey <$> fs, [])
+    Just (W.Multipart _) -> do
+      (formparams, fs) <- sinkTempFiles istate prbo req
+      return (convertBoth <$> formparams, [], convertKey <$> fs)
+    Nothing -> do
+      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

@@ -25,6 +25,7 @@ import           Control.Monad.Reader (MonadReader(..), ReaderT, asks, mapReader
 import           Control.Monad.State.Strict (State, StateT(..))
 import           Control.Monad.Trans.Class (MonadTrans(..))
 import           Control.Monad.Trans.Control (MonadBaseControl, MonadTransControl)
+import Control.Monad.Trans.Resource (InternalState)
 
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy.Char8 as LBS8 (ByteString)
@@ -42,6 +43,8 @@ import           Network.Wai.Parse (FileInfo)
 
 import UnliftIO.Exception (Handler(..), catch, catches)
 
+import Web.Scotty.Internal.WaiParseSafe (ParseRequestBodyOptions(..), defaultParseRequestBodyOptions)
+
 
 --------------------- Options -----------------------
 data Options = Options { verbose :: Int -- ^ 0 = silent, 1(def) = startup banner
@@ -94,13 +97,15 @@ data ScottyState m =
                 , routes :: [BodyInfo -> Middleware m]
                 , handler :: Maybe (ErrorHandler m)
                 , routeOptions :: RouteOptions
+                , parseRequestBodyOpts :: ParseRequestBodyOptions
+                , resourcetState :: InternalState
                 }
 
-instance Default (ScottyState m) where
-  def = defaultScottyState
+-- instance Default (ScottyState m) where
+--   def = defaultScottyState
 
-defaultScottyState :: ScottyState m
-defaultScottyState = ScottyState [] [] Nothing defaultRouteOptions
+defaultScottyState :: InternalState -> ScottyState m
+defaultScottyState = ScottyState [] [] Nothing defaultRouteOptions defaultParseRequestBodyOptions
 
 addMiddleware :: Wai.Middleware -> ScottyState m -> ScottyState m
 addMiddleware m s@(ScottyState {middlewares = ms}) = s { middlewares = m:ms }
@@ -162,15 +167,17 @@ instance E.Exception ScottyException
 ------------------ Scotty Actions -------------------
 type Param = (Text, Text)
 
-type File = (Text, FileInfo LBS8.ByteString)
+type File t = (Text, FileInfo t)
+-- type FileTemp = (Text, FileInfo FilePath)
 
 data ActionEnv = Env { envReq       :: Request
                      , envPathParams :: [Param]
                      , envFormParams    :: [Param]
                      , envQueryParams :: [Param]
                      , envBody      :: IO LBS8.ByteString
                      , envBodyChunk :: IO BS.ByteString
-                     , envFiles     :: [File]
+                     , envFiles     :: [File LBS8.ByteString]
+                     , envTempFiles :: [File FilePath]
                      , envResponse :: TVar ScottyResponse
                      }
 

Web/Scotty/Internal/WaiParseSafe.hs

@@ -3,10 +3,10 @@
 {-# language OverloadedStrings #-}
 -- | This module is a "safe" variant of Network.Wai.Parse from wai-extras, to work around the usage of 'error' in the original.
 --
--- It is meant to disappear once my patch to wai-extra https://github.com/yesodweb/wai/pull/964 is merged and the safe version of 'conduitRequestBodyEx' is made available upstream.
+-- It is meant to disappear once my patch to wai-extra https://github.com/yesodweb/wai/pull/964 is merged and the safe version of 'parseRequestBodyEx' is made available upstream.
 module Web.Scotty.Internal.WaiParseSafe where
 
-import Network.Wai.Parse (fileContent, File, FileInfo(..), Param, BackEnd, RequestBodyType(..))
+import Network.Wai.Parse (getRequestBodyType, fileContent, File, FileInfo(..), Param, BackEnd, RequestBodyType(..))
 
 import qualified Control.Exception as E
 import Control.Monad (guard, unless, when)
@@ -21,6 +21,7 @@ import Data.Maybe (catMaybes, fromMaybe)
 import Data.Typeable
 import Data.Word (Word8)
 import qualified Network.HTTP.Types as H
+import Network.Wai
 import Network.Wai.Handler.Warp (InvalidRequest(..))
 
 
@@ -54,6 +55,40 @@ defaultParseRequestBodyOptions = ParseRequestBodyOptions
     , prboMaxHeaderLines=Just 32
     , prboMaxHeaderLineLength=Just 8190 }
 
+-- | Parse the body of an HTTP request, limit resource usage.
+-- The HTTP body can contain both parameters and files.
+-- This function will return a list of key,value pairs
+-- for all parameters, and a list of key,a pairs
+-- for filenames. The a depends on the used backend that
+-- is responsible for storing the received files.
+--
+-- since wai-extra-3.1.15 : throws 'RequestParseException' if something goes wrong
+parseRequestBodyEx :: ParseRequestBodyOptions
+                   -> BackEnd y
+                   -> Request
+                   -> IO ([Param], [File y])
+parseRequestBodyEx o s r =
+    case getRequestBodyType r of
+        Nothing -> return ([], [])
+        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
+                  -> IO S.ByteString
+                  -> IO ([Param], [File y])
+sinkRequestBodyEx o s r body = do
+    ref <- newIORef ([], [])
+    let add x = atomicModifyIORef ref $ \(y, z) ->
+            case x of
+                Left y'  -> ((y':y, z), ())
+                Right z' -> ((y, z':z), ())
+    conduitRequestBodyEx o s r body add
+    bimap reverse reverse <$> readIORef ref
+
 conduitRequestBodyEx :: ParseRequestBodyOptions
                      -> BackEnd y
                      -> RequestBodyType

Web/Scotty/Route.hs

@@ -10,6 +10,7 @@ import Control.Concurrent.STM (newTVarIO)
 import           Control.Monad.IO.Class (MonadIO(..))
 import UnliftIO (MonadUnliftIO(..))
 import qualified Control.Monad.State as MS
+import Control.Monad.Trans.Resource (InternalState)
 
 import           Data.String (fromString)
 import qualified Data.Text as T
@@ -23,6 +24,7 @@ import           Web.Scotty.Action
 import           Web.Scotty.Internal.Types (RoutePattern(..), RouteOptions, ActionEnv(..), ActionT, ScottyState(..), ScottyT(..), ErrorHandler, Middleware, BodyInfo, handler, addRoute, defaultScottyResponse)
 import           Web.Scotty.Util (decodeUtf8Lenient)
 import Web.Scotty.Body (cloneBodyInfo, getBodyAction, getBodyChunkAction, getFormParamsAndFilesAction)
+import Web.Scotty.Internal.WaiParseSafe (ParseRequestBodyOptions(..))
 
 {- $setup
 >>> :{
@@ -78,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 (routeOptions s) (handler s) Nothing pat action) s
+matchAny pat action = ScottyT $ MS.modify $ \s -> addRoute (route (resourcetState s) (parseRequestBodyOpts s) (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.
@@ -101,12 +103,15 @@ let server = S.get "/foo/:bar" (S.pathParam "bar" >>= S.text)
 "something"
 -}
 addroute :: (MonadUnliftIO m) => StdMethod -> RoutePattern -> ActionT m () -> ScottyT m ()
-addroute method pat action = ScottyT $ MS.modify $ \s -> addRoute (route (routeOptions s) (handler s) (Just method) pat action) s
+addroute method pat action = ScottyT $ MS.modify $ \s ->
+  addRoute (route (resourcetState s) (parseRequestBodyOpts s) (routeOptions s) (handler s) (Just method) pat action) s
 
 route :: (MonadUnliftIO m) =>
-         RouteOptions
+         InternalState
+      -> ParseRequestBodyOptions
+      -> RouteOptions
       -> Maybe (ErrorHandler m) -> Maybe StdMethod -> RoutePattern -> ActionT m () -> BodyInfo -> Middleware m
-route opts h method pat action bodyInfo app req =
+route istate prbo 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'
@@ -124,7 +129,7 @@ route opts h method pat action bodyInfo app req =
               -- without messing up the state of the original BodyInfo.
               clonedBodyInfo <- cloneBodyInfo bodyInfo
 
-              env <- mkEnv clonedBodyInfo req captures opts
+              env <- mkEnv istate prbo clonedBodyInfo req captures opts
               res <- runAction h env action
               maybe tryNext return res
             Nothing -> tryNext
@@ -153,14 +158,20 @@ path :: Request -> T.Text
 path = T.cons '/' . T.intercalate "/" . pathInfo
 
 -- | Parse the request and construct the initial 'ActionEnv' with a default 200 OK response
-mkEnv :: MonadIO m => BodyInfo -> Request -> [Param] -> RouteOptions -> m ActionEnv
-mkEnv bodyInfo req captureps opts = do
-  (formps, bodyFiles) <- liftIO $ getFormParamsAndFilesAction req bodyInfo opts
+mkEnv :: MonadIO m =>
+         InternalState
+      -> ParseRequestBodyOptions
+      -> BodyInfo
+      -> Request
+      -> [Param]
+      -> RouteOptions
+      -> m ActionEnv
+mkEnv istate prbo bodyInfo req captureps opts = do
+  (formps, bodyFiles, tempFiles) <- liftIO $ getFormParamsAndFilesAction istate prbo req bodyInfo opts
   let
     queryps = parseEncodedParams $ queryString req
-    bodyFiles' = [ (decodeUtf8Lenient k, fi) | (k,fi) <- bodyFiles ]
   responseInit <- liftIO $ newTVarIO defaultScottyResponse
-  return $ Env req captureps formps queryps (getBodyAction bodyInfo opts) (getBodyChunkAction bodyInfo) bodyFiles' responseInit
+  return $ Env req captureps formps queryps (getBodyAction bodyInfo opts) (getBodyChunkAction bodyInfo) bodyFiles tempFiles responseInit
 
 
 parseEncodedParams :: Query -> [Param]

Web/Scotty/Trans.hs

@@ -66,6 +66,7 @@ import Control.Exception (assert)
 import Control.Monad (when)
 import Control.Monad.State.Strict (execState, modify)
 import Control.Monad.IO.Class
+import Control.Monad.Trans.Resource (runResourceT, withInternalState, InternalState)
 
 import Network.HTTP.Types (status404, status413, status500)
 import Network.Socket (Socket)
@@ -79,25 +80,26 @@ import Web.Scotty.Trans.Lazy as Lazy
 import Web.Scotty.Util (socketDescription)
 import Web.Scotty.Body (newBodyInfo)
 
+import UnliftIO (MonadUnliftIO(..))
 import UnliftIO.Exception (Handler(..), catch)
 
 
 -- | Run a scotty application using the warp server.
 -- NB: scotty p === scottyT p id
-scottyT :: (Monad m, MonadIO n)
-        => Port
-        -> (m W.Response -> IO W.Response) -- ^ Run monad 'm' into 'IO', called at each action.
-        -> ScottyT m ()
-        -> n ()
+-- scottyT :: (Monad m, MonadIO n)
+--         => Port
+--         -> (m W.Response -> IO W.Response) -- ^ Run monad 'm' into 'IO', called at each action.
+--         -> ScottyT m ()
+--         -> n ()
 scottyT p = scottyOptsT $ defaultOptions { settings = setPort p (settings defaultOptions) }
 
 -- | Run a scotty application using the warp server, passing extra options.
 -- NB: scottyOpts opts === scottyOptsT opts id
-scottyOptsT :: (Monad m, MonadIO n)
-            => Options
-            -> (m W.Response -> IO W.Response) -- ^ Run monad 'm' into 'IO', called at each action.
-            -> ScottyT m ()
-            -> n ()
+-- scottyOptsT :: (Monad m, MonadIO n)
+--             => Options
+--             -> (m W.Response -> IO W.Response) -- ^ Run monad 'm' into 'IO', called at each action.
+--             -> ScottyT m ()
+--             -> n ()
 scottyOptsT opts runActionToIO s = do
     when (verbose opts > 0) $
         liftIO $ putStrLn $ "Setting phasers to stun... (port " ++ show (getPort (settings opts)) ++ ") (ctrl-c to quit)"
@@ -106,12 +108,12 @@ scottyOptsT opts runActionToIO s = do
 -- | Run a scotty application using the warp server, passing extra options, and
 -- listening on the provided socket.
 -- NB: scottySocket opts sock === scottySocketT opts sock id
-scottySocketT :: (Monad m, MonadIO n)
-              => Options
-              -> Socket
-              -> (m W.Response -> IO W.Response)
-              -> ScottyT m ()
-              -> n ()
+-- scottySocketT :: (Monad m, MonadIO n)
+--               => Options
+--               -> Socket
+--               -> (m W.Response -> IO W.Response)
+--               -> ScottyT m ()
+--               -> n ()
 scottySocketT opts sock runActionToIO s = do
     when (verbose opts > 0) $ do
         d <- liftIO $ socketDescription sock
@@ -121,12 +123,12 @@ scottySocketT opts sock runActionToIO s = do
 -- | Turn a scotty application into a WAI 'Application', which can be
 -- run with any WAI handler.
 -- NB: scottyApp === scottyAppT id
-scottyAppT :: (Monad m, Monad n)
+scottyAppT :: (Monad m, MonadUnliftIO n)
            => (m W.Response -> IO W.Response) -- ^ Run monad 'm' into 'IO', called at each action.
            -> ScottyT m ()
            -> n W.Application
-scottyAppT runActionToIO defs = do
-    let s = execState (runS defs) defaultScottyState
+scottyAppT runActionToIO defs = runResourceT $ withInternalState $ \istate -> do
+    let s = execState (runS defs) (defaultScottyState istate)
     let rapp req callback = do
           bodyInfo <- newBodyInfo req
           resp <- runActionToIO (applyAll notFoundApp ([midd bodyInfo | midd <- routes s]) req)

changelog.md

@@ -8,6 +8,7 @@
 * Accept text-2.1 (#364)
 
 
+
 ## 0.21 [2023.12.17]
 ### New
 * add `getResponseHeaders`, `getResponseStatus`, `getResponseContent` (#214)