Nested WAI Applications under Scotty Routes (#233)

* nesting apps works

* trans instance for nested

* don't commit group

* ignoring stack

* spec added

* Changelog entry

.gitignore

@@ -20,3 +20,6 @@ cabal.project.local
 cabal.project.local~
 .HTF/
 .ghc.environment.*
+stack.yaml
+stack.yaml.lock
+

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'

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

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

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

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
 

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.

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 ["<h1>Scotty, beam me up!</h1>"]
+
+    get "/other/test/:word" $ do
+        beam <- param "word"
+        html $ mconcat ["<h1>Scotty, ", beam, " me up!</h1>"]
+
+    get "/test/:word" $ do
+        beam <- param "word"
+        html $ mconcat ["<h1>Scotty, ", beam, " me up!</h1>"]
+
+    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 ["<h1>Scotty, beam me up!</h1>"]
+
+    get "/test/:word" $ do
+        beam <- param "word"
+        html $ mconcat ["<h1>Scotty, ", beam, " me up!</h1>"]
+
+    get "/simple" $ nested simpleApp
+
+    get "/other" $ nested otherApp
+
+    get (regex "/other/.*") $ nested otherApp
+
+

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" .