module Web.Scotty.Route
( get, post, put, delete, patch, addroute, matchAny, notFound,
capture, regex, function, literal
) where
import Control.Arrow ((***))
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 qualified Data.Text.Lazy as T
import qualified Data.Text as TS
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.Types
import Web.Scotty.Util
get :: (ScottyError e, MonadIO m) => RoutePattern -> ActionT e m () -> ScottyT e m ()
get = addroute GET
post :: (ScottyError e, MonadIO m) => RoutePattern -> ActionT e m () -> ScottyT e m ()
post = addroute POST
put :: (ScottyError e, MonadIO m) => RoutePattern -> ActionT e m () -> ScottyT e m ()
put = addroute PUT
delete :: (ScottyError e, MonadIO m) => RoutePattern -> ActionT e m () -> ScottyT e m ()
delete = addroute DELETE
patch :: (ScottyError e, MonadIO m) => RoutePattern -> ActionT e m () -> ScottyT e m ()
patch = addroute PATCH
matchAny :: (ScottyError e, MonadIO m) => RoutePattern -> ActionT e m () -> ScottyT e m ()
matchAny pattern action = mapM_ (\v -> addroute v pattern action) [minBound..maxBound]
notFound :: (ScottyError e, MonadIO m) => ActionT e m () -> ScottyT e m ()
notFound action = matchAny (Function (\req -> Just [("path", path req)])) (status status404 >> 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 :: (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 h 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 (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
parseRequestBody :: MonadIO m
=> BL.ByteString
-> Parse.BackEnd y
-> Request
-> m ([Parse.Param], [Parse.File y])
parseRequestBody b 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
mkEnv req captures = do
b <- liftIO $ liftM BL.fromChunks $ lazyConsume (requestBody req)
(formparams, fs) <- liftIO $ parseRequestBody b Parse.lbsBackEnd req
let convert (k, v) = (strictByteStringToLazyText k, strictByteStringToLazyText v)
parameters = captures ++ map convert formparams ++ queryparams
queryparams = parseEncodedParams $ rawQueryString req
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 ]
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