diff --git a/.gitignore b/.gitignore index 82f3a88e..11ff6f1c 100644 --- a/.gitignore +++ b/.gitignore @@ -20,3 +20,6 @@ cabal.project.local cabal.project.local~ .HTF/ .ghc.environment.* +stack.yaml +stack.yaml.lock + diff --git a/Web/Scotty.hs b/Web/Scotty.hs index 889817e9..649f9bbc 100644 --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -13,7 +13,7 @@ module Web.Scotty -- | '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 + , 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 @@ -89,6 +89,18 @@ defaultHandler = Trans.defaultHandler middleware :: Middleware -> ScottyM () middleware = Trans.middleware +-- | Nest a whole WAI application inside a Scotty handler. +-- Note: You will want to ensure that this route fully handles the response, +-- as there is no easy delegation as per normal Scotty actions. +-- Also, you will have to carefully ensure that you are expecting the correct routes, +-- this could require stripping the current prefix, or adding the prefix to your +-- application's handlers if it depends on them. One potential use-case for this +-- is hosting a web-socket handler under a specific route. +-- nested :: Application -> ActionM () +-- nested :: (Monad m, MonadIO m) => Application -> ActionT Text m () +nested :: Application -> ActionM () +nested = Trans.nested + -- | Set global size limit for the request body. Requests with body size exceeding the limit will not be -- processed and an HTTP response 413 will be returned to the client. Size limit needs to be greater than 0, -- otherwise the application will terminate on start. @@ -118,7 +130,7 @@ raiseStatus = Trans.raiseStatus -- > get "/foo/:baz" $ do -- > w <- param "baz" -- > text $ "You made a request to: " <> w -next :: ActionM a +next :: ActionM () next = Trans.next -- | Abort execution of this action. Like an exception, any code after 'finish' diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs index f40402bd..331a0c9d 100644 --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -6,6 +6,7 @@ module Web.Scotty.Action , body , bodyReader , file + , rawResponse , files , finish , header @@ -20,6 +21,7 @@ module Web.Scotty.Action , raise , raiseStatus , raw + , nested , readEither , redirect , request @@ -43,6 +45,7 @@ import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Reader (MonadReader(..), ReaderT(..)) import qualified Control.Monad.State.Strict as MS import Control.Monad.Trans.Except +import Control.Concurrent.MVar import qualified Data.Aeson as A import qualified Data.ByteString.Char8 as B @@ -71,6 +74,8 @@ import Prelude.Compat import Web.Scotty.Internal.Types import Web.Scotty.Util +import Network.Wai.Internal (ResponseReceived(..)) + -- Nothing indicates route failed (due to Next) and pattern matching should continue. -- Just indicates a successful response. runAction :: (ScottyError e, Monad m) => ErrorHandler e m -> ActionEnv -> ActionT e m () -> m (Maybe Response) @@ -105,6 +110,7 @@ raise = raiseStatus status500 raiseStatus :: (ScottyError e, Monad m) => Status -> e -> ActionT e m a raiseStatus s = throwError . ActionError s + -- | Abort execution of this action and continue pattern matching routes. -- Like an exception, any code after 'next' is not executed. -- @@ -340,6 +346,9 @@ html t = do file :: Monad m => FilePath -> ActionT e m () file = ActionT . MS.modify . setContent . ContentFile +rawResponse :: Monad m => Response -> ActionT e m () +rawResponse = ActionT . MS.modify . setContent . ContentResponse + -- | Set the body of the response to the JSON encoding of the given value. Also sets \"Content-Type\" -- header to \"application/json; charset=utf-8\" if it has not already been set. json :: (A.ToJSON a, ScottyError e, Monad m) => a -> ActionT e m () @@ -358,3 +367,14 @@ stream = ActionT . MS.modify . setContent . ContentStream -- own with 'setHeader'. raw :: Monad m => BL.ByteString -> ActionT e m () raw = ActionT . MS.modify . setContent . ContentBuilder . fromLazyByteString + +-- | Nest a whole WAI application inside a Scotty handler. +-- See Web.Scotty for further documentation +nested :: (ScottyError e, MonadIO m) => Network.Wai.Application -> ActionT e m () +nested app = do + -- 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 + rawResponse res diff --git a/Web/Scotty/Internal/Types.hs b/Web/Scotty/Internal/Types.hs index 1098f142..9e7c5890 100644 --- a/Web/Scotty/Internal/Types.hs +++ b/Web/Scotty/Internal/Types.hs @@ -148,9 +148,10 @@ data BodyPartiallyStreamed = BodyPartiallyStreamed deriving (Show, Typeable) instance E.Exception BodyPartiallyStreamed -data Content = ContentBuilder Builder - | ContentFile FilePath - | ContentStream StreamingBody +data Content = ContentBuilder Builder + | ContentFile FilePath + | ContentStream StreamingBody + | ContentResponse Response data ScottyResponse = SR { srStatus :: Status , srHeaders :: ResponseHeaders diff --git a/Web/Scotty/Trans.hs b/Web/Scotty/Trans.hs index 1a7d1fb7..611e2282 100644 --- a/Web/Scotty/Trans.hs +++ b/Web/Scotty/Trans.hs @@ -28,7 +28,7 @@ module Web.Scotty.Trans -- -- | 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 + , text, html, file, json, stream, raw, nested -- ** Exceptions , raise, raiseStatus, rescue, next, finish, defaultHandler, ScottyError(..), liftAndCatchIO -- * Parsing Parameters diff --git a/Web/Scotty/Util.hs b/Web/Scotty/Util.hs index ebd31be6..b6e56bbc 100644 --- a/Web/Scotty/Util.hs +++ b/Web/Scotty/Util.hs @@ -48,9 +48,10 @@ setStatus s sr = sr { srStatus = s } -- is incompatible with responseRaw responses. mkResponse :: ScottyResponse -> Response mkResponse sr = case srContent sr of - ContentBuilder b -> responseBuilder s h b - ContentFile f -> responseFile s h f Nothing - ContentStream str -> responseStream s h str + ContentBuilder b -> responseBuilder s h b + ContentFile f -> responseFile s h f Nothing + ContentStream str -> responseStream s h str + ContentResponse res -> res where s = srStatus sr h = srHeaders sr diff --git a/changelog.md b/changelog.md index 465edd7f..67cdc49a 100644 --- a/changelog.md +++ b/changelog.md @@ -1,4 +1,5 @@ ## next [????.??.??] +* Adds a new `nested` handler that allows you to place an entire WAI Application under a Scotty route ## 0.12.1 [2022.11.17] * Fix CPP bug that prevented tests from building on Windows. diff --git a/examples/nested.hs b/examples/nested.hs new file mode 100644 index 00000000..2bb4477b --- /dev/null +++ b/examples/nested.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Web.Scotty +import Network.Wai +import qualified Data.Text.Lazy as TL +import Network.HTTP.Types.Status +import Data.Monoid (mconcat) + +simpleApp :: Application +simpleApp _ respond = do + putStrLn "I've done some IO here" + respond $ responseLBS + status200 + [("Content-Type", "text/plain")] + "Hello, Web!" + +scottApp :: IO Application +scottApp = scottyApp $ do + + get "/" $ do + html $ mconcat ["

