packages feed

happstack-static-routing 0.4.0 → 0.4.2

raw patch · 3 files changed

+56/−25 lines, 3 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

+ Happstack.StaticRouting: param :: Route a -> Route a

Files

happstack-static-routing.cabal view
@@ -1,5 +1,5 @@ Name:                happstack-static-routing-Version:             0.4.0+Version:             0.4.2 Synopsis: Support for static URL routing with overlap detection for Happstack.  Description: If you have a large routing table in Happstack and want
src/Happstack/StaticRouting.hs view
@@ -8,7 +8,7 @@ -- first. -- -- Routing tables are constructed from 'dir', 'path', 'remainingPath',--- 'choice', and (for now) 'param'.+-- 'choice', and 'param'. -- -- A routing table is compiled by using 'compile'.  The result is an -- overlap report, and a prefix tree that is used to efficiently@@ -22,6 +22,7 @@   , compile   , choice   , dir+  , param   , path   , Path   , remainingPath
src/Happstack/StaticRouting/Internal.hs view
@@ -15,26 +15,30 @@ import qualified Data.ListTrie.Map as Trie import Data.Map(Map) import qualified Data.Map as Map-import Data.List(intercalate)+import Data.List(intercalate,find) import Data.Maybe  -- | Static routing tables consisting of handlers of type 'a'. data Route a =     Dir Segment (Route a)-  | Handler EndSegment a+  | Param (Route a)+  | Handler EndSegment CheckApply a   | Choice [Route a]   deriving (Show, Functor) -newtype Segment =-    StringS String+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@@ -43,7 +47,12 @@   ) => 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@@ -54,14 +63,20 @@                             -> 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@@ -69,11 +84,11 @@ -- | 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) (pathHandler trans h)+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)+remainingPath m = Handler (Nothing,m) (\_ -> True)  newtype RouteTree a =   R { unR :: Trie.TrieMap Map Segment (Map EndSegment a) } deriving (Show, Functor)@@ -81,7 +96,7 @@ type Segments = ([Segment],EndSegment)  -- | Compile a route into a 'RouteTree'.  Turn overlapping routes into 'Nothing'-routeTreeWithOverlaps :: Route a -> RouteTree (Maybe a)+routeTreeWithOverlaps :: Route a -> RouteTree (Maybe (CheckApply,a)) routeTreeWithOverlaps r =   R $ foldr (\((ps,es),m) ->               Trie.insertWith (Map.unionWith merge)@@ -94,32 +109,41 @@  -- | 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 =+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, a)]+flatten :: Route a -> [(Segments, (CheckApply, a))] flatten = f where   f (Dir s r) = map (first (first (s:))) (f r)-  f (Handler e a) = [(([], e), a)]+  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@@ -136,25 +160,31 @@  -- | 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)+            RouteTree (CheckApply,(m Response)) -> m (Maybe Response) dispatch t = do   rq  <- askRq-  case dispatch' (rqMethod rq) (rqPaths rq) t of+  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.-dispatch' :: forall a . Method -> [String] -> RouteTree a -> Maybe ([String], a)-dispatch' m ps (R t) = dChildren ps `mplus` fmap (ps,) dNode+-- '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' m ps' . R+  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 = 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+  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