diff --git a/Web/Scotty.hs b/Web/Scotty.hs
--- 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,7 +9,9 @@
-- | '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
+ , 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, jsonData
@@ -23,53 +25,32 @@
-- ** Exceptions
, raise, rescue, next
-- * Types
- , ScottyM, ActionM, Parsable
+ , 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
-
-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)" >> (run p =<< scottyApp s)
+scotty p s = 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.
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
@@ -80,254 +61,4 @@
-- 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
-
-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 = sequence $ map 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 :: T.Text -> ActionM () -> ScottyM ()
-get = addroute GET
-
--- | post = addroute 'POST'
-post :: T.Text -> ActionM () -> ScottyM ()
-post = addroute POST
-
--- | put = addroute 'PUT'
-put :: T.Text -> ActionM () -> ScottyM ()
-put = addroute PUT
-
--- | delete = addroute 'DELETE'
-delete :: T.Text -> ActionM () -> ScottyM ()
-delete = addroute DELETE
-
--- | 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 -> T.Text -> ActionM () -> ScottyM ()
-addroute method path action = MS.modify (\ (ScottyState ms rs) -> ScottyState ms (r:rs))
- where r = route method withSlash action
- withSlash = case T.uncons path of
- Just ('/',_) -> path
- _ -> T.cons '/' path
-
-route :: StdMethod -> T.Text -> 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 params = 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 params b
-
-parseEncodedParams :: B.ByteString -> [Param]
-parseEncodedParams bs = [ (T.fromStrict k, T.fromStrict $ fromMaybe "" v) | (k,v) <- parseQueryText bs ]
-
--- todo: wildcards?
-matchRoute :: T.Text -> T.Text -> Maybe [Param]
-matchRoute pat req = go (T.split (=='/') pat) (T.split (=='/') req) []
- where go [] [] ps = Just ps -- request string and pattern match!
- go [] r ps | T.null (mconcat r) = Just ps -- in case request has trailing slashes
- | otherwise = Nothing -- request string is longer than pattern
- go p [] ps | T.null (mconcat p) = Just ps -- 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
--- /dev/null
+++ b/Web/Scotty/Action.hs
@@ -0,0 +1,204 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Web.Scotty.Action
+ ( request, body, param, jsonData
+ , status, header, redirect
+ , text, html, file, json
+ , raise, rescue, next
+ , 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
--- /dev/null
+++ b/Web/Scotty/Route.hs
@@ -0,0 +1,150 @@
+{-# LANGUAGE OverloadedStrings #-}
+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. 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)
+
+-- | 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
--- /dev/null
+++ b/Web/Scotty/Types.hs
@@ -0,0 +1,52 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+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 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)
+
+data RoutePattern = Capture Text
+ | Literal Text
+ | Function (Request -> Maybe [Param])
+
+instance IsString RoutePattern where fromString = Capture . pack
diff --git a/examples/basic.hs b/examples/basic.hs
--- a/examples/basic.hs
+++ b/examples/basic.hs
@@ -8,6 +8,8 @@
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)
@@ -15,6 +17,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"
diff --git a/scotty.cabal b/scotty.cabal
--- 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
@@ -63,20 +63,25 @@
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,
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
+ warp >= 1.0.0,
+ regex-compat >= 0.95.1
GHC-options: -Wall -fno-warn-orphans