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