Scotty, beam me up!

"] + + get "/other/test/:word" $ do + beam <- param "word" + html $ mconcat ["

Scotty, ", beam, " me up!

"] + + get "/test/:word" $ do + beam <- param "word" + html $ mconcat ["

Scotty, ", beam, " me up!

"] + + get "/nested" $ nested simpleApp + get "/other/nested" $ nested simpleApp + + notFound $ do + r <- request + html (TL.pack (show (pathInfo r))) + + -- For example, returns path info: ["other","qwer","adxf","jkashdfljhaslkfh","qwer"] + -- for request http://localhost:3000/other/qwer/adxf/jkashdfljhaslkfh/qwer + +main :: IO () +main = do + + otherApp <- scottApp + + scotty 3000 $ do + + get "/" $ do + html $ mconcat ["

Scotty, beam me up!

"] + + get "/test/:word" $ do + beam <- param "word" + html $ mconcat ["

Scotty, ", beam, " me up!

"] + + get "/simple" $ nested simpleApp + + get "/other" $ nested otherApp + + get (regex "/other/.*") $ nested otherApp + + diff --git a/test/Web/ScottySpec.hs b/test/Web/ScottySpec.hs index 2b47d242..6492edac 100644 --- a/test/Web/ScottySpec.hs +++ b/test/Web/ScottySpec.hs @@ -11,6 +11,7 @@ import Data.String 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 qualified Control.Exception.Lifted as EL import qualified Control.Exception as E @@ -191,6 +192,20 @@ spec = do it "responds with a Set-Cookie header with expiry date Jan 1, 1970" $ do get "/scotty" `shouldRespondWith` 200 {matchHeaders = ["Set-Cookie" <:> "foo=; Expires=Thu, 01-Jan-1970 00:00:00 GMT"]} + describe "nested" $ do + let + simpleApp :: Application + simpleApp _ respond = do + putStrLn "I've done some IO here" + respond $ responseLBS + status200 + [("Content-Type", "text/plain")] + "Hello, Web!" + + 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!"} + -- Unix sockets not available on Windows #if !defined(mingw32_HOST_OS) describe "scottySocket" .