packages feed

happstack-static-routing (empty) → 0.1

raw patch · 5 files changed

+321/−0 lines, 5 filesdep +basedep +containersdep +happstack-serversetup-changed

Dependencies added: base, containers, happstack-server, list-tries, transformers

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2011, Scrive++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Scrive nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ happstack-static-routing.cabal view
@@ -0,0 +1,43 @@+Name:                happstack-static-routing+Version:             0.1+Synopsis: Support for static URL routing with overlap detection for Happstack.++Description: If you have a large routing table in Happstack and want+  to insert a new handler, you might run into overlap problems+  (ambiguity).  The new handler might not fire because it matches+  against a URL that is already handled earlier.  Or if you put your+  new handler first, it might steal requests from existing handlers.++  This Happstack support library allows you to detect overlap cases+  and build unambiguous routing tables where the order of the handlers+  is irrelevant.++License:             BSD3+License-file:        LICENSE+Author:              Scrive+Maintainer:          magnus@scrive.com+Homepage:            https://github.com/carlssonia/happstack-static-routing+Stability:           Development+Category:            Web, Distributed Computing+Build-type:          Simple+Cabal-version:       >=1.6+++library+  exposed-modules:+     Happstack.StaticRouting++  other-modules:+     Happstack.StaticRouting.Internal++  hs-source-dirs: src++  build-depends: base >= 4 && <= 10+  build-depends: happstack-server >= 6+  build-depends: containers >= 0.3+  build-depends: list-tries >= 0.4+  build-depends: transformers >= 0.2++source-repository head+  type: git+  location: git://github.com/carlssonia/happstack-static-routing.git
+ src/Happstack/StaticRouting.hs view
@@ -0,0 +1,32 @@+{-# OPTIONS_HADDOCK prune #-}++-- | Support for static routing tables in Happstack.  The routing+-- tables are order independent as long as:+--+-- * if any two handlers overlap, one of them handles a more specific+-- path than the other.  The more specific handler is then tried+-- first.+--+-- Routing tables are constructed from 'dir', 'path', 'remainingPath',+-- 'choice', and (for now) 'param'.+--+-- A routing table is compiled by using 'compile'.  The result is an+-- overlap report, and a prefix tree that is used to efficiently+-- dispatch requests by means of 'dispatch'.+--+-- See the file @src\/Happstack\/StaticRouting\/Test.hs@ in the distribution+-- for examples.++module Happstack.StaticRouting+  ( Route+  , compile+  , choice+  , dir+  , path+  , Path+  , remainingPath+  , param+  , handler+  ) where++import Happstack.StaticRouting.Internal
+ src/Happstack/StaticRouting/Internal.hs view
@@ -0,0 +1,213 @@+{-# LANGUAGE OverlappingInstances, FunctionalDependencies, ScopedTypeVariables,+    MultiParamTypeClasses, FlexibleInstances, UndecidableInstances,+    FlexibleContexts #-}+{-# 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 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)+import Data.Maybe++-- | Static routing tables consisting of handlers of type 'a'.+data Route a =+    Dir Segment (Route a)+  | Handler EndSegment a+  | Param String (Route a)+  | Choice [Route a]++-- For backwards compatibility with GHC 6.12+handler :: EndSegment -> a -> Route a+handler = Handler++newtype Segment =+    StringS String+  deriving (Show, Eq, Ord)++type EndSegment = (Maybe Int, H.Method)++-- | Support for varying number of arguments to 'path' handlers.+class Path m a b | a -> m b where+  pathHandler :: (m b -> m c) -> a -> m c+  arity :: a -> Int++instance (FromReqURI d, ServerMonad m, MonadPlus m, Path m a b) => Path m (d -> a) b where+  pathHandler w f = H.path (pathHandler w . f)+  arity f = 1 + arity (f undefined)++instance Path m (m b) b where+  pathHandler w m = w m+  arity _ = 0++-- | Pop a path element if it matches the given string.+dir :: String -> Route a -> Route a+dir = Dir . StringS++-- | 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 :: Path m h a => H.Method -> (m a -> m b) -> h -> Route (m b)+path m w h = Handler (Just (arity h),m) (pathHandler w h)++-- | Expect zero or more segments.+remainingPath :: H.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)++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)++-- | 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+     )+++-- 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]++dispatchRemainingPath :: MonadPlus m => Map k [m a] -> m a+dispatchRemainingPath m = msum (map msum (Map.elems m))++-- | 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++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++    Nothing -> []) +++  [ [ (k:ks,a) | (ks,a) <- l ]+  | (k,t') <- Map.assocs (Trie.children1 t)+  , l <- pathOverlaps (R t') ]++showOverlaps :: [[([Segment],[(EndSegment,[(Param,[a])])])]] -> String+showOverlaps = unlines . intercalate [[]] . map (concatMap showPath)++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)++-- | 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') ]