From 6a1fee251bd63e451c60c46a68a7ed9c22a0b447 Mon Sep 17 00:00:00 2001 From: Marco Zocca Date: Fri, 1 Dec 2023 07:06:40 +0100 Subject: [PATCH 1/7] WIP example docstrings using curl should be ported to use hspec-wai --- doctest/Main.hs | 10 ++++++++++ scotty.cabal | 8 ++++++++ 2 files changed, 18 insertions(+) create mode 100644 doctest/Main.hs diff --git a/doctest/Main.hs b/doctest/Main.hs new file mode 100644 index 00000000..656ceb81 --- /dev/null +++ b/doctest/Main.hs @@ -0,0 +1,10 @@ +module Main where + +import Test.DocTest (doctest) + +main :: IO () +main = doctest [ + "Web" + , "-XOverloadedStrings" + , "-XLambdaCase" + ] diff --git a/scotty.cabal b/scotty.cabal index 97b2cd12..bd0a1b4f 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -122,6 +122,14 @@ test-suite spec 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 + hs-source-dirs: doctest + build-depends: base + , doctest + benchmark weigh main-is: Main.hs type: exitcode-stdio-1.0 From 211f4c67b581d2c0cf1ea8935c1126638a808a35 Mon Sep 17 00:00:00 2001 From: Marco Zocca Date: Sat, 2 Dec 2023 05:04:30 +0100 Subject: [PATCH 2/7] WIP some haddock syntax error with multiline decls --- Web/Scotty.hs | 46 +++++++++++++++++++++++++++++++++------------- doctest/Main.hs | 3 ++- scotty.cabal | 5 +++++ 3 files changed, 40 insertions(+), 14 deletions(-) diff --git a/Web/Scotty.hs b/Web/Scotty.hs index c5c6829f..e4e2954f 100644 --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -62,6 +62,22 @@ import Web.Scotty.Internal.Types (ScottyT, ActionT, ErrorHandler, Param, RoutePa import UnliftIO.Exception (Handler(..), catch) +-- $setup +-- >>> import Control.Monad.IO.Class (liftIO) +-- >>> import qualified Network.HTTP.Client as H +-- >>> import qualified Network.HTTP.Types as H +-- >>> import qualified Data.ByteString.Lazy.Char8 as LBS (unpack) +-- >>> import qualified Web.Scotty as S (scotty, get, text, pathParam) +-- >>> :{ +-- let +-- curl :: MonadIO m => String -> m String +-- 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 +-- :} + type ScottyM = ScottyT IO type ActionM = ActionT IO @@ -410,16 +426,18 @@ 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!" +-- > 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'. +-- as /captures/. These are parameters that can be looked up with 'pathParam'. -- --- > addroute GET "/foo/:bar" $ do --- > v <- param "bar" --- > text v +-- >>> :{ +-- let server = S.get "/foo/:bar" (S.pathParam "bar" >>= S.text) +-- in do +-- S.scotty 3000 server -- --- >>> curl http://localhost:3000/foo/something +-- curl "http://localhost:3000/foo/something" +-- :} -- something addroute :: StdMethod -> RoutePattern -> ActionM () -> ScottyM () addroute = Trans.addroute @@ -427,13 +445,15 @@ 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] +-- >>> :{ +-- let server = S.get (S.regex "^/f(.*)r$") $ do +-- cap <- S.pathParam "1" +-- S.text ["Capture:", cap] +-- in do +-- S.scotty 3000 server -- --- >>> curl http://localhost:3000/foo/bar --- Path: /foo/bar +-- curl "http://localhost:3000/foo/bar" +-- :} -- Capture: oo/ba -- regex :: String -> RoutePattern @@ -463,7 +483,7 @@ capture = Trans.capture -- > v <- param "version" -- > text v -- --- >>> curl http://localhost:3000/ +-- >>> curl "http://localhost:3000/" -- HTTP/1.1 -- function :: (Request -> Maybe [Param]) -> RoutePattern diff --git a/doctest/Main.hs b/doctest/Main.hs index 656ceb81..446bfaa4 100644 --- a/doctest/Main.hs +++ b/doctest/Main.hs @@ -4,7 +4,8 @@ import Test.DocTest (doctest) main :: IO () main = doctest [ - "Web" + "Web/Scotty.hs" + , "Web/Scotty/Trans.hs" , "-XOverloadedStrings" , "-XLambdaCase" ] diff --git a/scotty.cabal b/scotty.cabal index bd0a1b4f..72abcfa2 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -126,9 +126,14 @@ 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 + , http-client + , http-types + , scotty benchmark weigh main-is: Main.hs From e74d472a5826fe88c7cfb411af282272598aeb1b Mon Sep 17 00:00:00 2001 From: Marco Zocca Date: Sun, 3 Dec 2023 09:06:30 +0100 Subject: [PATCH 3/7] doctests work --- Web/Scotty.hs | 127 ++++++++++++++++++++++++-------------------- Web/Scotty/Route.hs | 113 ++++++++++++++++++++++++--------------- scotty.cabal | 2 + 3 files changed, 141 insertions(+), 101 deletions(-) diff --git a/Web/Scotty.hs b/Web/Scotty.hs index e4e2954f..5317f085 100644 --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -61,22 +61,33 @@ import Network.Wai.Handler.Warp (Port) 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 (liftIO) --- >>> import qualified Network.HTTP.Client as H --- >>> import qualified Network.HTTP.Types as H --- >>> import qualified Data.ByteString.Lazy.Char8 as LBS (unpack) --- >>> import qualified Web.Scotty as S (scotty, get, text, pathParam) --- >>> :{ --- let --- curl :: MonadIO m => String -> m String --- 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 --- :} +{- $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 @@ -423,39 +434,37 @@ matchAny = Trans.matchAny 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. --- --- > 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 --- S.scotty 3000 server --- --- 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. --- --- >>> :{ --- let server = S.get (S.regex "^/f(.*)r$") $ do --- cap <- S.pathParam "1" --- S.text ["Capture:", cap] --- in do --- S.scotty 3000 server --- --- curl "http://localhost:3000/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 @@ -474,18 +483,20 @@ regex = Trans.regex 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 diff --git a/Web/Scotty/Route.hs b/Web/Scotty/Route.hs index 1005d01b..cd96a837 100644 --- a/Web/Scotty/Route.hs +++ b/Web/Scotty/Route.hs @@ -27,6 +27,34 @@ import Web.Scotty.Internal.Types (RoutePattern(..), RouteOptions, Acti 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 @@ -60,23 +88,21 @@ matchAny pat action = ScottyT $ MS.modify $ \s -> addRoute (route (routeOptions 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 @@ -145,22 +171,22 @@ mkEnv bodyInfo req captureps opts = do parseEncodedParams :: B.ByteString -> [Param] parseEncodedParams bs = [ (k, fromMaybe "" v) | (k,v) <- parseQueryText bs ] --- | 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. @@ -178,18 +204,19 @@ regex pattern = Function $ \ req -> fmap (map (T.pack . show *** T.pack) . zip [ 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/scotty.cabal b/scotty.cabal index 72abcfa2..b6b2941e 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -134,6 +134,8 @@ test-suite doctest , http-client , http-types , scotty + , text + , wai benchmark weigh main-is: Main.hs From 8158a8c06f51b9fb35000a1618e634d4ee0668d3 Mon Sep 17 00:00:00 2001 From: Marco Zocca Date: Sun, 3 Dec 2023 09:12:57 +0100 Subject: [PATCH 4/7] fix typo in Action --- Web/Scotty/Action.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs index 54a12a3d..b73e691a 100644 --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -569,7 +569,7 @@ html t = do changeHeader addIfNotPresent "Content-Type" "text/html; charset=utf-8" raw $ BL.fromStrict $ encodeUtf8 t - -- | Set the body of the response to the given 'T.Text' value. Also sets \"Content-Type\" +-- | 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 From d8edaef609f587a617fd59ca9dbcbe2643326041 Mon Sep 17 00:00:00 2001 From: Marco Zocca Date: Sun, 3 Dec 2023 09:20:07 +0100 Subject: [PATCH 5/7] fix comment syntax in Route for 8.10 compat --- Web/Scotty/Route.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/Web/Scotty/Route.hs b/Web/Scotty/Route.hs index cd96a837..8a9cb049 100644 --- a/Web/Scotty/Route.hs +++ b/Web/Scotty/Route.hs @@ -111,10 +111,8 @@ route :: (MonadUnliftIO m) => -> 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 From 6f8dea7145b577b12f672d00b9cb5c391320a739 Mon Sep 17 00:00:00 2001 From: Marco Zocca Date: Sun, 3 Dec 2023 09:26:17 +0100 Subject: [PATCH 6/7] weird doctest failures on ghc < 9.4 --- scotty.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scotty.cabal b/scotty.cabal index b6b2941e..17d1d273 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -130,7 +130,7 @@ test-suite doctest hs-source-dirs: doctest build-depends: base , bytestring - , doctest + , doctest >= 0.20.1 , http-client , http-types , scotty From de8d7397068690bf2cb3193023070dea0c4abae0 Mon Sep 17 00:00:00 2001 From: Marco Zocca Date: Sat, 16 Dec 2023 10:38:53 +0100 Subject: [PATCH 7/7] no-op doctest for older GHCs --- doctest/Main.hs | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/doctest/Main.hs b/doctest/Main.hs index 446bfaa4..360bc290 100644 --- a/doctest/Main.hs +++ b/doctest/Main.hs @@ -1,7 +1,15 @@ +{-# 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" @@ -9,3 +17,7 @@ main = doctest [ , "-XOverloadedStrings" , "-XLambdaCase" ] +#else +main :: IO () +main = pure () +#endif