module Web.Growler.Router
( get
, post
, put
, delete
, patch
, addRoute
, matchAny
, capture
, regex
, function
, mount
, literal
, route
, handlerHook
, RoutePattern(..)
, notFound
, internalServerError
) where
import Control.Arrow ((***))
import Control.Monad.Trans
import qualified Control.Monad.Trans.State.Strict as S
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 qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as TL
import Network.HTTP.Types
import Network.Wai (Request (..))
import qualified Network.Wai.Parse as Parse
import qualified Text.Regex as Regex
import Web.Growler.Handler
import Web.Growler.Types hiding (status, capture)
modify' f = S.get >>= (($!) S.put . f)
mount :: Monad m => RoutePattern -> GrowlerT m () -> GrowlerT m ()
mount pat m = GrowlerT $ do
previous <- S.get
S.put []
fromGrowlerT m
modify' (fmap $ \(m, p, h) -> (m, pat <> p, h))
new <- S.get
S.put (new ++ previous)
handlerHook :: Monad m => (HandlerT m () -> HandlerT m ()) -> GrowlerT m ()
handlerHook f = GrowlerT $ modify' (fmap $ \(m, p, h) -> (m, p, f h))
get :: (MonadIO m) => RoutePattern -> HandlerT m () -> GrowlerT m ()
get = addRoute GET
post :: (MonadIO m) => RoutePattern -> HandlerT m () -> GrowlerT m ()
post = addRoute POST
put :: (MonadIO m) => RoutePattern -> HandlerT m () -> GrowlerT m ()
put = addRoute PUT
delete :: (MonadIO m) => RoutePattern -> HandlerT m () -> GrowlerT m ()
delete = addRoute DELETE
patch :: (MonadIO m) => RoutePattern -> HandlerT m () -> GrowlerT m ()
patch = addRoute PATCH
matchAny :: (MonadIO m) => RoutePattern -> HandlerT m () -> GrowlerT m ()
matchAny pattern action = mapM_ (\v -> addRoute v pattern action) [minBound..maxBound]
notFound :: (Monad m) => HandlerT m ()
notFound = status status404
internalServerError :: Monad m => HandlerT m ()
internalServerError = status status500
addRoute :: (MonadIO m) => StdMethod -> RoutePattern -> HandlerT m () -> GrowlerT m ()
addRoute method pat action = GrowlerT $ modify' ((method, pat, action):)
route :: Request -> StdMethod -> RoutePattern -> Maybe (T.Text, [Param])
route req method pat = if Right method == parseMethod (requestMethod req)
then matchRoute pat req
else Nothing
matchRoute :: RoutePattern -> Request -> Maybe (T.Text, [Param])
matchRoute (RoutePattern p) req = let (RoutePatternResult pat _ rps) = p req in case rps of
Fail -> Nothing
Partial _ -> Nothing
Complete ps -> Just (pat, ps)
parseEncodedParams :: B.ByteString -> [Param]
parseEncodedParams bs = [ (T.encodeUtf8 k, T.encodeUtf8 $ fromMaybe "" v) | (k,v) <- parseQueryText bs ]
regex :: String -> RoutePattern
regex pattern = RoutePattern go
where
go req = RoutePatternResult (T.pack pattern) req $ maybe Fail Complete $ fmap convertParams match
where
rgx = Regex.mkRegex pattern
strip (_, match, _, subs) = match : subs
match = Regex.matchRegexAll rgx $ T.unpack $ path req
convertParams = map (B.pack . show *** (T.encodeUtf8 . T.pack)) . zip [0 :: Int ..] . strip
capture :: String -> RoutePattern
capture = fromString
function :: (Request -> T.Text) -> (Request -> MatchResult) -> RoutePattern
function fn fps = RoutePattern $ \r -> RoutePatternResult (fn r) r (fps r)
literal :: String -> RoutePattern
literal pat = RoutePattern go
where
go req = RoutePatternResult packed (req { pathInfo = req' }) result
where
packed = T.pack pat
(result, req') = case T.stripPrefix packed (path req) of
Nothing -> (Fail, [])
Just rem -> if T.null rem then (Complete [], []) else (Partial [], dropWhile (== "") $ T.split (== '/') rem)