Routing.hs

{-# LANGUAGE BangPatterns     #-}
{-# LANGUAGE CPP              #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Rank2Types       #-}
module Snap.Internal.Routing
  ( Route(..)
  , pRoute
  , route
  , routeEarliestNC
  , routeHeight
  , routeLocal
  , splitPath
  ) where
------------------------------------------------------------------------------
import           Control.Applicative      ((<|>))
import           Data.ByteString          (ByteString)
import qualified Data.ByteString          as B (head, intercalate, length, null, pack, splitWith, tail)
import           Data.ByteString.Internal (c2w)
import           Data.HashMap.Strict      (HashMap)
import qualified Data.HashMap.Strict      as H (elems, empty, fromList, lookup, unionWith)
import qualified Data.Map                 as Map (empty, insertWith, unionWith)
import           Snap.Internal.Core       (MonadSnap, getRequest, getsRequest, localRequest, modifyRequest, pass, updateContextPath)
import           Snap.Internal.Http.Types (Params, Request (rqContextPath, rqParams, rqPathInfo))
import           Snap.Internal.Parsing    (urlDecode)
#if !MIN_VERSION_base(4,8,0)
import           Data.Monoid              (Monoid (..))
#endif
import           Data.Semigroup           (Semigroup (..))

------------------------------------------------------------------------------

------------------------------------------------------------------------------
-- | The internal data type you use to build a routing tree. Matching is
-- done unambiguously.
--
-- 'Capture' and 'Dir' routes can have a "fallback" route:
--
--   - For 'Capture', the fallback is routed when there is nothing to capture
--   - For 'Dir', the fallback is routed when we can't find a route in its map
--
-- Fallback routes are stacked: i.e. for a route like:
--
-- > Dir [("foo", Capture "bar" (Action bar) NoRoute)] baz
--
-- visiting the URI foo/ will result in the "bar" capture being empty and
-- triggering its fallback. It's NoRoute, so we go to the nearest parent
-- fallback and try that, which is the baz action.
data Route a m = Action ((MonadSnap m) => m a)   -- wraps a 'Snap' action
               -- captures the dir in a param
               | Capture ByteString (Route a m) (Route a m)
               -- match on a dir
               | Dir (HashMap ByteString (Route a m)) (Route a m)
               | NoRoute


------------------------------------------------------------------------------

instance Semigroup (Route a m) where
    NoRoute <> r = r

    l@(Action a) <> r = case r of
      (Action a')       -> Action (a <|> a')
      (Capture p r' fb) -> Capture p r' (fb <> l)
      (Dir _ _)         -> Dir H.empty l <> r
      NoRoute           -> l

    -- Whenever we're unioning two Captures and their capture variables
    -- differ, we have an ambiguity. We resolve this in the following order:
    --   1. Prefer whichever route is longer
    --   2. Else, prefer whichever has the earliest non-capture
    --   3. Else, prefer the right-hand side
    l@(Capture p r' fb) <> r = case r of
      (Action _)           -> Capture p r' (fb <> r)
      (Capture p' r'' fb')
              | p == p'    -> Capture p (r' <> r'') (fb <> fb')
              | rh' > rh'' -> Capture p r' (fb <> r)
              | rh' < rh'' -> Capture p' r'' (fb' <> l)
              | en' < en'' -> Capture p r' (fb <> r)
              | otherwise  -> Capture p' r'' (fb' <> l)
        where
          rh'  = routeHeight r'
          rh'' = routeHeight r''
          en'  = routeEarliestNC r' 1
          en'' = routeEarliestNC r'' 1
      (Dir rm fb')         -> Dir rm (fb' <> l)
      NoRoute              -> l

    (<>) l@(Dir rm fb) r = case r of
      (Action _)      -> Dir rm (fb <> r)
      (Capture _ _ _) -> Dir rm (fb <> r)
      (Dir rm' fb')   -> Dir (H.unionWith (<>) rm rm') (fb <> fb')
      NoRoute         -> l

instance Monoid (Route a m) where
    mempty = NoRoute
    mappend = (<>)

------------------------------------------------------------------------------
routeHeight :: Route a m -> Int
routeHeight r = case r of
  NoRoute          -> 1
  (Action _)       -> 1
  (Capture _ r' _) -> 1 + routeHeight r'
  (Dir rm _)       -> 1 + foldl max 1 (map routeHeight $ H.elems rm)
{-# INLINE routeHeight #-}


------------------------------------------------------------------------------
routeEarliestNC :: Route a m -> Int -> Int
routeEarliestNC r n = case r of
  NoRoute           -> n
  (Action _)        -> n
  (Capture _ r' _)  -> routeEarliestNC r' n+1
  (Dir _ _)         -> n
{-# INLINE routeEarliestNC #-}


------------------------------------------------------------------------------
-- | A web handler which, given a mapping from URL entry points to web
-- handlers, efficiently routes requests to the correct handler.
--
--
-- __Usage__
--
-- The URL entry points are given as relative paths, for example:
--
-- > route [ ("foo/bar/quux", fooBarQuux) ]
--
-- If the URI of the incoming request is @\/foo\/bar\/quux@ or
-- @\/foo\/bar\/quux\/...anything...@ then the request will be routed to
-- @\"fooBarQuux\"@, with 'rqContextPath' set to @\"\/foo\/bar\/quux\/\"@ and
-- 'rqPathInfo' set to @\"...anything...\"@.
--
-- A path component within an URL entry point beginning with a colon (@\":\"@)
-- is treated as a /variable capture/; the corresponding path component within
-- the request URI will be entered into the 'rqParams' parameters mapping with
-- the given name. For instance, if the routes were:
--
-- > route [ ("foo/:bar/baz", fooBazHandler) ]
--
-- Then a request for @\"\/foo\/saskatchewan\/baz\"@ would be routed to
-- @fooBazHandler@ with a mapping for @\"bar\" => \"saskatchewan\"@ in its
-- parameters table.
--
-- Longer paths are matched first, and specific routes are matched before
-- captures. That is, if given routes:
--
-- > [ ("a", h1), ("a/b", h2), ("a/:x", h3) ]
--
-- a request for @\"\/a\/b\"@ will go to @h2@, @\"\/a\/s\"@ for any /s/ will go
-- to @h3@, and @\"\/a\"@ will go to @h1@.
--
-- The following example matches @\"\/article\"@ to an article index,
-- @\"\/login\"@ to a login, and @\"\/article\/...\"@ to an article renderer.
--
-- @
-- 'route' [ (\"article\",     renderIndex)
--       , (\"article\/:id\", renderArticle)
--       , (\"login\",       'Snap.Core.method' POST doLogin) ]
-- @
--
-- __Note: URL decoding__
--
-- A short note about URL decoding: path matching and variable capture are done
-- on /decoded/ URLs, but the contents of 'rqContextPath' and 'rqPathInfo' will
-- contain the original encoded URL, i.e. what the user entered. For example,
-- in the following scenario:
--
-- > route [ ("a b c d/", foo ) ]
--
-- A request for \"@/a+b+c+d@\" will be sent to @foo@ with 'rqContextPath' set
-- to @\"/a+b+c+d/\"@.
--
-- This behaviour changed as of Snap 0.6.1; previous versions had unspecified
-- (and buggy!) semantics here.
--
--
-- __Example:__
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as Map
-- ghci> import qualified "Data.ByteString.Char8" as B8
-- ghci> import "Snap.Test"
-- ghci> :{
-- ghci| let handler = do r \<- 'getRequest'
-- ghci|                  'Snap.Core.writeBS' $ \"rqContextPath: \" \<> 'rqContextPath' r \<> \"\\n\"
-- ghci|                  'Snap.Core.writeBS' $ \"rqPathInfo: \" \<> 'rqPathInfo' r \<> \"\\n\"
-- ghci|                  'Snap.Core.writeBS' $ \"rqParams: \" \<> (B8.pack . show $ 'rqParams' r)
-- ghci| :}
-- ghci> 'Snap.Test.runHandler' ('Snap.Test.get' \"\/foo\/bar\" "Map.empty") ('route' [(\"foo\", handler)])
-- HTTP\/1.1 200 OK
-- server: Snap\/test
-- date: Sat, 02 Aug 2014 05:16:59 GMT
--
-- rqContextPath: \/foo\/
-- rqPathInfo: bar
-- rqParams: fromList []
-- ghci> 'Snap.Test.runHandler' ('Snap.Test.get' \"\/foo\/bar\" "Map.empty") ('route' [(\"foo\/:bar\", handler)])
-- [...]
--
-- rqContextPath: \/foo\/bar\/
-- rqPathInfo:
-- rqParams: fromList [(\"bar\",[\"bar\"])]
-- @
route :: MonadSnap m => [(ByteString, m a)] -> m a
route rts = do
  p <- getsRequest rqPathInfo
  route' (return $! ()) [] (splitPath p) Map.empty rts'
  where
    rts' = mconcat (map pRoute rts)
{-# INLINE route #-}


------------------------------------------------------------------------------
-- | The 'routeLocal' function is the same as 'route', except it doesn't
-- change the request's context path. This is useful if you want to route to a
-- particular handler but you want that handler to receive the 'rqPathInfo' as
-- it is.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Data.Map" as M
-- ghci> import qualified "Data.ByteString.Char8" as B8
-- ghci> import "Snap.Test"
-- ghci> :{
-- ghci| let handler = do r \<- 'getRequest'
-- ghci|                  'Snap.Core.writeBS' $ \"rqContextPath: \" \<> 'rqContextPath' r \<> \"\\n\"
-- ghci|                  'Snap.Core.writeBS' $ \"rqPathInfo: \" \<> 'rqPathInfo' r \<> \"\\n\"
-- ghci|                  'Snap.Core.writeBS' $ \"rqParams: \" \<> (B8.pack . show $ 'rqParams' r)
-- ghci| :}
-- ghci> 'Snap.Test.runHandler' ('Snap.Test.get' \"\/foo\/bar\" M.empty) ('routeLocal' [(\"foo\", handler)])
-- HTTP\/1.1 200 OK
-- server: Snap\/test
-- date: Sat, 02 Aug 2014 05:17:28 GMT
--
-- rqContextPath: \/
-- rqPathInfo: foo\/bar
-- ghci> 'Snap.Test.runHandler' ('Snap.Test.get' \"\/foo\/bar\" M.empty) ('routeLocal' [(\"foo\/:bar\", handler)])
-- [...]
--
-- rqContextPath: \/
-- rqPathInfo: foo\/bar
-- rqParams: fromList [(\"bar\",[\"bar\"])]
-- @
routeLocal :: MonadSnap m => [(ByteString, m a)] -> m a
routeLocal rts = do
    req    <- getRequest
    let ctx = rqContextPath req
    let p   = rqPathInfo req
    let md  = modifyRequest $ \r -> r {rqContextPath=ctx, rqPathInfo=p}

    (route' md [] (splitPath p) Map.empty rts') <|> (md >> pass)

  where
    rts' = mconcat (map pRoute rts)
{-# INLINE routeLocal #-}


------------------------------------------------------------------------------
splitPath :: ByteString -> [ByteString]
splitPath = B.splitWith (== (c2w '/'))
{-# INLINE splitPath #-}


------------------------------------------------------------------------------
pRoute :: MonadSnap m => (ByteString, m a) -> Route a m
pRoute (r, a) = foldr f (Action a) hier
  where
    hier   = filter (not . B.null) $ B.splitWith (== (c2w '/')) r
    f s rt = if B.head s == c2w ':'
        then Capture (B.tail s) rt NoRoute
        else Dir (H.fromList [(s, rt)]) NoRoute
{-# INLINE pRoute #-}


------------------------------------------------------------------------------
route' :: MonadSnap m
       => m ()           -- ^ action to run before we call the user handler
       -> [ByteString]   -- ^ the \"context\"; the list of path segments we've
                         -- already successfully matched, in reverse order
       -> [ByteString]   -- ^ the list of path segments we haven't yet matched
       -> Params
       -> Route a m
       -> m a
route' pre !ctx _ !params (Action action) =
    localRequest (updateContextPath (B.length ctx') . updateParams)
                 (pre >> action)
  where
    ctx' = B.intercalate (B.pack [c2w '/']) (reverse ctx)
    updateParams req = req
      { rqParams = Map.unionWith (flip (++)) params (rqParams req) }

route' pre !ctx [] !params (Capture _ _  fb) =
    route' pre ctx [] params fb

route' pre !ctx paths@(cwd:rest) !params (Capture p rt fb)
    | B.null cwd = fallback
    | otherwise  = m <|> fallback
  where
    fallback = route' pre ctx paths params fb
    m = maybe pass
              (\cwd' -> let params' = Map.insertWith (flip (++)) p [cwd'] params
                        in route' pre (cwd:ctx) rest params' rt)
              (urlDecode cwd)

route' pre !ctx [] !params (Dir _ fb) =
    route' pre ctx [] params fb
route' pre !ctx paths@(cwd:rest) !params (Dir rtm fb) = do
    cwd' <- maybe pass return $ urlDecode cwd
    case H.lookup cwd' rtm of
      Just rt -> (route' pre (cwd:ctx) rest params rt) <|>
                 (route' pre ctx paths params fb)
      Nothing -> route' pre ctx paths params fb

route' _ _ _ _ NoRoute = pass