From 95f3e6b848cc15afca16930e73d0a31075be82f0 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Thu, 12 Apr 2012 16:37:46 -0500 Subject: [PATCH 001/179] Bump version. Bump conduit version and put upper bound on it. --- scotty.cabal | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/scotty.cabal b/scotty.cabal index 7e57d5cf..091c715e 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -1,5 +1,5 @@ Name: scotty -Version: 0.3.0 +Version: 0.4.0 Synopsis: Haskell web framework inspired by Ruby's Sinatra, using WAI and Warp Homepage: https://github.com/xich/scotty Bug-reports: https://github.com/xich/scotty/issues @@ -70,14 +70,14 @@ Library blaze-builder >= 0.3, bytestring >= 0.9.1, case-insensitive >= 0.4, - conduit >= 0.1.1.1, + conduit >= 0.4.0.1 && < 0.5, data-default >= 0.3, http-types >= 0.6.8 && < 0.7, mtl >= 2.0.1, + resourcet >= 0.3.2 && < 0.4, text >= 0.11.1, wai >= 1.0.0, - warp >= 1.0.0, - resourcet >= 0.3.2 + warp >= 1.0.0 GHC-options: -Wall -fno-warn-orphans From 1f6cf6e58cccef446899dd7dd24a0bdeaca545a1 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Mon, 16 Apr 2012 17:23:36 -0500 Subject: [PATCH 002/179] Fix static file middleware to allow ..'s in argument, but not request path. --- Network/Wai/Middleware/Static.hs | 6 ++---- wai-middleware-static/wai-middleware-static.cabal | 2 +- 2 files changed, 3 insertions(+), 5 deletions(-) diff --git a/Network/Wai/Middleware/Static.hs b/Network/Wai/Middleware/Static.hs index 3b0ecfe1..d5925ea5 100644 --- a/Network/Wai/Middleware/Static.hs +++ b/Network/Wai/Middleware/Static.hs @@ -26,7 +26,7 @@ static = staticRoot "" -- > static = staticRoot "" staticRoot :: T.Text -> Middleware staticRoot base app req = - if ".." `isInfixOf` fStr + if ".." `isInfixOf` (F.encodeString fp) -- for security reasons then app req else do exists <- liftIO $ doesFileExist fStr if exists @@ -40,13 +40,11 @@ getMimeType = go . map E.encodeUtf8 . F.extensions where go [] = defaultMimeType go exts = fromMaybe (go $ tail exts) $ M.lookup (B.intercalate "." exts) defaultMimeTypes -type MimeMap = M.Map B.ByteString B.ByteString - defaultMimeType :: B.ByteString defaultMimeType = "application/octet-stream" -- This list taken from snap-core's Snap.Util.FileServe -defaultMimeTypes :: MimeMap +defaultMimeTypes :: M.Map B.ByteString B.ByteString defaultMimeTypes = M.fromList [ ( "asc" , "text/plain" ), ( "asf" , "video/x-ms-asf" ), diff --git a/wai-middleware-static/wai-middleware-static.cabal b/wai-middleware-static/wai-middleware-static.cabal index 57e4c5cd..4f03cefd 100644 --- a/wai-middleware-static/wai-middleware-static.cabal +++ b/wai-middleware-static/wai-middleware-static.cabal @@ -1,5 +1,5 @@ Name: wai-middleware-static -Version: 0.0.1 +Version: 0.1.0 Synopsis: WAI middleware that intercepts requests to static files. Homepage: https://github.com/xich/scotty Bug-reports: https://github.com/xich/scotty/issues From fd59918de950bfa5df771be7c3949233bd969524 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Mon, 16 Apr 2012 17:24:48 -0500 Subject: [PATCH 003/179] Lets get organized... charging towards a release. --- Web/Scotty.hs | 363 ++----------------------------------------- Web/Scotty/Action.hs | 215 +++++++++++++++++++++++++ Web/Scotty/Route.hs | 151 ++++++++++++++++++ Web/Scotty/Types.hs | 54 +++++++ examples/basic.hs | 6 + scotty.cabal | 5 +- 6 files changed, 446 insertions(+), 348 deletions(-) create mode 100644 Web/Scotty/Action.hs create mode 100644 Web/Scotty/Route.hs create mode 100644 Web/Scotty/Types.hs diff --git a/Web/Scotty.hs b/Web/Scotty.hs index 4a553b3f..faa6b46c 100644 --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} -- | It should be noted that most of the code snippets below depend on the -- OverloadedStrings language pragma. module Web.Scotty @@ -9,12 +9,12 @@ 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. - -- Be careful to ensure that notFound is the last route, as it will - -- match everything take precedence over later routes. - , middleware, get, post, put, delete, addroute, matchAll, notFound + , middleware, get, post, put, delete, addroute, matchAny, notFound + -- ** Route Patterns + , capture, regex, function, literal -- * Defining Actions -- ** Accessing the Request, Captures, and Query Parameters - , request, body, param, params, jsonData + , request, body, param, jsonData -- ** Modifying the Response and Redirecting , status, header, redirect -- ** Setting Response Body @@ -25,89 +25,23 @@ module Web.Scotty -- ** Exceptions , raise, rescue, next -- * Types - , ScottyM, ActionM, Parsable - , RoutePattern(..) + , ScottyM, ActionM, Param, Parsable, RoutePattern ) where -import Blaze.ByteString.Builder (fromByteString, fromLazyByteString) +import Web.Scotty.Action +import Web.Scotty.Route +import Web.Scotty.Types -import Control.Applicative -import Control.Monad.Error -import Control.Monad.Reader -import qualified Control.Monad.State as MS -import Control.Monad.Trans.Resource (ResourceT) +import Blaze.ByteString.Builder (fromByteString) -import qualified Data.Aeson as A -import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString.Lazy.Char8 as BL -import qualified Data.CaseInsensitive as CI -import Data.Default (Default, def) -import Data.Conduit.Lazy (lazyConsume) -import Data.Maybe (fromMaybe) -import Data.Monoid (mconcat) -import qualified Data.Text.Lazy as T -import Data.Text.Lazy.Encoding (encodeUtf8) +import Control.Monad.State (execStateT, modify) -import Network.HTTP.Types +import Data.Default (def) + +import Network.HTTP.Types (status404) import Network.Wai import Network.Wai.Handler.Warp (Port, run) -import Web.Scotty.Util -import Data.String - -import qualified Text.Regex as Regex -import Control.Arrow ((***)) - --- | Provides an interface for defining how different routes can be specified --- This includes three options: --- --- > Keyword - The standard approach to Sinatra style routes --- > GET "/users/sam" -> Keyword "/users/:user" -> Just [("user","sam")] --- > --- > Function - Let the user specify how their route matches --- > GET "/users/sam" -> Function (const (Just [("hello", "world")])) -> Just [("hello","world")] --- > --- > Literal - Ignore route parameters and match literally --- > GET "/users/sam" -> Literal "/users/:user" -> Nothing --- > GET "/users/:user" -> Literal "/users/:user" -> Just [] --- > --- > Regex - Match path against a regular expression. --- > GET "/users/sam" -> regexRoute "^/u(.*)m$" -> Just [("0", "/users/sam"), ("1","sers/sa")] --- -data RoutePattern = Keyword T.Text - | Literal T.Text - | Regex String - | Function (T.Text -> Maybe [Param]) - --- Provides a shorthand for creating a regex-based route pattern --- No named captures are supported at this point and instead you --- look up each match via its (Text) regex index number. --- --- > GET "/users/sam" -> regexRoute "^/u(.*)m$" -> Just [("0", "/users/sam"), ("1","sers/sa")] --- -regexRoute :: String -> RoutePattern -regexRoute pattern = Function rr - where - rr t = results - where - txt = T.unpack t - regex = Regex.mkRegex pattern - results = fmap (map (T.pack . show *** T.pack) . zip [0 :: Int ..] . strip) - (Regex.matchRegexAll regex txt) - strip (_, match, _, subs) = match : subs - -instance IsString RoutePattern where fromString x = Keyword (T.pack x) - -data ScottyState = ScottyState { middlewares :: [Middleware] - , routes :: [Middleware] - } - -instance Default ScottyState where - def = ScottyState [] [] - -newtype ScottyM a = S { runS :: MS.StateT ScottyState IO a } - deriving (Monad, MonadIO, Functor, MS.MonadState ScottyState) - -- | Run a scotty application using the warp server. scotty :: Port -> ScottyM () -> IO () scotty p s = putStrLn ("Setting phasers to stun... (ctrl-c to quit) (port " ++ show p ++ ")") >> (run p =<< scottyApp s) @@ -116,7 +50,7 @@ scotty p s = putStrLn ("Setting phasers to stun... (ctrl-c to quit) (port " ++ s -- run with any WAI handler. scottyApp :: ScottyM () -> IO Application scottyApp defs = do - s <- MS.execStateT (runS defs) def + s <- execStateT (runS defs) def return $ foldl (flip ($)) notFoundApp $ routes s ++ middlewares s notFoundApp :: Application @@ -127,269 +61,4 @@ notFoundApp _ = return $ ResponseBuilder status404 [("Content-Type","text/html") -- is the outermost middleware (it has first dibs on the request and last action -- on the response). Every middleware is run on each request. middleware :: Middleware -> ScottyM () -middleware m = MS.modify (\ (ScottyState ms rs) -> ScottyState (m:ms) rs) - -type Param = (T.Text, T.Text) - -data ActionError = Redirect T.Text - | ActionError T.Text - | Next - deriving (Eq,Show) - -instance Error ActionError where - strMsg = ActionError . T.pack - -data ActionEnv = Env { getReq :: Request, getParams :: [Param], getBody :: BL.ByteString } - -newtype ActionM a = AM { runAM :: ErrorT ActionError (ReaderT ActionEnv (MS.StateT Response IO)) a } - deriving ( Monad, MonadIO, Functor - , MonadReader ActionEnv, MS.MonadState Response, MonadError ActionError) - --- Nothing indicates route failed (due to Next) and pattern matching should continue. --- Just indicates a successful response. -runAction :: ActionEnv -> ActionM () -> IO (Maybe Response) -runAction env action = do - (e,r) <- flip MS.runStateT def - $ flip runReaderT env - $ runErrorT - $ runAM - $ action `catchError` defaultHandler - return $ either (const Nothing) (const $ Just r) e - -defaultHandler :: ActionError -> ActionM () -defaultHandler (Redirect url) = do - status status302 - header "Location" url -defaultHandler (ActionError msg) = do - status status500 - html $ mconcat ["

500 Internal Server Error

", msg] -defaultHandler Next = next - --- | Throw an exception, which can be caught with 'rescue'. Uncaught exceptions --- turn into HTTP 500 responses. -raise :: T.Text -> ActionM a -raise = throwError . ActionError - --- | Abort execution of this action and continue pattern matching routes. --- Like an exception, any code after 'next' is not executed. --- --- As an example, these two routes overlap. The only way the second one will --- ever run is if the first one calls 'next'. --- --- > get "/foo/:number" $ do --- > n <- param "number" --- > unless (all isDigit n) $ next --- > text "a number" --- > --- > get "/foo/:bar" $ do --- > bar <- param "bar" --- > text "not a number" -next :: ActionM a -next = throwError Next - --- | Catch an exception thrown by 'raise'. --- --- > raise "just kidding" `rescue` (\msg -> text msg) -rescue :: ActionM a -> (T.Text -> ActionM a) -> ActionM a -rescue action handler = catchError action $ \e -> case e of - ActionError msg -> handler msg -- handle errors - other -> throwError other -- rethrow redirects and nexts - --- | Redirect to given URL. Like throwing an uncatchable exception. Any code after the call to redirect --- will not be run. --- --- > redirect "http://www.google.com" --- --- OR --- --- > redirect "/foo/bar" -redirect :: T.Text -> ActionM a -redirect = throwError . Redirect - --- | Get the 'Request' object. -request :: ActionM Request -request = getReq <$> ask - --- | Get the request body. -body :: ActionM BL.ByteString -body = getBody <$> ask - --- | Parse the request body as a JSON object and return it. Raises an exception if parse is unsuccessful. -jsonData :: (A.FromJSON a) => ActionM a -jsonData = do - b <- body - maybe (raise "jsonData: no parse") return $ A.decode b - --- | Get a parameter. First looks in captures, then form data, then query parameters. --- --- * Raises an exception which can be caught by 'rescue' if parameter is not found. --- --- * If parameter is found, but 'read' fails to parse to the correct type, 'next' is called. --- This means captures are somewhat typed, in that a route won't match if a correctly typed --- capture cannot be parsed. -param :: (Parsable a) => T.Text -> ActionM a -param k = do - val <- lookup k <$> getParams <$> ask - case val of - Nothing -> raise $ mconcat ["Param: ", k, " not found!"] - Just v -> either (const next) return $ parseParam v - -params :: ActionM [(T.Text, T.Text)] -params = getParams <$> ask - -class Parsable a where - parseParam :: T.Text -> Either T.Text a - - -- if any individual element fails to parse, the whole list fails to parse. - parseParamList :: T.Text -> Either T.Text [a] - parseParamList t = mapM parseParam (T.split (== ',') t) - --- No point using 'read' for Text, ByteString, Char, and String. -instance Parsable T.Text where parseParam = Right -instance Parsable B.ByteString where parseParam = Right . lazyTextToStrictByteString -instance Parsable Char where - parseParam t = case T.unpack t of - [c] -> Right c - _ -> Left "parseParam Char: no parse" - parseParamList = Right . T.unpack -- String -instance Parsable () where - parseParam t = if T.null t then Right () else Left "parseParam Unit: no parse" - -instance (Parsable a) => Parsable [a] where parseParam = parseParamList - -instance Parsable Bool where parseParam = readEither -instance Parsable Double where parseParam = readEither -instance Parsable Float where parseParam = readEither -instance Parsable Int where parseParam = readEither -instance Parsable Integer where parseParam = readEither - -readEither :: (Read a) => T.Text -> Either T.Text a -readEither t = case [ x | (x,"") <- reads (T.unpack t) ] of - [x] -> Right x - [] -> Left "readEither: no parse" - _ -> Left "readEither: ambiguous parse" - --- | get = addroute 'GET' -get :: RoutePattern -> ActionM () -> ScottyM () -get = addroute GET - --- | post = addroute 'POST' -post :: RoutePattern -> ActionM () -> ScottyM () -post = addroute POST - --- | put = addroute 'PUT' -put :: RoutePattern -> ActionM () -> ScottyM () -put = addroute PUT - --- | delete = addroute 'DELETE' -delete :: RoutePattern -> ActionM () -> ScottyM () -delete = addroute DELETE - --- | Add a route for each StdMethod type -matchAll :: RoutePattern -> ActionM () -> ScottyM () -matchAll pattern action = mapM_ (\m -> m pattern action) [get, post, put, delete] - --- | Specify an action to take if nothing else is found -notFound :: ActionM () -> ScottyM () -notFound action = matchAll (Function (\x -> Just [("path", x)])) (status status404 >> action) - --- | Define a route with a 'StdMethod', 'T.Text' value representing the path spec, --- and a body ('ActionM') 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 'param'. --- --- > addroute GET "/foo/:bar" $ do --- > v <- param "bar" --- > text v --- --- >>> curl http://localhost:3000/foo/something --- something -addroute :: StdMethod -> RoutePattern -> ActionM () -> ScottyM () -addroute method path action = MS.modify (\ (ScottyState ms rs) -> ScottyState ms (r:rs)) - where r = route method path action - -route :: StdMethod -> RoutePattern -> ActionM () -> Middleware -route method path action app req = - if Right method == parseMethod (requestMethod req) - then case matchRoute path (strictByteStringToLazyText $ rawPathInfo req) of - Just captures -> do - env <- mkEnv method req captures - res <- lift $ runAction env action - maybe tryNext return res - Nothing -> tryNext - else tryNext - where tryNext = app req - -mkEnv :: StdMethod -> Request -> [Param] -> ResourceT IO ActionEnv -mkEnv method req captures = do - b <- BL.fromChunks <$> lazyConsume (requestBody req) - - let parameters = captures ++ formparams ++ queryparams - formparams = case (method, lookup "Content-Type" [(CI.mk k, CI.mk v) | (k,v) <- requestHeaders req]) of - (POST, Just "application/x-www-form-urlencoded") -> parseEncodedParams $ mconcat $ BL.toChunks b - _ -> [] - queryparams = parseEncodedParams $ rawQueryString req - - return $ Env req parameters b - -parseEncodedParams :: B.ByteString -> [Param] -parseEncodedParams bs = [ (T.fromStrict k, T.fromStrict $ fromMaybe "" v) | (k,v) <- parseQueryText bs ] - --- todo: wildcards? -matchRoute :: RoutePattern -> T.Text -> Maybe [Param] - -matchRoute (Literal pat) req | pat == req = Just [] - | otherwise = Nothing - -matchRoute (Regex pat) req = matchRoute (regexRoute pat) req - -matchRoute (Function fun) req = fun req - -matchRoute (Keyword pat) req = go (T.split (=='/') pat) (T.split (=='/') req) [] - where go [] [] prs = Just prs -- request string and pattern match! - go [] r prs | T.null (mconcat r) = Just prs -- in case request has trailing slashes - | otherwise = Nothing -- request string is longer than pattern - go p [] prs | T.null (mconcat p) = Just prs -- in case pattern has trailing slashes - | otherwise = Nothing -- request string is not long enough - go (p:ps) (r:rs) prs | p == r = go ps rs prs -- equal literals, keeping checking - | T.null p = Nothing -- p is null, but r is not, fail - | T.head p == ':' = go ps rs $ (T.tail p, r) : prs -- p is a capture, add to params - | otherwise = Nothing -- both literals, but unequal, fail - --- | Set the HTTP response status. Default is 200. -status :: Status -> ActionM () -status = MS.modify . setStatus - --- | Set one of the response headers. Will override any previously set value for that header. --- Header names are case-insensitive. -header :: T.Text -> T.Text -> ActionM () -header k v = MS.modify $ setHeader (CI.mk $ lazyTextToStrictByteString k, lazyTextToStrictByteString v) - --- | Set the body of the response to the given 'T.Text' value. Also sets \"Content-Type\" --- header to \"text/plain\". -text :: T.Text -> ActionM () -text t = do - header "Content-Type" "text/plain" - MS.modify $ setContent $ Left $ fromLazyByteString $ encodeUtf8 t - --- | Set the body of the response to the given 'T.Text' value. Also sets \"Content-Type\" --- header to \"text/html\". -html :: T.Text -> ActionM () -html t = do - header "Content-Type" "text/html" - MS.modify $ setContent $ Left $ fromLazyByteString $ encodeUtf8 t - --- | Send a file as the response. Doesn't set the \"Content-Type\" header, so you probably --- want to do that on your own with 'header'. -file :: FilePath -> ActionM () -file = MS.modify . setContent . Right - --- | Set the body of the response to the JSON encoding of the given value. Also sets \"Content-Type\" --- header to \"application/json\". -json :: (A.ToJSON a) => a -> ActionM () -json v = do - header "Content-Type" "application/json" - MS.modify $ setContent $ Left $ fromLazyByteString $ A.encode v +middleware m = modify (addMiddleware m) diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs new file mode 100644 index 00000000..255ad35e --- /dev/null +++ b/Web/Scotty/Action.hs @@ -0,0 +1,215 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | It should be noted that most of the code snippets below depend on the +-- OverloadedStrings language pragma. +module Web.Scotty.Action + ( -- * Defining Actions + -- ** Accessing the Request, Captures, and Query Parameters + request, body, param, jsonData + -- ** Modifying the Response and Redirecting + , status, header, redirect + -- ** Setting Response Body + -- + -- | 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 + -- ** Exceptions + , raise, rescue, next + -- * Types + , ActionM, Parsable, Param, mkEnv, runAction + ) where + +import Blaze.ByteString.Builder (fromLazyByteString) + +import Control.Applicative +import Control.Monad.Error +import Control.Monad.Reader +import qualified Control.Monad.State as MS +import Control.Monad.Trans.Resource (ResourceT) + +import qualified Data.Aeson as A +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as BL +import qualified Data.CaseInsensitive as CI +import Data.Default (Default, def) +import Data.Conduit.Lazy (lazyConsume) +import Data.Maybe (fromMaybe) +import Data.Monoid (mconcat) +import qualified Data.Text.Lazy as T +import Data.Text.Lazy.Encoding (encodeUtf8) + +import Network.HTTP.Types +import Network.Wai + +import Web.Scotty.Types +import Web.Scotty.Util + +-- Nothing indicates route failed (due to Next) and pattern matching should continue. +-- Just indicates a successful response. +runAction :: ActionEnv -> ActionM () -> IO (Maybe Response) +runAction env action = do + (e,r) <- flip MS.runStateT def + $ flip runReaderT env + $ runErrorT + $ runAM + $ action `catchError` defaultHandler + return $ either (const Nothing) (const $ Just r) e + +defaultHandler :: ActionError -> ActionM () +defaultHandler (Redirect url) = do + status status302 + header "Location" url +defaultHandler (ActionError msg) = do + status status500 + html $ mconcat ["

500 Internal Server Error

", msg] +defaultHandler Next = next + +mkEnv :: StdMethod -> Request -> [Param] -> ResourceT IO ActionEnv +mkEnv method req captures = do + b <- BL.fromChunks <$> lazyConsume (requestBody req) + + let parameters = captures ++ formparams ++ queryparams + formparams = case (method, lookup "Content-Type" [(CI.mk k, CI.mk v) | (k,v) <- requestHeaders req]) of + (_, Just "application/x-www-form-urlencoded") -> parseEncodedParams $ mconcat $ BL.toChunks b + _ -> [] + queryparams = parseEncodedParams $ rawQueryString req + + return $ Env req parameters b + +parseEncodedParams :: B.ByteString -> [Param] +parseEncodedParams bs = [ (T.fromStrict k, T.fromStrict $ fromMaybe "" v) | (k,v) <- parseQueryText bs ] + +-- | Throw an exception, which can be caught with 'rescue'. Uncaught exceptions +-- turn into HTTP 500 responses. +raise :: T.Text -> ActionM a +raise = throwError . ActionError + +-- | Abort execution of this action and continue pattern matching routes. +-- Like an exception, any code after 'next' is not executed. +-- +-- As an example, these two routes overlap. The only way the second one will +-- ever run is if the first one calls 'next'. +-- +-- > get "/foo/:number" $ do +-- > n <- param "number" +-- > unless (all isDigit n) $ next +-- > text "a number" +-- > +-- > get "/foo/:bar" $ do +-- > bar <- param "bar" +-- > text "not a number" +next :: ActionM a +next = throwError Next + +-- | Catch an exception thrown by 'raise'. +-- +-- > raise "just kidding" `rescue` (\msg -> text msg) +rescue :: ActionM a -> (T.Text -> ActionM a) -> ActionM a +rescue action handler = catchError action $ \e -> case e of + ActionError msg -> handler msg -- handle errors + other -> throwError other -- rethrow redirects and nexts + +-- | Redirect to given URL. Like throwing an uncatchable exception. Any code after the call to redirect +-- will not be run. +-- +-- > redirect "http://www.google.com" +-- +-- OR +-- +-- > redirect "/foo/bar" +redirect :: T.Text -> ActionM a +redirect = throwError . Redirect + +-- | Get the 'Request' object. +request :: ActionM Request +request = getReq <$> ask + +-- | Get the request body. +body :: ActionM BL.ByteString +body = getBody <$> ask + +-- | Parse the request body as a JSON object and return it. Raises an exception if parse is unsuccessful. +jsonData :: (A.FromJSON a) => ActionM a +jsonData = do + b <- body + maybe (raise "jsonData: no parse") return $ A.decode b + +-- | Get a parameter. First looks in captures, then form data, then query parameters. +-- +-- * Raises an exception which can be caught by 'rescue' if parameter is not found. +-- +-- * If parameter is found, but 'read' fails to parse to the correct type, 'next' is called. +-- This means captures are somewhat typed, in that a route won't match if a correctly typed +-- capture cannot be parsed. +param :: (Parsable a) => T.Text -> ActionM a +param k = do + val <- lookup k <$> getParams <$> ask + case val of + Nothing -> raise $ mconcat ["Param: ", k, " not found!"] + Just v -> either (const next) return $ parseParam v + +class Parsable a where + parseParam :: T.Text -> Either T.Text a + + -- if any individual element fails to parse, the whole list fails to parse. + parseParamList :: T.Text -> Either T.Text [a] + parseParamList t = mapM parseParam (T.split (== ',') t) + +-- No point using 'read' for Text, ByteString, Char, and String. +instance Parsable T.Text where parseParam = Right +instance Parsable B.ByteString where parseParam = Right . lazyTextToStrictByteString +instance Parsable Char where + parseParam t = case T.unpack t of + [c] -> Right c + _ -> Left "parseParam Char: no parse" + parseParamList = Right . T.unpack -- String +instance Parsable () where + parseParam t = if T.null t then Right () else Left "parseParam Unit: no parse" + +instance (Parsable a) => Parsable [a] where parseParam = parseParamList + +instance Parsable Bool where parseParam = readEither +instance Parsable Double where parseParam = readEither +instance Parsable Float where parseParam = readEither +instance Parsable Int where parseParam = readEither +instance Parsable Integer where parseParam = readEither + +readEither :: (Read a) => T.Text -> Either T.Text a +readEither t = case [ x | (x,"") <- reads (T.unpack t) ] of + [x] -> Right x + [] -> Left "readEither: no parse" + _ -> Left "readEither: ambiguous parse" + +-- | Set the HTTP response status. Default is 200. +status :: Status -> ActionM () +status = MS.modify . setStatus + +-- | Set one of the response headers. Will override any previously set value for that header. +-- Header names are case-insensitive. +header :: T.Text -> T.Text -> ActionM () +header k v = MS.modify $ setHeader (CI.mk $ lazyTextToStrictByteString k, lazyTextToStrictByteString v) + +-- | Set the body of the response to the given 'T.Text' value. Also sets \"Content-Type\" +-- header to \"text/plain\". +text :: T.Text -> ActionM () +text t = do + header "Content-Type" "text/plain" + MS.modify $ setContent $ Left $ fromLazyByteString $ encodeUtf8 t + +-- | Set the body of the response to the given 'T.Text' value. Also sets \"Content-Type\" +-- header to \"text/html\". +html :: T.Text -> ActionM () +html t = do + header "Content-Type" "text/html" + MS.modify $ setContent $ Left $ fromLazyByteString $ encodeUtf8 t + +-- | Send a file as the response. Doesn't set the \"Content-Type\" header, so you probably +-- want to do that on your own with 'header'. +file :: FilePath -> ActionM () +file = MS.modify . setContent . Right + +-- | Set the body of the response to the JSON encoding of the given value. Also sets \"Content-Type\" +-- header to \"application/json\". +json :: (A.ToJSON a) => a -> ActionM () +json v = do + header "Content-Type" "application/json" + MS.modify $ setContent $ Left $ fromLazyByteString $ A.encode v diff --git a/Web/Scotty/Route.hs b/Web/Scotty/Route.hs new file mode 100644 index 00000000..5ab639e3 --- /dev/null +++ b/Web/Scotty/Route.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | It should be noted that most of the code snippets below depend on the +-- OverloadedStrings language pragma. +module Web.Scotty.Route + ( get, post, put, delete, addroute, matchAny, notFound, + capture, regex, function, literal + ) where + +import Web.Scotty.Action +import Web.Scotty.Types + +import Control.Monad.Error +import qualified Control.Monad.State as MS + +import Data.Monoid (mconcat) +import qualified Data.Text.Lazy as T + +import Network.HTTP.Types +import Network.Wai + +import Web.Scotty.Util + +import qualified Text.Regex as Regex +import Control.Arrow ((***)) + +-- | get = 'addroute' 'GET' +get :: RoutePattern -> ActionM () -> ScottyM () +get = addroute GET + +-- | post = 'addroute' 'POST' +post :: RoutePattern -> ActionM () -> ScottyM () +post = addroute POST + +-- | put = 'addroute' 'PUT' +put :: RoutePattern -> ActionM () -> ScottyM () +put = addroute PUT + +-- | delete = 'addroute' 'DELETE' +delete :: RoutePattern -> ActionM () -> ScottyM () +delete = addroute DELETE + +-- | Add a route that matches regardless of the HTTP verb. +matchAny :: RoutePattern -> ActionM () -> ScottyM () +matchAny pattern action = mapM_ (\v -> addroute v pattern action) [minBound..maxBound] + +-- | Specify an action to take if nothing else is found +notFound :: ActionM () -> ScottyM () +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 ('ActionM') 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 'param'. +-- +-- > addroute GET "/foo/:bar" $ do +-- > v <- param "bar" +-- > text v +-- +-- >>> curl http://localhost:3000/foo/something +-- something +addroute :: StdMethod -> RoutePattern -> ActionM () -> ScottyM () +addroute method pat action = MS.modify (addRoute r) + where r = route method pat action + +route :: StdMethod -> RoutePattern -> ActionM () -> Middleware +route method pat action app req = + if Right method == parseMethod (requestMethod req) + then case matchRoute pat req of + Just captures -> do + env <- mkEnv method req captures + res <- lift $ runAction env action + maybe tryNext return res + Nothing -> tryNext + else tryNext + where tryNext = app req + +matchRoute :: RoutePattern -> Request -> Maybe [Param] + +matchRoute (Literal pat) req | pat == path req = Just [] + | otherwise = Nothing + +matchRoute (Function fun) req = fun req + +matchRoute (Capture pat) req = go (T.split (=='/') pat) (T.split (=='/') $ path req) [] + where go [] [] prs = Just prs -- request string and pattern match! + go [] r prs | T.null (mconcat r) = Just prs -- in case request has trailing slashes + | otherwise = Nothing -- request string is longer than pattern + go p [] prs | T.null (mconcat p) = Just prs -- in case pattern has trailing slashes + | otherwise = Nothing -- request string is not long enough + go (p:ps) (r:rs) prs | p == r = go ps rs prs -- equal literals, keeping checking + | T.null p = Nothing -- p is null, but r is not, fail + | T.head p == ':' = go ps rs $ (T.tail p, r) : prs -- p is a capture, add to params + | otherwise = Nothing -- both literals, but unequal, fail + +path :: Request -> T.Text +path = strictByteStringToLazyText . rawPathInfo + +-- | 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 +-- +regex :: String -> RoutePattern +regex pattern = 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 + strip (_, match, _, subs) = match : subs + +-- | Standard Sinatra-style route. Named captures are prepended with colons. +-- This is the default route type generated by OverloadedString routes. i.e. +-- +-- > get (capture "/foo/:bar") $ ... +-- +-- and +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > ... +-- > get "/foo/:bar" $ ... +-- +-- are equivalent. +capture :: String -> RoutePattern +capture = Capture . T.pack + +-- | 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 +-- +function :: (Request -> Maybe [Param]) -> RoutePattern +function = Function + +-- | Build a route that requires the requested path match exactly, without captures. +literal :: String -> RoutePattern +literal = Literal . T.pack diff --git a/Web/Scotty/Types.hs b/Web/Scotty/Types.hs new file mode 100644 index 00000000..f887fcbb --- /dev/null +++ b/Web/Scotty/Types.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +-- | It should be noted that most of the code snippets below depend on the +-- OverloadedStrings language pragma. +module Web.Scotty.Types where + +import Control.Monad.Error +import Control.Monad.Reader +import Control.Monad.State + +import Data.ByteString.Lazy.Char8 (ByteString) +import Data.Default (Default, def) +import Data.Text.Lazy (Text, pack) + +import Network.Wai + +import Data.String (IsString(..)) + +data RoutePattern = Capture Text + | Literal Text + | Function (Request -> Maybe [Param]) + +instance IsString RoutePattern where fromString = Capture . pack + +data ScottyState = ScottyState { middlewares :: [Middleware] + , routes :: [Middleware] + } + +addMiddleware :: Middleware -> ScottyState -> ScottyState +addMiddleware m (ScottyState ms rs) = ScottyState (m:ms) rs + +addRoute :: Middleware -> ScottyState -> ScottyState +addRoute r (ScottyState ms rs) = ScottyState ms (r:rs) + +instance Default ScottyState where + def = ScottyState [] [] + +newtype ScottyM a = S { runS :: StateT ScottyState IO a } + deriving (Monad, MonadIO, Functor, MonadState ScottyState) + +type Param = (Text, Text) + +data ActionError = Redirect Text + | ActionError Text + | Next + deriving (Eq,Show) + +instance Error ActionError where + strMsg = ActionError . pack + +data ActionEnv = Env { getReq :: Request, getParams :: [Param], getBody :: ByteString } + +newtype ActionM a = AM { runAM :: ErrorT ActionError (ReaderT ActionEnv (StateT Response IO)) a } + deriving ( Monad, MonadIO, Functor + , MonadReader ActionEnv, MonadState Response, MonadError ActionError) diff --git a/examples/basic.hs b/examples/basic.hs index 63d989de..b4823c7c 100644 --- a/examples/basic.hs +++ b/examples/basic.hs @@ -8,6 +8,8 @@ import Data.Monoid import System.Random (newStdGen, randomRs) import Network.HTTP.Types (status302) +import Network.Wai +import qualified Data.Text.Lazy as T import Data.Text.Lazy.Encoding (decodeUtf8) @@ -16,6 +18,10 @@ main = scotty 3000 $ do -- Add any WAI middleware, they are run top-down. middleware logStdoutDev +-- get (function $ \req -> Just [("version", T.pack $ show $ httpVersion req)]) $ do +-- v <- param "version" +-- text v + -- To demonstrate that routes are matched top-down. get "/" $ text "foobar" get "/" $ text "barfoo" diff --git a/scotty.cabal b/scotty.cabal index 8272158c..346d9fef 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -63,7 +63,10 @@ Extra-source-files: Library Exposed-modules: Web.Scotty - other-modules: Web.Scotty.Util + other-modules: Web.Scotty.Action + Web.Scotty.Route + Web.Scotty.Types + Web.Scotty.Util default-language: Haskell2010 build-depends: aeson >= 0.5, base >= 4.3.1 && < 5, From 42413cc40651e1416b87a91f5c8216fed7f353f4 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Mon, 16 Apr 2012 17:46:01 -0500 Subject: [PATCH 004/179] More cleanup. --- Web/Scotty/Action.hs | 13 +------------ Web/Scotty/Route.hs | 2 -- Web/Scotty/Types.hs | 14 ++++++-------- 3 files changed, 7 insertions(+), 22 deletions(-) diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs index 255ad35e..18fa5e13 100644 --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -1,20 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} --- | It should be noted that most of the code snippets below depend on the --- OverloadedStrings language pragma. module Web.Scotty.Action - ( -- * Defining Actions - -- ** Accessing the Request, Captures, and Query Parameters - request, body, param, jsonData - -- ** Modifying the Response and Redirecting + ( request, body, param, jsonData , status, header, redirect - -- ** Setting Response Body - -- - -- | 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 - -- ** Exceptions , raise, rescue, next - -- * Types , ActionM, Parsable, Param, mkEnv, runAction ) where diff --git a/Web/Scotty/Route.hs b/Web/Scotty/Route.hs index 5ab639e3..aa5494be 100644 --- a/Web/Scotty/Route.hs +++ b/Web/Scotty/Route.hs @@ -1,6 +1,4 @@ {-# LANGUAGE OverloadedStrings #-} --- | It should be noted that most of the code snippets below depend on the --- OverloadedStrings language pragma. module Web.Scotty.Route ( get, post, put, delete, addroute, matchAny, notFound, capture, regex, function, literal diff --git a/Web/Scotty/Types.hs b/Web/Scotty/Types.hs index f887fcbb..f6454818 100644 --- a/Web/Scotty/Types.hs +++ b/Web/Scotty/Types.hs @@ -1,6 +1,4 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} --- | It should be noted that most of the code snippets below depend on the --- OverloadedStrings language pragma. module Web.Scotty.Types where import Control.Monad.Error @@ -15,12 +13,6 @@ import Network.Wai import Data.String (IsString(..)) -data RoutePattern = Capture Text - | Literal Text - | Function (Request -> Maybe [Param]) - -instance IsString RoutePattern where fromString = Capture . pack - data ScottyState = ScottyState { middlewares :: [Middleware] , routes :: [Middleware] } @@ -52,3 +44,9 @@ data ActionEnv = Env { getReq :: Request, getParams :: [Param], getBody :: ByteS newtype ActionM a = AM { runAM :: ErrorT ActionError (ReaderT ActionEnv (StateT Response IO)) a } deriving ( Monad, MonadIO, Functor , MonadReader ActionEnv, MonadState Response, MonadError ActionError) + +data RoutePattern = Capture Text + | Literal Text + | Function (Request -> Maybe [Param]) + +instance IsString RoutePattern where fromString = Capture . pack From a21f5536be1422772b9b993f3b229d4f5ec948a3 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Mon, 16 Apr 2012 17:53:03 -0500 Subject: [PATCH 005/179] Comment Wibble. 0.4 Release. --- Web/Scotty/Route.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/Web/Scotty/Route.hs b/Web/Scotty/Route.hs index aa5494be..228bf220 100644 --- a/Web/Scotty/Route.hs +++ b/Web/Scotty/Route.hs @@ -41,7 +41,8 @@ delete = addroute DELETE matchAny :: RoutePattern -> ActionM () -> ScottyM () matchAny pattern action = mapM_ (\v -> addroute v pattern action) [minBound..maxBound] --- | Specify an action to take if nothing else is found +-- | Specify an action to take if nothing else is found. Note: this _always_ matches, +-- so should generally be the last route specified. notFound :: ActionM () -> ScottyM () notFound action = matchAny (Function (\req -> Just [("path", path req)])) (status status404 >> action) From 1918cea5d0f6997d6cd2e9e2787ad091530975a7 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Fri, 20 Apr 2012 11:48:27 -0500 Subject: [PATCH 006/179] Use pathInfo instead of rawPathInfo, to support being a subsite. --- Web/Scotty/Route.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/Web/Scotty/Route.hs b/Web/Scotty/Route.hs index 228bf220..3c0928a7 100644 --- a/Web/Scotty/Route.hs +++ b/Web/Scotty/Route.hs @@ -12,12 +12,11 @@ import qualified Control.Monad.State as MS import Data.Monoid (mconcat) import qualified Data.Text.Lazy as T +import qualified Data.Text as TS import Network.HTTP.Types import Network.Wai -import Web.Scotty.Util - import qualified Text.Regex as Regex import Control.Arrow ((***)) @@ -94,8 +93,9 @@ matchRoute (Capture pat) req = go (T.split (=='/') pat) (T.split (=='/') $ path | T.head p == ':' = go ps rs $ (T.tail p, r) : prs -- p is a capture, add to params | otherwise = Nothing -- both literals, but unequal, fail +-- Pretend we are at the top level. path :: Request -> T.Text -path = strictByteStringToLazyText . rawPathInfo +path = T.fromStrict . TS.cons '/' . TS.intercalate "/" . pathInfo -- | Match requests using a regular expression. -- Named captures are not yet supported. From 3e7d64a73b748e8b4882b470706882b0390838df Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Fri, 20 Apr 2012 12:05:00 -0500 Subject: [PATCH 007/179] Reorder imports. --- Web/Scotty.hs | 8 ++++---- Web/Scotty/Route.hs | 8 ++++---- Web/Scotty/Types.hs | 3 +-- 3 files changed, 9 insertions(+), 10 deletions(-) diff --git a/Web/Scotty.hs b/Web/Scotty.hs index faa6b46c..0f734dc3 100644 --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -28,10 +28,6 @@ module Web.Scotty , ScottyM, ActionM, Param, Parsable, RoutePattern ) where -import Web.Scotty.Action -import Web.Scotty.Route -import Web.Scotty.Types - import Blaze.ByteString.Builder (fromByteString) import Control.Monad.State (execStateT, modify) @@ -42,6 +38,10 @@ import Network.HTTP.Types (status404) import Network.Wai import Network.Wai.Handler.Warp (Port, run) +import Web.Scotty.Action +import Web.Scotty.Route +import Web.Scotty.Types + -- | Run a scotty application using the warp server. scotty :: Port -> ScottyM () -> IO () scotty p s = putStrLn ("Setting phasers to stun... (ctrl-c to quit) (port " ++ show p ++ ")") >> (run p =<< scottyApp s) diff --git a/Web/Scotty/Route.hs b/Web/Scotty/Route.hs index 3c0928a7..19edbbb4 100644 --- a/Web/Scotty/Route.hs +++ b/Web/Scotty/Route.hs @@ -4,9 +4,7 @@ module Web.Scotty.Route capture, regex, function, literal ) where -import Web.Scotty.Action -import Web.Scotty.Types - +import Control.Arrow ((***)) import Control.Monad.Error import qualified Control.Monad.State as MS @@ -18,7 +16,9 @@ import Network.HTTP.Types import Network.Wai import qualified Text.Regex as Regex -import Control.Arrow ((***)) + +import Web.Scotty.Action +import Web.Scotty.Types -- | get = 'addroute' 'GET' get :: RoutePattern -> ActionM () -> ScottyM () diff --git a/Web/Scotty/Types.hs b/Web/Scotty/Types.hs index f6454818..539f5341 100644 --- a/Web/Scotty/Types.hs +++ b/Web/Scotty/Types.hs @@ -7,12 +7,11 @@ import Control.Monad.State import Data.ByteString.Lazy.Char8 (ByteString) import Data.Default (Default, def) +import Data.String (IsString(..)) import Data.Text.Lazy (Text, pack) import Network.Wai -import Data.String (IsString(..)) - data ScottyState = ScottyState { middlewares :: [Middleware] , routes :: [Middleware] } From 799a1b697ac97d10f2bff20c7411a5c9a69207ea Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Fri, 4 May 2012 13:24:37 -0500 Subject: [PATCH 008/179] Move mkEnv --- Web/Scotty/Action.hs | 20 +------------------- Web/Scotty/Route.hs | 25 +++++++++++++++++++++++-- 2 files changed, 24 insertions(+), 21 deletions(-) diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs index 18fa5e13..154f476f 100644 --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -4,7 +4,7 @@ module Web.Scotty.Action , status, header, redirect , text, html, file, json , raise, rescue, next - , ActionM, Parsable, Param, mkEnv, runAction + , ActionM, Parsable, Param, runAction ) where import Blaze.ByteString.Builder (fromLazyByteString) @@ -13,15 +13,12 @@ import Control.Applicative import Control.Monad.Error import Control.Monad.Reader import qualified Control.Monad.State as MS -import Control.Monad.Trans.Resource (ResourceT) import qualified Data.Aeson as A import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.CaseInsensitive as CI import Data.Default (Default, def) -import Data.Conduit.Lazy (lazyConsume) -import Data.Maybe (fromMaybe) import Data.Monoid (mconcat) import qualified Data.Text.Lazy as T import Data.Text.Lazy.Encoding (encodeUtf8) @@ -52,21 +49,6 @@ defaultHandler (ActionError msg) = do html $ mconcat ["

500 Internal Server Error

", msg] defaultHandler Next = next -mkEnv :: StdMethod -> Request -> [Param] -> ResourceT IO ActionEnv -mkEnv method req captures = do - b <- BL.fromChunks <$> lazyConsume (requestBody req) - - let parameters = captures ++ formparams ++ queryparams - formparams = case (method, lookup "Content-Type" [(CI.mk k, CI.mk v) | (k,v) <- requestHeaders req]) of - (_, Just "application/x-www-form-urlencoded") -> parseEncodedParams $ mconcat $ BL.toChunks b - _ -> [] - queryparams = parseEncodedParams $ rawQueryString req - - return $ Env req parameters b - -parseEncodedParams :: B.ByteString -> [Param] -parseEncodedParams bs = [ (T.fromStrict k, T.fromStrict $ fromMaybe "" v) | (k,v) <- parseQueryText bs ] - -- | Throw an exception, which can be caught with 'rescue'. Uncaught exceptions -- turn into HTTP 500 responses. raise :: T.Text -> ActionM a diff --git a/Web/Scotty/Route.hs b/Web/Scotty/Route.hs index 19edbbb4..44020538 100644 --- a/Web/Scotty/Route.hs +++ b/Web/Scotty/Route.hs @@ -5,9 +5,16 @@ module Web.Scotty.Route ) where import Control.Arrow ((***)) +import Control.Applicative import Control.Monad.Error import qualified Control.Monad.State as MS +import Control.Monad.Trans.Resource (ResourceT) +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as BL +import qualified Data.CaseInsensitive as CI +import Data.Conduit.Lazy (lazyConsume) +import Data.Maybe (fromMaybe) import Data.Monoid (mconcat) import qualified Data.Text.Lazy as T import qualified Data.Text as TS @@ -60,8 +67,7 @@ notFound action = matchAny (Function (\req -> Just [("path", path req)])) (statu -- >>> curl http://localhost:3000/foo/something -- something addroute :: StdMethod -> RoutePattern -> ActionM () -> ScottyM () -addroute method pat action = MS.modify (addRoute r) - where r = route method pat action +addroute method pat action = MS.modify $ addRoute $ route method pat action route :: StdMethod -> RoutePattern -> ActionM () -> Middleware route method pat action app req = @@ -97,6 +103,21 @@ matchRoute (Capture pat) req = go (T.split (=='/') pat) (T.split (=='/') $ path path :: Request -> T.Text path = T.fromStrict . TS.cons '/' . TS.intercalate "/" . pathInfo +mkEnv :: StdMethod -> Request -> [Param] -> ResourceT IO ActionEnv +mkEnv method req captures = do + b <- BL.fromChunks <$> lazyConsume (requestBody req) + + let parameters = captures ++ formparams ++ queryparams + formparams = case (method, lookup "Content-Type" [(CI.mk k, CI.mk v) | (k,v) <- requestHeaders req]) of + (_, Just "application/x-www-form-urlencoded") -> parseEncodedParams $ mconcat $ BL.toChunks b + _ -> [] + queryparams = parseEncodedParams $ rawQueryString req + + return $ Env req parameters b + +parseEncodedParams :: B.ByteString -> [Param] +parseEncodedParams bs = [ (T.fromStrict k, T.fromStrict $ fromMaybe "" v) | (k,v) <- parseQueryText bs ] + -- | Match requests using a regular expression. -- Named captures are not yet supported. -- From 0be8f6780a473e8c0d08b5ddfd4e4bf0d8df8a77 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Mon, 7 May 2012 10:45:30 -0500 Subject: [PATCH 009/179] Add ability to get params as function arguments to the action. --- Web/Scotty.hs | 7 +++++-- Web/Scotty/Route.hs | 49 +++++++++++++++++++++++++++++++++++---------- examples/basic.hs | 3 +++ scotty.cabal | 2 +- 4 files changed, 47 insertions(+), 14 deletions(-) diff --git a/Web/Scotty.hs b/Web/Scotty.hs index 0f734dc3..ac72575c 100644 --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -13,6 +13,7 @@ module Web.Scotty -- ** Route Patterns , capture, regex, function, literal -- * Defining Actions + , Action -- ** Accessing the Request, Captures, and Query Parameters , request, body, param, jsonData -- ** Modifying the Response and Redirecting @@ -44,7 +45,9 @@ import Web.Scotty.Types -- | Run a scotty application using the warp server. scotty :: Port -> ScottyM () -> IO () -scotty p s = putStrLn ("Setting phasers to stun... (ctrl-c to quit) (port " ++ show p ++ ")") >> (run p =<< scottyApp s) +scotty p s = do + putStrLn $ "Setting phasers to stun... (ctrl-c to quit) (port " ++ show p ++ ")" + run p =<< scottyApp s -- | Turn a scotty application into a WAI 'Application', which can be -- run with any WAI handler. @@ -61,4 +64,4 @@ notFoundApp _ = return $ ResponseBuilder status404 [("Content-Type","text/html") -- is the outermost middleware (it has first dibs on the request and last action -- on the response). Every middleware is run on each request. middleware :: Middleware -> ScottyM () -middleware m = modify (addMiddleware m) +middleware = modify . addMiddleware diff --git a/Web/Scotty/Route.hs b/Web/Scotty/Route.hs index 44020538..1d459f68 100644 --- a/Web/Scotty/Route.hs +++ b/Web/Scotty/Route.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, FlexibleInstances, ScopedTypeVariables #-} module Web.Scotty.Route ( get, post, put, delete, addroute, matchAny, notFound, - capture, regex, function, literal + capture, regex, function, literal, Action ) where import Control.Arrow ((***)) @@ -15,7 +15,7 @@ import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.CaseInsensitive as CI import Data.Conduit.Lazy (lazyConsume) import Data.Maybe (fromMaybe) -import Data.Monoid (mconcat) +import Data.Monoid (mconcat, (<>)) import qualified Data.Text.Lazy as T import qualified Data.Text as TS @@ -28,23 +28,23 @@ import Web.Scotty.Action import Web.Scotty.Types -- | get = 'addroute' 'GET' -get :: RoutePattern -> ActionM () -> ScottyM () +get :: (Action action) => RoutePattern -> action -> ScottyM () get = addroute GET -- | post = 'addroute' 'POST' -post :: RoutePattern -> ActionM () -> ScottyM () +post :: (Action action) => RoutePattern -> action -> ScottyM () post = addroute POST -- | put = 'addroute' 'PUT' -put :: RoutePattern -> ActionM () -> ScottyM () +put :: (Action action) => RoutePattern -> action -> ScottyM () put = addroute PUT -- | delete = 'addroute' 'DELETE' -delete :: RoutePattern -> ActionM () -> ScottyM () +delete :: (Action action) => RoutePattern -> action -> ScottyM () delete = addroute DELETE -- | Add a route that matches regardless of the HTTP verb. -matchAny :: RoutePattern -> ActionM () -> ScottyM () +matchAny :: (Action action) => RoutePattern -> action -> ScottyM () matchAny pattern action = mapM_ (\v -> addroute v pattern action) [minBound..maxBound] -- | Specify an action to take if nothing else is found. Note: this _always_ matches, @@ -53,7 +53,7 @@ notFound :: ActionM () -> ScottyM () 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 ('ActionM') which modifies the response. +-- and a body ('Action') which modifies the response. -- -- > addroute GET "/" $ text "beam me up!" -- @@ -66,8 +66,35 @@ notFound action = matchAny (Function (\req -> Just [("path", path req)])) (statu -- -- >>> curl http://localhost:3000/foo/something -- something -addroute :: StdMethod -> RoutePattern -> ActionM () -> ScottyM () -addroute method pat action = MS.modify $ addRoute $ route method pat action +addroute :: (Action action) => StdMethod -> RoutePattern -> action -> ScottyM () +addroute method pat action = MS.modify $ addRoute $ route method pat $ build action pat + +-- | An action (executed when a route matches) can either be an 'ActionM' computation, or +-- a function with an argument for each capture in the route. For example: +-- +-- > get "/lambda/:foo/:bar" $ \ a b -> do +-- > text $ mconcat [a,b] +-- +-- is elaborated by Scotty to: +-- +-- > get "/lambda/:foo/:bar" $ do +-- > a <- param "foo" +-- > b <- param "bar" +-- > text $ mconcat [a,b] +class Action a where + build :: a -> RoutePattern -> ActionM () + +instance Action (ActionM a) where + build action _ = action >> return () + +instance (Parsable a, Action b) => Action (a -> b) where + build f pat = findCapture pat >>= \ (v, pat') -> build (f v) pat' + where findCapture :: RoutePattern -> ActionM (a, RoutePattern) + findCapture (Literal l) = raise $ "Lambda trying to capture a literal route: " <> l + findCapture (Capture p) = case T.span (/='/') (T.dropWhile (/=':') p) of + (m,r) | T.null m -> raise "More function arguments than captures." + | otherwise -> param (T.tail m) >>= \ v -> return (v, Capture r) + findCapture (Function _) = raise "Lambda trying to capture a function route." route :: StdMethod -> RoutePattern -> ActionM () -> Middleware route method pat action app req = diff --git a/examples/basic.hs b/examples/basic.hs index b4823c7c..a28f8c4a 100644 --- a/examples/basic.hs +++ b/examples/basic.hs @@ -85,6 +85,9 @@ main = scotty 3000 $ do b <- body text $ decodeUtf8 b + get "/lambda/:foo/:bar" $ \ foo bar baz -> do + text $ mconcat [foo, bar, baz] + {- If you don't want to use Warp as your webserver, you can use any WAI handler. diff --git a/scotty.cabal b/scotty.cabal index 346d9fef..18842eee 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -1,5 +1,5 @@ Name: scotty -Version: 0.4.0 +Version: 0.4.1 Synopsis: Haskell web framework inspired by Ruby's Sinatra, using WAI and Warp Homepage: https://github.com/xich/scotty Bug-reports: https://github.com/xich/scotty/issues From a10e987b5e71ea5416364c24995f6cc6351757d5 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Tue, 8 May 2012 13:01:41 -0500 Subject: [PATCH 010/179] Fix mappend synonym issue. --- Web/Scotty/Route.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Web/Scotty/Route.hs b/Web/Scotty/Route.hs index 1d459f68..92ec3cf9 100644 --- a/Web/Scotty/Route.hs +++ b/Web/Scotty/Route.hs @@ -15,7 +15,7 @@ import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.CaseInsensitive as CI import Data.Conduit.Lazy (lazyConsume) import Data.Maybe (fromMaybe) -import Data.Monoid (mconcat, (<>)) +import Data.Monoid (mconcat) import qualified Data.Text.Lazy as T import qualified Data.Text as TS @@ -90,7 +90,7 @@ instance Action (ActionM a) where instance (Parsable a, Action b) => Action (a -> b) where build f pat = findCapture pat >>= \ (v, pat') -> build (f v) pat' where findCapture :: RoutePattern -> ActionM (a, RoutePattern) - findCapture (Literal l) = raise $ "Lambda trying to capture a literal route: " <> l + findCapture (Literal l) = raise $ mconcat ["Lambda trying to capture a literal route: ", l] findCapture (Capture p) = case T.span (/='/') (T.dropWhile (/=':') p) of (m,r) | T.null m -> raise "More function arguments than captures." | otherwise -> param (T.tail m) >>= \ v -> return (v, Capture r) From 5983e1a874d0c76a9116d4aca12c0251655d9544 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Tue, 8 May 2012 13:09:31 -0500 Subject: [PATCH 011/179] Version bump. --- scotty.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scotty.cabal b/scotty.cabal index 18842eee..4da8e721 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -1,5 +1,5 @@ Name: scotty -Version: 0.4.1 +Version: 0.4.2 Synopsis: Haskell web framework inspired by Ruby's Sinatra, using WAI and Warp Homepage: https://github.com/xich/scotty Bug-reports: https://github.com/xich/scotty/issues From 91870274f96bbdb0d3549783eca431f3a1ade195 Mon Sep 17 00:00:00 2001 From: Shae Erisson Date: Tue, 22 May 2012 13:02:09 -0500 Subject: [PATCH 012/179] basic.hs needs wai-extra for Network.Wai.Middleware.RequestLogger but scotty.cabal does not depend on wai-extra, add documentation --- README | 2 +- examples/basic.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/README b/README index 14aa9398..9d7b6cbc 100644 --- a/README +++ b/README @@ -20,7 +20,7 @@ Scotty is the cheap and cheerful way to write RESTful, declarative web applicati * Conforms to WAI Application interface. * Uses very fast Warp webserver by default. -See examples/basic.hs to see Scotty in action. +See examples/basic.hs to see Scotty in action. (basic.hs needs the wai-extra package) > runghc examples/basic.hs Setting phasers to stun... (ctrl-c to quit) diff --git a/examples/basic.hs b/examples/basic.hs index a28f8c4a..870b97dc 100644 --- a/examples/basic.hs +++ b/examples/basic.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} import Web.Scotty -import Network.Wai.Middleware.RequestLogger +import Network.Wai.Middleware.RequestLogger -- install wai-extra if you don't have this import Control.Monad.Trans import Data.Monoid From 9549344323d54033c71707774306d76ff86a83ac Mon Sep 17 00:00:00 2001 From: Shae Erisson Date: Tue, 22 May 2012 18:19:10 -0500 Subject: [PATCH 013/179] added missing argument to get "/lambda" --- examples/basic.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/examples/basic.hs b/examples/basic.hs index 870b97dc..fdf92910 100644 --- a/examples/basic.hs +++ b/examples/basic.hs @@ -85,7 +85,7 @@ main = scotty 3000 $ do b <- body text $ decodeUtf8 b - get "/lambda/:foo/:bar" $ \ foo bar baz -> do + get "/lambda/:foo/:bar/:baz" $ \ foo bar baz -> do text $ mconcat [foo, bar, baz] {- If you don't want to use Warp as your webserver, From f2e92449732544bd7e5417315b880c6df1f64a6e Mon Sep 17 00:00:00 2001 From: Bardur Arantsson Date: Fri, 25 May 2012 06:15:02 +0200 Subject: [PATCH 014/179] Add "source" function to construct response directly from a Source --- Web/Scotty.hs | 2 +- Web/Scotty/Action.hs | 19 +++++++++++++------ Web/Scotty/Util.hs | 23 ++++++++++++++++------- 3 files changed, 30 insertions(+), 14 deletions(-) diff --git a/Web/Scotty.hs b/Web/Scotty.hs index ac72575c..796f29eb 100644 --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -22,7 +22,7 @@ module Web.Scotty -- -- | 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 + , text, html, file, json, source -- ** Exceptions , raise, rescue, next -- * Types diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs index 154f476f..6ec6183a 100644 --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -2,12 +2,12 @@ module Web.Scotty.Action ( request, body, param, jsonData , status, header, redirect - , text, html, file, json + , text, html, file, json, source , raise, rescue, next , ActionM, Parsable, Param, runAction ) where -import Blaze.ByteString.Builder (fromLazyByteString) +import Blaze.ByteString.Builder (Builder, fromLazyByteString) import Control.Applicative import Control.Monad.Error @@ -18,6 +18,7 @@ import qualified Data.Aeson as A import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.CaseInsensitive as CI +import Data.Conduit (Flush, ResourceT, Source) import Data.Default (Default, def) import Data.Monoid (mconcat) import qualified Data.Text.Lazy as T @@ -164,23 +165,29 @@ header k v = MS.modify $ setHeader (CI.mk $ lazyTextToStrictByteString k, lazyTe text :: T.Text -> ActionM () text t = do header "Content-Type" "text/plain" - MS.modify $ setContent $ Left $ fromLazyByteString $ encodeUtf8 t + MS.modify $ setContent $ ContentBuilder $ fromLazyByteString $ encodeUtf8 t -- | Set the body of the response to the given 'T.Text' value. Also sets \"Content-Type\" -- header to \"text/html\". html :: T.Text -> ActionM () html t = do header "Content-Type" "text/html" - MS.modify $ setContent $ Left $ fromLazyByteString $ encodeUtf8 t + MS.modify $ setContent $ ContentBuilder $ fromLazyByteString $ encodeUtf8 t -- | Send a file as the response. Doesn't set the \"Content-Type\" header, so you probably -- want to do that on your own with 'header'. file :: FilePath -> ActionM () -file = MS.modify . setContent . Right +file = MS.modify . setContent . ContentFile -- | Set the body of the response to the JSON encoding of the given value. Also sets \"Content-Type\" -- header to \"application/json\". json :: (A.ToJSON a) => a -> ActionM () json v = do header "Content-Type" "application/json" - MS.modify $ setContent $ Left $ fromLazyByteString $ A.encode v + MS.modify $ setContent $ ContentBuilder $ fromLazyByteString $ A.encode v + +-- | Set the body of the response to a Source. Doesn't set the +-- \"Content-Type\" header, so you probably want to do that on your +-- own with 'header'. +source :: Source (ResourceT IO) (Flush Builder) -> ActionM () +source = MS.modify . setContent . ContentSource diff --git a/Web/Scotty/Util.hs b/Web/Scotty/Util.hs index ef10acc4..37711bc6 100644 --- a/Web/Scotty/Util.hs +++ b/Web/Scotty/Util.hs @@ -2,6 +2,7 @@ module Web.Scotty.Util ( lazyTextToStrictByteString , strictByteStringToLazyText , setContent, setHeader, setStatus + , Content(..) ) where import Network.Wai @@ -10,6 +11,7 @@ import Network.HTTP.Types import Blaze.ByteString.Builder (Builder) import Data.CaseInsensitive (CI) +import Data.Conduit (Flush, Source, ResourceT) import Data.Default import Data.Monoid @@ -26,13 +28,20 @@ lazyTextToStrictByteString = ES.encodeUtf8 . T.toStrict strictByteStringToLazyText :: B.ByteString -> T.Text strictByteStringToLazyText = T.fromStrict . ES.decodeUtf8 -setContent :: Either Builder FilePath -> Response -> Response -setContent (Left b) (ResponseBuilder s h _) = ResponseBuilder s h b -setContent (Left b) (ResponseFile s h _ _) = ResponseBuilder s h b -setContent (Left b) (ResponseSource s h _) = ResponseBuilder s h b -setContent (Right f) (ResponseBuilder s h _) = ResponseFile s h f Nothing -setContent (Right f) (ResponseFile s h _ _) = ResponseFile s h f Nothing -setContent (Right f) (ResponseSource s h _) = ResponseFile s h f Nothing +data Content = ContentBuilder Builder + | ContentFile FilePath + | ContentSource (Source (ResourceT IO) (Flush Builder)) + +setContent :: Content -> Response -> Response +setContent (ContentBuilder b) (ResponseBuilder s h _) = ResponseBuilder s h b +setContent (ContentBuilder b) (ResponseFile s h _ _) = ResponseBuilder s h b +setContent (ContentBuilder b) (ResponseSource s h _) = ResponseBuilder s h b +setContent (ContentFile f) (ResponseBuilder s h _) = ResponseFile s h f Nothing +setContent (ContentFile f) (ResponseFile s h _ _) = ResponseFile s h f Nothing +setContent (ContentFile f) (ResponseSource s h _) = ResponseFile s h f Nothing +setContent (ContentSource src) (ResponseBuilder s h _) = ResponseSource s h src +setContent (ContentSource src) (ResponseFile s h _ _) = ResponseSource s h src +setContent (ContentSource src) (ResponseSource s h _) = ResponseSource s h src setHeader :: (CI Ascii, Ascii) -> Response -> Response setHeader (k,v) (ResponseBuilder s h b) = ResponseBuilder s (update h k v) b From da36d25fa9b8b5e858f57a2a3345334473ef958b Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Wed, 6 Jun 2012 12:22:42 -0500 Subject: [PATCH 015/179] Add Options, use it to contain Warp Settings, and other flags. --- Web/Scotty.hs | 18 ++++++++++-------- Web/Scotty/Types.hs | 12 ++++++++++-- 2 files changed, 20 insertions(+), 10 deletions(-) diff --git a/Web/Scotty.hs b/Web/Scotty.hs index 73560293..f588eb7d 100644 --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -3,7 +3,7 @@ -- OverloadedStrings language pragma. module Web.Scotty ( -- * scotty-to-WAI - scotty, scottySettings, scottyApp + scotty, scottyApp, scottyOpts, Options(..) -- * Defining Middleware and Routes -- -- | 'Middleware' and routes are run in the order in which they @@ -31,13 +31,14 @@ module Web.Scotty import Blaze.ByteString.Builder (fromByteString) +import Control.Monad (when) import Control.Monad.State (execStateT, modify) import Data.Default (def) import Network.HTTP.Types (status404) import Network.Wai -import Network.Wai.Handler.Warp (Port, Settings, run, runSettings) +import Network.Wai.Handler.Warp (Port, runSettings, settingsPort) import Web.Scotty.Action import Web.Scotty.Route @@ -45,13 +46,14 @@ import Web.Scotty.Types -- | Run a scotty application using the warp server. scotty :: Port -> ScottyM () -> IO () -scotty p s = do - putStrLn $ "Setting phasers to stun... (ctrl-c to quit) (port " ++ show p ++ ")" - run p =<< scottyApp s +scotty p = scottyOpts $ def { settings = (settings def) { settingsPort = p } } --- | Run a scotty application using different WAI settings. -scottySettings :: Settings -> ScottyM() -> IO () -scottySettings settings s = putStrLn "Setting phasers to kill... (ctrl-c to quit)" >> (runSettings settings =<< scottyApp s) +-- | Run a scotty application using the warp server, passing extra options. +scottyOpts :: Options -> ScottyM() -> IO () +scottyOpts opts s = do + when (verbose opts > 0) $ + putStrLn $ "Setting phasers to stun... (port " ++ show (settingsPort (settings opts)) ++ ") (ctrl-c to quit)" + runSettings (settings opts) =<< scottyApp s -- | Turn a scotty application into a WAI 'Application', which can be -- run with any WAI handler. diff --git a/Web/Scotty/Types.hs b/Web/Scotty/Types.hs index 539f5341..20c57551 100644 --- a/Web/Scotty/Types.hs +++ b/Web/Scotty/Types.hs @@ -11,16 +11,24 @@ import Data.String (IsString(..)) import Data.Text.Lazy (Text, pack) import Network.Wai +import Network.Wai.Handler.Warp (Settings, defaultSettings) + +data Options = Options { verbose :: Int -- ^ 0 = silent, 1(def) = startup banner + , settings :: Settings -- ^ Warp 'Settings' + } + +instance Default Options where + def = Options 1 defaultSettings data ScottyState = ScottyState { middlewares :: [Middleware] , routes :: [Middleware] } addMiddleware :: Middleware -> ScottyState -> ScottyState -addMiddleware m (ScottyState ms rs) = ScottyState (m:ms) rs +addMiddleware m s@(ScottyState {middlewares = ms}) = s { middlewares = m:ms } addRoute :: Middleware -> ScottyState -> ScottyState -addRoute r (ScottyState ms rs) = ScottyState ms (r:rs) +addRoute r s@(ScottyState {routes = rs}) = s { routes = r:rs } instance Default ScottyState where def = ScottyState [] [] From 3c55a5546cc5e69dd6e015b77431b6627ebda2f2 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Wed, 6 Jun 2012 12:30:58 -0500 Subject: [PATCH 016/179] Add example of using Options --- examples/options.hs | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) create mode 100644 examples/options.hs diff --git a/examples/options.hs b/examples/options.hs new file mode 100644 index 00000000..cdb3324f --- /dev/null +++ b/examples/options.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE OverloadedStrings #-} +import Web.Scotty + +import Network.Wai.Middleware.RequestLogger -- install wai-extra if you don't have this + +import Data.Default (def) +import Network.Wai.Handler.Warp (settingsPort) + +-- Set some Scotty settings +opts :: Options +opts = def { verbose = 0 + , settings = (settings def) { settingsPort = 4000 } + } + +-- This won't display anything at startup, and will listen on localhost:4000 +main :: IO () +main = scottyOpts opts $ do + middleware logStdoutDev + + get "/" $ text "hello world" From 6142777927912fd1f1c1d76d42232766c5b6ec46 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Wed, 6 Jun 2012 13:36:12 -0500 Subject: [PATCH 017/179] Version bump --- scotty.cabal | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/scotty.cabal b/scotty.cabal index 4da8e721..b7aee310 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -1,5 +1,5 @@ Name: scotty -Version: 0.4.2 +Version: 0.4.3 Synopsis: Haskell web framework inspired by Ruby's Sinatra, using WAI and Warp Homepage: https://github.com/xich/scotty Bug-reports: https://github.com/xich/scotty/issues @@ -55,8 +55,9 @@ Description: Extra-source-files: README examples/basic.hs - examples/urlshortener.hs examples/json.hs + examples/options.hs + examples/urlshortener.hs examples/static/jquery.js examples/static/jquery-json.js examples/static/json.js From 175d1eed94a951f2a87759281ac0d62aea8affe1 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Wed, 6 Jun 2012 14:51:22 -0500 Subject: [PATCH 018/179] Fix wai-middleware-static to use pathInfo instead of rawPathInfo --- Network/Wai/Middleware/Static.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Network/Wai/Middleware/Static.hs b/Network/Wai/Middleware/Static.hs index d5925ea5..46948eab 100644 --- a/Network/Wai/Middleware/Static.hs +++ b/Network/Wai/Middleware/Static.hs @@ -32,7 +32,7 @@ staticRoot base app req = if exists then return $ ResponseFile status200 [("Content-Type", getMimeType fp)] fStr Nothing else app req - where fp = F.collapse $ F.fromText $ T.dropWhile (=='/') $ E.decodeUtf8 $ rawPathInfo req + where fp = F.collapse $ F.fromText $ T.intercalate "/" $ pathInfo req fStr = F.encodeString $ F.fromText base F. fp getMimeType :: F.FilePath -> B.ByteString From a46b9c2312c807e15724de6f0e598235658d5b18 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Wed, 6 Jun 2012 14:52:20 -0500 Subject: [PATCH 019/179] wai-middleware-static: Add staticList and version bump. --- Network/Wai/Middleware/Static.hs | 12 +++++++++++- wai-middleware-static/wai-middleware-static.cabal | 2 +- 2 files changed, 12 insertions(+), 2 deletions(-) diff --git a/Network/Wai/Middleware/Static.hs b/Network/Wai/Middleware/Static.hs index 46948eab..8ef678d6 100644 --- a/Network/Wai/Middleware/Static.hs +++ b/Network/Wai/Middleware/Static.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} -module Network.Wai.Middleware.Static (static, staticRoot) where +module Network.Wai.Middleware.Static (static, staticRoot, staticList) where +import Control.Monad (mplus) import Control.Monad.Trans (liftIO) import Data.List (isInfixOf) import qualified Data.Map as M @@ -35,6 +36,15 @@ staticRoot base app req = where fp = F.collapse $ F.fromText $ T.intercalate "/" $ pathInfo req fStr = F.encodeString $ F.fromText base F. fp +-- | Serve only the files given in an association list. +-- Key is the URI, Value is the filesystem path. +staticList :: [(T.Text, T.Text)] -> Middleware +staticList fs app req = + maybe (app req) + (\fp -> return $ ResponseFile status200 [("Content-Type", getMimeType (F.fromText fp))] (T.unpack fp) Nothing) + ((lookup p fs) `mplus` (lookup (T.cons '/' p) fs)) -- try without and with leading slash + where p = (T.intercalate "/" $ pathInfo req) + getMimeType :: F.FilePath -> B.ByteString getMimeType = go . map E.encodeUtf8 . F.extensions where go [] = defaultMimeType diff --git a/wai-middleware-static/wai-middleware-static.cabal b/wai-middleware-static/wai-middleware-static.cabal index 4f03cefd..7a64108f 100644 --- a/wai-middleware-static/wai-middleware-static.cabal +++ b/wai-middleware-static/wai-middleware-static.cabal @@ -1,5 +1,5 @@ Name: wai-middleware-static -Version: 0.1.0 +Version: 0.1.1 Synopsis: WAI middleware that intercepts requests to static files. Homepage: https://github.com/xich/scotty Bug-reports: https://github.com/xich/scotty/issues From 60f1268b051efacd8b88354b32daea516fada940 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Wed, 6 Jun 2012 15:04:52 -0500 Subject: [PATCH 020/179] wai-middleware-static: forgot existence check --- Network/Wai/Middleware/Static.hs | 10 ++++++++-- wai-middleware-static/wai-middleware-static.cabal | 2 +- 2 files changed, 9 insertions(+), 3 deletions(-) diff --git a/Network/Wai/Middleware/Static.hs b/Network/Wai/Middleware/Static.hs index 8ef678d6..9fd10d42 100644 --- a/Network/Wai/Middleware/Static.hs +++ b/Network/Wai/Middleware/Static.hs @@ -6,12 +6,14 @@ import Control.Monad.Trans (liftIO) import Data.List (isInfixOf) import qualified Data.Map as M import Data.Maybe (fromMaybe) +import Data.Monoid (mconcat) import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.Text as T import qualified Data.Text.Encoding as E import qualified Filesystem.Path.CurrentOS as F -import Network.HTTP.Types (status200) +import Network.HTTP.Types (status200, status404) import System.Directory (doesFileExist) import Network.Wai @@ -41,7 +43,11 @@ staticRoot base app req = staticList :: [(T.Text, T.Text)] -> Middleware staticList fs app req = maybe (app req) - (\fp -> return $ ResponseFile status200 [("Content-Type", getMimeType (F.fromText fp))] (T.unpack fp) Nothing) + (\fp -> do let fStr = T.unpack fp + exists <- liftIO $ doesFileExist fStr + if exists + then return $ ResponseFile status200 [("Content-Type", getMimeType (F.fromText fp))] fStr Nothing + else return $ responseLBS status404 [("Content-Type", "text/plain")] $ mconcat ["404: ", BL.pack fStr, " not found."]) ((lookup p fs) `mplus` (lookup (T.cons '/' p) fs)) -- try without and with leading slash where p = (T.intercalate "/" $ pathInfo req) diff --git a/wai-middleware-static/wai-middleware-static.cabal b/wai-middleware-static/wai-middleware-static.cabal index 7a64108f..ff845756 100644 --- a/wai-middleware-static/wai-middleware-static.cabal +++ b/wai-middleware-static/wai-middleware-static.cabal @@ -1,5 +1,5 @@ Name: wai-middleware-static -Version: 0.1.1 +Version: 0.1.2 Synopsis: WAI middleware that intercepts requests to static files. Homepage: https://github.com/xich/scotty Bug-reports: https://github.com/xich/scotty/issues From 165e67a33563985982f4b47504fc50465bee6cfc Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Thu, 7 Jun 2012 15:30:10 -0500 Subject: [PATCH 021/179] wai-middleware-static: Switch to policy-based approach --- Network/Wai/Middleware/Static.hs | 121 ++++++++++++------ .../wai-middleware-static.cabal | 7 +- 2 files changed, 84 insertions(+), 44 deletions(-) diff --git a/Network/Wai/Middleware/Static.hs b/Network/Wai/Middleware/Static.hs index 9fd10d42..f1d62708 100644 --- a/Network/Wai/Middleware/Static.hs +++ b/Network/Wai/Middleware/Static.hs @@ -1,66 +1,109 @@ {-# LANGUAGE OverloadedStrings #-} -module Network.Wai.Middleware.Static (static, staticRoot, staticList) where +-- | Serve static files, subject to a policy that can filter or +-- modify incoming URIs. The flow is: +-- +-- incoming request URI ==> policies ==> exists? ==> respond +-- +-- If any of the polices fail (return Nothing), or the file doesn't +-- exist, then the middleware gives up and calls the inner application. +-- If the file is found, the middleware chooses a content type based +-- on the file extension and returns the file contents as the response. +module Network.Wai.Middleware.Static + ( -- * Middlewares + static, staticPolicy + , -- * Policies + Policy, (>->) + , addBase, addSlash, noDots, only + ) where -import Control.Monad (mplus) import Control.Monad.Trans (liftIO) import Data.List (isInfixOf) import qualified Data.Map as M import Data.Maybe (fromMaybe) -import Data.Monoid (mconcat) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy.Char8 as BL +import Data.Monoid import qualified Data.Text as T -import qualified Data.Text.Encoding as E -import qualified Filesystem.Path.CurrentOS as F -import Network.HTTP.Types (status200, status404) +import Network.HTTP.Types (status200, Ascii) import System.Directory (doesFileExist) +import System.FilePath import Network.Wai +-- | Take an incoming URI and optionally modify or filter it. +-- The result will be treated as a filepath. +type Policy = String -> Maybe String + +-- | Combine two policies. They are run from left to right. +(>->) :: Policy -> Policy -> Policy +p1 >-> p2 = maybe Nothing p2 . p1 + +-- | Filter URIs containing \"..\" +noDots :: Policy +noDots s = if ".." `isInfixOf` s then Nothing else Just s + +-- | Add a base path to the URI +-- +-- > staticPolicy (addBase "/home/user/files") +-- +-- GET \"foo\/bar\" looks for \"\/home\/user\/files\/foo\/bar\" +-- +addBase :: String -> Policy +addBase b = Just . (b ) + +-- | Add an initial slash to to the URI, if not already present. +-- +-- > staticPolicy addSlash +-- +-- GET \"foo\/bar\" looks for \"\/foo\/bar\" +addSlash :: Policy +addSlash s@('/':_) = Just s +addSlash s = Just ('/':s) + +-- | Filter any URIs not in a specific list, mapping to a filepath. +-- +-- > staticPolicy (only [("foo/bar", "/home/user/files/bar")]) +-- +-- GET \"foo\/bar\" looks for \"\/home\/user\/files\/bar\" +-- GET \"baz\/bar\" doesn't match anything +-- +only :: [(String,String)] -> Policy +only = flip lookup + -- | Serve static files out of the application root (current directory). -- If file is found, it is streamed to the client and no further middleware is run. static :: Middleware -static = staticRoot "" - --- | Like 'static', but only looks for static files in the given directory. --- Supplied path may be relative or absolute and is prepended to the requested path. --- --- > static = staticRoot "" -staticRoot :: T.Text -> Middleware -staticRoot base app req = - if ".." `isInfixOf` (F.encodeString fp) -- for security reasons - then app req - else do exists <- liftIO $ doesFileExist fStr - if exists - then return $ ResponseFile status200 [("Content-Type", getMimeType fp)] fStr Nothing - else app req - where fp = F.collapse $ F.fromText $ T.intercalate "/" $ pathInfo req - fStr = F.encodeString $ F.fromText base F. fp +static = staticPolicy mempty --- | Serve only the files given in an association list. --- Key is the URI, Value is the filesystem path. -staticList :: [(T.Text, T.Text)] -> Middleware -staticList fs app req = +-- | Serve static files subject to a 'Policy' +staticPolicy :: Policy -> Middleware +staticPolicy p app req = maybe (app req) - (\fp -> do let fStr = T.unpack fp - exists <- liftIO $ doesFileExist fStr + (\fp -> do exists <- liftIO $ doesFileExist fp if exists - then return $ ResponseFile status200 [("Content-Type", getMimeType (F.fromText fp))] fStr Nothing - else return $ responseLBS status404 [("Content-Type", "text/plain")] $ mconcat ["404: ", BL.pack fStr, " not found."]) - ((lookup p fs) `mplus` (lookup (T.cons '/' p) fs)) -- try without and with leading slash - where p = (T.intercalate "/" $ pathInfo req) + then return $ ResponseFile status200 + [("Content-Type", getMimeType fp)] + fp + Nothing + else app req) + (p $ T.unpack $ T.intercalate "/" $ pathInfo req) -getMimeType :: F.FilePath -> B.ByteString -getMimeType = go . map E.encodeUtf8 . F.extensions +getMimeType :: FilePath -> Ascii +getMimeType = go . extensions where go [] = defaultMimeType - go exts = fromMaybe (go $ tail exts) $ M.lookup (B.intercalate "." exts) defaultMimeTypes + go (ext:exts) = fromMaybe (go exts) $ M.lookup ext defaultMimeTypes + +extensions :: FilePath -> [String] +extensions [] = [] +extensions fp = case dropWhile (/= '.') fp of + [] -> [] + s -> let ext = tail s + in ext : extensions ext -defaultMimeType :: B.ByteString +defaultMimeType :: Ascii defaultMimeType = "application/octet-stream" -- This list taken from snap-core's Snap.Util.FileServe -defaultMimeTypes :: M.Map B.ByteString B.ByteString +defaultMimeTypes :: M.Map String Ascii defaultMimeTypes = M.fromList [ ( "asc" , "text/plain" ), ( "asf" , "video/x-ms-asf" ), diff --git a/wai-middleware-static/wai-middleware-static.cabal b/wai-middleware-static/wai-middleware-static.cabal index ff845756..eac2fff9 100644 --- a/wai-middleware-static/wai-middleware-static.cabal +++ b/wai-middleware-static/wai-middleware-static.cabal @@ -1,5 +1,5 @@ Name: wai-middleware-static -Version: 0.1.2 +Version: 0.2.0 Synopsis: WAI middleware that intercepts requests to static files. Homepage: https://github.com/xich/scotty Bug-reports: https://github.com/xich/scotty/issues @@ -18,18 +18,15 @@ Description: . [WAI] --- Extra-source-files: - Library Exposed-modules: Network.Wai.Middleware.Static default-language: Haskell2010 Build-depends: base >= 4.3.1 && < 5, - bytestring >= 0.9.1, containers >= 0.4, directory >= 1.1, http-types >= 0.6.8 && < 0.7, mtl >= 2.0.1, - system-filepath >= 0.4.4, + filepath >= 1.3.0.0, text >= 0.11.1, wai >= 1.0.0 From 9a63208aef341554f2d0cbf37a74541a8f0ff834 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Thu, 7 Jun 2012 15:32:31 -0500 Subject: [PATCH 022/179] Update json example to new static middleware --- examples/json.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/examples/json.hs b/examples/json.hs index aaddff6d..7f00a49c 100644 --- a/examples/json.hs +++ b/examples/json.hs @@ -24,7 +24,7 @@ $(deriveJSON Prelude.id ''Foo) main :: IO () main = scotty 3000 $ do middleware logStdoutDev - middleware $ staticRoot "static" + middleware $ staticPolicy (addBase "static") get "/" $ do html $ wrapper $ do From fe0fa27b0223e80bc87a0b16ffc10e4677303a0b Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Thu, 7 Jun 2012 16:28:56 -0500 Subject: [PATCH 023/179] wai-middleware-static: fix broken static --- Network/Wai/Middleware/Static.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Network/Wai/Middleware/Static.hs b/Network/Wai/Middleware/Static.hs index f1d62708..0048ccfe 100644 --- a/Network/Wai/Middleware/Static.hs +++ b/Network/Wai/Middleware/Static.hs @@ -72,7 +72,7 @@ only = flip lookup -- | Serve static files out of the application root (current directory). -- If file is found, it is streamed to the client and no further middleware is run. static :: Middleware -static = staticPolicy mempty +static = staticPolicy Just -- | Serve static files subject to a 'Policy' staticPolicy :: Policy -> Middleware From 8e3097b7655c5df004f3f66bc653f5a807653816 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Fri, 8 Jun 2012 10:12:42 -0500 Subject: [PATCH 024/179] Add Policy choice operator. --- Network/Wai/Middleware/Static.hs | 29 ++++++++++++------- examples/json.hs | 2 +- .../wai-middleware-static.cabal | 2 +- 3 files changed, 21 insertions(+), 12 deletions(-) diff --git a/Network/Wai/Middleware/Static.hs b/Network/Wai/Middleware/Static.hs index 0048ccfe..c2d0367c 100644 --- a/Network/Wai/Middleware/Static.hs +++ b/Network/Wai/Middleware/Static.hs @@ -12,20 +12,19 @@ module Network.Wai.Middleware.Static ( -- * Middlewares static, staticPolicy , -- * Policies - Policy, (>->) - , addBase, addSlash, noDots, only + Policy, (>->), (<|>) + , addBase, addSlash, hasExtension, noDots, only ) where import Control.Monad.Trans (liftIO) -import Data.List (isInfixOf) +import Data.List (isInfixOf, isSuffixOf) import qualified Data.Map as M import Data.Maybe (fromMaybe) -import Data.Monoid import qualified Data.Text as T import Network.HTTP.Types (status200, Ascii) import System.Directory (doesFileExist) -import System.FilePath +import qualified System.FilePath as FP import Network.Wai @@ -33,13 +32,15 @@ import Network.Wai -- The result will be treated as a filepath. type Policy = String -> Maybe String --- | Combine two policies. They are run from left to right. +-- | Sequence two policies. They are run from left to right. +infixr 5 >-> (>->) :: Policy -> Policy -> Policy p1 >-> p2 = maybe Nothing p2 . p1 --- | Filter URIs containing \"..\" -noDots :: Policy -noDots s = if ".." `isInfixOf` s then Nothing else Just s +-- | Choose between two policies. If the first returns Nothing, run the second. +infixr 4 <|> +(<|>) :: Policy -> Policy -> Policy +p1 <|> p2 = \s -> maybe (p2 s) Just (p1 s) -- | Add a base path to the URI -- @@ -48,7 +49,7 @@ noDots s = if ".." `isInfixOf` s then Nothing else Just s -- GET \"foo\/bar\" looks for \"\/home\/user\/files\/foo\/bar\" -- addBase :: String -> Policy -addBase b = Just . (b ) +addBase b = Just . (b FP.) -- | Add an initial slash to to the URI, if not already present. -- @@ -59,6 +60,14 @@ addSlash :: Policy addSlash s@('/':_) = Just s addSlash s = Just ('/':s) +-- | Filter URIs based on extension +hasExtension :: String -> Policy +hasExtension suf s = if suf `isSuffixOf` s then Just s else Nothing + +-- | Filter URIs containing \"..\" +noDots :: Policy +noDots s = if ".." `isInfixOf` s then Nothing else Just s + -- | Filter any URIs not in a specific list, mapping to a filepath. -- -- > staticPolicy (only [("foo/bar", "/home/user/files/bar")]) diff --git a/examples/json.hs b/examples/json.hs index 7f00a49c..a525cca9 100644 --- a/examples/json.hs +++ b/examples/json.hs @@ -24,7 +24,7 @@ $(deriveJSON Prelude.id ''Foo) main :: IO () main = scotty 3000 $ do middleware logStdoutDev - middleware $ staticPolicy (addBase "static") + middleware $ staticPolicy (noDots >-> addBase "static") get "/" $ do html $ wrapper $ do diff --git a/wai-middleware-static/wai-middleware-static.cabal b/wai-middleware-static/wai-middleware-static.cabal index eac2fff9..788e983d 100644 --- a/wai-middleware-static/wai-middleware-static.cabal +++ b/wai-middleware-static/wai-middleware-static.cabal @@ -1,5 +1,5 @@ Name: wai-middleware-static -Version: 0.2.0 +Version: 0.2.2 Synopsis: WAI middleware that intercepts requests to static files. Homepage: https://github.com/xich/scotty Bug-reports: https://github.com/xich/scotty/issues From f94967b61e5b6390fcdbd57a22fb3a8463bf7bef Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Fri, 8 Jun 2012 16:17:08 -0500 Subject: [PATCH 025/179] Make Policy abstract --- Network/Wai/Middleware/Static.hs | 71 +++++++++++++------ .../wai-middleware-static.cabal | 2 +- 2 files changed, 51 insertions(+), 22 deletions(-) diff --git a/Network/Wai/Middleware/Static.hs b/Network/Wai/Middleware/Static.hs index c2d0367c..1916660d 100644 --- a/Network/Wai/Middleware/Static.hs +++ b/Network/Wai/Middleware/Static.hs @@ -4,7 +4,7 @@ -- -- incoming request URI ==> policies ==> exists? ==> respond -- --- If any of the polices fail (return Nothing), or the file doesn't +-- If any of the polices fail, or the file doesn't -- exist, then the middleware gives up and calls the inner application. -- If the file is found, the middleware chooses a content type based -- on the file extension and returns the file contents as the response. @@ -12,14 +12,17 @@ module Network.Wai.Middleware.Static ( -- * Middlewares static, staticPolicy , -- * Policies - Policy, (>->), (<|>) - , addBase, addSlash, hasExtension, noDots, only + Policy, (<|>), (>->), policy, predicate + , addBase, addSlash, contains, hasPrefix, hasSuffix, noDots, only + , -- * Utilities + tryPolicy ) where import Control.Monad.Trans (liftIO) -import Data.List (isInfixOf, isSuffixOf) +import Data.List import qualified Data.Map as M import Data.Maybe (fromMaybe) +import Data.Monoid import qualified Data.Text as T import Network.HTTP.Types (status200, Ascii) @@ -30,17 +33,33 @@ import Network.Wai -- | Take an incoming URI and optionally modify or filter it. -- The result will be treated as a filepath. -type Policy = String -> Maybe String +newtype Policy = Policy { tryPolicy :: String -> Maybe String -- ^ Run a policy + } --- | Sequence two policies. They are run from left to right. +-- | Note: +-- 'mempty' == @policy Just@ (the always accepting policy) +-- 'mappend' == @>->@ (policy sequencing) +instance Monoid Policy where + mempty = policy Just + mappend p1 p2 = policy (maybe Nothing (tryPolicy p2) . tryPolicy p1) + +-- | Lift a function into a 'Policy' +policy :: (String -> Maybe String) -> Policy +policy = Policy + +-- | Lift a predicate into a 'Policy' +predicate :: (String -> Bool) -> Policy +predicate p = policy (\s -> if p s then Just s else Nothing) + +-- | Sequence two policies. They are run from left to right. (Note: this is `mappend`) infixr 5 >-> (>->) :: Policy -> Policy -> Policy -p1 >-> p2 = maybe Nothing p2 . p1 +(>->) = mappend --- | Choose between two policies. If the first returns Nothing, run the second. +-- | Choose between two policies. If the first fails, run the second. infixr 4 <|> (<|>) :: Policy -> Policy -> Policy -p1 <|> p2 = \s -> maybe (p2 s) Just (p1 s) +p1 <|> p2 = policy (\s -> maybe (tryPolicy p2 s) Just (tryPolicy p1 s)) -- | Add a base path to the URI -- @@ -49,7 +68,7 @@ p1 <|> p2 = \s -> maybe (p2 s) Just (p1 s) -- GET \"foo\/bar\" looks for \"\/home\/user\/files\/foo\/bar\" -- addBase :: String -> Policy -addBase b = Just . (b FP.) +addBase b = policy (Just . (b FP.)) -- | Add an initial slash to to the URI, if not already present. -- @@ -57,18 +76,28 @@ addBase b = Just . (b FP.) -- -- GET \"foo\/bar\" looks for \"\/foo\/bar\" addSlash :: Policy -addSlash s@('/':_) = Just s -addSlash s = Just ('/':s) +addSlash = policy slashOpt + where slashOpt s@('/':_) = Just s + slashOpt s = Just ('/':s) + +-- | Accept only URIs with given suffix +hasSuffix :: String -> Policy +hasSuffix suf = predicate (isSuffixOf suf) + +-- | Accept only URIs with given prefix +hasPrefix :: String -> Policy +hasPrefix pre = predicate (isPrefixOf pre) --- | Filter URIs based on extension -hasExtension :: String -> Policy -hasExtension suf s = if suf `isSuffixOf` s then Just s else Nothing +-- | Accept only URIs containing given string +contains :: String -> Policy +contains s = predicate (isInfixOf s) --- | Filter URIs containing \"..\" +-- | Reject URIs containing \"..\" noDots :: Policy -noDots s = if ".." `isInfixOf` s then Nothing else Just s +noDots = predicate (not . isInfixOf "..") --- | Filter any URIs not in a specific list, mapping to a filepath. +-- | Use URI as the key to an association list, rejecting those not found. +-- The policy result is the matching value. -- -- > staticPolicy (only [("foo/bar", "/home/user/files/bar")]) -- @@ -76,12 +105,12 @@ noDots s = if ".." `isInfixOf` s then Nothing else Just s -- GET \"baz\/bar\" doesn't match anything -- only :: [(String,String)] -> Policy -only = flip lookup +only al = policy (flip lookup al) -- | Serve static files out of the application root (current directory). -- If file is found, it is streamed to the client and no further middleware is run. static :: Middleware -static = staticPolicy Just +static = staticPolicy mempty -- | Serve static files subject to a 'Policy' staticPolicy :: Policy -> Middleware @@ -94,7 +123,7 @@ staticPolicy p app req = fp Nothing else app req) - (p $ T.unpack $ T.intercalate "/" $ pathInfo req) + (tryPolicy p $ T.unpack $ T.intercalate "/" $ pathInfo req) getMimeType :: FilePath -> Ascii getMimeType = go . extensions diff --git a/wai-middleware-static/wai-middleware-static.cabal b/wai-middleware-static/wai-middleware-static.cabal index 788e983d..cb0a7f9d 100644 --- a/wai-middleware-static/wai-middleware-static.cabal +++ b/wai-middleware-static/wai-middleware-static.cabal @@ -1,5 +1,5 @@ Name: wai-middleware-static -Version: 0.2.2 +Version: 0.3.0 Synopsis: WAI middleware that intercepts requests to static files. Homepage: https://github.com/xich/scotty Bug-reports: https://github.com/xich/scotty/issues From 66fc3136125954974a169ea9687ba7ee6006e8dd Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Mon, 25 Jun 2012 17:12:58 -0500 Subject: [PATCH 026/179] Expose Parsable and readEither, and improve haddock. --- Web/Scotty.hs | 2 +- Web/Scotty/Action.hs | 14 ++++++++++++-- scotty.cabal | 2 +- 3 files changed, 14 insertions(+), 4 deletions(-) diff --git a/Web/Scotty.hs b/Web/Scotty.hs index f588eb7d..2221cca2 100644 --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -26,7 +26,7 @@ module Web.Scotty -- ** Exceptions , raise, rescue, next -- * Types - , ScottyM, ActionM, Param, Parsable, RoutePattern + , ScottyM, ActionM, Param, Parsable(..), readEither, RoutePattern ) where import Blaze.ByteString.Builder (fromByteString) diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs index 6ec6183a..c49f9a23 100644 --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -4,7 +4,7 @@ module Web.Scotty.Action , status, header, redirect , text, html, file, json, source , raise, rescue, next - , ActionM, Parsable, Param, runAction + , ActionM, Parsable(..), readEither, Param, runAction ) where import Blaze.ByteString.Builder (Builder, fromLazyByteString) @@ -119,21 +119,28 @@ param k = do Nothing -> raise $ mconcat ["Param: ", k, " not found!"] Just v -> either (const next) return $ parseParam v +-- | Minimum implemention: 'parseParam' class Parsable a where + -- | Take a 'T.Text' value and parse it as 'a', or fail with a message. parseParam :: T.Text -> Either T.Text a - -- if any individual element fails to parse, the whole list fails to parse. + -- | Default implementation parses comma-delimited lists. + -- + -- > parseParamList t = mapM parseParam (T.split (== ',') t) parseParamList :: T.Text -> Either T.Text [a] parseParamList t = mapM parseParam (T.split (== ',') t) -- No point using 'read' for Text, ByteString, Char, and String. instance Parsable T.Text where parseParam = Right instance Parsable B.ByteString where parseParam = Right . lazyTextToStrictByteString +-- | Overrides default 'parseParamList' to parse String. instance Parsable Char where parseParam t = case T.unpack t of [c] -> Right c _ -> Left "parseParam Char: no parse" parseParamList = Right . T.unpack -- String +-- | Checks if parameter is present and is null-valued, not a literal '()'. +-- If the URI requested is: '/foo?bar=()&baz' then 'baz' will parse as (), where 'bar' will not. instance Parsable () where parseParam t = if T.null t then Right () else Left "parseParam Unit: no parse" @@ -145,6 +152,9 @@ instance Parsable Float where parseParam = readEither instance Parsable Int where parseParam = readEither instance Parsable Integer where parseParam = readEither +-- | Useful for creating 'Parsable' instances for things that already implement 'Read'. Ex: +-- +-- > instance Parsable Int where parseParam = readEither readEither :: (Read a) => T.Text -> Either T.Text a readEither t = case [ x | (x,"") <- reads (T.unpack t) ] of [x] -> Right x diff --git a/scotty.cabal b/scotty.cabal index b7aee310..1a3ab4e6 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -1,5 +1,5 @@ Name: scotty -Version: 0.4.3 +Version: 0.4.4 Synopsis: Haskell web framework inspired by Ruby's Sinatra, using WAI and Warp Homepage: https://github.com/xich/scotty Bug-reports: https://github.com/xich/scotty/issues From 7bb0ecf97f0af39af76fb69652d42ca6e2c0cd40 Mon Sep 17 00:00:00 2001 From: Hiromi Ishii Date: Sun, 15 Jul 2012 14:02:44 +0900 Subject: [PATCH 027/179] confirmed that scotty works with new wai/conduit --- scotty.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/scotty.cabal b/scotty.cabal index 1a3ab4e6..f119d406 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -74,9 +74,9 @@ Library blaze-builder >= 0.3, bytestring >= 0.9.1, case-insensitive >= 0.4, - conduit >= 0.4.0.1 && < 0.5, + conduit >= 0.4.0.1 && < 0.6, data-default >= 0.3, - http-types >= 0.6.8 && < 0.7, + http-types >= 0.6.8 && < 0.8, mtl >= 2.0.1, resourcet >= 0.3.2 && < 0.4, text >= 0.11.1, From 75e96f7ea789ab56357ababc030bc7b5f574c2e6 Mon Sep 17 00:00:00 2001 From: wiz Date: Tue, 17 Jul 2012 12:19:52 +0400 Subject: [PATCH 028/179] Fix for #19: Get all request parameters. --- Web/Scotty/Action.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs index c49f9a23..2e28255f 100644 --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} module Web.Scotty.Action - ( request, body, param, jsonData + ( request, body, param, params, jsonData , status, header, redirect , text, html, file, json, source , raise, rescue, next @@ -119,6 +119,10 @@ param k = do Nothing -> raise $ mconcat ["Param: ", k, " not found!"] Just v -> either (const next) return $ parseParam v +-- | Get all parameters from capture, form and query (in that order). +params :: ActionM [Param] +params = getParams <$> ask >>= return + -- | Minimum implemention: 'parseParam' class Parsable a where -- | Take a 'T.Text' value and parse it as 'a', or fail with a message. From 346309b8239c6cddac36cda0664f4e850232f40d Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Wed, 18 Jul 2012 14:39:07 -0700 Subject: [PATCH 029/179] Fix use of deprecated Ascii type synonym. --- Web/Scotty/Util.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Web/Scotty/Util.hs b/Web/Scotty/Util.hs index 37711bc6..7f276ad5 100644 --- a/Web/Scotty/Util.hs +++ b/Web/Scotty/Util.hs @@ -43,7 +43,7 @@ setContent (ContentSource src) (ResponseBuilder s h _) = ResponseSource s h src setContent (ContentSource src) (ResponseFile s h _ _) = ResponseSource s h src setContent (ContentSource src) (ResponseSource s h _) = ResponseSource s h src -setHeader :: (CI Ascii, Ascii) -> Response -> Response +setHeader :: (CI B.ByteString, B.ByteString) -> Response -> Response setHeader (k,v) (ResponseBuilder s h b) = ResponseBuilder s (update h k v) b setHeader (k,v) (ResponseFile s h f fp) = ResponseFile s (update h k v) f fp setHeader (k,v) (ResponseSource s h cs) = ResponseSource s (update h k v) cs From 1b9a5105cd6f6e0e4aa23f6837cc4c2c9a776a04 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Wed, 18 Jul 2012 14:41:04 -0700 Subject: [PATCH 030/179] Extraneous return, and params not exported from top level. --- Web/Scotty.hs | 2 +- Web/Scotty/Action.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/Web/Scotty.hs b/Web/Scotty.hs index 2221cca2..dca09388 100644 --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -15,7 +15,7 @@ module Web.Scotty -- * Defining Actions , Action -- ** Accessing the Request, Captures, and Query Parameters - , request, body, param, jsonData + , request, body, param, params, jsonData -- ** Modifying the Response and Redirecting , status, header, redirect -- ** Setting Response Body diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs index 2e28255f..2b677026 100644 --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -121,7 +121,7 @@ param k = do -- | Get all parameters from capture, form and query (in that order). params :: ActionM [Param] -params = getParams <$> ask >>= return +params = getParams <$> ask -- | Minimum implemention: 'parseParam' class Parsable a where From fe7a4362574cffa3396674ea3e294c2f58295660 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Wed, 18 Jul 2012 15:14:29 -0700 Subject: [PATCH 031/179] Organize haddock a bit. --- Web/Scotty.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/Web/Scotty.hs b/Web/Scotty.hs index dca09388..e7aba7fc 100644 --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -25,8 +25,10 @@ module Web.Scotty , text, html, file, json, source -- ** Exceptions , raise, rescue, next + -- * Parsing Parameters + , Param, Parsable(..), readEither -- * Types - , ScottyM, ActionM, Param, Parsable(..), readEither, RoutePattern + , ScottyM, ActionM, RoutePattern ) where import Blaze.ByteString.Builder (fromByteString) From bc51c4c3872e4d876207a51c2698f97cedbac05b Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Wed, 18 Jul 2012 15:35:48 -0700 Subject: [PATCH 032/179] Add reqHeader --- Web/Scotty.hs | 2 +- Web/Scotty/Action.hs | 10 +++++++++- examples/basic.hs | 4 ++++ 3 files changed, 14 insertions(+), 2 deletions(-) diff --git a/Web/Scotty.hs b/Web/Scotty.hs index e7aba7fc..e3f7d7da 100644 --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -15,7 +15,7 @@ module Web.Scotty -- * Defining Actions , Action -- ** Accessing the Request, Captures, and Query Parameters - , request, body, param, params, jsonData + , request, reqHeader, body, param, params, jsonData -- ** Modifying the Response and Redirecting , status, header, redirect -- ** Setting Response Body diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs index 2b677026..790601d9 100644 --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} module Web.Scotty.Action - ( request, body, param, params, jsonData + ( request, reqHeader, body, param, params, jsonData , status, header, redirect , text, html, file, json, source , raise, rescue, next @@ -95,6 +95,14 @@ redirect = throwError . Redirect request :: ActionM Request request = getReq <$> ask +-- | Get a request header. Header name is case-insensitive. +reqHeader :: T.Text -> ActionM T.Text +reqHeader k = do + hs <- requestHeaders <$> request + maybe (raise (mconcat ["reqHeader: ", k, " not found"])) + (return . strictByteStringToLazyText) + (lookup (CI.mk (lazyTextToStrictByteString k)) hs) + -- | Get the request body. body :: ActionM BL.ByteString body = getBody <$> ask diff --git a/examples/basic.hs b/examples/basic.hs index fdf92910..9918c5f3 100644 --- a/examples/basic.hs +++ b/examples/basic.hs @@ -88,6 +88,10 @@ main = scotty 3000 $ do get "/lambda/:foo/:bar/:baz" $ \ foo bar baz -> do text $ mconcat [foo, bar, baz] + get "/reqHeader" $ do + agent <- reqHeader "User-Agent" + text agent + {- If you don't want to use Warp as your webserver, you can use any WAI handler. From fbc108d572a8bccc5b02204ea0f43cc595f7213c Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Sat, 21 Jul 2012 09:39:12 -0700 Subject: [PATCH 033/179] Fix form encoding matcher to use isPrefixOf --- Web/Scotty/Route.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/Web/Scotty/Route.hs b/Web/Scotty/Route.hs index 92ec3cf9..48b0e3c7 100644 --- a/Web/Scotty/Route.hs +++ b/Web/Scotty/Route.hs @@ -13,6 +13,7 @@ import Control.Monad.Trans.Resource (ResourceT) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.CaseInsensitive as CI +import Data.Char (toLower) import Data.Conduit.Lazy (lazyConsume) import Data.Maybe (fromMaybe) import Data.Monoid (mconcat) @@ -135,8 +136,9 @@ mkEnv method req captures = do b <- BL.fromChunks <$> lazyConsume (requestBody req) let parameters = captures ++ formparams ++ queryparams - formparams = case (method, lookup "Content-Type" [(CI.mk k, CI.mk v) | (k,v) <- requestHeaders req]) of - (_, Just "application/x-www-form-urlencoded") -> parseEncodedParams $ mconcat $ BL.toChunks b + formparams = case (method, lookup "Content-Type" [(CI.mk k, v) | (k,v) <- requestHeaders req]) of + (_, Just enc) | "application/x-www-form-urlencoded" `B.isPrefixOf` (B.map toLower enc) + -> parseEncodedParams $ mconcat $ BL.toChunks b _ -> [] queryparams = parseEncodedParams $ rawQueryString req From c7542dfa20bf6c91ef90ed238bef4d11e7db458e Mon Sep 17 00:00:00 2001 From: James Newman Date: Mon, 23 Jul 2012 10:19:09 -0700 Subject: [PATCH 034/179] added support for file upload --- Web/Scotty/Action.hs | 6 +++++- Web/Scotty/Route.hs | 11 ++++++----- Web/Scotty/Types.hs | 3 ++- scotty.cabal | 3 ++- 4 files changed, 15 insertions(+), 8 deletions(-) diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs index 790601d9..85c07358 100644 --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} module Web.Scotty.Action - ( request, reqHeader, body, param, params, jsonData + ( request, files, reqHeader, body, param, params, jsonData , status, header, redirect , text, html, file, json, source , raise, rescue, next @@ -26,6 +26,7 @@ import Data.Text.Lazy.Encoding (encodeUtf8) import Network.HTTP.Types import Network.Wai +import Network.Wai.Parse (File) import Web.Scotty.Types import Web.Scotty.Util @@ -95,6 +96,9 @@ redirect = throwError . Redirect request :: ActionM Request request = getReq <$> ask +files :: ActionM [File BL.ByteString] +files = getFiles <$> ask + -- | Get a request header. Header name is case-insensitive. reqHeader :: T.Text -> ActionM T.Text reqHeader k = do diff --git a/Web/Scotty/Route.hs b/Web/Scotty/Route.hs index 92ec3cf9..afcf5f1b 100644 --- a/Web/Scotty/Route.hs +++ b/Web/Scotty/Route.hs @@ -21,6 +21,7 @@ import qualified Data.Text as TS import Network.HTTP.Types import Network.Wai +import Network.Wai.Parse (parseRequestBody, lbsBackEnd) import qualified Text.Regex as Regex @@ -134,13 +135,13 @@ mkEnv :: StdMethod -> Request -> [Param] -> ResourceT IO ActionEnv mkEnv method req captures = do b <- BL.fromChunks <$> lazyConsume (requestBody req) - let parameters = captures ++ formparams ++ queryparams - formparams = case (method, lookup "Content-Type" [(CI.mk k, CI.mk v) | (k,v) <- requestHeaders req]) of - (_, Just "application/x-www-form-urlencoded") -> parseEncodedParams $ mconcat $ BL.toChunks b - _ -> [] + (formparams, files) <- parseRequestBody lbsBackEnd req + let convert (bs0, bs1) = (T.pack . B.unpack $ bs0, T.pack . B.unpack $ bs1) + + let parameters = captures ++ map convert formparams ++ queryparams queryparams = parseEncodedParams $ rawQueryString req - return $ Env req parameters b + return $ Env req parameters b files parseEncodedParams :: B.ByteString -> [Param] parseEncodedParams bs = [ (T.fromStrict k, T.fromStrict $ fromMaybe "" v) | (k,v) <- parseQueryText bs ] diff --git a/Web/Scotty/Types.hs b/Web/Scotty/Types.hs index 20c57551..a5e038a7 100644 --- a/Web/Scotty/Types.hs +++ b/Web/Scotty/Types.hs @@ -12,6 +12,7 @@ import Data.Text.Lazy (Text, pack) import Network.Wai import Network.Wai.Handler.Warp (Settings, defaultSettings) +import Network.Wai.Parse(File) data Options = Options { verbose :: Int -- ^ 0 = silent, 1(def) = startup banner , settings :: Settings -- ^ Warp 'Settings' @@ -46,7 +47,7 @@ data ActionError = Redirect Text instance Error ActionError where strMsg = ActionError . pack -data ActionEnv = Env { getReq :: Request, getParams :: [Param], getBody :: ByteString } +data ActionEnv = Env { getReq :: Request, getParams :: [Param], getBody :: ByteString, getFiles :: [File ByteString] } newtype ActionM a = AM { runAM :: ErrorT ActionError (ReaderT ActionEnv (StateT Response IO)) a } deriving ( Monad, MonadIO, Functor diff --git a/scotty.cabal b/scotty.cabal index f119d406..83b7321d 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -82,7 +82,8 @@ Library text >= 0.11.1, wai >= 1.0.0, warp >= 1.0.0, - regex-compat >= 0.95.1 + regex-compat >= 0.95.1, + wai-extra >= 1.2 GHC-options: -Wall -fno-warn-orphans From 891915c94270040c8751d880a465e2bfbb0de471 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Mon, 23 Jul 2012 20:23:19 -0700 Subject: [PATCH 035/179] Some mkEnv cleanup. --- Web/Scotty/Route.hs | 17 ++++++++--------- 1 file changed, 8 insertions(+), 9 deletions(-) diff --git a/Web/Scotty/Route.hs b/Web/Scotty/Route.hs index d0a40bfb..afae8d5b 100644 --- a/Web/Scotty/Route.hs +++ b/Web/Scotty/Route.hs @@ -12,8 +12,6 @@ import Control.Monad.Trans.Resource (ResourceT) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as BL -import qualified Data.CaseInsensitive as CI -import Data.Char (toLower) import Data.Conduit.Lazy (lazyConsume) import Data.Maybe (fromMaybe) import Data.Monoid (mconcat) @@ -28,6 +26,7 @@ import qualified Text.Regex as Regex import Web.Scotty.Action import Web.Scotty.Types +import Web.Scotty.Util -- | get = 'addroute' 'GET' get :: (Action action) => RoutePattern -> action -> ScottyM () @@ -103,7 +102,7 @@ route method pat action app req = if Right method == parseMethod (requestMethod req) then case matchRoute pat req of Just captures -> do - env <- mkEnv method req captures + env <- mkEnv req captures res <- lift $ runAction env action maybe tryNext return res Nothing -> tryNext @@ -132,17 +131,17 @@ matchRoute (Capture pat) req = go (T.split (=='/') pat) (T.split (=='/') $ path path :: Request -> T.Text path = T.fromStrict . TS.cons '/' . TS.intercalate "/" . pathInfo -mkEnv :: StdMethod -> Request -> [Param] -> ResourceT IO ActionEnv -mkEnv method req captures = do +mkEnv :: Request -> [Param] -> ResourceT IO ActionEnv +mkEnv req captures = do b <- BL.fromChunks <$> lazyConsume (requestBody req) - (formparams, files) <- parseRequestBody lbsBackEnd req - let convert (bs0, bs1) = (T.pack . B.unpack $ bs0, T.pack . B.unpack $ bs1) + (formparams, fs) <- parseRequestBody lbsBackEnd req - let parameters = captures ++ map convert formparams ++ queryparams + let convert (k, v) = (strictByteStringToLazyText k, strictByteStringToLazyText v) + parameters = captures ++ map convert formparams ++ queryparams queryparams = parseEncodedParams $ rawQueryString req - return $ Env req parameters b files + return $ Env req parameters b fs parseEncodedParams :: B.ByteString -> [Param] parseEncodedParams bs = [ (T.fromStrict k, T.fromStrict $ fromMaybe "" v) | (k,v) <- parseQueryText bs ] From 1ca880eb501a273ce3edb008b5d6d41a225b79fa Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Mon, 23 Jul 2012 20:23:56 -0700 Subject: [PATCH 036/179] Version bump. --- scotty.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scotty.cabal b/scotty.cabal index 83b7321d..4411888a 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -1,5 +1,5 @@ Name: scotty -Version: 0.4.4 +Version: 0.4.5 Synopsis: Haskell web framework inspired by Ruby's Sinatra, using WAI and Warp Homepage: https://github.com/xich/scotty Bug-reports: https://github.com/xich/scotty/issues From 936268cd2db6b55aceff3819a4907bdc67882131 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Wed, 25 Jul 2012 09:46:45 -0700 Subject: [PATCH 037/179] Add upload example, and clean up files interface a bit. --- Web/Scotty.hs | 4 ++-- Web/Scotty/Action.hs | 4 ++-- Web/Scotty/Route.hs | 2 +- Web/Scotty/Types.hs | 6 ++++-- examples/upload.hs | 45 ++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 54 insertions(+), 7 deletions(-) create mode 100644 examples/upload.hs diff --git a/Web/Scotty.hs b/Web/Scotty.hs index e3f7d7da..d0338076 100644 --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -15,7 +15,7 @@ module Web.Scotty -- * Defining Actions , Action -- ** Accessing the Request, Captures, and Query Parameters - , request, reqHeader, body, param, params, jsonData + , request, reqHeader, body, param, params, jsonData, files -- ** Modifying the Response and Redirecting , status, header, redirect -- ** Setting Response Body @@ -28,7 +28,7 @@ module Web.Scotty -- * Parsing Parameters , Param, Parsable(..), readEither -- * Types - , ScottyM, ActionM, RoutePattern + , ScottyM, ActionM, RoutePattern, File ) where import Blaze.ByteString.Builder (fromByteString) diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs index 85c07358..8b22a5c5 100644 --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -26,7 +26,6 @@ import Data.Text.Lazy.Encoding (encodeUtf8) import Network.HTTP.Types import Network.Wai -import Network.Wai.Parse (File) import Web.Scotty.Types import Web.Scotty.Util @@ -96,7 +95,8 @@ redirect = throwError . Redirect request :: ActionM Request request = getReq <$> ask -files :: ActionM [File BL.ByteString] +-- | Get list of uploaded files. +files :: ActionM [File] files = getFiles <$> ask -- | Get a request header. Header name is case-insensitive. diff --git a/Web/Scotty/Route.hs b/Web/Scotty/Route.hs index afae8d5b..091972be 100644 --- a/Web/Scotty/Route.hs +++ b/Web/Scotty/Route.hs @@ -141,7 +141,7 @@ mkEnv req captures = do parameters = captures ++ map convert formparams ++ queryparams queryparams = parseEncodedParams $ rawQueryString req - return $ Env req parameters b fs + return $ Env req parameters b [ (strictByteStringToLazyText k, fi) | (k,fi) <- fs ] parseEncodedParams :: B.ByteString -> [Param] parseEncodedParams bs = [ (T.fromStrict k, T.fromStrict $ fromMaybe "" v) | (k,v) <- parseQueryText bs ] diff --git a/Web/Scotty/Types.hs b/Web/Scotty/Types.hs index a5e038a7..a19c88ab 100644 --- a/Web/Scotty/Types.hs +++ b/Web/Scotty/Types.hs @@ -12,7 +12,7 @@ import Data.Text.Lazy (Text, pack) import Network.Wai import Network.Wai.Handler.Warp (Settings, defaultSettings) -import Network.Wai.Parse(File) +import Network.Wai.Parse (FileInfo) data Options = Options { verbose :: Int -- ^ 0 = silent, 1(def) = startup banner , settings :: Settings -- ^ Warp 'Settings' @@ -47,7 +47,9 @@ data ActionError = Redirect Text instance Error ActionError where strMsg = ActionError . pack -data ActionEnv = Env { getReq :: Request, getParams :: [Param], getBody :: ByteString, getFiles :: [File ByteString] } +type File = (Text, FileInfo ByteString) + +data ActionEnv = Env { getReq :: Request, getParams :: [Param], getBody :: ByteString, getFiles :: [File] } newtype ActionM a = AM { runAM :: ErrorT ActionError (ReaderT ActionEnv (StateT Response IO)) a } deriving ( Monad, MonadIO, Functor diff --git a/examples/upload.hs b/examples/upload.hs new file mode 100644 index 00000000..9d24f1f1 --- /dev/null +++ b/examples/upload.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE OverloadedStrings #-} +import Web.Scotty + +import Control.Monad.IO.Class +import Data.Monoid + +import Network.Wai.Middleware.RequestLogger +import Network.Wai.Middleware.Static +import Network.Wai.Parse + +import qualified Text.Blaze.Html5 as H +import Text.Blaze.Html5.Attributes +import Text.Blaze.Renderer.Text (renderHtml) + +import qualified Data.ByteString.Lazy as B +import qualified Data.ByteString.Char8 as BS +import System.FilePath (()) + +main :: IO () +main = scotty 3000 $ do + middleware logStdoutDev + middleware $ staticPolicy (addBase "uploads") + + get "/" $ do + html $ renderHtml + $ H.html $ do + H.body $ do + H.form H.! method "post" H.! enctype "multipart/form-data" H.! action "/upload" $ do + H.input H.! type_ "file" H.! name "foofile" + H.br + H.input H.! type_ "file" H.! name "barfile" + H.br + H.input H.! type_ "submit" + + post "/upload" $ do + fs <- files + let fs' = [ (fieldName, BS.unpack (fileName fi), fileContent fi) | (fieldName,fi) <- fs ] + -- write the files to disk, so they will be served by the static middleware + liftIO $ sequence_ [ B.writeFile ("uploads" fn) fc | (_,fn,fc) <- fs' ] + -- generate list of links to the files just uploaded + html $ mconcat [ mconcat [ fName + , ": " + , renderHtml $ H.a (H.toHtml fn) H.! (href $ H.toValue fn) >> H.br + ] + | (fName,fn,_) <- fs' ] From 777de67bfe123cd9a6f1a382034084d4ff8acb32 Mon Sep 17 00:00:00 2001 From: Fujimura Daisuke Date: Sun, 26 Aug 2012 10:51:18 +0900 Subject: [PATCH 038/179] Loosen upper bound of http-types --- wai-middleware-static/wai-middleware-static.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/wai-middleware-static/wai-middleware-static.cabal b/wai-middleware-static/wai-middleware-static.cabal index cb0a7f9d..0f5b10f1 100644 --- a/wai-middleware-static/wai-middleware-static.cabal +++ b/wai-middleware-static/wai-middleware-static.cabal @@ -24,7 +24,7 @@ Library Build-depends: base >= 4.3.1 && < 5, containers >= 0.4, directory >= 1.1, - http-types >= 0.6.8 && < 0.7, + http-types >= 0.6.8 && < 0.8, mtl >= 2.0.1, filepath >= 1.3.0.0, text >= 0.11.1, From 2af0c94eace2e73ef0a5f172f1d6bdf5dd007056 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Thu, 30 Aug 2012 11:17:51 -0500 Subject: [PATCH 039/179] Fix deprecated type synonym. --- Network/Wai/Middleware/Static.hs | 5 ++++- wai-middleware-static/wai-middleware-static.cabal | 1 + 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/Network/Wai/Middleware/Static.hs b/Network/Wai/Middleware/Static.hs index 1916660d..3915022e 100644 --- a/Network/Wai/Middleware/Static.hs +++ b/Network/Wai/Middleware/Static.hs @@ -19,13 +19,14 @@ module Network.Wai.Middleware.Static ) where import Control.Monad.Trans (liftIO) +import qualified Data.ByteString as B import Data.List import qualified Data.Map as M import Data.Maybe (fromMaybe) import Data.Monoid import qualified Data.Text as T -import Network.HTTP.Types (status200, Ascii) +import Network.HTTP.Types (status200) import System.Directory (doesFileExist) import qualified System.FilePath as FP @@ -125,6 +126,8 @@ staticPolicy p app req = else app req) (tryPolicy p $ T.unpack $ T.intercalate "/" $ pathInfo req) +type Ascii = B.ByteString + getMimeType :: FilePath -> Ascii getMimeType = go . extensions where go [] = defaultMimeType diff --git a/wai-middleware-static/wai-middleware-static.cabal b/wai-middleware-static/wai-middleware-static.cabal index 0f5b10f1..3d7566ea 100644 --- a/wai-middleware-static/wai-middleware-static.cabal +++ b/wai-middleware-static/wai-middleware-static.cabal @@ -22,6 +22,7 @@ Library Exposed-modules: Network.Wai.Middleware.Static default-language: Haskell2010 Build-depends: base >= 4.3.1 && < 5, + bytestring >= 0.9.2.1, containers >= 0.4, directory >= 1.1, http-types >= 0.6.8 && < 0.8, From b775387f99b6d387f35d18efeef574e6bb812477 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Thu, 30 Aug 2012 11:18:38 -0500 Subject: [PATCH 040/179] Version bump --- wai-middleware-static/wai-middleware-static.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/wai-middleware-static/wai-middleware-static.cabal b/wai-middleware-static/wai-middleware-static.cabal index 3d7566ea..91698e52 100644 --- a/wai-middleware-static/wai-middleware-static.cabal +++ b/wai-middleware-static/wai-middleware-static.cabal @@ -1,5 +1,5 @@ Name: wai-middleware-static -Version: 0.3.0 +Version: 0.3.1 Synopsis: WAI middleware that intercepts requests to static files. Homepage: https://github.com/xich/scotty Bug-reports: https://github.com/xich/scotty/issues From 0cf67460f4712f534b0915d15a00728be9ca086a Mon Sep 17 00:00:00 2001 From: David Johnson Date: Tue, 16 Oct 2012 15:35:45 -0500 Subject: [PATCH 041/179] fixed deprecataed references, in examples --- examples/clicker.hs | 4 ++-- examples/json.hs | 10 +++++----- examples/upload.hs | 2 +- examples/urlshortener.hs | 2 +- 4 files changed, 9 insertions(+), 9 deletions(-) diff --git a/examples/clicker.hs b/examples/clicker.hs index 8450f6d0..5a63213a 100644 --- a/examples/clicker.hs +++ b/examples/clicker.hs @@ -62,7 +62,7 @@ main = do html $ wrapper $ do H.preEscapedLazyText fv H.form ! A.id "login" ! method "post" ! action "/login" $ do - H.text "Enter class key: " + H.h6 "Enter class key: " H.input ! type_ "text" ! name "code" H.br H.input ! type_ "submit" @@ -85,7 +85,7 @@ main = do sId <- maybe (do flash "not logged in!"; redirect "/") return =<< readCookie html $ wrapper $ do H.lazyText sId - H.a ! href "/logout" $ H.text "Log out" + H.a ! href "/logout" $ H.h6 "Log out" get "/professor" $ do text "professor" diff --git a/examples/json.hs b/examples/json.hs index a525cca9..7d7b5a9d 100644 --- a/examples/json.hs +++ b/examples/json.hs @@ -9,7 +9,7 @@ import Network.Wai.Middleware.Static import qualified Text.Blaze.Html5 as H import Text.Blaze.Html5 ((!)) import Text.Blaze.Html5.Attributes as A -import Text.Blaze.Renderer.Text (renderHtml) +import Text.Blaze.Html.Renderer.Text (renderHtml) import Web.Scotty @@ -29,7 +29,7 @@ main = scotty 3000 $ do get "/" $ do html $ wrapper $ do H.form ! A.id "fooform" ! method "post" ! action "#" $ do - H.text "Select a constructor: " + H.h5 "Select a constructor: " H.input ! type_ "radio" ! A.id "fooquux" ! name "con" ! value "Quux" H.label ! for "fooquux" $ "Quux" H.input ! type_ "radio" ! A.id "foobar" ! name "con" ! value "Bar" @@ -37,12 +37,12 @@ main = scotty 3000 $ do H.input ! type_ "radio" ! A.id "foobaz" ! name "con" ! value "Baz" H.label ! for "foobaz" $ "Baz" H.br - H.text "Enter an int: " + H.h5 "Enter an int: " H.input ! type_ "text" ! class_ "barfields" ! name "Barint" H.br - H.text "Enter a float: " + H.h5 "Enter a float: " H.input ! type_ "text" ! class_ "bazfields" ! name "Bazfloat" - H.text "Enter a string: " + H.h5 "Enter a string: " H.input ! type_ "text" ! class_ "bazfields" ! name "Bazstring" H.br H.input ! type_ "submit" diff --git a/examples/upload.hs b/examples/upload.hs index 9d24f1f1..6d589358 100644 --- a/examples/upload.hs +++ b/examples/upload.hs @@ -10,7 +10,7 @@ import Network.Wai.Parse import qualified Text.Blaze.Html5 as H import Text.Blaze.Html5.Attributes -import Text.Blaze.Renderer.Text (renderHtml) +import Text.Blaze.Html.Renderer.Text (renderHtml) import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.Char8 as BS diff --git a/examples/urlshortener.hs b/examples/urlshortener.hs index 49d6f645..775b8b2d 100644 --- a/examples/urlshortener.hs +++ b/examples/urlshortener.hs @@ -12,7 +12,7 @@ import Network.Wai.Middleware.Static import qualified Text.Blaze.Html5 as H import Text.Blaze.Html5.Attributes -import Text.Blaze.Renderer.Text (renderHtml) +import Text.Blaze.Html.Renderer.Text (renderHtml) -- TODO: -- Implement some kind of session and/or cookies From b1b22dcb749ebef2bb230eef125d3cfacb5435f7 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Mon, 1 Oct 2012 16:51:02 -0500 Subject: [PATCH 042/179] Probable fix to the conduit issue. --- Web/Scotty/Route.hs | 18 ++++++++++++++++-- 1 file changed, 16 insertions(+), 2 deletions(-) diff --git a/Web/Scotty/Route.hs b/Web/Scotty/Route.hs index 091972be..628588b2 100644 --- a/Web/Scotty/Route.hs +++ b/Web/Scotty/Route.hs @@ -12,7 +12,11 @@ import Control.Monad.Trans.Resource (ResourceT) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as BL +import Data.Conduit (($$), (=$)) +import Data.Conduit.Binary (sourceLbs) import Data.Conduit.Lazy (lazyConsume) +import Data.Conduit.List (consume) +import Data.Either (partitionEithers) import Data.Maybe (fromMaybe) import Data.Monoid (mconcat) import qualified Data.Text.Lazy as T @@ -20,7 +24,7 @@ import qualified Data.Text as TS import Network.HTTP.Types import Network.Wai -import Network.Wai.Parse (parseRequestBody, lbsBackEnd) +import qualified Network.Wai.Parse as Parse hiding (parseRequestBody) import qualified Text.Regex as Regex @@ -131,11 +135,21 @@ matchRoute (Capture pat) req = go (T.split (=='/') pat) (T.split (=='/') $ path path :: Request -> T.Text path = T.fromStrict . TS.cons '/' . TS.intercalate "/" . pathInfo +-- Stolen from wai-extra, modified to accept body as lazy ByteString +parseRequestBody :: BL.ByteString + -> Parse.BackEnd y + -> Request + -> ResourceT IO ([Parse.Param], [Parse.File y]) +parseRequestBody b s r = + case Parse.getRequestBodyType r of + Nothing -> return ([], []) + Just rbt -> fmap partitionEithers $ sourceLbs b $$ Parse.conduitRequestBody s rbt =$ consume + mkEnv :: Request -> [Param] -> ResourceT IO ActionEnv mkEnv req captures = do b <- BL.fromChunks <$> lazyConsume (requestBody req) - (formparams, fs) <- parseRequestBody lbsBackEnd req + (formparams, fs) <- parseRequestBody b Parse.lbsBackEnd req let convert (k, v) = (strictByteStringToLazyText k, strictByteStringToLazyText v) parameters = captures ++ map convert formparams ++ queryparams From 9cfadcd72dda1f23fa445072482488a14546155c Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Thu, 25 Oct 2012 16:30:59 -0500 Subject: [PATCH 043/179] Add note about extra packages for urlshortener example. --- examples/urlshortener.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/examples/urlshortener.hs b/examples/urlshortener.hs index 775b8b2d..08fac146 100644 --- a/examples/urlshortener.hs +++ b/examples/urlshortener.hs @@ -12,6 +12,10 @@ import Network.Wai.Middleware.Static import qualified Text.Blaze.Html5 as H import Text.Blaze.Html5.Attributes +-- Note: +-- Scotty does not require blaze-html or +-- wai-middleware-static, but this example does +-- cabal install blaze-html wai-middleware-static import Text.Blaze.Html.Renderer.Text (renderHtml) -- TODO: From a2d7b4ceaaff45e81b784bd2e27f0ed6ae03261c Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Thu, 25 Oct 2012 16:43:03 -0500 Subject: [PATCH 044/179] Change official repo, update dep versions, version bump, remove text about Miku. --- scotty.cabal | 39 ++++++++++++++++----------------------- 1 file changed, 16 insertions(+), 23 deletions(-) diff --git a/scotty.cabal b/scotty.cabal index 4411888a..98035045 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -1,8 +1,8 @@ Name: scotty -Version: 0.4.5 +Version: 0.4.6 Synopsis: Haskell web framework inspired by Ruby's Sinatra, using WAI and Warp -Homepage: https://github.com/xich/scotty -Bug-reports: https://github.com/xich/scotty/issues +Homepage: https://github.com/ku-fpg/scotty +Bug-reports: https://github.com/ku-fpg/scotty/issues License: BSD3 License-file: LICENSE Author: Andrew Farmer @@ -39,13 +39,6 @@ Description: . * Uses very fast Warp webserver by default. . - This design has been done in Haskell at least once before (to my knowledge) by - the miku framework. My issue with miku is that it uses the Hack2 interface - instead of WAI (they are analogous, but the latter seems to have more traction), - and that it is written using a custom prelude called Air (which appears to be an - attempt to turn Haskell into Ruby syntactically). I wanted something that - depends on relatively few other packages, with an API that fits on one page. - . As for the name: Sinatra + Warp = Scotty. . [WAI] @@ -69,24 +62,24 @@ Library Web.Scotty.Types Web.Scotty.Util default-language: Haskell2010 - build-depends: aeson >= 0.5, + build-depends: aeson >= 0.6.0.2, base >= 4.3.1 && < 5, - blaze-builder >= 0.3, + blaze-builder >= 0.3.1.0, bytestring >= 0.9.1, - case-insensitive >= 0.4, - conduit >= 0.4.0.1 && < 0.6, - data-default >= 0.3, - http-types >= 0.6.8 && < 0.8, - mtl >= 2.0.1, - resourcet >= 0.3.2 && < 0.4, - text >= 0.11.1, - wai >= 1.0.0, - warp >= 1.0.0, + case-insensitive >= 0.4.0.3, + conduit >= 0.5.2.7, + data-default >= 0.5.0, + http-types >= 0.7.3.0.1, + mtl >= 2.1.2, regex-compat >= 0.95.1, - wai-extra >= 1.2 + resourcet >= 0.4.0.2, + text >= 0.11.2.3, + wai >= 1.3.0.1, + wai-extra >= 1.3.0.3, + warp >= 1.3.4.1 GHC-options: -Wall -fno-warn-orphans source-repository head type: git - location: git://github.com/xich/scotty.git + location: git://github.com/ku-fpg/scotty.git From 35a1473d0b173837f0fd520583b722d57eda9d58 Mon Sep 17 00:00:00 2001 From: Daniil Date: Fri, 28 Dec 2012 13:10:03 +0400 Subject: [PATCH 045/179] Allow user to set the response body to a given raw data --- Web/Scotty.hs | 2 +- Web/Scotty/Action.hs | 14 ++++++++++---- 2 files changed, 11 insertions(+), 5 deletions(-) diff --git a/Web/Scotty.hs b/Web/Scotty.hs index d0338076..58b76470 100644 --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -22,7 +22,7 @@ module Web.Scotty -- -- | 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, source + , text, html, file, json, source, raw -- ** Exceptions , raise, rescue, next -- * Parsing Parameters diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs index 8b22a5c5..c81f4c70 100644 --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -2,7 +2,7 @@ module Web.Scotty.Action ( request, files, reqHeader, body, param, params, jsonData , status, header, redirect - , text, html, file, json, source + , text, html, file, json, source, raw , raise, rescue, next , ActionM, Parsable(..), readEither, Param, runAction ) where @@ -191,14 +191,14 @@ header k v = MS.modify $ setHeader (CI.mk $ lazyTextToStrictByteString k, lazyTe text :: T.Text -> ActionM () text t = do header "Content-Type" "text/plain" - MS.modify $ setContent $ ContentBuilder $ fromLazyByteString $ encodeUtf8 t + raw $ encodeUtf8 t -- | Set the body of the response to the given 'T.Text' value. Also sets \"Content-Type\" -- header to \"text/html\". html :: T.Text -> ActionM () html t = do header "Content-Type" "text/html" - MS.modify $ setContent $ ContentBuilder $ fromLazyByteString $ encodeUtf8 t + raw $ encodeUtf8 t -- | Send a file as the response. Doesn't set the \"Content-Type\" header, so you probably -- want to do that on your own with 'header'. @@ -210,10 +210,16 @@ file = MS.modify . setContent . ContentFile json :: (A.ToJSON a) => a -> ActionM () json v = do header "Content-Type" "application/json" - MS.modify $ setContent $ ContentBuilder $ fromLazyByteString $ A.encode v + raw $ A.encode v -- | Set the body of the response to a Source. Doesn't set the -- \"Content-Type\" header, so you probably want to do that on your -- own with 'header'. source :: Source (ResourceT IO) (Flush Builder) -> ActionM () source = MS.modify . setContent . ContentSource + +-- | Set the body of the response to the given 'BL.ByteString' value. Doesn't set the +-- \"Content-Type\" header, so you probably want to do that on your +-- own with 'header'. +raw :: BL.ByteString -> ActionM () +raw = MS.modify . setContent . ContentBuilder . fromLazyByteString From 0f8727802412542c542fec24981068e2b588d89d Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Sun, 10 Feb 2013 21:01:14 -0800 Subject: [PATCH 046/179] Fix wai-middleware-static package bounds. --- wai-middleware-static/wai-middleware-static.cabal | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/wai-middleware-static/wai-middleware-static.cabal b/wai-middleware-static/wai-middleware-static.cabal index 91698e52..a12820c4 100644 --- a/wai-middleware-static/wai-middleware-static.cabal +++ b/wai-middleware-static/wai-middleware-static.cabal @@ -1,8 +1,8 @@ Name: wai-middleware-static -Version: 0.3.1 +Version: 0.3.2 Synopsis: WAI middleware that intercepts requests to static files. -Homepage: https://github.com/xich/scotty -Bug-reports: https://github.com/xich/scotty/issues +Homepage: https://github.com/ku-fpg/scotty +Bug-reports: https://github.com/ku-fpg/scotty/issues License: BSD3 License-file: LICENSE Author: Andrew Farmer @@ -25,7 +25,7 @@ Library bytestring >= 0.9.2.1, containers >= 0.4, directory >= 1.1, - http-types >= 0.6.8 && < 0.8, + http-types >= 0.6.8, mtl >= 2.0.1, filepath >= 1.3.0.0, text >= 0.11.1, @@ -35,4 +35,4 @@ Library source-repository head type: git - location: git://github.com/xich/scotty.git + location: git://github.com/ku-fpg/scotty.git From d6bda34e1933ca4c44856f56d2d548f0f6e438c1 Mon Sep 17 00:00:00 2001 From: Daniil Frumin Date: Sun, 2 Jun 2013 15:33:11 +0400 Subject: [PATCH 047/179] GZip example --- .gitignore | 1 + examples/gzip.hs | 13 +++++++++++++ scotty.cabal | 1 + 3 files changed, 15 insertions(+) create mode 100644 examples/gzip.hs diff --git a/.gitignore b/.gitignore index 4a47555f..c3cf5d4e 100644 --- a/.gitignore +++ b/.gitignore @@ -2,3 +2,4 @@ dist/ *.hi *.o *.swp +cabal-dev/ diff --git a/examples/gzip.hs b/examples/gzip.hs new file mode 100644 index 00000000..18b8345c --- /dev/null +++ b/examples/gzip.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE OverloadedStrings #-} +import Web.Scotty +import Network.Wai.Middleware.RequestLogger +import Network.Wai +import Network.Wai.Middleware.Gzip (gzip,def) +import qualified Data.Text.Lazy as T +import Data.Text.Lazy.Encoding (decodeUtf8) + +main :: IO () +main = scotty 6666 $ do + middleware $ gzip def + middleware logStdoutDev + get "/" $ text "It works" diff --git a/scotty.cabal b/scotty.cabal index 98035045..afb8e613 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -48,6 +48,7 @@ Description: Extra-source-files: README examples/basic.hs + examples/gzip.hs examples/json.hs examples/options.hs examples/urlshortener.hs From 114615cf4d95a151713e547e53d309fb4b262b57 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Thu, 22 Aug 2013 17:20:15 -0500 Subject: [PATCH 048/179] Add ScottyT and ActionT transformers. --- Web/Scotty.hs | 30 ++++++++++-------- Web/Scotty/Action.hs | 55 +++++++++++++++++---------------- Web/Scotty/Route.hs | 72 ++++++++++++++------------------------------ Web/Scotty/Types.hs | 34 +++++++++++++++------ scotty.cabal | 1 + 5 files changed, 93 insertions(+), 99 deletions(-) diff --git a/Web/Scotty.hs b/Web/Scotty.hs index d0338076..9dcd652e 100644 --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, RankNTypes #-} -- | It should be noted that most of the code snippets below depend on the -- OverloadedStrings language pragma. module Web.Scotty @@ -12,8 +12,6 @@ module Web.Scotty , middleware, get, post, put, delete, addroute, matchAny, notFound -- ** Route Patterns , capture, regex, function, literal - -- * Defining Actions - , Action -- ** Accessing the Request, Captures, and Query Parameters , request, reqHeader, body, param, params, jsonData, files -- ** Modifying the Response and Redirecting @@ -29,12 +27,15 @@ module Web.Scotty , Param, Parsable(..), readEither -- * Types , ScottyM, ActionM, RoutePattern, File + -- * Monad Transformers + , ScottyT, ActionT ) where import Blaze.ByteString.Builder (fromByteString) import Control.Monad (when) import Control.Monad.State (execStateT, modify) +import Control.Monad.Morph (hoist) import Data.Default (def) @@ -44,32 +45,37 @@ import Network.Wai.Handler.Warp (Port, runSettings, settingsPort) import Web.Scotty.Action import Web.Scotty.Route -import Web.Scotty.Types +import Web.Scotty.Types hiding (Application, Middleware) +import qualified Web.Scotty.Types as Scotty -- | Run a scotty application using the warp server. scotty :: Port -> ScottyM () -> IO () scotty p = scottyOpts $ def { settings = (settings def) { settingsPort = p } } -- | Run a scotty application using the warp server, passing extra options. -scottyOpts :: Options -> ScottyM() -> IO () +scottyOpts :: Options -> ScottyM () -> IO () scottyOpts opts s = do when (verbose opts > 0) $ putStrLn $ "Setting phasers to stun... (port " ++ show (settingsPort (settings opts)) ++ ") (ctrl-c to quit)" - runSettings (settings opts) =<< scottyApp s + runSettings (settings opts) =<< scottyApp id id s -- | Turn a scotty application into a WAI 'Application', which can be -- run with any WAI handler. -scottyApp :: ScottyM () -> IO Application -scottyApp defs = do - s <- execStateT (runS defs) def - return $ foldl (flip ($)) notFoundApp $ routes s ++ middlewares s +scottyApp :: (Monad m, Monad n) + => (forall a. m a -> n a) -- run monad m into monad n, called once at ScottyT level + -> (forall a. m a -> IO a) -- run monad m into IO, called at each action + -> ScottyT m () + -> n Application +scottyApp runM runToIO defs = do + s <- runM $ execStateT (runS defs) def + return $ hoist runToIO . foldl (flip ($)) notFoundApp (routes s ++ middlewares s) -notFoundApp :: Application +notFoundApp :: Monad m => Scotty.Application m notFoundApp _ = return $ ResponseBuilder status404 [("Content-Type","text/html")] $ fromByteString "

404: File Not Found!

" -- | Use given middleware. Middleware is nested such that the first declared -- is the outermost middleware (it has first dibs on the request and last action -- on the response). Every middleware is run on each request. -middleware :: Middleware -> ScottyM () +middleware :: Monad m => Scotty.Middleware m -> ScottyT m () middleware = modify . addMiddleware diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs index 8b22a5c5..05889f37 100644 --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -9,7 +9,6 @@ module Web.Scotty.Action import Blaze.ByteString.Builder (Builder, fromLazyByteString) -import Control.Applicative import Control.Monad.Error import Control.Monad.Reader import qualified Control.Monad.State as MS @@ -19,7 +18,7 @@ import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.CaseInsensitive as CI import Data.Conduit (Flush, ResourceT, Source) -import Data.Default (Default, def) +import Data.Default (def) import Data.Monoid (mconcat) import qualified Data.Text.Lazy as T import Data.Text.Lazy.Encoding (encodeUtf8) @@ -32,7 +31,7 @@ import Web.Scotty.Util -- Nothing indicates route failed (due to Next) and pattern matching should continue. -- Just indicates a successful response. -runAction :: ActionEnv -> ActionM () -> IO (Maybe Response) +runAction :: Monad m => ActionEnv -> ActionT m () -> m (Maybe Response) runAction env action = do (e,r) <- flip MS.runStateT def $ flip runReaderT env @@ -41,7 +40,7 @@ runAction env action = do $ action `catchError` defaultHandler return $ either (const Nothing) (const $ Just r) e -defaultHandler :: ActionError -> ActionM () +defaultHandler :: Monad m => ActionError -> ActionT m () defaultHandler (Redirect url) = do status status302 header "Location" url @@ -52,7 +51,7 @@ defaultHandler Next = next -- | Throw an exception, which can be caught with 'rescue'. Uncaught exceptions -- turn into HTTP 500 responses. -raise :: T.Text -> ActionM a +raise :: Monad m => T.Text -> ActionT m a raise = throwError . ActionError -- | Abort execution of this action and continue pattern matching routes. @@ -69,13 +68,13 @@ raise = throwError . ActionError -- > get "/foo/:bar" $ do -- > bar <- param "bar" -- > text "not a number" -next :: ActionM a +next :: Monad m => ActionT m a next = throwError Next -- | Catch an exception thrown by 'raise'. -- -- > raise "just kidding" `rescue` (\msg -> text msg) -rescue :: ActionM a -> (T.Text -> ActionM a) -> ActionM a +rescue :: Monad m => ActionT m a -> (T.Text -> ActionT m a) -> ActionT m a rescue action handler = catchError action $ \e -> case e of ActionError msg -> handler msg -- handle errors other -> throwError other -- rethrow redirects and nexts @@ -88,31 +87,31 @@ rescue action handler = catchError action $ \e -> case e of -- OR -- -- > redirect "/foo/bar" -redirect :: T.Text -> ActionM a +redirect :: Monad m => T.Text -> ActionT m a redirect = throwError . Redirect -- | Get the 'Request' object. -request :: ActionM Request -request = getReq <$> ask +request :: Monad m => ActionT m Request +request = liftM getReq ask -- | Get list of uploaded files. -files :: ActionM [File] -files = getFiles <$> ask +files :: Monad m => ActionT m [File] +files = liftM getFiles ask -- | Get a request header. Header name is case-insensitive. -reqHeader :: T.Text -> ActionM T.Text +reqHeader :: Monad m => T.Text -> ActionT m T.Text reqHeader k = do - hs <- requestHeaders <$> request + hs <- liftM requestHeaders request maybe (raise (mconcat ["reqHeader: ", k, " not found"])) (return . strictByteStringToLazyText) (lookup (CI.mk (lazyTextToStrictByteString k)) hs) -- | Get the request body. -body :: ActionM BL.ByteString -body = getBody <$> ask +body :: Monad m => ActionT m BL.ByteString +body = liftM getBody ask -- | Parse the request body as a JSON object and return it. Raises an exception if parse is unsuccessful. -jsonData :: (A.FromJSON a) => ActionM a +jsonData :: (A.FromJSON a, Monad m) => ActionT m a jsonData = do b <- body maybe (raise "jsonData: no parse") return $ A.decode b @@ -124,16 +123,16 @@ jsonData = do -- * If parameter is found, but 'read' fails to parse to the correct type, 'next' is called. -- This means captures are somewhat typed, in that a route won't match if a correctly typed -- capture cannot be parsed. -param :: (Parsable a) => T.Text -> ActionM a +param :: (Parsable a, Monad m) => T.Text -> ActionT m a param k = do - val <- lookup k <$> getParams <$> ask + val <- liftM (lookup k . getParams) ask case val of Nothing -> raise $ mconcat ["Param: ", k, " not found!"] Just v -> either (const next) return $ parseParam v -- | Get all parameters from capture, form and query (in that order). -params :: ActionM [Param] -params = getParams <$> ask +params :: Monad m => ActionT m [Param] +params = liftM getParams ask -- | Minimum implemention: 'parseParam' class Parsable a where @@ -178,36 +177,36 @@ readEither t = case [ x | (x,"") <- reads (T.unpack t) ] of _ -> Left "readEither: ambiguous parse" -- | Set the HTTP response status. Default is 200. -status :: Status -> ActionM () +status :: Monad m => Status -> ActionT m () status = MS.modify . setStatus -- | Set one of the response headers. Will override any previously set value for that header. -- Header names are case-insensitive. -header :: T.Text -> T.Text -> ActionM () +header :: Monad m => T.Text -> T.Text -> ActionT m () header k v = MS.modify $ setHeader (CI.mk $ lazyTextToStrictByteString k, lazyTextToStrictByteString v) -- | Set the body of the response to the given 'T.Text' value. Also sets \"Content-Type\" -- header to \"text/plain\". -text :: T.Text -> ActionM () +text :: Monad m => T.Text -> ActionT m () text t = do header "Content-Type" "text/plain" MS.modify $ setContent $ ContentBuilder $ fromLazyByteString $ encodeUtf8 t -- | Set the body of the response to the given 'T.Text' value. Also sets \"Content-Type\" -- header to \"text/html\". -html :: T.Text -> ActionM () +html :: Monad m => T.Text -> ActionT m () html t = do header "Content-Type" "text/html" MS.modify $ setContent $ ContentBuilder $ fromLazyByteString $ encodeUtf8 t -- | Send a file as the response. Doesn't set the \"Content-Type\" header, so you probably -- want to do that on your own with 'header'. -file :: FilePath -> ActionM () +file :: Monad m => FilePath -> ActionT m () file = MS.modify . setContent . ContentFile -- | Set the body of the response to the JSON encoding of the given value. Also sets \"Content-Type\" -- header to \"application/json\". -json :: (A.ToJSON a) => a -> ActionM () +json :: (A.ToJSON a, Monad m) => a -> ActionT m () json v = do header "Content-Type" "application/json" MS.modify $ setContent $ ContentBuilder $ fromLazyByteString $ A.encode v @@ -215,5 +214,5 @@ json v = do -- | Set the body of the response to a Source. Doesn't set the -- \"Content-Type\" header, so you probably want to do that on your -- own with 'header'. -source :: Source (ResourceT IO) (Flush Builder) -> ActionM () +source :: Monad m => Source (ResourceT IO) (Flush Builder) -> ActionT m () source = MS.modify . setContent . ContentSource diff --git a/Web/Scotty/Route.hs b/Web/Scotty/Route.hs index 628588b2..97716edc 100644 --- a/Web/Scotty/Route.hs +++ b/Web/Scotty/Route.hs @@ -1,14 +1,14 @@ {-# LANGUAGE OverloadedStrings, FlexibleInstances, ScopedTypeVariables #-} module Web.Scotty.Route ( get, post, put, delete, addroute, matchAny, notFound, - capture, regex, function, literal, Action + capture, regex, function, literal ) where import Control.Arrow ((***)) -import Control.Applicative import Control.Monad.Error import qualified Control.Monad.State as MS import Control.Monad.Trans.Resource (ResourceT) +import Control.Monad.Morph (hoist) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as BL @@ -23,7 +23,7 @@ import qualified Data.Text.Lazy as T import qualified Data.Text as TS import Network.HTTP.Types -import Network.Wai +import Network.Wai (Request(..)) import qualified Network.Wai.Parse as Parse hiding (parseRequestBody) import qualified Text.Regex as Regex @@ -33,28 +33,28 @@ import Web.Scotty.Types import Web.Scotty.Util -- | get = 'addroute' 'GET' -get :: (Action action) => RoutePattern -> action -> ScottyM () +get :: MonadIO m => RoutePattern -> ActionT m () -> ScottyT m () get = addroute GET -- | post = 'addroute' 'POST' -post :: (Action action) => RoutePattern -> action -> ScottyM () +post :: MonadIO m => RoutePattern -> ActionT m () -> ScottyT m () post = addroute POST -- | put = 'addroute' 'PUT' -put :: (Action action) => RoutePattern -> action -> ScottyM () +put :: MonadIO m => RoutePattern -> ActionT m () -> ScottyT m () put = addroute PUT -- | delete = 'addroute' 'DELETE' -delete :: (Action action) => RoutePattern -> action -> ScottyM () +delete :: MonadIO m => RoutePattern -> ActionT m () -> ScottyT m () delete = addroute DELETE -- | Add a route that matches regardless of the HTTP verb. -matchAny :: (Action action) => RoutePattern -> action -> ScottyM () +matchAny :: MonadIO m => RoutePattern -> ActionT m () -> ScottyT m () matchAny pattern action = mapM_ (\v -> addroute v pattern action) [minBound..maxBound] -- | Specify an action to take if nothing else is found. Note: this _always_ matches, -- so should generally be the last route specified. -notFound :: ActionM () -> ScottyM () +notFound :: MonadIO 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, @@ -71,47 +71,20 @@ notFound action = matchAny (Function (\req -> Just [("path", path req)])) (statu -- -- >>> curl http://localhost:3000/foo/something -- something -addroute :: (Action action) => StdMethod -> RoutePattern -> action -> ScottyM () -addroute method pat action = MS.modify $ addRoute $ route method pat $ build action pat +addroute :: MonadIO m => StdMethod -> RoutePattern -> ActionT m () -> ScottyT m () +addroute method pat action = MS.modify $ addRoute $ route method pat action --- | An action (executed when a route matches) can either be an 'ActionM' computation, or --- a function with an argument for each capture in the route. For example: --- --- > get "/lambda/:foo/:bar" $ \ a b -> do --- > text $ mconcat [a,b] --- --- is elaborated by Scotty to: --- --- > get "/lambda/:foo/:bar" $ do --- > a <- param "foo" --- > b <- param "bar" --- > text $ mconcat [a,b] -class Action a where - build :: a -> RoutePattern -> ActionM () - -instance Action (ActionM a) where - build action _ = action >> return () - -instance (Parsable a, Action b) => Action (a -> b) where - build f pat = findCapture pat >>= \ (v, pat') -> build (f v) pat' - where findCapture :: RoutePattern -> ActionM (a, RoutePattern) - findCapture (Literal l) = raise $ mconcat ["Lambda trying to capture a literal route: ", l] - findCapture (Capture p) = case T.span (/='/') (T.dropWhile (/=':') p) of - (m,r) | T.null m -> raise "More function arguments than captures." - | otherwise -> param (T.tail m) >>= \ v -> return (v, Capture r) - findCapture (Function _) = raise "Lambda trying to capture a function route." - -route :: StdMethod -> RoutePattern -> ActionM () -> Middleware +route :: MonadIO m => StdMethod -> RoutePattern -> ActionT m () -> Middleware m route method pat action app req = - if Right method == parseMethod (requestMethod req) - then case matchRoute pat req of + let tryNext = app req + in if Right method == parseMethod (requestMethod req) + then case matchRoute pat req of Just captures -> do env <- mkEnv req captures res <- lift $ runAction env action maybe tryNext return res Nothing -> tryNext - else tryNext - where tryNext = app req + else tryNext matchRoute :: RoutePattern -> Request -> Maybe [Param] @@ -136,20 +109,21 @@ path :: Request -> T.Text path = T.fromStrict . TS.cons '/' . TS.intercalate "/" . pathInfo -- Stolen from wai-extra, modified to accept body as lazy ByteString -parseRequestBody :: BL.ByteString +parseRequestBody :: MonadIO m + => BL.ByteString -> Parse.BackEnd y -> Request - -> ResourceT IO ([Parse.Param], [Parse.File y]) + -> ResourceT m ([Parse.Param], [Parse.File y]) parseRequestBody b s r = case Parse.getRequestBodyType r of Nothing -> return ([], []) - Just rbt -> fmap partitionEithers $ sourceLbs b $$ Parse.conduitRequestBody s rbt =$ consume + Just rbt -> hoist liftIO $ liftM partitionEithers $ sourceLbs b $$ Parse.conduitRequestBody s rbt =$ consume -mkEnv :: Request -> [Param] -> ResourceT IO ActionEnv +mkEnv :: MonadIO m => Request -> [Param] -> ResourceT m ActionEnv mkEnv req captures = do - b <- BL.fromChunks <$> lazyConsume (requestBody req) + b <- hoist liftIO $ liftM BL.fromChunks $ lazyConsume (requestBody req) - (formparams, fs) <- parseRequestBody b Parse.lbsBackEnd req + (formparams, fs) <- hoist liftIO $ parseRequestBody b Parse.lbsBackEnd req let convert (k, v) = (strictByteStringToLazyText k, strictByteStringToLazyText v) parameters = captures ++ map convert formparams ++ queryparams diff --git a/Web/Scotty/Types.hs b/Web/Scotty/Types.hs index a19c88ab..bf8061b4 100644 --- a/Web/Scotty/Types.hs +++ b/Web/Scotty/Types.hs @@ -10,7 +10,8 @@ import Data.Default (Default, def) import Data.String (IsString(..)) import Data.Text.Lazy (Text, pack) -import Network.Wai +import qualified Data.Conduit as C +import Network.Wai hiding (Middleware, Application) import Network.Wai.Handler.Warp (Settings, defaultSettings) import Network.Wai.Parse (FileInfo) @@ -21,21 +22,29 @@ data Options = Options { verbose :: Int -- ^ 0 = silent, 1(def) = startup banner instance Default Options where def = Options 1 defaultSettings -data ScottyState = ScottyState { middlewares :: [Middleware] - , routes :: [Middleware] - } +data ScottyState m = ScottyState { middlewares :: [Middleware m] + , routes :: [Middleware m] + } -addMiddleware :: Middleware -> ScottyState -> ScottyState +type Middleware m = Application m -> Application m +type Application m = Request -> C.ResourceT m Response + +addMiddleware :: Monad m => Middleware m -> ScottyState m -> ScottyState m addMiddleware m s@(ScottyState {middlewares = ms}) = s { middlewares = m:ms } -addRoute :: Middleware -> ScottyState -> ScottyState +addRoute :: Monad m => Middleware m -> ScottyState m -> ScottyState m addRoute r s@(ScottyState {routes = rs}) = s { routes = r:rs } -instance Default ScottyState where +instance Default (ScottyState m) where def = ScottyState [] [] -newtype ScottyM a = S { runS :: StateT ScottyState IO a } - deriving (Monad, MonadIO, Functor, MonadState ScottyState) +newtype ScottyT m a = ScottyT { runS :: StateT (ScottyState m) m a } + deriving (Monad, MonadIO, Functor, MonadState (ScottyState m)) + +instance MonadTrans ScottyT where + lift = ScottyT . lift + +type ScottyM a = ScottyT IO a type Param = (Text, Text) @@ -51,10 +60,15 @@ type File = (Text, FileInfo ByteString) data ActionEnv = Env { getReq :: Request, getParams :: [Param], getBody :: ByteString, getFiles :: [File] } -newtype ActionM a = AM { runAM :: ErrorT ActionError (ReaderT ActionEnv (StateT Response IO)) a } +newtype ActionT m a = ActionT { runAM :: ErrorT ActionError (ReaderT ActionEnv (StateT Response m)) a } deriving ( Monad, MonadIO, Functor , MonadReader ActionEnv, MonadState Response, MonadError ActionError) +instance MonadTrans ActionT where + lift = ActionT . lift . lift . lift + +type ActionM a = ActionT IO a + data RoutePattern = Capture Text | Literal Text | Function (Request -> Maybe [Param]) diff --git a/scotty.cabal b/scotty.cabal index 98035045..d5cde489 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -71,6 +71,7 @@ Library data-default >= 0.5.0, http-types >= 0.7.3.0.1, mtl >= 2.1.2, + mmorph >= 1.0.0, regex-compat >= 0.95.1, resourcet >= 0.4.0.2, text >= 0.11.2.3, From f140b234b84024ee5e885e3cedf6a61029de68c8 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Sat, 24 Aug 2013 20:34:19 -0500 Subject: [PATCH 049/179] Use transResourceT instead of hoist, make scottyApp sig more specific. --- Web/Scotty.hs | 6 +++--- Web/Scotty/Route.hs | 9 ++++----- scotty.cabal | 1 - 3 files changed, 7 insertions(+), 9 deletions(-) diff --git a/Web/Scotty.hs b/Web/Scotty.hs index 9dcd652e..78612c1b 100644 --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -35,7 +35,7 @@ import Blaze.ByteString.Builder (fromByteString) import Control.Monad (when) import Control.Monad.State (execStateT, modify) -import Control.Monad.Morph (hoist) +import Control.Monad.Trans.Resource (transResourceT) import Data.Default (def) @@ -63,12 +63,12 @@ scottyOpts opts s = do -- run with any WAI handler. scottyApp :: (Monad m, Monad n) => (forall a. m a -> n a) -- run monad m into monad n, called once at ScottyT level - -> (forall a. m a -> IO a) -- run monad m into IO, called at each action + -> (m Response -> IO Response) -- run monad m into IO, called at each action -> ScottyT m () -> n Application scottyApp runM runToIO defs = do s <- runM $ execStateT (runS defs) def - return $ hoist runToIO . foldl (flip ($)) notFoundApp (routes s ++ middlewares s) + return $ transResourceT runToIO . foldl (flip ($)) notFoundApp (routes s ++ middlewares s) notFoundApp :: Monad m => Scotty.Application m notFoundApp _ = return $ ResponseBuilder status404 [("Content-Type","text/html")] diff --git a/Web/Scotty/Route.hs b/Web/Scotty/Route.hs index 97716edc..44f8de7c 100644 --- a/Web/Scotty/Route.hs +++ b/Web/Scotty/Route.hs @@ -7,8 +7,7 @@ module Web.Scotty.Route import Control.Arrow ((***)) import Control.Monad.Error import qualified Control.Monad.State as MS -import Control.Monad.Trans.Resource (ResourceT) -import Control.Monad.Morph (hoist) +import Control.Monad.Trans.Resource (ResourceT, transResourceT) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as BL @@ -117,13 +116,13 @@ parseRequestBody :: MonadIO m parseRequestBody b s r = case Parse.getRequestBodyType r of Nothing -> return ([], []) - Just rbt -> hoist liftIO $ liftM partitionEithers $ sourceLbs b $$ Parse.conduitRequestBody s rbt =$ consume + Just rbt -> transResourceT liftIO $ liftM partitionEithers $ sourceLbs b $$ Parse.conduitRequestBody s rbt =$ consume mkEnv :: MonadIO m => Request -> [Param] -> ResourceT m ActionEnv mkEnv req captures = do - b <- hoist liftIO $ liftM BL.fromChunks $ lazyConsume (requestBody req) + b <- transResourceT liftIO $ liftM BL.fromChunks $ lazyConsume (requestBody req) - (formparams, fs) <- hoist liftIO $ parseRequestBody b Parse.lbsBackEnd req + (formparams, fs) <- transResourceT liftIO $ parseRequestBody b Parse.lbsBackEnd req let convert (k, v) = (strictByteStringToLazyText k, strictByteStringToLazyText v) parameters = captures ++ map convert formparams ++ queryparams diff --git a/scotty.cabal b/scotty.cabal index d5cde489..98035045 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -71,7 +71,6 @@ Library data-default >= 0.5.0, http-types >= 0.7.3.0.1, mtl >= 2.1.2, - mmorph >= 1.0.0, regex-compat >= 0.95.1, resourcet >= 0.4.0.2, text >= 0.11.2.3, From e617c0b36072ec767cc74782a202e813b31cc9b3 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Sat, 24 Aug 2013 20:35:45 -0500 Subject: [PATCH 050/179] Version bump --- scotty.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scotty.cabal b/scotty.cabal index 98035045..6b589883 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -1,5 +1,5 @@ Name: scotty -Version: 0.4.6 +Version: 0.5.0 Synopsis: Haskell web framework inspired by Ruby's Sinatra, using WAI and Warp Homepage: https://github.com/ku-fpg/scotty Bug-reports: https://github.com/ku-fpg/scotty/issues From eb508764dd3b9e1780a13edd126558dddc1b762d Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Mon, 26 Aug 2013 18:40:43 -0500 Subject: [PATCH 051/179] Add support for HTTP PATCH --- Web/Scotty.hs | 2 +- Web/Scotty/Route.hs | 6 +++++- scotty.cabal | 2 +- 3 files changed, 7 insertions(+), 3 deletions(-) diff --git a/Web/Scotty.hs b/Web/Scotty.hs index 78612c1b..a35a4b4e 100644 --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -9,7 +9,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, addroute, matchAny, notFound + , middleware, get, post, put, delete, patch, addroute, matchAny, notFound -- ** Route Patterns , capture, regex, function, literal -- ** Accessing the Request, Captures, and Query Parameters diff --git a/Web/Scotty/Route.hs b/Web/Scotty/Route.hs index 44f8de7c..7e9a7bf0 100644 --- a/Web/Scotty/Route.hs +++ b/Web/Scotty/Route.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings, FlexibleInstances, ScopedTypeVariables #-} module Web.Scotty.Route - ( get, post, put, delete, addroute, matchAny, notFound, + ( get, post, put, delete, patch, addroute, matchAny, notFound, capture, regex, function, literal ) where @@ -47,6 +47,10 @@ put = addroute PUT delete :: MonadIO m => RoutePattern -> ActionT m () -> ScottyT m () delete = addroute DELETE +-- | patch = 'addroute' 'PATCH' +patch :: MonadIO m => RoutePattern -> ActionT m () -> ScottyT m () +patch = addroute PATCH + -- | Add a route that matches regardless of the HTTP verb. matchAny :: MonadIO m => RoutePattern -> ActionT m () -> ScottyT m () matchAny pattern action = mapM_ (\v -> addroute v pattern action) [minBound..maxBound] diff --git a/scotty.cabal b/scotty.cabal index 6b589883..7ff2dab2 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -69,7 +69,7 @@ Library case-insensitive >= 0.4.0.3, conduit >= 0.5.2.7, data-default >= 0.5.0, - http-types >= 0.7.3.0.1, + http-types >= 0.8.0, mtl >= 2.1.2, regex-compat >= 0.95.1, resourcet >= 0.4.0.2, From bd398460724bb77a17341c92ca71d1dfd2c39801 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Mon, 26 Aug 2013 19:00:28 -0500 Subject: [PATCH 052/179] Update README --- README | 11 ++--------- 1 file changed, 2 insertions(+), 9 deletions(-) diff --git a/README b/README index 9d7b6cbc..330f63cc 100644 --- a/README +++ b/README @@ -23,16 +23,9 @@ Scotty is the cheap and cheerful way to write RESTful, declarative web applicati See examples/basic.hs to see Scotty in action. (basic.hs needs the wai-extra package) > runghc examples/basic.hs - Setting phasers to stun... (ctrl-c to quit) + Setting phasers to stun... (port 3000) (ctrl-c to quit) (visit localhost:3000/somepath) -This design has been done in Haskell at least once before (to my knowledge) by -the miku framework. My issue with miku is that it uses the Hack2 interface -instead of WAI (they are analogous, but the latter seems to have more traction), -and that it is written using a custom prelude called Air (which appears to be an -attempt to turn Haskell into Ruby syntactically). I wanted something that -depends on relatively few other packages, with an API that fits on one page. - As for the name: Sinatra + Warp = Scotty. -Copyright (c) 2012 Andrew Farmer +Copyright (c) 2012-2013 Andrew Farmer From e4ed112a4bdf6f3ed76a6862e2daad9f2b09a1e7 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Mon, 26 Aug 2013 19:00:36 -0500 Subject: [PATCH 053/179] Remove no-longer-existing lambda-action example. --- examples/basic.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/examples/basic.hs b/examples/basic.hs index 9918c5f3..872f777e 100644 --- a/examples/basic.hs +++ b/examples/basic.hs @@ -85,9 +85,6 @@ main = scotty 3000 $ do b <- body text $ decodeUtf8 b - get "/lambda/:foo/:bar/:baz" $ \ foo bar baz -> do - text $ mconcat [foo, bar, baz] - get "/reqHeader" $ do agent <- reqHeader "User-Agent" text agent From 2ec4b6e9b12c87ee19a5f20d0d8b0cd75117f752 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Mon, 26 Aug 2013 20:04:37 -0500 Subject: [PATCH 054/179] Add Web.Scotty.Trans module, redefining Web.Scotty in terms of it. --- Web/Scotty.hs | 255 ++++++++++++++++++++++++++++++++++++++------ Web/Scotty/Trans.hs | 100 +++++++++++++++++ scotty.cabal | 2 + 3 files changed, 323 insertions(+), 34 deletions(-) create mode 100644 Web/Scotty/Trans.hs diff --git a/Web/Scotty.hs b/Web/Scotty.hs index a35a4b4e..9346bff1 100644 --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -24,58 +24,245 @@ module Web.Scotty -- ** Exceptions , raise, rescue, next -- * Parsing Parameters - , Param, Parsable(..), readEither + , Param, Trans.Parsable(..), Trans.readEither -- * Types , ScottyM, ActionM, RoutePattern, File - -- * Monad Transformers - , ScottyT, ActionT ) where -import Blaze.ByteString.Builder (fromByteString) +-- With the exception of this, everything else better just import types. +import qualified Web.Scotty.Trans as Trans -import Control.Monad (when) -import Control.Monad.State (execStateT, modify) -import Control.Monad.Trans.Resource (transResourceT) +import Blaze.ByteString.Builder (Builder) -import Data.Default (def) +import Data.Aeson (FromJSON, ToJSON) +import Data.ByteString.Lazy.Char8 (ByteString) +import Data.Conduit (Flush, ResourceT, Source) +import Data.Text.Lazy (Text) -import Network.HTTP.Types (status404) -import Network.Wai -import Network.Wai.Handler.Warp (Port, runSettings, settingsPort) +import Network.HTTP.Types (Status, StdMethod) +import Network.Wai (Application, Middleware, Request) +import Network.Wai.Handler.Warp (Port) -import Web.Scotty.Action -import Web.Scotty.Route -import Web.Scotty.Types hiding (Application, Middleware) -import qualified Web.Scotty.Types as Scotty +import Web.Scotty.Types (Param, ActionM, ScottyM, RoutePattern, Options, File) -- | Run a scotty application using the warp server. scotty :: Port -> ScottyM () -> IO () -scotty p = scottyOpts $ def { settings = (settings def) { settingsPort = p } } +scotty p = Trans.scottyT p id id -- | Run a scotty application using the warp server, passing extra options. scottyOpts :: Options -> ScottyM () -> IO () -scottyOpts opts s = do - when (verbose opts > 0) $ - putStrLn $ "Setting phasers to stun... (port " ++ show (settingsPort (settings opts)) ++ ") (ctrl-c to quit)" - runSettings (settings opts) =<< scottyApp id id s +scottyOpts opts = Trans.scottyOptsT opts id id -- | Turn a scotty application into a WAI 'Application', which can be -- run with any WAI handler. -scottyApp :: (Monad m, Monad n) - => (forall a. m a -> n a) -- run monad m into monad n, called once at ScottyT level - -> (m Response -> IO Response) -- run monad m into IO, called at each action - -> ScottyT m () - -> n Application -scottyApp runM runToIO defs = do - s <- runM $ execStateT (runS defs) def - return $ transResourceT runToIO . foldl (flip ($)) notFoundApp (routes s ++ middlewares s) - -notFoundApp :: Monad m => Scotty.Application m -notFoundApp _ = return $ ResponseBuilder status404 [("Content-Type","text/html")] - $ fromByteString "

404: File Not Found!

" +scottyApp :: ScottyM () -> IO Application +scottyApp = Trans.scottyAppT id id -- | Use given middleware. Middleware is nested such that the first declared -- is the outermost middleware (it has first dibs on the request and last action -- on the response). Every middleware is run on each request. -middleware :: Monad m => Scotty.Middleware m -> ScottyT m () -middleware = modify . addMiddleware +middleware :: Middleware -> ScottyM () +middleware = Trans.middleware + +-- | Throw an exception, which can be caught with 'rescue'. Uncaught exceptions +-- turn into HTTP 500 responses. +raise :: Text -> ActionM a +raise = Trans.raise + +-- | Abort execution of this action and continue pattern matching routes. +-- Like an exception, any code after 'next' is not executed. +-- +-- As an example, these two routes overlap. The only way the second one will +-- ever run is if the first one calls 'next'. +-- +-- > get "/foo/:number" $ do +-- > n <- param "number" +-- > unless (all isDigit n) $ next +-- > text "a number" +-- > +-- > get "/foo/:bar" $ do +-- > bar <- param "bar" +-- > text "not a number" +next :: ActionM a +next = Trans.next + +-- | Catch an exception thrown by 'raise'. +-- +-- > raise "just kidding" `rescue` (\msg -> text msg) +rescue :: ActionM a -> (Text -> ActionM a) -> ActionM a +rescue = Trans.rescue + +-- | Redirect to given URL. Like throwing an uncatchable exception. Any code after the call to redirect +-- will not be run. +-- +-- > redirect "http://www.google.com" +-- +-- OR +-- +-- > redirect "/foo/bar" +redirect :: Text -> ActionM a +redirect = Trans.redirect + +-- | Get the 'Request' object. +request :: ActionM Request +request = Trans.request + +-- | Get list of uploaded files. +files :: ActionM [File] +files = Trans.files + +-- | Get a request header. Header name is case-insensitive. +reqHeader :: Text -> ActionM Text +reqHeader = Trans.reqHeader + +-- | Get the request body. +body :: ActionM ByteString +body = Trans.body + +-- | Parse the request body as a JSON object and return it. Raises an exception if parse is unsuccessful. +jsonData :: FromJSON a => ActionM a +jsonData = Trans.jsonData + +-- | Get a parameter. First looks in captures, then form data, then query parameters. +-- +-- * Raises an exception which can be caught by 'rescue' if parameter is not found. +-- +-- * If parameter is found, but 'read' fails to parse to the correct type, 'next' is called. +-- This means captures are somewhat typed, in that a route won't match if a correctly typed +-- capture cannot be parsed. +param :: Trans.Parsable a => Text -> ActionM a +param = Trans.param + +-- | Get all parameters from capture, form and query (in that order). +params :: ActionM [Param] +params = Trans.params + +-- | Set the HTTP response status. Default is 200. +status :: Status -> ActionM () +status = Trans.status + +-- | Set one of the response headers. Will override any previously set value for that header. +-- Header names are case-insensitive. +header :: Text -> Text -> ActionM () +header = Trans.header + +-- | Set the body of the response to the given 'Text' value. Also sets \"Content-Type\" +-- header to \"text/plain\". +text :: Text -> ActionM () +text = Trans.text + +-- | Set the body of the response to the given 'Text' value. Also sets \"Content-Type\" +-- header to \"text/html\". +html :: Text -> ActionM () +html = Trans.html + +-- | Send a file as the response. Doesn't set the \"Content-Type\" header, so you probably +-- want to do that on your own with 'header'. +file :: FilePath -> ActionM () +file = Trans.file + +-- | Set the body of the response to the JSON encoding of the given value. Also sets \"Content-Type\" +-- header to \"application/json\". +json :: ToJSON a => a -> ActionM () +json = Trans.json + +-- | Set the body of the response to a Source. Doesn't set the +-- \"Content-Type\" header, so you probably want to do that on your +-- own with 'header'. +source :: Source (ResourceT IO) (Flush Builder) -> ActionM () +source = Trans.source + +-- | get = 'addroute' 'GET' +get :: RoutePattern -> ActionM () -> ScottyM () +get = Trans.get + +-- | post = 'addroute' 'POST' +post :: RoutePattern -> ActionM () -> ScottyM () +post = Trans.post + +-- | put = 'addroute' 'PUT' +put :: RoutePattern -> ActionM () -> ScottyM () +put = Trans.put + +-- | delete = 'addroute' 'DELETE' +delete :: RoutePattern -> ActionM () -> ScottyM () +delete = Trans.delete + +-- | patch = 'addroute' 'PATCH' +patch :: RoutePattern -> ActionM () -> ScottyM () +patch = Trans.patch + +-- | Add a route that matches regardless of the HTTP verb. +matchAny :: RoutePattern -> ActionM () -> ScottyM () +matchAny = Trans.matchAny + +-- | Specify an action to take if nothing else is found. Note: this _always_ matches, +-- so should generally be the last route specified. +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. +-- +-- > 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 'param'. +-- +-- > addroute GET "/foo/:bar" $ do +-- > v <- param "bar" +-- > text v +-- +-- >>> 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. +-- +-- > 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 +-- +regex :: String -> RoutePattern +regex = Trans.regex + +-- | Standard Sinatra-style route. Named captures are prepended with colons. +-- This is the default route type generated by OverloadedString routes. i.e. +-- +-- > get (capture "/foo/:bar") $ ... +-- +-- and +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > ... +-- > get "/foo/:bar" $ ... +-- +-- are equivalent. +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 +-- +function :: (Request -> Maybe [Param]) -> RoutePattern +function = Trans.function + +-- | Build a route that requires the requested path match exactly, without captures. +literal :: String -> RoutePattern +literal = Trans.literal diff --git a/Web/Scotty/Trans.hs b/Web/Scotty/Trans.hs new file mode 100644 index 00000000..024d8ec3 --- /dev/null +++ b/Web/Scotty/Trans.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE OverloadedStrings, RankNTypes #-} +-- | It should be noted that most of the code snippets below depend on the +-- OverloadedStrings language pragma. +-- +-- The functions in this module allow an arbitrary monad to be embedded +-- in Scotty's monad transformer stack in order that Scotty be combined +-- with other DSLs. +module Web.Scotty.Trans + ( -- * scotty-to-WAI + scottyT, scottyAppT, scottyOptsT, Options(..) + -- * Defining Middleware and Routes + -- + -- | '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, addroute, matchAny, notFound + -- ** Route Patterns + , capture, regex, function, literal + -- ** Accessing the Request, Captures, and Query Parameters + , request, reqHeader, body, param, params, jsonData, files + -- ** Modifying the Response and Redirecting + , status, header, redirect + -- ** Setting Response Body + -- + -- | 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, source + -- ** Exceptions + , raise, rescue, next + -- * Parsing Parameters + , Param, Parsable(..), readEither + -- * Types + , ScottyM, ActionM, RoutePattern, File + -- * Monad Transformers + , ScottyT, ActionT + ) where + +import Blaze.ByteString.Builder (fromByteString) + +import Control.Monad (when) +import Control.Monad.State (execStateT, modify) +import Control.Monad.Trans.Resource (transResourceT) +import Control.Monad.IO.Class + +import Data.Default (def) + +import Network.HTTP.Types (status404) +import Network.Wai +import Network.Wai.Handler.Warp (Port, runSettings, settingsPort) + +import Web.Scotty.Action +import Web.Scotty.Route +import Web.Scotty.Types hiding (Application, Middleware) +import qualified Web.Scotty.Types as Scotty + +-- | Run a scotty application using the warp server. +-- NB: 'scotty p' === 'scottyT p id id' +scottyT :: (Monad m, MonadIO n) + => Port + -> (forall a. m a -> n a) -- ^ Run monad 'm' into monad 'n', called once at 'ScottyT' level. + -> (m Response -> IO Response) -- ^ Run monad 'm' into 'IO', called at each action. + -> ScottyT m () + -> n () +scottyT p = scottyOptsT $ def { settings = (settings def) { settingsPort = p } } + +-- | Run a scotty application using the warp server, passing extra options. +-- NB: 'scottyOpts opts' === 'scottyOptsT opts id id' +scottyOptsT :: (Monad m, MonadIO n) + => Options + -> (forall a. m a -> n a) -- ^ Run monad 'm' into monad 'n', called once at 'ScottyT' level. + -> (m Response -> IO Response) -- ^ Run monad 'm' into 'IO', called at each action. + -> ScottyT m () + -> n () +scottyOptsT opts runM runActionToIO s = do + when (verbose opts > 0) $ + liftIO $ putStrLn $ "Setting phasers to stun... (port " ++ show (settingsPort (settings opts)) ++ ") (ctrl-c to quit)" + liftIO . runSettings (settings opts) =<< scottyAppT runM runActionToIO s + +-- | Turn a scotty application into a WAI 'Application', which can be +-- run with any WAI handler. +-- NB: 'scottyApp' === 'scottyAppT id id' +scottyAppT :: (Monad m, Monad n) + => (forall a. m a -> n a) -- ^ Run monad 'm' into monad 'n', called once at 'ScottyT' level. + -> (m Response -> IO Response) -- ^ Run monad 'm' into 'IO', called at each action. + -> ScottyT m () + -> n Application +scottyAppT runM runActionToIO defs = do + s <- runM $ execStateT (runS defs) def + return $ transResourceT runActionToIO + . foldl (flip ($)) notFoundApp (routes s ++ middlewares s) + +notFoundApp :: Monad m => Scotty.Application m +notFoundApp _ = return $ ResponseBuilder status404 [("Content-Type","text/html")] + $ fromByteString "

404: File Not Found!

" + +-- | Use given middleware. Middleware is nested such that the first declared +-- is the outermost middleware (it has first dibs on the request and last action +-- on the response). Every middleware is run on each request. +middleware :: Monad m => Scotty.Middleware m -> ScottyT m () +middleware = modify . addMiddleware diff --git a/scotty.cabal b/scotty.cabal index 7ff2dab2..28da987e 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -57,6 +57,7 @@ Extra-source-files: Library Exposed-modules: Web.Scotty + Web.Scotty.Trans other-modules: Web.Scotty.Action Web.Scotty.Route Web.Scotty.Types @@ -74,6 +75,7 @@ Library regex-compat >= 0.95.1, resourcet >= 0.4.0.2, text >= 0.11.2.3, + transformers >= 0.3.0.0, wai >= 1.3.0.1, wai-extra >= 1.3.0.3, warp >= 1.3.4.1 From cffeed2e77efa94906d3c5cad4f9aa14fa5da4ed Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Mon, 26 Aug 2013 20:32:44 -0500 Subject: [PATCH 055/179] Add example of using ScottyT to embed custom state monad. --- examples/globalstate.hs | 54 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 54 insertions(+) create mode 100644 examples/globalstate.hs diff --git a/examples/globalstate.hs b/examples/globalstate.hs new file mode 100644 index 00000000..b0c41269 --- /dev/null +++ b/examples/globalstate.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving #-} +-- | An example of embedding a custom state monad into +-- Scotty's transformer stack, using an MVar to synchronize +-- the state globally. +-- +-- Note: this example is somewhat simple, as our top level +-- is IO itself. The types of 'scottyT' and 'scottyAppT' are +-- general enough to allow a Scotty application to be +-- embedded into any MonadIO monad. +module Main where + +import Control.Concurrent.MVar +import Control.Monad.State hiding (get) + +import Data.Default +import Data.Text.Lazy (pack) + +import Web.Scotty.Trans + +newtype AppState = AppState { tickCount :: Int } + +instance Default AppState where + def = AppState 0 + +newtype WebM a = WebM { runWebM :: StateT AppState IO a } + deriving (Monad, MonadIO, MonadState AppState) + +webM :: MonadTrans t => WebM a -> t WebM a +webM = lift + +main = do + db <- newEmptyMVar + -- Note that 'runM' is only called once, at startup. + let runM m = do (r,s) <- runStateT (runWebM m) def + putMVar db s + return r + -- 'runActionToIO' is called once per action. + runActionToIO m = do s <- takeMVar db + (r,s') <- runStateT (runWebM m) s + putMVar db s' + return r + + scottyT 3000 runM runActionToIO $ do + get "/" $ do + c <- webM $ gets tickCount + text $ pack $ show c + + get "/plusone" $ do + webM $ modify $ \ st -> st { tickCount = tickCount st + 1 } + redirect "/" + + get "/plustwo" $ do + webM $ modify $ \ st -> st { tickCount = tickCount st + 2 } + redirect "/" From 5ab174d2b8095f6139b50987f6c82f7629b2501e Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Mon, 26 Aug 2013 20:59:27 -0500 Subject: [PATCH 056/179] Change reqHeader to return Maybe Text --- Web/Scotty.hs | 2 +- Web/Scotty/Action.hs | 6 ++---- examples/basic.hs | 2 +- 3 files changed, 4 insertions(+), 6 deletions(-) diff --git a/Web/Scotty.hs b/Web/Scotty.hs index 9346bff1..bd410af9 100644 --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -112,7 +112,7 @@ files :: ActionM [File] files = Trans.files -- | Get a request header. Header name is case-insensitive. -reqHeader :: Text -> ActionM Text +reqHeader :: Text -> ActionM (Maybe Text) reqHeader = Trans.reqHeader -- | Get the request body. diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs index 05889f37..5bb68414 100644 --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -99,12 +99,10 @@ files :: Monad m => ActionT m [File] files = liftM getFiles ask -- | Get a request header. Header name is case-insensitive. -reqHeader :: Monad m => T.Text -> ActionT m T.Text +reqHeader :: Monad m => T.Text -> ActionT m (Maybe T.Text) reqHeader k = do hs <- liftM requestHeaders request - maybe (raise (mconcat ["reqHeader: ", k, " not found"])) - (return . strictByteStringToLazyText) - (lookup (CI.mk (lazyTextToStrictByteString k)) hs) + return $ fmap strictByteStringToLazyText $ lookup (CI.mk (lazyTextToStrictByteString k)) hs -- | Get the request body. body :: Monad m => ActionT m BL.ByteString diff --git a/examples/basic.hs b/examples/basic.hs index 872f777e..f0eac48d 100644 --- a/examples/basic.hs +++ b/examples/basic.hs @@ -87,7 +87,7 @@ main = scotty 3000 $ do get "/reqHeader" $ do agent <- reqHeader "User-Agent" - text agent + maybe (raise "User-Agent header not found!") text agent {- If you don't want to use Warp as your webserver, you can use any WAI handler. From c5d68a4d3c4e4563b2d0b58ce5d2af51a1db1531 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Mon, 26 Aug 2013 21:08:44 -0500 Subject: [PATCH 057/179] Bring the 'raw' patch up to date with new transformers. --- Web/Scotty.hs | 5 +++++ Web/Scotty/Action.hs | 4 ++-- Web/Scotty/Trans.hs | 2 +- 3 files changed, 8 insertions(+), 3 deletions(-) diff --git a/Web/Scotty.hs b/Web/Scotty.hs index fe02d35e..42ad724a 100644 --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -172,6 +172,11 @@ json = Trans.json source :: Source (ResourceT IO) (Flush Builder) -> ActionM () source = Trans.source +-- | Set the body of the response to the given 'BL.ByteString' value. Doesn't set the +-- \"Content-Type\" header, so you probably want to do that on your own with 'header'. +raw :: ByteString -> ActionM () +raw = Trans.raw + -- | get = 'addroute' 'GET' get :: RoutePattern -> ActionM () -> ScottyM () get = Trans.get diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs index a9cb57c2..a86e4b9a 100644 --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -4,7 +4,7 @@ module Web.Scotty.Action , status, header, redirect , text, html, file, json, source, raw , raise, rescue, next - , ActionM, Parsable(..), readEither, Param, runAction + , Parsable(..), readEither, Param, runAction ) where import Blaze.ByteString.Builder (Builder, fromLazyByteString) @@ -218,5 +218,5 @@ source = MS.modify . setContent . ContentSource -- | Set the body of the response to the given 'BL.ByteString' value. Doesn't set the -- \"Content-Type\" header, so you probably want to do that on your -- own with 'header'. -raw :: BL.ByteString -> ActionM () +raw :: Monad m => BL.ByteString -> ActionT m () raw = MS.modify . setContent . ContentBuilder . fromLazyByteString diff --git a/Web/Scotty/Trans.hs b/Web/Scotty/Trans.hs index 024d8ec3..6e791ded 100644 --- a/Web/Scotty/Trans.hs +++ b/Web/Scotty/Trans.hs @@ -24,7 +24,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, source + , text, html, file, json, source, raw -- ** Exceptions , raise, rescue, next -- * Parsing Parameters From a8bc5ad34797cbc9b011cc3243e82a1217477216 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Thu, 29 Aug 2013 13:00:26 -0500 Subject: [PATCH 058/179] Accept traditional middleware, instead of Scotty's internal middleware type. --- Web/Scotty/Trans.hs | 14 +++++++------- Web/Scotty/Types.hs | 5 +++-- examples/globalstate.hs | 13 ++++++++----- 3 files changed, 18 insertions(+), 14 deletions(-) diff --git a/Web/Scotty/Trans.hs b/Web/Scotty/Trans.hs index 6e791ded..abdfd39a 100644 --- a/Web/Scotty/Trans.hs +++ b/Web/Scotty/Trans.hs @@ -56,20 +56,20 @@ import qualified Web.Scotty.Types as Scotty -- | Run a scotty application using the warp server. -- NB: 'scotty p' === 'scottyT p id id' scottyT :: (Monad m, MonadIO n) - => Port + => Port -> (forall a. m a -> n a) -- ^ Run monad 'm' into monad 'n', called once at 'ScottyT' level. -> (m Response -> IO Response) -- ^ Run monad 'm' into 'IO', called at each action. - -> ScottyT m () + -> ScottyT m () -> n () scottyT p = scottyOptsT $ def { settings = (settings def) { settingsPort = p } } -- | Run a scotty application using the warp server, passing extra options. -- NB: 'scottyOpts opts' === 'scottyOptsT opts id id' scottyOptsT :: (Monad m, MonadIO n) - => Options + => Options -> (forall a. m a -> n a) -- ^ Run monad 'm' into monad 'n', called once at 'ScottyT' level. -> (m Response -> IO Response) -- ^ Run monad 'm' into 'IO', called at each action. - -> ScottyT m () + -> ScottyT m () -> n () scottyOptsT opts runM runActionToIO s = do when (verbose opts > 0) $ @@ -86,8 +86,8 @@ scottyAppT :: (Monad m, Monad n) -> n Application scottyAppT runM runActionToIO defs = do s <- runM $ execStateT (runS defs) def - return $ transResourceT runActionToIO - . foldl (flip ($)) notFoundApp (routes s ++ middlewares s) + let rapp = transResourceT runActionToIO . foldl (flip ($)) notFoundApp (routes s) + return $ foldl (flip ($)) rapp (middlewares s) notFoundApp :: Monad m => Scotty.Application m notFoundApp _ = return $ ResponseBuilder status404 [("Content-Type","text/html")] @@ -96,5 +96,5 @@ notFoundApp _ = return $ ResponseBuilder status404 [("Content-Type","text/html") -- | Use given middleware. Middleware is nested such that the first declared -- is the outermost middleware (it has first dibs on the request and last action -- on the response). Every middleware is run on each request. -middleware :: Monad m => Scotty.Middleware m -> ScottyT m () +middleware :: Monad m => Middleware -> ScottyT m () middleware = modify . addMiddleware diff --git a/Web/Scotty/Types.hs b/Web/Scotty/Types.hs index bf8061b4..d8ecfedc 100644 --- a/Web/Scotty/Types.hs +++ b/Web/Scotty/Types.hs @@ -12,6 +12,7 @@ import Data.Text.Lazy (Text, pack) import qualified Data.Conduit as C import Network.Wai hiding (Middleware, Application) +import qualified Network.Wai as Wai import Network.Wai.Handler.Warp (Settings, defaultSettings) import Network.Wai.Parse (FileInfo) @@ -22,14 +23,14 @@ data Options = Options { verbose :: Int -- ^ 0 = silent, 1(def) = startup banner instance Default Options where def = Options 1 defaultSettings -data ScottyState m = ScottyState { middlewares :: [Middleware m] +data ScottyState m = ScottyState { middlewares :: [Wai.Middleware] , routes :: [Middleware m] } type Middleware m = Application m -> Application m type Application m = Request -> C.ResourceT m Response -addMiddleware :: Monad m => Middleware m -> ScottyState m -> ScottyState m +addMiddleware :: Wai.Middleware -> ScottyState m -> ScottyState m addMiddleware m s@(ScottyState {middlewares = ms}) = s { middlewares = m:ms } addRoute :: Monad m => Middleware m -> ScottyState m -> ScottyState m diff --git a/examples/globalstate.hs b/examples/globalstate.hs index b0c41269..160b5270 100644 --- a/examples/globalstate.hs +++ b/examples/globalstate.hs @@ -9,12 +9,14 @@ -- embedded into any MonadIO monad. module Main where -import Control.Concurrent.MVar +import Control.Concurrent.MVar import Control.Monad.State hiding (get) import Data.Default import Data.Text.Lazy (pack) +import Network.Wai.Middleware.RequestLogger + import Web.Scotty.Trans newtype AppState = AppState { tickCount :: Int } @@ -26,7 +28,7 @@ newtype WebM a = WebM { runWebM :: StateT AppState IO a } deriving (Monad, MonadIO, MonadState AppState) webM :: MonadTrans t => WebM a -> t WebM a -webM = lift +webM = lift main = do db <- newEmptyMVar @@ -38,9 +40,10 @@ main = do runActionToIO m = do s <- takeMVar db (r,s') <- runStateT (runWebM m) s putMVar db s' - return r - - scottyT 3000 runM runActionToIO $ do + return r + + scottyT 3000 runM runActionToIO $ do + middleware logStdoutDev get "/" $ do c <- webM $ gets tickCount text $ pack $ show c From 2b8a2edab8d093b8222e131e2ce12fa5a3a7ecd0 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Sun, 1 Sep 2013 23:56:38 -0500 Subject: [PATCH 059/179] Use the ReaderT/TVar solution for globalstate example rather than StateT/MVar. --- examples/globalstate.hs | 46 +++++++++++++++++++++++++++-------------- 1 file changed, 31 insertions(+), 15 deletions(-) diff --git a/examples/globalstate.hs b/examples/globalstate.hs index 160b5270..237fd380 100644 --- a/examples/globalstate.hs +++ b/examples/globalstate.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving #-} --- | An example of embedding a custom state monad into --- Scotty's transformer stack, using an MVar to synchronize --- the state globally. +-- An example of embedding a custom monad into +-- Scotty's transformer stack, using ReaderT to provide access +-- to a TVar containing global state. -- -- Note: this example is somewhat simple, as our top level -- is IO itself. The types of 'scottyT' and 'scottyAppT' are @@ -9,8 +9,8 @@ -- embedded into any MonadIO monad. module Main where -import Control.Concurrent.MVar -import Control.Monad.State hiding (get) +import Control.Concurrent.STM +import Control.Monad.Reader import Data.Default import Data.Text.Lazy (pack) @@ -24,23 +24,39 @@ newtype AppState = AppState { tickCount :: Int } instance Default AppState where def = AppState 0 -newtype WebM a = WebM { runWebM :: StateT AppState IO a } - deriving (Monad, MonadIO, MonadState AppState) +-- Why 'ReaderT (TVar AppState)' rather than 'StateT AppState'? +-- With a state transformer, 'runActionToIO' (below) would have +-- to provide the state to _every action_, and save the resulting +-- state, using an MVar. This means actions would be blocking, +-- effectively meaning only one request could be serviced at a time. +-- The 'ReaderT' solution means only actions that actually modify +-- the state need to block/retry. +-- +-- Also note: your monad must be an instance of 'MonadIO' for +-- Scotty to use it. +newtype WebM a = WebM { runWebM :: ReaderT (TVar AppState) IO a } + deriving (Monad, MonadIO, MonadReader (TVar AppState)) +-- Scotty's monads are layered on top of our custom monad. +-- We define this synonym for lift in order to be explicit +-- about when we are operating at the 'WebM' layer. webM :: MonadTrans t => WebM a -> t WebM a webM = lift +-- Some helpers to make this feel more like a state monad. +gets :: (AppState -> b) -> WebM b +gets f = ask >>= liftIO . readTVarIO >>= return . f + +modify :: (AppState -> AppState) -> WebM () +modify f = ask >>= liftIO . atomically . flip modifyTVar' f + +main :: IO () main = do - db <- newEmptyMVar + sync <- newTVarIO def -- Note that 'runM' is only called once, at startup. - let runM m = do (r,s) <- runStateT (runWebM m) def - putMVar db s - return r + let runM m = runReaderT (runWebM m) sync -- 'runActionToIO' is called once per action. - runActionToIO m = do s <- takeMVar db - (r,s') <- runStateT (runWebM m) s - putMVar db s' - return r + runActionToIO = runM scottyT 3000 runM runActionToIO $ do middleware logStdoutDev From a02a1fa357dfe00863f38b4a5996bc5e0270b432 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Fri, 13 Sep 2013 15:53:33 -0500 Subject: [PATCH 060/179] Add body to the error message when jsonData can't parse. --- Web/Scotty/Action.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs index a86e4b9a..de21ea68 100644 --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -19,9 +19,9 @@ import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.CaseInsensitive as CI import Data.Conduit (Flush, ResourceT, Source) import Data.Default (def) -import Data.Monoid (mconcat) +import Data.Monoid (mconcat, (<>)) import qualified Data.Text.Lazy as T -import Data.Text.Lazy.Encoding (encodeUtf8) +import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8) import Network.HTTP.Types import Network.Wai @@ -112,7 +112,7 @@ body = liftM getBody ask jsonData :: (A.FromJSON a, Monad m) => ActionT m a jsonData = do b <- body - maybe (raise "jsonData: no parse") return $ A.decode b + maybe (raise $ "jsonData - no parse: " <> decodeUtf8 b) return $ A.decode b -- | Get a parameter. First looks in captures, then form data, then query parameters. -- From f88ca8e3332792d63a0634bba61a106ae723c3e2 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Fri, 13 Sep 2013 15:54:48 -0500 Subject: [PATCH 061/179] Split 'header' into 'setHeader' and 'addHeader' --- Web/Scotty.hs | 10 +++++++--- Web/Scotty/Action.hs | 46 +++++++++++++++++++++++++++++++++----------- Web/Scotty/Trans.hs | 2 +- Web/Scotty/Util.hs | 34 ++++++++++++++++++-------------- 4 files changed, 63 insertions(+), 29 deletions(-) diff --git a/Web/Scotty.hs b/Web/Scotty.hs index 42ad724a..218675d7 100644 --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -15,7 +15,7 @@ module Web.Scotty -- ** Accessing the Request, Captures, and Query Parameters , request, reqHeader, body, param, params, jsonData, files -- ** Modifying the Response and Redirecting - , status, header, redirect + , status, addHeader, setHeader, redirect -- ** Setting Response Body -- -- | Note: only one of these should be present in any given route @@ -141,10 +141,14 @@ params = Trans.params status :: Status -> ActionM () status = Trans.status +-- | Add to the response headers. Header names are case-insensitive. +addHeader :: Text -> Text -> ActionM () +addHeader = Trans.addHeader + -- | Set one of the response headers. Will override any previously set value for that header. -- Header names are case-insensitive. -header :: Text -> Text -> ActionM () -header = Trans.header +setHeader :: Text -> Text -> ActionM () +setHeader = Trans.setHeader -- | Set the body of the response to the given 'Text' value. Also sets \"Content-Type\" -- header to \"text/plain\". diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs index de21ea68..f7da1a9c 100644 --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -1,10 +1,30 @@ {-# LANGUAGE OverloadedStrings #-} module Web.Scotty.Action - ( request, files, reqHeader, body, param, params, jsonData - , status, header, redirect - , text, html, file, json, source, raw - , raise, rescue, next - , Parsable(..), readEither, Param, runAction + ( addHeader + , body + , file + , files + , html + , json + , jsonData + , next + , param + , params + , raise + , raw + , readEither + , redirect + , reqHeader + , request + , rescue + , setHeader + , source + , status + , text + , Param + , Parsable(..) + -- private to Scotty + , runAction ) where import Blaze.ByteString.Builder (Builder, fromLazyByteString) @@ -43,7 +63,7 @@ runAction env action = do defaultHandler :: Monad m => ActionError -> ActionT m () defaultHandler (Redirect url) = do status status302 - header "Location" url + setHeader "Location" url defaultHandler (ActionError msg) = do status status500 html $ mconcat ["

500 Internal Server Error

", msg] @@ -178,23 +198,27 @@ readEither t = case [ x | (x,"") <- reads (T.unpack t) ] of status :: Monad m => Status -> ActionT m () status = MS.modify . setStatus +-- | Add to the response headers. Header names are case-insensitive. +addHeader :: Monad m => T.Text -> T.Text -> ActionT m () +addHeader k v = MS.modify $ setHeaderWith $ add (CI.mk $ lazyTextToStrictByteString k) (lazyTextToStrictByteString v) + -- | Set one of the response headers. Will override any previously set value for that header. -- Header names are case-insensitive. -header :: Monad m => T.Text -> T.Text -> ActionT m () -header k v = MS.modify $ setHeader (CI.mk $ lazyTextToStrictByteString k, lazyTextToStrictByteString v) +setHeader :: Monad m => T.Text -> T.Text -> ActionT m () +setHeader k v = MS.modify $ setHeaderWith $ replace (CI.mk $ lazyTextToStrictByteString k) (lazyTextToStrictByteString v) -- | Set the body of the response to the given 'T.Text' value. Also sets \"Content-Type\" -- header to \"text/plain\". text :: Monad m => T.Text -> ActionT m () text t = do - header "Content-Type" "text/plain" + setHeader "Content-Type" "text/plain" raw $ encodeUtf8 t -- | Set the body of the response to the given 'T.Text' value. Also sets \"Content-Type\" -- header to \"text/html\". html :: Monad m => T.Text -> ActionT m () html t = do - header "Content-Type" "text/html" + setHeader "Content-Type" "text/html" raw $ encodeUtf8 t -- | Send a file as the response. Doesn't set the \"Content-Type\" header, so you probably @@ -206,7 +230,7 @@ file = MS.modify . setContent . ContentFile -- header to \"application/json\". json :: (A.ToJSON a, Monad m) => a -> ActionT m () json v = do - header "Content-Type" "application/json" + setHeader "Content-Type" "application/json" raw $ A.encode v -- | Set the body of the response to a Source. Doesn't set the diff --git a/Web/Scotty/Trans.hs b/Web/Scotty/Trans.hs index abdfd39a..34bab9d3 100644 --- a/Web/Scotty/Trans.hs +++ b/Web/Scotty/Trans.hs @@ -19,7 +19,7 @@ module Web.Scotty.Trans -- ** Accessing the Request, Captures, and Query Parameters , request, reqHeader, body, param, params, jsonData, files -- ** Modifying the Response and Redirecting - , status, header, redirect + , status, addHeader, setHeader, redirect -- ** Setting Response Body -- -- | Note: only one of these should be present in any given route diff --git a/Web/Scotty/Util.hs b/Web/Scotty/Util.hs index 7f276ad5..75472723 100644 --- a/Web/Scotty/Util.hs +++ b/Web/Scotty/Util.hs @@ -1,8 +1,12 @@ module Web.Scotty.Util ( lazyTextToStrictByteString , strictByteStringToLazyText - , setContent, setHeader, setStatus + , setContent + , setHeaderWith + , setStatus , Content(..) + , replace + , add ) where import Network.Wai @@ -10,7 +14,6 @@ import Network.Wai import Network.HTTP.Types import Blaze.ByteString.Builder (Builder) -import Data.CaseInsensitive (CI) import Data.Conduit (Flush, Source, ResourceT) import Data.Default import Data.Monoid @@ -33,20 +36,20 @@ data Content = ContentBuilder Builder | ContentSource (Source (ResourceT IO) (Flush Builder)) setContent :: Content -> Response -> Response -setContent (ContentBuilder b) (ResponseBuilder s h _) = ResponseBuilder s h b -setContent (ContentBuilder b) (ResponseFile s h _ _) = ResponseBuilder s h b -setContent (ContentBuilder b) (ResponseSource s h _) = ResponseBuilder s h b -setContent (ContentFile f) (ResponseBuilder s h _) = ResponseFile s h f Nothing -setContent (ContentFile f) (ResponseFile s h _ _) = ResponseFile s h f Nothing -setContent (ContentFile f) (ResponseSource s h _) = ResponseFile s h f Nothing +setContent (ContentBuilder b) (ResponseBuilder s h _) = ResponseBuilder s h b +setContent (ContentBuilder b) (ResponseFile s h _ _) = ResponseBuilder s h b +setContent (ContentBuilder b) (ResponseSource s h _) = ResponseBuilder s h b +setContent (ContentFile f) (ResponseBuilder s h _) = ResponseFile s h f Nothing +setContent (ContentFile f) (ResponseFile s h _ _) = ResponseFile s h f Nothing +setContent (ContentFile f) (ResponseSource s h _) = ResponseFile s h f Nothing setContent (ContentSource src) (ResponseBuilder s h _) = ResponseSource s h src setContent (ContentSource src) (ResponseFile s h _ _) = ResponseSource s h src setContent (ContentSource src) (ResponseSource s h _) = ResponseSource s h src -setHeader :: (CI B.ByteString, B.ByteString) -> Response -> Response -setHeader (k,v) (ResponseBuilder s h b) = ResponseBuilder s (update h k v) b -setHeader (k,v) (ResponseFile s h f fp) = ResponseFile s (update h k v) f fp -setHeader (k,v) (ResponseSource s h cs) = ResponseSource s (update h k v) cs +setHeaderWith :: ([(HeaderName, B.ByteString)] -> [(HeaderName, B.ByteString)]) -> Response -> Response +setHeaderWith g (ResponseBuilder s h b) = ResponseBuilder s (g h) b +setHeaderWith g (ResponseFile s h f fp) = ResponseFile s (g h) f fp +setHeaderWith g (ResponseSource s h cs) = ResponseSource s (g h) cs setStatus :: Status -> Response -> Response setStatus s (ResponseBuilder _ h b) = ResponseBuilder s h b @@ -54,5 +57,8 @@ setStatus s (ResponseFile _ h f fp) = ResponseFile s h f fp setStatus s (ResponseSource _ h cs) = ResponseSource s h cs -- Note: we assume headers are not sensitive to order here (RFC 2616 specifies they are not) -update :: (Eq a) => [(a,b)] -> a -> b -> [(a,b)] -update m k v = (k,v) : filter ((/= k) . fst) m +replace :: (Eq a) => a -> b -> [(a,b)] -> [(a,b)] +replace k v m = add k v $ filter ((/= k) . fst) m + +add :: (Eq a) => a -> b -> [(a,b)] -> [(a,b)] +add k v m = (k,v):m From a1085699062153d11abda761a6dacc56b3c03385 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Fri, 13 Sep 2013 16:05:36 -0500 Subject: [PATCH 062/179] Remove clicker example --- examples/clicker.hs | 101 -------------------------------------------- 1 file changed, 101 deletions(-) delete mode 100644 examples/clicker.hs diff --git a/examples/clicker.hs b/examples/clicker.hs deleted file mode 100644 index 5a63213a..00000000 --- a/examples/clicker.hs +++ /dev/null @@ -1,101 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -import Control.Applicative -import Control.Concurrent.MVar -import Control.Monad.IO.Class (liftIO) - -import qualified Data.Map as M -import Data.Monoid -import qualified Data.Text.Lazy as T - -import Network.Wai -import Network.Wai.Middleware.RequestLogger -import Network.Wai.Middleware.Static - -import Numeric - -import qualified Text.Blaze.Html5 as H -import Text.Blaze.Html5 ((!)) -import Text.Blaze.Html5.Attributes as A -import Text.Blaze.Renderer.Text (renderHtml) - -import Web.ClientSession -import Web.Scotty -import Web.Scotty.Util - -import Debug.Trace - -mkFlash :: MVar (M.Map T.Text T.Text) -> (T.Text -> ActionM (), ActionM T.Text) -mkFlash mvar = ( \t -> liftIO $ modifyMVar_ mvar $ \m -> return $ M.insert "flash" t m - , do v <- liftIO $ modifyMVar mvar $ \m -> return (M.delete "flash" m, M.lookup "flash" m) - return $ maybe "" (\f -> "" <> f <> "") v - ) - -mkCookie :: IO (T.Text -> T.Text -> T.Text -> ActionM (), ActionM (Maybe T.Text)) -mkCookie = do - key <- getDefaultKey - return (\k v e -> do bs <- liftIO $ encryptIO key $ lazyTextToStrictByteString v - header "Set-Cookie" $ k <> "=" <> strictByteStringToLazyText bs <> "; " <> e - , do hs <- requestHeaders <$> request - return $ do c <- strictByteStringToLazyText <$> lookup "Cookie" hs - d <- snd <$> (safeHead $ filter ((=="sid") . fst) $ map (T.breakOn "=" . T.strip) $ T.splitOn ";" c) - fmap strictByteStringToLazyText $ decrypt key $ lazyTextToStrictByteString $ T.tail d - ) - -safeHead :: [a] -> Maybe a -safeHead [] = Nothing -safeHead (x:_) = Just x - -main :: IO () -main = do - session <- newMVar (M.empty :: M.Map T.Text T.Text) - sIds <- newMVar (0 :: Int) - let (flash, readFlash) = mkFlash session - - (setCookie, readCookie) <- mkCookie - - scotty 3000 $ do - middleware logStdoutDev - middleware $ staticRoot "static" - - get "/" $ do - fv <- readFlash - html $ wrapper $ do - H.preEscapedLazyText fv - H.form ! A.id "login" ! method "post" ! action "/login" $ do - H.h6 "Enter class key: " - H.input ! type_ "text" ! name "code" - H.br - H.input ! type_ "submit" - - post "/login" $ do - c <- param "code" - if c == ("password" :: T.Text) - then do sId <- liftIO $ modifyMVar sIds $ \i -> return (i+1,T.pack $ showHex i "") - setCookie "sid" sId "" - redirect "/student" - else do flash "login code incorrect!" - redirect "/" - - get "/logout" $ do - setCookie "sid" "" "; expires=" -- TODO: now() - flash "Logout successful!" - redirect "/" - - get "/student" $ do - sId <- maybe (do flash "not logged in!"; redirect "/") return =<< readCookie - html $ wrapper $ do - H.lazyText sId - H.a ! href "/logout" $ H.h6 "Log out" - - get "/professor" $ do - text "professor" - -wrapper :: H.Html -> T.Text -wrapper content' = renderHtml - $ H.html $ do - H.header $ do - -- the first two are libraries, the last is our custom code - H.script ! type_ "text/javascript" ! src "jquery.js" $ "" - H.script ! type_ "text/javascript" ! src "jquery-json.js" $ "" - H.script ! type_ "text/javascript" ! src "clicker.js" $ "" - H.body content' From de06b8f72081c75b29a8b1104d28e7836eec5ad7 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Fri, 13 Sep 2013 16:19:00 -0500 Subject: [PATCH 063/179] Update gzip example --- examples/gzip.hs | 24 +++++++++++++++--------- 1 file changed, 15 insertions(+), 9 deletions(-) diff --git a/examples/gzip.hs b/examples/gzip.hs index 18b8345c..6eb89f8b 100644 --- a/examples/gzip.hs +++ b/examples/gzip.hs @@ -1,13 +1,19 @@ {-# LANGUAGE OverloadedStrings #-} -import Web.Scotty import Network.Wai.Middleware.RequestLogger -import Network.Wai -import Network.Wai.Middleware.Gzip (gzip,def) -import qualified Data.Text.Lazy as T -import Data.Text.Lazy.Encoding (decodeUtf8) +import Network.Wai.Middleware.Gzip + +import Web.Scotty main :: IO () -main = scotty 6666 $ do - middleware $ gzip def - middleware logStdoutDev - get "/" $ text "It works" +main = scotty 3000 $ do + -- Note that files are not gzip'd by the default settings. + middleware $ gzip $ def { gzipFiles = GzipCompress } + middleware logStdoutDev + + -- gzip a normal response + get "/" $ text "It works" + + -- gzip a file response (note non-default gzip settings above) + get "/afile" $ do + setHeader "content-type" "text/plain" + file "gzip.hs" From d6f261d122a2bb3507967b0d92a268e0c6f20a09 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Wed, 18 Sep 2013 10:39:12 -0500 Subject: [PATCH 064/179] Markdown readme --- README | 31 ------------------------------- README.md | 34 ++++++++++++++++++++++++++++++++++ 2 files changed, 34 insertions(+), 31 deletions(-) delete mode 100644 README create mode 100644 README.md diff --git a/README b/README deleted file mode 100644 index 330f63cc..00000000 --- a/README +++ /dev/null @@ -1,31 +0,0 @@ -Scotty -====== - -A Haskell web framework inspired by Ruby's Sinatra, using WAI and Warp. - - {-# LANGUAGE OverloadedStrings #-} - import Web.Scotty - - import Data.Monoid (mconcat) - - main = scotty 3000 $ do - get "/:word" $ do - beam <- param "word" - html $ mconcat ["

Scotty, ", beam, " me up!

"] - -Scotty is the cheap and cheerful way to write RESTful, declarative web applications. - - * A page is as simple as defining the verb, url pattern, and Text content. - * It is template-language agnostic. Anything that returns a Text value will do. - * Conforms to WAI Application interface. - * Uses very fast Warp webserver by default. - -See examples/basic.hs to see Scotty in action. (basic.hs needs the wai-extra package) - - > runghc examples/basic.hs - Setting phasers to stun... (port 3000) (ctrl-c to quit) - (visit localhost:3000/somepath) - -As for the name: Sinatra + Warp = Scotty. - -Copyright (c) 2012-2013 Andrew Farmer diff --git a/README.md b/README.md new file mode 100644 index 00000000..db3cf888 --- /dev/null +++ b/README.md @@ -0,0 +1,34 @@ +# Scotty + +A Haskell web framework inspired by Ruby's Sinatra, using WAI and Warp. + +```haskell +{-# LANGUAGE OverloadedStrings #-} +import Web.Scotty + +import Data.Monoid (mconcat) + +main = scotty 3000 $ do +get "/:word" $ do + beam <- param "word" + html $ mconcat ["

Scotty, ", beam, " me up!

"] +``` + +Scotty is the cheap and cheerful way to write RESTful, declarative web applications. + +* A page is as simple as defining the verb, url pattern, and Text content. +* It is template-language agnostic. Anything that returns a Text value will do. +* Conforms to WAI Application interface. +* Uses very fast Warp webserver by default. + +See examples/basic.hs to see Scotty in action. (basic.hs needs the wai-extra package) + +```bash +> runghc examples/basic.hs +Setting phasers to stun... (port 3000) (ctrl-c to quit) +(visit localhost:3000/somepath) +``` + +As for the name: Sinatra + Warp = Scotty. + +Copyright (c) 2012-2013 Andrew Farmer From 2dfcf2ecf201a239a48f958fd55443c32a66be09 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Wed, 18 Sep 2013 11:01:26 -0500 Subject: [PATCH 065/179] Start tracking release notes. --- ReleaseNotes.md | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) create mode 100644 ReleaseNotes.md diff --git a/ReleaseNotes.md b/ReleaseNotes.md new file mode 100644 index 00000000..fad47b8e --- /dev/null +++ b/ReleaseNotes.md @@ -0,0 +1,28 @@ +## 0.5.0 + +* The Scotty monads (`ScottyM` and `ActionM`) are now monad transformers, + allowing Scotty applications to be embedded in arbitrary `MonadIO`s. + The old API continues to be exported from `Web.Scotty` where: + + type ScottyM = ScottyT IO + type ActionM = ActionT IO + + The new transformers are found in `Web.Scotty.Trans`. See the + `globalstate` example for use. Special thanks to Dan Frumin (co-dan) + for much of the legwork here. + +* Added support for HTTP PATCH method. + +* Removed lambda action syntax. This will return when we have a better + story for typesafe routes. + +* `reqHeader :: Text -> ActionM Text` ==> + `reqHeader :: Text -> ActionM (Maybe Text)` + +* New `raw` method to set body to a raw `ByteString` + +* Parse error thrown by `jsonData` now includes the body it couldn't parse. + +* `header` split into `setHeader` and `addHeader`. The former replaces + a response header (original behavior). The latter adds a header (useful + for multiple `Set-Cookie`s, for instance. From a4352d5086057a1ae3936647f1c64e74307f13cb Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Wed, 18 Sep 2013 11:07:44 -0500 Subject: [PATCH 066/179] Fix code block in ReleaseNotes.md --- ReleaseNotes.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ReleaseNotes.md b/ReleaseNotes.md index fad47b8e..45fa7607 100644 --- a/ReleaseNotes.md +++ b/ReleaseNotes.md @@ -4,8 +4,8 @@ allowing Scotty applications to be embedded in arbitrary `MonadIO`s. The old API continues to be exported from `Web.Scotty` where: - type ScottyM = ScottyT IO - type ActionM = ActionT IO + type ScottyM = ScottyT IO + type ActionM = ActionT IO The new transformers are found in `Web.Scotty.Trans`. See the `globalstate` example for use. Special thanks to Dan Frumin (co-dan) From dd3a8a7d65690c532fbff02fef2ada7f84c3f01a Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Wed, 18 Sep 2013 11:14:18 -0500 Subject: [PATCH 067/179] Update cabal file with extra-source-files --- scotty.cabal | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/scotty.cabal b/scotty.cabal index 522f6542..008bea32 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -46,11 +46,15 @@ Description: [Warp] Extra-source-files: - README + README.md + ReleaseNotes.md + examples/404.html examples/basic.hs + examples/globalstate.hs examples/gzip.hs examples/json.hs examples/options.hs + examples/upload.hs examples/urlshortener.hs examples/static/jquery.js examples/static/jquery-json.js From 076b3f64cd7cee40b4eba7cfcace7ba13c83c441 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Wed, 18 Sep 2013 11:21:09 -0500 Subject: [PATCH 068/179] Update copyright date in cabal file --- scotty.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scotty.cabal b/scotty.cabal index 008bea32..1f538ca2 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -7,7 +7,7 @@ License: BSD3 License-file: LICENSE Author: Andrew Farmer Maintainer: Andrew Farmer -Copyright: (c) 2012 Andrew Farmer +Copyright: (c) 2012-2013 Andrew Farmer Category: Web Stability: experimental Build-type: Simple From 0113c739f1de2ccd0ccced99125afbde931d5619 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Thu, 19 Sep 2013 22:39:03 -0500 Subject: [PATCH 069/179] Add paren --- ReleaseNotes.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ReleaseNotes.md b/ReleaseNotes.md index 45fa7607..2545c20d 100644 --- a/ReleaseNotes.md +++ b/ReleaseNotes.md @@ -25,4 +25,4 @@ * `header` split into `setHeader` and `addHeader`. The former replaces a response header (original behavior). The latter adds a header (useful - for multiple `Set-Cookie`s, for instance. + for multiple `Set-Cookie`s, for instance). From 60f3963cd0167b4d0d43e68bb2c59354e28d59d1 Mon Sep 17 00:00:00 2001 From: Abhinav Gupta Date: Sat, 5 Oct 2013 03:17:16 -0700 Subject: [PATCH 070/179] Added Parsable instance for strict Text. --- Web/Scotty/Action.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs index f7da1a9c..1d28a34c 100644 --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -40,6 +40,7 @@ import qualified Data.CaseInsensitive as CI import Data.Conduit (Flush, ResourceT, Source) import Data.Default (def) import Data.Monoid (mconcat, (<>)) +import qualified Data.Text as ST import qualified Data.Text.Lazy as T import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8) @@ -165,6 +166,7 @@ class Parsable a where -- No point using 'read' for Text, ByteString, Char, and String. instance Parsable T.Text where parseParam = Right +instance Parsable ST.Text where parseParam = Right . T.toStrict instance Parsable B.ByteString where parseParam = Right . lazyTextToStrictByteString -- | Overrides default 'parseParamList' to parse String. instance Parsable Char where From e5291b3a398c831d6ff7fe252ec0201a7023a015 Mon Sep 17 00:00:00 2001 From: Abhinav Gupta Date: Sat, 5 Oct 2013 03:18:29 -0700 Subject: [PATCH 071/179] Added Applicative instances for ScottyT and ActionT. --- Web/Scotty/Types.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/Web/Scotty/Types.hs b/Web/Scotty/Types.hs index d8ecfedc..7a957c24 100644 --- a/Web/Scotty/Types.hs +++ b/Web/Scotty/Types.hs @@ -1,6 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Web.Scotty.Types where +import Control.Applicative import Control.Monad.Error import Control.Monad.Reader import Control.Monad.State @@ -40,7 +41,8 @@ instance Default (ScottyState m) where def = ScottyState [] [] newtype ScottyT m a = ScottyT { runS :: StateT (ScottyState m) m a } - deriving (Monad, MonadIO, Functor, MonadState (ScottyState m)) + deriving (Monad, MonadIO, Functor, Applicative + , MonadState (ScottyState m)) instance MonadTrans ScottyT where lift = ScottyT . lift @@ -62,7 +64,7 @@ type File = (Text, FileInfo ByteString) data ActionEnv = Env { getReq :: Request, getParams :: [Param], getBody :: ByteString, getFiles :: [File] } newtype ActionT m a = ActionT { runAM :: ErrorT ActionError (ReaderT ActionEnv (StateT Response m)) a } - deriving ( Monad, MonadIO, Functor + deriving ( Monad, MonadIO, Functor, Applicative , MonadReader ActionEnv, MonadState Response, MonadError ActionError) instance MonadTrans ActionT where From 7d1375b16e249b1c56faa6ec521c096cfebbbe0c Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Thu, 17 Oct 2013 11:33:45 -0500 Subject: [PATCH 072/179] Only define ActionM and ScottyM in specialized module. --- Web/Scotty.hs | 3 +++ Web/Scotty/Trans.hs | 2 +- Web/Scotty/Types.hs | 4 ---- 3 files changed, 4 insertions(+), 5 deletions(-) diff --git a/Web/Scotty.hs b/Web/Scotty.hs index 218675d7..06b740bc 100644 --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -45,6 +45,9 @@ import Network.Wai.Handler.Warp (Port) import Web.Scotty.Types (Param, ActionM, ScottyM, RoutePattern, Options, File) +type ScottyM = ScottyT IO +type ActionM = ActionT IO + -- | Run a scotty application using the warp server. scotty :: Port -> ScottyM () -> IO () scotty p = Trans.scottyT p id id diff --git a/Web/Scotty/Trans.hs b/Web/Scotty/Trans.hs index 34bab9d3..2ec5dad6 100644 --- a/Web/Scotty/Trans.hs +++ b/Web/Scotty/Trans.hs @@ -30,7 +30,7 @@ module Web.Scotty.Trans -- * Parsing Parameters , Param, Parsable(..), readEither -- * Types - , ScottyM, ActionM, RoutePattern, File + , RoutePattern, File -- * Monad Transformers , ScottyT, ActionT ) where diff --git a/Web/Scotty/Types.hs b/Web/Scotty/Types.hs index 7a957c24..7bf91441 100644 --- a/Web/Scotty/Types.hs +++ b/Web/Scotty/Types.hs @@ -47,8 +47,6 @@ newtype ScottyT m a = ScottyT { runS :: StateT (ScottyState m) m a } instance MonadTrans ScottyT where lift = ScottyT . lift -type ScottyM a = ScottyT IO a - type Param = (Text, Text) data ActionError = Redirect Text @@ -70,8 +68,6 @@ newtype ActionT m a = ActionT { runAM :: ErrorT ActionError (ReaderT ActionEnv ( instance MonadTrans ActionT where lift = ActionT . lift . lift . lift -type ActionM a = ActionT IO a - data RoutePattern = Capture Text | Literal Text | Function (Request -> Maybe [Param]) From f09fd12f256b15a14ca8c636eae3866f2826dc43 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Thu, 17 Oct 2013 11:34:16 -0500 Subject: [PATCH 073/179] Add Helpers module --- Makefile | 5 +++++ Web/Scotty/Helpers.hs | 25 +++++++++++++++++++++++++ scotty.cabal | 1 + 3 files changed, 31 insertions(+) create mode 100644 Makefile create mode 100644 Web/Scotty/Helpers.hs diff --git a/Makefile b/Makefile new file mode 100644 index 00000000..28ae01c7 --- /dev/null +++ b/Makefile @@ -0,0 +1,5 @@ +boot: + cabal install --force-reinstalls + +ghci: + ghc --interactive -Wall Web/Scotty/Helpers.hs diff --git a/Web/Scotty/Helpers.hs b/Web/Scotty/Helpers.hs new file mode 100644 index 00000000..1df3c3d6 --- /dev/null +++ b/Web/Scotty/Helpers.hs @@ -0,0 +1,25 @@ +-- | Miscellaneous convenience functions. If you create a helper while using +-- Scotty that you find useful, feel free to submit a patch to this file. +module Web.Scotty.Helpers + ( addQueryString + ) where + +import Control.Monad + +import Data.Monoid +import qualified Data.Text.Lazy as T + +import qualified Network.Wai as Wai + +-- Note that we only import the monad transformer version, to force +-- us to be generic in the underyling monad. MonadIO constraints are fine. +import Web.Scotty.Trans +import Web.Scotty.Util + +-- | Append the query string from the current request to a 'T.Text' value. +-- Useful for repassing query parameters on redirect. +-- +-- > redirect =<< addQueryString "/foo" +-- +addQueryString :: Monad m => T.Text -> ActionT m T.Text +addQueryString r = liftM ((r <>) . strictByteStringToLazyText . Wai.rawQueryString) request diff --git a/scotty.cabal b/scotty.cabal index 1f538ca2..15d06eab 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -62,6 +62,7 @@ Extra-source-files: Library Exposed-modules: Web.Scotty + Web.Scotty.Helpers Web.Scotty.Trans other-modules: Web.Scotty.Action Web.Scotty.Route From e891ca977819d2f4753500f27a554760cd98521c Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Thu, 17 Oct 2013 11:39:25 -0500 Subject: [PATCH 074/179] Unbreak the build. :-P --- Web/Scotty.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Web/Scotty.hs b/Web/Scotty.hs index 06b740bc..c2697d2c 100644 --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -43,7 +43,7 @@ import Network.HTTP.Types (Status, StdMethod) import Network.Wai (Application, Middleware, Request) import Network.Wai.Handler.Warp (Port) -import Web.Scotty.Types (Param, ActionM, ScottyM, RoutePattern, Options, File) +import Web.Scotty.Types (ScottyT, ActionT, Param, RoutePattern, Options, File) type ScottyM = ScottyT IO type ActionM = ActionT IO From f38b9ccec65204230ab9f627498a850d08bb9ba3 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Mon, 28 Oct 2013 11:11:56 -0500 Subject: [PATCH 075/179] Add example of custom exceptions. --- examples/exceptions.hs | 61 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 61 insertions(+) create mode 100644 examples/exceptions.hs diff --git a/examples/exceptions.hs b/examples/exceptions.hs new file mode 100644 index 00000000..bf2dffa8 --- /dev/null +++ b/examples/exceptions.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, ScopedTypeVariables #-} +-- An example of embedding a custom monad into +-- Scotty's transformer stack, using ErrorT to provide +-- custom exceptions and a centralized exception handler. +module Main where + +import Control.Applicative +import Control.Monad.Error + +import Data.ByteString.Lazy hiding (pack) +import Data.ByteString.Lazy.Char8 (pack) +import Data.Monoid + +import Network.HTTP.Types +import Network.Wai.Middleware.RequestLogger +import Network.Wai + +import Web.Scotty.Trans + +newtype ExM a = ExM { runExM :: ErrorT Except IO a } + deriving (Functor, Applicative, Monad, MonadIO, MonadError Except) + +data Except = Forbidden | NotFound Int | Other ByteString + deriving (Show, Eq) + +instance Error Except where + strMsg = Other . pack + +handleEx :: Except -> IO Response +handleEx Forbidden = return $ plainResponse status403 "Scotty says no." +handleEx (NotFound i) = return $ plainResponse status404 (pack $ "Can't find " ++ show i ++ ".") +handleEx (Other bs) = return $ plainResponse status500 bs + +plainResponse :: Status -> ByteString -> Response +plainResponse st bs = responseLBS st [("Content-type","text/plain")] bs + +-- Scotty's monads are layered on top of our custom monad. +-- We define this helper to put our exceptions in the right layer. +throwEx :: MonadTrans t => Except -> t ExM () +throwEx = lift . throwError + +main :: IO () +main = do + let runM m = do + r <- runErrorT (runExM m) + either (\ ex -> fail $ "exception at startup: " ++ show ex) return r + -- 'runActionToIO' is called once per action. + runActionToIO m = runErrorT (runExM m) >>= either handleEx return + + scottyT 3000 runM runActionToIO $ do + middleware logStdoutDev + get "/" $ do + html $ mconcat ["Option 1 (Not Found)" + ,"
" + ,"Option 2 (Forbidden)" + ] + + get "/switch/:val" $ do + v :: Int <- param "val" + if even v then throwEx Forbidden else throwEx (NotFound v) + text "this will never be reached" From 3f58c595e0683eb678885017dd8f05c6c25d6f23 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Mon, 28 Oct 2013 11:31:28 -0500 Subject: [PATCH 076/179] Add examples/exceptions.hs to cabal file --- scotty.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/scotty.cabal b/scotty.cabal index 15d06eab..cd50cdb9 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -50,6 +50,7 @@ Extra-source-files: ReleaseNotes.md examples/404.html examples/basic.hs + examples/exceptions.hs examples/globalstate.hs examples/gzip.hs examples/json.hs From cbda1e69736a7b45a889da1108dbdb4134ffac91 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Wed, 4 Dec 2013 17:25:42 -0600 Subject: [PATCH 077/179] Some misc cleanup --- Web/Scotty/Types.hs | 4 ++-- examples/basic.hs | 2 +- examples/globalstate.hs | 4 ++-- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/Web/Scotty/Types.hs b/Web/Scotty/Types.hs index 7bf91441..196570d8 100644 --- a/Web/Scotty/Types.hs +++ b/Web/Scotty/Types.hs @@ -41,7 +41,7 @@ instance Default (ScottyState m) where def = ScottyState [] [] newtype ScottyT m a = ScottyT { runS :: StateT (ScottyState m) m a } - deriving (Monad, MonadIO, Functor, Applicative + deriving ( Functor, Applicative, Monad, MonadIO , MonadState (ScottyState m)) instance MonadTrans ScottyT where @@ -62,7 +62,7 @@ type File = (Text, FileInfo ByteString) data ActionEnv = Env { getReq :: Request, getParams :: [Param], getBody :: ByteString, getFiles :: [File] } newtype ActionT m a = ActionT { runAM :: ErrorT ActionError (ReaderT ActionEnv (StateT Response m)) a } - deriving ( Monad, MonadIO, Functor, Applicative + deriving ( Functor, Applicative, Monad, MonadIO , MonadReader ActionEnv, MonadState Response, MonadError ActionError) instance MonadTrans ActionT where diff --git a/examples/basic.hs b/examples/basic.hs index f0eac48d..47c3be31 100644 --- a/examples/basic.hs +++ b/examples/basic.hs @@ -38,7 +38,7 @@ main = scotty 3000 $ do -- You can set status and headers directly. get "/redirect-custom" $ do status status302 - header "Location" "http://www.google.com" + setHeader "Location" "http://www.google.com" -- note first arg to header is NOT case-sensitive -- redirects preempt execution diff --git a/examples/globalstate.hs b/examples/globalstate.hs index 237fd380..627cde6a 100644 --- a/examples/globalstate.hs +++ b/examples/globalstate.hs @@ -13,7 +13,7 @@ import Control.Concurrent.STM import Control.Monad.Reader import Data.Default -import Data.Text.Lazy (pack) +import Data.String import Network.Wai.Middleware.RequestLogger @@ -62,7 +62,7 @@ main = do middleware logStdoutDev get "/" $ do c <- webM $ gets tickCount - text $ pack $ show c + text $ fromString $ show c get "/plusone" $ do webM $ modify $ \ st -> st { tickCount = tickCount st + 1 } From 05b3772fb819043b3cb0eed5bb33e3abed22ff3c Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Thu, 5 Dec 2013 02:03:05 -0600 Subject: [PATCH 078/179] Overhaul for Wai 2.0, take away access to monad internals, beginning of custom error types. --- Web/Scotty.hs | 6 +-- Web/Scotty/Action.hs | 80 +++++++++++++++++++----------------- Web/Scotty/Helpers.hs | 2 +- Web/Scotty/Route.hs | 48 +++++++++++----------- Web/Scotty/Trans.hs | 7 ++-- Web/Scotty/Types.hs | 94 +++++++++++++++++++++++++++++-------------- Web/Scotty/Util.hs | 44 +++++++------------- scotty.cabal | 34 ++++++++-------- 8 files changed, 167 insertions(+), 148 deletions(-) diff --git a/Web/Scotty.hs b/Web/Scotty.hs index c2697d2c..9338df20 100644 --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -36,7 +36,7 @@ import Blaze.ByteString.Builder (Builder) import Data.Aeson (FromJSON, ToJSON) import Data.ByteString.Lazy.Char8 (ByteString) -import Data.Conduit (Flush, ResourceT, Source) +import Data.Conduit (Flush, Source) import Data.Text.Lazy (Text) import Network.HTTP.Types (Status, StdMethod) @@ -46,7 +46,7 @@ import Network.Wai.Handler.Warp (Port) import Web.Scotty.Types (ScottyT, ActionT, Param, RoutePattern, Options, File) type ScottyM = ScottyT IO -type ActionM = ActionT IO +type ActionM = ActionT () IO -- TODO: something besides () for default error type? -- | Run a scotty application using the warp server. scotty :: Port -> ScottyM () -> IO () @@ -176,7 +176,7 @@ json = Trans.json -- | Set the body of the response to a Source. Doesn't set the -- \"Content-Type\" header, so you probably want to do that on your -- own with 'header'. -source :: Source (ResourceT IO) (Flush Builder) -> ActionM () +source :: Source IO (Flush Builder) -> ActionM () source = Trans.source -- | Set the body of the response to the given 'BL.ByteString' value. Doesn't set the diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs index 1d28a34c..84d360c6 100644 --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -37,7 +37,7 @@ import qualified Data.Aeson as A import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.CaseInsensitive as CI -import Data.Conduit (Flush, ResourceT, Source) +import Data.Conduit (Flush, Source) import Data.Default (def) import Data.Monoid (mconcat, (<>)) import qualified Data.Text as ST @@ -52,28 +52,32 @@ import Web.Scotty.Util -- Nothing indicates route failed (due to Next) and pattern matching should continue. -- Just indicates a successful response. -runAction :: Monad m => ActionEnv -> ActionT m () -> m (Maybe Response) +runAction :: Monad m => ActionEnv -> ActionT e m () -> m (Maybe Response) runAction env action = do (e,r) <- flip MS.runStateT def $ flip runReaderT env $ runErrorT $ runAM $ action `catchError` defaultHandler - return $ either (const Nothing) (const $ Just r) e + return $ either (const Nothing) (const $ Just $ mkResponse r) e -defaultHandler :: Monad m => ActionError -> ActionT m () +defaultHandler :: Monad m => ActionError e -> ActionT e m () defaultHandler (Redirect url) = do status status302 setHeader "Location" url -defaultHandler (ActionError msg) = do +defaultHandler (StringError msg) = do status status500 html $ mconcat ["

500 Internal Server Error

", msg] defaultHandler Next = next +defaultHandler (ActionError _) = do + status status500 + html $ mconcat ["

500 Internal Server Error

" + ,"
Uncaught Custom Exception"] -- | Throw an exception, which can be caught with 'rescue'. Uncaught exceptions -- turn into HTTP 500 responses. -raise :: Monad m => T.Text -> ActionT m a -raise = throwError . ActionError +raise :: Monad m => T.Text -> ActionT e m a +raise = throwError . StringError -- | Abort execution of this action and continue pattern matching routes. -- Like an exception, any code after 'next' is not executed. @@ -89,15 +93,15 @@ raise = throwError . ActionError -- > get "/foo/:bar" $ do -- > bar <- param "bar" -- > text "not a number" -next :: Monad m => ActionT m a +next :: Monad m => ActionT e m a next = throwError Next -- | Catch an exception thrown by 'raise'. -- -- > raise "just kidding" `rescue` (\msg -> text msg) -rescue :: Monad m => ActionT m a -> (T.Text -> ActionT m a) -> ActionT m a +rescue :: Monad m => ActionT e m a -> (T.Text -> ActionT e m a) -> ActionT e m a rescue action handler = catchError action $ \e -> case e of - ActionError msg -> handler msg -- handle errors + StringError msg -> handler msg -- handle errors other -> throwError other -- rethrow redirects and nexts -- | Redirect to given URL. Like throwing an uncatchable exception. Any code after the call to redirect @@ -108,29 +112,29 @@ rescue action handler = catchError action $ \e -> case e of -- OR -- -- > redirect "/foo/bar" -redirect :: Monad m => T.Text -> ActionT m a +redirect :: Monad m => T.Text -> ActionT e m a redirect = throwError . Redirect -- | Get the 'Request' object. -request :: Monad m => ActionT m Request -request = liftM getReq ask +request :: Monad m => ActionT e m Request +request = ActionT $ liftM getReq ask -- | Get list of uploaded files. -files :: Monad m => ActionT m [File] -files = liftM getFiles ask +files :: Monad m => ActionT e m [File] +files = ActionT $ liftM getFiles ask -- | Get a request header. Header name is case-insensitive. -reqHeader :: Monad m => T.Text -> ActionT m (Maybe T.Text) +reqHeader :: Monad m => T.Text -> ActionT e m (Maybe T.Text) reqHeader k = do hs <- liftM requestHeaders request return $ fmap strictByteStringToLazyText $ lookup (CI.mk (lazyTextToStrictByteString k)) hs -- | Get the request body. -body :: Monad m => ActionT m BL.ByteString -body = liftM getBody ask +body :: Monad m => ActionT e m BL.ByteString +body = ActionT $ liftM getBody ask -- | Parse the request body as a JSON object and return it. Raises an exception if parse is unsuccessful. -jsonData :: (A.FromJSON a, Monad m) => ActionT m a +jsonData :: (A.FromJSON a, Monad m) => ActionT e m a jsonData = do b <- body maybe (raise $ "jsonData - no parse: " <> decodeUtf8 b) return $ A.decode b @@ -142,16 +146,16 @@ jsonData = do -- * If parameter is found, but 'read' fails to parse to the correct type, 'next' is called. -- This means captures are somewhat typed, in that a route won't match if a correctly typed -- capture cannot be parsed. -param :: (Parsable a, Monad m) => T.Text -> ActionT m a +param :: (Parsable a, Monad m) => T.Text -> ActionT e m a param k = do - val <- liftM (lookup k . getParams) ask + val <- ActionT $ liftM (lookup k . getParams) ask case val of Nothing -> raise $ mconcat ["Param: ", k, " not found!"] Just v -> either (const next) return $ parseParam v -- | Get all parameters from capture, form and query (in that order). -params :: Monad m => ActionT m [Param] -params = liftM getParams ask +params :: Monad m => ActionT e m [Param] +params = ActionT $ liftM getParams ask -- | Minimum implemention: 'parseParam' class Parsable a where @@ -197,40 +201,40 @@ readEither t = case [ x | (x,"") <- reads (T.unpack t) ] of _ -> Left "readEither: ambiguous parse" -- | Set the HTTP response status. Default is 200. -status :: Monad m => Status -> ActionT m () -status = MS.modify . setStatus +status :: Monad m => Status -> ActionT e m () +status = ActionT . MS.modify . setStatus -- | Add to the response headers. Header names are case-insensitive. -addHeader :: Monad m => T.Text -> T.Text -> ActionT m () -addHeader k v = MS.modify $ setHeaderWith $ add (CI.mk $ lazyTextToStrictByteString k) (lazyTextToStrictByteString v) +addHeader :: Monad m => T.Text -> T.Text -> ActionT e m () +addHeader k v = ActionT . MS.modify $ setHeaderWith $ add (CI.mk $ lazyTextToStrictByteString k) (lazyTextToStrictByteString v) -- | Set one of the response headers. Will override any previously set value for that header. -- Header names are case-insensitive. -setHeader :: Monad m => T.Text -> T.Text -> ActionT m () -setHeader k v = MS.modify $ setHeaderWith $ replace (CI.mk $ lazyTextToStrictByteString k) (lazyTextToStrictByteString v) +setHeader :: Monad m => T.Text -> T.Text -> ActionT e m () +setHeader k v = ActionT . MS.modify $ setHeaderWith $ replace (CI.mk $ lazyTextToStrictByteString k) (lazyTextToStrictByteString v) -- | Set the body of the response to the given 'T.Text' value. Also sets \"Content-Type\" -- header to \"text/plain\". -text :: Monad m => T.Text -> ActionT m () +text :: Monad m => T.Text -> ActionT e m () text t = do setHeader "Content-Type" "text/plain" raw $ encodeUtf8 t -- | Set the body of the response to the given 'T.Text' value. Also sets \"Content-Type\" -- header to \"text/html\". -html :: Monad m => T.Text -> ActionT m () +html :: Monad m => T.Text -> ActionT e m () html t = do setHeader "Content-Type" "text/html" raw $ encodeUtf8 t -- | Send a file as the response. Doesn't set the \"Content-Type\" header, so you probably -- want to do that on your own with 'header'. -file :: Monad m => FilePath -> ActionT m () -file = MS.modify . setContent . ContentFile +file :: Monad m => FilePath -> ActionT e m () +file = ActionT . MS.modify . setContent . ContentFile -- | Set the body of the response to the JSON encoding of the given value. Also sets \"Content-Type\" -- header to \"application/json\". -json :: (A.ToJSON a, Monad m) => a -> ActionT m () +json :: (A.ToJSON a, Monad m) => a -> ActionT e m () json v = do setHeader "Content-Type" "application/json" raw $ A.encode v @@ -238,11 +242,11 @@ json v = do -- | Set the body of the response to a Source. Doesn't set the -- \"Content-Type\" header, so you probably want to do that on your -- own with 'header'. -source :: Monad m => Source (ResourceT IO) (Flush Builder) -> ActionT m () -source = MS.modify . setContent . ContentSource +source :: Monad m => Source IO (Flush Builder) -> ActionT e m () +source = ActionT . MS.modify . setContent . ContentSource -- | Set the body of the response to the given 'BL.ByteString' value. Doesn't set the -- \"Content-Type\" header, so you probably want to do that on your -- own with 'header'. -raw :: Monad m => BL.ByteString -> ActionT m () -raw = MS.modify . setContent . ContentBuilder . fromLazyByteString +raw :: Monad m => BL.ByteString -> ActionT e m () +raw = ActionT . MS.modify . setContent . ContentBuilder . fromLazyByteString diff --git a/Web/Scotty/Helpers.hs b/Web/Scotty/Helpers.hs index 1df3c3d6..2e985a7f 100644 --- a/Web/Scotty/Helpers.hs +++ b/Web/Scotty/Helpers.hs @@ -21,5 +21,5 @@ import Web.Scotty.Util -- -- > redirect =<< addQueryString "/foo" -- -addQueryString :: Monad m => T.Text -> ActionT m T.Text +addQueryString :: Monad m => T.Text -> ActionT e m T.Text addQueryString r = liftM ((r <>) . strictByteStringToLazyText . Wai.rawQueryString) request diff --git a/Web/Scotty/Route.hs b/Web/Scotty/Route.hs index 7e9a7bf0..7c3d9621 100644 --- a/Web/Scotty/Route.hs +++ b/Web/Scotty/Route.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, FlexibleInstances, ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings, FlexibleContexts, FlexibleInstances, ScopedTypeVariables #-} module Web.Scotty.Route ( get, post, put, delete, patch, addroute, matchAny, notFound, capture, regex, function, literal @@ -7,7 +7,7 @@ module Web.Scotty.Route import Control.Arrow ((***)) import Control.Monad.Error import qualified Control.Monad.State as MS -import Control.Monad.Trans.Resource (ResourceT, transResourceT) +import Control.Monad.Trans.Resource (runResourceT, withInternalState, MonadBaseControl) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as BL @@ -32,32 +32,32 @@ import Web.Scotty.Types import Web.Scotty.Util -- | get = 'addroute' 'GET' -get :: MonadIO m => RoutePattern -> ActionT m () -> ScottyT m () +get :: MonadIO m => RoutePattern -> ActionT e m () -> ScottyT m () get = addroute GET -- | post = 'addroute' 'POST' -post :: MonadIO m => RoutePattern -> ActionT m () -> ScottyT m () +post :: MonadIO m => RoutePattern -> ActionT e m () -> ScottyT m () post = addroute POST -- | put = 'addroute' 'PUT' -put :: MonadIO m => RoutePattern -> ActionT m () -> ScottyT m () +put :: MonadIO m => RoutePattern -> ActionT e m () -> ScottyT m () put = addroute PUT -- | delete = 'addroute' 'DELETE' -delete :: MonadIO m => RoutePattern -> ActionT m () -> ScottyT m () +delete :: MonadIO m => RoutePattern -> ActionT e m () -> ScottyT m () delete = addroute DELETE -- | patch = 'addroute' 'PATCH' -patch :: MonadIO m => RoutePattern -> ActionT m () -> ScottyT m () +patch :: MonadIO m => RoutePattern -> ActionT e m () -> ScottyT m () patch = addroute PATCH -- | Add a route that matches regardless of the HTTP verb. -matchAny :: MonadIO m => RoutePattern -> ActionT m () -> ScottyT m () +matchAny :: MonadIO m => RoutePattern -> ActionT e m () -> ScottyT m () matchAny pattern action = mapM_ (\v -> addroute v pattern action) [minBound..maxBound] -- | Specify an action to take if nothing else is found. Note: this _always_ matches, -- so should generally be the last route specified. -notFound :: MonadIO m => ActionT m () -> ScottyT m () +notFound :: MonadIO m => ActionT e 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, @@ -74,29 +74,26 @@ notFound action = matchAny (Function (\req -> Just [("path", path req)])) (statu -- -- >>> curl http://localhost:3000/foo/something -- something -addroute :: MonadIO m => StdMethod -> RoutePattern -> ActionT m () -> ScottyT m () -addroute method pat action = MS.modify $ addRoute $ route method pat action +addroute :: MonadIO m => StdMethod -> RoutePattern -> ActionT e m () -> ScottyT m () +addroute method pat action = ScottyT $ MS.modify $ addRoute $ route method pat action -route :: MonadIO m => StdMethod -> RoutePattern -> ActionT m () -> Middleware m +route :: MonadIO m => StdMethod -> RoutePattern -> ActionT e m () -> Middleware m route method pat action app req = let tryNext = app req in if Right method == parseMethod (requestMethod req) then case matchRoute pat req of Just captures -> do env <- mkEnv req captures - res <- lift $ runAction env action + res <- runAction env action maybe tryNext return res Nothing -> tryNext else tryNext matchRoute :: RoutePattern -> Request -> Maybe [Param] - -matchRoute (Literal pat) req | pat == path req = Just [] - | otherwise = Nothing - +matchRoute (Literal pat) req | pat == path req = Just [] + | otherwise = Nothing matchRoute (Function fun) req = fun req - -matchRoute (Capture pat) req = go (T.split (=='/') pat) (T.split (=='/') $ path req) [] +matchRoute (Capture pat) req = go (T.split (=='/') pat) (T.split (=='/') $ path req) [] where go [] [] prs = Just prs -- request string and pattern match! go [] r prs | T.null (mconcat r) = Just prs -- in case request has trailing slashes | otherwise = Nothing -- request string is longer than pattern @@ -112,21 +109,22 @@ path :: Request -> T.Text path = T.fromStrict . TS.cons '/' . TS.intercalate "/" . pathInfo -- Stolen from wai-extra, modified to accept body as lazy ByteString -parseRequestBody :: MonadIO m +parseRequestBody :: (MonadBaseControl IO m, MonadIO m) => BL.ByteString -> Parse.BackEnd y -> Request - -> ResourceT m ([Parse.Param], [Parse.File y]) + -> m ([Parse.Param], [Parse.File y]) parseRequestBody b s r = case Parse.getRequestBodyType r of Nothing -> return ([], []) - Just rbt -> transResourceT liftIO $ liftM partitionEithers $ sourceLbs b $$ Parse.conduitRequestBody s rbt =$ consume + Just rbt -> runResourceT $ withInternalState $ \ is -> + liftIO $ liftM partitionEithers $ sourceLbs b $$ Parse.conduitRequestBody is s rbt =$ consume -mkEnv :: MonadIO m => Request -> [Param] -> ResourceT m ActionEnv +mkEnv :: MonadIO m => Request -> [Param] -> m ActionEnv mkEnv req captures = do - b <- transResourceT liftIO $ liftM BL.fromChunks $ lazyConsume (requestBody req) + b <- liftIO $ liftM BL.fromChunks $ lazyConsume (requestBody req) - (formparams, fs) <- transResourceT liftIO $ parseRequestBody b Parse.lbsBackEnd req + (formparams, fs) <- liftIO $ parseRequestBody b Parse.lbsBackEnd req let convert (k, v) = (strictByteStringToLazyText k, strictByteStringToLazyText v) parameters = captures ++ map convert formparams ++ queryparams diff --git a/Web/Scotty/Trans.hs b/Web/Scotty/Trans.hs index 2ec5dad6..f2c7d83c 100644 --- a/Web/Scotty/Trans.hs +++ b/Web/Scotty/Trans.hs @@ -39,7 +39,6 @@ import Blaze.ByteString.Builder (fromByteString) import Control.Monad (when) import Control.Monad.State (execStateT, modify) -import Control.Monad.Trans.Resource (transResourceT) import Control.Monad.IO.Class import Data.Default (def) @@ -86,15 +85,15 @@ scottyAppT :: (Monad m, Monad n) -> n Application scottyAppT runM runActionToIO defs = do s <- runM $ execStateT (runS defs) def - let rapp = transResourceT runActionToIO . foldl (flip ($)) notFoundApp (routes s) + let rapp = runActionToIO . foldl (flip ($)) notFoundApp (routes s) return $ foldl (flip ($)) rapp (middlewares s) notFoundApp :: Monad m => Scotty.Application m -notFoundApp _ = return $ ResponseBuilder status404 [("Content-Type","text/html")] +notFoundApp _ = return $ responseBuilder status404 [("Content-Type","text/html")] $ fromByteString "

404: File Not Found!

" -- | Use given middleware. Middleware is nested such that the first declared -- is the outermost middleware (it has first dibs on the request and last action -- on the response). Every middleware is run on each request. middleware :: Monad m => Middleware -> ScottyT m () -middleware = modify . addMiddleware +middleware = ScottyT . modify . addMiddleware diff --git a/Web/Scotty/Types.hs b/Web/Scotty/Types.hs index 196570d8..e528e0f2 100644 --- a/Web/Scotty/Types.hs +++ b/Web/Scotty/Types.hs @@ -1,22 +1,28 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, InstanceSigs, MultiParamTypeClasses #-} module Web.Scotty.Types where -import Control.Applicative -import Control.Monad.Error -import Control.Monad.Reader -import Control.Monad.State +import Blaze.ByteString.Builder (Builder) -import Data.ByteString.Lazy.Char8 (ByteString) -import Data.Default (Default, def) -import Data.String (IsString(..)) -import Data.Text.Lazy (Text, pack) +import Control.Applicative +import Control.Monad.Error +import Control.Monad.Reader +import Control.Monad.State +import Data.ByteString.Lazy.Char8 (ByteString) import qualified Data.Conduit as C -import Network.Wai hiding (Middleware, Application) +import Data.Default (Default, def) +import Data.Monoid (mempty) +import Data.String (IsString(..)) +import Data.Text.Lazy (Text, pack) + +import Network.HTTP.Types + +import Network.Wai hiding (Middleware, Application) import qualified Network.Wai as Wai -import Network.Wai.Handler.Warp (Settings, defaultSettings) -import Network.Wai.Parse (FileInfo) +import Network.Wai.Handler.Warp (Settings, defaultSettings) +import Network.Wai.Parse (FileInfo) +--------------------- Options ----------------------- data Options = Options { verbose :: Int -- ^ 0 = silent, 1(def) = startup banner , settings :: Settings -- ^ Warp 'Settings' } @@ -24,12 +30,17 @@ data Options = Options { verbose :: Int -- ^ 0 = silent, 1(def) = startup banner instance Default Options where def = Options 1 defaultSettings +----- Transformer Aware Applications/Middleware ----- +type Middleware m = Application m -> Application m +type Application m = Request -> m Response + +--------------- Scotty Applications ----------------- data ScottyState m = ScottyState { middlewares :: [Wai.Middleware] , routes :: [Middleware m] } -type Middleware m = Application m -> Application m -type Application m = Request -> C.ResourceT m Response +instance Default (ScottyState m) where + def = ScottyState [] [] addMiddleware :: Wai.Middleware -> ScottyState m -> ScottyState m addMiddleware m s@(ScottyState {middlewares = ms}) = s { middlewares = m:ms } @@ -37,39 +48,60 @@ addMiddleware m s@(ScottyState {middlewares = ms}) = s { middlewares = m:ms } addRoute :: Monad m => Middleware m -> ScottyState m -> ScottyState m addRoute r s@(ScottyState {routes = rs}) = s { routes = r:rs } -instance Default (ScottyState m) where - def = ScottyState [] [] - newtype ScottyT m a = ScottyT { runS :: StateT (ScottyState m) m a } - deriving ( Functor, Applicative, Monad, MonadIO - , MonadState (ScottyState m)) + deriving ( Functor, Applicative, Monad, MonadIO ) instance MonadTrans ScottyT where lift = ScottyT . lift +------------------ Scotty Actions ------------------- type Param = (Text, Text) -data ActionError = Redirect Text - | ActionError Text - | Next - deriving (Eq,Show) +data ActionError e = Redirect Text + | StringError Text + | Next + | ActionError e -instance Error ActionError where - strMsg = ActionError . pack +instance Error (ActionError e) where + strMsg = StringError . pack type File = (Text, FileInfo ByteString) -data ActionEnv = Env { getReq :: Request, getParams :: [Param], getBody :: ByteString, getFiles :: [File] } +data ActionEnv = Env { getReq :: Request + , getParams :: [Param] + , getBody :: ByteString + , getFiles :: [File] + } + +data Content = ContentBuilder Builder + | ContentFile FilePath + | ContentSource (C.Source IO (C.Flush Builder)) + +data ScottyResponse = SR { srStatus :: Status + , srHeaders :: ResponseHeaders + , srContent :: Content + } -newtype ActionT m a = ActionT { runAM :: ErrorT ActionError (ReaderT ActionEnv (StateT Response m)) a } - deriving ( Functor, Applicative, Monad, MonadIO - , MonadReader ActionEnv, MonadState Response, MonadError ActionError) +instance Default ScottyResponse where + def = SR status200 [] (ContentBuilder mempty) -instance MonadTrans ActionT where +newtype ActionT e m a = ActionT { runAM :: ErrorT (ActionError e) (ReaderT ActionEnv (StateT ScottyResponse m)) a } + deriving ( Functor, Applicative, Monad, MonadIO ) + +instance MonadTrans (ActionT e) where lift = ActionT . lift . lift . lift +instance Monad m => MonadError (ActionError e) (ActionT e m) where + throwError :: ActionError e -> ActionT e m a + throwError = ActionT . throwError + + catchError :: ActionT e m a -> (ActionError e -> ActionT e m a) -> ActionT e m a + catchError (ActionT m) f = ActionT (catchError m (runAM . f)) + +------------------ Scotty Routes -------------------- data RoutePattern = Capture Text | Literal Text | Function (Request -> Maybe [Param]) -instance IsString RoutePattern where fromString = Capture . pack +instance IsString RoutePattern where + fromString = Capture . pack diff --git a/Web/Scotty/Util.hs b/Web/Scotty/Util.hs index 75472723..968424ee 100644 --- a/Web/Scotty/Util.hs +++ b/Web/Scotty/Util.hs @@ -4,7 +4,7 @@ module Web.Scotty.Util , setContent , setHeaderWith , setStatus - , Content(..) + , mkResponse , replace , add ) where @@ -13,17 +13,11 @@ import Network.Wai import Network.HTTP.Types -import Blaze.ByteString.Builder (Builder) -import Data.Conduit (Flush, Source, ResourceT) -import Data.Default -import Data.Monoid - import qualified Data.ByteString as B import qualified Data.Text.Lazy as T import qualified Data.Text.Encoding as ES -instance Default Response where - def = ResponseBuilder status200 [] mempty +import Web.Scotty.Types lazyTextToStrictByteString :: T.Text -> B.ByteString lazyTextToStrictByteString = ES.encodeUtf8 . T.toStrict @@ -31,30 +25,22 @@ lazyTextToStrictByteString = ES.encodeUtf8 . T.toStrict strictByteStringToLazyText :: B.ByteString -> T.Text strictByteStringToLazyText = T.fromStrict . ES.decodeUtf8 -data Content = ContentBuilder Builder - | ContentFile FilePath - | ContentSource (Source (ResourceT IO) (Flush Builder)) +setContent :: Content -> ScottyResponse -> ScottyResponse +setContent c sr = sr { srContent = c } -setContent :: Content -> Response -> Response -setContent (ContentBuilder b) (ResponseBuilder s h _) = ResponseBuilder s h b -setContent (ContentBuilder b) (ResponseFile s h _ _) = ResponseBuilder s h b -setContent (ContentBuilder b) (ResponseSource s h _) = ResponseBuilder s h b -setContent (ContentFile f) (ResponseBuilder s h _) = ResponseFile s h f Nothing -setContent (ContentFile f) (ResponseFile s h _ _) = ResponseFile s h f Nothing -setContent (ContentFile f) (ResponseSource s h _) = ResponseFile s h f Nothing -setContent (ContentSource src) (ResponseBuilder s h _) = ResponseSource s h src -setContent (ContentSource src) (ResponseFile s h _ _) = ResponseSource s h src -setContent (ContentSource src) (ResponseSource s h _) = ResponseSource s h src +setHeaderWith :: ([(HeaderName, B.ByteString)] -> [(HeaderName, B.ByteString)]) -> ScottyResponse -> ScottyResponse +setHeaderWith f sr = sr { srHeaders = f (srHeaders sr) } -setHeaderWith :: ([(HeaderName, B.ByteString)] -> [(HeaderName, B.ByteString)]) -> Response -> Response -setHeaderWith g (ResponseBuilder s h b) = ResponseBuilder s (g h) b -setHeaderWith g (ResponseFile s h f fp) = ResponseFile s (g h) f fp -setHeaderWith g (ResponseSource s h cs) = ResponseSource s (g h) cs +setStatus :: Status -> ScottyResponse -> ScottyResponse +setStatus s sr = sr { srStatus = s } -setStatus :: Status -> Response -> Response -setStatus s (ResponseBuilder _ h b) = ResponseBuilder s h b -setStatus s (ResponseFile _ h f fp) = ResponseFile s h f fp -setStatus s (ResponseSource _ h cs) = ResponseSource s h cs +mkResponse :: ScottyResponse -> Response +mkResponse sr = case srContent sr of + ContentBuilder b -> responseBuilder s h b + ContentFile f -> responseFile s h f Nothing + ContentSource src -> responseSource s h src + where s = srStatus sr + h = srHeaders sr -- Note: we assume headers are not sensitive to order here (RFC 2616 specifies they are not) replace :: (Eq a) => a -> b -> [(a,b)] -> [(a,b)] diff --git a/scotty.cabal b/scotty.cabal index cd50cdb9..b8839005 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -1,5 +1,5 @@ Name: scotty -Version: 0.5.0 +Version: 0.6.0 Synopsis: Haskell web framework inspired by Ruby's Sinatra, using WAI and Warp Homepage: https://github.com/ku-fpg/scotty Bug-reports: https://github.com/ku-fpg/scotty/issues @@ -70,22 +70,22 @@ Library Web.Scotty.Types Web.Scotty.Util default-language: Haskell2010 - build-depends: aeson >= 0.6.0.2, - base >= 4.3.1 && < 5, - blaze-builder >= 0.3.1.0, - bytestring >= 0.9.1, - case-insensitive >= 0.4.0.3, - conduit >= 0.5.2.7, - data-default >= 0.5.0, - http-types >= 0.8.0, - mtl >= 2.1.2, - regex-compat >= 0.95.1, - resourcet >= 0.4.0.2, - text >= 0.11.2.3, - transformers >= 0.3.0.0, - wai >= 1.3.0.1, - wai-extra >= 1.3.0.3, - warp >= 1.3.4.1 + build-depends: aeson >= 0.6.2.1 && < 0.7, + base >= 4.3.1 && < 5, + blaze-builder >= 0.3.3.0 && < 0.4, + bytestring >= 0.10.0.2 && < 0.11, + case-insensitive >= 1.0.0.1 && < 1.2, + conduit >= 1.0.9.3 && < 1.1, + data-default >= 0.5.3 && < 0.6, + http-types >= 0.8.2 && < 0.9, + mtl >= 2.1.2 && < 2.2, + regex-compat >= 0.95.1 && < 0.96, + resourcet >= 0.4.7.2 && < 0.5, + text >= 0.11.3.1 && < 0.12, + transformers >= 0.3.0.0 && < 0.4, + wai >= 2.0.0 && < 2.1, + wai-extra >= 2.0.0.1 && < 2.1, + warp >= 2.0.0.1 && < 2.1 GHC-options: -Wall -fno-warn-orphans From 728422d7cf7399b2a114265bd92912e880223037 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Thu, 5 Dec 2013 02:14:41 -0600 Subject: [PATCH 079/179] Fix wai-middleware-static for Wai 2.0 --- Network/Wai/Middleware/Static.hs | 2 +- .../wai-middleware-static.cabal | 20 +++++++++---------- 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/Network/Wai/Middleware/Static.hs b/Network/Wai/Middleware/Static.hs index 3915022e..778d3f38 100644 --- a/Network/Wai/Middleware/Static.hs +++ b/Network/Wai/Middleware/Static.hs @@ -119,7 +119,7 @@ staticPolicy p app req = maybe (app req) (\fp -> do exists <- liftIO $ doesFileExist fp if exists - then return $ ResponseFile status200 + then return $ responseFile status200 [("Content-Type", getMimeType fp)] fp Nothing diff --git a/wai-middleware-static/wai-middleware-static.cabal b/wai-middleware-static/wai-middleware-static.cabal index a12820c4..8198ead8 100644 --- a/wai-middleware-static/wai-middleware-static.cabal +++ b/wai-middleware-static/wai-middleware-static.cabal @@ -1,5 +1,5 @@ Name: wai-middleware-static -Version: 0.3.2 +Version: 0.4.0 Synopsis: WAI middleware that intercepts requests to static files. Homepage: https://github.com/ku-fpg/scotty Bug-reports: https://github.com/ku-fpg/scotty/issues @@ -21,15 +21,15 @@ Description: Library Exposed-modules: Network.Wai.Middleware.Static default-language: Haskell2010 - Build-depends: base >= 4.3.1 && < 5, - bytestring >= 0.9.2.1, - containers >= 0.4, - directory >= 1.1, - http-types >= 0.6.8, - mtl >= 2.0.1, - filepath >= 1.3.0.0, - text >= 0.11.1, - wai >= 1.0.0 + Build-depends: base >= 4.6.0.1 && < 5, + bytestring >= 0.10.0.2 && < 0.11, + containers >= 0.5.0.0 && < 0.6, + directory >= 1.2.0.1 && < 1.3, + http-types >= 0.8.2 && < 0.9, + mtl >= 2.1.2 && < 2.2, + filepath >= 1.3.0.1 && < 1.4, + text >= 0.11.3.1 && < 0.12, + wai >= 2.0.0 && < 2.1 GHC-options: -Wall -fno-warn-orphans From ec082d1080d28bd113229ba3145472aa6794565f Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Thu, 5 Dec 2013 02:15:21 -0600 Subject: [PATCH 080/179] Add .keep file to examples/uploads directory for upload example. --- examples/uploads/.keep | 0 1 file changed, 0 insertions(+), 0 deletions(-) create mode 100644 examples/uploads/.keep diff --git a/examples/uploads/.keep b/examples/uploads/.keep new file mode 100644 index 00000000..e69de29b From dc98c2f3be79f4b64254e33f87619f76f330808d Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Thu, 5 Dec 2013 17:59:03 -0600 Subject: [PATCH 081/179] Allow for custom exception types, rather than just Text --- Web/Scotty.hs | 10 +++-- Web/Scotty/Action.hs | 80 ++++++++++++++++++------------------- Web/Scotty/Helpers.hs | 3 +- Web/Scotty/Route.hs | 26 ++++++------ Web/Scotty/Trans.hs | 14 ++++--- Web/Scotty/Types.hs | 59 ++++++++++++++++++---------- examples/exceptions.hs | 87 +++++++++++++++++++++-------------------- examples/globalstate.hs | 30 ++++++++------ 8 files changed, 172 insertions(+), 137 deletions(-) diff --git a/Web/Scotty.hs b/Web/Scotty.hs index 9338df20..465d3a57 100644 --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -22,7 +22,7 @@ module Web.Scotty -- definition, as they completely replace the current 'Response' body. , text, html, file, json, source, raw -- ** Exceptions - , raise, rescue, next + , raise, rescue, next, defaultHandler -- * Parsing Parameters , Param, Trans.Parsable(..), Trans.readEither -- * Types @@ -45,8 +45,8 @@ import Network.Wai.Handler.Warp (Port) import Web.Scotty.Types (ScottyT, ActionT, Param, RoutePattern, Options, File) -type ScottyM = ScottyT IO -type ActionM = ActionT () IO -- TODO: something besides () for default error type? +type ScottyM = ScottyT Text IO +type ActionM = ActionT Text IO -- | Run a scotty application using the warp server. scotty :: Port -> ScottyM () -> IO () @@ -61,6 +61,10 @@ scottyOpts opts = Trans.scottyOptsT opts id id scottyApp :: ScottyM () -> IO Application scottyApp = Trans.scottyAppT id id +-- | Global handler for uncaught exceptions. +defaultHandler :: (Text -> ActionM ()) -> ScottyM () +defaultHandler = Trans.defaultHandler + -- | Use given middleware. Middleware is nested such that the first declared -- is the outermost middleware (it has first dibs on the request and last action -- on the response). Every middleware is run on each request. diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs index 84d360c6..8090ba09 100644 --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, RankNTypes #-} module Web.Scotty.Action ( addHeader , body @@ -39,10 +39,10 @@ import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.CaseInsensitive as CI import Data.Conduit (Flush, Source) import Data.Default (def) -import Data.Monoid (mconcat, (<>)) +import Data.Monoid (mconcat) import qualified Data.Text as ST import qualified Data.Text.Lazy as T -import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8) +import Data.Text.Lazy.Encoding (encodeUtf8) import Network.HTTP.Types import Network.Wai @@ -52,32 +52,30 @@ import Web.Scotty.Util -- Nothing indicates route failed (due to Next) and pattern matching should continue. -- Just indicates a successful response. -runAction :: Monad m => ActionEnv -> ActionT e m () -> m (Maybe Response) -runAction env action = do +runAction :: (ScottyError e, Monad m) => ErrorHandler e m -> ActionEnv -> ActionT e m () -> m (Maybe Response) +runAction h env action = do (e,r) <- flip MS.runStateT def $ flip runReaderT env $ runErrorT $ runAM - $ action `catchError` defaultHandler + $ action `catchError` (defH h) return $ either (const Nothing) (const $ Just $ mkResponse r) e -defaultHandler :: Monad m => ActionError e -> ActionT e m () -defaultHandler (Redirect url) = do +-- | Default error handler for all actions. +defH :: (ScottyError e, Monad m) => ErrorHandler e m -> ActionError e -> ActionT e m () +defH _ (Redirect url) = do status status302 setHeader "Location" url -defaultHandler (StringError msg) = do +defH Nothing (ActionError e) = do status status500 - html $ mconcat ["

500 Internal Server Error

", msg] -defaultHandler Next = next -defaultHandler (ActionError _) = do - status status500 - html $ mconcat ["

500 Internal Server Error

" - ,"
Uncaught Custom Exception"] + html $ mconcat ["

500 Internal Server Error

", showError e] +defH h@(Just f) (ActionError e) = f e `catchError` (defH h) -- so handlers can throw exceptions themselves +defH _ Next = next -- | Throw an exception, which can be caught with 'rescue'. Uncaught exceptions -- turn into HTTP 500 responses. -raise :: Monad m => T.Text -> ActionT e m a -raise = throwError . StringError +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. @@ -93,16 +91,16 @@ raise = throwError . StringError -- > get "/foo/:bar" $ do -- > bar <- param "bar" -- > text "not a number" -next :: Monad m => ActionT e m a +next :: (ScottyError e, Monad m) => ActionT e m a next = throwError Next -- | Catch an exception thrown by 'raise'. -- -- > raise "just kidding" `rescue` (\msg -> text msg) -rescue :: Monad m => ActionT e m a -> (T.Text -> ActionT e m a) -> ActionT e m a -rescue action handler = catchError action $ \e -> case e of - StringError msg -> handler msg -- handle errors - other -> throwError other -- rethrow redirects and nexts +rescue :: (ScottyError e, Monad m) => ActionT e m a -> (e -> ActionT e m a) -> ActionT e m a +rescue action h = catchError action $ \e -> case e of + ActionError err -> h err -- handle errors + other -> throwError other -- rethrow internal error types -- | Redirect to given URL. Like throwing an uncatchable exception. Any code after the call to redirect -- will not be run. @@ -112,32 +110,32 @@ rescue action handler = catchError action $ \e -> case e of -- OR -- -- > redirect "/foo/bar" -redirect :: Monad m => T.Text -> ActionT e m a +redirect :: (ScottyError e, Monad m) => T.Text -> ActionT e m a redirect = throwError . Redirect -- | Get the 'Request' object. -request :: Monad m => ActionT e m Request +request :: (ScottyError e, Monad m) => ActionT e m Request request = ActionT $ liftM getReq ask -- | Get list of uploaded files. -files :: Monad m => ActionT e m [File] +files :: (ScottyError e, Monad m) => ActionT e m [File] files = ActionT $ liftM getFiles ask -- | Get a request header. Header name is case-insensitive. -reqHeader :: Monad m => T.Text -> ActionT e m (Maybe T.Text) +reqHeader :: (ScottyError e, Monad m) => T.Text -> ActionT e m (Maybe T.Text) reqHeader k = do hs <- liftM requestHeaders request return $ fmap strictByteStringToLazyText $ lookup (CI.mk (lazyTextToStrictByteString k)) hs -- | Get the request body. -body :: Monad m => ActionT e m BL.ByteString +body :: (ScottyError e, Monad m) => ActionT e m BL.ByteString body = ActionT $ liftM getBody ask -- | Parse the request body as a JSON object and return it. Raises an exception if parse is unsuccessful. -jsonData :: (A.FromJSON a, Monad m) => ActionT e m a +jsonData :: (A.FromJSON a, ScottyError e, Monad m) => ActionT e m a jsonData = do b <- body - maybe (raise $ "jsonData - no parse: " <> decodeUtf8 b) return $ A.decode b + maybe (raise $ stringError $ "jsonData - no parse: " ++ BL.unpack b) return $ A.decode b -- | Get a parameter. First looks in captures, then form data, then query parameters. -- @@ -146,15 +144,15 @@ jsonData = do -- * If parameter is found, but 'read' fails to parse to the correct type, 'next' is called. -- This means captures are somewhat typed, in that a route won't match if a correctly typed -- capture cannot be parsed. -param :: (Parsable a, Monad m) => T.Text -> ActionT e m a +param :: (Parsable a, ScottyError e, Monad m) => T.Text -> ActionT e m a param k = do val <- ActionT $ liftM (lookup k . getParams) ask case val of - Nothing -> raise $ mconcat ["Param: ", k, " not found!"] + Nothing -> raise $ stringError $ "Param: " ++ T.unpack k ++ " not found!" Just v -> either (const next) return $ parseParam v -- | Get all parameters from capture, form and query (in that order). -params :: Monad m => ActionT e m [Param] +params :: (ScottyError e, Monad m) => ActionT e m [Param] params = ActionT $ liftM getParams ask -- | Minimum implemention: 'parseParam' @@ -201,40 +199,40 @@ readEither t = case [ x | (x,"") <- reads (T.unpack t) ] of _ -> Left "readEither: ambiguous parse" -- | Set the HTTP response status. Default is 200. -status :: Monad m => Status -> ActionT e m () +status :: (ScottyError e, Monad m) => Status -> ActionT e m () status = ActionT . MS.modify . setStatus -- | Add to the response headers. Header names are case-insensitive. -addHeader :: Monad m => T.Text -> T.Text -> ActionT e m () +addHeader :: (ScottyError e, Monad m) => T.Text -> T.Text -> ActionT e m () addHeader k v = ActionT . MS.modify $ setHeaderWith $ add (CI.mk $ lazyTextToStrictByteString k) (lazyTextToStrictByteString v) -- | Set one of the response headers. Will override any previously set value for that header. -- Header names are case-insensitive. -setHeader :: Monad m => T.Text -> T.Text -> ActionT e m () +setHeader :: (ScottyError e, Monad m) => T.Text -> T.Text -> ActionT e m () setHeader k v = ActionT . MS.modify $ setHeaderWith $ replace (CI.mk $ lazyTextToStrictByteString k) (lazyTextToStrictByteString v) -- | Set the body of the response to the given 'T.Text' value. Also sets \"Content-Type\" -- header to \"text/plain\". -text :: Monad m => T.Text -> ActionT e m () +text :: (ScottyError e, Monad m) => T.Text -> ActionT e m () text t = do setHeader "Content-Type" "text/plain" raw $ encodeUtf8 t -- | Set the body of the response to the given 'T.Text' value. Also sets \"Content-Type\" -- header to \"text/html\". -html :: Monad m => T.Text -> ActionT e m () +html :: (ScottyError e, Monad m) => T.Text -> ActionT e m () html t = do setHeader "Content-Type" "text/html" raw $ encodeUtf8 t -- | Send a file as the response. Doesn't set the \"Content-Type\" header, so you probably -- want to do that on your own with 'header'. -file :: Monad m => FilePath -> ActionT e m () +file :: (ScottyError e, Monad m) => FilePath -> ActionT e m () file = ActionT . MS.modify . setContent . ContentFile -- | Set the body of the response to the JSON encoding of the given value. Also sets \"Content-Type\" -- header to \"application/json\". -json :: (A.ToJSON a, Monad m) => a -> ActionT e m () +json :: (A.ToJSON a, ScottyError e, Monad m) => a -> ActionT e m () json v = do setHeader "Content-Type" "application/json" raw $ A.encode v @@ -242,11 +240,11 @@ json v = do -- | Set the body of the response to a Source. Doesn't set the -- \"Content-Type\" header, so you probably want to do that on your -- own with 'header'. -source :: Monad m => Source IO (Flush Builder) -> ActionT e m () +source :: (ScottyError e, Monad m) => Source IO (Flush Builder) -> ActionT e m () source = ActionT . MS.modify . setContent . ContentSource -- | Set the body of the response to the given 'BL.ByteString' value. Doesn't set the -- \"Content-Type\" header, so you probably want to do that on your -- own with 'header'. -raw :: Monad m => BL.ByteString -> ActionT e m () +raw :: (ScottyError e, Monad m) => BL.ByteString -> ActionT e m () raw = ActionT . MS.modify . setContent . ContentBuilder . fromLazyByteString diff --git a/Web/Scotty/Helpers.hs b/Web/Scotty/Helpers.hs index 2e985a7f..4244f47a 100644 --- a/Web/Scotty/Helpers.hs +++ b/Web/Scotty/Helpers.hs @@ -13,6 +13,7 @@ import qualified Network.Wai as Wai -- Note that we only import the monad transformer version, to force -- us to be generic in the underyling monad. MonadIO constraints are fine. +import Web.Scotty.Types import Web.Scotty.Trans import Web.Scotty.Util @@ -21,5 +22,5 @@ import Web.Scotty.Util -- -- > redirect =<< addQueryString "/foo" -- -addQueryString :: Monad m => T.Text -> ActionT e m T.Text +addQueryString :: (ScottyError e, Monad m) => T.Text -> ActionT e m T.Text addQueryString r = liftM ((r <>) . strictByteStringToLazyText . Wai.rawQueryString) request diff --git a/Web/Scotty/Route.hs b/Web/Scotty/Route.hs index 7c3d9621..a74ffa61 100644 --- a/Web/Scotty/Route.hs +++ b/Web/Scotty/Route.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, FlexibleContexts, FlexibleInstances, ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings, FlexibleContexts, FlexibleInstances, RankNTypes #-} module Web.Scotty.Route ( get, post, put, delete, patch, addroute, matchAny, notFound, capture, regex, function, literal @@ -32,32 +32,32 @@ import Web.Scotty.Types import Web.Scotty.Util -- | get = 'addroute' 'GET' -get :: MonadIO m => RoutePattern -> ActionT e m () -> ScottyT m () +get :: (ScottyError e, MonadIO m) => RoutePattern -> ActionT e m () -> ScottyT e m () get = addroute GET -- | post = 'addroute' 'POST' -post :: MonadIO m => RoutePattern -> ActionT e m () -> ScottyT m () +post :: (ScottyError e, MonadIO m) => RoutePattern -> ActionT e m () -> ScottyT e m () post = addroute POST -- | put = 'addroute' 'PUT' -put :: MonadIO m => RoutePattern -> ActionT e m () -> ScottyT m () +put :: (ScottyError e, MonadIO m) => RoutePattern -> ActionT e m () -> ScottyT e m () put = addroute PUT -- | delete = 'addroute' 'DELETE' -delete :: MonadIO m => RoutePattern -> ActionT e m () -> ScottyT m () +delete :: (ScottyError e, MonadIO m) => RoutePattern -> ActionT e m () -> ScottyT e m () delete = addroute DELETE -- | patch = 'addroute' 'PATCH' -patch :: MonadIO m => RoutePattern -> ActionT e m () -> ScottyT m () +patch :: (ScottyError e, MonadIO m) => RoutePattern -> ActionT e m () -> ScottyT e m () patch = addroute PATCH -- | Add a route that matches regardless of the HTTP verb. -matchAny :: MonadIO m => RoutePattern -> ActionT e m () -> ScottyT m () +matchAny :: (ScottyError e, MonadIO m) => RoutePattern -> ActionT e m () -> ScottyT e m () matchAny pattern action = mapM_ (\v -> addroute v pattern action) [minBound..maxBound] -- | Specify an action to take if nothing else is found. Note: this _always_ matches, -- so should generally be the last route specified. -notFound :: MonadIO m => ActionT e m () -> ScottyT m () +notFound :: (ScottyError e, MonadIO m) => ActionT e m () -> ScottyT e 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, @@ -74,17 +74,17 @@ notFound action = matchAny (Function (\req -> Just [("path", path req)])) (statu -- -- >>> curl http://localhost:3000/foo/something -- something -addroute :: MonadIO m => StdMethod -> RoutePattern -> ActionT e m () -> ScottyT m () -addroute method pat action = ScottyT $ MS.modify $ addRoute $ route method pat action +addroute :: (ScottyError e, MonadIO m) => StdMethod -> RoutePattern -> ActionT e m () -> ScottyT e m () +addroute method pat action = ScottyT $ MS.modify $ \s -> addRoute (route (handler s) method pat action) s -route :: MonadIO m => StdMethod -> RoutePattern -> ActionT e m () -> Middleware m -route method pat action app req = +route :: (ScottyError e, MonadIO m) => ErrorHandler e m -> StdMethod -> RoutePattern -> ActionT e m () -> Middleware m +route h method pat action app req = let tryNext = app req in if Right method == parseMethod (requestMethod req) then case matchRoute pat req of Just captures -> do env <- mkEnv req captures - res <- runAction env action + res <- runAction h env action maybe tryNext return res Nothing -> tryNext else tryNext diff --git a/Web/Scotty/Trans.hs b/Web/Scotty/Trans.hs index f2c7d83c..3cd6162a 100644 --- a/Web/Scotty/Trans.hs +++ b/Web/Scotty/Trans.hs @@ -26,7 +26,7 @@ module Web.Scotty.Trans -- definition, as they completely replace the current 'Response' body. , text, html, file, json, source, raw -- ** Exceptions - , raise, rescue, next + , raise, rescue, next, defaultHandler, ScottyError(..) -- * Parsing Parameters , Param, Parsable(..), readEither -- * Types @@ -58,7 +58,7 @@ scottyT :: (Monad m, MonadIO n) => Port -> (forall a. m a -> n a) -- ^ Run monad 'm' into monad 'n', called once at 'ScottyT' level. -> (m Response -> IO Response) -- ^ Run monad 'm' into 'IO', called at each action. - -> ScottyT m () + -> ScottyT e m () -> n () scottyT p = scottyOptsT $ def { settings = (settings def) { settingsPort = p } } @@ -68,7 +68,7 @@ scottyOptsT :: (Monad m, MonadIO n) => Options -> (forall a. m a -> n a) -- ^ Run monad 'm' into monad 'n', called once at 'ScottyT' level. -> (m Response -> IO Response) -- ^ Run monad 'm' into 'IO', called at each action. - -> ScottyT m () + -> ScottyT e m () -> n () scottyOptsT opts runM runActionToIO s = do when (verbose opts > 0) $ @@ -81,7 +81,7 @@ scottyOptsT opts runM runActionToIO s = do scottyAppT :: (Monad m, Monad n) => (forall a. m a -> n a) -- ^ Run monad 'm' into monad 'n', called once at 'ScottyT' level. -> (m Response -> IO Response) -- ^ Run monad 'm' into 'IO', called at each action. - -> ScottyT m () + -> ScottyT e m () -> n Application scottyAppT runM runActionToIO defs = do s <- runM $ execStateT (runS defs) def @@ -92,8 +92,12 @@ notFoundApp :: Monad m => Scotty.Application m notFoundApp _ = return $ responseBuilder status404 [("Content-Type","text/html")] $ fromByteString "

404: File Not Found!

" +-- | Global handler for uncaught custom exceptions. +defaultHandler :: Monad m => (e -> ActionT e m ()) -> ScottyT e m () +defaultHandler f = ScottyT $ modify $ addHandler $ Just f + -- | Use given middleware. Middleware is nested such that the first declared -- is the outermost middleware (it has first dibs on the request and last action -- on the response). Every middleware is run on each request. -middleware :: Monad m => Middleware -> ScottyT m () +middleware :: Monad m => Middleware -> ScottyT e m () middleware = ScottyT . modify . addMiddleware diff --git a/Web/Scotty/Types.hs b/Web/Scotty/Types.hs index e528e0f2..e6511b52 100644 --- a/Web/Scotty/Types.hs +++ b/Web/Scotty/Types.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, InstanceSigs, MultiParamTypeClasses #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, MultiParamTypeClasses #-} module Web.Scotty.Types where import Blaze.ByteString.Builder (Builder) @@ -35,35 +35,56 @@ type Middleware m = Application m -> Application m type Application m = Request -> m Response --------------- Scotty Applications ----------------- -data ScottyState m = ScottyState { middlewares :: [Wai.Middleware] - , routes :: [Middleware m] - } +data ScottyState e m = + ScottyState { middlewares :: [Wai.Middleware] + , routes :: [Middleware m] + , handler :: ErrorHandler e m + } -instance Default (ScottyState m) where - def = ScottyState [] [] +instance Monad m => Default (ScottyState e m) where + def = ScottyState [] [] Nothing -addMiddleware :: Wai.Middleware -> ScottyState m -> ScottyState m +addMiddleware :: Wai.Middleware -> ScottyState e m -> ScottyState e m addMiddleware m s@(ScottyState {middlewares = ms}) = s { middlewares = m:ms } -addRoute :: Monad m => Middleware m -> ScottyState m -> ScottyState m +addRoute :: Monad m => Middleware m -> ScottyState e m -> ScottyState e m addRoute r s@(ScottyState {routes = rs}) = s { routes = r:rs } -newtype ScottyT m a = ScottyT { runS :: StateT (ScottyState m) m a } +addHandler :: ErrorHandler e m -> ScottyState e m -> ScottyState e m +addHandler h s = s { handler = h } + +newtype ScottyT e m a = ScottyT { runS :: StateT (ScottyState e m) m a } deriving ( Functor, Applicative, Monad, MonadIO ) -instance MonadTrans ScottyT where +instance MonadTrans (ScottyT e) where lift = ScottyT . lift ------------------- Scotty Actions ------------------- -type Param = (Text, Text) - +------------------ Scotty Errors -------------------- data ActionError e = Redirect Text - | StringError Text | Next | ActionError e -instance Error (ActionError e) where - strMsg = StringError . pack +class ScottyError e where + stringError :: String -> e + showError :: e -> Text + +instance ScottyError Text where + stringError = pack + showError = id + +instance ScottyError e => ScottyError (ActionError e) where + stringError = ActionError . stringError + showError (Redirect url) = url + showError Next = pack "Next" + showError (ActionError e) = showError e + +instance ScottyError e => Error (ActionError e) where + strMsg = stringError + +type ErrorHandler e m = Maybe (e -> ActionT e m ()) + +------------------ Scotty Actions ------------------- +type Param = (Text, Text) type File = (Text, FileInfo ByteString) @@ -88,14 +109,12 @@ instance Default ScottyResponse where newtype ActionT e m a = ActionT { runAM :: ErrorT (ActionError e) (ReaderT ActionEnv (StateT ScottyResponse m)) a } deriving ( Functor, Applicative, Monad, MonadIO ) -instance MonadTrans (ActionT e) where +instance ScottyError e => MonadTrans (ActionT e) where lift = ActionT . lift . lift . lift -instance Monad m => MonadError (ActionError e) (ActionT e m) where - throwError :: ActionError e -> ActionT e m a +instance (ScottyError e, Monad m) => MonadError (ActionError e) (ActionT e m) where throwError = ActionT . throwError - catchError :: ActionT e m a -> (ActionError e -> ActionT e m a) -> ActionT e m a catchError (ActionT m) f = ActionT (catchError m (runAM . f)) ------------------ Scotty Routes -------------------- diff --git a/examples/exceptions.hs b/examples/exceptions.hs index bf2dffa8..0ac9ed8c 100644 --- a/examples/exceptions.hs +++ b/examples/exceptions.hs @@ -1,61 +1,62 @@ {-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, ScopedTypeVariables #-} --- An example of embedding a custom monad into --- Scotty's transformer stack, using ErrorT to provide --- custom exceptions and a centralized exception handler. module Main where import Control.Applicative import Control.Monad.Error -import Data.ByteString.Lazy hiding (pack) -import Data.ByteString.Lazy.Char8 (pack) import Data.Monoid +import Data.String (fromString) import Network.HTTP.Types import Network.Wai.Middleware.RequestLogger import Network.Wai -import Web.Scotty.Trans +import System.Random -newtype ExM a = ExM { runExM :: ErrorT Except IO a } - deriving (Functor, Applicative, Monad, MonadIO, MonadError Except) +import Web.Scotty.Trans -data Except = Forbidden | NotFound Int | Other ByteString +-- Define a custom exception type. +data Except = Forbidden | NotFound Int | StringEx String deriving (Show, Eq) -instance Error Except where - strMsg = Other . pack - -handleEx :: Except -> IO Response -handleEx Forbidden = return $ plainResponse status403 "Scotty says no." -handleEx (NotFound i) = return $ plainResponse status404 (pack $ "Can't find " ++ show i ++ ".") -handleEx (Other bs) = return $ plainResponse status500 bs - -plainResponse :: Status -> ByteString -> Response -plainResponse st bs = responseLBS st [("Content-type","text/plain")] bs - --- Scotty's monads are layered on top of our custom monad. --- We define this helper to put our exceptions in the right layer. -throwEx :: MonadTrans t => Except -> t ExM () -throwEx = lift . throwError +-- The type must be an instance of 'ScottyError'. +-- 'ScottyError' is essentially a combination of 'Error' and 'Show'. +instance ScottyError Except where + stringError = StringEx + showError = fromString . show + +-- Handler for uncaught exceptions. +handleEx :: Monad m => Except -> ActionT Except m () +handleEx Forbidden = do + status status403 + html "

Scotty Says No

" +handleEx (NotFound i) = do + status status404 + html $ fromString $ "

Can't find " ++ show i ++ ".

" main :: IO () -main = do - let runM m = do - r <- runErrorT (runExM m) - either (\ ex -> fail $ "exception at startup: " ++ show ex) return r - -- 'runActionToIO' is called once per action. - runActionToIO m = runErrorT (runExM m) >>= either handleEx return - - scottyT 3000 runM runActionToIO $ do - middleware logStdoutDev - get "/" $ do - html $ mconcat ["Option 1 (Not Found)" - ,"
" - ,"Option 2 (Forbidden)" - ] - - get "/switch/:val" $ do - v :: Int <- param "val" - if even v then throwEx Forbidden else throwEx (NotFound v) - text "this will never be reached" +main = scottyT 3000 id id $ do -- note, we aren't using any additional transformer layers + -- so we can just use 'id' for the runners. + middleware logStdoutDev + + defaultHandler handleEx -- define what to do with uncaught exceptions + + get "/" $ do + html $ mconcat ["Option 1 (Not Found)" + ,"
" + ,"Option 2 (Forbidden)" + ,"
" + ,"Option 3 (Random)" + ] + + get "/switch/:val" $ do + v <- param "val" + if even v then raise Forbidden else raise (NotFound v) + text "this will never be reached" + + get "/random" $ do + rBool <- liftIO randomIO + i <- liftIO randomIO + let catchOne Forbidden = html "

Forbidden was randomly thrown, but we caught it." + catchOne other = raise other + raise (if rBool then Forbidden else NotFound i) `rescue` catchOne diff --git a/examples/globalstate.hs b/examples/globalstate.hs index 627cde6a..fa6170e3 100644 --- a/examples/globalstate.hs +++ b/examples/globalstate.hs @@ -14,6 +14,7 @@ import Control.Monad.Reader import Data.Default import Data.String +import Data.Text.Lazy (Text) import Network.Wai.Middleware.RequestLogger @@ -58,16 +59,23 @@ main = do -- 'runActionToIO' is called once per action. runActionToIO = runM - scottyT 3000 runM runActionToIO $ do - middleware logStdoutDev - get "/" $ do - c <- webM $ gets tickCount - text $ fromString $ show c + scottyT 3000 runM runActionToIO app - get "/plusone" $ do - webM $ modify $ \ st -> st { tickCount = tickCount st + 1 } - redirect "/" +-- This app doesn't use raise/rescue, so the exception +-- type is ambiguous. We can fix it by putting a type +-- annotation just about anywhere. In this case, we'll +-- just do it on the entire app. +app :: ScottyT Text WebM () +app = do + middleware logStdoutDev + get "/" $ do + c <- webM $ gets tickCount + text $ fromString $ show c - get "/plustwo" $ do - webM $ modify $ \ st -> st { tickCount = tickCount st + 2 } - redirect "/" + get "/plusone" $ do + webM $ modify $ \ st -> st { tickCount = tickCount st + 1 } + redirect "/" + + get "/plustwo" $ do + webM $ modify $ \ st -> st { tickCount = tickCount st + 2 } + redirect "/" From 95fb98633a1fdc0b4a56ca9fbfa28df826d556b3 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Thu, 5 Dec 2013 23:45:41 -0600 Subject: [PATCH 082/179] Edit repo URLs --- scotty.cabal | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/scotty.cabal b/scotty.cabal index b8839005..68af40bb 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -1,8 +1,8 @@ Name: scotty Version: 0.6.0 Synopsis: Haskell web framework inspired by Ruby's Sinatra, using WAI and Warp -Homepage: https://github.com/ku-fpg/scotty -Bug-reports: https://github.com/ku-fpg/scotty/issues +Homepage: https://github.com/scotty-web/scotty +Bug-reports: https://github.com/scotty-web/scotty/issues License: BSD3 License-file: LICENSE Author: Andrew Farmer @@ -91,4 +91,4 @@ Library source-repository head type: git - location: git://github.com/ku-fpg/scotty.git + location: git://github.com/scotty-web/scotty.git From 5d7d92893ad91c6856d4f6b600778bf444cf7b28 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Fri, 6 Dec 2013 00:09:41 -0600 Subject: [PATCH 083/179] Cleanup of examples, and new cookie example. --- examples/cookies.hs | 62 ++++++++++++++++++++++++++++++++++++++ examples/json.hs | 66 ----------------------------------------- examples/static/json.js | 59 ------------------------------------ examples/upload.hs | 2 +- 4 files changed, 63 insertions(+), 126 deletions(-) create mode 100644 examples/cookies.hs delete mode 100644 examples/json.hs delete mode 100644 examples/static/json.js diff --git a/examples/cookies.hs b/examples/cookies.hs new file mode 100644 index 00000000..2b626152 --- /dev/null +++ b/examples/cookies.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE OverloadedStrings #-} +-- This examples requires you to: cabal install cookie +-- and: cabal install blaze-html +import Control.Monad (forM_) +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as T +import qualified Data.Text.Lazy.Encoding as T +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import qualified Blaze.ByteString.Builder as B + +import qualified Text.Blaze.Html5 as H +import Text.Blaze.Html5.Attributes +import Text.Blaze.Html.Renderer.Text (renderHtml) +import Web.Scotty +import Web.Cookie + +makeCookie :: BS.ByteString -> BS.ByteString -> SetCookie +makeCookie n v = def { setCookieName = n, setCookieValue = v } + +renderSetCookie' :: SetCookie -> Text +renderSetCookie' = T.decodeUtf8 . B.toLazyByteString . renderSetCookie + +setCookie :: BS.ByteString -> BS.ByteString -> ActionM () +setCookie n v = setHeader "Set-Cookie" (renderSetCookie' (makeCookie n v)) + +getCookies :: ActionM (Maybe CookiesText) +getCookies = + fmap (fmap (parseCookiesText . lazyToStrict . T.encodeUtf8)) $ + reqHeader "Cookie" + where + lazyToStrict = BS.concat . BSL.toChunks + +renderCookiesTable :: CookiesText -> H.Html +renderCookiesTable cs = + H.table $ do + H.tr $ do + H.th "name" + H.th "value" + forM_ cs $ \(name, val) -> do + H.tr $ do + H.td (H.toMarkup name) + H.td (H.toMarkup val) + +main :: IO () +main = scotty 3000 $ do + get "/" $ do + cookies <- getCookies + html $ renderHtml $ do + case cookies of + Just cs -> renderCookiesTable cs + Nothing -> return () + H.form H.! method "post" H.! action "/set-a-cookie" $ do + H.input H.! type_ "text" H.! name "name" + H.input H.! type_ "text" H.! name "value" + H.input H.! type_ "submit" H.! value "set a cookie" + + post "/set-a-cookie" $ do + name <- param "name" + value <- param "value" + setCookie name value + redirect "/" diff --git a/examples/json.hs b/examples/json.hs deleted file mode 100644 index 7d7b5a9d..00000000 --- a/examples/json.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# LANGUAGE OverloadedStrings, TemplateHaskell #-} -import Data.Aeson.TH (deriveJSON) - -import qualified Data.Text.Lazy as T - -import Network.Wai.Middleware.RequestLogger -import Network.Wai.Middleware.Static - -import qualified Text.Blaze.Html5 as H -import Text.Blaze.Html5 ((!)) -import Text.Blaze.Html5.Attributes as A -import Text.Blaze.Html.Renderer.Text (renderHtml) - -import Web.Scotty - --- A rather contrived example to test round-tripping JSON through Scotty -data Foo = Quux - | Bar Int - | Baz (Float, String) - deriving (Eq, Show) - -$(deriveJSON Prelude.id ''Foo) - -main :: IO () -main = scotty 3000 $ do - middleware logStdoutDev - middleware $ staticPolicy (noDots >-> addBase "static") - - get "/" $ do - html $ wrapper $ do - H.form ! A.id "fooform" ! method "post" ! action "#" $ do - H.h5 "Select a constructor: " - H.input ! type_ "radio" ! A.id "fooquux" ! name "con" ! value "Quux" - H.label ! for "fooquux" $ "Quux" - H.input ! type_ "radio" ! A.id "foobar" ! name "con" ! value "Bar" - H.label ! for "foobar" $ "Bar" - H.input ! type_ "radio" ! A.id "foobaz" ! name "con" ! value "Baz" - H.label ! for "foobaz" $ "Baz" - H.br - H.h5 "Enter an int: " - H.input ! type_ "text" ! class_ "barfields" ! name "Barint" - H.br - H.h5 "Enter a float: " - H.input ! type_ "text" ! class_ "bazfields" ! name "Bazfloat" - H.h5 "Enter a string: " - H.input ! type_ "text" ! class_ "bazfields" ! name "Bazstring" - H.br - H.input ! type_ "submit" - H.div ! A.id "foolog" $ "" - - post "/foo" $ do - v <- jsonData - json $ case v of - Quux -> Quux - Bar i -> Bar $ i + 1 - Baz (f,s) -> Baz (f + 0.5, s) - -wrapper :: H.Html -> T.Text -wrapper content' = renderHtml - $ H.html $ do - H.header $ do - -- the first two are libraries, the last is our custom code - H.script ! type_ "text/javascript" ! src "jquery.js" $ "" - H.script ! type_ "text/javascript" ! src "jquery-json.js" $ "" - H.script ! type_ "text/javascript" ! src "json.js" $ "" - H.body content' diff --git a/examples/static/json.js b/examples/static/json.js deleted file mode 100644 index 133b8939..00000000 --- a/examples/static/json.js +++ /dev/null @@ -1,59 +0,0 @@ -$(document).ready(function() { - alert("here!"); - - $("#fooquux").click(function () { - $(".barfields").prop("disabled", true); - $(".bazfields").prop("disabled", true); - }); - - $("#foobar").click(function () { - $(".barfields").prop("disabled", false); - $(".bazfields").prop("disabled", true); - }); - - $("#foobaz").click(function () { - $(".bazfields").prop("disabled", false); - $(".barfields").prop("disabled", true); - }); - - // Some things to note: - // The result coming back (res) is a javascript object, so we must turn it to a string to view it. - // Errors will fail silently, since we haven't declared an error handler. - // JSON.stringify is broke-sauce... use $.toJSON from the jquery-json plugin. - $("#fooform").submit(function () { - var con = $(this).children('[name="con"]:checked').val(); - var inputs = $(this).children('[name^="' + con + '"]'); - var fields = $.map(inputs, function(v) { return $(v).val(); }); - $.ajax({ url: "/foo", - type: "POST", - data: mkCon(con,fields), - contentType: "application/json; charset=utf-8", - success: function(res) { - $("#foolog").append($.toJSON(res) + "
"); - }, - dataType: "json"}); // desired response type - return false; // prevent default submission action - }); -}); - -function mkCon(con, fields) { - // All user input is a string at first, - // and we need to recover the numeric types - if (con == 'Bar') { - fields[0] = parseInt(fields[0]); - } else if (con == 'Baz') { - fields[0] = parseFloat(fields[0]); - } - - // now build our object - // Aeson seems to be inconsistent here (maybe it's the JSON spec?) - // Constructors with zero or more than one fields become lists, - // but Constructors with exactly on field become values. - var o = {}; - if (fields.length == 1) { - o[con] = fields[0]; - } else { - o[con] = fields; - } - return $.toJSON(o); -} diff --git a/examples/upload.hs b/examples/upload.hs index 6d589358..70dd60fa 100644 --- a/examples/upload.hs +++ b/examples/upload.hs @@ -19,7 +19,7 @@ import System.FilePath (()) main :: IO () main = scotty 3000 $ do middleware logStdoutDev - middleware $ staticPolicy (addBase "uploads") + middleware $ staticPolicy (noDots >-> addBase "uploads") get "/" $ do html $ renderHtml From f7b2fa5bc4ceed28397f1429924b7f285c41e6b7 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Fri, 6 Dec 2013 00:47:18 -0600 Subject: [PATCH 084/179] Update haddock --- Web/Scotty.hs | 23 +++++++++++++---------- Web/Scotty/Action.hs | 20 ++++++++++---------- Web/Scotty/Trans.hs | 5 ++++- Web/Scotty/Types.hs | 2 ++ 4 files changed, 29 insertions(+), 21 deletions(-) diff --git a/Web/Scotty.hs b/Web/Scotty.hs index 465d3a57..690c4380 100644 --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -62,6 +62,9 @@ scottyApp :: ScottyM () -> IO Application scottyApp = Trans.scottyAppT id id -- | Global handler for uncaught exceptions. +-- +-- Uncaught exceptions normally become 500 responses. +-- You can use this to selectively override that behavior. defaultHandler :: (Text -> ActionM ()) -> ScottyM () defaultHandler = Trans.defaultHandler @@ -82,14 +85,14 @@ raise = Trans.raise -- As an example, these two routes overlap. The only way the second one will -- ever run is if the first one calls 'next'. -- --- > get "/foo/:number" $ do --- > n <- param "number" --- > unless (all isDigit n) $ next --- > text "a number" --- > -- > get "/foo/:bar" $ do --- > bar <- param "bar" --- > text "not a number" +-- > w :: Text <- param "bar" +-- > unless (w == "special") next +-- > text "You made a request to /foo/special" +-- > +-- > get "/foo/:baz" $ do +-- > w <- param "baz" +-- > text $ "You made a request to: " <> w next :: ActionM a next = Trans.next @@ -168,7 +171,7 @@ html :: Text -> ActionM () html = Trans.html -- | Send a file as the response. Doesn't set the \"Content-Type\" header, so you probably --- want to do that on your own with 'header'. +-- want to do that on your own with 'setHeader'. file :: FilePath -> ActionM () file = Trans.file @@ -179,12 +182,12 @@ json = Trans.json -- | Set the body of the response to a Source. Doesn't set the -- \"Content-Type\" header, so you probably want to do that on your --- own with 'header'. +-- own with 'setHeader'. source :: Source IO (Flush Builder) -> ActionM () source = Trans.source -- | Set the body of the response to the given 'BL.ByteString' value. Doesn't set the --- \"Content-Type\" header, so you probably want to do that on your own with 'header'. +-- \"Content-Type\" header, so you probably want to do that on your own with 'setHeader'. raw :: ByteString -> ActionM () raw = Trans.raw diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs index 8090ba09..edd8a490 100644 --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -83,14 +83,14 @@ raise = throwError . ActionError -- As an example, these two routes overlap. The only way the second one will -- ever run is if the first one calls 'next'. -- --- > get "/foo/:number" $ do --- > n <- param "number" --- > unless (all isDigit n) $ next --- > text "a number" --- > -- > get "/foo/:bar" $ do --- > bar <- param "bar" --- > text "not a number" +-- > w :: Text <- param "bar" +-- > unless (w == "special") next +-- > text "You made a request to /foo/special" +-- > +-- > get "/foo/:baz" $ do +-- > w <- param "baz" +-- > text $ "You made a request to: " <> w next :: (ScottyError e, Monad m) => ActionT e m a next = throwError Next @@ -226,7 +226,7 @@ html t = do raw $ encodeUtf8 t -- | Send a file as the response. Doesn't set the \"Content-Type\" header, so you probably --- want to do that on your own with 'header'. +-- want to do that on your own with 'setHeader'. file :: (ScottyError e, Monad m) => FilePath -> ActionT e m () file = ActionT . MS.modify . setContent . ContentFile @@ -239,12 +239,12 @@ json v = do -- | Set the body of the response to a Source. Doesn't set the -- \"Content-Type\" header, so you probably want to do that on your --- own with 'header'. +-- own with 'setHeader'. source :: (ScottyError e, Monad m) => Source IO (Flush Builder) -> ActionT e m () source = ActionT . MS.modify . setContent . ContentSource -- | Set the body of the response to the given 'BL.ByteString' value. Doesn't set the -- \"Content-Type\" header, so you probably want to do that on your --- own with 'header'. +-- own with 'setHeader'. raw :: (ScottyError e, Monad m) => BL.ByteString -> ActionT e m () raw = ActionT . MS.modify . setContent . ContentBuilder . fromLazyByteString diff --git a/Web/Scotty/Trans.hs b/Web/Scotty/Trans.hs index 3cd6162a..d3341f38 100644 --- a/Web/Scotty/Trans.hs +++ b/Web/Scotty/Trans.hs @@ -92,7 +92,10 @@ notFoundApp :: Monad m => Scotty.Application m notFoundApp _ = return $ responseBuilder status404 [("Content-Type","text/html")] $ fromByteString "

404: File Not Found!

" --- | Global handler for uncaught custom exceptions. +-- | Global handler for uncaught exceptions. +-- +-- Uncaught exceptions normally become 500 responses. +-- You can use this to selectively override that behavior. defaultHandler :: Monad m => (e -> ActionT e m ()) -> ScottyT e m () defaultHandler f = ScottyT $ modify $ addHandler $ Just f diff --git a/Web/Scotty/Types.hs b/Web/Scotty/Types.hs index e6511b52..df8fa55b 100644 --- a/Web/Scotty/Types.hs +++ b/Web/Scotty/Types.hs @@ -64,6 +64,8 @@ data ActionError e = Redirect Text | Next | ActionError e +-- | In order to use a custom exception type (aside from 'Text'), you must +-- define an instance of 'ScottyError' for that type. class ScottyError e where stringError :: String -> e showError :: e -> Text From 51dc83d37e47793086544acfb5191da3bf83461d Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Fri, 6 Dec 2013 11:38:46 -0600 Subject: [PATCH 085/179] Remove Web.Scotty.Helpers (to reappear in scotty-extra) --- Makefile | 2 +- Web/Scotty/Helpers.hs | 26 -------------------------- scotty.cabal | 4 +--- 3 files changed, 2 insertions(+), 30 deletions(-) delete mode 100644 Web/Scotty/Helpers.hs diff --git a/Makefile b/Makefile index 28ae01c7..9803250b 100644 --- a/Makefile +++ b/Makefile @@ -2,4 +2,4 @@ boot: cabal install --force-reinstalls ghci: - ghc --interactive -Wall Web/Scotty/Helpers.hs + ghc --interactive -Wall Web/Scotty.hs diff --git a/Web/Scotty/Helpers.hs b/Web/Scotty/Helpers.hs deleted file mode 100644 index 4244f47a..00000000 --- a/Web/Scotty/Helpers.hs +++ /dev/null @@ -1,26 +0,0 @@ --- | Miscellaneous convenience functions. If you create a helper while using --- Scotty that you find useful, feel free to submit a patch to this file. -module Web.Scotty.Helpers - ( addQueryString - ) where - -import Control.Monad - -import Data.Monoid -import qualified Data.Text.Lazy as T - -import qualified Network.Wai as Wai - --- Note that we only import the monad transformer version, to force --- us to be generic in the underyling monad. MonadIO constraints are fine. -import Web.Scotty.Types -import Web.Scotty.Trans -import Web.Scotty.Util - --- | Append the query string from the current request to a 'T.Text' value. --- Useful for repassing query parameters on redirect. --- --- > redirect =<< addQueryString "/foo" --- -addQueryString :: (ScottyError e, Monad m) => T.Text -> ActionT e m T.Text -addQueryString r = liftM ((r <>) . strictByteStringToLazyText . Wai.rawQueryString) request diff --git a/scotty.cabal b/scotty.cabal index 68af40bb..f3069381 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -50,20 +50,18 @@ Extra-source-files: ReleaseNotes.md examples/404.html examples/basic.hs + examples/cookies.hs examples/exceptions.hs examples/globalstate.hs examples/gzip.hs - examples/json.hs examples/options.hs examples/upload.hs examples/urlshortener.hs examples/static/jquery.js examples/static/jquery-json.js - examples/static/json.js Library Exposed-modules: Web.Scotty - Web.Scotty.Helpers Web.Scotty.Trans other-modules: Web.Scotty.Action Web.Scotty.Route From b5bb6e865fb14f738252822decb3da851848fbd2 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Fri, 6 Dec 2013 11:44:23 -0600 Subject: [PATCH 086/179] Update release notes. --- ReleaseNotes.md | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/ReleaseNotes.md b/ReleaseNotes.md index 2545c20d..7a5f888b 100644 --- a/ReleaseNotes.md +++ b/ReleaseNotes.md @@ -1,3 +1,17 @@ +## 0.6.0 + +* The Scotty transformers (`ScottyT` and `ActionT`) are now parameterized + over a custom exception type, allowing one to extend Scotty's `ErrorT` + layer with something richer than `Text` errors. See the `exceptions` + example for use. `ScottyM` and `ActionM` remain specialized to `Text` + exceptions for simplicity. + +* Both monads are now instances of `Functor` and `Applicative`. + +* There is a new `cookies` example. + +* Internals brought up-to-date with WAI 2.0 and related packages. + ## 0.5.0 * The Scotty monads (`ScottyM` and `ActionM`) are now monad transformers, From 2350eeacf0c6e289c82d0eab128d2b703dd15a73 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Fri, 6 Dec 2013 11:54:11 -0600 Subject: [PATCH 087/179] Ack forgot to adjust URLs in wai-middleware-static --- wai-middleware-static/wai-middleware-static.cabal | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/wai-middleware-static/wai-middleware-static.cabal b/wai-middleware-static/wai-middleware-static.cabal index 8198ead8..bf247ea1 100644 --- a/wai-middleware-static/wai-middleware-static.cabal +++ b/wai-middleware-static/wai-middleware-static.cabal @@ -1,13 +1,13 @@ Name: wai-middleware-static -Version: 0.4.0 +Version: 0.4.0.1 Synopsis: WAI middleware that intercepts requests to static files. -Homepage: https://github.com/ku-fpg/scotty -Bug-reports: https://github.com/ku-fpg/scotty/issues +Homepage: https://github.com/scotty-web/scotty +Bug-reports: https://github.com/scotty-web/scotty/issues License: BSD3 License-file: LICENSE Author: Andrew Farmer Maintainer: Andrew Farmer -Copyright: (c) 2012 Andrew Farmer +Copyright: (c) 2012-2013 Andrew Farmer Category: Web Stability: experimental Build-type: Simple @@ -35,4 +35,4 @@ Library source-repository head type: git - location: git://github.com/ku-fpg/scotty.git + location: git://github.com/scotty-web/scotty.git From 848cdfbfb10d3f79a0f8ac9109e862e79d9b34f7 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Fri, 13 Dec 2013 01:58:01 -0600 Subject: [PATCH 088/179] Match changes in wai-extra 2.0.1 --- Web/Scotty/Route.hs | 6 ++---- scotty.cabal | 5 ++--- 2 files changed, 4 insertions(+), 7 deletions(-) diff --git a/Web/Scotty/Route.hs b/Web/Scotty/Route.hs index a74ffa61..aba323e6 100644 --- a/Web/Scotty/Route.hs +++ b/Web/Scotty/Route.hs @@ -7,7 +7,6 @@ module Web.Scotty.Route import Control.Arrow ((***)) import Control.Monad.Error import qualified Control.Monad.State as MS -import Control.Monad.Trans.Resource (runResourceT, withInternalState, MonadBaseControl) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as BL @@ -109,7 +108,7 @@ path :: Request -> T.Text path = T.fromStrict . TS.cons '/' . TS.intercalate "/" . pathInfo -- Stolen from wai-extra, modified to accept body as lazy ByteString -parseRequestBody :: (MonadBaseControl IO m, MonadIO m) +parseRequestBody :: MonadIO m => BL.ByteString -> Parse.BackEnd y -> Request @@ -117,8 +116,7 @@ parseRequestBody :: (MonadBaseControl IO m, MonadIO m) parseRequestBody b s r = case Parse.getRequestBodyType r of Nothing -> return ([], []) - Just rbt -> runResourceT $ withInternalState $ \ is -> - liftIO $ liftM partitionEithers $ sourceLbs b $$ Parse.conduitRequestBody is s rbt =$ consume + Just rbt -> liftIO $ liftM partitionEithers $ sourceLbs b $$ Parse.conduitRequestBody s rbt =$ consume mkEnv :: MonadIO m => Request -> [Param] -> m ActionEnv mkEnv req captures = do diff --git a/scotty.cabal b/scotty.cabal index f3069381..5dd95cd8 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -1,5 +1,5 @@ Name: scotty -Version: 0.6.0 +Version: 0.6.1 Synopsis: Haskell web framework inspired by Ruby's Sinatra, using WAI and Warp Homepage: https://github.com/scotty-web/scotty Bug-reports: https://github.com/scotty-web/scotty/issues @@ -78,11 +78,10 @@ Library http-types >= 0.8.2 && < 0.9, mtl >= 2.1.2 && < 2.2, regex-compat >= 0.95.1 && < 0.96, - resourcet >= 0.4.7.2 && < 0.5, text >= 0.11.3.1 && < 0.12, transformers >= 0.3.0.0 && < 0.4, wai >= 2.0.0 && < 2.1, - wai-extra >= 2.0.0.1 && < 2.1, + wai-extra >= 2.0.1 && < 2.1, warp >= 2.0.0.1 && < 2.1 GHC-options: -Wall -fno-warn-orphans From 6e2c6903d6b8a61350c5b2b2f853c7fee56e756d Mon Sep 17 00:00:00 2001 From: Kirill Zaborsky Date: Sun, 22 Dec 2013 00:00:02 +0300 Subject: [PATCH 089/179] Time to upgrade (or loosen?) text dependency Fails to build with current hackage text version, time to create new package version? --- scotty.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scotty.cabal b/scotty.cabal index 5dd95cd8..82d0117d 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -78,7 +78,7 @@ Library http-types >= 0.8.2 && < 0.9, mtl >= 2.1.2 && < 2.2, regex-compat >= 0.95.1 && < 0.96, - text >= 0.11.3.1 && < 0.12, + text >= 1.0 && < 1.1, transformers >= 0.3.0.0 && < 0.4, wai >= 2.0.0 && < 2.1, wai-extra >= 2.0.1 && < 2.1, From 27dda760522650f1ca05b1aee6b3b624654eb2f2 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Sun, 22 Dec 2013 13:47:05 -0600 Subject: [PATCH 090/179] Keep lower bound on text, bump version --- scotty.cabal | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/scotty.cabal b/scotty.cabal index 82d0117d..073bd97f 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -1,12 +1,12 @@ Name: scotty -Version: 0.6.1 +Version: 0.6.2 Synopsis: Haskell web framework inspired by Ruby's Sinatra, using WAI and Warp Homepage: https://github.com/scotty-web/scotty Bug-reports: https://github.com/scotty-web/scotty/issues License: BSD3 License-file: LICENSE -Author: Andrew Farmer -Maintainer: Andrew Farmer +Author: Andrew Farmer +Maintainer: Andrew Farmer Copyright: (c) 2012-2013 Andrew Farmer Category: Web Stability: experimental @@ -78,7 +78,7 @@ Library http-types >= 0.8.2 && < 0.9, mtl >= 2.1.2 && < 2.2, regex-compat >= 0.95.1 && < 0.96, - text >= 1.0 && < 1.1, + text >= 0.11.3.1 && < 1.1, transformers >= 0.3.0.0 && < 0.4, wai >= 2.0.0 && < 2.1, wai-extra >= 2.0.1 && < 2.1, From 8e917beae5cfaa96e51b82e5ea1fdc58f2409459 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Sun, 22 Dec 2013 14:12:49 -0600 Subject: [PATCH 091/179] Bump text bounds for wai-middleware-static --- wai-middleware-static/wai-middleware-static.cabal | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/wai-middleware-static/wai-middleware-static.cabal b/wai-middleware-static/wai-middleware-static.cabal index bf247ea1..d7f6b94c 100644 --- a/wai-middleware-static/wai-middleware-static.cabal +++ b/wai-middleware-static/wai-middleware-static.cabal @@ -1,12 +1,12 @@ Name: wai-middleware-static -Version: 0.4.0.1 +Version: 0.4.0.2 Synopsis: WAI middleware that intercepts requests to static files. Homepage: https://github.com/scotty-web/scotty Bug-reports: https://github.com/scotty-web/scotty/issues License: BSD3 License-file: LICENSE -Author: Andrew Farmer -Maintainer: Andrew Farmer +Author: Andrew Farmer +Maintainer: Andrew Farmer Copyright: (c) 2012-2013 Andrew Farmer Category: Web Stability: experimental @@ -28,7 +28,7 @@ Library http-types >= 0.8.2 && < 0.9, mtl >= 2.1.2 && < 2.2, filepath >= 1.3.0.1 && < 1.4, - text >= 0.11.3.1 && < 0.12, + text >= 0.11.3.1 && < 1.1, wai >= 2.0.0 && < 2.1 GHC-options: -Wall -fno-warn-orphans From 2a8c36fc5d80aee66524103bf321518f969c3226 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Thu, 23 Jan 2014 10:45:54 -0500 Subject: [PATCH 092/179] Bump text and aeson upper bounds --- scotty.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/scotty.cabal b/scotty.cabal index 073bd97f..b2df6239 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -68,7 +68,7 @@ Library Web.Scotty.Types Web.Scotty.Util default-language: Haskell2010 - build-depends: aeson >= 0.6.2.1 && < 0.7, + build-depends: aeson >= 0.6.2.1 && < 0.8, base >= 4.3.1 && < 5, blaze-builder >= 0.3.3.0 && < 0.4, bytestring >= 0.10.0.2 && < 0.11, @@ -78,7 +78,7 @@ Library http-types >= 0.8.2 && < 0.9, mtl >= 2.1.2 && < 2.2, regex-compat >= 0.95.1 && < 0.96, - text >= 0.11.3.1 && < 1.1, + text >= 0.11.3.1 && < 1.2, transformers >= 0.3.0.0 && < 0.4, wai >= 2.0.0 && < 2.1, wai-extra >= 2.0.1 && < 2.1, From 1744c7cfe43c70624631cd0a6cf752e6a422c0cc Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Mon, 27 Jan 2014 13:33:38 -0600 Subject: [PATCH 093/179] Allow case-insensitive parsing of True/False (javascript uses true/false) --- Web/Scotty/Action.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs index edd8a490..9e6a309c 100644 --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -183,7 +183,14 @@ instance Parsable () where instance (Parsable a) => Parsable [a] where parseParam = parseParamList -instance Parsable Bool where parseParam = readEither +instance Parsable Bool where + parseParam t = if t' == T.toCaseFold "true" + then Right True + else if t' == T.toCaseFold "false" + then Right False + else Left "parseParam Bool: no parse" + where t' = T.toCaseFold t + instance Parsable Double where parseParam = readEither instance Parsable Float where parseParam = readEither instance Parsable Int where parseParam = readEither From cb2187b50aa6a5247b00a7c361cf556022c0cdd4 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Mon, 27 Jan 2014 16:21:39 -0600 Subject: [PATCH 094/179] Bump version, add release notes --- ReleaseNotes.md | 15 +++++++++++++++ scotty.cabal | 2 +- 2 files changed, 16 insertions(+), 1 deletion(-) diff --git a/ReleaseNotes.md b/ReleaseNotes.md index 7a5f888b..c6164f84 100644 --- a/ReleaseNotes.md +++ b/ReleaseNotes.md @@ -1,3 +1,18 @@ +## 0.7.0 + +* Make `Bool` parsing case-insensitive. Goal: support both Haskell's True/False + and Javascript's true/false. Thanks to Ben Gamari for suggesting this. + +* Bump `aeson`/`text` upper bounds. + +## 0.6.2 + +* Bump upper bound for `text`. + +## 0.6.1 + +* Match changes in `wai-extra`. + ## 0.6.0 * The Scotty transformers (`ScottyT` and `ActionT`) are now parameterized diff --git a/scotty.cabal b/scotty.cabal index b2df6239..dd6a9160 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -1,5 +1,5 @@ Name: scotty -Version: 0.6.2 +Version: 0.7.0 Synopsis: Haskell web framework inspired by Ruby's Sinatra, using WAI and Warp Homepage: https://github.com/scotty-web/scotty Bug-reports: https://github.com/scotty-web/scotty/issues From 449d18844a4b1e05c477e63e304e48985ee91d39 Mon Sep 17 00:00:00 2001 From: Sebastian Date: Mon, 10 Feb 2014 19:02:28 +0100 Subject: [PATCH 095/179] text version bump. --- wai-middleware-static/wai-middleware-static.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/wai-middleware-static/wai-middleware-static.cabal b/wai-middleware-static/wai-middleware-static.cabal index d7f6b94c..44c1de87 100644 --- a/wai-middleware-static/wai-middleware-static.cabal +++ b/wai-middleware-static/wai-middleware-static.cabal @@ -1,5 +1,5 @@ Name: wai-middleware-static -Version: 0.4.0.2 +Version: 0.4.0.3 Synopsis: WAI middleware that intercepts requests to static files. Homepage: https://github.com/scotty-web/scotty Bug-reports: https://github.com/scotty-web/scotty/issues @@ -28,7 +28,7 @@ Library http-types >= 0.8.2 && < 0.9, mtl >= 2.1.2 && < 2.2, filepath >= 1.3.0.1 && < 1.4, - text >= 0.11.3.1 && < 1.1, + text >= 0.11.3.1 && < 1.2, wai >= 2.0.0 && < 2.1 GHC-options: -Wall -fno-warn-orphans From 39fa6e14744cd2f93157a591dd3a73f8fd838ac0 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Mon, 10 Mar 2014 15:06:18 -0500 Subject: [PATCH 096/179] Bump warp/wai/wai-extra bounds, including minbound for warp slowloris issue. --- scotty.cabal | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/scotty.cabal b/scotty.cabal index dd6a9160..559f89db 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -80,9 +80,9 @@ Library regex-compat >= 0.95.1 && < 0.96, text >= 0.11.3.1 && < 1.2, transformers >= 0.3.0.0 && < 0.4, - wai >= 2.0.0 && < 2.1, - wai-extra >= 2.0.1 && < 2.1, - warp >= 2.0.0.1 && < 2.1 + wai >= 2.0.0 && < 2.2, + wai-extra >= 2.0.1 && < 2.2, + warp >= 2.0.3.3 && < 2.2 GHC-options: -Wall -fno-warn-orphans From e337962521f3adc91121c5dcf8629224cb168781 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Mon, 10 Mar 2014 15:28:27 -0500 Subject: [PATCH 097/179] Rename ReleaseNotes.md to changelog.md so hackage picks it up --- ReleaseNotes.md => changelog.md | 2 ++ scotty.cabal | 2 +- 2 files changed, 3 insertions(+), 1 deletion(-) rename ReleaseNotes.md => changelog.md (92%) diff --git a/ReleaseNotes.md b/changelog.md similarity index 92% rename from ReleaseNotes.md rename to changelog.md index c6164f84..f01fe7c3 100644 --- a/ReleaseNotes.md +++ b/changelog.md @@ -5,6 +5,8 @@ * Bump `aeson`/`text` upper bounds. +* Bump `wai`/`wai-extra`/`warp` bounds, including new lower bound for `warp`, which fixes a security issue related to Slowloris protection. + ## 0.6.2 * Bump upper bound for `text`. diff --git a/scotty.cabal b/scotty.cabal index 559f89db..00e37f4f 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -47,7 +47,7 @@ Description: Extra-source-files: README.md - ReleaseNotes.md + changelog.md examples/404.html examples/basic.hs examples/cookies.hs From 9bc17155695e89e0267c7ef548e155001cce2c69 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Mon, 10 Mar 2014 15:47:14 -0500 Subject: [PATCH 098/179] Use setPort instead of settingsPort as a setter --- Web/Scotty/Trans.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Web/Scotty/Trans.hs b/Web/Scotty/Trans.hs index d3341f38..a4df08ec 100644 --- a/Web/Scotty/Trans.hs +++ b/Web/Scotty/Trans.hs @@ -45,7 +45,7 @@ import Data.Default (def) import Network.HTTP.Types (status404) import Network.Wai -import Network.Wai.Handler.Warp (Port, runSettings, settingsPort) +import Network.Wai.Handler.Warp (Port, runSettings, setPort, settingsPort) import Web.Scotty.Action import Web.Scotty.Route @@ -60,7 +60,7 @@ scottyT :: (Monad m, MonadIO n) -> (m Response -> IO Response) -- ^ Run monad 'm' into 'IO', called at each action. -> ScottyT e m () -> n () -scottyT p = scottyOptsT $ def { settings = (settings def) { settingsPort = p } } +scottyT p = scottyOptsT $ def { settings = setPort p (settings def) } -- | Run a scotty application using the warp server, passing extra options. -- NB: 'scottyOpts opts' === 'scottyOptsT opts id id' From bd7eea4e28425767481000da2d7a403d6b82839f Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Mon, 10 Mar 2014 16:30:34 -0500 Subject: [PATCH 099/179] Lift IO exceptions into ActionT exceptions via stringError --- Web/Scotty/Types.hs | 8 +++++++- examples/basic.hs | 9 +++++++++ 2 files changed, 16 insertions(+), 1 deletion(-) diff --git a/Web/Scotty/Types.hs b/Web/Scotty/Types.hs index df8fa55b..aede5282 100644 --- a/Web/Scotty/Types.hs +++ b/Web/Scotty/Types.hs @@ -4,6 +4,7 @@ module Web.Scotty.Types where import Blaze.ByteString.Builder (Builder) import Control.Applicative +import Control.Exception (catch, SomeException) import Control.Monad.Error import Control.Monad.Reader import Control.Monad.State @@ -109,7 +110,12 @@ instance Default ScottyResponse where def = SR status200 [] (ContentBuilder mempty) newtype ActionT e m a = ActionT { runAM :: ErrorT (ActionError e) (ReaderT ActionEnv (StateT ScottyResponse m)) a } - deriving ( Functor, Applicative, Monad, MonadIO ) + deriving ( Functor, Applicative, Monad ) + +instance (MonadIO m, ScottyError e) => MonadIO (ActionT e m) where + liftIO io = ActionT $ do + r <- liftIO $ liftM Right io `catch` (\ e -> return $ Left $ stringError $ show (e :: SomeException)) + either throwError return r instance ScottyError e => MonadTrans (ActionT e) where lift = ActionT . lift . lift . lift diff --git a/examples/basic.hs b/examples/basic.hs index 47c3be31..abb7423c 100644 --- a/examples/basic.hs +++ b/examples/basic.hs @@ -3,6 +3,7 @@ import Web.Scotty import Network.Wai.Middleware.RequestLogger -- install wai-extra if you don't have this +import Control.Monad import Control.Monad.Trans import Data.Monoid import System.Random (newStdGen, randomRs) @@ -12,6 +13,7 @@ import Network.Wai import qualified Data.Text.Lazy as T import Data.Text.Lazy.Encoding (decodeUtf8) +import Data.String (fromString) main :: IO () main = scotty 3000 $ do @@ -89,6 +91,13 @@ main = scotty 3000 $ do agent <- reqHeader "User-Agent" maybe (raise "User-Agent header not found!") text agent + -- Make a request to this URI, then type a line in the terminal, which + -- will be the response. Using ctrl-c will cause getLine to fail. + -- This demonstrates that IO exceptions are lifted into ActionM exceptions. + get "/iofail" $ do + msg <- liftIO $ liftM fromString getLine + text msg + {- If you don't want to use Warp as your webserver, you can use any WAI handler. From b84413712e5f5a8cf984068089371c26006e6a1b Mon Sep 17 00:00:00 2001 From: Mark Date: Tue, 11 Mar 2014 19:24:19 +0100 Subject: [PATCH 100/179] Fixing imports --- Web/Scotty/Types.hs | 4 ++-- scotty | 1 + 2 files changed, 3 insertions(+), 2 deletions(-) create mode 160000 scotty diff --git a/Web/Scotty/Types.hs b/Web/Scotty/Types.hs index aede5282..c3a01ea3 100644 --- a/Web/Scotty/Types.hs +++ b/Web/Scotty/Types.hs @@ -4,7 +4,6 @@ module Web.Scotty.Types where import Blaze.ByteString.Builder (Builder) import Control.Applicative -import Control.Exception (catch, SomeException) import Control.Monad.Error import Control.Monad.Reader import Control.Monad.State @@ -22,6 +21,7 @@ import Network.Wai hiding (Middleware, Application) import qualified Network.Wai as Wai import Network.Wai.Handler.Warp (Settings, defaultSettings) import Network.Wai.Parse (FileInfo) +import qualified Control.Exception as E --------------------- Options ----------------------- data Options = Options { verbose :: Int -- ^ 0 = silent, 1(def) = startup banner @@ -114,7 +114,7 @@ newtype ActionT e m a = ActionT { runAM :: ErrorT (ActionError e) (ReaderT Actio instance (MonadIO m, ScottyError e) => MonadIO (ActionT e m) where liftIO io = ActionT $ do - r <- liftIO $ liftM Right io `catch` (\ e -> return $ Left $ stringError $ show (e :: SomeException)) + r <- liftIO $ liftM Right io `E.catch` (\ e -> return $ Left $ stringError $ show (e :: E.SomeException)) either throwError return r instance ScottyError e => MonadTrans (ActionT e) where diff --git a/scotty b/scotty new file mode 160000 index 00000000..8596f587 --- /dev/null +++ b/scotty @@ -0,0 +1 @@ +Subproject commit 8596f587117a899aa7f6f06b118aaa697eba41ec From 4094455b2c6e857e7941df1713b18f078a955d05 Mon Sep 17 00:00:00 2001 From: Zhang Yichao Date: Fri, 14 Mar 2014 15:51:29 +0800 Subject: [PATCH 101/179] setPort is introduced in warp-2.1.0, so 2.0.3.3 is not enough --- scotty.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scotty.cabal b/scotty.cabal index 00e37f4f..a125dc49 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -82,7 +82,7 @@ Library transformers >= 0.3.0.0 && < 0.4, wai >= 2.0.0 && < 2.2, wai-extra >= 2.0.1 && < 2.2, - warp >= 2.0.3.3 && < 2.2 + warp >= 2.1.1 && < 2.2 GHC-options: -Wall -fno-warn-orphans From c86695fafc84466cff420fcca237cf40154aa9b9 Mon Sep 17 00:00:00 2001 From: Zhang Yichao Date: Fri, 14 Mar 2014 15:51:52 +0800 Subject: [PATCH 102/179] settingsPort is deprecated, use getPort from warp-2.1.1 --- Web/Scotty/Trans.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Web/Scotty/Trans.hs b/Web/Scotty/Trans.hs index a4df08ec..57d05cbd 100644 --- a/Web/Scotty/Trans.hs +++ b/Web/Scotty/Trans.hs @@ -45,7 +45,7 @@ import Data.Default (def) import Network.HTTP.Types (status404) import Network.Wai -import Network.Wai.Handler.Warp (Port, runSettings, setPort, settingsPort) +import Network.Wai.Handler.Warp (Port, runSettings, setPort, getPort) import Web.Scotty.Action import Web.Scotty.Route @@ -72,7 +72,7 @@ scottyOptsT :: (Monad m, MonadIO n) -> n () scottyOptsT opts runM runActionToIO s = do when (verbose opts > 0) $ - liftIO $ putStrLn $ "Setting phasers to stun... (port " ++ show (settingsPort (settings opts)) ++ ") (ctrl-c to quit)" + liftIO $ putStrLn $ "Setting phasers to stun... (port " ++ show (getPort (settings opts)) ++ ") (ctrl-c to quit)" liftIO . runSettings (settings opts) =<< scottyAppT runM runActionToIO s -- | Turn a scotty application into a WAI 'Application', which can be From d2114bc0889ba04ad6be5c02c2e65eebb287346a Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Mon, 17 Mar 2014 15:53:01 -0500 Subject: [PATCH 103/179] Renamed 'reqHeader' to 'header', add 'headers', deprecation notice. --- Web/Scotty.hs | 13 +++++++++++-- Web/Scotty/Action.hs | 21 ++++++++++++++++++--- Web/Scotty/Trans.hs | 2 +- examples/basic.hs | 4 ++-- 4 files changed, 32 insertions(+), 8 deletions(-) diff --git a/Web/Scotty.hs b/Web/Scotty.hs index 690c4380..eea1dad5 100644 --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -13,7 +13,7 @@ module Web.Scotty -- ** Route Patterns , capture, regex, function, literal -- ** Accessing the Request, Captures, and Query Parameters - , request, reqHeader, body, param, params, jsonData, files + , request, header, reqHeader, headers, body, param, params, jsonData, files -- ** Modifying the Response and Redirecting , status, addHeader, setHeader, redirect -- ** Setting Response Body @@ -122,8 +122,17 @@ files :: ActionM [File] files = Trans.files -- | Get a request header. Header name is case-insensitive. +header :: Text -> ActionM (Maybe Text) +header = Trans.header + +-- | Get a request header. Header name is case-insensitive. (Deprecated in favor of `header`.) reqHeader :: Text -> ActionM (Maybe Text) -reqHeader = Trans.reqHeader +reqHeader = Trans.header +{-# DEPRECATED reqHeader "Use header instead. reqHeader will be removed in the next release." #-} + +-- | Get all the request headers. Header names are case-insensitive. +headers :: ActionM [(Text, Text)] +headers = Trans.headers -- | Get the request body. body :: ActionM ByteString diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs index 9e6a309c..4848e7d3 100644 --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -4,6 +4,8 @@ module Web.Scotty.Action , body , file , files + , header + , headers , html , json , jsonData @@ -14,7 +16,7 @@ module Web.Scotty.Action , raw , readEither , redirect - , reqHeader + , reqHeader -- Deprecated , request , rescue , setHeader @@ -121,12 +123,25 @@ request = ActionT $ liftM getReq ask files :: (ScottyError e, Monad m) => ActionT e m [File] files = ActionT $ liftM getFiles ask --- | Get a request header. Header name is case-insensitive. +-- | Get a request header. Header name is case-insensitive. (Deprecated in favor of `header`.) reqHeader :: (ScottyError e, Monad m) => T.Text -> ActionT e m (Maybe T.Text) -reqHeader k = do +reqHeader = header +{-# DEPRECATED reqHeader "Use header instead. This will be removed in the next release." #-} + +-- | Get a request header. Header name is case-insensitive. +header :: (ScottyError e, Monad m) => T.Text -> ActionT e m (Maybe T.Text) +header k = do hs <- liftM requestHeaders request return $ fmap strictByteStringToLazyText $ lookup (CI.mk (lazyTextToStrictByteString k)) hs +-- | Get all the request headers. Header names are case-insensitive. +headers :: (ScottyError e, Monad m) => ActionT e m [(T.Text, T.Text)] +headers = do + hs <- liftM requestHeaders request + return [ ( strictByteStringToLazyText (CI.original k) + , strictByteStringToLazyText v) + | (k,v) <- hs ] + -- | Get the request body. body :: (ScottyError e, Monad m) => ActionT e m BL.ByteString body = ActionT $ liftM getBody ask diff --git a/Web/Scotty/Trans.hs b/Web/Scotty/Trans.hs index 57d05cbd..7a62d50d 100644 --- a/Web/Scotty/Trans.hs +++ b/Web/Scotty/Trans.hs @@ -17,7 +17,7 @@ module Web.Scotty.Trans -- ** Route Patterns , capture, regex, function, literal -- ** Accessing the Request, Captures, and Query Parameters - , request, reqHeader, body, param, params, jsonData, files + , request, header, reqHeader, headers, body, param, params, jsonData, files -- ** Modifying the Response and Redirecting , status, addHeader, setHeader, redirect -- ** Setting Response Body diff --git a/examples/basic.hs b/examples/basic.hs index abb7423c..92403bb5 100644 --- a/examples/basic.hs +++ b/examples/basic.hs @@ -87,8 +87,8 @@ main = scotty 3000 $ do b <- body text $ decodeUtf8 b - get "/reqHeader" $ do - agent <- reqHeader "User-Agent" + get "/header" $ do + agent <- header "User-Agent" maybe (raise "User-Agent header not found!") text agent -- Make a request to this URI, then type a line in the terminal, which From 8497a341e86c3ac3525bc8f6d2c7a6291546a0c1 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Mon, 17 Mar 2014 15:57:41 -0500 Subject: [PATCH 104/179] Add to changelog --- changelog.md | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/changelog.md b/changelog.md index f01fe7c3..4c7ed176 100644 --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,10 @@ ## 0.7.0 +* Renamed `reqHeader` to `header`. Added `headers` function to get all headers. + +* Changed `MonadIO` instance for `ActionT` such that IO exceptions are lifted + into `ScottyError`s via `stringError`. + * Make `Bool` parsing case-insensitive. Goal: support both Haskell's True/False and Javascript's true/false. Thanks to Ben Gamari for suggesting this. From 5994dd24697de89a0fe1bcf647c1884136fd1375 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Wed, 19 Mar 2014 15:51:18 -0500 Subject: [PATCH 105/179] Bump wai upper bound to sync with scotty --- wai-middleware-static/wai-middleware-static.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/wai-middleware-static/wai-middleware-static.cabal b/wai-middleware-static/wai-middleware-static.cabal index 44c1de87..079d90a5 100644 --- a/wai-middleware-static/wai-middleware-static.cabal +++ b/wai-middleware-static/wai-middleware-static.cabal @@ -25,11 +25,11 @@ Library bytestring >= 0.10.0.2 && < 0.11, containers >= 0.5.0.0 && < 0.6, directory >= 1.2.0.1 && < 1.3, + filepath >= 1.3.0.1 && < 1.4, http-types >= 0.8.2 && < 0.9, mtl >= 2.1.2 && < 2.2, - filepath >= 1.3.0.1 && < 1.4, text >= 0.11.3.1 && < 1.2, - wai >= 2.0.0 && < 2.1 + wai >= 2.0.0 && < 2.2 GHC-options: -Wall -fno-warn-orphans From 49c6577780bbb29db64fa331a57a4e46e6c4a591 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Wed, 19 Mar 2014 16:24:38 -0500 Subject: [PATCH 106/179] Use setFdCacheDuration 0 to work around #55 --- Web/Scotty/Types.hs | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/Web/Scotty/Types.hs b/Web/Scotty/Types.hs index 17e4e5c9..0bc2b916 100644 --- a/Web/Scotty/Types.hs +++ b/Web/Scotty/Types.hs @@ -20,16 +20,22 @@ import Network.HTTP.Types import Network.Wai hiding (Middleware, Application) import qualified Network.Wai as Wai -import Network.Wai.Handler.Warp (Settings, defaultSettings) +import Network.Wai.Handler.Warp (Settings, defaultSettings, setFdCacheDuration) import Network.Wai.Parse (FileInfo) --------------------- Options ----------------------- data Options = Options { verbose :: Int -- ^ 0 = silent, 1(def) = startup banner , settings :: Settings -- ^ Warp 'Settings' + -- Note: to work around an issue in warp, + -- the default FD cache duration is set to 0 + -- so changes to static files are always picked + -- up. This likely has performance implications, + -- so you may want to modify this for production + -- servers using `setFdCacheDuration`. } instance Default Options where - def = Options 1 defaultSettings + def = Options 1 (setFdCacheDuration 0 defaultSettings) ----- Transformer Aware Applications/Middleware ----- type Middleware m = Application m -> Application m From b63e76e124fb0561836b4d5eab0897983d4bb635 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Wed, 19 Mar 2014 16:25:06 -0500 Subject: [PATCH 107/179] Update haddock docs, including notes about production servers. --- Web/Scotty.hs | 9 +++++++++ Web/Scotty/Trans.hs | 15 ++++++++++++--- 2 files changed, 21 insertions(+), 3 deletions(-) diff --git a/Web/Scotty.hs b/Web/Scotty.hs index eea1dad5..c6c302ba 100644 --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -1,6 +1,10 @@ {-# LANGUAGE OverloadedStrings, RankNTypes #-} -- | It should be noted that most of the code snippets below depend on the -- OverloadedStrings language pragma. +-- +-- Scotty is set up by default for development mode. For production servers, +-- you will likely want to modify 'Trans.settings' and the 'defaultHandler'. See +-- the comments on each of these functions for more information. module Web.Scotty ( -- * scotty-to-WAI scotty, scottyApp, scottyOpts, Options(..) @@ -65,6 +69,11 @@ scottyApp = Trans.scottyAppT id id -- -- Uncaught exceptions normally become 500 responses. -- You can use this to selectively override that behavior. +-- +-- Note: IO exceptions are lifted into Scotty exceptions by default. +-- This has security implications, so you probably want to provide your +-- own defaultHandler in production which does not send out the error +-- strings as 500 responses. defaultHandler :: (Text -> ActionM ()) -> ScottyM () defaultHandler = Trans.defaultHandler diff --git a/Web/Scotty/Trans.hs b/Web/Scotty/Trans.hs index 7a62d50d..20644b16 100644 --- a/Web/Scotty/Trans.hs +++ b/Web/Scotty/Trans.hs @@ -5,6 +5,10 @@ -- The functions in this module allow an arbitrary monad to be embedded -- in Scotty's monad transformer stack in order that Scotty be combined -- with other DSLs. +-- +-- Scotty is set up by default for development mode. For production servers, +-- you will likely want to modify 'settings' and the 'defaultHandler'. See +-- the comments on each of these functions for more information. module Web.Scotty.Trans ( -- * scotty-to-WAI scottyT, scottyAppT, scottyOptsT, Options(..) @@ -53,7 +57,7 @@ import Web.Scotty.Types hiding (Application, Middleware) import qualified Web.Scotty.Types as Scotty -- | Run a scotty application using the warp server. --- NB: 'scotty p' === 'scottyT p id id' +-- NB: scotty p === scottyT p id id scottyT :: (Monad m, MonadIO n) => Port -> (forall a. m a -> n a) -- ^ Run monad 'm' into monad 'n', called once at 'ScottyT' level. @@ -63,7 +67,7 @@ scottyT :: (Monad m, MonadIO n) scottyT p = scottyOptsT $ def { settings = setPort p (settings def) } -- | Run a scotty application using the warp server, passing extra options. --- NB: 'scottyOpts opts' === 'scottyOptsT opts id id' +-- NB: scottyOpts opts === scottyOptsT opts id id scottyOptsT :: (Monad m, MonadIO n) => Options -> (forall a. m a -> n a) -- ^ Run monad 'm' into monad 'n', called once at 'ScottyT' level. @@ -77,7 +81,7 @@ scottyOptsT opts runM runActionToIO s = do -- | Turn a scotty application into a WAI 'Application', which can be -- run with any WAI handler. --- NB: 'scottyApp' === 'scottyAppT id id' +-- NB: scottyApp === scottyAppT id id scottyAppT :: (Monad m, Monad n) => (forall a. m a -> n a) -- ^ Run monad 'm' into monad 'n', called once at 'ScottyT' level. -> (m Response -> IO Response) -- ^ Run monad 'm' into 'IO', called at each action. @@ -96,6 +100,11 @@ notFoundApp _ = return $ responseBuilder status404 [("Content-Type","text/html") -- -- Uncaught exceptions normally become 500 responses. -- You can use this to selectively override that behavior. +-- +-- Note: IO exceptions are lifted into 'ScottyError's by 'stringError'. +-- This has security implications, so you probably want to provide your +-- own defaultHandler in production which does not send out the error +-- strings as 500 responses. defaultHandler :: Monad m => (e -> ActionT e m ()) -> ScottyT e m () defaultHandler f = ScottyT $ modify $ addHandler $ Just f From c8ea6c442949ca39b38332918b8ed735315748d6 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Wed, 19 Mar 2014 16:26:46 -0500 Subject: [PATCH 108/179] Bump version and changelog --- changelog.md | 5 +++++ scotty.cabal | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/changelog.md b/changelog.md index 4c7ed176..a510a217 100644 --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,8 @@ +## 0.7.1 + +* Default warp settings now use `setFdCacheDuration 0` to work around a warp + issue where file changes are not getting picked up. + ## 0.7.0 * Renamed `reqHeader` to `header`. Added `headers` function to get all headers. diff --git a/scotty.cabal b/scotty.cabal index a125dc49..43a1b777 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -1,5 +1,5 @@ Name: scotty -Version: 0.7.0 +Version: 0.7.1 Synopsis: Haskell web framework inspired by Ruby's Sinatra, using WAI and Warp Homepage: https://github.com/scotty-web/scotty Bug-reports: https://github.com/scotty-web/scotty/issues From 274572706b8e4ca905587acadac40129353d5a9a Mon Sep 17 00:00:00 2001 From: nhibberd Date: Mon, 24 Mar 2014 21:08:23 +1000 Subject: [PATCH 109/179] Use secure defaults for static middleware. These changes affect the security defaults and will definitely provide better behaviour for the existing users. Issue #64 - Implementating noDots by default. Issue #63 - Implementating isNotAbsolute by default tightens up the security to a normal standard. Previous request on `localhost:3000//etc/passwd` would print out the contents of `/etc/passwd`. With the added security, the request will now return 404. --- Network/Wai/Middleware/Static.hs | 20 +++++++++++++++----- 1 file changed, 15 insertions(+), 5 deletions(-) diff --git a/Network/Wai/Middleware/Static.hs b/Network/Wai/Middleware/Static.hs index 778d3f38..7ba497ed 100644 --- a/Network/Wai/Middleware/Static.hs +++ b/Network/Wai/Middleware/Static.hs @@ -10,10 +10,10 @@ -- on the file extension and returns the file contents as the response. module Network.Wai.Middleware.Static ( -- * Middlewares - static, staticPolicy + static, staticPolicy, unsafeStaticPolicy , -- * Policies Policy, (<|>), (>->), policy, predicate - , addBase, addSlash, contains, hasPrefix, hasSuffix, noDots, only + , addBase, addSlash, contains, hasPrefix, hasSuffix, noDots, isNotAbsolute, only , -- * Utilities tryPolicy ) where @@ -69,7 +69,7 @@ p1 <|> p2 = policy (\s -> maybe (tryPolicy p2 s) Just (tryPolicy p1 s)) -- GET \"foo\/bar\" looks for \"\/home\/user\/files\/foo\/bar\" -- addBase :: String -> Policy -addBase b = policy (Just . (b FP.)) +addBase b = isNotAbsolute >-> policy (Just . (b FP.)) -- | Add an initial slash to to the URI, if not already present. -- @@ -97,6 +97,11 @@ contains s = predicate (isInfixOf s) noDots :: Policy noDots = predicate (not . isInfixOf "..") +-- | Reject URIs that are not absolute +isNotAbsolute :: Policy +isNotAbsolute = predicate $ not . FP.isAbsolute + + -- | Use URI as the key to an association list, rejecting those not found. -- The policy result is the matching value. -- @@ -111,11 +116,16 @@ only al = policy (flip lookup al) -- | Serve static files out of the application root (current directory). -- If file is found, it is streamed to the client and no further middleware is run. static :: Middleware -static = staticPolicy mempty +static = staticPolicy $ noDots >-> isNotAbsolute -- | Serve static files subject to a 'Policy' staticPolicy :: Policy -> Middleware -staticPolicy p app req = +staticPolicy p = + unsafeStaticPolicy $ noDots >-> isNotAbsolute >-> p + +-- | Serve potentially unsafe static files subject to a 'Policy' +unsafeStaticPolicy :: Policy -> Middleware +unsafeStaticPolicy p app req = maybe (app req) (\fp -> do exists <- liftIO $ doesFileExist fp if exists From e757d0f41e50cc978f7520ecd01241c3623ba5fa Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Mon, 24 Mar 2014 12:40:59 -0500 Subject: [PATCH 110/179] Remove redundant policies, add haddock docs --- Network/Wai/Middleware/Static.hs | 23 +++++++++++++---------- 1 file changed, 13 insertions(+), 10 deletions(-) diff --git a/Network/Wai/Middleware/Static.hs b/Network/Wai/Middleware/Static.hs index 7ba497ed..059e05b7 100644 --- a/Network/Wai/Middleware/Static.hs +++ b/Network/Wai/Middleware/Static.hs @@ -69,7 +69,7 @@ p1 <|> p2 = policy (\s -> maybe (tryPolicy p2 s) Just (tryPolicy p1 s)) -- GET \"foo\/bar\" looks for \"\/home\/user\/files\/foo\/bar\" -- addBase :: String -> Policy -addBase b = isNotAbsolute >-> policy (Just . (b FP.)) +addBase b = policy (Just . (b FP.)) -- | Add an initial slash to to the URI, if not already present. -- @@ -83,25 +83,24 @@ addSlash = policy slashOpt -- | Accept only URIs with given suffix hasSuffix :: String -> Policy -hasSuffix suf = predicate (isSuffixOf suf) +hasSuffix = predicate . isSuffixOf -- | Accept only URIs with given prefix hasPrefix :: String -> Policy -hasPrefix pre = predicate (isPrefixOf pre) +hasPrefix = predicate . isPrefixOf -- | Accept only URIs containing given string contains :: String -> Policy -contains s = predicate (isInfixOf s) +contains = predicate . isInfixOf -- | Reject URIs containing \"..\" noDots :: Policy noDots = predicate (not . isInfixOf "..") --- | Reject URIs that are not absolute +-- | Reject URIs that are absolute paths isNotAbsolute :: Policy isNotAbsolute = predicate $ not . FP.isAbsolute - -- | Use URI as the key to an association list, rejecting those not found. -- The policy result is the matching value. -- @@ -115,15 +114,19 @@ only al = policy (flip lookup al) -- | Serve static files out of the application root (current directory). -- If file is found, it is streamed to the client and no further middleware is run. +-- +-- Note: for security reasons, this uses the 'noDots' and 'isNotAbsolute' policy by default. static :: Middleware -static = staticPolicy $ noDots >-> isNotAbsolute +static = staticPolicy mempty -- | Serve static files subject to a 'Policy' +-- +-- Note: for security reasons, this uses the 'noDots' and 'isNotAbsolute' policy by default. staticPolicy :: Policy -> Middleware -staticPolicy p = - unsafeStaticPolicy $ noDots >-> isNotAbsolute >-> p +staticPolicy p = unsafeStaticPolicy $ noDots >-> isNotAbsolute >-> p --- | Serve potentially unsafe static files subject to a 'Policy' +-- | Serve static files subject to a 'Policy'. Unlike 'static' and 'staticPolicy', this +-- has no policies enabled by default, and is hence insecure. unsafeStaticPolicy :: Policy -> Middleware unsafeStaticPolicy p app req = maybe (app req) From c5d921a4f39220fa03a8ca49e76e1a9adf744a12 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Mon, 24 Mar 2014 12:49:30 -0500 Subject: [PATCH 111/179] Bump version, add changelog --- wai-middleware-static/changelog.md | 8 ++++++++ wai-middleware-static/wai-middleware-static.cabal | 8 +++++--- 2 files changed, 13 insertions(+), 3 deletions(-) create mode 100644 wai-middleware-static/changelog.md diff --git a/wai-middleware-static/changelog.md b/wai-middleware-static/changelog.md new file mode 100644 index 00000000..cd0b4651 --- /dev/null +++ b/wai-middleware-static/changelog.md @@ -0,0 +1,8 @@ +## 0.5.0.0 + +* Add `isNotAbsolute` policy and change `static` and `staticPolicy` to + use `noDots` and `isNotAbsolute` policies by default. (Thanks to Nick Hibberd!) + +* Add `unsafeStaticPolicy`, which behaves as the old insecure `staticPolicy` behaved. + +* Add changelog diff --git a/wai-middleware-static/wai-middleware-static.cabal b/wai-middleware-static/wai-middleware-static.cabal index 079d90a5..c4c961c5 100644 --- a/wai-middleware-static/wai-middleware-static.cabal +++ b/wai-middleware-static/wai-middleware-static.cabal @@ -1,13 +1,13 @@ Name: wai-middleware-static -Version: 0.4.0.3 -Synopsis: WAI middleware that intercepts requests to static files. +Version: 0.5.0.0 +Synopsis: WAI middleware that serves requests to static files. Homepage: https://github.com/scotty-web/scotty Bug-reports: https://github.com/scotty-web/scotty/issues License: BSD3 License-file: LICENSE Author: Andrew Farmer Maintainer: Andrew Farmer -Copyright: (c) 2012-2013 Andrew Farmer +Copyright: (c) 2012-2014 Andrew Farmer Category: Web Stability: experimental Build-type: Simple @@ -18,6 +18,8 @@ Description: . [WAI] +Extra-source-files: changelog.md + Library Exposed-modules: Network.Wai.Middleware.Static default-language: Haskell2010 From 0cad947d1501429a57bcef73608ba4e8ca631597 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Mon, 24 Mar 2014 12:52:29 -0500 Subject: [PATCH 112/179] Update copyright year in cabal file --- scotty.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scotty.cabal b/scotty.cabal index 43a1b777..057b5aef 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -7,7 +7,7 @@ License: BSD3 License-file: LICENSE Author: Andrew Farmer Maintainer: Andrew Farmer -Copyright: (c) 2012-2013 Andrew Farmer +Copyright: (c) 2012-2014 Andrew Farmer Category: Web Stability: experimental Build-type: Simple From abefd01c818fcbaf4fd9782508ef53517126bb6b Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Tue, 8 Apr 2014 14:07:31 -0500 Subject: [PATCH 113/179] Bump bounds on conduit, add conduit-extra --- scotty.cabal | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/scotty.cabal b/scotty.cabal index 057b5aef..1fc88e38 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -1,5 +1,5 @@ Name: scotty -Version: 0.7.1 +Version: 0.7.2 Synopsis: Haskell web framework inspired by Ruby's Sinatra, using WAI and Warp Homepage: https://github.com/scotty-web/scotty Bug-reports: https://github.com/scotty-web/scotty/issues @@ -73,7 +73,8 @@ Library blaze-builder >= 0.3.3.0 && < 0.4, bytestring >= 0.10.0.2 && < 0.11, case-insensitive >= 1.0.0.1 && < 1.2, - conduit >= 1.0.9.3 && < 1.1, + conduit >= 1.1 && < 1.2, + conduit-extra >= 1.1 && < 1.2, data-default >= 0.5.3 && < 0.6, http-types >= 0.8.2 && < 0.9, mtl >= 2.1.2 && < 2.2, From 893dfa48c8c95c3c0693dba678b0c2094190eb77 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Tue, 8 Apr 2014 14:13:08 -0500 Subject: [PATCH 114/179] Edit changelog --- changelog.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/changelog.md b/changelog.md index a510a217..4340b98f 100644 --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,7 @@ +## 0.7.2 + +* Bump lower bound on conduit, add conduit-extra to cabal build depends. + ## 0.7.1 * Default warp settings now use `setFdCacheDuration 0` to work around a warp From e58a6ba64a610e1cd764d65a6fa1479b8cc60150 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Wed, 9 Apr 2014 22:35:29 +0800 Subject: [PATCH 115/179] Allow case-insensitive 1.2.* --- scotty.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scotty.cabal b/scotty.cabal index 1fc88e38..8b461e85 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -72,7 +72,7 @@ Library base >= 4.3.1 && < 5, blaze-builder >= 0.3.3.0 && < 0.4, bytestring >= 0.10.0.2 && < 0.11, - case-insensitive >= 1.0.0.1 && < 1.2, + case-insensitive >= 1.0.0.1 && < 1.3, conduit >= 1.1 && < 1.2, conduit-extra >= 1.1 && < 1.2, data-default >= 0.5.3 && < 0.6, From 71519bd7807e61b8f225c3ec940bb2149a0e5f6c Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Wed, 9 Apr 2014 22:37:38 +0800 Subject: [PATCH 116/179] DRY up capture --- Web/Scotty/Route.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/Web/Scotty/Route.hs b/Web/Scotty/Route.hs index aba323e6..d45ff065 100644 --- a/Web/Scotty/Route.hs +++ b/Web/Scotty/Route.hs @@ -17,6 +17,7 @@ import Data.Conduit.List (consume) import Data.Either (partitionEithers) import Data.Maybe (fromMaybe) import Data.Monoid (mconcat) +import Data.String (fromString) import qualified Data.Text.Lazy as T import qualified Data.Text as TS @@ -164,7 +165,7 @@ regex pattern = Function $ \ req -> fmap (map (T.pack . show *** T.pack) . zip [ -- -- are equivalent. capture :: String -> RoutePattern -capture = Capture . T.pack +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 From 088605a163c024721f338187e2fba3540ef9da1b Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Thu, 10 Apr 2014 09:15:50 +0800 Subject: [PATCH 117/179] Add travis-ci config --- .travis.yml | 1 + 1 file changed, 1 insertion(+) create mode 100644 .travis.yml diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 00000000..999bd37b --- /dev/null +++ b/.travis.yml @@ -0,0 +1 @@ +language: haskell From 8005632b23dcea44d0a4d1e5b5a5ac12fc23c227 Mon Sep 17 00:00:00 2001 From: Robert Vollmert Date: Sat, 12 Apr 2014 15:14:04 +0200 Subject: [PATCH 118/179] Indent body of 'do' in README example. --- README.md | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/README.md b/README.md index db3cf888..f60d8fd5 100644 --- a/README.md +++ b/README.md @@ -9,9 +9,9 @@ import Web.Scotty import Data.Monoid (mconcat) main = scotty 3000 $ do -get "/:word" $ do - beam <- param "word" - html $ mconcat ["

Scotty, ", beam, " me up!

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

Scotty, ", beam, " me up!

"] ``` Scotty is the cheap and cheerful way to write RESTful, declarative web applications. From 571350ed399a73c52448cb25dccbf89c73fcd3ca Mon Sep 17 00:00:00 2001 From: Fujimura Daisuke Date: Sat, 12 Apr 2014 15:23:46 +0900 Subject: [PATCH 119/179] Ignore sandbox files --- .gitignore | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.gitignore b/.gitignore index c3cf5d4e..9997557d 100644 --- a/.gitignore +++ b/.gitignore @@ -3,3 +3,5 @@ dist/ *.o *.swp cabal-dev/ +.cabal-sandbox/ +cabal.sandbox.config From ff3a5215cd72ae0a6c942424227a817e016facb6 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Mon, 14 Apr 2014 12:59:23 -0500 Subject: [PATCH 120/179] 2 spaces to 4 --- README.md | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/README.md b/README.md index f60d8fd5..76857994 100644 --- a/README.md +++ b/README.md @@ -9,9 +9,9 @@ import Web.Scotty import Data.Monoid (mconcat) main = scotty 3000 $ do - get "/:word" $ do - beam <- param "word" - html $ mconcat ["

Scotty, ", beam, " me up!

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

Scotty, ", beam, " me up!

"] ``` Scotty is the cheap and cheerful way to write RESTful, declarative web applications. From e10ca24da3979296c0288e61c7bc97a7580ecadb Mon Sep 17 00:00:00 2001 From: Sergei Trofimovich Date: Sat, 24 May 2014 11:44:47 +0300 Subject: [PATCH 121/179] scotty.cabal: allow mtl-2.2, transformers-0.4 Signed-off-by: Sergei Trofimovich --- scotty.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/scotty.cabal b/scotty.cabal index 8b461e85..8debbff9 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -77,10 +77,10 @@ Library conduit-extra >= 1.1 && < 1.2, data-default >= 0.5.3 && < 0.6, http-types >= 0.8.2 && < 0.9, - mtl >= 2.1.2 && < 2.2, + mtl >= 2.1.2 && < 2.3, regex-compat >= 0.95.1 && < 0.96, text >= 0.11.3.1 && < 1.2, - transformers >= 0.3.0.0 && < 0.4, + transformers >= 0.3.0.0 && < 0.5, wai >= 2.0.0 && < 2.2, wai-extra >= 2.0.1 && < 2.2, warp >= 2.1.1 && < 2.2 From ccb09e3bff1f8ed2d069877fa0282aff99760630 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Wed, 28 May 2014 14:02:45 +0800 Subject: [PATCH 122/179] Bump version --- changelog.md | 4 ++++ scotty.cabal | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/changelog.md b/changelog.md index 4340b98f..f3e2625f 100644 --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,7 @@ +## 0.7.3 + +* Bump upper bound for `case-insensitive`, `mtl` and `transformers`. + ## 0.7.2 * Bump lower bound on conduit, add conduit-extra to cabal build depends. diff --git a/scotty.cabal b/scotty.cabal index 8debbff9..e734fcf0 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -1,5 +1,5 @@ Name: scotty -Version: 0.7.2 +Version: 0.7.3 Synopsis: Haskell web framework inspired by Ruby's Sinatra, using WAI and Warp Homepage: https://github.com/scotty-web/scotty Bug-reports: https://github.com/scotty-web/scotty/issues From 01bc32cea6ee09f15d600dcfe692aa0803bb4f11 Mon Sep 17 00:00:00 2001 From: Fujimura Daisuke Date: Sat, 12 Apr 2014 15:24:08 +0900 Subject: [PATCH 123/179] Setup Hspec --- scotty.cabal | 25 +++++++++++++++++++++++++ test/Spec.hs | 1 + 2 files changed, 26 insertions(+) create mode 100644 test/Spec.hs diff --git a/scotty.cabal b/scotty.cabal index e734fcf0..fc85714c 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -87,6 +87,31 @@ Library GHC-options: -Wall -fno-warn-orphans +test-suite spec + main-is: Spec.hs + type: exitcode-stdio-1.0 + hs-source-dirs: test + build-depends: aeson >= 0.6.2.1 && < 0.8, + base >= 4.3.1 && < 5, + blaze-builder >= 0.3.3.0 && < 0.4, + bytestring >= 0.10.0.2 && < 0.11, + case-insensitive >= 1.0.0.1 && < 1.3, + conduit >= 1.1 && < 1.2, + conduit-extra >= 1.1 && < 1.2, + data-default >= 0.5.3 && < 0.6, + http-types >= 0.8.2 && < 0.9, + hspec >= 1.9.2, + mtl >= 2.1.2 && < 2.2, + regex-compat >= 0.95.1 && < 0.96, + scotty, + text >= 0.11.3.1 && < 1.2, + transformers >= 0.3.0.0 && < 0.4, + wai >= 2.0.0 && < 2.2, + wai-extra >= 2.0.1 && < 2.2, + wai-test >= 2.0.0 && < 2.2, + warp >= 2.1.1 && < 2.2 + GHC-options: -Wall -fno-warn-orphans + source-repository head type: git location: git://github.com/scotty-web/scotty.git diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 index 00000000..a824f8c3 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} From e7f80cccb7325f44a0d9d4bfd2ac3618c59928dc Mon Sep 17 00:00:00 2001 From: Fujimura Daisuke Date: Sat, 12 Apr 2014 17:47:27 +0900 Subject: [PATCH 124/179] Add coveralls setting to travis.yml --- .travis.yml | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/.travis.yml b/.travis.yml index 999bd37b..6e5ae4dc 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1 +1,9 @@ language: haskell + +before_install: + - cabal install hpc-coveralls +script: + - cabal configure --enable-tests --enable-library-coverage && cabal build + - run-cabal-test --show-details=always +after_script: + - hpc-coveralls spec From 496974b81fa0b84acb7b3202cd26776631ef255b Mon Sep 17 00:00:00 2001 From: Fujimura Daisuke Date: Sat, 12 Apr 2014 17:47:33 +0900 Subject: [PATCH 125/179] Add specs for some basic scotty functions --- test/SpecHelper.hs | 72 ++++++++++++++++++++++++++++++++++ test/Web/ScottySpec.hs | 88 ++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 160 insertions(+) create mode 100644 test/SpecHelper.hs create mode 100644 test/Web/ScottySpec.hs diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs new file mode 100644 index 00000000..ca762a9d --- /dev/null +++ b/test/SpecHelper.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE OverloadedStrings #-} + +module SpecHelper + ( get + , post + , put + , delete + , patch + , request + , body + , status + , header + , headers + ) where + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import Data.Monoid (mempty) +import Network.HTTP.Types +import Network.Wai (Application, Request, requestMethod) +import Network.Wai.Test (SRequest (..), SResponse (..), + defaultRequest, runSession, setPath, + simpleBody, simpleHeaders, srequest) + +-- | Send GET request to given WAI application with given path +get :: Application -> BS.ByteString -> IO SResponse +get app path = request app methodGet path mempty + +-- | Send POST request to given WAI application with given path and body +post :: Application -> BS.ByteString -> LBS.ByteString -> IO SResponse +post app = request app methodPost + +-- | Send PUT request to given WAI application with given path and body +put :: Application -> BS.ByteString -> LBS.ByteString -> IO SResponse +put app = request app methodPut + +-- | Send DELETE request to given WAI application with given path +delete :: Application -> BS.ByteString -> IO SResponse +delete app path = request app methodDelete path mempty + +-- | Send PATCH request to given WAI application with given path and body +patch :: Application -> BS.ByteString -> LBS.ByteString -> IO SResponse +patch app = request app methodPatch + +-- | Return response body of given WAI reponse +body :: SResponse -> LBS.ByteString +body = simpleBody + +-- | Return header of given WAI reponse +header :: HeaderName -> SResponse -> Maybe BS.ByteString +header key response = lookup key (headers response) + +-- | Return all headers of given WAI reponse +headers :: SResponse -> ResponseHeaders +headers = simpleHeaders + +-- | Return response status of given WAI reponse +status :: SResponse -> Status +status = simpleStatus + +-- | Send request to given WAI application, with given HTTP method, path +-- and body +request :: Application -> Method -> BS.ByteString -> LBS.ByteString -> IO SResponse +request app method path requestBody = + runSession (srequest (SRequest request' requestBody)) app + where request' = defaultRequest + `setPath` path + `setMethod` method + +-- | Set given request method to the request +setMethod :: Request -> Method -> Request +setMethod req method = req { requestMethod = method } diff --git a/test/Web/ScottySpec.hs b/test/Web/ScottySpec.hs new file mode 100644 index 00000000..c5d60af0 --- /dev/null +++ b/test/Web/ScottySpec.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE OverloadedStrings #-} +module Web.ScottySpec (spec) where + +import qualified SpecHelper as Helper + +import Control.Applicative +import Control.Monad +import Data.Monoid (mconcat) +import Network.HTTP.Types +import Test.Hspec +import Web.Scotty + +spec :: Spec +spec = do + let availableMethods = [GET, POST, HEAD, PUT, DELETE, PATCH] + + describe "scotty" $ + it "should run a scotty application" pending + + describe "get" $ + it "should route GET request" $ do + app <- scottyApp $ get "/scotty" $ html "" + Helper.status <$> app `Helper.get` "/scotty" `shouldReturn` status200 + + describe "post" $ + it "should route POST request" $ do + app <- scottyApp $ post "/scotty" $ html "" + Helper.status <$> Helper.post app "/scotty" "" `shouldReturn` status200 + + describe "put" $ + it "should route PUT request" $ do + app <- scottyApp $ put "/scotty" $ html "" + Helper.status <$> Helper.put app "/scotty" "" `shouldReturn` status200 + + describe "delete" $ + it "should route DELETE request" $ do + app <- scottyApp $ delete "/scotty" $ html "" + Helper.status <$> Helper.delete app "/scotty" `shouldReturn` status200 + + describe "patch" $ + it "should route PATCH request" $ do + app <- scottyApp $ patch "/scotty" $ html "" + Helper.status <$> Helper.patch app "/scotty" "" `shouldReturn` status200 + + describe "addroute" $ -- TODO The name should be `addRoute`. + it ("should route " ++ show availableMethods ++ " request") $ + forM_ availableMethods $ \(method) -> do + app <- scottyApp $ + addroute method "/scotty" $ html "" + Helper.status <$> Helper.request app (renderStdMethod method) "/scotty" "" + `shouldReturn` status200 + + describe "matchAny" $ + it ("should route " ++ show availableMethods ++ " request") $ + forM_ availableMethods $ \(method) -> do + app <- scottyApp $ + matchAny "/scotty" $ html "" + Helper.status <$> Helper.request app (renderStdMethod method) "/scotty" "" + `shouldReturn` status200 + + describe "notFound" $ + it "should route all request" $ do + app <- scottyApp $ + notFound $ html "routed to not found" + Helper.body <$> Helper.get app "/somewhere" + `shouldReturn` "routed to not found" + + describe "param" $ + it "should return query parameter with given key" $ do + app <- scottyApp $ + get "/search" $ do + query <- param "query" + html $ mconcat ["

", query, "

"] + Helper.body <$> app `Helper.get` "/search?query=haskell" + `shouldReturn` "

haskell

" + + describe "html" $ do + it "should return response in text/html" $ do + app <- scottyApp $ + get "/scotty" $ html "

scotty

" + Helper.header "Content-Type" <$> app `Helper.get` "/scotty" + `shouldReturn` Just "text/html" + + it "should return given string as html" $ do + app <- scottyApp $ + get "/scotty" $ html "

scotty

" + Helper.body <$> app `Helper.get` "/scotty" + `shouldReturn` "

scotty

" From 2b9a2179c43499092f8edd705c72a1e559ebe88c Mon Sep 17 00:00:00 2001 From: Fujimura Daisuke Date: Sat, 12 Apr 2014 17:53:53 +0900 Subject: [PATCH 126/179] Add travis.ci and coveralls badge to readme --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 76857994..7c7fbc94 100644 --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -# Scotty +# Scotty [![Build Status](https://travis-ci.org/scotty-web/scotty.svg)](https://travis-ci.org/scotty-web/scotty)[![Coverage Status](https://coveralls.io/repos/scotty-web/scotty/badge.png)](https://coveralls.io/r/scotty-web/scotty) A Haskell web framework inspired by Ruby's Sinatra, using WAI and Warp. From b37c5e69123d12c4e9e3f46087988ac275dc948a Mon Sep 17 00:00:00 2001 From: Fujimura Daisuke Date: Thu, 29 May 2014 17:53:17 +0900 Subject: [PATCH 127/179] Remove TODO and pending spec --- test/Web/ScottySpec.hs | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/test/Web/ScottySpec.hs b/test/Web/ScottySpec.hs index c5d60af0..95fa3698 100644 --- a/test/Web/ScottySpec.hs +++ b/test/Web/ScottySpec.hs @@ -14,9 +14,6 @@ spec :: Spec spec = do let availableMethods = [GET, POST, HEAD, PUT, DELETE, PATCH] - describe "scotty" $ - it "should run a scotty application" pending - describe "get" $ it "should route GET request" $ do app <- scottyApp $ get "/scotty" $ html "" @@ -42,7 +39,7 @@ spec = do app <- scottyApp $ patch "/scotty" $ html "" Helper.status <$> Helper.patch app "/scotty" "" `shouldReturn` status200 - describe "addroute" $ -- TODO The name should be `addRoute`. + describe "addroute" $ it ("should route " ++ show availableMethods ++ " request") $ forM_ availableMethods $ \(method) -> do app <- scottyApp $ From e1c4465259ea5ecb7e0b0f00d311e4b7ae4557c8 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Thu, 29 May 2014 19:11:07 +0800 Subject: [PATCH 128/179] Clean up test dependencies --- scotty.cabal | 24 ++++++------------------ 1 file changed, 6 insertions(+), 18 deletions(-) diff --git a/scotty.cabal b/scotty.cabal index fc85714c..e6aa1f11 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -91,25 +91,13 @@ test-suite spec main-is: Spec.hs type: exitcode-stdio-1.0 hs-source-dirs: test - build-depends: aeson >= 0.6.2.1 && < 0.8, - base >= 4.3.1 && < 5, - blaze-builder >= 0.3.3.0 && < 0.4, - bytestring >= 0.10.0.2 && < 0.11, - case-insensitive >= 1.0.0.1 && < 1.3, - conduit >= 1.1 && < 1.2, - conduit-extra >= 1.1 && < 1.2, - data-default >= 0.5.3 && < 0.6, - http-types >= 0.8.2 && < 0.9, + build-depends: base, + bytestring, + http-types, + wai, hspec >= 1.9.2, - mtl >= 2.1.2 && < 2.2, - regex-compat >= 0.95.1 && < 0.96, - scotty, - text >= 0.11.3.1 && < 1.2, - transformers >= 0.3.0.0 && < 0.4, - wai >= 2.0.0 && < 2.2, - wai-extra >= 2.0.1 && < 2.2, - wai-test >= 2.0.0 && < 2.2, - warp >= 2.1.1 && < 2.2 + wai-test >= 2.0.0, + scotty GHC-options: -Wall -fno-warn-orphans source-repository head From 275cfe240cad3d533245f627de6017c69081cb4e Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Fri, 30 May 2014 10:08:43 +0800 Subject: [PATCH 129/179] wai-middleware-static: Allow mtl-0.2.* --- wai-middleware-static/wai-middleware-static.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/wai-middleware-static/wai-middleware-static.cabal b/wai-middleware-static/wai-middleware-static.cabal index c4c961c5..5e9a080c 100644 --- a/wai-middleware-static/wai-middleware-static.cabal +++ b/wai-middleware-static/wai-middleware-static.cabal @@ -29,7 +29,7 @@ Library directory >= 1.2.0.1 && < 1.3, filepath >= 1.3.0.1 && < 1.4, http-types >= 0.8.2 && < 0.9, - mtl >= 2.1.2 && < 2.2, + mtl >= 2.1.2 && < 2.3, text >= 0.11.3.1 && < 1.2, wai >= 2.0.0 && < 2.2 From f211b8e0b00a35aca2b520220cf3e9fe7f54ba09 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Fri, 30 May 2014 11:13:35 +0800 Subject: [PATCH 130/179] wai-middleware-static: Bump version --- wai-middleware-static/changelog.md | 3 +++ wai-middleware-static/wai-middleware-static.cabal | 2 +- 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/wai-middleware-static/changelog.md b/wai-middleware-static/changelog.md index cd0b4651..e9a6b7b3 100644 --- a/wai-middleware-static/changelog.md +++ b/wai-middleware-static/changelog.md @@ -1,3 +1,6 @@ +## 0.5.0.1 + * Bump upper bound for `mtl` + ## 0.5.0.0 * Add `isNotAbsolute` policy and change `static` and `staticPolicy` to diff --git a/wai-middleware-static/wai-middleware-static.cabal b/wai-middleware-static/wai-middleware-static.cabal index 5e9a080c..6e5fbf05 100644 --- a/wai-middleware-static/wai-middleware-static.cabal +++ b/wai-middleware-static/wai-middleware-static.cabal @@ -1,5 +1,5 @@ Name: wai-middleware-static -Version: 0.5.0.0 +Version: 0.5.0.1 Synopsis: WAI middleware that serves requests to static files. Homepage: https://github.com/scotty-web/scotty Bug-reports: https://github.com/scotty-web/scotty/issues From 2ed02fa5d3628eeb89122ffafd2328be2c31cec3 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Fri, 30 May 2014 11:34:20 +0800 Subject: [PATCH 131/179] Exclude test directory for coveralls --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 6e5ae4dc..e9b28d71 100644 --- a/.travis.yml +++ b/.travis.yml @@ -6,4 +6,4 @@ script: - cabal configure --enable-tests --enable-library-coverage && cabal build - run-cabal-test --show-details=always after_script: - - hpc-coveralls spec + - hpc-coveralls --exclude-dir=test spec From a8dbce63ee2d45d8864b25fdabe246c055b1b488 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Fri, 30 May 2014 11:54:03 +0800 Subject: [PATCH 132/179] Show coverall stats for master --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 7c7fbc94..e435d9d2 100644 --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -# Scotty [![Build Status](https://travis-ci.org/scotty-web/scotty.svg)](https://travis-ci.org/scotty-web/scotty)[![Coverage Status](https://coveralls.io/repos/scotty-web/scotty/badge.png)](https://coveralls.io/r/scotty-web/scotty) +# Scotty [![Build Status](https://travis-ci.org/scotty-web/scotty.svg)](https://travis-ci.org/scotty-web/scotty)[![Coverage Status](https://coveralls.io/repos/scotty-web/scotty/badge.png?branch=master)](https://coveralls.io/r/scotty-web/scotty?branch=master) A Haskell web framework inspired by Ruby's Sinatra, using WAI and Warp. From aedefd568a8083f6428b980d97ccc73e7e983a70 Mon Sep 17 00:00:00 2001 From: Ryan Desfosses Date: Fri, 30 May 2014 10:55:08 -0400 Subject: [PATCH 133/179] added default-language under test-suite spec --- scotty.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/scotty.cabal b/scotty.cabal index e6aa1f11..0c91fb19 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -90,6 +90,7 @@ Library test-suite spec main-is: Spec.hs type: exitcode-stdio-1.0 + default-language: Haskell2010 hs-source-dirs: test build-depends: base, bytestring, From d0eed6da84473863f1428915a5ef80ae1d2a2b0b Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Mon, 9 Jun 2014 13:48:17 -0500 Subject: [PATCH 134/179] Update to wai/wai-extra/warp 3.0 --- Network/Wai/Middleware/Static.hs | 16 ++++---- Web/Scotty.hs | 21 +++++----- Web/Scotty/Action.hs | 13 +++---- Web/Scotty/Route.hs | 38 ++++++++++++------- Web/Scotty/Trans.hs | 10 ++--- Web/Scotty/Types.hs | 13 +++---- Web/Scotty/Util.hs | 5 ++- changelog.md | 11 +++++- scotty.cabal | 12 +++--- wai-middleware-static/changelog.md | 9 ++++- .../wai-middleware-static.cabal | 4 +- 11 files changed, 86 insertions(+), 66 deletions(-) diff --git a/Network/Wai/Middleware/Static.hs b/Network/Wai/Middleware/Static.hs index 059e05b7..6d744b92 100644 --- a/Network/Wai/Middleware/Static.hs +++ b/Network/Wai/Middleware/Static.hs @@ -125,18 +125,18 @@ static = staticPolicy mempty staticPolicy :: Policy -> Middleware staticPolicy p = unsafeStaticPolicy $ noDots >-> isNotAbsolute >-> p --- | Serve static files subject to a 'Policy'. Unlike 'static' and 'staticPolicy', this +-- | Serve static files subject to a 'Policy'. Unlike 'static' and 'staticPolicy', this -- has no policies enabled by default, and is hence insecure. unsafeStaticPolicy :: Policy -> Middleware -unsafeStaticPolicy p app req = - maybe (app req) +unsafeStaticPolicy p app req callback = + maybe (app req callback) (\fp -> do exists <- liftIO $ doesFileExist fp if exists - then return $ responseFile status200 - [("Content-Type", getMimeType fp)] - fp - Nothing - else app req) + then callback $ responseFile status200 + [("Content-Type", getMimeType fp)] + fp + Nothing + else app req callback) (tryPolicy p $ T.unpack $ T.intercalate "/" $ pathInfo req) type Ascii = B.ByteString diff --git a/Web/Scotty.hs b/Web/Scotty.hs index c6c302ba..5190c2ae 100644 --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -24,7 +24,7 @@ module Web.Scotty -- -- | 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, source, raw + , text, html, file, json, stream, raw -- ** Exceptions , raise, rescue, next, defaultHandler -- * Parsing Parameters @@ -36,21 +36,18 @@ module Web.Scotty -- With the exception of this, everything else better just import types. import qualified Web.Scotty.Trans as Trans -import Blaze.ByteString.Builder (Builder) - import Data.Aeson (FromJSON, ToJSON) import Data.ByteString.Lazy.Char8 (ByteString) -import Data.Conduit (Flush, Source) import Data.Text.Lazy (Text) import Network.HTTP.Types (Status, StdMethod) -import Network.Wai (Application, Middleware, Request) +import Network.Wai (Application, Middleware, Request, StreamingBody) import Network.Wai.Handler.Warp (Port) import Web.Scotty.Types (ScottyT, ActionT, Param, RoutePattern, Options, File) type ScottyM = ScottyT Text IO -type ActionM = ActionT Text IO +type ActionM = ActionT Text IO -- | Run a scotty application using the warp server. scotty :: Port -> ScottyM () -> IO () @@ -65,14 +62,14 @@ scottyOpts opts = Trans.scottyOptsT opts id id scottyApp :: ScottyM () -> IO Application scottyApp = Trans.scottyAppT id id --- | Global handler for uncaught exceptions. +-- | Global handler for uncaught exceptions. -- --- Uncaught exceptions normally become 500 responses. +-- Uncaught exceptions normally become 500 responses. -- You can use this to selectively override that behavior. -- -- Note: IO exceptions are lifted into Scotty exceptions by default. -- This has security implications, so you probably want to provide your --- own defaultHandler in production which does not send out the error +-- own defaultHandler in production which does not send out the error -- strings as 500 responses. defaultHandler :: (Text -> ActionM ()) -> ScottyM () defaultHandler = Trans.defaultHandler @@ -198,11 +195,11 @@ file = Trans.file json :: ToJSON a => a -> ActionM () json = Trans.json --- | Set the body of the response to a Source. Doesn't set the +-- | Set the body of the response to a StreamingBody. Doesn't set the -- \"Content-Type\" header, so you probably want to do that on your -- own with 'setHeader'. -source :: Source IO (Flush Builder) -> ActionM () -source = Trans.source +stream :: StreamingBody -> ActionM () +stream = Trans.stream -- | Set the body of the response to the given 'BL.ByteString' value. Doesn't set the -- \"Content-Type\" header, so you probably want to do that on your own with 'setHeader'. diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs index 4848e7d3..fa8f506e 100644 --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -20,8 +20,8 @@ module Web.Scotty.Action , request , rescue , setHeader - , source , status + , stream , text , Param , Parsable(..) @@ -29,7 +29,7 @@ module Web.Scotty.Action , runAction ) where -import Blaze.ByteString.Builder (Builder, fromLazyByteString) +import Blaze.ByteString.Builder (fromLazyByteString) import Control.Monad.Error import Control.Monad.Reader @@ -39,7 +39,6 @@ import qualified Data.Aeson as A import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.CaseInsensitive as CI -import Data.Conduit (Flush, Source) import Data.Default (def) import Data.Monoid (mconcat) import qualified Data.Text as ST @@ -139,7 +138,7 @@ headers :: (ScottyError e, Monad m) => ActionT e m [(T.Text, T.Text)] headers = do hs <- liftM requestHeaders request return [ ( strictByteStringToLazyText (CI.original k) - , strictByteStringToLazyText v) + , strictByteStringToLazyText v) | (k,v) <- hs ] -- | Get the request body. @@ -198,7 +197,7 @@ instance Parsable () where instance (Parsable a) => Parsable [a] where parseParam = parseParamList -instance Parsable Bool where +instance Parsable Bool where parseParam t = if t' == T.toCaseFold "true" then Right True else if t' == T.toCaseFold "false" @@ -262,8 +261,8 @@ json v = do -- | Set the body of the response to a Source. Doesn't set the -- \"Content-Type\" header, so you probably want to do that on your -- own with 'setHeader'. -source :: (ScottyError e, Monad m) => Source IO (Flush Builder) -> ActionT e m () -source = ActionT . MS.modify . setContent . ContentSource +stream :: (ScottyError e, Monad m) => StreamingBody -> ActionT e m () +stream = ActionT . MS.modify . setContent . ContentStream -- | Set the body of the response to the given 'BL.ByteString' value. Doesn't set the -- \"Content-Type\" header, so you probably want to do that on your diff --git a/Web/Scotty/Route.hs b/Web/Scotty/Route.hs index d45ff065..900e96bc 100644 --- a/Web/Scotty/Route.hs +++ b/Web/Scotty/Route.hs @@ -1,20 +1,17 @@ -{-# LANGUAGE OverloadedStrings, FlexibleContexts, FlexibleInstances, RankNTypes #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, LambdaCase, + OverloadedStrings, RankNTypes, ScopedTypeVariables #-} module Web.Scotty.Route ( get, post, put, delete, patch, addroute, matchAny, notFound, capture, regex, function, literal ) where import Control.Arrow ((***)) +import Control.Concurrent.MVar import Control.Monad.Error import qualified Control.Monad.State as MS import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as BL -import Data.Conduit (($$), (=$)) -import Data.Conduit.Binary (sourceLbs) -import Data.Conduit.Lazy (lazyConsume) -import Data.Conduit.List (consume) -import Data.Either (partitionEithers) import Data.Maybe (fromMaybe) import Data.Monoid (mconcat) import Data.String (fromString) @@ -108,26 +105,39 @@ matchRoute (Capture pat) req = go (T.split (=='/') pat) (T.split (=='/') $ path path :: Request -> T.Text path = T.fromStrict . TS.cons '/' . TS.intercalate "/" . pathInfo --- Stolen from wai-extra, modified to accept body as lazy ByteString +-- Stolen from wai-extra's Network.Wai.Parse, modified to accept body as list of Bytestrings. +-- Reason: WAI's requestBody is an IO action that returns the body as chunks. Once read, +-- they can't be read again. We read them into a lazy Bytestring, so Scotty user can get +-- the raw body, even if they also want to call wai-extra's parsing routines. parseRequestBody :: MonadIO m - => BL.ByteString + => [B.ByteString] -> Parse.BackEnd y -> Request -> m ([Parse.Param], [Parse.File y]) -parseRequestBody b s r = +parseRequestBody bl s r = case Parse.getRequestBodyType r of Nothing -> return ([], []) - Just rbt -> liftIO $ liftM partitionEithers $ sourceLbs b $$ Parse.conduitRequestBody s rbt =$ consume - -mkEnv :: MonadIO m => Request -> [Param] -> m ActionEnv + Just rbt -> do + mvar <- liftIO $ newMVar bl -- MVar is a bit of a hack so we don't have to inline + -- large portions of Network.Wai.Parse + let provider = takeMVar mvar >>= \case + [] -> putMVar mvar [] >> return B.empty + (b:bs) -> putMVar mvar bs >> return b + liftIO $ Parse.sinkRequestBody s rbt provider + +mkEnv :: forall m. MonadIO m => Request -> [Param] -> m ActionEnv mkEnv req captures = do - b <- liftIO $ liftM BL.fromChunks $ lazyConsume (requestBody req) + let rbody = requestBody req + takeAll :: ([B.ByteString] -> m [B.ByteString]) -> m [B.ByteString] + takeAll prefix = liftIO rbody >>= \ b -> if B.null b then prefix [] else takeAll (prefix . (b:)) + bs <- takeAll return - (formparams, fs) <- liftIO $ parseRequestBody b Parse.lbsBackEnd req + (formparams, fs) <- liftIO $ parseRequestBody bs Parse.lbsBackEnd req let convert (k, v) = (strictByteStringToLazyText k, strictByteStringToLazyText v) parameters = captures ++ map convert formparams ++ queryparams queryparams = parseEncodedParams $ rawQueryString req + b = BL.fromChunks bs return $ Env req parameters b [ (strictByteStringToLazyText k, fi) | (k,fi) <- fs ] diff --git a/Web/Scotty/Trans.hs b/Web/Scotty/Trans.hs index 20644b16..2e508c7d 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, source, raw + , text, html, file, json, stream, raw -- ** Exceptions , raise, rescue, next, defaultHandler, ScottyError(..) -- * Parsing Parameters @@ -89,21 +89,21 @@ scottyAppT :: (Monad m, Monad n) -> n Application scottyAppT runM runActionToIO defs = do s <- runM $ execStateT (runS defs) def - let rapp = runActionToIO . foldl (flip ($)) notFoundApp (routes s) + let rapp = \ req callback -> runActionToIO (foldl (flip ($)) notFoundApp (routes s) req) >>= callback return $ foldl (flip ($)) rapp (middlewares s) notFoundApp :: Monad m => Scotty.Application m notFoundApp _ = return $ responseBuilder status404 [("Content-Type","text/html")] $ fromByteString "

404: File Not Found!

" --- | Global handler for uncaught exceptions. +-- | Global handler for uncaught exceptions. -- --- Uncaught exceptions normally become 500 responses. +-- Uncaught exceptions normally become 500 responses. -- You can use this to selectively override that behavior. -- -- Note: IO exceptions are lifted into 'ScottyError's by 'stringError'. -- This has security implications, so you probably want to provide your --- own defaultHandler in production which does not send out the error +-- own defaultHandler in production which does not send out the error -- strings as 500 responses. defaultHandler :: Monad m => (e -> ActionT e m ()) -> ScottyT e m () defaultHandler f = ScottyT $ modify $ addHandler $ Just f diff --git a/Web/Scotty/Types.hs b/Web/Scotty/Types.hs index 0bc2b916..c2c2b851 100644 --- a/Web/Scotty/Types.hs +++ b/Web/Scotty/Types.hs @@ -10,7 +10,6 @@ import Control.Monad.Reader import Control.Monad.State import Data.ByteString.Lazy.Char8 (ByteString) -import qualified Data.Conduit as C import Data.Default (Default, def) import Data.Monoid (mempty) import Data.String (IsString(..)) @@ -42,7 +41,7 @@ type Middleware m = Application m -> Application m type Application m = Request -> m Response --------------- Scotty Applications ----------------- -data ScottyState e m = +data ScottyState e m = ScottyState { middlewares :: [Wai.Middleware] , routes :: [Middleware m] , handler :: ErrorHandler e m @@ -72,7 +71,7 @@ data ActionError e = Redirect Text | ActionError e -- | In order to use a custom exception type (aside from 'Text'), you must --- define an instance of 'ScottyError' for that type. +-- define an instance of 'ScottyError' for that type. class ScottyError e where stringError :: String -> e showError :: e -> Text @@ -87,7 +86,7 @@ instance ScottyError e => ScottyError (ActionError e) where showError Next = pack "Next" showError (ActionError e) = showError e -instance ScottyError e => Error (ActionError e) where +instance ScottyError e => Error (ActionError e) where strMsg = stringError type ErrorHandler e m = Maybe (e -> ActionT e m ()) @@ -100,12 +99,12 @@ type File = (Text, FileInfo ByteString) data ActionEnv = Env { getReq :: Request , getParams :: [Param] , getBody :: ByteString - , getFiles :: [File] + , getFiles :: [File] } data Content = ContentBuilder Builder | ContentFile FilePath - | ContentSource (C.Source IO (C.Flush Builder)) + | ContentStream StreamingBody data ScottyResponse = SR { srStatus :: Status , srHeaders :: ResponseHeaders @@ -136,5 +135,5 @@ data RoutePattern = Capture Text | Literal Text | Function (Request -> Maybe [Param]) -instance IsString RoutePattern where +instance IsString RoutePattern where fromString = Capture . pack diff --git a/Web/Scotty/Util.hs b/Web/Scotty/Util.hs index 968424ee..002722d6 100644 --- a/Web/Scotty/Util.hs +++ b/Web/Scotty/Util.hs @@ -34,11 +34,14 @@ setHeaderWith f sr = sr { srHeaders = f (srHeaders sr) } setStatus :: Status -> ScottyResponse -> ScottyResponse setStatus s sr = sr { srStatus = s } +-- Note: we currently don't support responseRaw, which may be useful +-- for websockets. However, we always read the request body, which +-- 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 - ContentSource src -> responseSource s h src + ContentStream str -> responseStream s h str where s = srStatus sr h = srHeaders sr diff --git a/changelog.md b/changelog.md index f3e2625f..97201fda 100644 --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,12 @@ +## 0.8.0 + +* Upgrade to wai/wai-extra/warp 3.0 + +* No longer depend on conduit/conduit-extra + +* The `source` response method has been removed in favor of new `stream` response, + which matches changes in WAI 3.0. + ## 0.7.3 * Bump upper bound for `case-insensitive`, `mtl` and `transformers`. @@ -65,7 +74,7 @@ * Removed lambda action syntax. This will return when we have a better story for typesafe routes. -* `reqHeader :: Text -> ActionM Text` ==> +* `reqHeader :: Text -> ActionM Text` ==> `reqHeader :: Text -> ActionM (Maybe Text)` * New `raw` method to set body to a raw `ByteString` diff --git a/scotty.cabal b/scotty.cabal index 0c91fb19..fa8c8574 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -1,5 +1,5 @@ Name: scotty -Version: 0.7.3 +Version: 0.8.0 Synopsis: Haskell web framework inspired by Ruby's Sinatra, using WAI and Warp Homepage: https://github.com/scotty-web/scotty Bug-reports: https://github.com/scotty-web/scotty/issues @@ -73,17 +73,15 @@ Library blaze-builder >= 0.3.3.0 && < 0.4, bytestring >= 0.10.0.2 && < 0.11, case-insensitive >= 1.0.0.1 && < 1.3, - conduit >= 1.1 && < 1.2, - conduit-extra >= 1.1 && < 1.2, data-default >= 0.5.3 && < 0.6, http-types >= 0.8.2 && < 0.9, mtl >= 2.1.2 && < 2.3, regex-compat >= 0.95.1 && < 0.96, text >= 0.11.3.1 && < 1.2, transformers >= 0.3.0.0 && < 0.5, - wai >= 2.0.0 && < 2.2, - wai-extra >= 2.0.1 && < 2.2, - warp >= 2.1.1 && < 2.2 + wai >= 3.0.0 && < 3.1, + wai-extra >= 3.0.0 && < 3.1, + warp >= 3.0.0 && < 3.1 GHC-options: -Wall -fno-warn-orphans @@ -97,7 +95,7 @@ test-suite spec http-types, wai, hspec >= 1.9.2, - wai-test >= 2.0.0, + wai-extra >= 3.0.0, scotty GHC-options: -Wall -fno-warn-orphans diff --git a/wai-middleware-static/changelog.md b/wai-middleware-static/changelog.md index e9a6b7b3..488bd90f 100644 --- a/wai-middleware-static/changelog.md +++ b/wai-middleware-static/changelog.md @@ -1,9 +1,14 @@ +## 0.6.0 + +* Update to wai 3.0 + ## 0.5.0.1 - * Bump upper bound for `mtl` + +* Bump upper bound for `mtl` ## 0.5.0.0 -* Add `isNotAbsolute` policy and change `static` and `staticPolicy` to +* Add `isNotAbsolute` policy and change `static` and `staticPolicy` to use `noDots` and `isNotAbsolute` policies by default. (Thanks to Nick Hibberd!) * Add `unsafeStaticPolicy`, which behaves as the old insecure `staticPolicy` behaved. diff --git a/wai-middleware-static/wai-middleware-static.cabal b/wai-middleware-static/wai-middleware-static.cabal index 6e5fbf05..0f312031 100644 --- a/wai-middleware-static/wai-middleware-static.cabal +++ b/wai-middleware-static/wai-middleware-static.cabal @@ -1,5 +1,5 @@ Name: wai-middleware-static -Version: 0.5.0.1 +Version: 0.6.0 Synopsis: WAI middleware that serves requests to static files. Homepage: https://github.com/scotty-web/scotty Bug-reports: https://github.com/scotty-web/scotty/issues @@ -31,7 +31,7 @@ Library http-types >= 0.8.2 && < 0.9, mtl >= 2.1.2 && < 2.3, text >= 0.11.3.1 && < 1.2, - wai >= 2.0.0 && < 2.2 + wai >= 3.0.0 && < 3.1 GHC-options: -Wall -fno-warn-orphans From 458d54e71acf4b31256d5608d87f335541afc7ab Mon Sep 17 00:00:00 2001 From: alexbiehl Date: Tue, 10 Jun 2014 08:54:38 +0200 Subject: [PATCH 135/179] source in terms of stream --- Web/Scotty.hs | 11 ++++++++++- Web/Scotty/Action.hs | 15 +++++++++++++++ Web/Scotty/Trans.hs | 2 +- scotty.cabal | 1 + 4 files changed, 27 insertions(+), 2 deletions(-) diff --git a/Web/Scotty.hs b/Web/Scotty.hs index 5190c2ae..38e2ebf3 100644 --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -24,7 +24,7 @@ module Web.Scotty -- -- | 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, source, raw -- ** Exceptions , raise, rescue, next, defaultHandler -- * Parsing Parameters @@ -39,6 +39,8 @@ import qualified Web.Scotty.Trans as Trans import Data.Aeson (FromJSON, ToJSON) import Data.ByteString.Lazy.Char8 (ByteString) import Data.Text.Lazy (Text) +import Blaze.ByteString.Builder (Builder) +import Data.Conduit (Flush, Source) import Network.HTTP.Types (Status, StdMethod) import Network.Wai (Application, Middleware, Request, StreamingBody) @@ -201,6 +203,13 @@ json = Trans.json stream :: StreamingBody -> ActionM () stream = Trans.stream +-- | Set the body of the response to a Source. Doesn't set the +-- \"Content-Type\" header, so you probably want to do that on your +-- own with 'setHeader'. (Deprecated, use stream instead) +source :: Source IO (Flush Builder) -> ActionM () +source = Trans.source +{-# DEPRECATED source "Use stream instead. This will be removed in the next release." #-} + -- | Set the body of the response to the given 'BL.ByteString' value. Doesn't set the -- \"Content-Type\" header, so you probably want to do that on your own with 'setHeader'. raw :: ByteString -> ActionM () diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs index fa8f506e..e8788689 100644 --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -22,6 +22,7 @@ module Web.Scotty.Action , setHeader , status , stream + , source -- Deprecated , text , Param , Parsable(..) @@ -48,6 +49,10 @@ import Data.Text.Lazy.Encoding (encodeUtf8) import Network.HTTP.Types import Network.Wai +import Blaze.ByteString.Builder (Builder) +import Data.Conduit +import qualified Data.Conduit.List as CL + import Web.Scotty.Types import Web.Scotty.Util @@ -264,6 +269,16 @@ json v = do stream :: (ScottyError e, Monad m) => StreamingBody -> ActionT e m () stream = ActionT . MS.modify . setContent . ContentStream +-- | Set the body of the response to a Source. Doesn't set the +-- \"Content-Type\" header, so you probably want to do that on your +-- own with 'setHeader'. (Deprecated, use stream instead) +source :: (ScottyError e, Monad m) => Source IO (Flush Builder) -> ActionT e m () +source src = stream $ \send flush -> src $$ CL.mapM_ (\mbuilder -> + case mbuilder of + Chunk b -> send b + Flush -> flush) +{-# DEPRECATED source "Use stream instead. This will be removed in the next release." #-} + -- | Set the body of the response to the given 'BL.ByteString' value. Doesn't set the -- \"Content-Type\" header, so you probably want to do that on your -- own with 'setHeader'. diff --git a/Web/Scotty/Trans.hs b/Web/Scotty/Trans.hs index 2e508c7d..ce9f3f76 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, source, raw -- ** Exceptions , raise, rescue, next, defaultHandler, ScottyError(..) -- * Parsing Parameters diff --git a/scotty.cabal b/scotty.cabal index fa8c8574..50a03a1a 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -73,6 +73,7 @@ Library blaze-builder >= 0.3.3.0 && < 0.4, bytestring >= 0.10.0.2 && < 0.11, case-insensitive >= 1.0.0.1 && < 1.3, + conduit >= 1.1 && < 1.2, data-default >= 0.5.3 && < 0.6, http-types >= 0.8.2 && < 0.9, mtl >= 2.1.2 && < 2.3, From e4ec454562cdd8c4f1af9eaa62922bfc337c0741 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Tue, 10 Jun 2014 09:03:34 -0500 Subject: [PATCH 136/179] Update changelog --- changelog.md | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/changelog.md b/changelog.md index 97201fda..7c702af0 100644 --- a/changelog.md +++ b/changelog.md @@ -2,14 +2,14 @@ * Upgrade to wai/wai-extra/warp 3.0 -* No longer depend on conduit/conduit-extra +* No longer depend on conduit-extra. -* The `source` response method has been removed in favor of new `stream` response, - which matches changes in WAI 3.0. +* The `source` response method has been deprecated in favor + of a new `stream` response, matching changes in WAI 3.0. ## 0.7.3 -* Bump upper bound for `case-insensitive`, `mtl` and `transformers`. +* Bump upper bound for case-insensitive, mtl and transformers. ## 0.7.2 From a435446cca5160b53188a792f177dbf083e38f30 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Tue, 10 Jun 2014 09:09:27 -0500 Subject: [PATCH 137/179] Remove deprecated reqHeader --- Web/Scotty.hs | 7 +------ Web/Scotty/Action.hs | 6 ------ Web/Scotty/Trans.hs | 2 +- changelog.md | 2 ++ 4 files changed, 4 insertions(+), 13 deletions(-) diff --git a/Web/Scotty.hs b/Web/Scotty.hs index 38e2ebf3..eff1d426 100644 --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -17,7 +17,7 @@ module Web.Scotty -- ** Route Patterns , capture, regex, function, literal -- ** Accessing the Request, Captures, and Query Parameters - , request, header, reqHeader, headers, body, param, params, jsonData, files + , request, header, headers, body, param, params, jsonData, files -- ** Modifying the Response and Redirecting , status, addHeader, setHeader, redirect -- ** Setting Response Body @@ -133,11 +133,6 @@ files = Trans.files header :: Text -> ActionM (Maybe Text) header = Trans.header --- | Get a request header. Header name is case-insensitive. (Deprecated in favor of `header`.) -reqHeader :: Text -> ActionM (Maybe Text) -reqHeader = Trans.header -{-# DEPRECATED reqHeader "Use header instead. reqHeader will be removed in the next release." #-} - -- | Get all the request headers. Header names are case-insensitive. headers :: ActionM [(Text, Text)] headers = Trans.headers diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs index e8788689..5ac1ec0f 100644 --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -16,7 +16,6 @@ module Web.Scotty.Action , raw , readEither , redirect - , reqHeader -- Deprecated , request , rescue , setHeader @@ -127,11 +126,6 @@ request = ActionT $ liftM getReq ask files :: (ScottyError e, Monad m) => ActionT e m [File] files = ActionT $ liftM getFiles ask --- | Get a request header. Header name is case-insensitive. (Deprecated in favor of `header`.) -reqHeader :: (ScottyError e, Monad m) => T.Text -> ActionT e m (Maybe T.Text) -reqHeader = header -{-# DEPRECATED reqHeader "Use header instead. This will be removed in the next release." #-} - -- | Get a request header. Header name is case-insensitive. header :: (ScottyError e, Monad m) => T.Text -> ActionT e m (Maybe T.Text) header k = do diff --git a/Web/Scotty/Trans.hs b/Web/Scotty/Trans.hs index ce9f3f76..e9fb7ac6 100644 --- a/Web/Scotty/Trans.hs +++ b/Web/Scotty/Trans.hs @@ -21,7 +21,7 @@ module Web.Scotty.Trans -- ** Route Patterns , capture, regex, function, literal -- ** Accessing the Request, Captures, and Query Parameters - , request, header, reqHeader, headers, body, param, params, jsonData, files + , request, header, headers, body, param, params, jsonData, files -- ** Modifying the Response and Redirecting , status, addHeader, setHeader, redirect -- ** Setting Response Body diff --git a/changelog.md b/changelog.md index 7c702af0..fbc8e310 100644 --- a/changelog.md +++ b/changelog.md @@ -7,6 +7,8 @@ * The `source` response method has been deprecated in favor of a new `stream` response, matching changes in WAI 3.0. +* Removed the deprecated `reqHeader` function. + ## 0.7.3 * Bump upper bound for case-insensitive, mtl and transformers. From 26f90137267df155ffd35c9e7490aaf689bbd607 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Tue, 10 Jun 2014 09:09:44 -0500 Subject: [PATCH 138/179] Fix deprecation pragmas/comments. Order imports. --- Web/Scotty.hs | 10 ++++++---- Web/Scotty/Action.hs | 18 ++++++++---------- Web/Scotty/Trans.hs | 13 +++++++++++-- 3 files changed, 25 insertions(+), 16 deletions(-) diff --git a/Web/Scotty.hs b/Web/Scotty.hs index eff1d426..9e94db2b 100644 --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -35,11 +35,13 @@ module Web.Scotty -- With the exception of this, everything else better just import types. import qualified Web.Scotty.Trans as Trans +import qualified Web.Scotty.Action as Action -- for 'source', to avoid deprecation warning on Trans.source + +import Blaze.ByteString.Builder (Builder) import Data.Aeson (FromJSON, ToJSON) import Data.ByteString.Lazy.Char8 (ByteString) import Data.Text.Lazy (Text) -import Blaze.ByteString.Builder (Builder) import Data.Conduit (Flush, Source) import Network.HTTP.Types (Status, StdMethod) @@ -200,10 +202,10 @@ stream = Trans.stream -- | Set the body of the response to a Source. Doesn't set the -- \"Content-Type\" header, so you probably want to do that on your --- own with 'setHeader'. (Deprecated, use stream instead) +-- own with 'setHeader'. source :: Source IO (Flush Builder) -> ActionM () -source = Trans.source -{-# DEPRECATED source "Use stream instead. This will be removed in the next release." #-} +source = Action.source +{-# DEPRECATED source "Use 'stream' instead. This will be removed in the next release." #-} -- | Set the body of the response to the given 'BL.ByteString' value. Doesn't set the -- \"Content-Type\" header, so you probably want to do that on your own with 'setHeader'. diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs index 5ac1ec0f..518457a0 100644 --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -29,7 +29,7 @@ module Web.Scotty.Action , runAction ) where -import Blaze.ByteString.Builder (fromLazyByteString) +import Blaze.ByteString.Builder (Builder, fromLazyByteString) import Control.Monad.Error import Control.Monad.Reader @@ -39,19 +39,17 @@ import qualified Data.Aeson as A import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.CaseInsensitive as CI -import Data.Default (def) -import Data.Monoid (mconcat) +import Data.Conduit +import qualified Data.Conduit.List as CL +import Data.Default (def) +import Data.Monoid (mconcat) import qualified Data.Text as ST import qualified Data.Text.Lazy as T -import Data.Text.Lazy.Encoding (encodeUtf8) +import Data.Text.Lazy.Encoding (encodeUtf8) import Network.HTTP.Types import Network.Wai -import Blaze.ByteString.Builder (Builder) -import Data.Conduit -import qualified Data.Conduit.List as CL - import Web.Scotty.Types import Web.Scotty.Util @@ -265,13 +263,13 @@ stream = ActionT . MS.modify . setContent . ContentStream -- | Set the body of the response to a Source. Doesn't set the -- \"Content-Type\" header, so you probably want to do that on your --- own with 'setHeader'. (Deprecated, use stream instead) +-- own with 'setHeader'. source :: (ScottyError e, Monad m) => Source IO (Flush Builder) -> ActionT e m () source src = stream $ \send flush -> src $$ CL.mapM_ (\mbuilder -> case mbuilder of Chunk b -> send b Flush -> flush) -{-# DEPRECATED source "Use stream instead. This will be removed in the next release." #-} +-- Deprecated, but pragma is in Web.Scotty and Web.Scotty.Trans -- | Set the body of the response to the given 'BL.ByteString' value. Doesn't set the -- \"Content-Type\" header, so you probably want to do that on your diff --git a/Web/Scotty/Trans.hs b/Web/Scotty/Trans.hs index e9fb7ac6..8825d29c 100644 --- a/Web/Scotty/Trans.hs +++ b/Web/Scotty/Trans.hs @@ -39,23 +39,32 @@ module Web.Scotty.Trans , ScottyT, ActionT ) where -import Blaze.ByteString.Builder (fromByteString) +import Blaze.ByteString.Builder (Builder, fromByteString) import Control.Monad (when) import Control.Monad.State (execStateT, modify) import Control.Monad.IO.Class +import Data.Conduit (Flush, Source) import Data.Default (def) import Network.HTTP.Types (status404) import Network.Wai import Network.Wai.Handler.Warp (Port, runSettings, setPort, getPort) -import Web.Scotty.Action +import Web.Scotty.Action hiding (source) +import qualified Web.Scotty.Action as Action import Web.Scotty.Route import Web.Scotty.Types hiding (Application, Middleware) import qualified Web.Scotty.Types as Scotty +-- | Set the body of the response to a Source. Doesn't set the +-- \"Content-Type\" header, so you probably want to do that on your +-- own with 'setHeader'. +source :: (ScottyError e, Monad m) => Source IO (Flush Builder) -> ActionT e m () +source = Action.source +{-# DEPRECATED source "Use 'stream' instead. This will be removed in the next release." #-} + -- | Run a scotty application using the warp server. -- NB: scotty p === scottyT p id id scottyT :: (Monad m, MonadIO n) From 57db0b098f1cb475eced6926474bbccd70bf6361 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Tue, 10 Jun 2014 23:22:16 +0800 Subject: [PATCH 139/179] Remove trailing whitespace --- examples/globalstate.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/examples/globalstate.hs b/examples/globalstate.hs index fa6170e3..790119aa 100644 --- a/examples/globalstate.hs +++ b/examples/globalstate.hs @@ -10,7 +10,7 @@ module Main where import Control.Concurrent.STM -import Control.Monad.Reader +import Control.Monad.Reader import Data.Default import Data.String @@ -30,9 +30,9 @@ instance Default AppState where -- to provide the state to _every action_, and save the resulting -- state, using an MVar. This means actions would be blocking, -- effectively meaning only one request could be serviced at a time. --- The 'ReaderT' solution means only actions that actually modify +-- The 'ReaderT' solution means only actions that actually modify -- the state need to block/retry. --- +-- -- Also note: your monad must be an instance of 'MonadIO' for -- Scotty to use it. newtype WebM a = WebM { runWebM :: ReaderT (TVar AppState) IO a } From 6a32f7b8cf04345940aee9b15084e17b24b9301f Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Tue, 10 Jun 2014 23:50:08 +0800 Subject: [PATCH 140/179] Add IRC channel --- README.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/README.md b/README.md index e435d9d2..e4b997fd 100644 --- a/README.md +++ b/README.md @@ -31,4 +31,8 @@ Setting phasers to stun... (port 3000) (ctrl-c to quit) As for the name: Sinatra + Warp = Scotty. +### Development & Support + +Open an issue on GitHub or join `#hspec` on Freenode. + Copyright (c) 2012-2013 Andrew Farmer From c2e9edee80206a28b0e25f7f0e216ec2942e86ca Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Tue, 10 Jun 2014 12:07:55 -0500 Subject: [PATCH 141/179] Change IRC channel to #scotty --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index e4b997fd..6e5ecc40 100644 --- a/README.md +++ b/README.md @@ -33,6 +33,6 @@ As for the name: Sinatra + Warp = Scotty. ### Development & Support -Open an issue on GitHub or join `#hspec` on Freenode. +Open an issue on GitHub or join `#scotty` on Freenode. Copyright (c) 2012-2013 Andrew Farmer From 1186eaa6a1e9147647729c0723ad73caa4d56c53 Mon Sep 17 00:00:00 2001 From: Sebastian Date: Mon, 24 Mar 2014 23:21:44 +0100 Subject: [PATCH 142/179] added MonadBase MonadTransControl and MonadBaseControl instances --- Web/Scotty/Types.hs | 24 +++++++++++++++++++++++- scotty.cabal | 2 ++ 2 files changed, 25 insertions(+), 1 deletion(-) diff --git a/Web/Scotty/Types.hs b/Web/Scotty/Types.hs index c2c2b851..8349993b 100644 --- a/Web/Scotty/Types.hs +++ b/Web/Scotty/Types.hs @@ -1,13 +1,16 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, MultiParamTypeClasses #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, TypeFamilies #-} module Web.Scotty.Types where import Blaze.ByteString.Builder (Builder) import Control.Applicative import qualified Control.Exception as E +import Control.Monad.Base (MonadBase, liftBase, liftBaseDefault) import Control.Monad.Error import Control.Monad.Reader import Control.Monad.State +import Control.Monad.Trans.Control (MonadBaseControl, StM, liftBaseWith, restoreM, ComposeSt, defaultLiftBaseWith, defaultRestoreM, MonadTransControl, StT, liftWith, restoreT) + import Data.ByteString.Lazy.Char8 (ByteString) import Data.Default (Default, def) @@ -129,6 +132,25 @@ instance (ScottyError e, Monad m) => MonadError (ActionError e) (ActionT e m) wh throwError = ActionT . throwError catchError (ActionT m) f = ActionT (catchError m (runAM . f)) + + +instance (MonadBase b m, ScottyError e) => MonadBase b (ActionT e m) where + liftBase = liftBaseDefault + + +instance (ScottyError e) => MonadTransControl (ActionT e) where + newtype StT (ActionT e) a = StAction {unStAction :: StT (StateT ScottyResponse) (StT (ReaderT ActionEnv) (StT (ErrorT (ActionError e)) a))} + liftWith = \f -> + ActionT $ liftWith $ \run -> + liftWith $ \run' -> + liftWith $ \run'' -> + f $ liftM StAction . run'' . run' . run . runAM + restoreT = ActionT . restoreT . restoreT . restoreT . liftM unStAction + +instance (ScottyError e, MonadBaseControl b m) => MonadBaseControl b (ActionT e m) where + newtype StM (ActionT e m) a = STMAction {unStMActionT :: ComposeSt (ActionT e) m a} + liftBaseWith = defaultLiftBaseWith STMAction + restoreM = defaultRestoreM unStMActionT ------------------ Scotty Routes -------------------- data RoutePattern = Capture Text diff --git a/scotty.cabal b/scotty.cabal index 50a03a1a..b32e7b7d 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -77,9 +77,11 @@ Library data-default >= 0.5.3 && < 0.6, http-types >= 0.8.2 && < 0.9, mtl >= 2.1.2 && < 2.3, + monad-control >= 0.3.2.3 && < 0.4, regex-compat >= 0.95.1 && < 0.96, text >= 0.11.3.1 && < 1.2, transformers >= 0.3.0.0 && < 0.5, + transformers-base >= 0.4.1 && < 0.5, wai >= 3.0.0 && < 3.1, wai-extra >= 3.0.0 && < 3.1, warp >= 3.0.0 && < 3.1 From 5d11dc8ef6838b7d80d114e063187c27de006dcb Mon Sep 17 00:00:00 2001 From: Sebastian Date: Tue, 10 Jun 2014 21:05:02 +0200 Subject: [PATCH 143/179] added test case for MonadBaseControl instance --- scotty.cabal | 1 + test/Web/ScottySpec.hs | 7 +++++++ 2 files changed, 8 insertions(+) diff --git a/scotty.cabal b/scotty.cabal index b32e7b7d..c6c181bd 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -96,6 +96,7 @@ test-suite spec build-depends: base, bytestring, http-types, + lifted-base, wai, hspec >= 1.9.2, wai-extra >= 3.0.0, diff --git a/test/Web/ScottySpec.hs b/test/Web/ScottySpec.hs index 95fa3698..92b14e7f 100644 --- a/test/Web/ScottySpec.hs +++ b/test/Web/ScottySpec.hs @@ -9,6 +9,8 @@ import Data.Monoid (mconcat) import Network.HTTP.Types import Test.Hspec import Web.Scotty +import qualified Control.Exception.Lifted as EL +import qualified Control.Exception as E spec :: Spec spec = do @@ -83,3 +85,8 @@ spec = do get "/scotty" $ html "

scotty

" Helper.body <$> app `Helper.get` "/scotty" `shouldReturn` "

scotty

" + + describe "lifted-base" $ + it "should not return the default exception handler" $ do + app <- scottyApp $ get "/" $ ((undefined) `EL.catch` ((\_ -> html "") :: E.SomeException -> ActionM ())) + Helper.status <$> app `Helper.get` "/" `shouldReturn` status200 From 06eb001a23831a823b8173edad39c4baf65d38be Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Tue, 17 Jun 2014 11:11:23 +0800 Subject: [PATCH 144/179] Export internal types --- Web/Scotty.hs | 2 +- Web/Scotty/Action.hs | 2 +- Web/Scotty/{ => Internal}/Types.hs | 2 +- Web/Scotty/Route.hs | 2 +- Web/Scotty/Trans.hs | 4 ++-- Web/Scotty/Util.hs | 2 +- changelog.md | 4 ++++ scotty.cabal | 2 +- 8 files changed, 12 insertions(+), 8 deletions(-) rename Web/Scotty/{ => Internal}/Types.hs (99%) diff --git a/Web/Scotty.hs b/Web/Scotty.hs index 9e94db2b..db1bb9a5 100644 --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -48,7 +48,7 @@ import Network.HTTP.Types (Status, StdMethod) import Network.Wai (Application, Middleware, Request, StreamingBody) import Network.Wai.Handler.Warp (Port) -import Web.Scotty.Types (ScottyT, ActionT, Param, RoutePattern, Options, File) +import Web.Scotty.Internal.Types (ScottyT, ActionT, Param, RoutePattern, Options, File) type ScottyM = ScottyT Text IO type ActionM = ActionT Text IO diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs index 518457a0..c9fa9952 100644 --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -50,7 +50,7 @@ import Data.Text.Lazy.Encoding (encodeUtf8) import Network.HTTP.Types import Network.Wai -import Web.Scotty.Types +import Web.Scotty.Internal.Types import Web.Scotty.Util -- Nothing indicates route failed (due to Next) and pattern matching should continue. diff --git a/Web/Scotty/Types.hs b/Web/Scotty/Internal/Types.hs similarity index 99% rename from Web/Scotty/Types.hs rename to Web/Scotty/Internal/Types.hs index c2c2b851..069e6807 100644 --- a/Web/Scotty/Types.hs +++ b/Web/Scotty/Internal/Types.hs @@ -1,5 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, MultiParamTypeClasses #-} -module Web.Scotty.Types where +module Web.Scotty.Internal.Types where import Blaze.ByteString.Builder (Builder) diff --git a/Web/Scotty/Route.hs b/Web/Scotty/Route.hs index 900e96bc..6ed05c46 100644 --- a/Web/Scotty/Route.hs +++ b/Web/Scotty/Route.hs @@ -25,7 +25,7 @@ import qualified Network.Wai.Parse as Parse hiding (parseRequestBody) import qualified Text.Regex as Regex import Web.Scotty.Action -import Web.Scotty.Types +import Web.Scotty.Internal.Types import Web.Scotty.Util -- | get = 'addroute' 'GET' diff --git a/Web/Scotty/Trans.hs b/Web/Scotty/Trans.hs index 8825d29c..7c66bc9a 100644 --- a/Web/Scotty/Trans.hs +++ b/Web/Scotty/Trans.hs @@ -55,8 +55,8 @@ import Network.Wai.Handler.Warp (Port, runSettings, setPort, getPort) import Web.Scotty.Action hiding (source) import qualified Web.Scotty.Action as Action import Web.Scotty.Route -import Web.Scotty.Types hiding (Application, Middleware) -import qualified Web.Scotty.Types as Scotty +import Web.Scotty.Internal.Types hiding (Application, Middleware) +import qualified Web.Scotty.Internal.Types as Scotty -- | Set the body of the response to a Source. Doesn't set the -- \"Content-Type\" header, so you probably want to do that on your diff --git a/Web/Scotty/Util.hs b/Web/Scotty/Util.hs index 002722d6..4233b304 100644 --- a/Web/Scotty/Util.hs +++ b/Web/Scotty/Util.hs @@ -17,7 +17,7 @@ import qualified Data.ByteString as B import qualified Data.Text.Lazy as T import qualified Data.Text.Encoding as ES -import Web.Scotty.Types +import Web.Scotty.Internal.Types lazyTextToStrictByteString :: T.Text -> B.ByteString lazyTextToStrictByteString = ES.encodeUtf8 . T.toStrict diff --git a/changelog.md b/changelog.md index fbc8e310..94ff54c4 100644 --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,7 @@ +## 0.8.1 + +* Export internal types + ## 0.8.0 * Upgrade to wai/wai-extra/warp 3.0 diff --git a/scotty.cabal b/scotty.cabal index 50a03a1a..5b465ae9 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -63,9 +63,9 @@ Extra-source-files: Library Exposed-modules: Web.Scotty Web.Scotty.Trans + Web.Scotty.Internal.Types other-modules: Web.Scotty.Action Web.Scotty.Route - Web.Scotty.Types Web.Scotty.Util default-language: Haskell2010 build-depends: aeson >= 0.6.2.1 && < 0.8, From 677b7b6e74aec8d77133cf50b289358b82ac62db Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Thu, 19 Jun 2014 15:23:58 +0800 Subject: [PATCH 145/179] Remove trailing whitespace --- Web/Scotty/Internal/Types.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/Web/Scotty/Internal/Types.hs b/Web/Scotty/Internal/Types.hs index 2f209e1d..a3ee61d3 100644 --- a/Web/Scotty/Internal/Types.hs +++ b/Web/Scotty/Internal/Types.hs @@ -132,19 +132,19 @@ instance (ScottyError e, Monad m) => MonadError (ActionError e) (ActionT e m) wh throwError = ActionT . throwError catchError (ActionT m) f = ActionT (catchError m (runAM . f)) - - + + instance (MonadBase b m, ScottyError e) => MonadBase b (ActionT e m) where liftBase = liftBaseDefault - + instance (ScottyError e) => MonadTransControl (ActionT e) where newtype StT (ActionT e) a = StAction {unStAction :: StT (StateT ScottyResponse) (StT (ReaderT ActionEnv) (StT (ErrorT (ActionError e)) a))} - liftWith = \f -> - ActionT $ liftWith $ \run -> - liftWith $ \run' -> - liftWith $ \run'' -> - f $ liftM StAction . run'' . run' . run . runAM + liftWith = \f -> + ActionT $ liftWith $ \run -> + liftWith $ \run' -> + liftWith $ \run'' -> + f $ liftM StAction . run'' . run' . run . runAM restoreT = ActionT . restoreT . restoreT . restoreT . liftM unStAction instance (ScottyError e, MonadBaseControl b m) => MonadBaseControl b (ActionT e m) where From 0499927345f1b146a72b0afb6892832f77b57978 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Thu, 19 Jun 2014 15:24:44 +0800 Subject: [PATCH 146/179] Bump version and update changelog --- changelog.md | 2 ++ scotty.cabal | 2 +- 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/changelog.md b/changelog.md index 94ff54c4..f4f64064 100644 --- a/changelog.md +++ b/changelog.md @@ -1,6 +1,8 @@ ## 0.8.1 * Export internal types +* Added `MonadBase`, `MonadTransControl` and `MonadBaseControl` instances for + `ActionT` ## 0.8.0 diff --git a/scotty.cabal b/scotty.cabal index 4b975548..7072606c 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -1,5 +1,5 @@ Name: scotty -Version: 0.8.0 +Version: 0.8.1 Synopsis: Haskell web framework inspired by Ruby's Sinatra, using WAI and Warp Homepage: https://github.com/scotty-web/scotty Bug-reports: https://github.com/scotty-web/scotty/issues From a513c248ad0326dc371c77805dad4694b3a30508 Mon Sep 17 00:00:00 2001 From: RyanGlScott Date: Wed, 16 Jul 2014 11:23:41 -0500 Subject: [PATCH 147/179] Use Control.Monad.Except if mtl >= 2.2.1 --- Web/Scotty/Action.hs | 12 ++++++++++-- Web/Scotty/Internal/Types.hs | 16 +++++++++++++++- Web/Scotty/Route.hs | 8 ++++++-- 3 files changed, 31 insertions(+), 5 deletions(-) diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs index c9fa9952..b7264421 100644 --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, RankNTypes #-} +{-# LANGUAGE CPP, OverloadedStrings, RankNTypes #-} module Web.Scotty.Action ( addHeader , body @@ -31,7 +31,11 @@ module Web.Scotty.Action import Blaze.ByteString.Builder (Builder, fromLazyByteString) -import Control.Monad.Error +#if MIN_VERSION_mtl(2,2,1) +import Control.Monad.Except +#else +import Control.Monad.Error +#endif import Control.Monad.Reader import qualified Control.Monad.State as MS @@ -59,7 +63,11 @@ runAction :: (ScottyError e, Monad m) => ErrorHandler e m -> ActionEnv -> Action runAction h env action = do (e,r) <- flip MS.runStateT def $ flip runReaderT env +#if MIN_VERSION_mtl(2,2,1) + $ runExceptT +#else $ runErrorT +#endif $ runAM $ action `catchError` (defH h) return $ either (const Nothing) (const $ Just $ mkResponse r) e diff --git a/Web/Scotty/Internal/Types.hs b/Web/Scotty/Internal/Types.hs index a3ee61d3..b723cff7 100644 --- a/Web/Scotty/Internal/Types.hs +++ b/Web/Scotty/Internal/Types.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, TypeFamilies #-} +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, TypeFamilies #-} module Web.Scotty.Internal.Types where import Blaze.ByteString.Builder (Builder) @@ -6,7 +6,11 @@ import Blaze.ByteString.Builder (Builder) import Control.Applicative import qualified Control.Exception as E import Control.Monad.Base (MonadBase, liftBase, liftBaseDefault) +#if MIN_VERSION_mtl(2,2,1) +import Control.Monad.Except +#else import Control.Monad.Error +#endif import Control.Monad.Reader import Control.Monad.State import Control.Monad.Trans.Control (MonadBaseControl, StM, liftBaseWith, restoreM, ComposeSt, defaultLiftBaseWith, defaultRestoreM, MonadTransControl, StT, liftWith, restoreT) @@ -89,8 +93,10 @@ instance ScottyError e => ScottyError (ActionError e) where showError Next = pack "Next" showError (ActionError e) = showError e +#if !MIN_VERSION_mtl(2,2,1) instance ScottyError e => Error (ActionError e) where strMsg = stringError +#endif type ErrorHandler e m = Maybe (e -> ActionT e m ()) @@ -117,7 +123,11 @@ data ScottyResponse = SR { srStatus :: Status instance Default ScottyResponse where def = SR status200 [] (ContentBuilder mempty) +#if MIN_VERSION_mtl(2,2,1) +newtype ActionT e m a = ActionT { runAM :: ExceptT (ActionError e) (ReaderT ActionEnv (StateT ScottyResponse m)) a } +#else newtype ActionT e m a = ActionT { runAM :: ErrorT (ActionError e) (ReaderT ActionEnv (StateT ScottyResponse m)) a } +#endif deriving ( Functor, Applicative, Monad ) instance (MonadIO m, ScottyError e) => MonadIO (ActionT e m) where @@ -139,7 +149,11 @@ instance (MonadBase b m, ScottyError e) => MonadBase b (ActionT e m) where instance (ScottyError e) => MonadTransControl (ActionT e) where +#if MIN_VERSION_mtl(2,2,1) + newtype StT (ActionT e) a = StAction {unStAction :: StT (StateT ScottyResponse) (StT (ReaderT ActionEnv) (StT (ExceptT (ActionError e)) a))} +#else newtype StT (ActionT e) a = StAction {unStAction :: StT (StateT ScottyResponse) (StT (ReaderT ActionEnv) (StT (ErrorT (ActionError e)) a))} +#endif liftWith = \f -> ActionT $ liftWith $ \run -> liftWith $ \run' -> diff --git a/Web/Scotty/Route.hs b/Web/Scotty/Route.hs index 6ed05c46..0fc14404 100644 --- a/Web/Scotty/Route.hs +++ b/Web/Scotty/Route.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts, FlexibleInstances, LambdaCase, +{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, LambdaCase, OverloadedStrings, RankNTypes, ScopedTypeVariables #-} module Web.Scotty.Route ( get, post, put, delete, patch, addroute, matchAny, notFound, @@ -7,7 +7,11 @@ module Web.Scotty.Route import Control.Arrow ((***)) import Control.Concurrent.MVar -import Control.Monad.Error +#if MIN_VERSION_mtl(2,2,1) +import Control.Monad.Except +#else +import Control.Monad.Error +#endif import qualified Control.Monad.State as MS import qualified Data.ByteString.Char8 as B From 50371e99e97c69da1391a9c77646dce011c05a23 Mon Sep 17 00:00:00 2001 From: RyanGlScott Date: Wed, 16 Jul 2014 11:27:14 -0500 Subject: [PATCH 148/179] Improved indentation --- Web/Scotty/Action.hs | 12 ++++++------ Web/Scotty/Route.hs | 20 ++++++++++---------- 2 files changed, 16 insertions(+), 16 deletions(-) diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs index b7264421..e9575712 100644 --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -29,14 +29,14 @@ module Web.Scotty.Action , runAction ) where -import Blaze.ByteString.Builder (Builder, fromLazyByteString) +import Blaze.ByteString.Builder (Builder, fromLazyByteString) #if MIN_VERSION_mtl(2,2,1) import Control.Monad.Except #else import Control.Monad.Error #endif -import Control.Monad.Reader +import Control.Monad.Reader import qualified Control.Monad.State as MS import qualified Data.Aeson as A @@ -51,11 +51,11 @@ import qualified Data.Text as ST import qualified Data.Text.Lazy as T import Data.Text.Lazy.Encoding (encodeUtf8) -import Network.HTTP.Types -import Network.Wai +import Network.HTTP.Types +import Network.Wai -import Web.Scotty.Internal.Types -import Web.Scotty.Util +import Web.Scotty.Internal.Types +import Web.Scotty.Util -- Nothing indicates route failed (due to Next) and pattern matching should continue. -- Just indicates a successful response. diff --git a/Web/Scotty/Route.hs b/Web/Scotty/Route.hs index 0fc14404..95daea2b 100644 --- a/Web/Scotty/Route.hs +++ b/Web/Scotty/Route.hs @@ -5,8 +5,8 @@ module Web.Scotty.Route capture, regex, function, literal ) where -import Control.Arrow ((***)) -import Control.Concurrent.MVar +import Control.Arrow ((***)) +import Control.Concurrent.MVar #if MIN_VERSION_mtl(2,2,1) import Control.Monad.Except #else @@ -16,21 +16,21 @@ import qualified Control.Monad.State as MS import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as BL -import Data.Maybe (fromMaybe) -import Data.Monoid (mconcat) -import Data.String (fromString) +import Data.Maybe (fromMaybe) +import Data.Monoid (mconcat) +import Data.String (fromString) import qualified Data.Text.Lazy as T import qualified Data.Text as TS -import Network.HTTP.Types -import Network.Wai (Request(..)) +import Network.HTTP.Types +import Network.Wai (Request(..)) import qualified Network.Wai.Parse as Parse hiding (parseRequestBody) import qualified Text.Regex as Regex -import Web.Scotty.Action -import Web.Scotty.Internal.Types -import Web.Scotty.Util +import Web.Scotty.Action +import Web.Scotty.Internal.Types +import Web.Scotty.Util -- | get = 'addroute' 'GET' get :: (ScottyError e, MonadIO m) => RoutePattern -> ActionT e m () -> ScottyT e m () From c923697a27d48a0efaa6a899a8a04c2f64622b3b Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Thu, 17 Jul 2014 10:20:45 -0500 Subject: [PATCH 149/179] Add link to wiki in README.md --- README.md | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/README.md b/README.md index 6e5ecc40..586d6668 100644 --- a/README.md +++ b/README.md @@ -31,8 +31,14 @@ Setting phasers to stun... (port 3000) (ctrl-c to quit) As for the name: Sinatra + Warp = Scotty. +### More Information + +Tutorials and related projects can be found in the Scotty wiki: + +https://github.com/scotty-web/scotty/wiki + ### Development & Support Open an issue on GitHub or join `#scotty` on Freenode. -Copyright (c) 2012-2013 Andrew Farmer +Copyright (c) 2012-2014 Andrew Farmer From b215712f53127504d84d119a11f2a00739fc397f Mon Sep 17 00:00:00 2001 From: Luke Taylor Date: Sun, 20 Jul 2014 00:30:48 +0100 Subject: [PATCH 150/179] Relax aeson upper bound --- scotty.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scotty.cabal b/scotty.cabal index 7072606c..49f42598 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -68,7 +68,7 @@ Library Web.Scotty.Route Web.Scotty.Util default-language: Haskell2010 - build-depends: aeson >= 0.6.2.1 && < 0.8, + build-depends: aeson >= 0.6.2.1 && < 0.9, base >= 4.3.1 && < 5, blaze-builder >= 0.3.3.0 && < 0.4, bytestring >= 0.10.0.2 && < 0.11, From 04bf942a9fe904c64fb2e353619c5c4dd0d9acc8 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Sun, 20 Jul 2014 20:14:20 +0800 Subject: [PATCH 151/179] Bump version and update changelog --- changelog.md | 7 +++++++ scotty.cabal | 2 +- 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/changelog.md b/changelog.md index f4f64064..74b6b09f 100644 --- a/changelog.md +++ b/changelog.md @@ -1,6 +1,13 @@ +## 0.8.2 + +* Bump `aeson` upper bound + +* Fix `mtl` related deprecation warnings + ## 0.8.1 * Export internal types + * Added `MonadBase`, `MonadTransControl` and `MonadBaseControl` instances for `ActionT` diff --git a/scotty.cabal b/scotty.cabal index 49f42598..21baba83 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -1,5 +1,5 @@ Name: scotty -Version: 0.8.1 +Version: 0.8.2 Synopsis: Haskell web framework inspired by Ruby's Sinatra, using WAI and Warp Homepage: https://github.com/scotty-web/scotty Bug-reports: https://github.com/scotty-web/scotty/issues From c38d83042358a836d4a70f8c22c084061b6edaaf Mon Sep 17 00:00:00 2001 From: James Fisher Date: Mon, 11 Aug 2014 08:44:08 +0100 Subject: [PATCH 152/179] Set charset=utf-8 in Content-Type when serving UTF-8 plaintext and HTML Update test for `html` function, to assert new Content-Type header Add an equivalent test for `text` function Add sample non-ASCII text to test for UTF-8 encoding --- Web/Scotty/Action.hs | 8 ++++---- scotty.cabal | 1 + test/Web/ScottySpec.hs | 34 ++++++++++++++++++++++++++-------- 3 files changed, 31 insertions(+), 12 deletions(-) diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs index e9575712..ddd1f014 100644 --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -238,17 +238,17 @@ setHeader :: (ScottyError e, Monad m) => T.Text -> T.Text -> ActionT e m () setHeader k v = ActionT . MS.modify $ setHeaderWith $ replace (CI.mk $ lazyTextToStrictByteString k) (lazyTextToStrictByteString v) -- | Set the body of the response to the given 'T.Text' value. Also sets \"Content-Type\" --- header to \"text/plain\". +-- header to \"text/plain; charset=utf-8\". text :: (ScottyError e, Monad m) => T.Text -> ActionT e m () text t = do - setHeader "Content-Type" "text/plain" + setHeader "Content-Type" "text/plain; charset=utf-8" raw $ encodeUtf8 t -- | Set the body of the response to the given 'T.Text' value. Also sets \"Content-Type\" --- header to \"text/html\". +-- header to \"text/html; charset=utf-8\". html :: (ScottyError e, Monad m) => T.Text -> ActionT e m () html t = do - setHeader "Content-Type" "text/html" + setHeader "Content-Type" "text/html; charset=utf-8" raw $ encodeUtf8 t -- | Send a file as the response. Doesn't set the \"Content-Type\" header, so you probably diff --git a/scotty.cabal b/scotty.cabal index 21baba83..d2c246fb 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -95,6 +95,7 @@ test-suite spec hs-source-dirs: test build-depends: base, bytestring, + text, http-types, lifted-base, wai, diff --git a/test/Web/ScottySpec.hs b/test/Web/ScottySpec.hs index 92b14e7f..bf3eb6d4 100644 --- a/test/Web/ScottySpec.hs +++ b/test/Web/ScottySpec.hs @@ -5,7 +5,8 @@ import qualified SpecHelper as Helper import Control.Applicative import Control.Monad -import Data.Monoid (mconcat) +import Data.Monoid (mconcat) +import Data.Text.Lazy.Encoding (encodeUtf8) import Network.HTTP.Types import Test.Hspec import Web.Scotty @@ -73,18 +74,35 @@ spec = do Helper.body <$> app `Helper.get` "/search?query=haskell" `shouldReturn` "

haskell

" + describe "text" $ do + let + modernGreekText = "νέα ελληνικά" + app' = scottyApp $ get "/scotty" $ text modernGreekText + + it "should return response in text/plain encoded in utf-8" $ do + app <- app' + Helper.header "Content-Type" <$> app `Helper.get` "/scotty" + `shouldReturn` Just "text/plain; charset=utf-8" + + it "should return given string as text" $ do + app <- app' + Helper.body <$> app `Helper.get` "/scotty" + `shouldReturn` (encodeUtf8 modernGreekText) + describe "html" $ do - it "should return response in text/html" $ do - app <- scottyApp $ - get "/scotty" $ html "

scotty

" + let + russianLanguageTextInHtml = "

ру́сский язы́к

" + app' = scottyApp $ get "/scotty" $ html russianLanguageTextInHtml + + it "should return response in text/html encoded in utf-8" $ do + app <- app' Helper.header "Content-Type" <$> app `Helper.get` "/scotty" - `shouldReturn` Just "text/html" + `shouldReturn` Just "text/html; charset=utf-8" it "should return given string as html" $ do - app <- scottyApp $ - get "/scotty" $ html "

scotty

" + app <- app' Helper.body <$> app `Helper.get` "/scotty" - `shouldReturn` "

scotty

" + `shouldReturn` (encodeUtf8 russianLanguageTextInHtml) describe "lifted-base" $ it "should not return the default exception handler" $ do From 21e5580bff0588e3906f8a43e224ee26264f45c4 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Wed, 13 Aug 2014 15:08:33 -0500 Subject: [PATCH 153/179] Remove wai-middleware-static (in its own repo now) --- Network/Wai/Middleware/Static.hs | 218 ------------------ wai-middleware-static/LICENSE | 30 --- .../Network/Wai/Middleware/Static.hs | 1 - wai-middleware-static/Setup.hs | 2 - wai-middleware-static/changelog.md | 16 -- .../wai-middleware-static.cabal | 40 ---- 6 files changed, 307 deletions(-) delete mode 100644 Network/Wai/Middleware/Static.hs delete mode 100644 wai-middleware-static/LICENSE delete mode 120000 wai-middleware-static/Network/Wai/Middleware/Static.hs delete mode 100644 wai-middleware-static/Setup.hs delete mode 100644 wai-middleware-static/changelog.md delete mode 100644 wai-middleware-static/wai-middleware-static.cabal diff --git a/Network/Wai/Middleware/Static.hs b/Network/Wai/Middleware/Static.hs deleted file mode 100644 index 6d744b92..00000000 --- a/Network/Wai/Middleware/Static.hs +++ /dev/null @@ -1,218 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} --- | Serve static files, subject to a policy that can filter or --- modify incoming URIs. The flow is: --- --- incoming request URI ==> policies ==> exists? ==> respond --- --- If any of the polices fail, or the file doesn't --- exist, then the middleware gives up and calls the inner application. --- If the file is found, the middleware chooses a content type based --- on the file extension and returns the file contents as the response. -module Network.Wai.Middleware.Static - ( -- * Middlewares - static, staticPolicy, unsafeStaticPolicy - , -- * Policies - Policy, (<|>), (>->), policy, predicate - , addBase, addSlash, contains, hasPrefix, hasSuffix, noDots, isNotAbsolute, only - , -- * Utilities - tryPolicy - ) where - -import Control.Monad.Trans (liftIO) -import qualified Data.ByteString as B -import Data.List -import qualified Data.Map as M -import Data.Maybe (fromMaybe) -import Data.Monoid -import qualified Data.Text as T - -import Network.HTTP.Types (status200) -import System.Directory (doesFileExist) -import qualified System.FilePath as FP - -import Network.Wai - --- | Take an incoming URI and optionally modify or filter it. --- The result will be treated as a filepath. -newtype Policy = Policy { tryPolicy :: String -> Maybe String -- ^ Run a policy - } - --- | Note: --- 'mempty' == @policy Just@ (the always accepting policy) --- 'mappend' == @>->@ (policy sequencing) -instance Monoid Policy where - mempty = policy Just - mappend p1 p2 = policy (maybe Nothing (tryPolicy p2) . tryPolicy p1) - --- | Lift a function into a 'Policy' -policy :: (String -> Maybe String) -> Policy -policy = Policy - --- | Lift a predicate into a 'Policy' -predicate :: (String -> Bool) -> Policy -predicate p = policy (\s -> if p s then Just s else Nothing) - --- | Sequence two policies. They are run from left to right. (Note: this is `mappend`) -infixr 5 >-> -(>->) :: Policy -> Policy -> Policy -(>->) = mappend - --- | Choose between two policies. If the first fails, run the second. -infixr 4 <|> -(<|>) :: Policy -> Policy -> Policy -p1 <|> p2 = policy (\s -> maybe (tryPolicy p2 s) Just (tryPolicy p1 s)) - --- | Add a base path to the URI --- --- > staticPolicy (addBase "/home/user/files") --- --- GET \"foo\/bar\" looks for \"\/home\/user\/files\/foo\/bar\" --- -addBase :: String -> Policy -addBase b = policy (Just . (b FP.)) - --- | Add an initial slash to to the URI, if not already present. --- --- > staticPolicy addSlash --- --- GET \"foo\/bar\" looks for \"\/foo\/bar\" -addSlash :: Policy -addSlash = policy slashOpt - where slashOpt s@('/':_) = Just s - slashOpt s = Just ('/':s) - --- | Accept only URIs with given suffix -hasSuffix :: String -> Policy -hasSuffix = predicate . isSuffixOf - --- | Accept only URIs with given prefix -hasPrefix :: String -> Policy -hasPrefix = predicate . isPrefixOf - --- | Accept only URIs containing given string -contains :: String -> Policy -contains = predicate . isInfixOf - --- | Reject URIs containing \"..\" -noDots :: Policy -noDots = predicate (not . isInfixOf "..") - --- | Reject URIs that are absolute paths -isNotAbsolute :: Policy -isNotAbsolute = predicate $ not . FP.isAbsolute - --- | Use URI as the key to an association list, rejecting those not found. --- The policy result is the matching value. --- --- > staticPolicy (only [("foo/bar", "/home/user/files/bar")]) --- --- GET \"foo\/bar\" looks for \"\/home\/user\/files\/bar\" --- GET \"baz\/bar\" doesn't match anything --- -only :: [(String,String)] -> Policy -only al = policy (flip lookup al) - --- | Serve static files out of the application root (current directory). --- If file is found, it is streamed to the client and no further middleware is run. --- --- Note: for security reasons, this uses the 'noDots' and 'isNotAbsolute' policy by default. -static :: Middleware -static = staticPolicy mempty - --- | Serve static files subject to a 'Policy' --- --- Note: for security reasons, this uses the 'noDots' and 'isNotAbsolute' policy by default. -staticPolicy :: Policy -> Middleware -staticPolicy p = unsafeStaticPolicy $ noDots >-> isNotAbsolute >-> p - --- | Serve static files subject to a 'Policy'. Unlike 'static' and 'staticPolicy', this --- has no policies enabled by default, and is hence insecure. -unsafeStaticPolicy :: Policy -> Middleware -unsafeStaticPolicy p app req callback = - maybe (app req callback) - (\fp -> do exists <- liftIO $ doesFileExist fp - if exists - then callback $ responseFile status200 - [("Content-Type", getMimeType fp)] - fp - Nothing - else app req callback) - (tryPolicy p $ T.unpack $ T.intercalate "/" $ pathInfo req) - -type Ascii = B.ByteString - -getMimeType :: FilePath -> Ascii -getMimeType = go . extensions - where go [] = defaultMimeType - go (ext:exts) = fromMaybe (go exts) $ M.lookup ext defaultMimeTypes - -extensions :: FilePath -> [String] -extensions [] = [] -extensions fp = case dropWhile (/= '.') fp of - [] -> [] - s -> let ext = tail s - in ext : extensions ext - -defaultMimeType :: Ascii -defaultMimeType = "application/octet-stream" - --- This list taken from snap-core's Snap.Util.FileServe -defaultMimeTypes :: M.Map String Ascii -defaultMimeTypes = M.fromList [ - ( "asc" , "text/plain" ), - ( "asf" , "video/x-ms-asf" ), - ( "asx" , "video/x-ms-asf" ), - ( "avi" , "video/x-msvideo" ), - ( "bz2" , "application/x-bzip" ), - ( "c" , "text/plain" ), - ( "class" , "application/octet-stream" ), - ( "conf" , "text/plain" ), - ( "cpp" , "text/plain" ), - ( "css" , "text/css" ), - ( "cxx" , "text/plain" ), - ( "dtd" , "text/xml" ), - ( "dvi" , "application/x-dvi" ), - ( "gif" , "image/gif" ), - ( "gz" , "application/x-gzip" ), - ( "hs" , "text/plain" ), - ( "htm" , "text/html" ), - ( "html" , "text/html" ), - ( "jar" , "application/x-java-archive" ), - ( "jpeg" , "image/jpeg" ), - ( "jpg" , "image/jpeg" ), - ( "js" , "text/javascript" ), - ( "json" , "application/json" ), - ( "log" , "text/plain" ), - ( "m3u" , "audio/x-mpegurl" ), - ( "mov" , "video/quicktime" ), - ( "mp3" , "audio/mpeg" ), - ( "mpeg" , "video/mpeg" ), - ( "mpg" , "video/mpeg" ), - ( "ogg" , "application/ogg" ), - ( "pac" , "application/x-ns-proxy-autoconfig" ), - ( "pdf" , "application/pdf" ), - ( "png" , "image/png" ), - ( "ps" , "application/postscript" ), - ( "qt" , "video/quicktime" ), - ( "sig" , "application/pgp-signature" ), - ( "spl" , "application/futuresplash" ), - ( "svg" , "image/svg+xml" ), - ( "swf" , "application/x-shockwave-flash" ), - ( "tar" , "application/x-tar" ), - ( "tar.bz2" , "application/x-bzip-compressed-tar" ), - ( "tar.gz" , "application/x-tgz" ), - ( "tbz" , "application/x-bzip-compressed-tar" ), - ( "text" , "text/plain" ), - ( "tgz" , "application/x-tgz" ), - ( "torrent" , "application/x-bittorrent" ), - ( "ttf" , "application/x-font-truetype" ), - ( "txt" , "text/plain" ), - ( "wav" , "audio/x-wav" ), - ( "wax" , "audio/x-ms-wax" ), - ( "wma" , "audio/x-ms-wma" ), - ( "wmv" , "video/x-ms-wmv" ), - ( "xbm" , "image/x-xbitmap" ), - ( "xml" , "text/xml" ), - ( "xpm" , "image/x-xpixmap" ), - ( "xwd" , "image/x-xwindowdump" ), - ( "zip" , "application/zip" ) ] diff --git a/wai-middleware-static/LICENSE b/wai-middleware-static/LICENSE deleted file mode 100644 index 23e45ba7..00000000 --- a/wai-middleware-static/LICENSE +++ /dev/null @@ -1,30 +0,0 @@ -Copyright (c)2012, Andrew Farmer - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Andrew Farmer nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/wai-middleware-static/Network/Wai/Middleware/Static.hs b/wai-middleware-static/Network/Wai/Middleware/Static.hs deleted file mode 120000 index 46d00b7f..00000000 --- a/wai-middleware-static/Network/Wai/Middleware/Static.hs +++ /dev/null @@ -1 +0,0 @@ -../../../../Network/Wai/Middleware/Static.hs \ No newline at end of file diff --git a/wai-middleware-static/Setup.hs b/wai-middleware-static/Setup.hs deleted file mode 100644 index 9a994af6..00000000 --- a/wai-middleware-static/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/wai-middleware-static/changelog.md b/wai-middleware-static/changelog.md deleted file mode 100644 index 488bd90f..00000000 --- a/wai-middleware-static/changelog.md +++ /dev/null @@ -1,16 +0,0 @@ -## 0.6.0 - -* Update to wai 3.0 - -## 0.5.0.1 - -* Bump upper bound for `mtl` - -## 0.5.0.0 - -* Add `isNotAbsolute` policy and change `static` and `staticPolicy` to - use `noDots` and `isNotAbsolute` policies by default. (Thanks to Nick Hibberd!) - -* Add `unsafeStaticPolicy`, which behaves as the old insecure `staticPolicy` behaved. - -* Add changelog diff --git a/wai-middleware-static/wai-middleware-static.cabal b/wai-middleware-static/wai-middleware-static.cabal deleted file mode 100644 index 0f312031..00000000 --- a/wai-middleware-static/wai-middleware-static.cabal +++ /dev/null @@ -1,40 +0,0 @@ -Name: wai-middleware-static -Version: 0.6.0 -Synopsis: WAI middleware that serves requests to static files. -Homepage: https://github.com/scotty-web/scotty -Bug-reports: https://github.com/scotty-web/scotty/issues -License: BSD3 -License-file: LICENSE -Author: Andrew Farmer -Maintainer: Andrew Farmer -Copyright: (c) 2012-2014 Andrew Farmer -Category: Web -Stability: experimental -Build-type: Simple -Cabal-version: >= 1.10 -Description: - WAI middleware that intercepts requests to static files and serves them - if they exist. - . - [WAI] - -Extra-source-files: changelog.md - -Library - Exposed-modules: Network.Wai.Middleware.Static - default-language: Haskell2010 - Build-depends: base >= 4.6.0.1 && < 5, - bytestring >= 0.10.0.2 && < 0.11, - containers >= 0.5.0.0 && < 0.6, - directory >= 1.2.0.1 && < 1.3, - filepath >= 1.3.0.1 && < 1.4, - http-types >= 0.8.2 && < 0.9, - mtl >= 2.1.2 && < 2.3, - text >= 0.11.3.1 && < 1.2, - wai >= 3.0.0 && < 3.1 - - GHC-options: -Wall -fno-warn-orphans - -source-repository head - type: git - location: git://github.com/scotty-web/scotty.git From 3e15ac6bd017ca8aa4a712cd307c34b3349eae1a Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Wed, 13 Aug 2014 15:08:50 -0500 Subject: [PATCH 154/179] cabal repl --- Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile b/Makefile index 9803250b..c955fc02 100644 --- a/Makefile +++ b/Makefile @@ -2,4 +2,4 @@ boot: cabal install --force-reinstalls ghci: - ghc --interactive -Wall Web/Scotty.hs + cabal repl From 7e43ba0ae52bbd1a6848b1a94d58aaead67eaf9c Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Wed, 13 Aug 2014 23:53:52 +0800 Subject: [PATCH 155/179] Use hspec-wai for specs + nicer spec descriptions --- scotty.cabal | 4 +- test/SpecHelper.hs | 72 ------------------ test/Web/ScottySpec.hs | 169 ++++++++++++++++++----------------------- 3 files changed, 76 insertions(+), 169 deletions(-) delete mode 100644 test/SpecHelper.hs diff --git a/scotty.cabal b/scotty.cabal index d2c246fb..7295f049 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -99,8 +99,8 @@ test-suite spec http-types, lifted-base, wai, - hspec >= 1.9.2, - wai-extra >= 3.0.0, + hspec2, + hspec-wai >= 0.3.0, scotty GHC-options: -Wall -fno-warn-orphans diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs deleted file mode 100644 index ca762a9d..00000000 --- a/test/SpecHelper.hs +++ /dev/null @@ -1,72 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module SpecHelper - ( get - , post - , put - , delete - , patch - , request - , body - , status - , header - , headers - ) where - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS -import Data.Monoid (mempty) -import Network.HTTP.Types -import Network.Wai (Application, Request, requestMethod) -import Network.Wai.Test (SRequest (..), SResponse (..), - defaultRequest, runSession, setPath, - simpleBody, simpleHeaders, srequest) - --- | Send GET request to given WAI application with given path -get :: Application -> BS.ByteString -> IO SResponse -get app path = request app methodGet path mempty - --- | Send POST request to given WAI application with given path and body -post :: Application -> BS.ByteString -> LBS.ByteString -> IO SResponse -post app = request app methodPost - --- | Send PUT request to given WAI application with given path and body -put :: Application -> BS.ByteString -> LBS.ByteString -> IO SResponse -put app = request app methodPut - --- | Send DELETE request to given WAI application with given path -delete :: Application -> BS.ByteString -> IO SResponse -delete app path = request app methodDelete path mempty - --- | Send PATCH request to given WAI application with given path and body -patch :: Application -> BS.ByteString -> LBS.ByteString -> IO SResponse -patch app = request app methodPatch - --- | Return response body of given WAI reponse -body :: SResponse -> LBS.ByteString -body = simpleBody - --- | Return header of given WAI reponse -header :: HeaderName -> SResponse -> Maybe BS.ByteString -header key response = lookup key (headers response) - --- | Return all headers of given WAI reponse -headers :: SResponse -> ResponseHeaders -headers = simpleHeaders - --- | Return response status of given WAI reponse -status :: SResponse -> Status -status = simpleStatus - --- | Send request to given WAI application, with given HTTP method, path --- and body -request :: Application -> Method -> BS.ByteString -> LBS.ByteString -> IO SResponse -request app method path requestBody = - runSession (srequest (SRequest request' requestBody)) app - where request' = defaultRequest - `setPath` path - `setMethod` method - --- | Set given request method to the request -setMethod :: Request -> Method -> Request -setMethod req method = req { requestMethod = method } diff --git a/test/Web/ScottySpec.hs b/test/Web/ScottySpec.hs index bf3eb6d4..215081f9 100644 --- a/test/Web/ScottySpec.hs +++ b/test/Web/ScottySpec.hs @@ -1,110 +1,89 @@ {-# LANGUAGE OverloadedStrings #-} -module Web.ScottySpec (spec) where +module Web.ScottySpec (main, spec) where -import qualified SpecHelper as Helper +import Test.Hspec +import Test.Hspec.Wai +import Network.Wai (Application) -import Control.Applicative import Control.Monad -import Data.Monoid (mconcat) -import Data.Text.Lazy.Encoding (encodeUtf8) +import Data.Char +import Data.String import Network.HTTP.Types -import Test.Hspec -import Web.Scotty import qualified Control.Exception.Lifted as EL import qualified Control.Exception as E +import Web.Scotty as Scotty hiding (get, post, put, patch, delete, request) +import qualified Web.Scotty as Scotty + +main :: IO () +main = hspec spec + +availableMethods :: [StdMethod] +availableMethods = [GET, POST, HEAD, PUT, PATCH, DELETE] + +withApp :: ScottyM () -> SpecWith Application -> Spec +withApp = with . scottyApp + spec :: Spec -spec = do - let availableMethods = [GET, POST, HEAD, PUT, DELETE, PATCH] - - describe "get" $ - it "should route GET request" $ do - app <- scottyApp $ get "/scotty" $ html "" - Helper.status <$> app `Helper.get` "/scotty" `shouldReturn` status200 - - describe "post" $ - it "should route POST request" $ do - app <- scottyApp $ post "/scotty" $ html "" - Helper.status <$> Helper.post app "/scotty" "" `shouldReturn` status200 - - describe "put" $ - it "should route PUT request" $ do - app <- scottyApp $ put "/scotty" $ html "" - Helper.status <$> Helper.put app "/scotty" "" `shouldReturn` status200 - - describe "delete" $ - it "should route DELETE request" $ do - app <- scottyApp $ delete "/scotty" $ html "" - Helper.status <$> Helper.delete app "/scotty" `shouldReturn` status200 - - describe "patch" $ - it "should route PATCH request" $ do - app <- scottyApp $ patch "/scotty" $ html "" - Helper.status <$> Helper.patch app "/scotty" "" `shouldReturn` status200 - - describe "addroute" $ - it ("should route " ++ show availableMethods ++ " request") $ - forM_ availableMethods $ \(method) -> do - app <- scottyApp $ - addroute method "/scotty" $ html "" - Helper.status <$> Helper.request app (renderStdMethod method) "/scotty" "" - `shouldReturn` status200 - - describe "matchAny" $ - it ("should route " ++ show availableMethods ++ " request") $ - forM_ availableMethods $ \(method) -> do - app <- scottyApp $ - matchAny "/scotty" $ html "" - Helper.status <$> Helper.request app (renderStdMethod method) "/scotty" "" - `shouldReturn` status200 - - describe "notFound" $ - it "should route all request" $ do - app <- scottyApp $ - notFound $ html "routed to not found" - Helper.body <$> Helper.get app "/somewhere" - `shouldReturn` "routed to not found" - - describe "param" $ - it "should return query parameter with given key" $ do - app <- scottyApp $ - get "/search" $ do - query <- param "query" - html $ mconcat ["

", query, "

"] - Helper.body <$> app `Helper.get` "/search?query=haskell" - `shouldReturn` "

haskell

" +spec = do + describe "ScottyM" $ do + forM_ [ + ("GET", Scotty.get, get) + , ("POST", Scotty.post, (`post` "")) + , ("PUT", Scotty.put, (`put` "")) + , ("PATCH", Scotty.patch, (`patch` "")) + , ("DELETE", Scotty.delete, delete) + ] $ \(method, route, makeRequest) -> do + describe (map toLower method) $ do + withApp (route "/scotty" $ html "") $ do + it ("adds route for " ++ method ++ " requests") $ do + makeRequest "/scotty" `shouldRespondWith` 200 + + describe "addroute" $ do + forM_ availableMethods $ \method -> do + withApp (addroute method "/scotty" $ html "") $ do + it ("can be used to add route for " ++ show method ++ " requests") $ do + request (renderStdMethod method) "/scotty" "" `shouldRespondWith` 200 + + describe "matchAny" $ do + withApp (matchAny "/scotty" $ html "") $ do + forM_ availableMethods $ \method -> do + it ("adds route that matches " ++ show method ++ " requests") $ do + request (renderStdMethod method) "/scotty" "" `shouldRespondWith` 200 + + describe "notFound" $ do + withApp (notFound $ html "my custom not found page") $ do + it "adds handler for requests that do not match any route" $ do + get "/somewhere" `shouldRespondWith` "my custom not found page" {matchStatus = 404} + + describe "ActionM" $ do + withApp (Scotty.get "/" $ (undefined `EL.catch` ((\_ -> html "") :: E.SomeException -> ActionM ()))) $ do + it "has a MonadBaseControl instance" $ do + get "/" `shouldRespondWith` 200 + + describe "param" $ do + withApp (Scotty.get "/search" $ param "query" >>= text) $ do + it "returns query parameter with given name" $ do + get "/search?query=haskell" `shouldRespondWith` "haskell" describe "text" $ do - let - modernGreekText = "νέα ελληνικά" - app' = scottyApp $ get "/scotty" $ text modernGreekText + let modernGreekText :: IsString a => a + modernGreekText = "νέα ελληνικά" - it "should return response in text/plain encoded in utf-8" $ do - app <- app' - Helper.header "Content-Type" <$> app `Helper.get` "/scotty" - `shouldReturn` Just "text/plain; charset=utf-8" + withApp (Scotty.get "/scotty" $ text modernGreekText) $ do + it "sets body to given text" $ do + get "/scotty" `shouldRespondWith` modernGreekText - it "should return given string as text" $ do - app <- app' - Helper.body <$> app `Helper.get` "/scotty" - `shouldReturn` (encodeUtf8 modernGreekText) + it "sets Content-Type header to \"text/plain; charset=utf-8\"" $ do + get "/scotty" `shouldRespondWith` 200 {matchHeaders = [("Content-Type", "text/plain; charset=utf-8")]} describe "html" $ do - let - russianLanguageTextInHtml = "

ру́сский язы́к

" - app' = scottyApp $ get "/scotty" $ html russianLanguageTextInHtml - - it "should return response in text/html encoded in utf-8" $ do - app <- app' - Helper.header "Content-Type" <$> app `Helper.get` "/scotty" - `shouldReturn` Just "text/html; charset=utf-8" - - it "should return given string as html" $ do - app <- app' - Helper.body <$> app `Helper.get` "/scotty" - `shouldReturn` (encodeUtf8 russianLanguageTextInHtml) - - describe "lifted-base" $ - it "should not return the default exception handler" $ do - app <- scottyApp $ get "/" $ ((undefined) `EL.catch` ((\_ -> html "") :: E.SomeException -> ActionM ())) - Helper.status <$> app `Helper.get` "/" `shouldReturn` status200 + let russianLanguageTextInHtml :: IsString a => a + russianLanguageTextInHtml = "

ру́сский язы́к

" + + withApp (Scotty.get "/scotty" $ html russianLanguageTextInHtml) $ do + it "sets body to given text" $ do + get "/scotty" `shouldRespondWith` russianLanguageTextInHtml + + it "sets Content-Type header to \"text/html; charset=utf-8\"" $ do + get "/scotty" `shouldRespondWith` 200 {matchHeaders = [("Content-Type", "text/html; charset=utf-8")]} From a6fe92e317bc91c7cfa4e37f4486018f60d90571 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Thu, 14 Aug 2014 11:01:25 +0800 Subject: [PATCH 156/179] Assume HTTP status 500 for `defaultHandler` (the user can still explicitly specify a different status code) --- Web/Scotty/Action.hs | 2 +- Web/Scotty/Trans.hs | 4 ++-- test/Web/ScottySpec.hs | 23 +++++++++++++++++++++++ 3 files changed, 26 insertions(+), 3 deletions(-) diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs index ddd1f014..4946709a 100644 --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -225,7 +225,7 @@ readEither t = case [ x | (x,"") <- reads (T.unpack t) ] of _ -> Left "readEither: ambiguous parse" -- | Set the HTTP response status. Default is 200. -status :: (ScottyError e, Monad m) => Status -> ActionT e m () +status :: Monad m => Status -> ActionT e m () status = ActionT . MS.modify . setStatus -- | Add to the response headers. Header names are case-insensitive. diff --git a/Web/Scotty/Trans.hs b/Web/Scotty/Trans.hs index 7c66bc9a..40de2ee0 100644 --- a/Web/Scotty/Trans.hs +++ b/Web/Scotty/Trans.hs @@ -48,7 +48,7 @@ import Control.Monad.IO.Class import Data.Conduit (Flush, Source) import Data.Default (def) -import Network.HTTP.Types (status404) +import Network.HTTP.Types (status404, status500) import Network.Wai import Network.Wai.Handler.Warp (Port, runSettings, setPort, getPort) @@ -115,7 +115,7 @@ notFoundApp _ = return $ responseBuilder status404 [("Content-Type","text/html") -- own defaultHandler in production which does not send out the error -- strings as 500 responses. defaultHandler :: Monad m => (e -> ActionT e m ()) -> ScottyT e m () -defaultHandler f = ScottyT $ modify $ addHandler $ Just f +defaultHandler f = ScottyT $ modify $ addHandler $ Just (\e -> status status500 >> f e) -- | Use given middleware. Middleware is nested such that the first declared -- is the outermost middleware (it has first dibs on the request and last action diff --git a/test/Web/ScottySpec.hs b/test/Web/ScottySpec.hs index 215081f9..a7e4637c 100644 --- a/test/Web/ScottySpec.hs +++ b/test/Web/ScottySpec.hs @@ -56,6 +56,29 @@ spec = do it "adds handler for requests that do not match any route" $ do get "/somewhere" `shouldRespondWith` "my custom not found page" {matchStatus = 404} + withApp (notFound $ status status400 >> html "my custom not found page") $ do + it "allows to customize the HTTP status code" $ do + get "/somewhere" `shouldRespondWith` "my custom not found page" {matchStatus = 400} + + context "when not specified" $ do + withApp (return ()) $ do + it "returns 404 when no route matches" $ do + get "/" `shouldRespondWith` "

404: File Not Found!

" {matchStatus = 404} + + describe "defaultHandler" $ do + withApp (defaultHandler text >> Scotty.get "/" (liftIO $ E.throwIO E.DivideByZero)) $ do + it "sets custom exception handler" $ do + get "/" `shouldRespondWith` "divide by zero" {matchStatus = 500} + + withApp (defaultHandler (\_ -> status status503) >> Scotty.get "/" (liftIO $ E.throwIO E.DivideByZero)) $ do + it "allows to customize the HTTP status code" $ do + get "/" `shouldRespondWith` "" {matchStatus = 503} + + context "when not specified" $ do + withApp (Scotty.get "/" $ liftIO $ E.throwIO E.DivideByZero) $ do + it "returns 500 on exceptions" $ do + get "/" `shouldRespondWith` "

500 Internal Server Error

divide by zero" {matchStatus = 500} + describe "ActionM" $ do withApp (Scotty.get "/" $ (undefined `EL.catch` ((\_ -> html "") :: E.SomeException -> ActionM ()))) $ do it "has a MonadBaseControl instance" $ do From 04a22a07ef42a4fc19fc887b0ff2d7906cb7d00e Mon Sep 17 00:00:00 2001 From: Wille Faler Date: Mon, 25 Aug 2014 18:15:27 +0100 Subject: [PATCH 157/179] set default json charset to utf-8 to avoid international chars becoming garbage --- 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 4946709a..3304e66d 100644 --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -260,7 +260,7 @@ file = ActionT . MS.modify . setContent . ContentFile -- header to \"application/json\". json :: (A.ToJSON a, ScottyError e, Monad m) => a -> ActionT e m () json v = do - setHeader "Content-Type" "application/json" + setHeader "Content-Type" "application/json; charset=utf-8" raw $ A.encode v -- | Set the body of the response to a Source. Doesn't set the From 5e3997aa93e447a0d7b1886ff20adc396b68d00d Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Mon, 25 Aug 2014 15:48:52 -0500 Subject: [PATCH 158/179] Update haddock for html/text/json to match code. --- Web/Scotty.hs | 6 +++--- Web/Scotty/Action.hs | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/Web/Scotty.hs b/Web/Scotty.hs index db1bb9a5..1eea24e0 100644 --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -175,12 +175,12 @@ setHeader :: Text -> Text -> ActionM () setHeader = Trans.setHeader -- | Set the body of the response to the given 'Text' value. Also sets \"Content-Type\" --- header to \"text/plain\". +-- header to \"text/plain; charset=utf-8\". text :: Text -> ActionM () text = Trans.text -- | Set the body of the response to the given 'Text' value. Also sets \"Content-Type\" --- header to \"text/html\". +-- header to \"text/html; charset=utf-8\". html :: Text -> ActionM () html = Trans.html @@ -190,7 +190,7 @@ file :: FilePath -> ActionM () file = Trans.file -- | Set the body of the response to the JSON encoding of the given value. Also sets \"Content-Type\" --- header to \"application/json\". +-- header to \"application/json; charset=utf-8\". json :: ToJSON a => a -> ActionM () json = Trans.json diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs index 3304e66d..3f86bbb8 100644 --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -257,7 +257,7 @@ file :: (ScottyError e, Monad m) => FilePath -> ActionT e m () file = ActionT . MS.modify . setContent . ContentFile -- | Set the body of the response to the JSON encoding of the given value. Also sets \"Content-Type\" --- header to \"application/json\". +-- header to \"application/json; charset=utf-8\". json :: (A.ToJSON a, ScottyError e, Monad m) => a -> ActionT e m () json v = do setHeader "Content-Type" "application/json; charset=utf-8" From 77015728ea8e36a51fed65de5b228a109ba5ca03 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Tue, 26 Aug 2014 14:42:41 +0800 Subject: [PATCH 159/179] Update changelog and bump version --- changelog.md | 6 ++++++ scotty.cabal | 2 +- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/changelog.md b/changelog.md index 74b6b09f..e2c0426d 100644 --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,9 @@ +## 0.9.0 + +* Add `charset=utf-8` to `Content-Type` for `text`, `html` and `json` + +* Assume HTTP status 500 for `defaultHandler` + ## 0.8.2 * Bump `aeson` upper bound diff --git a/scotty.cabal b/scotty.cabal index 7295f049..17ff3c50 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -1,5 +1,5 @@ Name: scotty -Version: 0.8.2 +Version: 0.9.0 Synopsis: Haskell web framework inspired by Ruby's Sinatra, using WAI and Warp Homepage: https://github.com/scotty-web/scotty Bug-reports: https://github.com/scotty-web/scotty/issues From 9ee9d33a634d9af5ef254cf1ac70e356ed1bd66f Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Wed, 27 Aug 2014 01:18:37 -0500 Subject: [PATCH 160/179] Remove deprecated source functions and conduit dep --- Web/Scotty.hs | 13 +------------ Web/Scotty/Action.hs | 15 +-------------- Web/Scotty/Trans.hs | 15 +++------------ scotty.cabal | 1 - 4 files changed, 5 insertions(+), 39 deletions(-) diff --git a/Web/Scotty.hs b/Web/Scotty.hs index 1eea24e0..7a4b5fe5 100644 --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -24,7 +24,7 @@ module Web.Scotty -- -- | 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, source, raw + , text, html, file, json, stream, raw -- ** Exceptions , raise, rescue, next, defaultHandler -- * Parsing Parameters @@ -35,14 +35,10 @@ module Web.Scotty -- With the exception of this, everything else better just import types. import qualified Web.Scotty.Trans as Trans -import qualified Web.Scotty.Action as Action -- for 'source', to avoid deprecation warning on Trans.source - -import Blaze.ByteString.Builder (Builder) import Data.Aeson (FromJSON, ToJSON) import Data.ByteString.Lazy.Char8 (ByteString) import Data.Text.Lazy (Text) -import Data.Conduit (Flush, Source) import Network.HTTP.Types (Status, StdMethod) import Network.Wai (Application, Middleware, Request, StreamingBody) @@ -200,13 +196,6 @@ json = Trans.json stream :: StreamingBody -> ActionM () stream = Trans.stream --- | Set the body of the response to a Source. Doesn't set the --- \"Content-Type\" header, so you probably want to do that on your --- own with 'setHeader'. -source :: Source IO (Flush Builder) -> ActionM () -source = Action.source -{-# DEPRECATED source "Use 'stream' instead. This will be removed in the next release." #-} - -- | Set the body of the response to the given 'BL.ByteString' value. Doesn't set the -- \"Content-Type\" header, so you probably want to do that on your own with 'setHeader'. raw :: ByteString -> ActionM () diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs index 3f86bbb8..9e7396c1 100644 --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -21,7 +21,6 @@ module Web.Scotty.Action , setHeader , status , stream - , source -- Deprecated , text , Param , Parsable(..) @@ -29,7 +28,7 @@ module Web.Scotty.Action , runAction ) where -import Blaze.ByteString.Builder (Builder, fromLazyByteString) +import Blaze.ByteString.Builder (fromLazyByteString) #if MIN_VERSION_mtl(2,2,1) import Control.Monad.Except @@ -43,8 +42,6 @@ import qualified Data.Aeson as A import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.CaseInsensitive as CI -import Data.Conduit -import qualified Data.Conduit.List as CL import Data.Default (def) import Data.Monoid (mconcat) import qualified Data.Text as ST @@ -269,16 +266,6 @@ json v = do stream :: (ScottyError e, Monad m) => StreamingBody -> ActionT e m () stream = ActionT . MS.modify . setContent . ContentStream --- | Set the body of the response to a Source. Doesn't set the --- \"Content-Type\" header, so you probably want to do that on your --- own with 'setHeader'. -source :: (ScottyError e, Monad m) => Source IO (Flush Builder) -> ActionT e m () -source src = stream $ \send flush -> src $$ CL.mapM_ (\mbuilder -> - case mbuilder of - Chunk b -> send b - Flush -> flush) --- Deprecated, but pragma is in Web.Scotty and Web.Scotty.Trans - -- | Set the body of the response to the given 'BL.ByteString' value. Doesn't set the -- \"Content-Type\" header, so you probably want to do that on your -- own with 'setHeader'. diff --git a/Web/Scotty/Trans.hs b/Web/Scotty/Trans.hs index 40de2ee0..0f7d3741 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, source, raw + , text, html, file, json, stream, raw -- ** Exceptions , raise, rescue, next, defaultHandler, ScottyError(..) -- * Parsing Parameters @@ -39,32 +39,23 @@ module Web.Scotty.Trans , ScottyT, ActionT ) where -import Blaze.ByteString.Builder (Builder, fromByteString) +import Blaze.ByteString.Builder (fromByteString) import Control.Monad (when) import Control.Monad.State (execStateT, modify) import Control.Monad.IO.Class -import Data.Conduit (Flush, Source) import Data.Default (def) import Network.HTTP.Types (status404, status500) import Network.Wai import Network.Wai.Handler.Warp (Port, runSettings, setPort, getPort) -import Web.Scotty.Action hiding (source) -import qualified Web.Scotty.Action as Action +import Web.Scotty.Action import Web.Scotty.Route import Web.Scotty.Internal.Types hiding (Application, Middleware) import qualified Web.Scotty.Internal.Types as Scotty --- | Set the body of the response to a Source. Doesn't set the --- \"Content-Type\" header, so you probably want to do that on your --- own with 'setHeader'. -source :: (ScottyError e, Monad m) => Source IO (Flush Builder) -> ActionT e m () -source = Action.source -{-# DEPRECATED source "Use 'stream' instead. This will be removed in the next release." #-} - -- | Run a scotty application using the warp server. -- NB: scotty p === scottyT p id id scottyT :: (Monad m, MonadIO n) diff --git a/scotty.cabal b/scotty.cabal index 17ff3c50..237971a9 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -73,7 +73,6 @@ Library blaze-builder >= 0.3.3.0 && < 0.4, bytestring >= 0.10.0.2 && < 0.11, case-insensitive >= 1.0.0.1 && < 1.3, - conduit >= 1.1 && < 1.2, data-default >= 0.5.3 && < 0.6, http-types >= 0.8.2 && < 0.9, mtl >= 2.1.2 && < 2.3, From c8e48fa7abdf46e4302007818a5febaee10929c1 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Wed, 27 Aug 2014 01:19:17 -0500 Subject: [PATCH 161/179] ScottyError constraint necessary for mtl < 2.2.1 --- Web/Scotty/Action.hs | 2 +- Web/Scotty/Trans.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs index 9e7396c1..458ab99e 100644 --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -222,7 +222,7 @@ readEither t = case [ x | (x,"") <- reads (T.unpack t) ] of _ -> Left "readEither: ambiguous parse" -- | Set the HTTP response status. Default is 200. -status :: Monad m => Status -> ActionT e m () +status :: (ScottyError e, Monad m) => Status -> ActionT e m () status = ActionT . MS.modify . setStatus -- | Add to the response headers. Header names are case-insensitive. diff --git a/Web/Scotty/Trans.hs b/Web/Scotty/Trans.hs index 0f7d3741..80bbcc4b 100644 --- a/Web/Scotty/Trans.hs +++ b/Web/Scotty/Trans.hs @@ -105,7 +105,7 @@ notFoundApp _ = return $ responseBuilder status404 [("Content-Type","text/html") -- This has security implications, so you probably want to provide your -- own defaultHandler in production which does not send out the error -- strings as 500 responses. -defaultHandler :: Monad m => (e -> ActionT e m ()) -> ScottyT e m () +defaultHandler :: (ScottyError e, Monad m) => (e -> ActionT e m ()) -> ScottyT e m () defaultHandler f = ScottyT $ modify $ addHandler $ Just (\e -> status status500 >> f e) -- | Use given middleware. Middleware is nested such that the first declared From 889f9aa1f601c1d2e3adad3056902ed2ecd9ac74 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Wed, 27 Aug 2014 01:19:46 -0500 Subject: [PATCH 162/179] Parens --- Web/Scotty/Internal/Types.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Web/Scotty/Internal/Types.hs b/Web/Scotty/Internal/Types.hs index b723cff7..6ae996c2 100644 --- a/Web/Scotty/Internal/Types.hs +++ b/Web/Scotty/Internal/Types.hs @@ -148,7 +148,7 @@ instance (MonadBase b m, ScottyError e) => MonadBase b (ActionT e m) where liftBase = liftBaseDefault -instance (ScottyError e) => MonadTransControl (ActionT e) where +instance ScottyError e => MonadTransControl (ActionT e) where #if MIN_VERSION_mtl(2,2,1) newtype StT (ActionT e) a = StAction {unStAction :: StT (StateT ScottyResponse) (StT (ReaderT ActionEnv) (StT (ExceptT (ActionError e)) a))} #else From 5299c338d37665693dcc796f569b01e0817ab566 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Wed, 27 Aug 2014 01:22:46 -0500 Subject: [PATCH 163/179] Update changelog --- changelog.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/changelog.md b/changelog.md index e2c0426d..0328e95c 100644 --- a/changelog.md +++ b/changelog.md @@ -4,6 +4,10 @@ * Assume HTTP status 500 for `defaultHandler` +* Remove deprecated `source` method. + +* No longer depend on conduit. + ## 0.8.2 * Bump `aeson` upper bound From e7781488e7ef75a5403c16d3655ad4fa38651129 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Mon, 1 Sep 2014 07:47:24 +0200 Subject: [PATCH 164/179] Make text/html/json only set Content-Type if not already set. --- Web/Scotty.hs | 6 +++--- Web/Scotty/Action.hs | 28 +++++++++++++++++++--------- Web/Scotty/Util.hs | 14 +++++++++++--- test/Web/ScottySpec.hs | 13 +++++++++++++ 4 files changed, 46 insertions(+), 15 deletions(-) diff --git a/Web/Scotty.hs b/Web/Scotty.hs index 7a4b5fe5..e4a49f64 100644 --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -171,12 +171,12 @@ setHeader :: Text -> Text -> ActionM () setHeader = Trans.setHeader -- | Set the body of the response to the given 'Text' value. Also sets \"Content-Type\" --- header to \"text/plain; charset=utf-8\". +-- header to \"text/plain; charset=utf-8\" if it has not already been set. text :: Text -> ActionM () text = Trans.text -- | Set the body of the response to the given 'Text' value. Also sets \"Content-Type\" --- header to \"text/html; charset=utf-8\". +-- header to \"text/html; charset=utf-8\" if it has not already been set. html :: Text -> ActionM () html = Trans.html @@ -186,7 +186,7 @@ file :: FilePath -> ActionM () file = Trans.file -- | 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\". +-- header to \"application/json; charset=utf-8\" if it has not already been set. json :: ToJSON a => a -> ActionM () json = Trans.json diff --git a/Web/Scotty/Action.hs b/Web/Scotty/Action.hs index 458ab99e..0dc12fab 100644 --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -215,7 +215,7 @@ instance Parsable Integer where parseParam = readEither -- | Useful for creating 'Parsable' instances for things that already implement 'Read'. Ex: -- -- > instance Parsable Int where parseParam = readEither -readEither :: (Read a) => T.Text -> Either T.Text a +readEither :: Read a => T.Text -> Either T.Text a readEither t = case [ x | (x,"") <- reads (T.unpack t) ] of [x] -> Right x [] -> Left "readEither: no parse" @@ -225,27 +225,37 @@ readEither t = case [ x | (x,"") <- reads (T.unpack t) ] of status :: (ScottyError e, Monad m) => Status -> ActionT e m () status = ActionT . MS.modify . setStatus +-- Not exported, but useful in the functions below. +changeHeader :: (ScottyError e, Monad m) + => (CI.CI B.ByteString -> B.ByteString -> [(HeaderName, B.ByteString)] -> [(HeaderName, B.ByteString)]) + -> T.Text -> T.Text -> ActionT e m () +changeHeader f k = ActionT + . MS.modify + . setHeaderWith + . f (CI.mk $ lazyTextToStrictByteString k) + . lazyTextToStrictByteString + -- | Add to the response headers. Header names are case-insensitive. addHeader :: (ScottyError e, Monad m) => T.Text -> T.Text -> ActionT e m () -addHeader k v = ActionT . MS.modify $ setHeaderWith $ add (CI.mk $ lazyTextToStrictByteString k) (lazyTextToStrictByteString v) +addHeader = changeHeader add -- | Set one of the response headers. Will override any previously set value for that header. -- Header names are case-insensitive. setHeader :: (ScottyError e, Monad m) => T.Text -> T.Text -> ActionT e m () -setHeader k v = ActionT . MS.modify $ setHeaderWith $ replace (CI.mk $ lazyTextToStrictByteString k) (lazyTextToStrictByteString v) +setHeader = changeHeader replace -- | Set the body of the response to the given 'T.Text' value. Also sets \"Content-Type\" --- header to \"text/plain; charset=utf-8\". +-- header to \"text/plain; charset=utf-8\" if it has not already been set. text :: (ScottyError e, Monad m) => T.Text -> ActionT e m () text t = do - setHeader "Content-Type" "text/plain; charset=utf-8" + changeHeader addIfNotPresent "Content-Type" "text/plain; charset=utf-8" raw $ encodeUtf8 t -- | Set the body of the response to the given 'T.Text' value. Also sets \"Content-Type\" --- header to \"text/html; charset=utf-8\". +-- header to \"text/html; charset=utf-8\" if it has not already been set. html :: (ScottyError e, Monad m) => T.Text -> ActionT e m () html t = do - setHeader "Content-Type" "text/html; charset=utf-8" + changeHeader addIfNotPresent "Content-Type" "text/html; charset=utf-8" raw $ encodeUtf8 t -- | Send a file as the response. Doesn't set the \"Content-Type\" header, so you probably @@ -254,10 +264,10 @@ file :: (ScottyError e, Monad m) => FilePath -> ActionT e m () file = ActionT . MS.modify . setContent . ContentFile -- | 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\". +-- 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 () json v = do - setHeader "Content-Type" "application/json; charset=utf-8" + changeHeader addIfNotPresent "Content-Type" "application/json; charset=utf-8" raw $ A.encode v -- | Set the body of the response to a Source. Doesn't set the diff --git a/Web/Scotty/Util.hs b/Web/Scotty/Util.hs index 4233b304..58440cb7 100644 --- a/Web/Scotty/Util.hs +++ b/Web/Scotty/Util.hs @@ -7,6 +7,7 @@ module Web.Scotty.Util , mkResponse , replace , add + , addIfNotPresent ) where import Network.Wai @@ -46,8 +47,15 @@ mkResponse sr = case srContent sr of h = srHeaders sr -- Note: we assume headers are not sensitive to order here (RFC 2616 specifies they are not) -replace :: (Eq a) => a -> b -> [(a,b)] -> [(a,b)] -replace k v m = add k v $ filter ((/= k) . fst) m +replace :: Eq a => a -> b -> [(a,b)] -> [(a,b)] +replace k v = add k v . filter ((/= k) . fst) -add :: (Eq a) => a -> b -> [(a,b)] -> [(a,b)] +add :: Eq a => a -> b -> [(a,b)] -> [(a,b)] add k v m = (k,v):m + +addIfNotPresent :: Eq a => a -> b -> [(a,b)] -> [(a,b)] +addIfNotPresent k v = go + where go [] = [(k,v)] + go l@((x,y):r) + | x == k = l + | otherwise = (x,y) : go r diff --git a/test/Web/ScottySpec.hs b/test/Web/ScottySpec.hs index a7e4637c..43058167 100644 --- a/test/Web/ScottySpec.hs +++ b/test/Web/ScottySpec.hs @@ -100,6 +100,10 @@ spec = do it "sets Content-Type header to \"text/plain; charset=utf-8\"" $ do get "/scotty" `shouldRespondWith` 200 {matchHeaders = [("Content-Type", "text/plain; charset=utf-8")]} + withApp (Scotty.get "/scotty" $ setHeader "Content-Type" "text/somethingweird" >> text modernGreekText) $ do + it "doesn't override a previously set Content-Type header" $ do + get "/scotty" `shouldRespondWith` 200 {matchHeaders = [("Content-Type", "text/somethingweird")]} + describe "html" $ do let russianLanguageTextInHtml :: IsString a => a russianLanguageTextInHtml = "

ру́сский язы́к

" @@ -110,3 +114,12 @@ spec = do it "sets Content-Type header to \"text/html; charset=utf-8\"" $ do get "/scotty" `shouldRespondWith` 200 {matchHeaders = [("Content-Type", "text/html; charset=utf-8")]} + + withApp (Scotty.get "/scotty" $ setHeader "Content-Type" "text/somethingweird" >> html russianLanguageTextInHtml) $ do + it "doesn't override a previously set Content-Type header" $ do + get "/scotty" `shouldRespondWith` 200 {matchHeaders = [("Content-Type", "text/somethingweird")]} + + describe "json" $ do + withApp (Scotty.get "/scotty" $ setHeader "Content-Type" "text/somethingweird" >> json (Just (5::Int))) $ do + it "doesn't override a previously set Content-Type header" $ do + get "/scotty" `shouldRespondWith` 200 {matchHeaders = [("Content-Type", "text/somethingweird")]} From 003577ee43d1e3ca84e63235e45f4fa756cf4561 Mon Sep 17 00:00:00 2001 From: Andrew Farmer Date: Mon, 1 Sep 2014 07:50:42 +0200 Subject: [PATCH 165/179] Update changelog --- changelog.md | 4 ++++ scotty.cabal | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/changelog.md b/changelog.md index 0328e95c..a9613cc4 100644 --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,7 @@ +## 0.9.1 + +* text/html/json only set Content-Type header when not already set + ## 0.9.0 * Add `charset=utf-8` to `Content-Type` for `text`, `html` and `json` diff --git a/scotty.cabal b/scotty.cabal index 237971a9..e346389d 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -1,5 +1,5 @@ Name: scotty -Version: 0.9.0 +Version: 0.9.1 Synopsis: Haskell web framework inspired by Ruby's Sinatra, using WAI and Warp Homepage: https://github.com/scotty-web/scotty Bug-reports: https://github.com/scotty-web/scotty/issues From a408460f547a842fdd0d2e699fe2bf50aef2b653 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Mon, 8 Sep 2014 18:47:29 +0800 Subject: [PATCH 166/179] Adapt for hspec-wai-0.4.* --- scotty.cabal | 2 +- test/Web/ScottySpec.hs | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/scotty.cabal b/scotty.cabal index e346389d..fd446cab 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -99,7 +99,7 @@ test-suite spec lifted-base, wai, hspec2, - hspec-wai >= 0.3.0, + hspec-wai >= 0.4.0, scotty GHC-options: -Wall -fno-warn-orphans diff --git a/test/Web/ScottySpec.hs b/test/Web/ScottySpec.hs index 43058167..27f3d606 100644 --- a/test/Web/ScottySpec.hs +++ b/test/Web/ScottySpec.hs @@ -43,13 +43,13 @@ spec = do forM_ availableMethods $ \method -> do withApp (addroute method "/scotty" $ html "") $ do it ("can be used to add route for " ++ show method ++ " requests") $ do - request (renderStdMethod method) "/scotty" "" `shouldRespondWith` 200 + request (renderStdMethod method) "/scotty" [] "" `shouldRespondWith` 200 describe "matchAny" $ do withApp (matchAny "/scotty" $ html "") $ do forM_ availableMethods $ \method -> do it ("adds route that matches " ++ show method ++ " requests") $ do - request (renderStdMethod method) "/scotty" "" `shouldRespondWith` 200 + request (renderStdMethod method) "/scotty" [] "" `shouldRespondWith` 200 describe "notFound" $ do withApp (notFound $ html "my custom not found page") $ do From c4ef24863d887b3ee13af8b727d490c51a25ec95 Mon Sep 17 00:00:00 2001 From: RyanGlScott Date: Mon, 8 Sep 2014 23:08:35 -0500 Subject: [PATCH 167/179] Bump text upper version bounds --- scotty.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scotty.cabal b/scotty.cabal index fd446cab..a97e110c 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -78,7 +78,7 @@ Library mtl >= 2.1.2 && < 2.3, monad-control >= 0.3.2.3 && < 0.4, regex-compat >= 0.95.1 && < 0.96, - text >= 0.11.3.1 && < 1.2, + text >= 0.11.3.1 && < 1.3, transformers >= 0.3.0.0 && < 0.5, transformers-base >= 0.4.1 && < 0.5, wai >= 3.0.0 && < 3.1, From 8338eb1e5c980be5f3c891c469b75f8f5572280d Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Tue, 9 Sep 2014 14:00:25 +0800 Subject: [PATCH 168/179] Fix travis build --- .travis.yml | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index e9b28d71..c8dacb46 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,9 +1,12 @@ language: haskell -before_install: +install: + - cabal install --only-dependencies --enable-tests - cabal install hpc-coveralls + script: - - cabal configure --enable-tests --enable-library-coverage && cabal build + - cabal configure --enable-tests --enable-library-coverage --ghc-options=-Werror && cabal build - run-cabal-test --show-details=always + after_script: - hpc-coveralls --exclude-dir=test spec From 005c619397244a9b82025ddd6a3f0b9b76ee9706 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Tue, 9 Sep 2014 14:59:26 +0800 Subject: [PATCH 169/179] Require hspec-wai >= 0.4.1 --- scotty.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scotty.cabal b/scotty.cabal index a97e110c..fd2d029b 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -99,7 +99,7 @@ test-suite spec lifted-base, wai, hspec2, - hspec-wai >= 0.4.0, + hspec-wai >= 0.4.1, scotty GHC-options: -Wall -fno-warn-orphans From 9c5dc879821cb2161e88090cde17d21fb4be5e42 Mon Sep 17 00:00:00 2001 From: Petr Pudlak Date: Fri, 5 Sep 2014 10:44:36 +0200 Subject: [PATCH 170/179] Remove the use of the LambdaCase extension The extension is available only in GHC 7.6+, which unnecessarily prevents compiling scotty on older versions (for example Debian Wheezy has 7.4). Also simplify takeMVar ... putMVar using modifyMVar. --- Web/Scotty/Route.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/Web/Scotty/Route.hs b/Web/Scotty/Route.hs index 95daea2b..98515fb0 100644 --- a/Web/Scotty/Route.hs +++ b/Web/Scotty/Route.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, LambdaCase, +{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, OverloadedStrings, RankNTypes, ScopedTypeVariables #-} module Web.Scotty.Route ( get, post, put, delete, patch, addroute, matchAny, notFound, @@ -124,9 +124,9 @@ parseRequestBody bl s r = Just rbt -> do mvar <- liftIO $ newMVar bl -- MVar is a bit of a hack so we don't have to inline -- large portions of Network.Wai.Parse - let provider = takeMVar mvar >>= \case - [] -> putMVar mvar [] >> return B.empty - (b:bs) -> putMVar mvar bs >> return b + let provider = modifyMVar mvar $ \bsold -> case bsold of + [] -> return ([], B.empty) + (b:bs) -> return (bs, b) liftIO $ Parse.sinkRequestBody s rbt provider mkEnv :: forall m. MonadIO m => Request -> [Param] -> m ActionEnv From 3bd7a09feb906be6d549c3d2f276b40a30eba6af Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Wed, 24 Sep 2014 17:34:52 +0800 Subject: [PATCH 171/179] Update for hspec-wai 0.5.* --- scotty.cabal | 2 +- test/Web/ScottySpec.hs | 10 +++++----- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/scotty.cabal b/scotty.cabal index fd2d029b..cf643976 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -99,7 +99,7 @@ test-suite spec lifted-base, wai, hspec2, - hspec-wai >= 0.4.1, + hspec-wai >= 0.5, scotty GHC-options: -Wall -fno-warn-orphans diff --git a/test/Web/ScottySpec.hs b/test/Web/ScottySpec.hs index 27f3d606..2b414fa6 100644 --- a/test/Web/ScottySpec.hs +++ b/test/Web/ScottySpec.hs @@ -98,11 +98,11 @@ spec = do get "/scotty" `shouldRespondWith` modernGreekText it "sets Content-Type header to \"text/plain; charset=utf-8\"" $ do - get "/scotty" `shouldRespondWith` 200 {matchHeaders = [("Content-Type", "text/plain; charset=utf-8")]} + get "/scotty" `shouldRespondWith` 200 {matchHeaders = ["Content-Type" <:> "text/plain; charset=utf-8"]} withApp (Scotty.get "/scotty" $ setHeader "Content-Type" "text/somethingweird" >> text modernGreekText) $ do it "doesn't override a previously set Content-Type header" $ do - get "/scotty" `shouldRespondWith` 200 {matchHeaders = [("Content-Type", "text/somethingweird")]} + get "/scotty" `shouldRespondWith` 200 {matchHeaders = ["Content-Type" <:> "text/somethingweird"]} describe "html" $ do let russianLanguageTextInHtml :: IsString a => a @@ -113,13 +113,13 @@ spec = do get "/scotty" `shouldRespondWith` russianLanguageTextInHtml it "sets Content-Type header to \"text/html; charset=utf-8\"" $ do - get "/scotty" `shouldRespondWith` 200 {matchHeaders = [("Content-Type", "text/html; charset=utf-8")]} + get "/scotty" `shouldRespondWith` 200 {matchHeaders = ["Content-Type" <:> "text/html; charset=utf-8"]} withApp (Scotty.get "/scotty" $ setHeader "Content-Type" "text/somethingweird" >> html russianLanguageTextInHtml) $ do it "doesn't override a previously set Content-Type header" $ do - get "/scotty" `shouldRespondWith` 200 {matchHeaders = [("Content-Type", "text/somethingweird")]} + get "/scotty" `shouldRespondWith` 200 {matchHeaders = ["Content-Type" <:> "text/somethingweird"]} describe "json" $ do withApp (Scotty.get "/scotty" $ setHeader "Content-Type" "text/somethingweird" >> json (Just (5::Int))) $ do it "doesn't override a previously set Content-Type header" $ do - get "/scotty" `shouldRespondWith` 200 {matchHeaders = [("Content-Type", "text/somethingweird")]} + get "/scotty" `shouldRespondWith` 200 {matchHeaders = ["Content-Type" <:> "text/somethingweird"]} From 576c5b68c41a1877e3ea091c6f16632c70935c2d Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Fri, 3 Oct 2014 18:10:54 -0500 Subject: [PATCH 172/179] Create an example of using the reader monad --- examples/reader.hs | 36 ++++++++++++++++++++++++++++++++++++ 1 file changed, 36 insertions(+) create mode 100644 examples/reader.hs diff --git a/examples/reader.hs b/examples/reader.hs new file mode 100644 index 00000000..96915c5d --- /dev/null +++ b/examples/reader.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Control.Monad.Reader (MonadIO, MonadReader, ReaderT, asks, lift, runReaderT) +import Data.Default (def) +import Data.Text.Lazy (Text, pack) +import Web.Scotty.Trans (ScottyT, get, scottyOptsT, text) + +data State = State + { environment :: String + } deriving (Eq, Read, Show) + +newtype StateM a = StateM + { runStateM :: ReaderT State IO a + } deriving (Monad, MonadIO, MonadReader State) + +application :: ScottyT Text StateM () +application = do + get "/" $ do + e <- lift $ asks environment + text $ pack $ show e + +main :: IO () +main = scottyOptsT def runM runIO application where + runM :: StateM a -> IO a + runM m = runReaderT (runStateM m) state + + runIO :: StateM a -> IO a + runIO = runM + + state :: State + state = State + { environment = "Development" + } From b4882b9bcd297e493abae8085465978ca57c8547 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Mon, 6 Oct 2014 07:48:34 -0500 Subject: [PATCH 173/179] Rename "state" to "config" --- examples/reader.hs | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/examples/reader.hs b/examples/reader.hs index 96915c5d..4b522b84 100644 --- a/examples/reader.hs +++ b/examples/reader.hs @@ -8,15 +8,15 @@ import Data.Default (def) import Data.Text.Lazy (Text, pack) import Web.Scotty.Trans (ScottyT, get, scottyOptsT, text) -data State = State +data Config = Config { environment :: String } deriving (Eq, Read, Show) -newtype StateM a = StateM - { runStateM :: ReaderT State IO a - } deriving (Monad, MonadIO, MonadReader State) +newtype ConfigM a = ConfigM + { runConfigM :: ReaderT Config IO a + } deriving (Monad, MonadIO, MonadReader Config) -application :: ScottyT Text StateM () +application :: ScottyT Text ConfigM () application = do get "/" $ do e <- lift $ asks environment @@ -24,13 +24,13 @@ application = do main :: IO () main = scottyOptsT def runM runIO application where - runM :: StateM a -> IO a - runM m = runReaderT (runStateM m) state + runM :: ConfigM a -> IO a + runM m = runReaderT (runConfigM m) config - runIO :: StateM a -> IO a + runIO :: ConfigM a -> IO a runIO = runM - state :: State - state = State + config :: Config + config = Config { environment = "Development" } From 26285cceed1917b2297ed0fef0ae7976d040f63b Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Mon, 6 Oct 2014 07:50:00 -0500 Subject: [PATCH 174/179] Derive functor and applicative instances too --- examples/reader.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/examples/reader.hs b/examples/reader.hs index 4b522b84..5ea12d80 100644 --- a/examples/reader.hs +++ b/examples/reader.hs @@ -3,6 +3,7 @@ module Main where +import Control.Applicative (Applicative) import Control.Monad.Reader (MonadIO, MonadReader, ReaderT, asks, lift, runReaderT) import Data.Default (def) import Data.Text.Lazy (Text, pack) @@ -14,7 +15,7 @@ data Config = Config newtype ConfigM a = ConfigM { runConfigM :: ReaderT Config IO a - } deriving (Monad, MonadIO, MonadReader Config) + } deriving (Applicative, Functor, Monad, MonadIO, MonadReader Config) application :: ScottyT Text ConfigM () application = do From f48fcc71e5fa0de598217d10eaceb494b865d0f7 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Mon, 6 Oct 2014 07:56:23 -0500 Subject: [PATCH 175/179] Add a motivating comment Mostly copied from `globalstate.hs`. --- examples/reader.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/examples/reader.hs b/examples/reader.hs index 5ea12d80..999da77a 100644 --- a/examples/reader.hs +++ b/examples/reader.hs @@ -1,6 +1,10 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} +{- + An example of embedding a custom monad into Scotty's transformer + stack, using ReaderT to provide access to a global state. +-} module Main where import Control.Applicative (Applicative) From 31e664474fc21019b7e83bd810d52c115340b4ff Mon Sep 17 00:00:00 2001 From: Konstantine Rybnikov Date: Wed, 29 Oct 2014 18:28:55 +0200 Subject: [PATCH 176/179] Use aeson's eitherDecode instead of just decode --- 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 0dc12fab..72b8cb01 100644 --- a/Web/Scotty/Action.hs +++ b/Web/Scotty/Action.hs @@ -151,7 +151,7 @@ body = ActionT $ liftM getBody ask jsonData :: (A.FromJSON a, ScottyError e, Monad m) => ActionT e m a jsonData = do b <- body - maybe (raise $ stringError $ "jsonData - no parse: " ++ BL.unpack b) return $ A.decode b + either (\e -> raise $ stringError $ "jsonData - no parse: " ++ e ++ ". Data was:" ++ BL.unpack b) return $ A.eitherDecode b -- | Get a parameter. First looks in captures, then form data, then query parameters. -- From 787580aa2b9c8de95170efaf47954a98eff756e2 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Sun, 2 Nov 2014 18:41:00 +0800 Subject: [PATCH 177/179] Add more tests --- test/Web/ScottySpec.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/test/Web/ScottySpec.hs b/test/Web/ScottySpec.hs index 2b414fa6..f6010905 100644 --- a/test/Web/ScottySpec.hs +++ b/test/Web/ScottySpec.hs @@ -85,10 +85,14 @@ spec = do get "/" `shouldRespondWith` 200 describe "param" $ do - withApp (Scotty.get "/search" $ param "query" >>= text) $ do + withApp (Scotty.matchAny "/search" $ param "query" >>= text) $ do it "returns query parameter with given name" $ do get "/search?query=haskell" `shouldRespondWith` "haskell" + context "when used with application/x-www-form-urlencoded data" $ do + it "returns POST parameter with given name" $ do + request "POST" "/search" [("Content-Type","application/x-www-form-urlencoded")] "query=haskell" `shouldRespondWith` "haskell" + describe "text" $ do let modernGreekText :: IsString a => a modernGreekText = "νέα ελληνικά" From 1b6eb897d609fbccd58d07c162388a9a87d31510 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Tue, 11 Nov 2014 22:03:44 +0800 Subject: [PATCH 178/179] Depend on hspec-2.* --- scotty.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scotty.cabal b/scotty.cabal index cf643976..40cdadf9 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -98,7 +98,7 @@ test-suite spec http-types, lifted-base, wai, - hspec2, + hspec == 2.*, hspec-wai >= 0.5, scotty GHC-options: -Wall -fno-warn-orphans From f9bbe0b8e0fca88f3c42f77820d6d8bf87d63bd4 Mon Sep 17 00:00:00 2001 From: Alexey Khudyakov Date: Mon, 27 Oct 2014 18:10:18 +0100 Subject: [PATCH 179/179] Add scotty-specific middlewares Based on patch of Zhang Yichao --- Web/Scotty.hs | 8 +++++++- Web/Scotty/Internal/Types.hs | 6 +++++- Web/Scotty/Trans.hs | 20 +++++++++++++++++--- 3 files changed, 29 insertions(+), 5 deletions(-) diff --git a/Web/Scotty.hs b/Web/Scotty.hs index e4a49f64..2526a631 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, addroute, matchAny, notFound + , middleware, scottyMiddleware, get, post, put, delete, patch, addroute, matchAny, notFound -- ** Route Patterns , capture, regex, function, literal -- ** Accessing the Request, Captures, and Query Parameters @@ -45,6 +45,7 @@ import Network.Wai (Application, Middleware, Request, StreamingBody) import Network.Wai.Handler.Warp (Port) import Web.Scotty.Internal.Types (ScottyT, ActionT, Param, RoutePattern, Options, File) +import qualified Web.Scotty.Internal.Types as Scotty type ScottyM = ScottyT Text IO type ActionM = ActionT Text IO @@ -80,6 +81,11 @@ defaultHandler = Trans.defaultHandler middleware :: Middleware -> ScottyM () middleware = Trans.middleware +-- | Use given scotty middleware. They are nested like WAI middlewares +-- but act after all WAI middlewares. +scottyMiddleware :: Scotty.Middleware IO -> ScottyM () +scottyMiddleware = Trans.scottyMiddleware + -- | 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/Internal/Types.hs b/Web/Scotty/Internal/Types.hs index 6ae996c2..c09cdc5f 100644 --- a/Web/Scotty/Internal/Types.hs +++ b/Web/Scotty/Internal/Types.hs @@ -50,16 +50,20 @@ type Application m = Request -> m Response --------------- Scotty Applications ----------------- data ScottyState e m = ScottyState { middlewares :: [Wai.Middleware] + , scottyMiddlewares :: [Middleware m] , routes :: [Middleware m] , handler :: ErrorHandler e m } instance Monad m => Default (ScottyState e m) where - def = ScottyState [] [] Nothing + def = ScottyState [] [] [] Nothing addMiddleware :: Wai.Middleware -> ScottyState e m -> ScottyState e m addMiddleware m s@(ScottyState {middlewares = ms}) = s { middlewares = m:ms } +addScottyMiddleware :: Middleware m -> ScottyState e m -> ScottyState e m +addScottyMiddleware m s@(ScottyState {scottyMiddlewares = ms}) = s { scottyMiddlewares = m:ms } + addRoute :: Monad m => Middleware m -> ScottyState e m -> ScottyState e m addRoute r s@(ScottyState {routes = rs}) = s { routes = r:rs } diff --git a/Web/Scotty/Trans.hs b/Web/Scotty/Trans.hs index 80bbcc4b..788890d7 100644 --- a/Web/Scotty/Trans.hs +++ b/Web/Scotty/Trans.hs @@ -17,7 +17,7 @@ module Web.Scotty.Trans -- | '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, addroute, matchAny, notFound + , middleware, scottyMiddleware, get, post, put, delete, patch, addroute, matchAny, notFound -- ** Route Patterns , capture, regex, function, literal -- ** Accessing the Request, Captures, and Query Parameters @@ -89,8 +89,17 @@ scottyAppT :: (Monad m, Monad n) -> n Application scottyAppT runM runActionToIO defs = do s <- runM $ execStateT (runS defs) def - let rapp = \ req callback -> runActionToIO (foldl (flip ($)) notFoundApp (routes s) req) >>= callback - return $ foldl (flip ($)) rapp (middlewares s) + -- Convert scotty app to WAI app + let wai app = \req callback -> callback =<< runActionToIO (app req) + -- Apply WAI middlewares + return $ chain (middlewares s) + $ wai + $ chain (scottyMiddlewares s) + $ chain (routes s) + $ notFoundApp + +chain :: [a -> a] -> a -> a +chain fs a = foldl (flip ($)) a fs notFoundApp :: Monad m => Scotty.Application m notFoundApp _ = return $ responseBuilder status404 [("Content-Type","text/html")] @@ -113,3 +122,8 @@ defaultHandler f = ScottyT $ modify $ addHandler $ Just (\e -> status status500 -- on the response). Every middleware is run on each request. middleware :: Monad m => Middleware -> ScottyT e m () middleware = ScottyT . modify . addMiddleware + +-- | Use given scotty middleware. They are nested like WAI middlewares +-- but act after all WAI middlewares. +scottyMiddleware :: Monad m => Scotty.Middleware m -> ScottyT e m () +scottyMiddleware = ScottyT . modify . addScottyMiddleware