scotty 0.22 → 0.30
raw patch · 18 files changed
+1121/−268 lines, 18 filesdep +containersdep +http-api-datadep +randomdep −data-default-classdep ~network
Dependencies added: containers, http-api-data, random, unordered-containers
Dependencies removed: data-default-class
Dependency ranges changed: network
Files
- README.md +2/−0
- Web/Scotty.hs +126/−56
- Web/Scotty/Action.hs +183/−102
- Web/Scotty/Cookie.hs +2/−2
- Web/Scotty/Internal/Types.hs +21/−40
- Web/Scotty/Route.hs +1/−1
- Web/Scotty/Session.hs +192/−0
- Web/Scotty/Trans.hs +56/−20
- Web/Scotty/Trans/Lazy.hs +45/−21
- Web/Scotty/Trans/Strict.hs +6/−5
- changelog.md +18/−1
- examples/cookies.hs +4/−4
- examples/gzip.hs +2/−2
- examples/json_mode.hs +55/−0
- examples/middleware.hs +79/−0
- examples/session.hs +31/−0
- scotty.cabal +10/−5
- test/Web/ScottySpec.hs +288/−9
README.md view
@@ -56,6 +56,8 @@ * [configuration](./examples/reader.hs) * [cookies](./examples/cookies.hs) * [file upload](./examples/upload.hs)+* [session](./examples/session.hs)+* [WAI middlewares (logging, header validation)](./examples/middleware.hs) * and more ## More Information
Web/Scotty.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings, RankNTypes #-}+{-# LANGUAGE RankNTypes #-} -- | It should be noted that most of the code snippets below depend on the -- OverloadedStrings language pragma. --@@ -25,16 +25,17 @@ , capture, regex, function, literal -- ** Accessing the Request and its fields , request, header, headers, body, bodyReader- , jsonData+ , jsonData, formData -- ** 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+ , files, filesOpts+ -- ** Modifying the Response+ , status, addHeader, setHeader+ -- ** Redirecting+ , redirect, redirect300, redirect301, redirect302, redirect303, redirect304, redirect307, redirect308 -- ** Setting Response Body -- -- | Note: only one of these should be present in any given route@@ -43,15 +44,21 @@ -- ** Accessing the fields of the Response , getResponseHeaders, getResponseStatus, getResponseContent -- ** Exceptions- , raise, raiseStatus, throw, rescue, next, finish, defaultHandler, liftAndCatchIO+ , throw, next, finish, defaultHandler , liftIO, catch- , StatusError(..) , ScottyException(..) -- * Parsing Parameters , Param, Trans.Parsable(..), Trans.readEither -- * Types , ScottyM, ActionM, RoutePattern, File, Content(..), Kilobytes, ErrorHandler, Handler(..) , ScottyState, defaultScottyState+ -- ** Cookie functions+ , setCookie, setSimpleCookie, getCookie, getCookies, deleteCookie, Cookie.makeSimpleCookie+ -- ** Session Management+ , Session (..), SessionId, SessionJar, SessionStatus+ , createSessionJar, createUserSession, createSession, addSession+ , readSession, getUserSession, getSession, readUserSession+ , deleteSession, maintainSessions ) where import qualified Web.Scotty.Trans as Trans@@ -62,15 +69,20 @@ import qualified Data.ByteString as BS import Data.ByteString.Lazy.Char8 (ByteString) import Data.Text.Lazy (Text, toStrict)+import qualified Data.Text as T 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 qualified Network.Wai.Parse as W -import Web.Scotty.Internal.Types (ScottyT, ActionT, ErrorHandler, Param, RoutePattern, Options, defaultOptions, File, Kilobytes, ScottyState, defaultScottyState, ScottyException, StatusError(..), Content(..))+import Web.FormUrlEncoded (FromForm)+import Web.Scotty.Internal.Types (ScottyT, ActionT, ErrorHandler, Param, RoutePattern, Options, defaultOptions, File, Kilobytes, ScottyState, defaultScottyState, ScottyException, Content(..)) import UnliftIO.Exception (Handler(..), catch)+import qualified Web.Scotty.Cookie as Cookie +import Web.Scotty.Session (Session (..), SessionId, SessionJar, SessionStatus , createSessionJar,+ createSession, addSession, maintainSessions) {- $setup >>> :{@@ -149,20 +161,6 @@ setMaxRequestBodySize :: Kilobytes -> ScottyM () setMaxRequestBodySize = Trans.setMaxRequestBodySize --- | Throw a "500 Server Error" 'StatusError', which can be caught with 'catch'.------ Uncaught exceptions turn into HTTP 500 responses.-raise :: Text -> ActionM a-raise = Trans.raise-{-# DEPRECATED raise "Throw an exception instead" #-}---- | Throw a 'StatusError' exception that has an associated HTTP error code and can be caught with 'catch'.------ Uncaught exceptions turn into HTTP responses corresponding to the given status.-raiseStatus :: Status -> Text -> ActionM a-raiseStatus = Trans.raiseStatus-{-# DEPRECATED raiseStatus "Use status, text, and finish instead" #-}- -- | Throw an exception which can be caught within the scope of the current Action with 'catch'. -- -- If the exception is not caught locally, another option is to implement a global 'Handler' (with 'defaultHandler') that defines its interpretation and a translation to HTTP error codes.@@ -206,20 +204,8 @@ finish :: ActionM a finish = Trans.finish --- | Catch an exception e.g. a 'StatusError' or a user-defined exception.------ > raise JustKidding `catch` (\msg -> text msg)-rescue :: E.Exception e => ActionM a -> (e -> ActionM a) -> ActionM a-rescue = Trans.rescue-{-# DEPRECATED rescue "Use catch instead" #-}---- | Like 'liftIO', but catch any IO exceptions and turn them into Scotty exceptions.-liftAndCatchIO :: IO a -> ActionM a-liftAndCatchIO = Trans.liftAndCatchIO-{-# DEPRECATED liftAndCatchIO "Use liftIO instead" #-}---- | Redirect to given URL. Like throwing an uncatchable exception. Any code after the call to redirect--- will not be run.+-- | Synonym for 'redirect302'.+-- If you are unsure which redirect to use, you probably want this one. -- -- > redirect "http://www.google.com" --@@ -229,6 +215,48 @@ redirect :: Text -> ActionM a redirect = Trans.redirect +-- | Redirect to given URL with status 300 (Multiple Choices). Like throwing+-- an uncatchable exception. Any code after the call to+-- redirect will not be run.+redirect300 :: Text -> ActionM a+redirect300 = Trans.redirect300++-- | Redirect to given URL with status 301 (Moved Permanently). Like throwing+-- an uncatchable exception. Any code after the call to+-- redirect will not be run.+redirect301 :: Text -> ActionM a+redirect301 = Trans.redirect301++-- | Redirect to given URL with status 302 (Found). Like throwing+-- an uncatchable exception. Any code after the call to+-- redirect will not be run.+redirect302 :: Text -> ActionM a+redirect302 = Trans.redirect302++-- | Redirect to given URL with status 303 (See Other). Like throwing+-- an uncatchable exception. Any code after the call to+-- redirect will not be run.+redirect303 :: Text -> ActionM a+redirect303 = Trans.redirect303++-- | Redirect to given URL with status 304 (Not Modified). Like throwing+-- an uncatchable exception. Any code after the call to+-- redirect will not be run.+redirect304 :: Text -> ActionM a+redirect304 = Trans.redirect304++-- | Redirect to given URL with status 307 (Temporary Redirect). Like throwing+-- an uncatchable exception. Any code after the call to+-- redirect will not be run.+redirect307 :: Text -> ActionM a+redirect307 = Trans.redirect307++-- | Redirect to given URL with status 308 (Permanent Redirect). Like throwing+-- an uncatchable exception. Any code after the call to+-- redirect will not be run.+redirect308 :: Text -> ActionM a+redirect308 = Trans.redirect308+ -- | Get the 'Request' object. request :: ActionM Request request = Trans.request@@ -242,7 +270,7 @@ -- | 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+filesOpts :: W.ParseRequestBodyOptions -> ([Param] -> [File FilePath] -> ActionM a) -- ^ temp files validation, storage etc -> ActionM a filesOpts = Trans.filesOpts@@ -273,16 +301,11 @@ jsonData :: FromJSON a => ActionM a jsonData = Trans.jsonData --- | Get a parameter. First looks in captures, then form data, then query parameters.------ * Raises an exception which can be caught by 'catch' if parameter is not found.+-- | Parse the request body as @x-www-form-urlencoded@ form data and return it. Raises an exception if parse is unsuccessful. ----- * If parameter is found, but 'parseParam' fails to parse to the correct type, 'next' is called.--- This means captures are somewhat typed, in that a route won't match if a correctly typed--- capture cannot be parsed.-param :: Trans.Parsable a => Text -> ActionM a-param = Trans.param . toStrict-{-# DEPRECATED param "(#204) Not a good idea to treat all parameters identically. Use pathParam, formParam and queryParam instead. "#-}+-- NB: uses 'body' internally+formData :: FromForm a => ActionM a+formData = Trans.formData -- | Synonym for 'pathParam' --@@ -352,14 +375,6 @@ queryParamMaybe :: (Trans.Parsable a) => Text -> ActionM (Maybe a) queryParamMaybe = Trans.queryParamMaybe . toStrict ------ | Get all parameters from path, form and query (in that order).-params :: ActionM [Param]-params = Trans.params-{-# DEPRECATED params "(#204) Not a good idea to treat all parameters identically. Use pathParams, formParams and queryParams instead. "#-}- -- | Synonym for 'pathParams' captureParams :: ActionM [Param] captureParams = Trans.captureParams@@ -540,5 +555,60 @@ literal = Trans.literal +-- | Retrieves a session by its ID from the session jar.+getSession :: SessionJar a -> SessionId -> ActionM (Either SessionStatus (Session a))+getSession = Trans.getSession+ +-- | Deletes a session by its ID from the session jar.+deleteSession :: SessionJar a -> SessionId -> ActionM ()+deleteSession = Trans.deleteSession+ +{- | Retrieves the current user's session based on the "sess_id" cookie.+| Returns `Left SessionStatus` if the session is expired or does not exist.+-}+getUserSession :: SessionJar a -> ActionM (Either SessionStatus (Session a))+getUserSession = Trans.getUserSession +-- | Reads the content of a session by its ID.+readSession :: SessionJar a -> SessionId -> ActionM (Either SessionStatus a)+readSession = Trans.readSession +-- | Reads the content of the current user's session.+readUserSession ::SessionJar a -> ActionM (Either SessionStatus a)+readUserSession = Trans.readUserSession++-- | Creates a new session for a user, storing the content and setting a cookie.+createUserSession :: + SessionJar a -- ^ SessionJar, which can be created by createSessionJar+ -> Maybe Int -- ^ Optional expiration time (in seconds)+ -> a -- ^ Content+ -> ActionM (Session a)+createUserSession = Trans.createUserSession++-- Cookie functions++-- | Set a cookie, with full access to its options (see 'SetCookie')+setCookie :: Cookie.SetCookie -> ActionM ()+setCookie = Cookie.setCookie++-- | 'makeSimpleCookie' and 'setCookie' combined.+setSimpleCookie :: T.Text -- ^ name+ -> T.Text -- ^ value+ -> ActionM ()+setSimpleCookie = Cookie.setSimpleCookie++-- | Lookup one cookie name+getCookie :: T.Text -- ^ name+ -> ActionM (Maybe T.Text)+getCookie = Cookie.getCookie++-- | Returns all cookies+getCookies :: ActionM Cookie.CookiesText+getCookies = Cookie.getCookies++-- | Browsers don't directly delete a cookie, but setting its expiry to a past date (e.g. the UNIX epoch) +-- ensures that the cookie will be invalidated +-- (whether and when it will be actually deleted by the browser seems to be browser-dependent).+deleteCookie :: T.Text -- ^ name+ -> ActionM ()+deleteCookie = Cookie.deleteCookie
Web/Scotty/Action.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}@@ -20,11 +18,10 @@ , headers , html , htmlLazy- , liftAndCatchIO , json , jsonData+ , formData , next- , param , pathParam , captureParam , formParam@@ -33,20 +30,23 @@ , captureParamMaybe , formParamMaybe , queryParamMaybe- , params , pathParams , captureParams , formParams , queryParams- , raise- , raiseStatus , throw , raw , nested , readEither , redirect+ , redirect300+ , redirect301+ , redirect302+ , redirect303+ , redirect304+ , redirect307+ , redirect308 , request- , rescue , setHeader , status , stream@@ -68,7 +68,7 @@ import Control.Monad (when) import Control.Monad.IO.Class (MonadIO(..)) import UnliftIO (MonadUnliftIO(..))-import Control.Monad.Reader (MonadReader(..), ReaderT(..))+import Control.Monad.Reader (MonadReader(..), ReaderT(..), asks) import Control.Monad.Trans.Resource (withInternalState, runResourceT) import Control.Concurrent.MVar@@ -79,7 +79,10 @@ import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.CaseInsensitive as CI import Data.Traversable (for)+import qualified Data.Map.Strict as Map+import qualified Data.HashMap.Strict as HM import Data.Int+import Data.List (foldl') import Data.Maybe (maybeToList) import qualified Data.Text as T import Data.Text.Encoding as STE@@ -101,9 +104,10 @@ import Numeric.Natural +import Web.FormUrlEncoded (Form(..), FromForm(..)) import Web.Scotty.Internal.Types import Web.Scotty.Util (mkResponse, addIfNotPresent, add, replace, lazyTextToStrictByteString, decodeUtf8Lenient)-import UnliftIO.Exception (Handler(..), catch, catches, throwIO)+import UnliftIO.Exception (Handler(..), catches, throwIO) import System.IO (hPutStrLn, stderr) import Network.Wai.Internal (ResponseReceived(..))@@ -124,101 +128,150 @@ ok <- flip runReaderT env $ runAM $ tryNext $ action `catches` concat [ [actionErrorHandler] , maybeToList mh- , [statusErrorHandler, scottyExceptionHandler, someExceptionHandler options]+ , [scottyExceptionHandler options, someExceptionHandler options] ] res <- getResponse env return $ bool Nothing (Just $ mkResponse res) ok --- | Catches 'StatusError' and produces an appropriate HTTP response.-statusErrorHandler :: MonadIO m => ErrorHandler m-statusErrorHandler = Handler $ \case- StatusError s e -> do- status s- let code = T.pack $ show $ statusCode s- let msg = decodeUtf8Lenient $ statusMessage s- html $ mconcat ["<h1>", code, " ", msg, "</h1>", e]- -- | Exception handler in charge of 'ActionError'. Rethrowing 'Next' here is caught by 'tryNext'. -- All other cases of 'ActionError' are converted to HTTP responses. actionErrorHandler :: MonadIO m => ErrorHandler m actionErrorHandler = Handler $ \case- AERedirect url -> do- status status302+ AERedirect s url -> do+ status s setHeader "Location" url AENext -> next AEFinish -> return () -- | Default handler for exceptions from scotty-scottyExceptionHandler :: MonadIO m => ErrorHandler m-scottyExceptionHandler = Handler $ \case+scottyExceptionHandler :: MonadIO m => Options -> ErrorHandler m+scottyExceptionHandler Options{jsonMode} = Handler $ \case RequestTooLarge -> do status status413- text "Request body is too large"+ if jsonMode+ then json $ A.object ["status" A..= (413 :: Int), "description" A..= ("Request body is too large" :: T.Text)]+ else text "Request body is too large" MalformedJSON bs err -> do status status400- raw $ BL.unlines- [ "jsonData: malformed"- , "Body: " <> bs- , "Error: " <> BL.fromStrict (encodeUtf8 err)- ]+ if jsonMode+ then json $ A.object+ [ "status" A..= (400 :: Int)+ , "description" A..= ("jsonData: malformed" :: T.Text)+ , "body" A..= decodeUtf8Lenient (BL.toStrict bs)+ , "error" A..= err+ ]+ else raw $ BL.unlines+ [ "jsonData: malformed"+ , "Body: " <> bs+ , "Error: " <> BL.fromStrict (encodeUtf8 err)+ ] FailedToParseJSON bs err -> do status status422- raw $ BL.unlines- [ "jsonData: failed to parse"- , "Body: " <> bs- , "Error: " <> BL.fromStrict (encodeUtf8 err)- ]+ if jsonMode+ then json $ A.object+ [ "status" A..= (422 :: Int)+ , "description" A..= ("jsonData: failed to parse" :: T.Text)+ , "body" A..= decodeUtf8Lenient (BL.toStrict bs)+ , "error" A..= err+ ]+ else raw $ BL.unlines+ [ "jsonData: failed to parse"+ , "Body: " <> bs+ , "Error: " <> BL.fromStrict (encodeUtf8 err)+ ]+ MalformedForm err -> do+ status status400+ if jsonMode+ then json $ A.object+ [ "status" A..= (400 :: Int)+ , "description" A..= ("formData: malformed" :: T.Text)+ , "error" A..= err+ ]+ else raw $ BL.unlines+ [ "formData: malformed"+ , "Error: " <> BL.fromStrict (encodeUtf8 err)+ ] PathParameterNotFound k -> do status status500- text $ T.unwords [ "Path parameter", k, "not found"]+ if jsonMode+ then json $ A.object+ [ "status" A..= (500 :: Int)+ , "description" A..= T.unwords [ "Path parameter", k, "not found"]+ ]+ else text $ T.unwords [ "Path parameter", k, "not found"] QueryParameterNotFound k -> do status status400- text $ T.unwords [ "Query parameter", k, "not found"]+ if jsonMode+ then json $ A.object+ [ "status" A..= (400 :: Int)+ , "description" A..= T.unwords [ "Query parameter", k, "not found"]+ ]+ else text $ T.unwords [ "Query parameter", k, "not found"] FormFieldNotFound k -> do status status400- text $ T.unwords [ "Query parameter", k, "not found"]+ if jsonMode+ then json $ A.object+ [ "status" A..= (400 :: Int)+ , "description" A..= T.unwords [ "Form field", k, "not found"]+ ]+ else text $ T.unwords [ "Form field", k, "not found"] FailedToParseParameter k v e -> do status status400- text $ T.unwords [ "Failed to parse parameter", k, v, ":", e]+ if jsonMode+ then json $ A.object+ [ "status" A..= (400 :: Int)+ , "description" A..= T.unwords [ "Failed to parse parameter", k, v, ":", e]+ ]+ else text $ T.unwords [ "Failed to parse parameter", k, v, ":", e] WarpRequestException we -> case we of RequestHeaderFieldsTooLarge -> do status status413+ if jsonMode+ then json $ A.object+ [ "status" A..= (413 :: Int)+ , "description" A..= ("Request header fields too large" :: T.Text)+ ]+ else text "Request header fields too large" 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)]+ if jsonMode+ then json $ A.object+ [ "status" A..= (400 :: Int)+ , "description" A..= T.unwords ["Request Exception:", T.pack (show weo)]+ ]+ else 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)]+ if jsonMode+ then json $ A.object+ [ "status" A..= (413 :: Int)+ , "description" A..= T.unwords ["wai-extra Exception:", T.pack (show we)]+ ]+ else text $ T.unwords ["wai-extra Exception:", T.pack (show we)] ResourceTException rte -> do status status500- text $ T.unwords ["resourcet Exception:", T.pack (show rte)]+ if jsonMode+ then json $ A.object+ [ "status" A..= (500 :: Int)+ , "description" A..= T.unwords ["resourcet Exception:", T.pack (show rte)]+ ]+ else text $ T.unwords ["resourcet Exception:", T.pack (show rte)] -- | Uncaught exceptions turn into HTTP 500 Server Error codes someExceptionHandler :: MonadIO m => Options -> ErrorHandler m-someExceptionHandler Options{verbose} =+someExceptionHandler Options{verbose, jsonMode} = Handler $ \(E.SomeException e) -> do when (verbose > 0) $ liftIO $ hPutStrLn stderr $ "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.-raise :: (MonadIO m) =>- T.Text -- ^ Error text- -> ActionT m a-raise = raiseStatus status500-{-# DEPRECATED raise "Throw an exception instead" #-}---- | Throw a 'StatusError' exception that has an associated HTTP error code and can be caught with 'catch'.------ Uncaught exceptions turn into HTTP responses corresponding to the given status.-raiseStatus :: Monad m => Status -> T.Text -> ActionT m a-raiseStatus s = E.throw . StatusError s-{-# DEPRECATED raiseStatus "Use status, text, and finish instead" #-}+ if jsonMode+ then json $ A.object+ [ "status" A..= (500 :: Int)+ , "description" A..= ("Internal Server Error" :: T.Text)+ ]+ else text "Internal Server Error" -- | Throw an exception which can be caught within the scope of the current Action with 'catch'. --@@ -248,20 +301,8 @@ next :: Monad m => ActionT m a next = E.throw AENext --- | Catch an exception e.g. a 'StatusError' or a user-defined exception.------ > raise JustKidding `catch` (\msg -> text msg)-rescue :: (MonadUnliftIO m, E.Exception e) => ActionT m a -> (e -> ActionT m a) -> ActionT m a-rescue = catch-{-# DEPRECATED rescue "Use catch instead" #-}---- | Catch any synchronous IO exceptions-liftAndCatchIO :: MonadIO m => IO a -> ActionT m a-liftAndCatchIO = liftIO-{-# DEPRECATED liftAndCatchIO "Use liftIO instead" #-}---- | Redirect to given URL. Like throwing an uncatchable exception. Any code after the call to redirect--- will not be run.+-- | Synonym for 'redirect302'.+-- If you are unsure which redirect to use, you probably want this one. -- -- > redirect "http://www.google.com" --@@ -269,8 +310,53 @@ -- -- > redirect "/foo/bar" redirect :: (Monad m) => T.Text -> ActionT m a-redirect = E.throw . AERedirect+redirect = redirect302 +-- | Redirect to given URL with status 300 (Multiple Choices). Like throwing+-- an uncatchable exception. Any code after the call to+-- redirect will not be run.+redirect300 :: (Monad m) => T.Text -> ActionT m a+redirect300 = redirectStatus status300++-- | Redirect to given URL with status 301 (Moved Permanently). Like throwing+-- an uncatchable exception. Any code after the call to+-- redirect will not be run.+redirect301 :: (Monad m) => T.Text -> ActionT m a+redirect301 = redirectStatus status301++-- | Redirect to given URL with status 302 (Found). Like throwing+-- an uncatchable exception. Any code after the call to+-- redirect will not be run.+redirect302 :: (Monad m) => T.Text -> ActionT m a+redirect302 = redirectStatus status302++-- | Redirect to given URL with status 303 (See Other). Like throwing+-- an uncatchable exception. Any code after the call to+-- redirect will not be run.+redirect303 :: (Monad m) => T.Text -> ActionT m a+redirect303 = redirectStatus status303++-- | Redirect to given URL with status 304 (Not Modified). Like throwing+-- an uncatchable exception. Any code after the call to+-- redirect will not be run.+redirect304 :: (Monad m) => T.Text -> ActionT m a+redirect304 = redirectStatus status304++-- | Redirect to given URL with status 307 (Temporary Redirect). Like throwing+-- an uncatchable exception. Any code after the call to+-- redirect will not be run.+redirect307 :: (Monad m) => T.Text -> ActionT m a+redirect307 = redirectStatus status307++-- | Redirect to given URL with status 308 (Permanent Redirect). Like throwing+-- an uncatchable exception. Any code after the call to+-- redirect will not be run.+redirect308 :: (Monad m) => T.Text -> ActionT m a+redirect308 = redirectStatus status308++redirectStatus :: (Monad m) => Status -> T.Text -> ActionT m a+redirectStatus s = E.throw . AERedirect s+ -- | Finish the execution of the current action. Like throwing an uncatchable -- exception. Any code after the call to finish will not be run. --@@ -354,21 +440,27 @@ A.Error err -> throwIO $ FailedToParseJSON b $ T.pack err A.Success a -> return a --- | Get a parameter. First looks in captures, then form data, then query parameters.------ * Raises an exception which can be caught by 'catch' if parameter is not found.+-- | Parse the request body as @x-www-form-urlencoded@ form data and return it. ----- * If parameter is found, but 'parseParam' fails to parse to the correct type, 'next' is called.--- This means captures are somewhat typed, in that a route won't match if a correctly typed--- capture cannot be parsed.-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!"- 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. "#-}+-- The form is parsed using 'urlDecodeAsForm'. If that returns 'Left', the+-- status is set to 400 and an exception is thrown.+formData :: (FromForm a, MonadUnliftIO m) => ActionT m a+formData = do+ form <- paramListToForm <$> formParams+ case fromForm form of+ Left err -> throwIO $ MalformedForm err+ Right value -> return value+ where+ -- This rather contrived implementation uses cons and reverse to avoid+ -- quadratic complexity when constructing a Form from a list of Param.+ -- It's equivalent to using HashMap.insertWith (++) which does have+ -- quadratic complexity due to appending at the end of list.+ paramListToForm :: [Param] -> Form+ paramListToForm = Form . fmap reverse . foldl' (\f (k, v) -> HM.alter (prependValue v) k f) HM.empty + prependValue :: a -> Maybe [a] -> Maybe [a]+ prependValue v = Just . maybe [v] (v :)+ -- | Synonym for 'pathParam' captureParam :: (Parsable a, MonadIO m) => T.Text -> ActionT m a captureParam = pathParam@@ -487,16 +579,11 @@ -> T.Text -- ^ parameter name -> ActionT m (Maybe b) paramWithMaybe f k = do- val <- ActionT $ (lookup k . f) <$> ask+ val <- ActionT $ asks (lookup k . f) case val of Nothing -> pure Nothing Just v -> either (const $ pure Nothing) (pure . Just) $ parseParam $ TL.fromStrict v --- | Get all parameters from path, form and query (in that order).-params :: Monad m => ActionT m [Param]-params = paramsWith getParams-{-# DEPRECATED params "(#204) Not a good idea to treat all parameters identically. Use pathParams, formParams and queryParams instead. "#-}- -- | Get path parameters pathParams :: Monad m => ActionT m [Param] pathParams = paramsWith envPathParams@@ -515,13 +602,7 @@ queryParams = paramsWith envQueryParams 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 <> [] <> envQueryParams e-+paramsWith f = ActionT (asks f) -- === access the fields of the Response being constructed @@ -572,7 +653,7 @@ instance (Parsable a) => Parsable [a] where parseParam = parseParamList instance Parsable Bool where- parseParam t = if t' == TL.toCaseFold "true"+ parseParam t = if t' == TL.toCaseFold "true" || t' == TL.toCaseFold "on" then Right True else if t' == TL.toCaseFold "false" then Right False
Web/Scotty/Cookie.hs view
@@ -22,7 +22,7 @@ import Data.Maybe import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Read as TL (decimal)-import Web.Scotty (scotty, html)+import Web.Scotty (scotty, html, get) import Web.Scotty.Cookie (getCookie, setSimpleCookie) main :: IO ()@@ -30,7 +30,7 @@ get \"/\" $ do hits <- liftM (fromMaybe \"0\") $ 'getCookie' \"hits\" let hits' =- case TL.decimal hits of+ case TL.decimal $ TL.fromStrict hits of Right n -> TL.pack . show . (+1) $ (fst n :: Integer) Left _ -> \"1\" 'setSimpleCookie' \"hits\" $ TL.toStrict hits'
Web/Scotty/Internal/Types.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -7,6 +6,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-} module Web.Scotty.Internal.Types where import Blaze.ByteString.Builder (Builder)@@ -18,22 +18,19 @@ import Control.Monad (MonadPlus(..)) import Control.Monad.Base (MonadBase) import Control.Monad.Catch (MonadCatch, MonadThrow)-import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.IO.Class (MonadIO(..)) import UnliftIO (MonadUnliftIO(..)) import Control.Monad.Reader (MonadReader(..), ReaderT, asks, mapReaderT)-import Control.Monad.State.Strict (State, StateT(..))+import Control.Monad.State.Strict (State) import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Control (MonadBaseControl, MonadTransControl) import qualified Control.Monad.Trans.Resource as RT (InternalState, InvalidAccess) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy.Char8 as LBS8 (ByteString)-import Data.Default.Class (Default, def) import Data.String (IsString(..)) import qualified Data.Text as T (Text, pack)-import Data.Typeable (Typeable)-+import GHC.Stack (callStack) import Network.HTTP.Types import Network.Wai hiding (Middleware, Application)@@ -42,7 +39,7 @@ import Network.Wai.Parse (FileInfo) import qualified Network.Wai.Parse as WPS (ParseRequestBodyOptions, RequestParseException(..)) -import UnliftIO.Exception (Handler(..), catch, catches)+import UnliftIO.Exception (Handler(..), catch, catches, StringException(..)) @@ -56,20 +53,15 @@ -- up. This likely has performance implications, -- so you may want to modify this for production -- servers using `setFdCacheDuration`.+ , jsonMode :: Bool -- ^ If True, return JSON error responses instead of HTML } -instance Default Options where- def = defaultOptions- defaultOptions :: Options-defaultOptions = Options 1 W.defaultSettings+defaultOptions = Options 1 W.defaultSettings False newtype RouteOptions = RouteOptions { maxRequestBodySize :: Maybe Kilobytes -- max allowed request size in KB } -instance Default RouteOptions where- def = defaultRouteOptions- defaultRouteOptions :: RouteOptions defaultRouteOptions = RouteOptions Nothing @@ -100,9 +92,6 @@ , routeOptions :: RouteOptions } --- instance Default (ScottyState m) where--- def = defaultScottyState- defaultScottyState :: ScottyState m defaultScottyState = ScottyState [] [] Nothing defaultRouteOptions @@ -132,23 +121,18 @@ -- The exception constructor is not exposed to the user and all exceptions of this type are caught -- and processed within the 'runAction' function. data ActionError- = AERedirect T.Text -- ^ Redirect+ = AERedirect Status T.Text -- ^ Redirect | AENext -- ^ Stop processing this route and skip to the next one | AEFinish -- ^ Stop processing the request- deriving (Show, Typeable)+ deriving (Show) instance E.Exception ActionError tryNext :: MonadUnliftIO m => m a -> m Bool-tryNext io = catch (io >> pure True) $ \e ->- case e of+tryNext io = catch (io >> pure True) $+ \case AENext -> pure False _ -> pure True --- | E.g. when a parameter is not found in a query string (400 Bad Request) or when parsing a JSON body fails (422 Unprocessable Entity)-data StatusError = StatusError Status T.Text deriving (Show, Typeable)-instance E.Exception StatusError-{-# DEPRECATED StatusError "If it is supposed to be caught, a proper exception type should be defined" #-}- -- | Specializes a 'Handler' to the 'ActionT' monad type ErrorHandler m = Handler (ActionT m) () @@ -157,6 +141,7 @@ = RequestTooLarge | MalformedJSON LBS8.ByteString T.Text | FailedToParseJSON LBS8.ByteString T.Text+ | MalformedForm T.Text | PathParameterNotFound T.Text | QueryParameterNotFound T.Text | FormFieldNotFound T.Text@@ -164,7 +149,7 @@ | WarpRequestException W.InvalidRequest | WaiRequestParseException WPS.RequestParseException -- request parsing | ResourceTException RT.InvalidAccess -- use after free- deriving (Show, Typeable)+ deriving (Show) instance E.Exception ScottyException ------------------ Scotty Actions -------------------@@ -208,7 +193,7 @@ tv <- ActionT $ asks envResponse liftIO $ atomically $ modifyTVar' tv f -data BodyPartiallyStreamed = BodyPartiallyStreamed deriving (Show, Typeable)+data BodyPartiallyStreamed = BodyPartiallyStreamed deriving (Show) instance E.Exception BodyPartiallyStreamed @@ -231,8 +216,6 @@ setStatus :: Status -> ScottyResponse -> ScottyResponse setStatus s sr = sr { srStatus = s } -instance Default ScottyResponse where- def = defaultScottyResponse -- | The default response has code 200 OK and empty body defaultScottyResponse :: ScottyResponse@@ -250,13 +233,13 @@ ask = ActionT $ lift ask local f = ActionT . mapReaderT (local f) . runAM --- | Models the invariant that only 'StatusError's can be thrown and caught.-instance (MonadUnliftIO m) => MonadError StatusError (ActionT m) where- throwError = E.throw- catchError = catch--- | Modeled after the behaviour in scotty < 0.20, 'fail' throws a 'StatusError' with code 500 ("Server Error"), which can be caught with 'E.catch'.+-- | MonadFail instance for ActionT that converts 'fail' calls into Scotty exceptions+-- which allows these failures to be caught by Scotty's error handling system+-- and properly returned as HTTP 500 responses. The instance throws a 'StringException'+-- containing both the failure message and a call stack for debugging purposes. instance (MonadIO m) => MonadFail (ActionT m) where- fail = E.throw . StatusError status500 . T.pack+ fail msg = E.throw $ StringException msg callStack+ -- | 'empty' throws 'ActionError' 'AENext', whereas '(<|>)' catches any 'ActionError's or 'StatusError's in the first action and proceeds to the second one. instance (MonadUnliftIO m) => Alternative (ActionT m) where empty = E.throw AENext@@ -269,13 +252,11 @@ -- | catches either ActionError (thrown by 'next'), -- 'ScottyException' (thrown if e.g. a query parameter is not found)--- or 'StatusError' (via 'raiseStatus') tryAnyStatus :: MonadUnliftIO m => m a -> m Bool-tryAnyStatus io = (io >> pure True) `catches` [h1, h2, h3]+tryAnyStatus io = (io >> pure True) `catches` [h1, h2] where h1 = Handler $ \(_ :: ActionError) -> pure False- h2 = Handler $ \(_ :: StatusError) -> pure False- h3 = Handler $ \(_ :: ScottyException) -> pure False+ h2 = Handler $ \(_ :: ScottyException) -> pure False instance (Semigroup a) => Semigroup (ScottyT m a) where x <> y = (<>) <$> x <*> y
Web/Scotty/Route.hs view
@@ -23,7 +23,7 @@ import Web.Scotty.Action -import Web.Scotty.Internal.Types (Options, RoutePattern(..), RouteOptions, ActionEnv(..), ActionT, ScottyState(..), ScottyT(..), ErrorHandler, Middleware, BodyInfo, File, handler, addRoute, defaultScottyResponse)+import Web.Scotty.Internal.Types (Options, RoutePattern(..), RouteOptions, ActionEnv(..), ScottyState(..), ScottyT(..), ErrorHandler, Middleware, BodyInfo, File, handler, addRoute, defaultScottyResponse) import Web.Scotty.Util (decodeUtf8Lenient) import Web.Scotty.Body (cloneBodyInfo, getBodyAction, getBodyChunkAction, getFormParamsAndFilesAction)
+ Web/Scotty/Session.hs view
@@ -0,0 +1,192 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}++{- |+Module : Web.Scotty.Session+Copyright : (c) 2025 Tushar Adhatrao,+ (c) 2025 Marco Zocca++License : BSD-3-Clause+Maintainer :+Stability : experimental+Portability : GHC++This module provides session management functionality for Scotty web applications.++==Example usage:++@+\{\-\# LANGUAGE OverloadedStrings \#\-\}++import Web.Scotty+import Web.Scotty.Session+import Control.Monad.IO.Class (liftIO)+main :: IO ()+main = do+ -- Create a session jar+ sessionJar <- createSessionJar+ scotty 3000 $ do+ -- Route to create a session+ get "/create" $ do+ sess <- createUserSession sessionJar "user data"+ html $ "Session created with ID: " <> sessId sess+ -- Route to read a session+ get "/read" $ do+ eSession <- getUserSession sessionJar+ case eSession of+ Left _-> html "No session found or session expired."+ Right sess -> html $ "Session content: " <> sessContent sess+@+-}+module Web.Scotty.Session (+ Session (..),+ SessionId,+ SessionJar,+ SessionStatus,++ -- * Create Session Jar+ createSessionJar,++ -- * Create session+ createUserSession,+ createSession,++ -- * Read session+ readUserSession,+ readSession,+ getUserSession,+ getSession,++ -- * Add session+ addSession,++ -- * Delte session+ deleteSession,++ -- * Helper functions+ maintainSessions,+) where++import Control.Concurrent+import Control.Concurrent.STM+import Control.Monad+import Control.Monad.IO.Class (MonadIO (..))+import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T+import Data.Time (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime)+import System.Random (randomRIO)+import Web.Scotty.Action (ActionT)+import Web.Scotty.Cookie++-- | Type alias for session identifiers.+type SessionId = T.Text++-- | Status of a session lookup.+data SessionStatus = SessionNotFound | SessionExpired+ deriving (Show, Eq)++-- | Represents a session containing an ID, expiration time, and content.+data Session a = Session+ { sessId :: SessionId+ -- ^ Unique identifier for the session.+ , sessExpiresAt :: UTCTime+ -- ^ Expiration time of the session.+ , sessContent :: a+ -- ^ Content stored in the session.+ }+ deriving (Eq, Show)++-- | Type for session storage, a transactional variable containing a map of session IDs to sessions.+type SessionJar a = TVar (HM.HashMap SessionId (Session a))++-- | Creates a new session jar and starts a background thread to maintain it.+createSessionJar :: IO (SessionJar a)+createSessionJar = do+ storage <- newTVarIO HM.empty+ _ <- forkIO $ maintainSessions storage+ return storage++-- | Continuously removes expired sessions from the session jar.+maintainSessions :: SessionJar a -> IO ()+maintainSessions sessionJar =+ forever $ do+ now <- getCurrentTime+ let stillValid sess = sessExpiresAt sess > now+ atomically $ modifyTVar sessionJar $ \m -> HM.filter stillValid m+ threadDelay 1000000+ ++-- | Adds or overwrites a new session to the session jar.+addSession :: SessionJar a -> Session a -> IO ()+addSession sessionJar sess =+ atomically $ modifyTVar sessionJar $ \m -> HM.insert (sessId sess) sess m++-- | Retrieves a session by its ID from the session jar.+getSession :: (MonadIO m) => SessionJar a -> SessionId -> ActionT m (Either SessionStatus (Session a))+getSession sessionJar sId =+ do+ s <- liftIO $ readTVarIO sessionJar+ case HM.lookup sId s of+ Nothing -> pure $ Left SessionNotFound+ Just sess -> do + now <- liftIO getCurrentTime+ if sessExpiresAt sess < now+ then deleteSession sessionJar (sessId sess) >> pure (Left SessionExpired)+ else pure $ Right sess++-- | Deletes a session by its ID from the session jar.+deleteSession :: (MonadIO m) => SessionJar a -> SessionId -> ActionT m ()+deleteSession sessionJar sId =+ liftIO $+ atomically $+ modifyTVar sessionJar $+ HM.delete sId++{- | Retrieves the current user's session based on the "sess_id" cookie.+| Returns `Left SessionStatus` if the session is expired or does not exist.+-}+getUserSession :: (MonadIO m) => SessionJar a -> ActionT m (Either SessionStatus (Session a))+getUserSession sessionJar = do+ getCookie "sess_id" >>= \case+ Nothing -> pure $ Left SessionNotFound+ Just sid -> lookupSession sid+ where+ lookupSession = getSession sessionJar++-- | Reads the content of a session by its ID.+readSession :: (MonadIO m) => SessionJar a -> SessionId -> ActionT m (Either SessionStatus a)+readSession sessionJar sId = do+ res <- getSession sessionJar sId+ return $ sessContent <$> res++-- | Reads the content of the current user's session.+readUserSession :: (MonadIO m) => SessionJar a -> ActionT m (Either SessionStatus a)+readUserSession sessionJar = do+ res <- getUserSession sessionJar+ return $ sessContent <$> res++-- | The time-to-live for sessions, in seconds.+sessionTTL :: NominalDiffTime+sessionTTL = 36000 -- in seconds++-- | Creates a new session for a user, storing the content and setting a cookie.+createUserSession :: (MonadIO m) => + SessionJar a -- ^ SessionJar, which can be created by createSessionJar+ -> Maybe Int -- ^ Optional expiration time (in seconds)+ -> a -- ^ Content+ -> ActionT m (Session a)+createUserSession sessionJar mbExpirationTime content = do+ sess <- liftIO $ createSession sessionJar mbExpirationTime content+ setSimpleCookie "sess_id" (sessId sess)+ return sess++-- | Creates a new session with a generated ID, sets its expiration, +-- | and adds it to the session jar.+createSession :: SessionJar a -> Maybe Int -> a -> IO (Session a)+createSession sessionJar mbExpirationTime content = do+ sId <- liftIO $ T.pack <$> replicateM 32 (randomRIO ('a', 'z'))+ now <- getCurrentTime+ let expiresAt = addUTCTime (maybe sessionTTL fromIntegral mbExpirationTime) now+ sess = Session sId expiresAt content+ liftIO $ addSession sessionJar sess+ return $ Session sId expiresAt content
Web/Scotty/Trans.hs view
@@ -30,17 +30,19 @@ , capture, regex, function, literal -- ** Accessing the Request and its fields , request, Lazy.header, Lazy.headers, body, bodyReader- , jsonData+ , jsonData, formData -- ** Accessing Path, Form and Query Parameters- , param, params , pathParam, captureParam, formParam, queryParam , pathParamMaybe, captureParamMaybe, formParamMaybe, queryParamMaybe , pathParams, captureParams, formParams, queryParams -- *** Files- , files, filesOpts, ParseRequestBodyOptions- -- ** Modifying the Response and Redirecting- , status, Lazy.addHeader, Lazy.setHeader, Lazy.redirect+ , files, filesOpts+ -- ** Modifying the Response+ , status, Lazy.addHeader, Lazy.setHeader+ -- ** Redirecting+ , Lazy.redirect, Lazy.redirect300, Lazy.redirect301, Lazy.redirect302, Lazy.redirect303+ , Lazy.redirect304, Lazy.redirect307, Lazy.redirect308 -- ** Setting Response Body -- -- | Note: only one of these should be present in any given route@@ -49,9 +51,8 @@ -- ** Accessing the fields of the Response , getResponseHeaders, getResponseStatus, getResponseContent -- ** Exceptions- , Lazy.raise, Lazy.raiseStatus, throw, rescue, next, finish, defaultHandler, liftAndCatchIO+ , throw, next, finish, defaultHandler , liftIO, catch- , StatusError(..) , ScottyException(..) -- * Parsing Parameters , Param, Parsable(..), readEither@@ -60,9 +61,15 @@ -- * Monad Transformers , ScottyT, ActionT , ScottyState, defaultScottyState+ -- ** Functions from Cookie module+ , setSimpleCookie, getCookie, getCookies, deleteCookie, makeSimpleCookie+ -- ** Session Management+ , Session (..), SessionId, SessionJar, createSessionJar,+ createUserSession, createSession, readUserSession,+ readSession, getUserSession, getSession, addSession, deleteSession, maintainSessions ) where -import Blaze.ByteString.Builder (fromByteString)+import Blaze.ByteString.Builder (fromByteString, fromLazyByteString) import Blaze.ByteString.Builder.Char8 (fromString) import Control.Exception (assert)@@ -71,6 +78,9 @@ import Control.Monad.State.Strict (execState, modify) import Control.Monad.IO.Class +import qualified Data.Aeson as A+import qualified Data.Text as T+ import Network.HTTP.Types (status404, status413, status500) import Network.Socket (Socket) import qualified Network.Wai as W (Application, Middleware, Response, responseBuilder)@@ -78,12 +88,16 @@ import Web.Scotty.Action import Web.Scotty.Route-import Web.Scotty.Internal.Types (ScottyT(..), defaultScottyState, Application, RoutePattern, Options(..), defaultOptions, RouteOptions(..), defaultRouteOptions, ErrorHandler, Kilobytes, File, addMiddleware, setHandler, updateMaxRequestBodySize, routes, middlewares, ScottyException(..), ScottyState, defaultScottyState, StatusError(..), Content(..))+import Web.Scotty.Internal.Types (ScottyT(..), defaultScottyState, Application, RoutePattern, Options(..), defaultOptions, RouteOptions(..), defaultRouteOptions, ErrorHandler, Kilobytes, File, addMiddleware, setHandler, updateMaxRequestBodySize, routes, middlewares, ScottyException(..), ScottyState, defaultScottyState, Content(..)) import Web.Scotty.Trans.Lazy as Lazy import Web.Scotty.Util (socketDescription) import Web.Scotty.Body (newBodyInfo) import UnliftIO.Exception (Handler(..), catch)+import Web.Scotty.Cookie (setSimpleCookie,getCookie,getCookies,deleteCookie,makeSimpleCookie)+import Web.Scotty.Session (Session (..), SessionId, SessionJar, createSessionJar,+ createUserSession, createSession, readUserSession,+ readSession, getUserSession, getSession, addSession, deleteSession, maintainSessions) -- | Run a scotty application using the warp server.@@ -130,28 +144,50 @@ -> (m W.Response -> IO W.Response) -- ^ Run monad 'm' into 'IO', called at each action. -> ScottyT m () -> n W.Application-scottyAppT options runActionToIO defs = do- let s = execState (runReaderT (runS defs) options) defaultScottyState+scottyAppT opts runActionToIO defs = do+ let s = execState (runReaderT (runS defs) opts) defaultScottyState let rapp req callback = do bodyInfo <- newBodyInfo req- resp <- runActionToIO (applyAll notFoundApp ([midd bodyInfo | midd <- routes s]) req)- `catch` unhandledExceptionHandler+ resp <- runActionToIO (applyAll (notFoundApp opts) ([midd bodyInfo | midd <- routes s]) req)+ `catch` unhandledExceptionHandler opts callback resp return $ applyAll rapp (middlewares s) -- | Exception handler in charge of 'ScottyException' that's not caught by 'scottyExceptionHandler'-unhandledExceptionHandler :: MonadIO m => ScottyException -> m W.Response-unhandledExceptionHandler = \case- RequestTooLarge -> return $ W.responseBuilder status413 ct "Request is too big Jim!"- e -> return $ W.responseBuilder status500 ct $ "Internal Server Error: " <> fromString (show e)+unhandledExceptionHandler :: MonadIO m => Options -> ScottyException -> m W.Response+unhandledExceptionHandler opts = \case+ RequestTooLarge ->+ if jsonMode opts+ then return $ W.responseBuilder status413 ctJson $ + fromLazyByteString $ A.encode $ A.object+ [ "status" A..= (413 :: Int)+ , "description" A..= ("Request is too big Jim!" :: T.Text)+ ]+ else return $ W.responseBuilder status413 ctText "Request is too big Jim!"+ e ->+ if jsonMode opts+ then return $ W.responseBuilder status500 ctJson $ + fromLazyByteString $ A.encode $ A.object+ [ "status" A..= (500 :: Int)+ , "description" A..= ("Internal Server Error: " <> T.pack (show e))+ ]+ else return $ W.responseBuilder status500 ctText $ "Internal Server Error: " <> fromString (show e) where- ct = [("Content-Type", "text/plain")]+ ctText = [("Content-Type", "text/plain")]+ ctJson = [("Content-Type", "application/json; charset=utf-8")] applyAll :: Foldable t => a -> t (a -> a) -> a applyAll = foldl (flip ($)) -notFoundApp :: Monad m => Application m-notFoundApp _ = return $ W.responseBuilder status404 [("Content-Type","text/html")]+notFoundApp :: Monad m => Options -> Application m+notFoundApp opts _ =+ if jsonMode opts+ then return $ W.responseBuilder status404 [("Content-Type","application/json; charset=utf-8")]+ $ fromLazyByteString $ A.encode $ A.object+ [ "status" A..= (404 :: Int)+ , "description" A..= ("File Not Found!" :: T.Text)+ ]+ else return $ W.responseBuilder status404 [("Content-Type","text/html")] $ fromByteString "<h1>404: File Not Found!</h1>" -- | Global handler for user-defined exceptions.
Web/Scotty/Trans/Lazy.hs view
@@ -5,29 +5,11 @@ import Data.Bifunctor (bimap) import qualified Data.Text.Lazy as T -import Network.HTTP.Types (Status)- import qualified Web.Scotty.Action as Base import Web.Scotty.Internal.Types --- | Throw a "500 Server Error" 'StatusError', which can be caught with 'rescue'.------ Uncaught exceptions turn into HTTP 500 responses.-raise :: (MonadIO m) =>- T.Text -- ^ Error text- -> ActionT m a-raise = Base.raise . T.toStrict-{-# DEPRECATED raise "Throw an exception instead" #-}---- | Throw a 'StatusError' exception that has an associated HTTP error code and can be caught with 'rescue'.------ Uncaught exceptions turn into HTTP responses corresponding to the given status.-raiseStatus :: Monad m => Status -> T.Text -> ActionT m a-raiseStatus s = Base.raiseStatus s . T.toStrict-{-# DEPRECATED raiseStatus "Use status, text, and finish instead" #-}---- | Redirect to given URL. Like throwing an uncatchable exception. Any code after the call to redirect--- will not be run.+-- | Synonym for 'redirect302'.+-- If you are unsure which redirect to use, you probably want this one. -- -- > redirect "http://www.google.com" --@@ -35,7 +17,49 @@ -- -- > redirect "/foo/bar" redirect :: (Monad m) => T.Text -> ActionT m a-redirect = Base.redirect . T.toStrict+redirect = redirect302++-- | Redirect to given URL with status 300 (Multiple Choices). Like throwing+-- an uncatchable exception. Any code after the call to+-- redirect will not be run.+redirect300 :: (Monad m) => T.Text -> ActionT m a+redirect300 = Base.redirect300 . T.toStrict++-- | Redirect to given URL with status 301 (Moved Permanently). Like throwing+-- an uncatchable exception. Any code after the call to+-- redirect will not be run.+redirect301 :: (Monad m) => T.Text -> ActionT m a+redirect301 = Base.redirect301 . T.toStrict++-- | Redirect to given URL with status 302 (Found). Like throwing+-- an uncatchable exception. Any code after the call to+-- redirect will not be run.+redirect302 :: (Monad m) => T.Text -> ActionT m a+redirect302 = Base.redirect302 . T.toStrict++-- | Redirect to given URL with status 303 (See Other). Like throwing+-- an uncatchable exception. Any code after the call to+-- redirect will not be run.+redirect303 :: (Monad m) => T.Text -> ActionT m a+redirect303 = Base.redirect303 . T.toStrict++-- | Redirect to given URL with status 304 (Not Modified). Like throwing+-- an uncatchable exception. Any code after the call to+-- redirect will not be run.+redirect304 :: (Monad m) => T.Text -> ActionT m a+redirect304 = Base.redirect304 . T.toStrict++-- | Redirect to given URL with status 307 (Temporary Redirect). Like throwing+-- an uncatchable exception. Any code after the call to+-- redirect will not be run.+redirect307 :: (Monad m) => T.Text -> ActionT m a+redirect307 = Base.redirect307 . T.toStrict++-- | Redirect to given URL with status 308 (Permanent Redirect). Like throwing+-- an uncatchable exception. Any code after the call to+-- redirect will not be run.+redirect308 :: (Monad m) => T.Text -> ActionT m a+redirect308 = Base.redirect308 . T.toStrict -- | Get a request header. Header name is case-insensitive. header :: (Monad m) => T.Text -> ActionT m (Maybe T.Text)
Web/Scotty/Trans/Strict.hs view
@@ -24,13 +24,15 @@ , capture, regex, function, literal -- ** Accessing the Request, Captures, and Query Parameters , request, Base.header, Base.headers, body, bodyReader- , param, params , captureParam, formParam, queryParam , captureParamMaybe, formParamMaybe, queryParamMaybe , captureParams, formParams, queryParams , jsonData, files- -- ** Modifying the Response and Redirecting- , status, Base.addHeader, Base.setHeader, Base.redirect+ -- ** Modifying the Response + , status, Base.addHeader, Base.setHeader+ -- ** Redirecting+ , Base.redirect, Base.redirect300, Base.redirect301, Base.redirect302, Base.redirect303+ , Base.redirect304, Base.redirect307, Base.redirect308 -- ** Setting Response Body -- -- | Note: only one of these should be present in any given route@@ -41,8 +43,7 @@ -- ** Accessing the fields of the Response , getResponseHeaders, getResponseStatus, getResponseContent -- ** Exceptions- , Base.raise, Base.raiseStatus, throw, rescue, next, finish, defaultHandler, liftAndCatchIO- , StatusError(..)+ , throw, next, finish, defaultHandler , ScottyException(..) -- * Parsing Parameters , Param, Parsable(..), readEither
changelog.md view
@@ -1,5 +1,22 @@-## next [????.??.??]+## 0.30 [2026.01.06] +* Added sessions (#317).+* Fixed cookie example from `Cookie` module documentation. `getCookie` Function would return strict variant of `Text`. Will convert it into lazy variant using `fromStrict`. +* Exposed simple functions of `Cookie` module via `Web.Scotty` & `Web.Scotty.Trans`.+* Add tests for URL encoding of query parameters and form parameters. Add `formData` action for decoding `FromForm` instances (#321).+* Add explicit redirect functions for all redirect status codes.+* Added ActionM variants for cookie module functions (#406).+* Updated `Parsable` instance for `Bool` to accept `on` for HTML form checkboxes.+* Add tests demonstrating usage of `Network.Wai.Middleware.ValidateHeaders` from wai-extra for header validation (#359).+* Added `jsonMode` flag to `Options` to return JSON-formatted error responses instead of HTML (#97). When enabled, all default error handlers (404, 500, etc.) return JSON with format `{"status": <code>, "description": "<message>"}`. Content-Type is set to `application/json; charset=utf-8`.+* Added middleware example demonstrating request logging and request header validation using WAI middlewares (#199, #385).++### Breaking changes+* Remove dependency on data-default class (#386). We have been exporting constants for default config values since 0.20, and this dependency was simply unnecessary.+* Remove re-export of `Network.Wai.Parse.ParseRequestBodyOptions` from `Web.Scotty` and `Web.Scotty.Trans`. This is a type from `wai-extra` so exporting it is unnecessary.+* Remove deprecated exports (#408) `liftAndCatchIO`, `param`, `params`, `raise`, `raiseStatus`, `rescue` from `Web.Scotty` and `Web.Scotty.Trans`.+* Remove deprecated `StatusError` type from `Scotty.Internal.Types`.+* Remove typeclass instance `MonadError StatusError (ActionT m)` from `Scotty.Internal.Types`. ## 0.22 [2024.03.09]
examples/cookies.hs view
@@ -5,10 +5,10 @@ import Control.Monad (forM_) import qualified Text.Blaze.Html5 as H-import Text.Blaze.Html5.Attributes-import Text.Blaze.Html.Renderer.Text (renderHtml)-import Web.Scotty-import Web.Scotty.Cookie (CookiesText, setSimpleCookie, getCookies)+import Text.Blaze.Html5.Attributes+import Text.Blaze.Html.Renderer.Text (renderHtml)+import Web.Scotty -- Web.Scotty exports setSimpleCookie,getCookies+import Web.Scotty.Cookie (CookiesText) renderCookiesTable :: CookiesText -> H.Html renderCookiesTable cs =
examples/gzip.hs view
@@ -2,14 +2,14 @@ module Main (main) where import Network.Wai.Middleware.RequestLogger-import Network.Wai.Middleware.Gzip+import Network.Wai.Middleware.Gzip (defaultGzipSettings, GzipSettings(..), GzipFiles(..), gzip) import Web.Scotty main :: IO () main = scotty 3000 $ do -- Note that files are not gzip'd by the default settings.- middleware $ gzip $ def { gzipFiles = GzipCompress }+ middleware $ gzip $ defaultGzipSettings { gzipFiles = GzipCompress } middleware logStdoutDev -- gzip a normal response
+ examples/json_mode.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Example demonstrating JSON mode in Scotty+--+-- By default, Scotty returns HTML error responses. Setting jsonMode = True+-- in Options causes all error responses to be returned as JSON instead.+--+-- To test:+-- cabal run scotty-json-mode+-- curl http://localhost:3000/ # HTML welcome page+-- curl http://localhost:3000/missing # 404 error as HTML+-- curl http://localhost:3000/error # 500 error as HTML (missing path param)+--+-- To enable JSON mode, change `useJsonMode = False` to `useJsonMode = True` below+module Main (main) where++import Web.Scotty+import Data.Aeson (object, (.=))+import qualified Data.Text.Lazy as TL++-- | Toggle this to test JSON mode+useJsonMode :: Bool+useJsonMode = False++main :: IO ()+main = do+ if useJsonMode+ then do+ putStrLn "\n=== Running server with JSON mode ENABLED ==="+ putStrLn "All error responses will be returned as JSON"+ else do+ putStrLn "\n=== Running server with HTML mode (default) ==="+ putStrLn "Error responses will be returned as HTML"+ + putStrLn "\nEndpoints to test:"+ putStrLn " http://localhost:3000/ - Welcome page"+ putStrLn " http://localhost:3000/missing - 404 Not Found"+ putStrLn " http://localhost:3000/error - 500 Internal Server Error"+ putStrLn "\nPress Ctrl+C to stop\n"+ + scottyOpts (defaultOptions { jsonMode = useJsonMode }) $ do+ get "/" $ do+ if useJsonMode+ then json $ object + [ "message" .= ("Welcome! JSON mode is ON" :: TL.Text)+ , "endpoints" .= object + [ "notFound" .= ("/missing" :: String)+ , "error" .= ("/error" :: String)+ ]+ ]+ else html "<h1>Welcome! JSON mode is OFF (default)</h1><ul><li><a href='/missing'>404 Example</a></li><li><a href='/error'>500 Example</a></li></ul>"+ + get "/error" $ do+ -- This will trigger a 500 error because we're trying to access a non-existent path parameter+ _ <- pathParam "nonexistent" :: ActionM TL.Text+ text "This will never be reached"
+ examples/middleware.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE OverloadedStrings #-}+module Main (main) where++import Web.Scotty+import Network.Wai.Middleware.RequestLogger+import Network.Wai.Middleware.ValidateHeaders (validateHeadersMiddleware, defaultValidateHeadersSettings)+import Data.Aeson (object, (.=))+import qualified Data.Text.Lazy as TL+import qualified Data.ByteString.Lazy as BL++main :: IO ()+main = do+ putStrLn "\n=== Scotty Middleware Example ==="+ putStrLn "\nThis example demonstrates two WAI middlewares:"+ putStrLn "1. Request Logging - logs all HTTP requests to stdout"+ putStrLn "2. Header Validation - validates incoming request headers\n"+ putStrLn "The validateHeadersMiddleware checks REQUEST headers from clients."+ putStrLn "It rejects requests with invalid headers (containing illegal characters)"+ putStrLn "such as CR/LF, control characters, or invalid header names.\n"+ putStrLn "Try these requests:"+ putStrLn " curl http://localhost:3000/"+ putStrLn " curl -H 'X-Custom: value' http://localhost:3000/headers"+ putStrLn " curl -H 'X-Token!#$: valid' http://localhost:3000/headers"+ putStrLn "\nTo test invalid headers (these will return 500):"+ putStrLn " curl -H 'Invalid Header: value' http://localhost:3000/ # header name cannot contain spaces"+ putStrLn " Note: Headers with CR/LF in values will also be rejected"+ putStrLn "\nPress Ctrl+C to stop\n"+ + scotty 3000 $ do+ -- Request logging middleware - logs all requests to stdout in development format+ middleware logStdoutDev+ + -- Header validation middleware - validates REQUEST headers to prevent header injection+ -- This middleware checks headers sent by the CLIENT and rejects malformed ones+ -- It validates both header names and values according to HTTP specifications+ middleware $ validateHeadersMiddleware defaultValidateHeadersSettings+ + -- Endpoint group 1: Basic endpoints that demonstrate logging+ get "/" $ do+ text "Welcome! This request was logged by the logging middleware."+ + get "/hello/:name" $ do+ name <- pathParam "name"+ text $ "Hello, " <> name <> "! Check the server logs to see the request details."+ + -- Endpoint group 2: Shows all request headers that passed validation+ get "/headers" $ do+ allHeaders <- headers+ let formatHeader (name, value) = + name <> ": " <> value <> "\n"+ headerList = map formatHeader allHeaders+ text $ mconcat + [ "Your request headers (all validated by middleware):\n\n"+ , mconcat headerList+ , "\nThese headers passed validation. Invalid headers would have been rejected with 500.\n"+ , "Try sending a request with invalid headers to see the middleware in action."+ ]+ + -- Endpoint group 3: Demonstrates specific header inspection+ get "/user-agent" $ do+ agent <- header "User-Agent"+ case agent of+ Just ua -> text $ "Your User-Agent: " <> ua+ Nothing -> text "No User-Agent header provided"+ + -- Endpoint group 4: POST request to demonstrate logging of different methods+ post "/echo" $ do+ requestBody <- body+ text $ "Request body received (" <> TL.pack (show (BL.length requestBody)) <> " bytes). Check server logs for details."+ + -- Endpoint group 5: JSON response with logging+ get "/json" $ do+ json $ object + [ "message" .= ("All request headers were validated" :: String)+ , "middleware" .= object+ [ "logging" .= ("logStdoutDev" :: String)+ , "validation" .= ("validateHeadersMiddleware" :: String)+ ]+ ]
+ examples/session.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE OverloadedStrings #-}+module Main (main) where++import Web.Scotty+import qualified Data.Text.Lazy as LT+import qualified Data.Text as T++main :: IO ()+main = do+ sessionJar <- liftIO createSessionJar :: IO (SessionJar T.Text)+ scotty 3000 $ do+ -- Login route+ get "/login" $ do+ username <- queryParam "username" :: ActionM String+ password <- queryParam "password" :: ActionM String+ if username == "foo" && password == "bar"+ then do+ _ <- createUserSession sessionJar Nothing "foo"+ text "Login successful!"+ else+ text "Invalid username or password."+ -- Dashboard route+ get "/dashboard" $ do+ mUser <- readUserSession sessionJar+ case mUser of+ Nothing -> text "Hello, user."+ Just userName -> text $ "Hello, " <> LT.fromStrict userName <> "."+ -- Logout route+ get "/logout" $ do+ deleteCookie "sess_id"+ text "Logged out successfully."
scotty.cabal view
@@ -1,5 +1,5 @@ Name: scotty-Version: 0.22+Version: 0.30 Synopsis: Haskell web framework inspired by Ruby's Sinatra, using WAI and Warp Homepage: https://github.com/scotty-web/scotty Bug-reports: https://github.com/scotty-web/scotty/issues@@ -64,6 +64,7 @@ Web.Scotty.Trans.Strict Web.Scotty.Internal.Types Web.Scotty.Cookie+ Web.Scotty.Session other-modules: Web.Scotty.Action Web.Scotty.Body Web.Scotty.Route@@ -75,13 +76,14 @@ blaze-builder >= 0.3.3.0 && < 0.5, bytestring >= 0.10.0.2 , case-insensitive >= 1.0.0.1 && < 1.3,+ containers >= 0.5 && < 0.8, cookie >= 0.4,- data-default-class >= 0.1, exceptions >= 0.7 && < 0.11,+ http-api-data < 0.7, http-types >= 0.9.1 && < 0.13, monad-control >= 1.0.0.3 && < 1.1, mtl >= 2.1.2 && < 2.4,- network >= 2.6.0.2 && < 3.2,+ network >= 2.6.0.2 && < 3.3, regex-compat >= 0.95.1 && < 0.96, resourcet, stm,@@ -90,9 +92,11 @@ transformers >= 0.3.0.0 && < 0.7, transformers-base >= 0.4.1 && < 0.5, unliftio >= 0.2,+ unordered-containers >= 0.2.10.0 && < 0.3, wai >= 3.0.0 && < 3.3, wai-extra >= 3.1.14,- warp >= 3.0.13 && < 3.4+ warp >= 3.0.13,+ random >= 1.0.0.0 if impl(ghc < 8.0) build-depends: fail@@ -100,7 +104,7 @@ if impl(ghc < 7.10) build-depends: nats >= 0.1 && < 2 - GHC-options: -Wall -fno-warn-orphans+ GHC-options: -Wall -fno-warn-orphans -Wno-unused-imports test-suite spec main-is: Spec.hs@@ -115,6 +119,7 @@ directory, hspec == 2.*, hspec-wai >= 0.6.3,+ http-api-data, http-types, lifted-base, network,
test/Web/ScottySpec.hs view
@@ -1,28 +1,37 @@-{-# LANGUAGE OverloadedStrings, CPP, ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings, CPP, ScopedTypeVariables, DeriveGeneric #-} module Web.ScottySpec (main, spec) where import Test.Hspec-import Test.Hspec.Wai (with, request, get, post, put, patch, delete, options, (<:>), shouldRespondWith, postHtmlForm, matchHeaders, matchBody, matchStatus)+import Test.Hspec.Wai (WaiSession, with, request, get, post, put, patch, delete, options, (<:>), shouldRespondWith, matchHeaders, matchBody, matchStatus) import Test.Hspec.Wai.Extra (postMultipartForm, FileMeta(..)) import Control.Applicative import Control.Monad import Data.Char import Data.String+import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL+import qualified Data.Text as T import qualified Data.Text.Lazy.Encoding as TLE import Data.Time (UTCTime(..)) import Data.Time.Calendar (fromGregorian) import Data.Time.Clock (secondsToDiffTime) +import GHC.Generics (Generic)+ import Network.HTTP.Types import Network.Wai (Application, Request(queryString), responseLBS)+import Network.Wai.Middleware.ValidateHeaders (validateHeadersMiddleware, defaultValidateHeadersSettings) import Network.Wai.Parse (defaultParseRequestBodyOptions)+import Network.Wai.Test (SResponse) import qualified Control.Exception.Lifted as EL import qualified Control.Exception as E +import Web.FormUrlEncoded (FromForm) import Web.Scotty as Scotty hiding (get, post, put, patch, delete, request, options) import qualified Web.Scotty as Scotty+import Web.Scotty.Trans (scottyAppT) -- for testing JSON mode with custom Options+import Web.Scotty (ScottyException(..)) import qualified Web.Scotty.Cookie as SC (getCookie, setSimpleCookie, deleteCookie) #if !defined(mingw32_HOST_OS)@@ -30,6 +39,7 @@ import Control.Exception (bracketOnError) import qualified Data.ByteString as BS import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as LBS import Network.Socket (Family(..), SockAddr(..), Socket, SocketOption(..), SocketType(..), bind, close, connect, listen, maxListenQueue, setSocketOption, socket) import Network.Socket.ByteString (send, recv) import System.Directory (removeFile)@@ -41,6 +51,16 @@ availableMethods :: [StdMethod] availableMethods = [GET, POST, HEAD, PUT, PATCH, DELETE, OPTIONS] +data SearchForm = SearchForm+ { sfQuery :: Text+ , sfYear :: Int+ } deriving (Generic)++instance FromForm SearchForm where++postForm :: ByteString -> LBS.ByteString -> WaiSession st SResponse+postForm p = request "POST" p [("Content-Type","application/x-www-form-urlencoded")]+ spec :: Spec spec = do let withApp = with . scottyApp@@ -130,7 +150,57 @@ it "catches an exception after the handler is set" $ do get "/b" `shouldRespondWith` "ok" {matchStatus = 503} + context "custom handlers and HTTP status codes (issue noted by user)" $ do+ withApp (do+ let h = Handler (\(_ :: ScottyException) -> text "Custom error message")+ defaultHandler h+ Scotty.post "/missing-body" $ do+ _ <- jsonData :: ActionM Int+ text "ok"+ ) $ do+ it "custom handler catches exception before status is set (returns 200)" $ do+ -- Note: This demonstrates the issue where custom handlers lose the original status+ -- The scottyExceptionHandler would set 400, but custom handler runs first+ post "/missing-body" "" `shouldRespondWith` "Custom error message" {matchStatus = 200} + withApp (do+ let h = Handler (\(e :: ScottyException) -> do+ case e of+ MalformedJSON _ _ -> status status400+ QueryParameterNotFound _ -> status status400+ PathParameterNotFound _ -> status status500+ _ -> status status500+ text "Custom error with status")+ defaultHandler h+ Scotty.post "/missing-body" $ do+ _ <- jsonData :: ActionM Int+ text "ok"+ ) $ do+ it "custom handler can manually set appropriate status" $ do+ -- This shows the workaround: custom handlers must explicitly set status+ post "/missing-body" "" `shouldRespondWith` "Custom error with status" {matchStatus = 400}++ withApp (do+ let h = Handler (\(_ :: ScottyException) -> text "Query error")+ defaultHandler h+ Scotty.get "/needs-param" $ do+ _ <- queryParam "missing" :: ActionM Int+ text "ok"+ ) $ do+ it "query parameter exception also returns 200 without explicit status" $ do+ get "/needs-param" `shouldRespondWith` "Query error" {matchStatus = 200}++ withApp (do+ let h = Handler (\(_ :: ScottyException) -> text "Path error")+ defaultHandler h+ Scotty.get "/path/:id" $ do+ _ <- pathParam "nonexistent" :: ActionM Int+ text "ok"+ ) $ do+ it "path parameter exception also returns 200 without explicit status" $ do+ get "/path/123" `shouldRespondWith` "Path error" {matchStatus = 200}++ describe "setMaxRequestBodySize" $ do let large = TLE.encodeUtf8 . TL.pack . concat $ [show c | c <- ([1..4500]::[Integer])]@@ -170,6 +240,90 @@ it "returns query parameter with given name" $ do get "/search" `shouldRespondWith` "haskell" + context "ValidateHeaders middleware" $ do+ context "rejects invalid header values" $ do+ withApp (do+ Scotty.middleware $ validateHeadersMiddleware defaultValidateHeadersSettings+ Scotty.get "/test" $ do+ setHeader "X-Custom" "value\r\nwith\r\nnewlines"+ text "should not reach here"+ ) $ do+ it "returns 500 when header value contains CR/LF" $ do+ get "/test" `shouldRespondWith` 500++ withApp (do+ Scotty.middleware $ validateHeadersMiddleware defaultValidateHeadersSettings+ Scotty.get "/test" $ do+ setHeader "X-Custom" "value\nwith\nnewlines"+ text "should not reach here"+ ) $ do+ it "returns 500 when header value contains LF" $ do+ get "/test" `shouldRespondWith` 500++ withApp (do+ Scotty.middleware $ validateHeadersMiddleware defaultValidateHeadersSettings+ Scotty.get "/test" $ do+ setHeader "X-Custom" "value\0with\0null"+ text "should not reach here"+ ) $ do+ it "returns 500 when header value contains NUL" $ do+ get "/test" `shouldRespondWith` 500++ withApp (do+ Scotty.middleware $ validateHeadersMiddleware defaultValidateHeadersSettings+ Scotty.get "/test" $ do+ setHeader "X-Custom" "trailing space "+ text "should not reach here"+ ) $ do+ it "returns 500 when header value has trailing whitespace" $ do+ get "/test" `shouldRespondWith` 500++ withApp (do+ Scotty.middleware $ validateHeadersMiddleware defaultValidateHeadersSettings+ Scotty.get "/test" $ do+ setHeader "X-Custom" " leading space"+ text "should not reach here"+ ) $ do+ it "returns 500 when header value has leading whitespace" $ do+ get "/test" `shouldRespondWith` 500++ context "allows valid header values" $ do+ withApp (do+ Scotty.middleware $ validateHeadersMiddleware defaultValidateHeadersSettings+ Scotty.get "/test" $ do+ setHeader "X-Custom" "valid-value"+ text "success"+ ) $ do+ it "returns 200 when header value is valid" $ do+ get "/test" `shouldRespondWith` "success" {matchStatus = 200}++ withApp (do+ Scotty.middleware $ validateHeadersMiddleware defaultValidateHeadersSettings+ Scotty.get "/test" $ do+ setHeader "X-Custom" "value with spaces"+ text "success"+ ) $ do+ it "returns 200 when header value contains internal spaces" $ do+ get "/test" `shouldRespondWith` "success" {matchStatus = 200}++ withApp (do+ Scotty.middleware $ validateHeadersMiddleware defaultValidateHeadersSettings+ Scotty.get "/test" $ do+ setHeader "Content-Type" "text/plain; charset=utf-8"+ text "success"+ ) $ do+ it "returns 200 for standard Content-Type header" $ do+ get "/test" `shouldRespondWith` 200++ context "can be disabled by not adding the middleware" $ do+ withApp (do+ Scotty.get "/test" $ do+ setHeader "X-Custom" "value\r\nwith\r\nnewlines"+ text "no validation"+ ) $ do+ it "allows invalid headers when middleware is not enabled" $ do+ get "/test" `shouldRespondWith` "no validation" {matchStatus = 200}+ describe "ActionM" $ do context "MonadBaseControl instance" $ do withApp (Scotty.get "/" $ (undefined `EL.catch` ((\_ -> html "") :: E.SomeException -> ActionM ()))) $ do@@ -195,8 +349,10 @@ withApp (Scotty.get "/" $ fail "boom!") $ do it "returns 500 if not caught" $ get "/" `shouldRespondWith` 500- withApp (Scotty.get "/" $ (fail "boom!") `catch` (\(_ :: StatusError) -> text "ok")) $- it "can catch the StatusError thrown by fail" $ do+ withApp (Scotty.get "/" $ fail "boom!" `catch` (\(_ :: E.SomeException) -> do + status status200+ text "ok")) $+ it "can catch the Exception thrown by fail" $ do get "/" `shouldRespondWith` 200 { matchBody = "ok"} describe "redirect" $ do@@ -207,6 +363,64 @@ it "Responds with a 302 Redirect" $ do get "/a" `shouldRespondWith` 302 { matchHeaders = ["Location" <:> "/b"] } + describe "redirect300" $ do+ withApp (+ do+ Scotty.get "/a" $ redirect300 "/b"+ ) $ do+ it "Responds with a 300 Redirect" $ do+ get "/a" `shouldRespondWith` 300 { matchHeaders = ["Location" <:> "/b"] }+++ describe "redirect301" $ do+ withApp (+ do+ Scotty.get "/a" $ redirect301 "/b"+ ) $ do+ it "Responds with a 301 Redirect" $ do+ get "/a" `shouldRespondWith` 301 { matchHeaders = ["Location" <:> "/b"] }++ describe "redirect302" $ do+ withApp (+ do+ Scotty.get "/a" $ redirect302 "/b"+ ) $ do+ it "Responds with a 302 Redirect" $ do+ get "/a" `shouldRespondWith` 302 { matchHeaders = ["Location" <:> "/b"] }+++ describe "redirect303" $ do+ withApp (+ do+ Scotty.delete "/a" $ redirect303 "/b"+ ) $ do+ it "Responds with a 303 as passed in" $ do+ delete "/a" `shouldRespondWith` 303 { matchHeaders = ["Location" <:> "/b"]}++ describe "redirect304" $ do+ withApp (+ do+ Scotty.get "/a" $ redirect304 "/b"+ ) $ do+ it "Responds with a 304 Redirect" $ do+ get "/a" `shouldRespondWith` 304 { matchHeaders = ["Location" <:> "/b"] }++ describe "redirect307" $ do+ withApp (+ do+ Scotty.get "/a" $ redirect307 "/b"+ ) $ do+ it "Responds with a 307 Redirect" $ do+ get "/a" `shouldRespondWith` 307 { matchHeaders = ["Location" <:> "/b"] }++ describe "redirect308" $ do+ withApp (+ do+ Scotty.get "/a" $ redirect308 "/b"+ ) $ do+ it "Responds with a 308 Redirect" $ do+ get "/a" `shouldRespondWith` 308 { matchHeaders = ["Location" <:> "/b"] }+ describe "Parsable" $ do it "parses a UTCTime string" $ do parseParam "2023-12-18T00:38:00Z" `shouldBe` Right (UTCTime (fromGregorian 2023 12 18) (secondsToDiffTime (60 * 38)) )@@ -255,6 +469,8 @@ withApp (Scotty.get "/search" $ queryParam "query" >>= text) $ do it "returns query parameter with given name" $ do get "/search?query=haskell" `shouldRespondWith` "haskell"+ it "decodes URL-encoding" $ do+ get "/search?query=Kurf%C3%BCrstendamm" `shouldRespondWith` "Kurfürstendamm" withApp (Scotty.matchAny "/search" (do v <- queryParam "query" json (v :: Int) )) $ do@@ -268,16 +484,28 @@ ) $ do it "catches a ScottyException" $ do get "/search?query=potato" `shouldRespondWith` 200 { matchBody = "z"}+ + describe "formData" $ do+ withApp (Scotty.post "/search" $ formData >>= (text . sfQuery)) $ do+ it "decodes the form" $ do+ postForm "/search" "sfQuery=Haskell&sfYear=2024" `shouldRespondWith` "Haskell" + it "decodes URL-encoding" $ do+ postForm "/search" "sfQuery=Kurf%C3%BCrstendamm&sfYear=2024" `shouldRespondWith` "Kurfürstendamm"++ it "returns 400 when the form is malformed" $ do+ postForm "/search" "sfQuery=Haskell" `shouldRespondWith` 400+ describe "formParam" $ do- let- postForm p bdy = request "POST" p [("Content-Type","application/x-www-form-urlencoded")] bdy withApp (Scotty.post "/search" $ formParam "query" >>= text) $ do it "returns form parameter with given name" $ do postForm "/search" "query=haskell" `shouldRespondWith` "haskell" it "replaces non UTF-8 bytes with Unicode replacement character" $ do postForm "/search" "query=\xe9" `shouldRespondWith` "\xfffd"++ it "decodes URL-encoding" $ do+ postForm "/search" "query=Kurf%C3%BCrstendamm" `shouldRespondWith` "Kurfürstendamm" withApp (Scotty.post "/search" (do v <- formParam "query" json (v :: Int))) $ do@@ -285,6 +513,15 @@ postForm "/search" "query=42" `shouldRespondWith` 200 it "responds with 400 Bad Request if the form parameter cannot be parsed at the right type" $ do postForm "/search" "query=potato" `shouldRespondWith` 400+ withApp (Scotty.post "/checkbox" (do+ e <- formParam "enabled"+ json (e :: Bool))) $ do+ it "responds with 200 OK if the checkbox parameter can be parsed at the right type" $ do+ postForm "/checkbox" "enabled=true" `shouldRespondWith` 200+ postForm "/checkbox" "enabled=on" `shouldRespondWith` 200+ postForm "/checkbox" "enabled=false" `shouldRespondWith` 200+ it "responds with 400 Bad Request if the checkbox parameter cannot be parsed at the right type" $ do+ postForm "/checkbox" "enabled=undefined" `shouldRespondWith` 400 withApp (do Scotty.post "/" $ next@@ -354,7 +591,7 @@ describe "filesOpts" $ do let- postForm = postMultipartForm "/files" "ABC123" [+ postMpForm = postMultipartForm "/files" "ABC123" [ (FMFile "file1.txt", "text/plain;charset=UTF-8", "first_file", "xxx"), (FMFile "file2.txt", "text/plain;charset=UTF-8", "second_file", "yyy") ]@@ -364,13 +601,13 @@ withApp (Scotty.post "/files" processForm ) $ do it "loads uploaded files in memory" $ do- postForm `shouldRespondWith` 200 { matchBody = "2"}+ postMpForm `shouldRespondWith` 200 { matchBody = "2"} context "preserves the body of a POST request even after 'next' (#147)" $ do withApp (do Scotty.post "/files" next Scotty.post "/files" processForm) $ do it "loads uploaded files in memory" $ do- postForm `shouldRespondWith` 200 { matchBody = "2"}+ postMpForm `shouldRespondWith` 200 { matchBody = "2"} describe "text" $ do@@ -449,6 +686,48 @@ withApp (Scotty.get "/nested" (nested simpleApp)) $ do it "responds with the expected simpleApp response" $ do get "/nested" `shouldRespondWith` 200 {matchHeaders = ["Content-Type" <:> "text/plain"], matchBody = "Hello, Web!"}+ + describe "Session Management" $ do+ withApp (Scotty.get "/scotty" $ do+ sessionJar <- liftIO createSessionJar + sess <- createUserSession sessionJar Nothing ("foo" :: T.Text)+ mRes <- readSession sessionJar (sessId sess)+ case mRes of+ Left _ -> Scotty.status status400+ Right res -> do + if res /= "foo" then Scotty.status status400+ else text "all good"+ ) $ do+ it "Roundtrip of session by adding and fetching a value" $ do+ get "/scotty" `shouldRespondWith` 200++ describe "JSON Mode" $ do+ let scottyAppJson = scottyAppT (defaultOptions { jsonMode = True }) id+ let withJsonApp = with . scottyAppJson+ + describe "notFound" $ do+ context "when JSON mode is enabled" $ do+ withJsonApp (return ()) $ do+ it "returns 404 with JSON response" $ do+ get "/" `shouldRespondWith` 404 {matchHeaders = ["Content-Type" <:> "application/json; charset=utf-8"]}++ describe "exception handlers" $ do+ context "when JSON mode is enabled" $ do+ withJsonApp (Scotty.get "/" $ throw E.DivideByZero) $ do+ it "returns 500 with JSON response for unhandled exceptions" $ do+ get "/" `shouldRespondWith` 500 {matchHeaders = ["Content-Type" <:> "application/json; charset=utf-8"]}++ withJsonApp (Scotty.get "/param/:id" $ do+ (_ :: Int) <- pathParam "nonexistent"+ text "ok") $ do+ it "returns 500 with JSON response for missing path parameter" $ do+ get "/param/test" `shouldRespondWith` 500 {matchHeaders = ["Content-Type" <:> "application/json; charset=utf-8"]}++ withJsonApp (Scotty.get "/query" $ do+ (_ :: Int) <- queryParam "missing"+ text "ok") $ do+ it "returns 400 with JSON response for missing query parameter" $ do+ get "/query" `shouldRespondWith` 400 {matchHeaders = ["Content-Type" <:> "application/json; charset=utf-8"]} -- Unix sockets not available on Windows #if !defined(mingw32_HOST_OS)