Skip to content

Commit

Permalink
Merge branch 'master' into print-unhandled-exception
Browse files Browse the repository at this point in the history
  • Loading branch information
ocramz authored Mar 9, 2024
2 parents b098474 + 00a8e3b commit 4e24ded
Show file tree
Hide file tree
Showing 17 changed files with 432 additions and 130 deletions.
4 changes: 2 additions & 2 deletions .github/workflows/haskell-ci.yml
Original file line number Diff line number Diff line change
Expand Up @@ -20,8 +20,8 @@ jobs:
- { cabal: "3.10", os: ubuntu-latest, ghc: "9.0.2" }
- { cabal: "3.10", os: ubuntu-latest, ghc: "9.2.8" }
- { cabal: "3.10", os: ubuntu-latest, ghc: "9.4.6" }
- { cabal: "3.10", os: ubuntu-latest, ghc: "9.6.2" }
- { cabal: "3.10", os: ubuntu-latest, ghc: "9.6.3" }
- { cabal: "3.10", os: ubuntu-latest, ghc: "9.6.4" }
- { cabal: "3.10", os: ubuntu-latest, ghc: "9.8.2" }
fail-fast: false

steps:
Expand Down
21 changes: 19 additions & 2 deletions Web/Scotty.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
-- ** Modifying the Response and Redirecting
, status, addHeader, setHeader, redirect
-- ** Setting Response Body
Expand Down Expand Up @@ -65,6 +67,7 @@ import Network.HTTP.Types (Status, StdMethod, ResponseHeaders)
import Network.Socket (Socket)
import Network.Wai (Application, Middleware, Request, StreamingBody)
import Network.Wai.Handler.Warp (Port)
import qualified Network.Wai.Parse as W (defaultParseRequestBodyOptions)

import Web.Scotty.Internal.Types (ScottyT, ActionT, ErrorHandler, Param, RoutePattern, Options, defaultOptions, File, Kilobytes, ScottyState, defaultScottyState, ScottyException, StatusError(..), Content(..))
import UnliftIO.Exception (Handler(..), catch)
Expand Down Expand Up @@ -231,9 +234,19 @@ request :: ActionM Request
request = Trans.request

-- | Get list of uploaded files.
files :: ActionM [File]
--
-- NB: Loads all file contents in memory with options 'W.defaultParseRequestBodyOptions'
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
Expand All @@ -243,6 +256,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

Expand All @@ -253,6 +268,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

Expand Down
80 changes: 70 additions & 10 deletions Web/Scotty/Action.hs
Original file line number Diff line number Diff line change
Expand Up @@ -13,6 +13,8 @@ module Web.Scotty.Action
, file
, rawResponse
, files
, filesOpts
, W.ParseRequestBodyOptions, W.defaultParseRequestBodyOptions
, finish
, header
, headers
Expand Down Expand Up @@ -67,6 +69,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 (withInternalState, runResourceT)

import Control.Concurrent.MVar

Expand All @@ -75,6 +78,7 @@ 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
Expand All @@ -92,6 +96,8 @@ 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 (FileInfo(..), ParseRequestBodyOptions, defaultParseRequestBodyOptions)

import Numeric.Natural

Expand All @@ -102,6 +108,7 @@ import System.IO (hPutStrLn, stderr)

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'
--
Expand Down Expand Up @@ -173,6 +180,18 @@ 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
weo -> do -- FIXME fall-through case on InvalidRequest, it would be nice to return more specific error messages and codes here
status status400
text $ T.unwords ["Request Exception:", T.pack (show weo)]
WaiRequestParseException we -> do
status status413 -- 413 Content Too Large https://developer.mozilla.org/en-US/docs/Web/HTTP/Status/413
text $ T.unwords ["wai-extra Exception:", T.pack (show we)]
ResourceTException rte -> do
status status500
text $ T.unwords ["resourcet Exception:", T.pack (show rte)]

-- | Uncaught exceptions turn into HTTP 500 Server Error codes
someExceptionHandler :: MonadIO m => Options -> ErrorHandler m
Expand All @@ -184,6 +203,7 @@ someExceptionHandler Options{verbose} =
"Unhandled exception of " <> show (typeOf e) <> ": " <> show e
status status500


-- | Throw a "500 Server Error" 'StatusError', which can be caught with 'catch'.
--
-- Uncaught exceptions turn into HTTP 500 responses.
Expand Down Expand Up @@ -263,8 +283,29 @@ request :: Monad m => ActionT m Request
request = ActionT $ envReq <$> ask

-- | Get list of uploaded files.
files :: Monad m => ActionT m [File]
files = ActionT $ envFiles <$> ask
--
-- NB: Loads all file contents in memory with options 'W.defaultParseRequestBodyOptions'
files :: MonadUnliftIO m => ActionT m [File BL.ByteString]
files = runResourceT $ withInternalState $ \istate -> do
(_, fs) <- formParamsAndFilesWith istate W.defaultParseRequestBodyOptions
for fs (\(fname, f) -> do
bs <- liftIO $ BL.readFile (W.fileContent f)
pure (fname, f{ W.fileContent = bs})
)


-- | Get list of uploaded temp files and form parameters decoded from multipart payloads.
--
-- NB the temp files are deleted when the continuation exits.
filesOpts :: MonadUnliftIO m =>
W.ParseRequestBodyOptions
-> ([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



-- | Get a request header. Header name is case-insensitive.
header :: (Monad m) => T.Text -> ActionT m (Maybe T.Text)
Expand All @@ -281,6 +322,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)

Expand All @@ -299,6 +342,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
Expand All @@ -320,7 +365,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. "#-}

Expand Down Expand Up @@ -351,8 +396,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 :: (MonadUnliftIO m, Parsable b) => T.Text -> ActionT m b
formParam k = runResourceT $ withInternalState $ \istate -> do
(ps, _) <- formParamsAndFilesWith istate W.defaultParseRequestBodyOptions
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.
--
Expand Down Expand Up @@ -387,8 +438,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 :: (MonadUnliftIO m, Parsable a) =>
T.Text -> ActionT m (Maybe a)
formParamMaybe k = runResourceT $ withInternalState $ \istate -> do
(ps, _) <- formParamsAndFilesWith istate W.defaultParseRequestBodyOptions
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.
--
Expand Down Expand Up @@ -449,8 +506,10 @@ captureParams :: Monad m => ActionT m [Param]
captureParams = paramsWith envPathParams

-- | Get form parameters
formParams :: Monad m => ActionT m [Param]
formParams = paramsWith envFormParams
formParams :: MonadUnliftIO m => ActionT m [Param]
formParams = runResourceT $ withInternalState $ \istate -> do
fst <$> formParamsAndFilesWith istate W.defaultParseRequestBodyOptions

-- | Get query parameters
queryParams :: Monad m => ActionT m [Param]
queryParams = paramsWith envQueryParams
Expand All @@ -459,8 +518,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
Expand Down
Loading

0 comments on commit 4e24ded

Please sign in to comment.