{-# 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