module Snap.Route
( Routes
, showRoutes
, expandRoutes
, renderErrorWith
, addRoute
, get
, get_
, Snap.Route.head
, head_
, post
, post_
, put
, put_
, delete
, delete_
, trace
, trace_
, options
, options_
, connect
, connect_
)
where
import Control.Applicative hiding (Const)
import Control.Monad
import Control.Monad.State.Strict hiding (get, put)
import Data.ByteString (ByteString)
import Data.Either
import Data.Function
import Data.List hiding (head, delete)
import Data.Predicate
import Data.Predicate.Env (Env)
import Snap.Core
import Snap.Predicate
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as C
import qualified Data.ByteString.Lazy as Lazy
import qualified Data.List as L
import qualified Data.Predicate.Env as E
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)
}
type Renderer = Error -> Maybe Lazy.ByteString
data St m = St ![Route m] !Renderer
iniSt :: St m
iniSt = St [] (fmap Lazy.fromStrict . _message)
newtype Routes m a = Routes
{ _unroutes :: State (St 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 . modify $ \(St !rr !f) ->
St (Route m r (Pack p x) : rr) f
renderErrorWith :: Monad m => Renderer -> Routes m ()
renderErrorWith f = Routes . modify $ \(St !rr _) -> St rr f
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
get_, head_, post_, put_, delete_, trace_, options_, connect_ ::
(MonadSnap m)
=> ByteString
-> (() -> m ())
-> Routes m ()
get_ p h = addRoute GET p h (Const ())
head_ p h = addRoute HEAD p h (Const ())
post_ p h = addRoute POST p h (Const ())
put_ p h = addRoute PUT p h (Const ())
delete_ p h = addRoute DELETE p h (Const ())
trace_ p h = addRoute TRACE p h (Const ())
options_ p h = addRoute OPTIONS p h (Const ())
connect_ p h = addRoute CONNECT p h (Const ())
showRoutes :: Routes m () -> [String]
showRoutes (Routes routes) =
let St rr _ = execState routes iniSt in
flip map (concat (normalise rr)) $ \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 St rr f = execState routes iniSt in
map (\g -> (_path (L.head g), select f g)) (normalise rr)
normalise :: [Route m] -> [[Route m]]
normalise rr =
let rg = grouped . sorted $ rr
paths = map (namelessPath . L.head) rg
ambig = paths \\ nub paths
in if null ambig then rg else error (ambiguityMessage ambig)
where
sorted :: [Route m] -> [Route m]
sorted = sortBy (compare `on` _path)
grouped :: [Route m] -> [[Route m]]
grouped = groupBy ((==) `on` _path)
namelessPath :: Route m -> ByteString
namelessPath =
let colon = 0x3A
slash = 0x2F
fun s = if s /= "" && S.head s == colon then "<>" else s
in S.intercalate "/" . map fun . S.split slash . _path
ambiguityMessage a =
"Paths differing only in variable names are not supported.\n" ++
"Problematic paths (with variable positions denoted by <>):\n" ++
show a
data Handler m = Handler
{ _delta :: !Delta
, _handler :: !(m ())
}
select :: MonadSnap m => Renderer -> [Route m] -> m ()
select f g = do
ms <- filterM byMethod g
if null ms
then do
respond f (Error 405 Nothing)
modifyResponse (setHeader "Allow" validMethods)
else evalAll ms
where
byMethod :: MonadSnap m => Route m -> m Bool
byMethod x = (_method x ==) <$> getsRequest rqMethod
validMethods :: ByteString
validMethods = S.intercalate "," $ nub (C.pack . show . _method <$> g)
evalAll :: MonadSnap m => [Route m] -> m ()
evalAll rs = do
req <- getRequest
let (n, y) = partitionEithers . snd $ foldl' (evalSingle req) (E.empty, []) rs
if null y
then respond f (L.head n)
else closest y
evalSingle :: MonadSnap m => Request -> (Env, [Either Error (Handler m)]) -> Route m -> (Env, [Either Error (Handler m)])
evalSingle rq (e, rs) r =
case _pred r of
Pack p h ->
case runState (apply p rq) e of
(F m, e') -> (e', Left m : rs)
(T d v, e') -> (e', Right (Handler d (h v)) : rs)
closest :: MonadSnap m => [Handler m] -> m ()
closest = foldl' (<|>) pass
. map _handler
. sortBy (compare `on` _delta)
respond :: MonadSnap m => Renderer -> Error -> m ()
respond f e = do
putResponse . clearContentLength
. setResponseCode (fromIntegral . _status $ e)
$ emptyResponse
maybe (return ()) writeLBS (f e)