From d0ab65b41d058f1aed83c855dedc55bae24045fe Mon Sep 17 00:00:00 2001 From: Marco Zocca Date: Fri, 29 Dec 2023 20:10:04 +0100 Subject: [PATCH] wip --- Web/Scotty.hs | 16 +++++++++++++++- Web/Scotty/Action.hs | 19 ++++++++++++++----- Web/Scotty/Trans.hs | 5 ++++- examples/upload.hs | 13 +++++++++---- 4 files changed, 42 insertions(+), 11 deletions(-) diff --git a/Web/Scotty.hs b/Web/Scotty.hs index e574e881..54b35d2c 100644 --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -25,12 +25,14 @@ module Web.Scotty , capture, regex, function, literal -- ** Accessing the Request and its fields , request, header, headers, body, bodyReader - , jsonData, files + , jsonData -- ** Accessing Path, Form and Query Parameters , param, params , pathParam, captureParam, formParam, queryParam , pathParamMaybe, captureParamMaybe, formParamMaybe, queryParamMaybe , pathParams, captureParams, formParams, queryParams + -- *** Files + , files, filesOpts, Trans.ParseRequestBodyOptions, Trans.defaultParseRequestBodyOptions -- ** Modifying the Response and Redirecting , status, addHeader, setHeader, redirect -- ** Setting Response Body @@ -234,6 +236,14 @@ request = Trans.request files :: ActionM [File ByteString] files = Trans.files +-- | Get list of temp files and form parameters decoded from multipart payloads. +-- +-- NB the temp files are deleted when the continuation exits +filesOpts :: Trans.ParseRequestBodyOptions + -> ([Param] -> [File FilePath] -> ActionM a) -- ^ temp files validation, storage etc + -> ActionM a +filesOpts = Trans.filesOpts + -- | Get a request header. Header name is case-insensitive. header :: Text -> ActionM (Maybe Text) header = Trans.header @@ -243,6 +253,8 @@ headers :: ActionM [(Text, Text)] headers = Trans.headers -- | Get the request body. +-- +-- NB: loads the entire request body in memory body :: ActionM ByteString body = Trans.body @@ -253,6 +265,8 @@ bodyReader :: ActionM (IO BS.ByteString) bodyReader = Trans.bodyReader -- | Parse the request body as a JSON object and return it. Raises an exception if parse is unsuccessful. +-- +-- NB: uses 'body' internally jsonData :: FromJSON a => ActionM a jsonData = Trans.jsonData diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs index 98fd57be..87212776 100644 --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -12,7 +12,8 @@ module Web.Scotty.Action , file , rawResponse , files - -- , filesTemp + , filesOpts + , ParseRequestBodyOptions, defaultParseRequestBodyOptions , finish , header , headers @@ -72,6 +73,7 @@ import Control.Monad.Trans.Resource (InternalState, withInternalState, runResour import Control.Concurrent.MVar import qualified Data.Aeson as A +import Data.Bifunctor (bimap, first) import Data.Bool (bool) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as BL @@ -98,7 +100,7 @@ import qualified Network.Wai.Parse as W (File, Param, getRequestBodyType, BackEn import Numeric.Natural import Web.Scotty.Internal.Types -import Web.Scotty.Internal.WaiParseSafe (ParseRequestBodyOptions, RequestParseException(..), parseRequestBodyEx) +import Web.Scotty.Internal.WaiParseSafe (ParseRequestBodyOptions, defaultParseRequestBodyOptions, RequestParseException(..), parseRequestBodyEx) import Web.Scotty.Util (mkResponse, addIfNotPresent, add, replace, lazyTextToStrictByteString, decodeUtf8Lenient) import UnliftIO.Exception (Handler(..), catch, catches, throwIO) @@ -284,13 +286,16 @@ files = ActionT $ envFiles <$> ask -- 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 + -> ([Param] -> [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 + (ps, fs) <- liftIO $ sinkTempFiles istate prbo req + let + params' = bimap decodeUtf8Lenient decodeUtf8Lenient <$> ps + files' = first decodeUtf8Lenient <$> fs + io params' files' sinkTempFiles :: InternalState -> ParseRequestBodyOptions @@ -315,6 +320,8 @@ headers = do | (k,v) <- hs ] -- | Get the request body. +-- +-- NB This loads the whole request body in memory at once. body :: (MonadIO m) => ActionT m BL.ByteString body = ActionT ask >>= (liftIO . envBody) @@ -333,6 +340,8 @@ bodyReader = ActionT $ envBodyChunk <$> ask -- 422 Unprocessable Entity. -- -- These status codes are as per https://www.restapitutorial.com/httpstatuscodes.html. +-- +-- NB : Internally this uses 'body'. jsonData :: (A.FromJSON a, MonadIO m) => ActionT m a jsonData = do b <- body diff --git a/Web/Scotty/Trans.hs b/Web/Scotty/Trans.hs index e4f47840..fcc0bcfc 100644 --- a/Web/Scotty/Trans.hs +++ b/Web/Scotty/Trans.hs @@ -30,12 +30,15 @@ module Web.Scotty.Trans , capture, regex, function, literal -- ** Accessing the Request and its fields , request, Lazy.header, Lazy.headers, body, bodyReader - , jsonData, files + , jsonData + -- ** Accessing Path, Form and Query Parameters , param, params , pathParam, captureParam, formParam, queryParam , pathParamMaybe, captureParamMaybe, formParamMaybe, queryParamMaybe , pathParams, captureParams, formParams, queryParams + -- *** Files + , files, filesOpts, ParseRequestBodyOptions, defaultParseRequestBodyOptions -- ** Modifying the Response and Redirecting , status, Lazy.addHeader, Lazy.setHeader, Lazy.redirect -- ** Setting Response Body diff --git a/examples/upload.hs b/examples/upload.hs index 06f184a1..8765d42d 100644 --- a/examples/upload.hs +++ b/examples/upload.hs @@ -4,11 +4,12 @@ module Main (main) where import Web.Scotty import Control.Monad.IO.Class +import Data.Foldable (for_) import qualified Data.Text.Lazy as TL import Network.Wai.Middleware.RequestLogger import Network.Wai.Middleware.Static -import Network.Wai.Parse +import Network.Wai.Parse (fileName, fileContent) import qualified Text.Blaze.Html5 as H import Text.Blaze.Html5.Attributes @@ -35,10 +36,14 @@ main = scotty 3000 $ do H.input H.! type_ "submit" post "/upload" $ do - fs <- files - let fs' = [ (fieldName, BS.unpack (fileName fi), fileContent fi) | (fieldName,fi) <- fs ] + filesOpts defaultParseRequestBodyOptions $ \_ fs -> do + let + -- fs' = [ (fieldName, BS.unpack (fileName fi), fileContent fi) | (fieldName,fi) <- fs ] + fpaths = [fileContent fi | (_, fi) <- fs] -- write the files to disk, so they will be served by the static middleware - liftIO $ sequence_ [ B.writeFile ("uploads" fn) fc | (_,fn,fc) <- fs' ] + -- liftIO $ sequence_ [ B.writeFile ("uploads" fn) fc | (_,fn,fc) <- fs' ] + for_ fpaths $ \fpath -> do + fc <- B.readFile fpath -- generate list of links to the files just uploaded html $ mconcat [ mconcat [ TL.fromStrict fName , ": "