happstack-static-routing 0.3.2 → 0.4.0

raw patch · 3 files changed

+91/−153 lines, 3 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• happstack-static-routing.cabal +1/−1
• src/Happstack/StaticRouting.hs +0/−2
• src/Happstack/StaticRouting/Internal.hs +90/−150

@@ -1,5 +1,5 @@ Name:                happstack-static-routing-Version:             0.3.2+Version:             0.4.0 Synopsis: Support for static URL routing with overlap detection for Happstack.  Description: If you have a large routing table in Happstack and want

@@ -25,8 +25,6 @@   , path   , Path   , remainingPath-  , param-  , handler   ) where  import Happstack.StaticRouting.Internal

@@ -1,14 +1,15 @@ {-# LANGUAGE OverlappingInstances, FunctionalDependencies, ScopedTypeVariables,     MultiParamTypeClasses, FlexibleInstances, UndecidableInstances,-    FlexibleContexts, DeriveFunctor #-}+    FlexibleContexts, DeriveFunctor, PatternGuards, TupleSections #-} {-# OPTIONS_HADDOCK hide #-}  module Happstack.StaticRouting.Internal where -import Happstack.Server(askRq, rqPaths, rqMethod, localRq, ServerMonad,-  HasRqData, methodM, look, FromReqURI)-import qualified Happstack.Server as H-import Control.Monad(msum, MonadPlus, mzero, mplus)+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@@ -21,19 +22,14 @@ data Route a =     Dir Segment (Route a)   | Handler EndSegment a-  | Param String (Route a)   | Choice [Route a]-  deriving Functor---- For backwards compatibility with GHC 6.12-handler :: EndSegment -> a -> Route a-handler = Handler+  deriving (Show, Functor)  newtype Segment =     StringS String   deriving (Show, Eq, Ord) -type EndSegment = (Maybe Int, H.Method)+type EndSegment = (Maybe Int, Method)  -- | Support for varying number of arguments to 'path' handlers. class Path m hm h r | h r -> m where@@ -43,12 +39,21 @@ instance (     FromReqURI v   , ServerMonad hm-  , MonadPlus hm   , Path m hm h r   ) => Path m hm (v -> h) r where-    pathHandler trans f = H.path (pathHandler trans . f)+    pathHandler trans f = applyPath (pathHandler trans . f)     arity m f = 1 + arity m (f undefined) +-- | 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@@ -63,158 +68,93 @@  -- | 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-     => H.Method -> (m r -> hm r') -> h -> Route (hm r')+     => Method -> (m r -> hm r') -> h -> Route (hm r') path m trans h = Handler (Just (arity (undefined::hm r) h), m) (pathHandler trans h)  -- | Expect zero or more segments.-remainingPath :: H.Method -> h -> Route h+remainingPath :: Method -> h -> Route h remainingPath m = Handler (Nothing,m) --- | DEPRECATED. Expect a specific parameter to be present.-param :: String -> Route a -> Route a-param = Param---- | Extract handler monad from a route.-extract :: (ServerMonad m, MonadPlus m, HasRqData m, MonadIO m) => Route (m a) -> m a-extract = f Nothing where-  f p (Dir (StringS s) r) = H.dir s (f p r)-  f (Just p) (Param p' _) = error $ "extract: cannot handle more than one param: "++ show(p,p')-  f _ (Param p r) = f (Just p) r-  f p (Handler (_,m) a) = doParam p >> methodM m >> a-  f p (Choice rs) = msum (map (f p) rs)--doParam :: (MonadIO m, HasRqData m, ServerMonad m, MonadPlus m) =>-           Maybe String -> m ()-doParam Nothing = return ()-doParam (Just p) = H.getDataFn (look p) >>= either (const mzero) (const (return ()))--type Param = Maybe String newtype RouteTree a =-  R { unR :: Trie.TrieMap Map Segment (Map EndSegment (Map Param [a])) } deriving (Show)+  R { unR :: Trie.TrieMap Map Segment (Map EndSegment a) } deriving (Show, Functor)  type Segments = ([Segment],EndSegment) -routeTree :: (ServerMonad m, MonadPlus m) => Route (m a) -> RouteTree (m a)-routeTree r = R $ foldr (\(((ps,es),mp),m) ->-                          Trie.insertWith (Map.unionWith (Map.unionWith (++)))-                              ps-                              (Map.singleton es (Map.singleton mp [m])))-                  Trie.empty (flatten r)--flatten :: (ServerMonad m, MonadPlus m) => Route (m a) -> [((Segments, Param), m a)]-flatten = f Nothing where-  f p (Dir s r) = map (first (first (first (s:)))) (f p r)-  f (Just p) (Param p' _) = error $ "flatten: cannot handle more than one param: "++show (p,p')-  f _ (Param p' r) = f (Just p') r-  f p (Handler e a) = [((([], e),p), a)]-  f p (Choice rs) = concatMap (f p) rs---- | Compile routes, also return possible overlap report.  If the--- overlap report is 'Nothing', the routing table is order--- independent.  If the overlap report is @Just s@, then @s@ is a--- textual representation of all the paths that are order dependent,--- suitable for a warning message.-compile :: (MonadIO m, HasRqData m, ServerMonad m, MonadPlus m) =>-           Route (m a) -> (m a, Maybe String)-compile r = ( dispatch t-            , if null os then Nothing-              else Just $ "Overlapping handlers: \n"++ showOverlaps os-            )-  where t = routeTree r-        os = overlaps True t--maybezero :: MonadPlus m => Maybe a -> (a -> m b) -> m b-maybezero = flip (maybe mzero)+-- | Compile a route into a 'RouteTree'.  Turn overlapping routes into 'Nothing'+routeTreeWithOverlaps :: Route a -> RouteTree (Maybe 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 --- | Dispatch a request given a route.  Give priority to more specific paths--- in case of overlap.-dispatch :: (MonadIO m, HasRqData m, ServerMonad m, MonadPlus m) =>-            RouteTree (m a) -> m a-dispatch (R t) = do-  let m = Trie.children1 t-  rq  <- askRq-  let ps = rqPaths rq-  (case ps of-      p:xs -> maybezero (Map.lookup (StringS p) m)-                        (localRq (\newRq -> newRq{rqPaths = xs}) . dispatch . R)-      []   -> mzero)-    -- most specific: match against a given next segment-    `mplus`-    (maybezero (Trie.lookup [] t) $ \em ->-     maybezero (Map.lookup (Just (length ps), rqMethod rq) em) dispatchParams-    -- or else a 'path' taking a given specific number of remaining segments-     `mplus`-     maybezero (Map.lookup (Nothing, rqMethod rq) em) dispatchRemainingPath-     -- least specific: a 'remainingPath' taking any number of remaining segments-     )+-- | Check for overlaps in a 'RouteTree', returning either an error+-- message in case of an overlap, or a 'RouteTree' without overlaps.+routeTree :: RouteTree (Maybe a) -> Either String (RouteTree a)+routeTree t | null os   = Right $ fmap fromJust t+            | otherwise =+                Left $ unlines $+                  "Happstack.StaticRouting: Overlapping handlers in" :+                  map (("  "++) . showSegments) os +  where os = [ (ss, es) | (ss, m) <- Trie.toList (unR t)+             , (es, Nothing) <- Map.toList m+             ] --- We want first to handle ones with params-dispatchParams :: (MonadIO m, HasRqData m, ServerMonad m, MonadPlus m) =>-                  Map (Maybe String) [m a] -> m a-dispatchParams m = let-                    (paramfull,paramless) = Map.partitionWithKey (const . isJust) m-                   in msum $ [doParam p >> msum hs | (p,hs) <- Map.assocs paramfull] ++ [msum hs | (Nothing,hs) <- Map.assocs paramless]+showSegments :: Segments -> String+showSegments (ss, es) = concatMap showSegment ss ++ showEndSegment es+  where -dispatchRemainingPath :: MonadPlus m => Map k [m a] -> m a-dispatchRemainingPath m = msum (map msum (Map.elems m))+  showSegment :: Segment -> String+  showSegment (StringS e) = "dir " ++ show e ++ " $ " --- | All paths with more than one handler.-overlaps :: forall a .-            Bool -- ^ Only include order-dependent paths (exclude paths overlapping with more specific paths)-         -> RouteTree a -> [[([Segment],[(EndSegment,[(Param,[a])])])]]-overlaps eso t = (filter (not . null) $-                  map (filter (not . null . snd) . (:[]) . second f) $-                  flattenTree t) ++-                 if eso then [] else  pathOverlaps t-  where f :: [(EndSegment,[(Param,[a])])] -> [(EndSegment,[(Param,[a])])]-        f l = (filter (not . null . snd) . map (second g)) l-        g l@((Nothing,_):_:_) | not eso = l  -- non-parameter handler overlaps with parameter handlers-        g l = filter ((>1) . length . snd) l -- more than one handler for this path+  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 -pathOverlaps :: RouteTree a -> [[([Segment], [(EndSegment, [(Param, [a])])])]]-pathOverlaps (R t) =-  (case Trie.lookup [] t of-    Just em -> filter ((>1) . length) $ map f (Map.keys em)-      where f es1 = filter ((>0) . length . snd)-                    [ (ks, filter (lengthOverlaps es1 (length ks)) as)-                    | (ks,as) <- flattenTree (R t) ]-            lengthOverlaps (a1,m1) ksl ((a2,m2),_) =-              m1 == m2 && case (a1,a2) of-                            (Nothing,_) -> True-                            (Just i1,Nothing) -> i1 >= ksl-                            (Just i1,Just i2) -> i1 == ksl + i2+flatten :: Route a -> [(Segments, a)]+flatten = f where+  f (Dir s r) = map (first (first (s:))) (f r)+  f (Handler e a) = [(([], e), a)]+  f (Choice rs) = concatMap f rs -    Nothing -> []) ++-  [ [ (k:ks,a) | (ks,a) <- l ]-  | (k,t') <- Map.assocs (Trie.children1 t)-  , l <- pathOverlaps (R t') ]+-- | 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 -showOverlaps :: [[([Segment],[(EndSegment,[(Param,[a])])])]] -> String-showOverlaps = unlines . intercalate [[]] . map (concatMap showPath)+-- | 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 (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 -showPath :: ([Segment],[(EndSegment,[(Param,[a])])]) -> [String]-showPath (ss,es) =-  [ intercalate "/" (map showSegment ss++-                     showArity i)++-                     showParam p++showMethod m++-                     showHandlers hs-  | ((i,m),ps) <- es, (p,hs) <- ps ]-  where showParam Nothing  = ""-        showParam (Just p) = "?"++p++"=*"-        showMethod H.GET = ""-        showMethod m = " ("++show m++")"-        showSegment (StringS s) = s-        showArity Nothing = ["**"]-        showArity (Just i) = replicate i "*"-        showHandlers hs | length hs == 1 = ""-                        | otherwise      = " -> "++show (length hs)+-- | Dispatch a request given a method and path.  Give priority to more specific paths.+dispatch' :: forall a . Method -> [String] -> RouteTree a -> Maybe ([String], a)+dispatch' m ps (R t) = dChildren ps `mplus` fmap (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' m ps' . R+  dChildren []      = Nothing+  dNode :: Maybe a+  dNode = Trie.lookup [] t >>= \em ->+   -- or else a 'path' taking a given specific number of remaining segments+           Map.lookup (Just (length ps), m) em+  -- least specific: a 'remainingPath' taking any number of remaining segments+     `mplus` Map.lookup (Nothing, m) em --- | Convert to a list of path-value pairs.-flattenTree :: RouteTree a -> [([Segment],[(EndSegment,[(Param,[a])])])]-flattenTree (R t) =-  (case Trie.lookup [] t of-     Just em -> [([], map (second Map.assocs) (Map.assocs em))]-     Nothing -> []) ++-  [ (k:ks,a) | (k,t') <- Map.assocs (Trie.children1 t)-             , (ks,a) <- flattenTree (R t') ]