Nested WAI Applications under Scotty Routes

.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
+    , middleware, get, post, put, delete, patch, options, addroute, matchAny, notFound, nested
       -- ** 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
+
 -- | Throw an exception, which can be caught with 'rescue'. Uncaught exceptions
 -- turn into HTTP 500 responses.
 raise :: Text -> ActionM a
@@ -108,7 +120,7 @@ raise = Trans.raise
 -- > 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
@@ -19,6 +20,7 @@ module Web.Scotty.Action
     , params
     , raise
     , raw
+    , nested
     , readEither
     , redirect
     , request
@@ -40,6 +42,7 @@ import           Control.Monad.Error.Class
 import           Control.Monad.Reader
 import qualified Control.Monad.State        as MS
 import           Control.Monad.Trans.Except
+import           Control.Concurrent.MVar
 
 import qualified Data.Aeson                 as A
 import qualified Data.ByteString.Char8      as B
@@ -63,6 +66,8 @@ import           Numeric.Natural
 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)
@@ -91,6 +96,7 @@ defH _          Finish            = return ()
 raise :: (ScottyError e, Monad m) => e -> ActionT e m a
 raise = throwError . ActionError
 
+
 -- | Abort execution of this action and continue pattern matching routes.
 -- Like an exception, any code after 'next' is not executed.
 --
@@ -301,6 +307,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 ()
@@ -319,3 +328,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

@@ -123,9 +123,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, rescue, next, finish, defaultHandler, ScottyError(..), liftAndCatchIO
       -- * Parsing Parameters

Web/Scotty/Util.hs

@@ -44,9 +44,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
 

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
+
+