{-# LANGUAGE OverlappingInstances, FunctionalDependencies, ScopedTypeVariables,
MultiParamTypeClasses, FlexibleInstances, UndecidableInstances,
FlexibleContexts, DeriveFunctor, PatternGuards, TupleSections #-}
{-# OPTIONS_HADDOCK hide #-}
module Happstack.StaticRouting.Internal where
import Debug.Trace
import Happstack.Server(askRq, rqPaths, rqMethod, localRq, ServerMonad, Method,
HasRqData, methodM, look, FromReqURI, fromReqURI, notFound, Response, toResponse, FilterMonad)
import Control.Monad(msum, MonadPlus, mzero, mplus, liftM)
import Control.Monad.IO.Class(MonadIO)
import Control.Arrow(first, second)
import qualified Data.ListTrie.Map as Trie
import Data.Map(Map)
import qualified Data.Map as Map
import Data.List(intercalate,find)
import Data.Maybe
-- | Static routing tables consisting of handlers of type 'a'.
data Route a =
Dir Segment (Route a)
| Param (Route a)
| Handler EndSegment CheckApply a
| Choice [Route a]
deriving (Show, Functor)
data Segment =
StringS String | ParamS
deriving (Show, Eq, Ord)
type EndSegment = (Maybe Int, Method)
type CheckApply = [String] -> Bool
-- | Support for varying number of arguments to 'path' handlers.
class Path m hm h r | h r -> m where
pathHandler :: forall r'. (m r -> hm r') -> h -> hm r'
arity :: hm r -> h -> Int
canBeApplied :: hm r -> h -> [String] -> Bool
instance (
FromReqURI v
, ServerMonad hm
, Path m hm h r
) => Path m hm (v -> h) r where
pathHandler trans f = applyPath (pathHandler trans . f)
arity m f = 1 + arity m (f undefined)
canBeApplied m f [] = False
canBeApplied m f (s:ss) = case (fromReqURI s) of
Just p -> canBeApplied m (f p) ss
Nothing -> False
-- | Pop a path element and parse it using the 'fromReqURI' in the
-- 'FromReqURI' class. Variant of Happstack.Server.path without 'mzero'
applyPath :: (FromReqURI a, ServerMonad m) => (a -> m b) -> m b
applyPath handle = do
rq <- askRq
case rqPaths rq of
(p:xs) | Just a <- fromReqURI p
-> localRq (\newRq -> newRq{rqPaths = xs}) (handle a)
_ -> error "Happstack.StaticRouting.applyPath"
instance Path m hm (m r) r where
pathHandler trans mr = trans mr
arity _ _ = 0
canBeApplied _ _ _ = True
-- | Pop a path element if it matches the given string.
dir :: String -> Route a -> Route a
dir = Dir . StringS
-- | Pop a path element, and store it to use with handler
param :: Route a -> Route a
param = Param
-- | Combine several route alternatives into one.
choice :: [Route a] -> Route a
choice = Choice
-- | Expect the given method, and exactly 'n' more segments, where 'n' is the arity of the handler.
path :: forall m hm h r r'. Path m hm h r
=> Method -> (m r -> hm r') -> h -> Route (hm r')
path m trans h = Handler (Just (arity (undefined::hm r) h), m) (canBeApplied (undefined::hm r) h) (pathHandler trans h)
-- | Expect zero or more segments.
remainingPath :: Method -> h -> Route h
remainingPath m = Handler (Nothing,m) (\_ -> True)
newtype RouteTree a =
R { unR :: Trie.TrieMap Map Segment (Map EndSegment a) } deriving (Show, Functor)
type Segments = ([Segment],EndSegment)
-- | Compile a route into a 'RouteTree'. Turn overlapping routes into 'Nothing'
routeTreeWithOverlaps :: Route a -> RouteTree (Maybe (CheckApply,a))
routeTreeWithOverlaps r =
R $ foldr (\((ps,es),m) ->
Trie.insertWith (Map.unionWith merge)
ps
(Map.singleton es (Just m)))
Trie.empty
(flatten r)
where merge (Just _) _ = Nothing -- overlap
merge Nothing m = m
-- | Check for overlaps in a 'RouteTree', returning either an error
-- message in case of an overlap, or a 'RouteTree' without overlaps.
routeTree :: RouteTree (Maybe (CheckApply,a)) -> Either String (RouteTree (CheckApply,a))
routeTree t | not $ null os =
Left $ unlines $
"Happstack.StaticRouting: Overlapping handlers in" :
map ((" "++) . showSegments) os
| not $ null is =
Left $ unlines $
"Happstack.StaticRouting: Unreachable handler due to ignored parameter in" :
map ((" "++) . showSegments) is
| otherwise = Right $ fmap fromJust t
where os = [ (ss, es) | (ss, m) <- Trie.toList (unR t)
, (es, Nothing) <- Map.toList m
]
is = [ (ss, es) | (ss, m) <- Trie.toList (unR t)
, (es@(Just p, _), _) <- Map.toList m
, p < length (filter ((==) ParamS) $ ss)
]
showSegments :: Segments -> String
showSegments (ss, es) = concatMap showSegment ss ++ showEndSegment es
where
showSegment :: Segment -> String
showSegment (StringS e) = "dir " ++ show e ++ " $ "
showSegment (ParamS) = "param (used in handler) $ "
showEndSegment :: EndSegment -> String
showEndSegment (Just a, m) = "<handler> -- with method " ++ show m ++ " and arity " ++ show a
showEndSegment (Nothing, m) = "remainingPath $ <handler> -- with method " ++ show m
flatten :: Route a -> [(Segments, (CheckApply, a))]
flatten = f where
f (Dir s r) = map (first (first (s:))) (f r)
f (Param r) = map (first (first (ParamS:))) (f r)
f (Handler e ca a) = [(([], e), (ca, a))]
f (Choice rs) = concatMap f rs
-- | Compile routes or return overlap report. Returns 'Left e' in
-- case of order-dependent overlap between handlers, where 'e'
-- describes the overlap. Returns 'Right h', where h is a compiled
-- handler that returns 'Nothing' in case no matching handler was
-- found, otherwise 'Just response'.
compile :: (MonadIO m, HasRqData m, ServerMonad m, FilterMonad Response m) =>
Route (m Response) -> Either String (m (Maybe Response))
compile r = case t of
Left s -> Left s
Right t -> Right $ dispatch t
where t = routeTree $ routeTreeWithOverlaps r
-- | Dispatch a request given a route. Give priority to more specific paths.
dispatch :: forall m . (MonadIO m, HasRqData m, ServerMonad m, FilterMonad Response m) =>
RouteTree (CheckApply,(m Response)) -> m (Maybe Response)
dispatch t = do
rq <- askRq
case dispatch' [] (rqMethod rq) (rqPaths rq) t of
Just (rq', h) -> Just `liftM` localRq (\newRq -> newRq{ rqPaths = rq'}) h
Nothing -> return Nothing
-- | Dispatch a request given a method and path. Give priority to more specific paths.
-- 'params' holds path segments that where matched 'ParamS' segment.
dispatch' :: forall a . [String] -> Method -> [String] -> RouteTree (CheckApply,a) -> Maybe ([String], a)
dispatch' params m ps (R t) = dChildren ps `mplus` fmap (params ++ ps,) dNode
where
-- most specific: look up a segment in the children and recurse
dChildren :: [String] -> Maybe ([String], a)
dChildren (p:ps') = ((Map.lookup (StringS p) (Trie.children1 t)) >>= dispatch' params m ps' . R)
`mplus` ((Map.lookup (ParamS) (Trie.children1 t)) >>= dispatch' (params ++ [p]) m ps' . R)
dChildren [] = Nothing
dNode :: Maybe a
dNode = do
-- Find a handler that does not need any more segments
em <- Trie.lookup [] t
-- Select one that matches number of parameters or one that will ignore them (created with 'remainingPath')
(ac,h) <- (Map.lookup (Just (length ps + length params), m) em) `mplus` (Map.lookup (Nothing, m) em)
-- Make sure that params can converted with fromReqURI
if (ac (params ++ ps))
then return h
else Nothing