module Web.Scotty.Route
( get, post, put, delete, addroute, matchAny, notFound,
capture, regex, function, literal, Action
) 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
import Network.HTTP.Types
import Network.Wai
import qualified Text.Regex as Regex
import Web.Scotty.Action
import Web.Scotty.Types
get :: (Action action) => RoutePattern -> action -> ScottyM ()
get = addroute GET
post :: (Action action) => RoutePattern -> action -> ScottyM ()
post = addroute POST
put :: (Action action) => RoutePattern -> action -> ScottyM ()
put = addroute PUT
delete :: (Action action) => RoutePattern -> action -> ScottyM ()
delete = addroute DELETE
matchAny :: (Action action) => RoutePattern -> action -> ScottyM ()
matchAny pattern action = mapM_ (\v -> addroute v pattern action) [minBound..maxBound]
notFound :: ActionM () -> ScottyM ()
notFound action = matchAny (Function (\req -> Just [("path", path req)])) (status status404 >> action)
addroute :: (Action action) => StdMethod -> RoutePattern -> action -> ScottyM ()
addroute method pat action = MS.modify $ addRoute $ route method pat $ build action pat
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 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
go [] r prs | T.null (mconcat r) = Just prs
| otherwise = Nothing
go p [] prs | T.null (mconcat p) = Just prs
| otherwise = Nothing
go (p:ps) (r:rs) prs | p == r = go ps rs prs
| T.null p = Nothing
| T.head p == ':' = go ps rs $ (T.tail p, r) : prs
| otherwise = Nothing
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 ]
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
capture :: String -> RoutePattern
capture = Capture . T.pack
function :: (Request -> Maybe [Param]) -> RoutePattern
function = Function
literal :: String -> RoutePattern
literal = Literal . T.pack