module Snap.Routes
( Routes
, showRoutes
, expandRoutes
, get
, Snap.Routes.head
, addRoute
, post
, put
, delete
, trace
, options
, connect
)
where
import Control.Applicative
import Control.Monad
import Data.ByteString (ByteString)
import Data.Either
import Data.Predicate
import Data.Word
import Snap.Core
import Control.Monad.Trans.State.Strict (State)
import qualified Control.Monad.Trans.State.Strict as State
import qualified Data.List as L
type Error = (Word, Maybe ByteString)
data Pack m where
Pack :: (Show p, Predicate p Request, FVal p ~ Error)
=> p
-> (TVal p -> m ())
-> Pack m
data Route m = Route
{ _method :: !Method
, _path :: !ByteString
, _pred :: !(Pack m)
}
newtype Routes m a = Routes
{ _unroutes :: State [Route m] a }
instance Monad (Routes m) where
return = Routes . return
m >>= f = Routes $ _unroutes m >>= _unroutes . f
addRoute :: (MonadSnap m, Show p, Predicate p Request, FVal p ~ Error)
=> Method
-> ByteString
-> (TVal p -> m ())
-> p
-> Routes m ()
addRoute m r x p = Routes $ State.modify ((Route m r (Pack p x)):)
get, head, post, put, delete, trace, options, connect ::
(MonadSnap m, Show p, Predicate p Request, FVal p ~ Error)
=> ByteString
-> (TVal p -> m ())
-> p
-> Routes m ()
get = addRoute GET
head = addRoute HEAD
post = addRoute POST
put = addRoute PUT
delete = addRoute DELETE
trace = addRoute TRACE
options = addRoute OPTIONS
connect = addRoute CONNECT
showRoutes :: Routes m () -> [String]
showRoutes (Routes routes) =
let rs = reverse $ State.execState routes []
in flip map rs $ \x ->
case _pred x of
Pack p _ -> shows (_method x)
. (' ':)
. shows (_path x)
. (' ':)
. shows p $ ""
expandRoutes :: MonadSnap m => Routes m () -> [(ByteString, m ())]
expandRoutes (Routes routes) =
let rg = grouped . sorted . reverse $ State.execState routes []
in map (\g -> (_path (L.head g), select g)) rg
where
sorted :: [Route m] -> [Route m]
sorted = L.sortBy (\a b -> _path a `compare` _path b)
grouped :: [Route m] -> [[Route m]]
grouped = L.groupBy (\a b -> _path a == _path b)
select :: MonadSnap m => [Route m] -> m ()
select g = do
ms <- filterM byMethod g
if L.null ms
then respond (405, Nothing)
else evalAll ms
where
byMethod :: MonadSnap m => Route m -> m Bool
byMethod x = (_method x ==) <$> getsRequest rqMethod
evalAll :: MonadSnap m => [Route m] -> m ()
evalAll rs = do
req <- getRequest
let (n, y) = partitionEithers $ map (eval req) rs
if null y
then respond (L.head n)
else L.head y
eval :: MonadSnap m => Request -> Route m -> Either Error (m ())
eval rq r = case _pred r of
Pack p h ->
case apply p rq of
F Nothing -> Left (500, Nothing)
F (Just m) -> Left m
T v -> Right (h v)
respond :: MonadSnap m => Error -> m ()
respond (i, msg) = do
putResponse . clearContentLength
. setResponseCode (fromIntegral i)
$ emptyResponse
maybe (return ()) writeBS msg