From 9d8e1d63d77c681858132109bc14ce9ca5a0a9e2 Mon Sep 17 00:00:00 2001 From: Lyndon Maydwell Date: Thu, 24 Oct 2019 14:36:28 +1100 Subject: [PATCH 1/8] nesting apps works --- Web/Scotty.hs | 22 +++++++++++- Web/Scotty/Action.hs | 5 +++ Web/Scotty/Internal/Types.hs | 7 ++-- Web/Scotty/Util.hs | 7 ++-- examples/nested.hs | 58 +++++++++++++++++++++++++++++++ stack.yaml | 67 ++++++++++++++++++++++++++++++++++++ stack.yaml.lock | 12 +++++++ 7 files changed, 171 insertions(+), 7 deletions(-) create mode 100644 examples/nested.hs create mode 100644 stack.yaml create mode 100644 stack.yaml.lock diff --git a/Web/Scotty.hs b/Web/Scotty.hs index 286ec792..e34dc8c5 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 + , middleware, get, post, put, delete, patch, options, addroute, matchAny, notFound, nested -- ** Route Patterns , capture, regex, function, literal -- ** Accessing the Request, Captures, and Query Parameters @@ -40,13 +40,17 @@ import Data.Aeson (FromJSON, ToJSON) import qualified Data.ByteString as BS import Data.ByteString.Lazy.Char8 (ByteString) import Data.Text.Lazy (Text) +import Control.Concurrent.MVar +import Control.Monad.IO.Class import Network.HTTP.Types (Status, StdMethod) import Network.Socket (Socket) import Network.Wai (Application, Middleware, Request, StreamingBody) import Network.Wai.Handler.Warp (Port) +import Network.Wai.Internal (ResponseReceived(..)) import Web.Scotty.Internal.Types (ScottyT, ActionT, Param, RoutePattern, Options, File) +import Web.Scotty.Action (rawResponse) type ScottyM = ScottyT Text IO type ActionM = ActionT Text IO @@ -89,6 +93,22 @@ 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 app = do + -- Is MVar really the best choice here? Not sure. + r <- request + ref <- liftIO $ newEmptyMVar + _ <- liftAndCatchIO $ app r (\res -> liftIO (putMVar ref res) >> return ResponseReceived) + res <- liftIO $ readMVar ref + rawResponse res + -- | Throw an exception, which can be caught with 'rescue'. Uncaught exceptions -- turn into HTTP 500 responses. raise :: Text -> ActionM a diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs index d7c67648..cd06c32f 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 @@ -91,6 +92,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 +303,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 () diff --git a/Web/Scotty/Internal/Types.hs b/Web/Scotty/Internal/Types.hs index eda09ef9..eae3f5d5 100644 --- a/Web/Scotty/Internal/Types.hs +++ b/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 diff --git a/Web/Scotty/Util.hs b/Web/Scotty/Util.hs index 36246df9..a486277f 100644 --- a/Web/Scotty/Util.hs +++ b/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 diff --git a/examples/nested.hs b/examples/nested.hs new file mode 100644 index 00000000..35a7f196 --- /dev/null +++ b/examples/nested.hs @@ -0,0 +1,58 @@ +{-# 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, bean me up!

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

Scotty, ", beam, " me up!

"] + + get "/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, bean 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/stack.yaml b/stack.yaml new file mode 100644 index 00000000..64088110 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,67 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# https://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# +# The location of a snapshot can be provided as a file or url. Stack assumes +# a snapshot provided as a file might change, whereas a url resource does not. +# +# resolver: ./custom-snapshot.yaml +# resolver: https://example.com/snapshots/2018-01-01.yaml +resolver: lts-14.8 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# subdirs: +# - auto-update +# - wai +packages: +- . +- examples +# Dependency packages to be pulled from upstream that are not in the resolver. +# These entries can reference officially published versions as well as +# forks / in-progress versions pinned to a git hash. For example: +# +# extra-deps: +# - acme-missiles-0.3 +# - git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# +# extra-deps: [] + +# Override default flag values for local packages and extra-deps +# flags: {} + +# Extra package databases containing global packages +# extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=2.1" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor diff --git a/stack.yaml.lock b/stack.yaml.lock new file mode 100644 index 00000000..49189701 --- /dev/null +++ b/stack.yaml.lock @@ -0,0 +1,12 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: [] +snapshots: +- completed: + size: 524789 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/8.yaml + sha256: 8af5eb80734f02621d37e82cc0cde614af2ddc9c320610acb0b1b6d9ac162930 + original: lts-14.8 From 1d2846dad0685e4e47408d520862121df31924fd Mon Sep 17 00:00:00 2001 From: Lyndon Maydwell Date: Thu, 24 Oct 2019 16:33:05 +1100 Subject: [PATCH 2/8] trans instance for nested --- Web/Scotty.hs | 19 +++++++------------ Web/Scotty/Action.hs | 15 +++++++++++++++ Web/Scotty/Trans.hs | 2 +- examples/nested.hs | 7 ++++++- 4 files changed, 29 insertions(+), 14 deletions(-) diff --git a/Web/Scotty.hs b/Web/Scotty.hs index e34dc8c5..d31b2f40 100644 --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -40,17 +40,13 @@ import Data.Aeson (FromJSON, ToJSON) import qualified Data.ByteString as BS import Data.ByteString.Lazy.Char8 (ByteString) import Data.Text.Lazy (Text) -import Control.Concurrent.MVar -import Control.Monad.IO.Class import Network.HTTP.Types (Status, StdMethod) import Network.Socket (Socket) import Network.Wai (Application, Middleware, Request, StreamingBody) import Network.Wai.Handler.Warp (Port) -import Network.Wai.Internal (ResponseReceived(..)) import Web.Scotty.Internal.Types (ScottyT, ActionT, Param, RoutePattern, Options, File) -import Web.Scotty.Action (rawResponse) type ScottyM = ScottyT Text IO type ActionM = ActionT Text IO @@ -100,14 +96,13 @@ middleware = Trans.middleware -- 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 app = do - -- Is MVar really the best choice here? Not sure. - r <- request - ref <- liftIO $ newEmptyMVar - _ <- liftAndCatchIO $ app r (\res -> liftIO (putMVar ref res) >> return ResponseReceived) - res <- liftIO $ readMVar ref - rawResponse res +nested = Trans.nested + +group :: ScottyM () -> ActionM () +group = undefined -- | Throw an exception, which can be caught with 'rescue'. Uncaught exceptions -- turn into HTTP 500 responses. @@ -128,7 +123,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' diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs index cd06c32f..acabddeb 100644 --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -20,6 +20,7 @@ module Web.Scotty.Action , params , raise , raw + , nested , readEither , redirect , request @@ -41,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 @@ -64,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) @@ -324,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 diff --git a/Web/Scotty/Trans.hs b/Web/Scotty/Trans.hs index ebedb24f..96bede54 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, rescue, next, finish, defaultHandler, ScottyError(..), liftAndCatchIO -- * Parsing Parameters diff --git a/examples/nested.hs b/examples/nested.hs index 35a7f196..f75e7fe3 100644 --- a/examples/nested.hs +++ b/examples/nested.hs @@ -22,11 +22,16 @@ scottApp = scottyApp $ do get "/" $ do html $ mconcat ["

Scotty, bean 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 "/nested" $ nested simpleApp + get "/other/nested" $ nested simpleApp notFound $ do r <- request From 8bd9ed89906df03609f2116fd62778a244e9f491 Mon Sep 17 00:00:00 2001 From: Lyndon Maydwell Date: Thu, 24 Oct 2019 16:34:28 +1100 Subject: [PATCH 3/8] don't commit group --- Web/Scotty.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/Web/Scotty.hs b/Web/Scotty.hs index d31b2f40..804bd0af 100644 --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -101,9 +101,6 @@ middleware = Trans.middleware nested :: Application -> ActionM () nested = Trans.nested -group :: ScottyM () -> ActionM () -group = undefined - -- | Throw an exception, which can be caught with 'rescue'. Uncaught exceptions -- turn into HTTP 500 responses. raise :: Text -> ActionM a From bd00dcf5e0288a944901f4ed9f75a5065b08163c Mon Sep 17 00:00:00 2001 From: Lyndon Maydwell Date: Thu, 24 Oct 2019 16:35:50 +1100 Subject: [PATCH 4/8] stack isn't required... --- stack.yaml | 67 ------------------------------------------------- stack.yaml.lock | 12 --------- 2 files changed, 79 deletions(-) delete mode 100644 stack.yaml delete mode 100644 stack.yaml.lock diff --git a/stack.yaml b/stack.yaml deleted file mode 100644 index 64088110..00000000 --- a/stack.yaml +++ /dev/null @@ -1,67 +0,0 @@ -# This file was automatically generated by 'stack init' -# -# Some commonly used options have been documented as comments in this file. -# For advanced use and comprehensive documentation of the format, please see: -# https://docs.haskellstack.org/en/stable/yaml_configuration/ - -# Resolver to choose a 'specific' stackage snapshot or a compiler version. -# A snapshot resolver dictates the compiler version and the set of packages -# to be used for project dependencies. For example: -# -# resolver: lts-3.5 -# resolver: nightly-2015-09-21 -# resolver: ghc-7.10.2 -# -# The location of a snapshot can be provided as a file or url. Stack assumes -# a snapshot provided as a file might change, whereas a url resource does not. -# -# resolver: ./custom-snapshot.yaml -# resolver: https://example.com/snapshots/2018-01-01.yaml -resolver: lts-14.8 - -# User packages to be built. -# Various formats can be used as shown in the example below. -# -# packages: -# - some-directory -# - https://example.com/foo/bar/baz-0.0.2.tar.gz -# subdirs: -# - auto-update -# - wai -packages: -- . -- examples -# Dependency packages to be pulled from upstream that are not in the resolver. -# These entries can reference officially published versions as well as -# forks / in-progress versions pinned to a git hash. For example: -# -# extra-deps: -# - acme-missiles-0.3 -# - git: https://github.com/commercialhaskell/stack.git -# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# -# extra-deps: [] - -# Override default flag values for local packages and extra-deps -# flags: {} - -# Extra package databases containing global packages -# extra-package-dbs: [] - -# Control whether we use the GHC we find on the path -# system-ghc: true -# -# Require a specific version of stack, using version ranges -# require-stack-version: -any # Default -# require-stack-version: ">=2.1" -# -# Override the architecture used by stack, especially useful on Windows -# arch: i386 -# arch: x86_64 -# -# Extra directories used by stack for building -# extra-include-dirs: [/path/to/dir] -# extra-lib-dirs: [/path/to/dir] -# -# Allow a newer minor version of GHC than the snapshot specifies -# compiler-check: newer-minor diff --git a/stack.yaml.lock b/stack.yaml.lock deleted file mode 100644 index 49189701..00000000 --- a/stack.yaml.lock +++ /dev/null @@ -1,12 +0,0 @@ -# This file was autogenerated by Stack. -# You should not edit this file by hand. -# For more information, please see the documentation at: -# https://docs.haskellstack.org/en/stable/lock_files - -packages: [] -snapshots: -- completed: - size: 524789 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/8.yaml - sha256: 8af5eb80734f02621d37e82cc0cde614af2ddc9c320610acb0b1b6d9ac162930 - original: lts-14.8 From c2184bb6efb1278340b99d6831242c47b47a3680 Mon Sep 17 00:00:00 2001 From: Lyndon Maydwell Date: Thu, 24 Oct 2019 16:36:15 +1100 Subject: [PATCH 5/8] ignoring stack --- .gitignore | 3 +++ 1 file changed, 3 insertions(+) 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 + From 089872039f73ab8b9006c30b12f341e3b7c1df48 Mon Sep 17 00:00:00 2001 From: Lyndon Maydwell Date: Thu, 6 Jul 2023 14:01:51 +1000 Subject: [PATCH 6/8] Spelling bean -> beam --- examples/nested.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/examples/nested.hs b/examples/nested.hs index f75e7fe3..2bb4477b 100644 --- a/examples/nested.hs +++ b/examples/nested.hs @@ -20,7 +20,7 @@ scottApp :: IO Application scottApp = scottyApp $ do get "/" $ do - html $ mconcat ["

Scotty, bean me up!

"] + html $ mconcat ["

Scotty, beam me up!

"] get "/other/test/:word" $ do beam <- param "word" @@ -48,7 +48,7 @@ main = do scotty 3000 $ do get "/" $ do - html $ mconcat ["

Scotty, bean me up!

"] + html $ mconcat ["

Scotty, beam me up!

"] get "/test/:word" $ do beam <- param "word" From 5fcd45d4f08f492eb00426360dd6e6851cde5f30 Mon Sep 17 00:00:00 2001 From: Lyndon Maydwell Date: Fri, 7 Jul 2023 18:48:59 +1000 Subject: [PATCH 7/8] spec added --- test/Web/ScottySpec.hs | 15 +++++++++++++++ 1 file changed, 15 insertions(+) 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" . From 1358e6f036cd5cd9e4f3816318beba660826a5d5 Mon Sep 17 00:00:00 2001 From: Lyndon Maydwell Date: Sat, 23 Sep 2023 20:00:16 +1000 Subject: [PATCH 8/8] Changelog entry --- changelog.md | 1 + 1 file changed, 1 insertion(+) 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.