1 {-# LANGUAGE BangPatterns #-} 2 {-# LANGUAGE CPP #-} 3 {-# LANGUAGE FlexibleContexts #-} 4 {-# LANGUAGE Rank2Types #-} 5 module Snap.Internal.Routing 6 ( Route(..) 7 , pRoute 8 , route 9 , routeEarliestNC 10 , routeHeight 11 , routeLocal 12 , splitPath 13 ) where 14 ------------------------------------------------------------------------------ 15 import Control.Applicative ((<|>)) 16 import Data.ByteString (ByteString) 17 import qualified Data.ByteString as B (head, intercalate, length, null, pack, splitWith, tail) 18 import Data.ByteString.Internal (c2w) 19 import Data.HashMap.Strict (HashMap) 20 import qualified Data.HashMap.Strict as H (elems, empty, fromList, lookup, unionWith) 21 import qualified Data.Map as Map (empty, insertWith, unionWith) 22 import Snap.Internal.Core (MonadSnap, getRequest, getsRequest, localRequest, modifyRequest, pass, updateContextPath) 23 import Snap.Internal.Http.Types (Params, Request (rqContextPath, rqParams, rqPathInfo)) 24 import Snap.Internal.Parsing (urlDecode) 25 #if !MIN_VERSION_base(4,8,0) 26 import Data.Monoid (Monoid (..)) 27 #endif 28 ------------------------------------------------------------------------------ 29 30 ------------------------------------------------------------------------------ 31 -- | The internal data type you use to build a routing tree. Matching is 32 -- done unambiguously. 33 -- 34 -- 'Capture' and 'Dir' routes can have a "fallback" route: 35 -- 36 -- - For 'Capture', the fallback is routed when there is nothing to capture 37 -- - For 'Dir', the fallback is routed when we can't find a route in its map 38 -- 39 -- Fallback routes are stacked: i.e. for a route like: 40 -- 41 -- > Dir [("foo", Capture "bar" (Action bar) NoRoute)] baz 42 -- 43 -- visiting the URI foo/ will result in the "bar" capture being empty and 44 -- triggering its fallback. It's NoRoute, so we go to the nearest parent 45 -- fallback and try that, which is the baz action. 46 data Route a m = Action ((MonadSnap m) => m a) -- wraps a 'Snap' action 47 -- captures the dir in a param 48 | Capture ByteString (Route a m) (Route a m) 49 -- match on a dir 50 | Dir (HashMap ByteString (Route a m)) (Route a m) 51 | NoRoute 52 53 54 ------------------------------------------------------------------------------ 55 instance Monoid (Route a m) where 56 mempty = NoRoute 57 58 mappend NoRoute r = r 59 60 mappend l@(Action a) r = case r of 61 (Action a') -> Action (a <|> a') 62 (Capture p r' fb) -> Capture p r' (mappend fb l) 63 (Dir _ _) -> mappend (Dir H.empty l) r 64 NoRoute -> l 65 66 -- Whenever we're unioning two Captures and their capture variables 67 -- differ, we have an ambiguity. We resolve this in the following order: 68 -- 1. Prefer whichever route is longer 69 -- 2. Else, prefer whichever has the earliest non-capture 70 -- 3. Else, prefer the right-hand side 71 mappend l@(Capture p r' fb) r = case r of 72 (Action _) -> Capture p r' (mappend fb r) 73 (Capture p' r'' fb') 74 | p == p' -> Capture p (mappend r' r'') (mappend fb fb') 75 | rh' > rh'' -> Capture p r' (mappend fb r) 76 | rh' < rh'' -> Capture p' r'' (mappend fb' l) 77 | en' < en'' -> Capture p r' (mappend fb r) 78 | otherwise -> Capture p' r'' (mappend fb' l) 79 where 80 rh' = routeHeight r' 81 rh'' = routeHeight r'' 82 en' = routeEarliestNC r' 1 83 en'' = routeEarliestNC r'' 1 84 (Dir rm fb') -> Dir rm (mappend fb' l) 85 NoRoute -> l 86 87 mappend l@(Dir rm fb) r = case r of 88 (Action _) -> Dir rm (mappend fb r) 89 (Capture _ _ _) -> Dir rm (mappend fb r) 90 (Dir rm' fb') -> Dir (H.unionWith mappend rm rm') (mappend fb fb') 91 NoRoute -> l 92 93 94 ------------------------------------------------------------------------------ 95 routeHeight :: Route a m -> Int 96 routeHeight r = case r of 97 NoRoute -> 1 98 (Action _) -> 1 99 (Capture _ r' _) -> 1 + routeHeight r' 100 (Dir rm _) -> 1 + foldl max 1 (map routeHeight $ H.elems rm) 101 {-# INLINE routeHeight #-} 102 103 104 ------------------------------------------------------------------------------ 105 routeEarliestNC :: Route a m -> Int -> Int 106 routeEarliestNC r n = case r of 107 NoRoute -> n 108 (Action _) -> n 109 (Capture _ r' _) -> routeEarliestNC r' n+1 110 (Dir _ _) -> n 111 {-# INLINE routeEarliestNC #-} 112 113 114 ------------------------------------------------------------------------------ 115 -- | A web handler which, given a mapping from URL entry points to web 116 -- handlers, efficiently routes requests to the correct handler. 117 -- 118 -- 119 -- __Usage__ 120 -- 121 -- The URL entry points are given as relative paths, for example: 122 -- 123 -- > route [ ("foo/bar/quux", fooBarQuux) ] 124 -- 125 -- If the URI of the incoming request is @\/foo\/bar\/quux@ or 126 -- @\/foo\/bar\/quux\/...anything...@ then the request will be routed to 127 -- @\"fooBarQuux\"@, with 'rqContextPath' set to @\"\/foo\/bar\/quux\/\"@ and 128 -- 'rqPathInfo' set to @\"...anything...\"@. 129 -- 130 -- A path component within an URL entry point beginning with a colon (@\":\"@) 131 -- is treated as a /variable capture/; the corresponding path component within 132 -- the request URI will be entered into the 'rqParams' parameters mapping with 133 -- the given name. For instance, if the routes were: 134 -- 135 -- > route [ ("foo/:bar/baz", fooBazHandler) ] 136 -- 137 -- Then a request for @\"\/foo\/saskatchewan\/baz\"@ would be routed to 138 -- @fooBazHandler@ with a mapping for @\"bar\" => \"saskatchewan\"@ in its 139 -- parameters table. 140 -- 141 -- Longer paths are matched first, and specific routes are matched before 142 -- captures. That is, if given routes: 143 -- 144 -- > [ ("a", h1), ("a/b", h2), ("a/:x", h3) ] 145 -- 146 -- a request for @\"\/a\/b\"@ will go to @h2@, @\"\/a\/s\"@ for any /s/ will go 147 -- to @h3@, and @\"\/a\"@ will go to @h1@. 148 -- 149 -- The following example matches @\"\/article\"@ to an article index, 150 -- @\"\/login\"@ to a login, and @\"\/article\/...\"@ to an article renderer. 151 -- 152 -- @ 153 -- 'route' [ (\"article\", renderIndex) 154 -- , (\"article\/:id\", renderArticle) 155 -- , (\"login\", 'Snap.Core.method' POST doLogin) ] 156 -- @ 157 -- 158 -- __Note: URL decoding__ 159 -- 160 -- A short note about URL decoding: path matching and variable capture are done 161 -- on /decoded/ URLs, but the contents of 'rqContextPath' and 'rqPathInfo' will 162 -- contain the original encoded URL, i.e. what the user entered. For example, 163 -- in the following scenario: 164 -- 165 -- > route [ ("a b c d/", foo ) ] 166 -- 167 -- A request for \"@/a+b+c+d@\" will be sent to @foo@ with 'rqContextPath' set 168 -- to @\"/a+b+c+d/\"@. 169 -- 170 -- This behaviour changed as of Snap 0.6.1; previous versions had unspecified 171 -- (and buggy!) semantics here. 172 -- 173 -- 174 -- __Example:__ 175 -- 176 -- @ 177 -- ghci> :set -XOverloadedStrings 178 -- ghci> import qualified "Data.Map" as Map 179 -- ghci> import qualified "Data.ByteString.Char8" as B8 180 -- ghci> import "Snap.Test" 181 -- ghci> :{ 182 -- ghci| let handler = do r \<- 'getRequest' 183 -- ghci| 'Snap.Core.writeBS' $ \"rqContextPath: \" \<> 'rqContextPath' r \<> \"\\n\" 184 -- ghci| 'Snap.Core.writeBS' $ \"rqPathInfo: \" \<> 'rqPathInfo' r \<> \"\\n\" 185 -- ghci| 'Snap.Core.writeBS' $ \"rqParams: \" \<> (B8.pack . show $ 'rqParams' r) 186 -- ghci| :} 187 -- ghci> 'Snap.Test.runHandler' ('Snap.Test.get' \"\/foo\/bar\" "Map.empty") ('route' [(\"foo\", handler)]) 188 -- HTTP\/1.1 200 OK 189 -- server: Snap\/test 190 -- date: Sat, 02 Aug 2014 05:16:59 GMT 191 -- 192 -- rqContextPath: \/foo\/ 193 -- rqPathInfo: bar 194 -- rqParams: fromList [] 195 -- ghci> 'Snap.Test.runHandler' ('Snap.Test.get' \"\/foo\/bar\" "Map.empty") ('route' [(\"foo\/:bar\", handler)]) 196 -- [...] 197 -- 198 -- rqContextPath: \/foo\/bar\/ 199 -- rqPathInfo: 200 -- rqParams: fromList [(\"bar\",[\"bar\"])] 201 -- @ 202 route :: MonadSnap m => [(ByteString, m a)] -> m a 203 route rts = do 204 p <- getsRequest rqPathInfo 205 route' (return $! ()) [] (splitPath p) Map.empty rts' 206 where 207 rts' = mconcat (map pRoute rts) 208 {-# INLINE route #-} 209 210 211 ------------------------------------------------------------------------------ 212 -- | The 'routeLocal' function is the same as 'route', except it doesn't 213 -- change the request's context path. This is useful if you want to route to a 214 -- particular handler but you want that handler to receive the 'rqPathInfo' as 215 -- it is. 216 -- 217 -- Example: 218 -- 219 -- @ 220 -- ghci> :set -XOverloadedStrings 221 -- ghci> import qualified "Data.Map" as M 222 -- ghci> import qualified "Data.ByteString.Char8" as B8 223 -- ghci> import "Snap.Test" 224 -- ghci> :{ 225 -- ghci| let handler = do r \<- 'getRequest' 226 -- ghci| 'Snap.Core.writeBS' $ \"rqContextPath: \" \<> 'rqContextPath' r \<> \"\\n\" 227 -- ghci| 'Snap.Core.writeBS' $ \"rqPathInfo: \" \<> 'rqPathInfo' r \<> \"\\n\" 228 -- ghci| 'Snap.Core.writeBS' $ \"rqParams: \" \<> (B8.pack . show $ 'rqParams' r) 229 -- ghci| :} 230 -- ghci> 'Snap.Test.runHandler' ('Snap.Test.get' \"\/foo\/bar\" M.empty) ('routeLocal' [(\"foo\", handler)]) 231 -- HTTP\/1.1 200 OK 232 -- server: Snap\/test 233 -- date: Sat, 02 Aug 2014 05:17:28 GMT 234 -- 235 -- rqContextPath: \/ 236 -- rqPathInfo: foo\/bar 237 -- ghci> 'Snap.Test.runHandler' ('Snap.Test.get' \"\/foo\/bar\" M.empty) ('routeLocal' [(\"foo\/:bar\", handler)]) 238 -- [...] 239 -- 240 -- rqContextPath: \/ 241 -- rqPathInfo: foo\/bar 242 -- rqParams: fromList [(\"bar\",[\"bar\"])] 243 -- @ 244 routeLocal :: MonadSnap m => [(ByteString, m a)] -> m a 245 routeLocal rts = do 246 req <- getRequest 247 let ctx = rqContextPath req 248 let p = rqPathInfo req 249 let md = modifyRequest $ \r -> r {rqContextPath=ctx, rqPathInfo=p} 250 251 (route' md [] (splitPath p) Map.empty rts') <|> (md >> pass) 252 253 where 254 rts' = mconcat (map pRoute rts) 255 {-# INLINE routeLocal #-} 256 257 258 ------------------------------------------------------------------------------ 259 splitPath :: ByteString -> [ByteString] 260 splitPath = B.splitWith (== (c2w '/')) 261 {-# INLINE splitPath #-} 262 263 264 ------------------------------------------------------------------------------ 265 pRoute :: MonadSnap m => (ByteString, m a) -> Route a m 266 pRoute (r, a) = foldr f (Action a) hier 267 where 268 hier = filter (not . B.null) $ B.splitWith (== (c2w '/')) r 269 f s rt = if B.head s == c2w ':' 270 then Capture (B.tail s) rt NoRoute 271 else Dir (H.fromList [(s, rt)]) NoRoute 272 {-# INLINE pRoute #-} 273 274 275 ------------------------------------------------------------------------------ 276 route' :: MonadSnap m 277 => m () -- ^ action to run before we call the user handler 278 -> [ByteString] -- ^ the \"context\"; the list of path segments we've 279 -- already successfully matched, in reverse order 280 -> [ByteString] -- ^ the list of path segments we haven't yet matched 281 -> Params 282 -> Route a m 283 -> m a 284 route' pre !ctx _ !params (Action action) = 285 localRequest (updateContextPath (B.length ctx') . updateParams) 286 (pre >> action) 287 where 288 ctx' = B.intercalate (B.pack [c2w '/']) (reverse ctx) 289 updateParams req = req 290 { rqParams = Map.unionWith (flip (++)) params (rqParams req) } 291 292 route' pre !ctx [] !params (Capture _ _ fb) = 293 route' pre ctx [] params fb 294 295 route' pre !ctx paths@(cwd:rest) !params (Capture p rt fb) 296 | B.null cwd = fallback 297 | otherwise = m <|> fallback 298 where 299 fallback = route' pre ctx paths params fb 300 m = maybe pass 301 (\cwd' -> let params' = Map.insertWith (flip (++)) p [cwd'] params 302 in route' pre (cwd:ctx) rest params' rt) 303 (urlDecode cwd) 304 305 route' pre !ctx [] !params (Dir _ fb) = 306 route' pre ctx [] params fb 307 route' pre !ctx paths@(cwd:rest) !params (Dir rtm fb) = do 308 cwd' <- maybe pass return $ urlDecode cwd 309 case H.lookup cwd' rtm of 310 Just rt -> (route' pre (cwd:ctx) rest params rt) <|> 311 (route' pre ctx paths params fb) 312 Nothing -> route' pre ctx paths params fb 313 314 route' _ _ _ _ NoRoute = pass