diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -8,7 +8,7 @@ main = scotty 3000 $ get "/:word" $ do - beam <- captureParam "word" + beam <- pathParam "word" html $ mconcat ["

Scotty, ", beam, " me up!

"] ``` @@ -19,15 +19,44 @@ * Conforms to the [web application interface (WAI)](https://github.com/yesodweb/wai/). * Uses the very fast Warp webserver by default. -See examples/basic.hs to see Scotty in action. (basic.hs needs the wai-extra package) +As for the name: Sinatra + Warp = Scotty. +## Examples + +Run /basic.hs to see Scotty in action: + ```bash -> runghc examples/basic.hs -Setting phasers to stun... (port 3000) (ctrl-c to quit) -(visit localhost:3000/somepath) +runghc examples/basic.hs ``` +`Setting phasers to stun... (port 3000) (ctrl-c to quit)` -As for the name: Sinatra + Warp = Scotty. +Or equivalently with [`stack`](https://docs.haskellstack.org/en/stable/): + +```bash +stack exec -- scotty-basic +``` + +Once the server is running you can interact with it with curl or a browser: + +```bash +curl localhost:3000 +``` +`foobar` + +```bash +curl localhost:3000/foo_query?p=42 +``` +`

42

` + + +Additionally, the `examples` directory shows a number of concrete use cases, e.g. + +* [exception handling](./examples/exceptions.hs) +* [global state](./examples/globalstate.hs) +* [configuration](./examples/reader.hs) +* [cookies](./examples/cookies.hs) +* [file upload](./examples/upload.hs) +* and more ## More Information diff --git a/Web/Scotty.hs b/Web/Scotty.hs --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -5,9 +5,16 @@ -- Scotty is set up by default for development mode. For production servers, -- you will likely want to modify 'Trans.settings' and the 'defaultHandler'. See -- the comments on each of these functions for more information. +-- +-- Please refer to the @examples@ directory and the @spec@ test suite for concrete use cases, e.g. constructing responses, exception handling and useful implementation details. module Web.Scotty - ( -- * scotty-to-WAI - scotty, scottyApp, scottyOpts, scottySocket, Options(..), defaultOptions + ( -- * Running 'scotty' servers + scotty + , scottyOpts + , scottySocket + , Options(..), defaultOptions + -- ** scotty-to-WAI + , scottyApp -- * Defining Middleware and Routes -- -- | 'Middleware' and routes are run in the order in which they @@ -16,12 +23,14 @@ , middleware, get, post, put, delete, patch, options, addroute, matchAny, notFound, nested, setMaxRequestBodySize -- ** Route Patterns , capture, regex, function, literal - -- ** Accessing the Request, Captures, and Query Parameters + -- ** Accessing the Request and its fields , request, header, headers, body, bodyReader - , param, params - , captureParam, formParam, queryParam - , captureParams, formParams, queryParams , jsonData, files + -- ** Accessing Path, Form and Query Parameters + , param, params + , pathParam, captureParam, formParam, queryParam + , pathParamMaybe, captureParamMaybe, formParamMaybe, queryParamMaybe + , pathParams, captureParams, formParams, queryParams -- ** Modifying the Response and Redirecting , status, addHeader, setHeader, redirect -- ** Setting Response Body @@ -29,32 +38,65 @@ -- | Note: only one of these should be present in any given route -- definition, as they completely replace the current 'Response' body. , text, html, file, json, stream, raw + -- ** Accessing the fields of the Response + , getResponseHeaders, getResponseStatus, getResponseContent -- ** Exceptions , raise, raiseStatus, throw, rescue, next, finish, defaultHandler, liftAndCatchIO + , liftIO, catch , StatusError(..) + , ScottyException(..) -- * Parsing Parameters , Param, Trans.Parsable(..), Trans.readEither -- * Types - , ScottyM, ActionM, RoutePattern, File, Kilobytes, Handler(..) + , ScottyM, ActionM, RoutePattern, File, Content(..), Kilobytes, ErrorHandler, Handler(..) , ScottyState, defaultScottyState ) where import qualified Web.Scotty.Trans as Trans import qualified Control.Exception as E +import Control.Monad.IO.Class import Data.Aeson (FromJSON, ToJSON) import qualified Data.ByteString as BS import Data.ByteString.Lazy.Char8 (ByteString) -import Data.Text.Lazy (Text) +import Data.Text.Lazy (Text, toStrict) -import Network.HTTP.Types (Status, StdMethod) +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 Web.Scotty.Internal.Types (ScottyT, ActionT, ErrorHandler, Param, RoutePattern, Options, defaultOptions, File, Kilobytes, ScottyState, defaultScottyState, StatusError(..)) -import Web.Scotty.Exceptions (Handler(..)) +import Web.Scotty.Internal.Types (ScottyT, ActionT, ErrorHandler, Param, RoutePattern, Options, defaultOptions, File, Kilobytes, ScottyState, defaultScottyState, ScottyException, StatusError(..), Content(..)) +import UnliftIO.Exception (Handler(..), catch) +{- $setup +>>> :{ +import Control.Monad.IO.Class (MonadIO(..)) +import qualified Network.HTTP.Client as H +import qualified Network.HTTP.Types as H +import qualified Network.Wai as W (httpVersion) +import qualified Data.ByteString.Lazy.Char8 as LBS (unpack) +import qualified Data.Text as T (pack) +import Control.Concurrent (ThreadId, forkIO, killThread) +import Control.Exception (bracket) +import qualified Web.Scotty as S (ScottyM, scottyOpts, get, text, regex, pathParam, Options(..), defaultOptions) +-- | GET an HTTP path +curl :: MonadIO m => + String -- ^ path + -> m String -- ^ response body +curl path = liftIO $ do + req0 <- H.parseRequest path + let req = req0 { H.method = "GET"} + mgr <- H.newManager H.defaultManagerSettings + (LBS.unpack . H.responseBody) <$> H.httpLbs req mgr +-- | Fork a process, run a Scotty server in it and run an action while the server is running. Kills the scotty thread once the inner action is done. +withScotty :: S.ScottyM () + -> IO a -- ^ inner action, e.g. 'curl "localhost:3000/"' + -> IO a +withScotty serv act = bracket (forkIO $ S.scottyOpts (S.defaultOptions{ S.verbose = 0 }) serv) killThread (\_ -> act) +:} +-} + type ScottyM = ScottyT IO type ActionM = ActionT IO @@ -104,19 +146,21 @@ setMaxRequestBodySize :: Kilobytes -> ScottyM () setMaxRequestBodySize = Trans.setMaxRequestBodySize --- | Throw a "500 Server Error" 'StatusError', which can be caught with 'rescue'. +-- | 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 'rescue'. +-- | 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 'rescue' or 'catch'. +-- | 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. -- @@ -134,12 +178,12 @@ -- ever run is if the first one calls 'next'. -- -- > get "/foo/:bar" $ do --- > w :: Text <- captureParam "bar" +-- > w :: Text <- pathParam "bar" -- > unless (w == "special") next -- > text "You made a request to /foo/special" -- > -- > get "/foo/:baz" $ do --- > w <- captureParam "baz" +-- > w <- pathParam "baz" -- > text $ "You made a request to: " <> w next :: ActionM () next = Trans.next @@ -151,7 +195,7 @@ -- content the text message. -- -- > get "/foo/:bar" $ do --- > w :: Text <- captureParam "bar" +-- > w :: Text <- pathParam "bar" -- > unless (w == "special") finish -- > text "You made a request to /foo/special" -- @@ -161,13 +205,15 @@ -- | Catch an exception e.g. a 'StatusError' or a user-defined exception. -- --- > raise JustKidding `rescue` (\msg -> text msg) +-- > 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. @@ -212,47 +258,97 @@ -- | Get a parameter. First looks in captures, then form data, then query parameters. -- --- * Raises an exception which can be caught by 'rescue' if parameter is not found. +-- * Raises an exception which can be caught by 'catch' if parameter is not found. -- -- * 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 -{-# DEPRECATED param "(#204) Not a good idea to treat all parameters identically. Use captureParam, formParam and queryParam instead. "#-} +param = Trans.param . toStrict +{-# DEPRECATED param "(#204) Not a good idea to treat all parameters identically. Use pathParam, formParam and queryParam instead. "#-} --- | Get a capture parameter. +-- | Synonym for 'pathParam' -- --- * Raises an exception which can be caught by 'rescue' if parameter is not found. If the exception is not caught, scotty will return a HTTP error code 500 ("Internal Server Error") to the client. +-- /Since: 0.20/ +captureParam :: Trans.Parsable a => Text -> ActionM a +captureParam = Trans.captureParam . toStrict + +-- | Get a path parameter. -- +-- * Raises an exception which can be caught by 'catch' if parameter is not found. If the exception is not caught, scotty will return a HTTP error code 500 ("Internal Server Error") to the client. +-- -- * If the parameter is found, but 'parseParam' fails to parse to the correct type, 'next' is called. -captureParam :: Trans.Parsable a => Text -> ActionM a -captureParam = Trans.captureParam +-- +-- /Since: 0.21/ +pathParam :: Trans.Parsable a => Text -> ActionM a +pathParam = Trans.pathParam . toStrict -- | Get a form parameter. -- --- * Raises an exception which can be caught by 'rescue' if parameter is not found. If the exception is not caught, scotty will return a HTTP error code 400 ("Bad Request") to the client. +-- * Raises an exception which can be caught by 'catch' if parameter is not found. If the exception is not caught, scotty will return a HTTP error code 400 ("Bad Request") to the client. -- -- * 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 :: Trans.Parsable a => Text -> ActionM a -formParam = Trans.formParam +formParam = Trans.formParam . toStrict -- | Get a query parameter. -- --- * Raises an exception which can be caught by 'rescue' if parameter is not found. If the exception is not caught, scotty will return a HTTP error code 400 ("Bad Request") to the client. +-- * Raises an exception which can be caught by 'catch' if parameter is not found. If the exception is not caught, scotty will return a HTTP error code 400 ("Bad Request") to the client. -- -- * This function raises a code 400 also if the parameter is found, but 'parseParam' fails to parse to the correct type. +-- +-- /Since: 0.20/ queryParam :: Trans.Parsable a => Text -> ActionM a -queryParam = Trans.queryParam +queryParam = Trans.queryParam . toStrict --- | Get all parameters from capture, form and query (in that order). + +-- | Look up a path parameter. Returns 'Nothing' if the parameter is not found or cannot be parsed at the right type. +-- +-- NB : Doesn't throw exceptions. In particular, route pattern matching will not continue, so developers +-- must 'raiseStatus' or 'throw' to signal something went wrong. +-- +-- /Since: 0.21/ +pathParamMaybe :: (Trans.Parsable a) => Text -> ActionM (Maybe a) +pathParamMaybe = Trans.pathParamMaybe . toStrict + +-- | Synonym for 'pathParamMaybe' +-- +-- /Since: 0.21/ +captureParamMaybe :: (Trans.Parsable a) => Text -> ActionM (Maybe a) +captureParamMaybe = Trans.pathParamMaybe . toStrict + +-- | Look up a form parameter. Returns 'Nothing' if the parameter is not found or cannot be parsed at the right type. +-- +-- NB : Doesn't throw exceptions, so developers must 'raiseStatus' or 'throw' to signal something went wrong. +-- +-- /Since: 0.21/ +formParamMaybe :: (Trans.Parsable a) => Text -> ActionM (Maybe a) +formParamMaybe = Trans.formParamMaybe . toStrict + +-- | Look up a query parameter. Returns 'Nothing' if the parameter is not found or cannot be parsed at the right type. +-- +-- NB : Doesn't throw exceptions, so developers must 'raiseStatus' or 'throw' to signal something went wrong. +-- +-- /Since: 0.21/ +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 captureParams, formParams and queryParams instead. "#-} +{-# DEPRECATED params "(#204) Not a good idea to treat all parameters identically. Use pathParams, formParams and queryParams instead. "#-} --- | Get capture parameters +-- | Synonym for 'pathParams' captureParams :: ActionM [Param] captureParams = Trans.captureParams +-- | Get path parameters +pathParams :: ActionM [Param] +pathParams = Trans.pathParams -- | Get form parameters formParams :: ActionM [Param] formParams = Trans.formParams @@ -305,6 +401,24 @@ raw :: ByteString -> ActionM () raw = Trans.raw + +-- | Access the HTTP 'Status' of the Response +-- +-- /Since: 0.21/ +getResponseStatus :: ActionM Status +getResponseStatus = Trans.getResponseStatus +-- | Access the HTTP headers of the Response +-- +-- /Since: 0.21/ +getResponseHeaders :: ActionM ResponseHeaders +getResponseHeaders = Trans.getResponseHeaders +-- | Access the content of the Response +-- +-- /Since: 0.21/ +getResponseContent :: ActionM Content +getResponseContent = Trans.getResponseContent + + -- | get = 'addroute' 'GET' get :: RoutePattern -> ActionM () -> ScottyM () get = Trans.get @@ -338,35 +452,37 @@ notFound :: ActionM () -> ScottyM () notFound = Trans.notFound --- | Define a route with a 'StdMethod', 'Text' value representing the path spec, --- and a body ('Action') which modifies the response. --- --- > addroute GET "/" $ text "beam me up!" --- --- The path spec can include values starting with a colon, which are interpreted --- as /captures/. These are named wildcards that can be looked up with 'param'. --- --- > addroute GET "/foo/:bar" $ do --- > v <- param "bar" --- > text v --- --- >>> curl http://localhost:3000/foo/something --- something +{- | Define a route with a 'StdMethod', a route pattern representing the path spec, +and an 'Action' which may modify the response. + +> get "/" $ text "beam me up!" + +The path spec can include values starting with a colon, which are interpreted +as /captures/. These are parameters that can be looked up with 'pathParam'. + +>>> :{ +let server = S.get "/foo/:bar" (S.pathParam "bar" >>= S.text) + in do + withScotty server $ curl "http://localhost:3000/foo/something" +:} +"something" +-} addroute :: StdMethod -> RoutePattern -> ActionM () -> ScottyM () addroute = Trans.addroute --- | Match requests using a regular expression. --- Named captures are not yet supported. --- --- > get (regex "^/f(.*)r$") $ do --- > path <- param "0" --- > cap <- param "1" --- > text $ mconcat ["Path: ", path, "\nCapture: ", cap] --- --- >>> curl http://localhost:3000/foo/bar --- Path: /foo/bar --- Capture: oo/ba --- + +{- | Match requests using a regular expression. +Named captures are not yet supported. + +>>> :{ +let server = S.get (S.regex "^/f(.*)r$") $ do + cap <- S.pathParam "1" + S.text cap + in do + withScotty server $ curl "http://localhost:3000/foo/bar" +:} +"oo/ba" +-} regex :: String -> RoutePattern regex = Trans.regex @@ -385,21 +501,27 @@ capture :: String -> RoutePattern capture = Trans.capture --- | Build a route based on a function which can match using the entire 'Request' object. --- 'Nothing' indicates the route does not match. A 'Just' value indicates --- a successful match, optionally returning a list of key-value pairs accessible --- by 'param'. --- --- > get (function $ \req -> Just [("version", pack $ show $ httpVersion req)]) $ do --- > v <- param "version" --- > text v --- --- >>> curl http://localhost:3000/ --- HTTP/1.1 --- + +{- | Build a route based on a function which can match using the entire 'Request' object. +'Nothing' indicates the route does not match. A 'Just' value indicates +a successful match, optionally returning a list of key-value pairs accessible by 'param'. + +>>> :{ +let server = S.get (function $ \req -> Just [("version", T.pack $ show $ W.httpVersion req)]) $ do + v <- S.pathParam "version" + S.text v + in do + withScotty server $ curl "http://localhost:3000/" +:} +"HTTP/1.1" +-} function :: (Request -> Maybe [Param]) -> RoutePattern function = Trans.function -- | Build a route that requires the requested path match exactly, without captures. literal :: String -> RoutePattern literal = Trans.literal + + + + diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -16,15 +16,22 @@ , header , headers , html + , htmlLazy , liftAndCatchIO , json , jsonData , next , param + , pathParam , captureParam , formParam , queryParam + , pathParamMaybe + , captureParamMaybe + , formParamMaybe + , queryParamMaybe , params + , pathParams , captureParams , formParams , queryParams @@ -41,8 +48,13 @@ , status , stream , text + , textLazy + , getResponseStatus + , getResponseHeaders + , getResponseContent , Param , Parsable(..) + , ActionT -- private to Scotty , runAction ) where @@ -63,10 +75,11 @@ import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.CaseInsensitive as CI import Data.Int -import qualified Data.Text as ST -import qualified Data.Text.Encoding as STE -import qualified Data.Text.Lazy as T -import Data.Text.Lazy.Encoding (encodeUtf8) +import Data.Maybe (maybeToList) +import qualified Data.Text as T +import Data.Text.Encoding as STE +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TLE import Data.Word import Network.HTTP.Types @@ -79,8 +92,8 @@ import Numeric.Natural import Web.Scotty.Internal.Types -import Web.Scotty.Util (mkResponse, addIfNotPresent, add, replace, lazyTextToStrictByteString, strictByteStringToLazyText) -import Web.Scotty.Exceptions (Handler(..), catch, catchesOptionally, tryAny) +import Web.Scotty.Util (mkResponse, addIfNotPresent, add, replace, lazyTextToStrictByteString, decodeUtf8Lenient) +import UnliftIO.Exception (Handler(..), catch, catches, throwIO) import Network.Wai.Internal (ResponseReceived(..)) @@ -95,13 +108,11 @@ -> ActionT m () -- ^ Route action to be evaluated -> m (Maybe Response) runAction mh env action = do - let - handlers = [ - statusErrorHandler, -- StatusError - actionErrorHandler, -- ActionError i.e. Next, Finish, Redirect - someExceptionHandler -- all remaining exceptions - ] - ok <- flip runReaderT env $ runAM $ tryNext (catchesOptionally action mh handlers ) + ok <- flip runReaderT env $ runAM $ tryNext $ action `catches` concat + [ [actionErrorHandler] + , maybeToList mh + , [statusErrorHandler, scottyExceptionHandler, someExceptionHandler] + ] res <- getResponse env return $ bool Nothing (Just $ mkResponse res) ok @@ -111,7 +122,7 @@ StatusError s e -> do status s let code = T.pack $ show $ statusCode s - let msg = T.fromStrict $ STE.decodeUtf8 $ statusMessage s + let msg = decodeUtf8Lenient $ statusMessage s html $ mconcat ["

", code, " ", msg, "

", e] -- | Exception handler in charge of 'ActionError'. Rethrowing 'Next' here is caught by 'tryNext'. @@ -124,26 +135,61 @@ AENext -> next AEFinish -> return () +-- | Default handler for exceptions from scotty +scottyExceptionHandler :: MonadIO m => ErrorHandler m +scottyExceptionHandler = Handler $ \case + RequestTooLarge -> do + status status413 + text "Request body is too large" + MalformedJSON bs err -> do + status status400 + 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) + ] + PathParameterNotFound k -> do + status status500 + text $ T.unwords [ "Path parameter", k, "not found"] + QueryParameterNotFound k -> do + status status400 + text $ T.unwords [ "Query parameter", k, "not found"] + FormFieldNotFound k -> do + status status400 + text $ T.unwords [ "Query parameter", k, "not found"] + FailedToParseParameter k v e -> do + status status400 + text $ T.unwords [ "Failed to parse parameter", k, v, ":", e] + -- | Uncaught exceptions turn into HTTP 500 Server Error codes someExceptionHandler :: MonadIO m => ErrorHandler m someExceptionHandler = Handler $ \case (_ :: E.SomeException) -> status status500 --- | Throw a "500 Server Error" 'StatusError', which can be caught with 'rescue'. +-- | 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 'rescue'. +-- | 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" #-} --- | Throw an exception which can be caught within the scope of the current Action with 'rescue' or 'catch'. +-- | 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. -- @@ -161,28 +207,27 @@ -- ever run is if the first one calls 'next'. -- -- > get "/foo/:bar" $ do --- > w :: Text <- captureParam "bar" +-- > w :: Text <- pathParam "bar" -- > unless (w == "special") next -- > text "You made a request to /foo/special" -- > -- > get "/foo/:baz" $ do --- > w <- captureParam "baz" +-- > w <- pathParam "baz" -- > text $ "You made a request to: " <> w next :: Monad m => ActionT m a next = E.throw AENext -- | Catch an exception e.g. a 'StatusError' or a user-defined exception. -- --- > raise JustKidding `rescue` (\msg -> text msg) +-- > 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 io = liftIO $ do - r <- tryAny io - either E.throwIO pure r - +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. @@ -214,14 +259,14 @@ header :: (Monad m) => T.Text -> ActionT m (Maybe T.Text) header k = do hs <- requestHeaders <$> request - return $ fmap strictByteStringToLazyText $ lookup (CI.mk (lazyTextToStrictByteString k)) hs + return $ fmap decodeUtf8Lenient $ lookup (CI.mk (encodeUtf8 k)) hs -- | Get all the request headers. Header names are case-insensitive. headers :: (Monad m) => ActionT m [(T.Text, T.Text)] headers = do hs <- requestHeaders <$> request - return [ ( strictByteStringToLazyText (CI.original k) - , strictByteStringToLazyText v) + return [ ( decodeUtf8Lenient (CI.original k) + , decodeUtf8Lenient v) | (k,v) <- hs ] -- | Get the request body. @@ -246,27 +291,16 @@ jsonData :: (A.FromJSON a, MonadIO m) => ActionT m a jsonData = do b <- body - when (b == "") $ do - let htmlError = "jsonData - No data was provided." - raiseStatus status400 $ T.pack htmlError + when (b == "") $ throwIO $ MalformedJSON b "no data" case A.eitherDecode b of - Left err -> do - let htmlError = "jsonData - malformed." - `mappend` " Data was: " `mappend` BL.unpack b - `mappend` " Error was: " `mappend` err - raiseStatus status400 $ T.pack htmlError + Left err -> throwIO $ MalformedJSON b $ T.pack err Right value -> case A.fromJSON value of - A.Error err -> do - let htmlError = "jsonData - failed parse." - `mappend` " Data was: " `mappend` BL.unpack b `mappend` "." - `mappend` " Error was: " `mappend` err - raiseStatus status422 $ T.pack htmlError - A.Success a -> do - return a + 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 'rescue' if parameter is not found. +-- * Raises an exception which can be caught by 'catch' if parameter is not found. -- -- * 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 @@ -276,66 +310,133 @@ val <- ActionT $ (lookup k . getParams) <$> ask case val of Nothing -> raiseStatus status500 $ "Param: " <> k <> " not found!" -- FIXME - Just v -> either (const next) return $ parseParam v + 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. "#-} --- | Get a capture parameter. +-- | Synonym for 'pathParam' +captureParam :: (Parsable a, MonadIO m) => T.Text -> ActionT m a +captureParam = pathParam + +-- | Look up a path parameter. -- --- * Raises an exception which can be caught by 'rescue' if parameter is not found. If the exception is not caught, scotty will return a HTTP error code 500 ("Internal Server Error") to the client. +-- * Raises an exception which can be caught by 'catch' if parameter is not found. If the exception is not caught, scotty will return a HTTP error code 500 ("Internal Server Error") to the client. -- -- * If the parameter is found, but 'parseParam' fails to parse to the correct type, 'next' is called. -captureParam :: (Parsable a, Monad m) => T.Text -> ActionT m a -captureParam = paramWith CaptureParam envCaptureParams status500 +-- +-- /Since: 0.20/ +pathParam :: (Parsable a, MonadIO m) => T.Text -> ActionT m a +pathParam k = do + val <- ActionT $ lookup k . envPathParams <$> ask + case val of + Nothing -> throwIO $ PathParameterNotFound k + Just v -> case parseParam $ TL.fromStrict v of + Left _ -> next + Right a -> pure a --- | Get a form parameter. +-- | Look up a form parameter. -- --- * Raises an exception which can be caught by 'rescue' if parameter is not found. If the exception is not caught, scotty will return a HTTP error code 400 ("Bad Request") to the client. +-- * Raises an exception which can be caught by 'catch' if parameter is not found. If the exception is not caught, scotty will return a HTTP error code 400 ("Bad Request") to the client. -- -- * This function raises a code 400 also if the parameter is found, but 'parseParam' fails to parse to the correct type. -formParam :: (Parsable a, Monad m) => T.Text -> ActionT m a -formParam = paramWith FormParam envFormParams status400 +-- +-- /Since: 0.20/ +formParam :: (Parsable a, MonadIO m) => T.Text -> ActionT m a +formParam = paramWith FormFieldNotFound envFormParams --- | Get a query parameter. +-- | Look up a query parameter. -- --- * Raises an exception which can be caught by 'rescue' if parameter is not found. If the exception is not caught, scotty will return a HTTP error code 400 ("Bad Request") to the client. +-- * Raises an exception which can be caught by 'catch' if parameter is not found. If the exception is not caught, scotty will return a HTTP error code 400 ("Bad Request") to the client. -- -- * This function raises a code 400 also if the parameter is found, but 'parseParam' fails to parse to the correct type. -queryParam :: (Parsable a, Monad m) => T.Text -> ActionT m a -queryParam = paramWith QueryParam envQueryParams status400 +-- +-- /Since: 0.20/ +queryParam :: (Parsable a, MonadIO m) => T.Text -> ActionT m a +queryParam = paramWith QueryParameterNotFound envQueryParams -data ParamType = CaptureParam +-- | Look up a path parameter. Returns 'Nothing' if the parameter is not found or cannot be parsed at the right type. +-- +-- NB : Doesn't throw exceptions. In particular, route pattern matching will not continue, so developers +-- must 'raiseStatus' or 'throw' to signal something went wrong. +-- +-- /Since: 0.21/ +pathParamMaybe :: (Parsable a, Monad m) => T.Text -> ActionT m (Maybe a) +pathParamMaybe = paramWithMaybe envPathParams + +-- | Look up a capture parameter. Returns 'Nothing' if the parameter is not found or cannot be parsed at the right type. +-- +-- NB : Doesn't throw exceptions. In particular, route pattern matching will not continue, so developers +-- must 'raiseStatus' or 'throw' to signal something went wrong. +-- +-- /Since: 0.21/ +captureParamMaybe :: (Parsable a, Monad m) => T.Text -> ActionT m (Maybe a) +captureParamMaybe = paramWithMaybe envPathParams + +-- | Look up a form parameter. Returns 'Nothing' if the parameter is not found or cannot be parsed at the right type. +-- +-- 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 + +-- | Look up a query parameter. Returns 'Nothing' if the parameter is not found or cannot be parsed at the right type. +-- +-- NB : Doesn't throw exceptions, so developers must 'raiseStatus' or 'throw' to signal something went wrong. +-- +-- /Since: 0.21/ +queryParamMaybe :: (Parsable a, Monad m) => T.Text -> ActionT m (Maybe a) +queryParamMaybe = paramWithMaybe envQueryParams + +data ParamType = PathParam | FormParam | QueryParam instance Show ParamType where show = \case - CaptureParam -> "capture" + PathParam -> "path" FormParam -> "form" QueryParam -> "query" -paramWith :: (Monad m, Parsable b) => - ParamType +paramWith :: (MonadIO m, Parsable b) => + (T.Text -> ScottyException) -> (ActionEnv -> [Param]) - -> Status -- ^ HTTP status to return if parameter is not found -> T.Text -- ^ parameter name -> ActionT m b -paramWith ty f err k = do +paramWith toError f k = do val <- ActionT $ (lookup k . f) <$> ask case val of - Nothing -> raiseStatus err (T.unwords [T.pack (show ty), "parameter:", k, "not found!"]) - Just v -> - let handleParseError = \case - CaptureParam -> next - _ -> raiseStatus err (T.unwords ["Cannot parse", v, "as a", T.pack (show ty), "parameter"]) - in either (const $ handleParseError ty) return $ parseParam v + Nothing -> throwIO $ toError k + Just v -> case parseParam $ TL.fromStrict v of + Left e -> throwIO $ FailedToParseParameter k v (TL.toStrict e) + Right a -> pure a --- | Get all parameters from capture, form and query (in that order). +-- | Look up a parameter. Returns 'Nothing' if the parameter is not found or cannot be parsed at the right type. +-- +-- NB : Doesn't throw exceptions. +-- +-- /Since: FIXME/ +paramWithMaybe :: (Monad m, Parsable b) => + (ActionEnv -> [Param]) + -> T.Text -- ^ parameter name + -> ActionT m (Maybe b) +paramWithMaybe f k = do + val <- ActionT $ (lookup k . f) <$> ask + 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 captureParams, formParams and queryParams instead. "#-} +{-# DEPRECATED params "(#204) Not a good idea to treat all parameters identically. Use pathParams, formParams and queryParams instead. "#-} --- | Get capture parameters +-- | Get path parameters +pathParams :: Monad m => ActionT m [Param] +pathParams = paramsWith envPathParams + +-- | Get path parameters captureParams :: Monad m => ActionT m [Param] -captureParams = paramsWith envCaptureParams +captureParams = paramsWith envPathParams + -- | Get form parameters formParams :: Monad m => ActionT m [Param] formParams = paramsWith envFormParams @@ -348,44 +449,64 @@ {-# DEPRECATED getParams "(#204) Not a good idea to treat all parameters identically" #-} getParams :: ActionEnv -> [Param] -getParams e = envCaptureParams e <> envFormParams e <> envQueryParams e +getParams e = envPathParams e <> envFormParams e <> envQueryParams e + +-- === access the fields of the Response being constructed + +-- | Access the HTTP 'Status' of the Response +-- +-- /SINCE 0.21/ +getResponseStatus :: (MonadIO m) => ActionT m Status +getResponseStatus = srStatus <$> getResponseAction +-- | Access the HTTP headers of the Response +-- +-- /SINCE 0.21/ +getResponseHeaders :: (MonadIO m) => ActionT m ResponseHeaders +getResponseHeaders = srHeaders <$> getResponseAction +-- | Access the content of the Response +-- +-- /SINCE 0.21/ +getResponseContent :: (MonadIO m) => ActionT m Content +getResponseContent = srContent <$> getResponseAction + + -- | Minimum implemention: 'parseParam' class Parsable a where -- | Take a 'T.Text' value and parse it as 'a', or fail with a message. - parseParam :: T.Text -> Either T.Text a + parseParam :: TL.Text -> Either TL.Text a -- | Default implementation parses comma-delimited lists. -- -- > parseParamList t = mapM parseParam (T.split (== ',') t) - parseParamList :: T.Text -> Either T.Text [a] - parseParamList t = mapM parseParam (T.split (== ',') t) + parseParamList :: TL.Text -> Either TL.Text [a] + parseParamList t = mapM parseParam (TL.split (== ',') t) -- No point using 'read' for Text, ByteString, Char, and String. -instance Parsable T.Text where parseParam = Right -instance Parsable ST.Text where parseParam = Right . T.toStrict +instance Parsable T.Text where parseParam = Right . TL.toStrict +instance Parsable TL.Text where parseParam = Right instance Parsable B.ByteString where parseParam = Right . lazyTextToStrictByteString -instance Parsable BL.ByteString where parseParam = Right . encodeUtf8 +instance Parsable BL.ByteString where parseParam = Right . TLE.encodeUtf8 -- | Overrides default 'parseParamList' to parse String. instance Parsable Char where - parseParam t = case T.unpack t of + parseParam t = case TL.unpack t of [c] -> Right c _ -> Left "parseParam Char: no parse" - parseParamList = Right . T.unpack -- String + parseParamList = Right . TL.unpack -- String -- | Checks if parameter is present and is null-valued, not a literal '()'. -- If the URI requested is: '/foo?bar=()&baz' then 'baz' will parse as (), where 'bar' will not. instance Parsable () where - parseParam t = if T.null t then Right () else Left "parseParam Unit: no parse" + parseParam t = if TL.null t then Right () else Left "parseParam Unit: no parse" instance (Parsable a) => Parsable [a] where parseParam = parseParamList instance Parsable Bool where - parseParam t = if t' == T.toCaseFold "true" + parseParam t = if t' == TL.toCaseFold "true" then Right True - else if t' == T.toCaseFold "false" + else if t' == TL.toCaseFold "false" then Right False else Left "parseParam Bool: no parse" - where t' = T.toCaseFold t + where t' = TL.toCaseFold t instance Parsable Double where parseParam = readEither instance Parsable Float where parseParam = readEither @@ -407,8 +528,8 @@ -- | Useful for creating 'Parsable' instances for things that already implement 'Read'. Ex: -- -- > instance Parsable Int where parseParam = readEither -readEither :: Read a => T.Text -> Either T.Text a -readEither t = case [ x | (x,"") <- reads (T.unpack t) ] of +readEither :: Read a => TL.Text -> Either TL.Text a +readEither t = case [ x | (x,"") <- reads (TL.unpack t) ] of [x] -> Right x [] -> Left "readEither: no parse" _ -> Left "readEither: ambiguous parse" @@ -422,7 +543,7 @@ => (CI.CI B.ByteString -> B.ByteString -> [(HeaderName, B.ByteString)] -> [(HeaderName, B.ByteString)]) -> T.Text -> T.Text -> ActionT m () changeHeader f k = - modifyResponse . setHeaderWith . f (CI.mk $ lazyTextToStrictByteString k) . lazyTextToStrictByteString + modifyResponse . setHeaderWith . f (CI.mk $ encodeUtf8 k) . encodeUtf8 -- | Add to the response headers. Header names are case-insensitive. addHeader :: MonadIO m => T.Text -> T.Text -> ActionT m () @@ -438,15 +559,29 @@ text :: (MonadIO m) => T.Text -> ActionT m () text t = do changeHeader addIfNotPresent "Content-Type" "text/plain; charset=utf-8" - raw $ encodeUtf8 t + raw $ BL.fromStrict $ encodeUtf8 t -- | Set the body of the response to the given 'T.Text' value. Also sets \"Content-Type\" +-- header to \"text/plain; charset=utf-8\" if it has not already been set. +textLazy :: (MonadIO m) => TL.Text -> ActionT m () +textLazy t = do + changeHeader addIfNotPresent "Content-Type" "text/plain; charset=utf-8" + raw $ TLE.encodeUtf8 t + +-- | Set the body of the response to the given 'T.Text' value. Also sets \"Content-Type\" -- header to \"text/html; charset=utf-8\" if it has not already been set. html :: (MonadIO m) => T.Text -> ActionT m () html t = do changeHeader addIfNotPresent "Content-Type" "text/html; charset=utf-8" - raw $ encodeUtf8 t + raw $ BL.fromStrict $ encodeUtf8 t +-- | Set the body of the response to the given 'T.Text' value. Also sets \"Content-Type\" +-- header to \"text/html; charset=utf-8\" if it has not already been set. +htmlLazy :: (MonadIO m) => TL.Text -> ActionT m () +htmlLazy t = do + changeHeader addIfNotPresent "Content-Type" "text/html; charset=utf-8" + raw $ TLE.encodeUtf8 t + -- | Send a file as the response. Doesn't set the \"Content-Type\" header, so you probably -- want to do that on your own with 'setHeader'. Setting a status code will have no effect -- because Warp will overwrite that to 200 (see 'Network.Wai.Handler.Warp.Internal.sendResponse'). @@ -482,6 +617,6 @@ -- Is MVar really the best choice here? Not sure. r <- request ref <- liftIO $ newEmptyMVar - _ <- liftAndCatchIO $ app r (\res -> putMVar ref res >> return ResponseReceived) - res <- liftAndCatchIO $ readMVar ref + _ <- liftIO $ app r (\res -> putMVar ref res >> return ResponseReceived) + res <- liftIO $ readMVar ref rawResponse res diff --git a/Web/Scotty/Body.hs b/Web/Scotty/Body.hs --- a/Web/Scotty/Body.hs +++ b/Web/Scotty/Body.hs @@ -20,7 +20,7 @@ import qualified Network.Wai.Parse as W (File, Param, getRequestBodyType, BackEnd, lbsBackEnd, sinkRequestBody) import Web.Scotty.Action (Param) import Web.Scotty.Internal.Types (BodyInfo(..), BodyChunkBuffer(..), BodyPartiallyStreamed(..), RouteOptions(..)) -import Web.Scotty.Util (readRequestBody, strictByteStringToLazyText) +import Web.Scotty.Util (readRequestBody, strictByteStringToLazyText, decodeUtf8Lenient) -- | Make a new BodyInfo with readProgress at 0 and an empty BodyChunkBuffer. newBodyInfo :: (MonadIO m) => Request -> m BodyInfo @@ -47,7 +47,7 @@ bs <- getBodyAction bodyInfo opts let wholeBody = BL.toChunks bs (formparams, fs) <- parseRequestBody wholeBody W.lbsBackEnd req -- NB this loads the whole body into memory - let convert (k, v) = (strictByteStringToLazyText k, strictByteStringToLazyText v) + let convert (k, v) = (decodeUtf8Lenient k, decodeUtf8Lenient v) return (convert <$> formparams, fs) else return ([], []) diff --git a/Web/Scotty/Cookie.hs b/Web/Scotty/Cookie.hs --- a/Web/Scotty/Cookie.hs +++ b/Web/Scotty/Cookie.hs @@ -79,21 +79,23 @@ -- cookie import Web.Cookie (SetCookie, setCookieName , setCookieValue, setCookiePath, setCookieExpires, setCookieMaxAge, setCookieDomain, setCookieHttpOnly, setCookieSecure, setCookieSameSite, renderSetCookie, defaultSetCookie, CookiesText, parseCookiesText, SameSiteOption, sameSiteStrict, sameSiteNone, sameSiteLax) -- scotty -import Web.Scotty.Trans (ActionT, addHeader, header) +import Web.Scotty.Action (ActionT, addHeader, header) -- time import Data.Time.Clock.POSIX ( posixSecondsToUTCTime ) -- text import Data.Text (Text) import qualified Data.Text.Encoding as T (encodeUtf8) -import qualified Data.Text.Lazy.Encoding as TL (encodeUtf8, decodeUtf8) - - +import Web.Scotty.Util (decodeUtf8Lenient) -- | Set a cookie, with full access to its options (see 'SetCookie') setCookie :: (MonadIO m) => SetCookie -> ActionT m () -setCookie c = addHeader "Set-Cookie" (TL.decodeUtf8 . toLazyByteString $ renderSetCookie c) +setCookie c = addHeader "Set-Cookie" + $ decodeUtf8Lenient + $ BSL.toStrict + $ toLazyByteString + $ renderSetCookie c -- | 'makeSimpleCookie' and 'setCookie' combined. @@ -114,7 +116,7 @@ getCookies :: (Monad m) => ActionT m CookiesText getCookies = (maybe [] parse) <$> header "Cookie" - where parse = parseCookiesText . BSL.toStrict . TL.encodeUtf8 + where parse = parseCookiesText . T.encodeUtf8 -- | 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 :: (MonadIO m) diff --git a/Web/Scotty/Exceptions.hs b/Web/Scotty/Exceptions.hs deleted file mode 100644 --- a/Web/Scotty/Exceptions.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -module Web.Scotty.Exceptions ( - Handler(..) - -- * catching - , catch - , catchAny - , catches - , catchesOptionally - -- * trying - , try - , tryAny - ) where - -import Data.Maybe (maybeToList) - -import UnliftIO (MonadUnliftIO(..), catch, catchAny, catches, try, tryAny, Handler(..)) - - --- | Handlers are tried sequentially -catchesOptionally :: MonadUnliftIO m => - m a - -> Maybe (Handler m a) -- ^ if present, this 'Handler' is tried first - -> [Handler m a] -- ^ these are tried in order - -> m a -catchesOptionally io mh handlers = io `catches` (maybeToList mh <> handlers) diff --git a/Web/Scotty/Internal/Types.hs b/Web/Scotty/Internal/Types.hs --- a/Web/Scotty/Internal/Types.hs +++ b/Web/Scotty/Internal/Types.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} @@ -22,7 +21,7 @@ import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.IO.Class (MonadIO(..)) import UnliftIO (MonadUnliftIO(..)) -import Control.Monad.Reader (MonadReader(..), ReaderT, asks) +import Control.Monad.Reader (MonadReader(..), ReaderT, asks, mapReaderT) import Control.Monad.State.Strict (State, StateT(..)) import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Control (MonadBaseControl, MonadTransControl) @@ -31,7 +30,7 @@ import qualified Data.ByteString.Lazy.Char8 as LBS8 (ByteString) import Data.Default.Class (Default, def) import Data.String (IsString(..)) -import Data.Text.Lazy (Text, pack) +import Data.Text (Text, pack) import Data.Typeable (Typeable) import Network.HTTP.Types @@ -41,7 +40,7 @@ import Network.Wai.Handler.Warp (Settings, defaultSettings) import Network.Wai.Parse (FileInfo) -import Web.Scotty.Exceptions (Handler(..), catch, catches) +import UnliftIO.Exception (Handler(..), catch, catches) --------------------- Options ----------------------- @@ -143,12 +142,21 @@ -- | 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 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) () -- | Thrown e.g. when a request is too large -data ScottyException = RequestException BS.ByteString Status deriving (Show, Typeable) +data ScottyException + = RequestTooLarge + | MalformedJSON LBS8.ByteString Text + | FailedToParseJSON LBS8.ByteString Text + | PathParameterNotFound Text + | QueryParameterNotFound Text + | FormFieldNotFound Text + | FailedToParseParameter Text Text Text + deriving (Show, Typeable) instance E.Exception ScottyException ------------------ Scotty Actions ------------------- @@ -157,7 +165,7 @@ type File = (Text, FileInfo LBS8.ByteString) data ActionEnv = Env { envReq :: Request - , envCaptureParams :: [Param] + , envPathParams :: [Param] , envFormParams :: [Param] , envQueryParams :: [Param] , envBody :: IO LBS8.ByteString @@ -169,9 +177,14 @@ getResponse :: MonadIO m => ActionEnv -> m ScottyResponse getResponse ae = liftIO $ readTVarIO (envResponse ae) +getResponseAction :: (MonadIO m) => ActionT m ScottyResponse +getResponseAction = do + ae <- ActionT ask + getResponse ae + modifyResponse :: (MonadIO m) => (ScottyResponse -> ScottyResponse) -> ActionT m () modifyResponse f = do - tv <- asks envResponse + tv <- ActionT $ asks envResponse liftIO $ atomically $ modifyTVar' tv f data BodyPartiallyStreamed = BodyPartiallyStreamed deriving (Show, Typeable) @@ -206,13 +219,17 @@ newtype ActionT m a = ActionT { runAM :: ReaderT ActionEnv m a } - deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader ActionEnv, MonadTrans, MonadThrow, MonadCatch, MonadBase b, MonadBaseControl b, MonadTransControl, MonadUnliftIO) + deriving newtype (Functor, Applicative, Monad, MonadIO, MonadTrans, MonadThrow, MonadCatch, MonadBase b, MonadBaseControl b, MonadTransControl, MonadUnliftIO) +instance MonadReader r m => MonadReader r (ActionT m) where + 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' or 'rescue'. +-- | Modeled after the behaviour in scotty < 0.20, 'fail' throws a 'StatusError' with code 500 ("Server Error"), which can be caught with 'E.catch'. instance (MonadIO m) => MonadFail (ActionT m) where fail = E.throw . StatusError status500 . pack -- | 'empty' throws 'ActionError' 'AENext', whereas '(<|>)' catches any 'ActionError's or 'StatusError's in the first action and proceeds to the second one. @@ -225,52 +242,34 @@ mzero = empty mplus = (<|>) --- | catches either ActionError (thrown by 'next') or 'StatusError' (thrown if e.g. a query parameter is not found) +-- | 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] +tryAnyStatus io = (io >> pure True) `catches` [h1, h2, h3] where h1 = Handler $ \(_ :: ActionError) -> pure False h2 = Handler $ \(_ :: StatusError) -> pure False + h3 = Handler $ \(_ :: ScottyException) -> pure False instance (Semigroup a) => Semigroup (ScottyT m a) where x <> y = (<>) <$> x <*> y instance ( Monoid a -#if !(MIN_VERSION_base(4,11,0)) - , Semigroup a -#endif -#if !(MIN_VERSION_base(4,8,0)) - , Functor m -#endif ) => Monoid (ScottyT m a) where mempty = return mempty -#if !(MIN_VERSION_base(4,11,0)) - mappend = (<>) -#endif instance ( Monad m -#if !(MIN_VERSION_base(4,8,0)) - , Functor m -#endif , Semigroup a ) => Semigroup (ActionT m a) where x <> y = (<>) <$> x <*> y instance ( Monad m, Monoid a -#if !(MIN_VERSION_base(4,11,0)) - , Semigroup a -#endif -#if !(MIN_VERSION_base(4,8,0)) - , Functor m -#endif ) => Monoid (ActionT m a) where mempty = return mempty -#if !(MIN_VERSION_base(4,11,0)) - mappend = (<>) -#endif ------------------ Scotty Routes -------------------- data RoutePattern = Capture Text diff --git a/Web/Scotty/Route.hs b/Web/Scotty/Route.hs --- a/Web/Scotty/Route.hs +++ b/Web/Scotty/Route.hs @@ -11,12 +11,8 @@ import UnliftIO (MonadUnliftIO(..)) import qualified Control.Monad.State as MS -import qualified Data.ByteString.Char8 as B - -import Data.Maybe (fromMaybe) import Data.String (fromString) -import qualified Data.Text.Lazy as T -import qualified Data.Text as TS +import qualified Data.Text as T import Network.HTTP.Types import Network.Wai (Request(..)) @@ -25,9 +21,37 @@ import Web.Scotty.Action import Web.Scotty.Internal.Types (RoutePattern(..), RouteOptions, ActionEnv(..), ActionT, ScottyState(..), ScottyT(..), ErrorHandler, Middleware, BodyInfo, handler, addRoute, defaultScottyResponse) -import Web.Scotty.Util (strictByteStringToLazyText) +import Web.Scotty.Util (decodeUtf8Lenient) import Web.Scotty.Body (cloneBodyInfo, getBodyAction, getBodyChunkAction, getFormParamsAndFilesAction) +{- $setup +>>> :{ +import Control.Monad.IO.Class (MonadIO(..)) +import qualified Network.HTTP.Client as H +import qualified Network.HTTP.Types as H +import qualified Network.Wai as W (httpVersion) +import qualified Data.ByteString.Lazy.Char8 as LBS (unpack) +import qualified Data.Text as T (pack) +import Control.Concurrent (ThreadId, forkIO, killThread) +import Control.Exception (bracket) +import qualified Web.Scotty as S (ScottyM, scottyOpts, get, text, regex, pathParam, Options(..), defaultOptions) +-- | GET an HTTP path +curl :: MonadIO m => + String -- ^ path + -> m String -- ^ response body +curl path = liftIO $ do + req0 <- H.parseRequest path + let req = req0 { H.method = "GET"} + mgr <- H.newManager H.defaultManagerSettings + (LBS.unpack . H.responseBody) <$> H.httpLbs req mgr +-- | Fork a process, run a Scotty server in it and run an action while the server is running. Kills the scotty thread once the inner action is done. +withScotty :: S.ScottyM () + -> IO a -- ^ inner action, e.g. 'curl "localhost:3000/"' + -> IO a +withScotty serv act = bracket (forkIO $ S.scottyOpts (S.defaultOptions{ S.verbose = 0 }) serv) killThread (\_ -> act) +:} +-} + -- | get = 'addroute' 'GET' get :: (MonadUnliftIO m) => RoutePattern -> ActionT m () -> ScottyT m () get = addroute GET @@ -61,23 +85,21 @@ notFound :: (MonadUnliftIO m) => ActionT m () -> ScottyT m () notFound action = matchAny (Function (\req -> Just [("path", path req)])) (status status404 >> action) --- | Define a route with a 'StdMethod', 'T.Text' value representing the path spec, --- and a body ('Action') which modifies the response. --- --- > addroute GET "/" $ text "beam me up!" --- --- The path spec can include values starting with a colon, which are interpreted --- as /captures/. These are named wildcards that can be looked up with 'captureParam'. --- --- > addroute GET "/foo/:bar" $ do --- > v <- captureParam "bar" --- > text v --- --- >>> curl http://localhost:3000/foo/something --- something --- --- NB: the 'RouteOptions' and the exception handler of the newly-created route will be --- copied from the previously-created routes. +{- | Define a route with a 'StdMethod', a route pattern representing the path spec, +and an 'Action' which may modify the response. + +> get "/" $ text "beam me up!" + +The path spec can include values starting with a colon, which are interpreted +as /captures/. These are parameters that can be looked up with 'pathParam'. + +>>> :{ +let server = S.get "/foo/:bar" (S.pathParam "bar" >>= S.text) + in do + withScotty server $ curl "http://localhost:3000/foo/something" +:} +"something" +-} addroute :: (MonadUnliftIO m) => StdMethod -> RoutePattern -> ActionT m () -> ScottyT m () addroute method pat action = ScottyT $ MS.modify $ \s -> addRoute (route (routeOptions s) (handler s) (Just method) pat action) s @@ -86,10 +108,8 @@ -> Maybe (ErrorHandler m) -> Maybe StdMethod -> RoutePattern -> ActionT m () -> BodyInfo -> Middleware m route opts h method pat action bodyInfo app req = let tryNext = app req - {- | - We match all methods in the case where 'method' is 'Nothing'. - See https://github.com/scotty-web/scotty/issues/196 and 'matchAny' - -} + -- We match all methods in the case where 'method' is 'Nothing'. + -- See https://github.com/scotty-web/scotty/issues/196 and 'matchAny' methodMatches :: Bool methodMatches = maybe True (\x -> (Right x == parseMethod (requestMethod req))) method @@ -114,7 +134,7 @@ matchRoute (Literal pat) req | pat == path req = Just [] | otherwise = Nothing matchRoute (Function fun) req = fun req -matchRoute (Capture pat) req = go (T.split (=='/') pat) (compress $ T.split (=='/') $ path req) [] +matchRoute (Capture pat) req = go (T.split (=='/') pat) (compress $ "":pathInfo req) [] -- add empty segment to simulate being at the root where go [] [] prs = Just prs -- request string and pattern match! go [] r prs | T.null (mconcat r) = Just prs -- in case request has trailing slashes | otherwise = Nothing -- request string is longer than pattern @@ -130,38 +150,38 @@ -- Pretend we are at the top level. path :: Request -> T.Text -path = T.fromStrict . TS.cons '/' . TS.intercalate "/" . pathInfo +path = T.cons '/' . T.intercalate "/" . pathInfo -- | Parse the request and construct the initial 'ActionEnv' with a default 200 OK response mkEnv :: MonadIO m => BodyInfo -> Request -> [Param] -> RouteOptions -> m ActionEnv mkEnv bodyInfo req captureps opts = do (formps, bodyFiles) <- liftIO $ getFormParamsAndFilesAction req bodyInfo opts let - queryps = parseEncodedParams $ rawQueryString req - bodyFiles' = [ (strictByteStringToLazyText k, fi) | (k,fi) <- bodyFiles ] + queryps = parseEncodedParams $ queryString req + bodyFiles' = [ (decodeUtf8Lenient k, fi) | (k,fi) <- bodyFiles ] responseInit <- liftIO $ newTVarIO defaultScottyResponse return $ Env req captureps formps queryps (getBodyAction bodyInfo opts) (getBodyChunkAction bodyInfo) bodyFiles' responseInit -parseEncodedParams :: B.ByteString -> [Param] -parseEncodedParams bs = [ (T.fromStrict k, T.fromStrict $ fromMaybe "" v) | (k,v) <- parseQueryText bs ] +parseEncodedParams :: Query -> [Param] +parseEncodedParams qs = [ ( decodeUtf8Lenient k, maybe "" decodeUtf8Lenient v) | (k,v) <- qs ] --- | Match requests using a regular expression. --- Named captures are not yet supported. --- --- > get (regex "^/f(.*)r$") $ do --- > path <- param "0" --- > cap <- param "1" --- > text $ mconcat ["Path: ", path, "\nCapture: ", cap] --- --- >>> curl http://localhost:3000/foo/bar --- Path: /foo/bar --- Capture: oo/ba --- +{- | Match requests using a regular expression. +Named captures are not yet supported. + +>>> :{ +let server = S.get (S.regex "^/f(.*)r$") $ do + cap <- S.pathParam "1" + S.text cap + in do + withScotty server $ curl "http://localhost:3000/foo/bar" +:} +"oo/ba" +-} regex :: String -> RoutePattern -regex pattern = Function $ \ req -> fmap (map (T.pack . show *** T.pack) . zip [0 :: Int ..] . strip) +regex pat = Function $ \ req -> fmap (map (T.pack . show *** T.pack) . zip [0 :: Int ..] . strip) (Regex.matchRegexAll rgx $ T.unpack $ path req) - where rgx = Regex.mkRegex pattern + where rgx = Regex.mkRegex pat strip (_, match, _, subs) = match : subs -- | Standard Sinatra-style route. Named captures are prepended with colons. @@ -179,18 +199,19 @@ capture :: String -> RoutePattern capture = fromString --- | Build a route based on a function which can match using the entire 'Request' object. --- 'Nothing' indicates the route does not match. A 'Just' value indicates --- a successful match, optionally returning a list of key-value pairs accessible --- by 'param'. --- --- > get (function $ \req -> Just [("version", T.pack $ show $ httpVersion req)]) $ do --- > v <- param "version" --- > text v --- --- >>> curl http://localhost:3000/ --- HTTP/1.1 --- +{- | Build a route based on a function which can match using the entire 'Request' object. +'Nothing' indicates the route does not match. A 'Just' value indicates +a successful match, optionally returning a list of key-value pairs accessible by 'param'. + +>>> :{ +let server = S.get (function $ \req -> Just [("version", T.pack $ show $ W.httpVersion req)]) $ do + v <- S.pathParam "version" + S.text v + in do + withScotty server $ curl "http://localhost:3000/" +:} +"HTTP/1.1" +-} function :: (Request -> Maybe [Param]) -> RoutePattern function = Function diff --git a/Web/Scotty/Trans.hs b/Web/Scotty/Trans.hs --- a/Web/Scotty/Trans.hs +++ b/Web/Scotty/Trans.hs @@ -4,15 +4,22 @@ -- OverloadedStrings language pragma. -- -- The functions in this module allow an arbitrary monad to be embedded --- in Scotty's monad transformer stack in order that Scotty be combined --- with other DSLs. +-- in Scotty's monad transformer stack, e.g. for complex endpoint configuration, +-- interacting with databases etc. -- -- Scotty is set up by default for development mode. For production servers, -- you will likely want to modify 'settings' and the 'defaultHandler'. See -- the comments on each of these functions for more information. +-- +-- Please refer to the @examples@ directory and the @spec@ test suite for concrete use cases, e.g. constructing responses, exception handling and useful implementation details. module Web.Scotty.Trans - ( -- * scotty-to-WAI - scottyT, scottyAppT, scottyOptsT, scottySocketT, Options(..), defaultOptions + ( -- * Running 'scotty' servers + scottyT + , scottyOptsT + , scottySocketT + , Options(..), defaultOptions + -- ** scotty-to-WAI + , scottyAppT -- * Defining Middleware and Routes -- -- | 'Middleware' and routes are run in the order in which they @@ -21,50 +28,60 @@ , middleware, get, post, put, delete, patch, options, addroute, matchAny, notFound, setMaxRequestBodySize -- ** Route Patterns , capture, regex, function, literal - -- ** Accessing the Request, Captures, and Query Parameters - , request, header, headers, body, bodyReader - , param, params - , captureParam, formParam, queryParam - , captureParams, formParams, queryParams + -- ** Accessing the Request and its fields + , request, Lazy.header, Lazy.headers, body, bodyReader , jsonData, files + -- ** Accessing Path, Form and Query Parameters + , param, params + , pathParam, captureParam, formParam, queryParam + , pathParamMaybe, captureParamMaybe, formParamMaybe, queryParamMaybe + , pathParams, captureParams, formParams, queryParams -- ** Modifying the Response and Redirecting - , status, addHeader, setHeader, redirect + , status, Lazy.addHeader, Lazy.setHeader, Lazy.redirect -- ** Setting Response Body -- -- | Note: only one of these should be present in any given route -- definition, as they completely replace the current 'Response' body. - , text, html, file, json, stream, raw, nested + , Lazy.text, Lazy.html, file, json, stream, raw, nested + -- ** Accessing the fields of the Response + , getResponseHeaders, getResponseStatus, getResponseContent -- ** Exceptions - , raise, raiseStatus, throw, rescue, next, finish, defaultHandler, liftAndCatchIO + , Lazy.raise, Lazy.raiseStatus, throw, rescue, next, finish, defaultHandler, liftAndCatchIO + , liftIO, catch , StatusError(..) + , ScottyException(..) -- * Parsing Parameters , Param, Parsable(..), readEither -- * Types - , RoutePattern, File, Kilobytes, ErrorHandler, Handler(..) + , RoutePattern, File, Content(..), Kilobytes, ErrorHandler, Handler(..) -- * Monad Transformers , ScottyT, ActionT , ScottyState, defaultScottyState ) where import Blaze.ByteString.Builder (fromByteString) +import Blaze.ByteString.Builder.Char8 (fromString) import Control.Exception (assert) import Control.Monad (when) import Control.Monad.State.Strict (execState, modify) import Control.Monad.IO.Class -import Network.HTTP.Types (status404) +import Network.HTTP.Types (status404, status413, status500) import Network.Socket (Socket) import qualified Network.Wai as W (Application, Middleware, Response, responseBuilder) import Network.Wai.Handler.Warp (Port, runSettings, runSettingsSocket, setPort, getPort) import Web.Scotty.Action import Web.Scotty.Route -import Web.Scotty.Internal.Types (ActionT(..), ScottyT(..), defaultScottyState, Application, RoutePattern, Options(..), defaultOptions, RouteOptions(..), defaultRouteOptions, ErrorHandler, Kilobytes, File, addMiddleware, setHandler, updateMaxRequestBodySize, routes, middlewares, ScottyException(..), ScottyState, defaultScottyState, StatusError(..)) +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.Trans.Lazy as Lazy import Web.Scotty.Util (socketDescription) import Web.Scotty.Body (newBodyInfo) -import Web.Scotty.Exceptions (Handler(..), catches) +import UnliftIO.Exception (Handler(..), catch) + + -- | Run a scotty application using the warp server. -- NB: scotty p === scottyT p id scottyT :: (Monad m, MonadIO n) @@ -112,10 +129,19 @@ let s = execState (runS defs) defaultScottyState let rapp req callback = do bodyInfo <- newBodyInfo req - resp <- runActionToIO (applyAll notFoundApp ([midd bodyInfo | midd <- routes s]) req) `catches` [scottyExceptionHandler] + resp <- runActionToIO (applyAll notFoundApp ([midd bodyInfo | midd <- routes s]) req) + `catch` unhandledExceptionHandler 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) + where + ct = [("Content-Type", "text/plain")] + applyAll :: Foldable t => a -> t (a -> a) -> a applyAll = foldl (flip ($)) @@ -127,13 +153,6 @@ defaultHandler :: (Monad m) => ErrorHandler m -> ScottyT m () defaultHandler f = ScottyT $ modify $ setHandler $ Just f --- | Exception handler in charge of 'ScottyException' -scottyExceptionHandler :: MonadIO m => Handler m W.Response -scottyExceptionHandler = Handler $ \case - RequestException ebody s -> do - return $ W.responseBuilder s [("Content-Type", "text/plain")] (fromByteString ebody) - - -- | Use given middleware. Middleware is nested such that the first declared -- is the outermost middleware (it has first dibs on the request and last action -- on the response). Every middleware is run on each request. @@ -146,3 +165,4 @@ setMaxRequestBodySize :: Kilobytes -- ^ Request size limit -> ScottyT m () setMaxRequestBodySize i = assert (i > 0) $ ScottyT . modify . updateMaxRequestBodySize $ defaultRouteOptions { maxRequestBodySize = Just i } + diff --git a/Web/Scotty/Trans/Lazy.hs b/Web/Scotty/Trans/Lazy.hs new file mode 100644 --- /dev/null +++ b/Web/Scotty/Trans/Lazy.hs @@ -0,0 +1,61 @@ +module Web.Scotty.Trans.Lazy where + +import Control.Monad (join) +import Control.Monad.IO.Class +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. +-- +-- > redirect "http://www.google.com" +-- +-- OR +-- +-- > redirect "/foo/bar" +redirect :: (Monad m) => T.Text -> ActionT m a +redirect = Base.redirect . T.toStrict + +-- | Get a request header. Header name is case-insensitive. +header :: (Monad m) => T.Text -> ActionT m (Maybe T.Text) +header h = fmap T.fromStrict <$> Base.header (T.toStrict h) + +-- | Get all the request headers. Header names are case-insensitive. +headers :: (Monad m) => ActionT m [(T.Text, T.Text)] +headers = map (join bimap T.fromStrict) <$> Base.headers + +-- | Add to the response headers. Header names are case-insensitive. +addHeader :: MonadIO m => T.Text -> T.Text -> ActionT m () +addHeader k v = Base.addHeader (T.toStrict k) (T.toStrict v) + +-- | Set one of the response headers. Will override any previously set value for that header. +-- Header names are case-insensitive. +setHeader :: MonadIO m => T.Text -> T.Text -> ActionT m () +setHeader k v = Base.addHeader (T.toStrict k) (T.toStrict v) + +text :: (MonadIO m) => T.Text -> ActionT m () +text = Base.textLazy + +html :: (MonadIO m) => T.Text -> ActionT m () +html = Base.htmlLazy diff --git a/Web/Scotty/Trans/Strict.hs b/Web/Scotty/Trans/Strict.hs new file mode 100644 --- /dev/null +++ b/Web/Scotty/Trans/Strict.hs @@ -0,0 +1,56 @@ +-- | This module is essentially identical to 'Web.Scotty.Trans', except that +-- some functions take/return strict Text instead of the lazy ones. +-- +-- It should be noted that most of the code snippets below depend on the +-- OverloadedStrings language pragma. +-- +-- The functions in this module allow an arbitrary monad to be embedded +-- in Scotty's monad transformer stack in order that Scotty be combined +-- with other DSLs. +-- +-- Scotty is set up by default for development mode. For production servers, +-- you will likely want to modify 'settings' and the 'defaultHandler'. See +-- the comments on each of these functions for more information. +module Web.Scotty.Trans.Strict + ( -- * scotty-to-WAI + scottyT, scottyAppT, scottyOptsT, scottySocketT, Options(..), defaultOptions + -- * Defining Middleware and Routes + -- + -- | 'Middleware' and routes are run in the order in which they + -- are defined. All middleware is run first, followed by the first + -- route that matches. If no route matches, a 404 response is given. + , middleware, get, post, put, delete, patch, options, addroute, matchAny, notFound, setMaxRequestBodySize + -- ** Route Patterns + , 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 + -- ** Setting Response Body + -- + -- | Note: only one of these should be present in any given route + -- definition, as they completely replace the current 'Response' body. + , Base.text, Base.html, file, json, stream, raw, nested + , textLazy + , htmlLazy + -- ** Accessing the fields of the Response + , getResponseHeaders, getResponseStatus, getResponseContent + -- ** Exceptions + , Base.raise, Base.raiseStatus, throw, rescue, next, finish, defaultHandler, liftAndCatchIO + , StatusError(..) + , ScottyException(..) + -- * Parsing Parameters + , Param, Parsable(..), readEither + -- * Types + , RoutePattern, File, Content(..), Kilobytes, ErrorHandler, Handler(..) + -- * Monad Transformers + , ScottyT, ActionT + , ScottyState, defaultScottyState + ) where +import Web.Scotty.Action as Base +import Web.Scotty.Trans diff --git a/Web/Scotty/Util.hs b/Web/Scotty/Util.hs --- a/Web/Scotty/Util.hs +++ b/Web/Scotty/Util.hs @@ -1,7 +1,10 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} +{-# options_ghc -Wno-unused-imports #-} module Web.Scotty.Util ( lazyTextToStrictByteString , strictByteStringToLazyText + , decodeUtf8Lenient , mkResponse , replace , add @@ -13,16 +16,12 @@ import Network.Socket (SockAddr(..), Socket, getSocketName, socketPort) import Network.Wai +import Control.Exception import Control.Monad (when) -import qualified Control.Exception as EUnsafe (throw) - - -import Network.HTTP.Types - import qualified Data.ByteString as B -import qualified Data.Text as TP (pack) +import qualified Data.Text as TP (Text, pack) import qualified Data.Text.Lazy as TL -import qualified Data.Text.Encoding as ES +import Data.Text.Encoding as ES import qualified Data.Text.Encoding.Error as ES import Web.Scotty.Internal.Types @@ -33,7 +32,10 @@ strictByteStringToLazyText :: B.ByteString -> TL.Text strictByteStringToLazyText = TL.fromStrict . ES.decodeUtf8With ES.lenientDecode - +#if !MIN_VERSION_text(2,0,0) +decodeUtf8Lenient :: B.ByteString -> TP.Text +decodeUtf8Lenient = ES.decodeUtf8With ES.lenientDecode +#endif -- Note: we currently don't support responseRaw, which may be useful -- for websockets. However, we always read the request body, which @@ -92,7 +94,7 @@ readUntilEmpty = do b <- rbody if B.null b - then EUnsafe.throw (RequestException (ES.encodeUtf8 . TP.pack $ "Request is too big Jim!") status413) + then throwIO RequestTooLarge else readUntilEmpty diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,11 +1,33 @@ ## next [????.??.??] -## 0.20.1 [2023.10.03] +## 0.21 [2023.12.17] +### New +* add `getResponseHeaders`, `getResponseStatus`, `getResponseContent` (#214) +* add `captureParamMaybe`, `formParamMaybe`, `queryParamMaybe` (#322) +* add `Web.Scotty.Trans.Strict` and `Web.Scotty.Trans.Lazy` (#334) +* renamed `captureParam`, `captureParamMaybe`, and `captureParams` to `pathParam`, `pathParamMaybe`, `pathParams` respectively, keeping the old names as their synonyms (#344) + +### Deprecated +* deprecate `rescue` and `liftAndCatchIO` (#332) +* Deprecate `StatusError`, `raise` and `raiseStatus` (#351) + +### Fixes +* Reverted the `MonadReader` instance of `ActionT` so that it inherits the base monad (#342) +* Scotty's API such as `queryParam` now throws `ScottyException` rather than `StatusException`. + Uncaught exceptions are handled by `scottyExceptionHandler`, resembling the existing behaviour + +### Documentation +* Add doctest, refactor some inline examples into doctests (#353) +* document "`defaultHandler` only applies to endpoints defined after it" (#237) + + +## 0.20.1 [2023.10.03] * remove dependencies on 'base-compat' and 'base-compat-batteries' (#318) * re-add MonadFail (ActionT m) instance (#325) * re-add MonadError (ActionT m) instance, but the error type is now specialized to 'StatusError' (#325) * raise lower bound on base ( > 4.14 ) to reflect support for GHC >= 8.10 (#325). + ## 0.20 [2023.10.02] * Drop support for GHC < 8.10 and modernise the CI pipeline (#300). diff --git a/doctest/Main.hs b/doctest/Main.hs new file mode 100644 --- /dev/null +++ b/doctest/Main.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE CPP #-} +module Main where + +#if __GLASGOW_HASKELL__ >= 946 +import Test.DocTest (doctest) + +-- 1. Our current doctests require a number of imports that scotty doesn't need +-- 2. declaring doctest helper functions in this module doesn't seem to work +-- 3. cabal tests cannot have exposed modules? +-- 4. GHCi only started supporting multiline imports since 9.4.6 ( https://gitlab.haskell.org/ghc/ghc/-/issues/20473 ) +-- so lacking a better option we no-op doctest for older GHCs + +main :: IO () +main = doctest [ + "Web/Scotty.hs" + , "Web/Scotty/Trans.hs" + , "-XOverloadedStrings" + , "-XLambdaCase" + ] +#else +main :: IO () +main = pure () +#endif diff --git a/examples/basic.hs b/examples/basic.hs --- a/examples/basic.hs +++ b/examples/basic.hs @@ -35,12 +35,22 @@ get "/" $ text "foobar" get "/" $ text "barfoo" - -- Using a parameter in the query string. Since it has - -- not been given, a 500 page is generated. - get "/foo" $ do - v <- captureParam "fooparam" + -- Looking for a parameter in the path. Since the path pattern does not + -- contain the parameter name 'p', the server responds with 500 Server Error. + get "/foo_fail" $ do + v <- pathParam "p" html $ mconcat ["

", v, "

"] + -- Looking for a parameter 'p' in the path. + get "/foo_path/:p" $ do + v <- pathParam "p" + html $ mconcat ["

", v, "

"] + + -- Looking for a parameter 'p' in the query string. + get "/foo_query" $ do + v <- queryParam "p" + html $ mconcat ["

", v, "

"] + -- An uncaught error becomes a 500 page. get "/raise" $ throw Boom @@ -58,13 +68,13 @@ -- Of course you can catch your own errors. get "/rescue" $ do (do void $ throw Boom; redirect "http://www.we-never-go-here.com") - `rescue` (\(e :: Err) -> text $ "we recovered from " `mappend` pack (show e)) + `catch` (\(e :: Err) -> text $ "we recovered from " `mappend` pack (show e)) -- Parts of the URL that start with a colon match -- any string, and capture that value as a parameter. -- URL captures take precedence over query string parameters. get "/foo/:bar/required" $ do - v <- captureParam "bar" + v <- pathParam "bar" html $ mconcat ["

", v, "

"] -- Files are streamed directly to the client. @@ -81,7 +91,7 @@ json $ take 20 $ randomRs (1::Int,100) g get "/ints/:is" $ do - is <- captureParam "is" + is <- pathParam "is" json $ [(1::Int)..10] ++ is get "/setbody" $ do diff --git a/examples/cookies.hs b/examples/cookies.hs --- a/examples/cookies.hs +++ b/examples/cookies.hs @@ -33,7 +33,7 @@ H.input H.! type_ "submit" H.! value "set a cookie" post "/set-a-cookie" $ do - name' <- captureParam "name" - value' <- captureParam "value" + name' <- pathParam "name" + value' <- pathParam "value" setSimpleCookie name' value' redirect "/" diff --git a/examples/exceptions.hs b/examples/exceptions.hs --- a/examples/exceptions.hs +++ b/examples/exceptions.hs @@ -5,6 +5,7 @@ import Control.Exception (Exception(..)) import Control.Monad.IO.Class +import Control.Monad.IO.Unlift (MonadUnliftIO(..)) import Data.String (fromString) import Data.Typeable @@ -34,8 +35,12 @@ html $ fromString $ "

" ++ s ++ "

" main :: IO () -main = scottyT 3000 id $ do -- note, we aren't using any additional transformer layers - -- so we can just use 'id' for the runner. +main = do + scottyT 3000 id server -- note: we use 'id' since we don't have to run any effects at each action + +-- Any custom monad stack will need to implement 'MonadUnliftIO' +server :: MonadUnliftIO m => ScottyT m () +server = do middleware logStdoutDev defaultHandler handleEx -- define what to do with uncaught exceptions @@ -49,7 +54,7 @@ ] get "/switch/:val" $ do - v <- captureParam "val" + v <- pathParam "val" _ <- if even v then throw Forbidden else throw (NotFound v) text "this will never be reached" @@ -58,4 +63,4 @@ i <- liftIO randomIO let catchOne Forbidden = html "

Forbidden was randomly thrown, but we caught it." catchOne other = throw other - throw (if rBool then Forbidden else NotFound i) `rescue` catchOne + throw (if rBool then Forbidden else NotFound i) `catch` catchOne diff --git a/examples/upload.hs b/examples/upload.hs --- a/examples/upload.hs +++ b/examples/upload.hs @@ -4,6 +4,7 @@ import Web.Scotty import Control.Monad.IO.Class +import qualified Data.Text.Lazy as TL import Network.Wai.Middleware.RequestLogger import Network.Wai.Middleware.Static @@ -39,7 +40,7 @@ -- write the files to disk, so they will be served by the static middleware liftIO $ sequence_ [ B.writeFile ("uploads" fn) fc | (_,fn,fc) <- fs' ] -- generate list of links to the files just uploaded - html $ mconcat [ mconcat [ fName + html $ mconcat [ mconcat [ TL.fromStrict fName , ": " , renderHtml $ H.a (H.toHtml fn) H.! (href $ H.toValue fn) >> H.br ] diff --git a/examples/urlshortener.hs b/examples/urlshortener.hs --- a/examples/urlshortener.hs +++ b/examples/urlshortener.hs @@ -49,7 +49,7 @@ H.input H.! type_ "submit" post "/shorten" $ do - url <- captureParam "url" + url <- formParam "url" liftIO $ modifyMVar_ m $ \(i,db) -> return (i+1, M.insert i (T.pack url) db) redirect "/list" diff --git a/scotty.cabal b/scotty.cabal --- a/scotty.cabal +++ b/scotty.cabal @@ -1,5 +1,5 @@ Name: scotty -Version: 0.20.1 +Version: 0.21 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 @@ -22,7 +22,7 @@ . main = scotty 3000 $ get "/:word" $ do - beam <- captureParam "word" + beam <- pathParam "word" html $ mconcat ["<h1>Scotty, ", beam, " me up!</h1>"] @ . @@ -47,6 +47,7 @@ , GHC == 9.2.8 , GHC == 9.4.6 , GHC == 9.6.2 + , GHC == 9.6.3 Extra-source-files: README.md changelog.md @@ -60,18 +61,19 @@ Library Exposed-modules: Web.Scotty Web.Scotty.Trans + Web.Scotty.Trans.Strict Web.Scotty.Internal.Types Web.Scotty.Cookie other-modules: Web.Scotty.Action Web.Scotty.Body - Web.Scotty.Exceptions Web.Scotty.Route + Web.Scotty.Trans.Lazy Web.Scotty.Util default-language: Haskell2010 build-depends: aeson >= 0.6.2.1 && < 2.3, base >= 4.14 && < 5, blaze-builder >= 0.3.3.0 && < 0.5, - bytestring >= 0.10.0.2 && < 0.12, + bytestring >= 0.10.0.2 && < 0.13, case-insensitive >= 1.0.0.1 && < 1.3, cookie >= 0.4, data-default-class >= 0.1, @@ -120,6 +122,21 @@ wai build-tool-depends: hspec-discover:hspec-discover == 2.* GHC-options: -Wall -threaded -fno-warn-orphans + +test-suite doctest + main-is: Main.hs + type: exitcode-stdio-1.0 + default-language: Haskell2010 + GHC-options: -Wall -threaded -fno-warn-orphans + hs-source-dirs: doctest + build-depends: base + , bytestring + , doctest >= 0.20.1 + , http-client + , http-types + , scotty + , text + , wai benchmark weigh main-is: Main.hs diff --git a/test/Web/ScottySpec.hs b/test/Web/ScottySpec.hs --- a/test/Web/ScottySpec.hs +++ b/test/Web/ScottySpec.hs @@ -11,7 +11,7 @@ import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TLE import Network.HTTP.Types -import Network.Wai (Application, responseLBS) +import Network.Wai (Application, Request(queryString), responseLBS) import qualified Control.Exception.Lifted as EL import qualified Control.Exception as E @@ -56,6 +56,10 @@ it ("properly handles extra slash routes for " ++ method ++ " requests") $ do makeRequest "//scotty" `shouldRespondWith` 200 + withApp (route "/:paramName" $ captureParam "paramName" >>= text) $ do + it ("captures route parameters for " ++ method ++ " requests with url encoded '/' in path") $ do + makeRequest "/a%2Fb" `shouldRespondWith` "a/b" + describe "addroute" $ do forM_ availableMethods $ \method -> do withApp (addroute method "/scotty" $ html "") $ do @@ -92,14 +96,31 @@ withApp (do let h = Handler (\(_ :: E.ArithException) -> status status503) defaultHandler h - Scotty.get "/" (liftAndCatchIO $ E.throwIO E.DivideByZero)) $ do + Scotty.get "/" (liftIO $ E.throwIO E.DivideByZero)) $ do it "allows to customize the HTTP status code" $ do get "/" `shouldRespondWith` "" {matchStatus = 503} + withApp (do + let h = Handler (\(_ :: E.SomeException) -> setHeader "Location" "/c" >> status status500) + defaultHandler h + Scotty.get "/a" (redirect "/b")) $ do + it "should give priority to actionErrorHandlers" $ do + get "/a" `shouldRespondWith` 302 { matchHeaders = ["Location" <:> "/b"] } context "when not specified" $ do withApp (Scotty.get "/" $ throw E.DivideByZero) $ do it "returns 500 on exceptions" $ do get "/" `shouldRespondWith` "" {matchStatus = 500} + context "only applies to endpoints defined after it (#237)" $ do + withApp (do + let h = Handler (\(_ :: E.SomeException) -> status status503 >> text "ok") + Scotty.get "/a" (throw E.DivideByZero) + defaultHandler h + Scotty.get "/b" (throw E.DivideByZero) + ) $ do + it "doesn't catch an exception before the handler is set" $ do + get "/a" `shouldRespondWith` 500 + it "catches an exception after the handler is set" $ do + get "/b" `shouldRespondWith` "ok" {matchStatus = 503} describe "setMaxRequestBodySize" $ do @@ -119,7 +140,17 @@ request "POST" "/" [("Content-Type","multipart/form-data; boundary=--33")] large `shouldRespondWith` 200 + describe "middleware" $ do + context "can rewrite the query string (#348)" $ do + withApp (do + Scotty.middleware $ \app req sendResponse -> + app req{queryString = [("query", Just "haskell")]} sendResponse + Scotty.matchAny "/search" $ queryParam "query" >>= text + ) $ do + it "returns query parameter with given name" $ do + get "/search" `shouldRespondWith` "haskell" + describe "ActionM" $ do context "MonadBaseControl instance" $ do withApp (Scotty.get "/" $ (undefined `EL.catch` ((\_ -> html "") :: E.SomeException -> ActionM ()))) $ do @@ -145,7 +176,7 @@ withApp (Scotty.get "/" $ fail "boom!") $ do it "returns 500 if not caught" $ get "/" `shouldRespondWith` 500 - withApp (Scotty.get "/" $ (fail "boom!") `rescue` (\(_ :: StatusError) -> text "ok")) $ + withApp (Scotty.get "/" $ (fail "boom!") `catch` (\(_ :: StatusError) -> text "ok")) $ it "can catch the StatusError thrown by fail" $ do get "/" `shouldRespondWith` 200 { matchBody = "ok"} @@ -188,7 +219,7 @@ get "/search/potato" `shouldRespondWith` 500 context "recover from missing parameter exception" $ do withApp (Scotty.get "/search/:q" $ - (captureParam "z" >>= text) `rescue` (\(_::StatusError) -> text "z") + (captureParam "z" >>= text) `catch` (\(_::ScottyException) -> text "z") ) $ do it "catches a StatusError" $ do get "/search/xxx" `shouldRespondWith` 200 { matchBody = "z"} @@ -206,9 +237,9 @@ get "/search?query=potato" `shouldRespondWith` 400 context "recover from type mismatch parameter exception" $ do withApp (Scotty.get "/search" $ - (queryParam "z" >>= (\v -> json (v :: Int))) `rescue` (\(_::StatusError) -> text "z") + (queryParam "z" >>= (\v -> json (v :: Int))) `catch` (\(_::ScottyException) -> text "z") ) $ do - it "catches a StatusError" $ do + it "catches a ScottyException" $ do get "/search?query=potato" `shouldRespondWith` 200 { matchBody = "z"} describe "formParam" $ do @@ -238,10 +269,30 @@ postForm "/" "p=42" `shouldRespondWith` "42" context "recover from type mismatch parameter exception" $ do withApp (Scotty.post "/search" $ - (formParam "z" >>= (\v -> json (v :: Int))) `rescue` (\(_::StatusError) -> text "z") + (formParam "z" >>= (\v -> json (v :: Int))) `catch` (\(_::ScottyException) -> text "z") ) $ do it "catches a StatusError" $ do postForm "/search" "z=potato" `shouldRespondWith` 200 { matchBody = "z"} + + describe "captureParamMaybe" $ do + withApp ( + do + Scotty.get "/a/:q" $ do + mx <- captureParamMaybe "q" + case mx of + Just (_ :: Int) -> status status200 + Nothing -> status status500 + Scotty.get "/b/:q" $ do + mx <- captureParamMaybe "z" + case mx of + Just (_ :: TL.Text) -> text "impossible" >> status status500 + Nothing -> status status200 + ) $ do + it "responds with 200 OK if the parameter can be parsed at the right type, 500 otherwise" $ do + get "/a/potato" `shouldRespondWith` 500 + get "/a/42" `shouldRespondWith` 200 + it "responds with 200 OK if the parameter is not found" $ do + get "/b/potato" `shouldRespondWith` 200 describe "text" $ do