module Web.Growler.Router
( get
, post
, put
, delete
, patch
, addRoute
, matchAny
, notFound
, capture
, regex
, function
, literal
, route
, RoutePattern(..)
) where
import Control.Arrow ((***))
import Control.Monad.State hiding (get, put)
import Control.Monad.Trans
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)
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 :: (MonadIO m) => HandlerT m ()
notFound = status status404
addRoute :: (MonadIO m) => StdMethod -> RoutePattern -> HandlerT m () -> GrowlerT m ()
addRoute method pat action = GrowlerT $ modify ((method, pat, action):)
route :: Request -> StdMethod -> RoutePattern -> Maybe [Param]
route req method pat = if Right method == parseMethod (requestMethod req)
then matchRoute pat req
else Nothing
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.encodeUtf8 $ T.tail p, T.encodeUtf8 r) : prs
| otherwise = Nothing
path :: Request -> T.Text
path = T.cons '/' . T.intercalate "/" . pathInfo
parseEncodedParams :: B.ByteString -> [Param]
parseEncodedParams bs = [ (T.encodeUtf8 k, T.encodeUtf8 $ fromMaybe "" v) | (k,v) <- parseQueryText bs ]
regex :: String -> RoutePattern
regex pattern = Function (const $ T.pack pattern) $ \ req -> fmap (map (B.pack . show *** (T.encodeUtf8 . 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 = fromString
function :: (Request -> T.Text) -> (Request -> Maybe [Param]) -> RoutePattern
function = Function
literal :: String -> RoutePattern
literal = Literal . T.pack