1 {-# LANGUAGE RankNTypes #-}
    2 {-# LANGUAGE FlexibleContexts #-}
    3 module Snap.Internal.Routing where
    4 
    5 
    6 ------------------------------------------------------------------------------
    7 import           Control.Applicative ((<|>))
    8 import           Data.ByteString (ByteString)
    9 import           Data.ByteString.Internal (c2w)
   10 import qualified Data.ByteString as B
   11 import           Data.Monoid
   12 import qualified Data.Map as Map
   13 
   14 ------------------------------------------------------------------------------
   15 import           Snap.Internal.Http.Types
   16 import           Snap.Internal.Types
   17 
   18 
   19 ------------------------------------------------------------------------------
   20 {-|
   21 
   22 The internal data type you use to build a routing tree.  Matching is
   23 done unambiguously.
   24 
   25 'Capture' and 'Dir' routes can have a "fallback" route:
   26 
   27   - For 'Capture', the fallback is routed when there is nothing to capture
   28   - For 'Dir', the fallback is routed when we can't find a route in its map
   29 
   30 Fallback routes are stacked: i.e. for a route like:
   31 
   32 > Dir [("foo", Capture "bar" (Action bar) NoRoute)] baz
   33 
   34 visiting the URI foo/ will result in the "bar" capture being empty and
   35 triggering its fallback. It's NoRoute, so we go to the nearest parent
   36 fallback and try that, which is the baz action.
   37 
   38 -}
   39 data Route a m = Action ((MonadSnap m) => m a)   -- wraps a 'Snap' action
   40                -- captures the dir in a param
   41                | Capture ByteString (Route a m) (Route a m)
   42                -- match on a dir
   43                | Dir (Map.Map ByteString (Route a m)) (Route a m)
   44                | NoRoute
   45 
   46 
   47 ------------------------------------------------------------------------------
   48 instance Monoid (Route a m) where
   49     mempty = NoRoute
   50 
   51     mappend NoRoute r = r
   52 
   53     mappend l@(Action a) r = case r of
   54       (Action a')       -> Action (a <|> a')
   55       (Capture p r' fb) -> Capture p r' (mappend fb l)
   56       (Dir _ _)         -> mappend (Dir Map.empty l) r
   57       NoRoute           -> l
   58 
   59     -- Whenever we're unioning two Captures and their capture variables
   60     -- differ, we have an ambiguity. We resolve this in the following order:
   61     --   1. Prefer whichever route is longer
   62     --   2. Else, prefer whichever has the earliest non-capture
   63     --   3. Else, prefer the right-hand side
   64     mappend l@(Capture p r' fb) r = case r of
   65       (Action _)           -> Capture p r' (mappend fb r)
   66       (Capture p' r'' fb')
   67               | p == p'    -> Capture p (mappend r' r'') (mappend fb fb')
   68               | rh' > rh'' -> Capture p r' (mappend fb r)
   69               | rh' < rh'' -> Capture p' r'' (mappend fb' l)
   70               | en' < en'' -> Capture p r' (mappend fb r)
   71               | otherwise  -> Capture p' r'' (mappend fb' l)
   72         where
   73           rh'  = routeHeight r'
   74           rh'' = routeHeight r''
   75           en'  = routeEarliestNC r' 1
   76           en'' = routeEarliestNC r'' 1
   77       (Dir rm fb')         -> Dir rm (mappend fb' l)
   78       NoRoute              -> l
   79 
   80     mappend l@(Dir rm fb) r = case r of
   81       (Action _)      -> Dir rm (mappend fb r)
   82       (Capture _ _ _) -> Dir rm (mappend fb r)
   83       (Dir rm' fb')   -> Dir (Map.unionWith mappend rm rm') (mappend fb fb')
   84       NoRoute         -> l
   85 
   86 
   87 ------------------------------------------------------------------------------
   88 routeHeight :: Route a m -> Int
   89 routeHeight r = case r of
   90   NoRoute          -> 1
   91   (Action _)       -> 1
   92   (Capture _ r' _) -> 1+routeHeight r'
   93   (Dir rm _)       -> 1+foldl max 1 (map routeHeight $ Map.elems rm)
   94 
   95 routeEarliestNC :: Route a m -> Int -> Int
   96 routeEarliestNC r n = case r of
   97   NoRoute           -> n
   98   (Action _)        -> n
   99   (Capture _ r' _)  -> routeEarliestNC r' n+1
  100   (Dir _ _)         -> n
  101 
  102 
  103 ------------------------------------------------------------------------------
  104 -- | A web handler which, given a mapping from URL entry points to web
  105 -- handlers, efficiently routes requests to the correct handler.
  106 --
  107 -- The URL entry points are given as relative paths, for example:
  108 --
  109 -- > route [ ("foo/bar/quux", fooBarQuux) ]
  110 --
  111 -- If the URI of the incoming request is
  112 --
  113 -- > /foo/bar/quux
  114 --
  115 -- or
  116 --
  117 -- > /foo/bar/quux/...anything...
  118 --
  119 -- then the request will be routed to \"@fooBarQuux@\", with 'rqContextPath'
  120 -- set to \"@\/foo\/bar\/quux\/@\" and 'rqPathInfo' set to
  121 -- \"@...anything...@\".
  122 --
  123 -- A path component within an URL entry point beginning with a colon (\"@:@\")
  124 -- is treated as a /variable capture/; the corresponding path component within
  125 -- the request URI will be entered into the 'rqParams' parameters mapping with
  126 -- the given name. For instance, if the routes were:
  127 --
  128 -- > route [ ("foo/:bar/baz", fooBazHandler) ]
  129 --
  130 -- Then a request for \"@\/foo\/saskatchewan\/baz@\" would be routed to
  131 -- @fooBazHandler@ with a mapping for:
  132 --
  133 -- > "bar" => "saskatchewan"
  134 --
  135 -- in its parameters table.
  136 --
  137 -- Longer paths are matched first, and specific routes are matched before
  138 -- captures. That is, if given routes:
  139 --
  140 -- > [ ("a", h1), ("a/b", h2), ("a/:x", h3) ]
  141 --
  142 -- a request for \"@\/a\/b@\" will go to @h2@, \"@\/a\/s@\" for any /s/ will
  143 -- go to @h3@, and \"@\/a@\" will go to @h1@.
  144 --
  145 -- The following example matches \"@\/article@\" to an article index,
  146 -- \"@\/login@\" to a login, and \"@\/article\/...@\" to an article renderer.
  147 --
  148 -- > route [ ("article",     renderIndex)
  149 -- >       , ("article/:id", renderArticle)
  150 -- >       , ("login",       method POST doLogin) ]
  151 --
  152 route :: MonadSnap m => [(ByteString, m a)] -> m a
  153 route rts = do
  154   p <- getRequest >>= maybe pass return . urlDecode . rqPathInfo
  155   route' (return ()) ([], splitPath p) Map.empty rts'
  156   where
  157     rts' = mconcat (map pRoute rts)
  158 
  159 
  160 ------------------------------------------------------------------------------
  161 -- | The 'routeLocal' function is the same as 'route'', except it doesn't
  162 -- change the request's context path. This is useful if you want to route to a
  163 -- particular handler but you want that handler to receive the 'rqPathInfo' as
  164 -- it is.
  165 routeLocal :: MonadSnap m => [(ByteString, m a)] -> m a
  166 routeLocal rts = do
  167     req    <- getRequest
  168     let ctx = rqContextPath req
  169     let p   = rqPathInfo req
  170     p' <- maybe pass return $ urlDecode p
  171     let md  = modifyRequest $ \r -> r {rqContextPath=ctx, rqPathInfo=p}
  172 
  173     (route' md ([], splitPath p') Map.empty rts') <|> (md >> pass)
  174 
  175   where
  176     rts' = mconcat (map pRoute rts)
  177 
  178 
  179 ------------------------------------------------------------------------------
  180 splitPath :: ByteString -> [ByteString]
  181 splitPath = B.splitWith (== (c2w '/'))
  182 
  183 
  184 ------------------------------------------------------------------------------
  185 pRoute :: MonadSnap m => (ByteString, m a) -> Route a m
  186 pRoute (r, a) = foldr f (Action a) hier
  187   where
  188     hier   = filter (not . B.null) $ B.splitWith (== (c2w '/')) r
  189     f s rt = if B.head s == c2w ':'
  190         then Capture (B.tail s) rt NoRoute
  191         else Dir (Map.fromList [(s, rt)]) NoRoute
  192 
  193 
  194 ------------------------------------------------------------------------------
  195 route' :: MonadSnap m
  196        => m ()
  197        -> ([ByteString], [ByteString])
  198        -> Params
  199        -> Route a m
  200        -> m a
  201 route' pre (ctx, _) params (Action action) =
  202     localRequest (updateContextPath (B.length ctx') . updateParams)
  203                  (pre >> action)
  204   where
  205     ctx' = B.intercalate (B.pack [c2w '/']) (reverse ctx)
  206     updateParams req = req
  207       { rqParams = Map.unionWith (++) params (rqParams req) }
  208 
  209 route' pre (ctx, [])       params (Capture _ _  fb) =
  210     route' pre (ctx, []) params fb
  211 route' pre (ctx, cwd:rest) params (Capture p rt fb) =
  212     (route' pre (cwd:ctx, rest) params' rt) <|>
  213     (route' pre (ctx, cwd:rest) params  fb)
  214   where
  215     params' = Map.insertWith (++) p [cwd] params
  216 
  217 route' pre (ctx, [])       params (Dir _   fb) =
  218     route' pre (ctx, []) params fb
  219 route' pre (ctx, cwd:rest) params (Dir rtm fb) =
  220     case Map.lookup cwd rtm of
  221       Just rt -> (route' pre (cwd:ctx, rest) params rt) <|>
  222                  (route' pre (ctx, cwd:rest) params fb)
  223       Nothing -> route' pre (ctx, cwd:rest) params fb
  224 
  225 route' _ _ _ NoRoute = pass