{-# LANGUAGE FlexibleInstances, PatternGuards, ScopedTypeVariables, TypeSynonymInstances #-}
-- | Route an incoming 'Request' to a handler. For more in-depth documentation see this section of the Happstack Crash Course: <http://www.happstack.com/docs/crashcourse/index.html#route-filters>
module Happstack.Server.Routing
    ( -- * Route by scheme
      http
    , https
      -- * Route by request method
    , methodM
    , methodOnly
    , methodSP
    , method
    , MatchMethod(..)
      -- * Route by pathInfo
    , dir
    , dirs
    , nullDir
    , trailingSlash
    , noTrailingSlash
    , anyPath
    , path
    , uriRest
    -- * Route by host
    , host
    , withHost
      -- * Route by (Request -> Bool)
    , guardRq
    ) where

import           Control.Monad                    (MonadPlus(mzero), unless)
import qualified Data.ByteString.Char8            as B
import           Happstack.Server.Monads          (ServerMonad(..))
import           Happstack.Server.Types           (Request(..), Method(..), FromReqURI(..), getHeader, rqURL)
import           System.FilePath                  (makeRelative, splitDirectories)

-- | instances of this class provide a variety of ways to match on the 'Request' method.
--
-- Examples:
--
-- > method GET                  -- match GET or HEAD
-- > method [GET, POST]          -- match GET, HEAD or POST
-- > method HEAD                 -- match HEAD /but not/ GET
-- > method (== GET)             -- match GET or HEAD
-- > method (not . (==) DELETE)  -- match any method except DELETE
-- > method ()                   -- match any method
--
-- As you can see, GET implies that HEAD should match as well.  This is to
-- make it harder to write an application that uses HTTP incorrectly.
-- Happstack handles HEAD requests automatically, but we still need to make
-- sure our handlers don't mismatch or a HEAD will result in a 404.
--
-- If you must, you can still do something like this
-- to match GET without HEAD:
--
-- > guardRq ((== GET) . rqMethod)

class MatchMethod m where
    matchMethod :: m -> Method -> Bool

instance MatchMethod Method where
    matchMethod :: Method -> Method -> Bool
matchMethod Method
m = (Method -> Bool) -> Method -> Bool
forall m. MatchMethod m => m -> Method -> Bool
matchMethod (Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
== Method
m)

instance MatchMethod [Method] where
    matchMethod :: [Method] -> Method -> Bool
matchMethod [Method]
ms Method
m = (Method -> Bool) -> [Method] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Method -> Method -> Bool
forall m. MatchMethod m => m -> Method -> Bool
`matchMethod` Method
m) [Method]
ms

instance MatchMethod (Method -> Bool) where
    matchMethod :: (Method -> Bool) -> Method -> Bool
matchMethod Method -> Bool
f Method
HEAD = Method -> Bool
f Method
HEAD Bool -> Bool -> Bool
|| Method -> Bool
f Method
GET
    matchMethod Method -> Bool
f Method
m    = Method -> Bool
f Method
m

instance MatchMethod () where
    matchMethod :: () -> Method -> Bool
matchMethod () Method
_ = Bool
True

-------------------------------------
-- guards

-- | Guard using an arbitrary function on the 'Request'.
guardRq :: (ServerMonad m, MonadPlus m) => (Request -> Bool) -> m ()
guardRq :: (Request -> Bool) -> m ()
guardRq Request -> Bool
f = do
    Request
rq <- m Request
forall (m :: * -> *). ServerMonad m => m Request
askRq
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Request -> Bool
f Request
rq) m ()
forall (m :: * -> *) a. MonadPlus m => m a
mzero


-- | guard which checks that an insecure connection was made via http:\/\/
--
-- Example:
--
-- > handler :: ServerPart Response
-- > handler =
-- >     do http
-- >        ...
http :: (ServerMonad m, MonadPlus m) => m ()
http :: m ()
http = (Request -> Bool) -> m ()
forall (m :: * -> *).
(ServerMonad m, MonadPlus m) =>
(Request -> Bool) -> m ()
guardRq (Bool -> Bool
not (Bool -> Bool) -> (Request -> Bool) -> Request -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Bool
rqSecure)


-- | guard which checks that a secure connection was made via https:\/\/
--
-- Example:
--
-- > handler :: ServerPart Response
-- > handler =
-- >     do https
-- >        ...
https :: (ServerMonad m, MonadPlus m) => m ()
https :: m ()
https = (Request -> Bool) -> m ()
forall (m :: * -> *).
(ServerMonad m, MonadPlus m) =>
(Request -> Bool) -> m ()
guardRq Request -> Bool
rqSecure


-- | Guard against the method only (as opposed to 'methodM').
--
-- Example:
--
-- > handler :: ServerPart Response
-- > handler =
-- >     do methodOnly [GET, HEAD]
-- >        ...
method :: (ServerMonad m, MonadPlus m, MatchMethod method) => method -> m ()
method :: method -> m ()
method method
meth = (Request -> Bool) -> m ()
forall (m :: * -> *).
(ServerMonad m, MonadPlus m) =>
(Request -> Bool) -> m ()
guardRq ((Request -> Bool) -> m ()) -> (Request -> Bool) -> m ()
forall a b. (a -> b) -> a -> b
$ \Request
rq -> method -> Method -> Bool
forall m. MatchMethod m => m -> Method -> Bool
matchMethod method
meth (Request -> Method
rqMethod Request
rq)

-- | Guard against the method. This function also guards against
-- *any remaining path segments*. See 'method' for the version
-- that guards only by method.
--
-- Example:
--
-- > handler :: ServerPart Response
-- > handler =
-- >     do methodM [GET, HEAD]
-- >        ...
--
-- NOTE: This function is largely retained for backwards
-- compatibility. The fact that implicitly calls 'nullDir' is often
-- forgotten and leads to confusion. It is probably better to just use
-- 'method' and call 'nullDir' explicitly.
--
-- This function will likely be deprecated in the future.
methodM :: (ServerMonad m, MonadPlus m, MatchMethod method) => method -> m ()
methodM :: method -> m ()
methodM method
meth = method -> m ()
forall (m :: * -> *) method.
(ServerMonad m, MonadPlus m, MatchMethod method) =>
method -> m ()
methodOnly method
meth m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m ()
forall (m :: * -> *). (ServerMonad m, MonadPlus m) => m ()
nullDir

-- | Guard against the method only (as opposed to 'methodM').
--
-- Example:
--
-- > handler :: ServerPart Response
-- > handler =
-- >     do methodOnly [GET, HEAD]
-- >        ...
methodOnly :: (ServerMonad m, MonadPlus m, MatchMethod method) => method -> m ()
methodOnly :: method -> m ()
methodOnly = method -> m ()
forall (m :: * -> *) method.
(ServerMonad m, MonadPlus m, MatchMethod method) =>
method -> m ()
method
{-# DEPRECATED methodOnly "this function is just an alias for method now" #-}

-- | Guard against the method. Note, this function also guards against
-- any remaining path segments. Similar to 'methodM' but with a different type signature.
--
-- Example:
--
-- > handler :: ServerPart Response
-- > handler = methodSP [GET, HEAD] $ subHandler
--
-- NOTE: This style of combinator is going to be deprecated in the
-- future. It is better to just use 'method'.
--
-- > handler :: ServerPart Response
-- > handler = method [GET, HEAD] >> nullDir >> subHandler
{-# DEPRECATED methodSP "use method instead." #-}
methodSP :: (ServerMonad m, MonadPlus m, MatchMethod method) => method -> m b-> m b
methodSP :: method -> m b -> m b
methodSP method
m m b
handle = method -> m ()
forall (m :: * -> *) method.
(ServerMonad m, MonadPlus m, MatchMethod method) =>
method -> m ()
methodM method
m m () -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m b
handle

-- | guard which only succeeds if there are no remaining path segments
--
-- Often used if you want to explicitly assign a route for '/'
--
nullDir :: (ServerMonad m, MonadPlus m) => m ()
nullDir :: m ()
nullDir = (Request -> Bool) -> m ()
forall (m :: * -> *).
(ServerMonad m, MonadPlus m) =>
(Request -> Bool) -> m ()
guardRq ((Request -> Bool) -> m ()) -> (Request -> Bool) -> m ()
forall a b. (a -> b) -> a -> b
$ \Request
rq -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Request -> [String]
rqPaths Request
rq)

-- | Pop a path element and run the supplied handler if it matches the
-- given string.
--
-- > handler :: ServerPart Response
-- > handler = dir "foo" $ dir "bar" $ subHandler
--
-- The path element can not contain \'/\'. See also 'dirs'.
dir :: (ServerMonad m, MonadPlus m) => String -> m a -> m a
dir :: String -> m a -> m a
dir String
staticPath m a
handle =
    do
        Request
rq <- m Request
forall (m :: * -> *). ServerMonad m => m Request
askRq
        case Request -> [String]
rqPaths Request
rq of
            (String
p:[String]
xs) | String
p String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
staticPath -> (Request -> Request) -> m a -> m a
forall (m :: * -> *) a.
ServerMonad m =>
(Request -> Request) -> m a -> m a
localRq (\Request
newRq -> Request
newRq{rqPaths :: [String]
rqPaths = [String]
xs}) m a
handle
            [String]
_ -> m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

-- | Guard against a 'FilePath'. Unlike 'dir' the 'FilePath' may
-- contain \'/\'. If the guard succeeds, the matched elements will be
-- popped from the directory stack.
--
-- > dirs "foo/bar" $ ...
--
-- See also: 'dir'.
dirs :: (ServerMonad m, MonadPlus m) => FilePath -> m a -> m a
dirs :: String -> m a -> m a
dirs String
fp m a
m =
     do let parts :: [String]
parts = String -> [String]
splitDirectories (String -> String -> String
makeRelative String
"/" String
fp)
        (String -> m a -> m a) -> m a -> [String] -> m a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr String -> m a -> m a
forall (m :: * -> *) a.
(ServerMonad m, MonadPlus m) =>
String -> m a -> m a
dir m a
m [String]
parts

-- | Guard against the host.
--
-- This matches against the @host@ header specified in the incoming 'Request'.
--
-- Can be used to support virtual hosting, <http://en.wikipedia.org/wiki/Virtual_hosting>
--
-- Note that this matches against the value of the @Host@ header which may include the port number.
--
-- <http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html#sec14.23>
--
-- see also: 'withHost'
host :: (ServerMonad m, MonadPlus m) => String -> m a -> m a
host :: String -> m a -> m a
host String
desiredHost m a
handle =
    do Request
rq <- m Request
forall (m :: * -> *). ServerMonad m => m Request
askRq
       case String -> Request -> Maybe ByteString
forall r. HasHeaders r => String -> r -> Maybe ByteString
getHeader String
"host" Request
rq of
         (Just ByteString
hostBS) | String
desiredHost String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> String
B.unpack ByteString
hostBS -> m a
handle
         Maybe ByteString
_ -> m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

-- | Lookup the @host@ header in the incoming request and pass it to the handler.
--
-- see also: 'host'
withHost :: (ServerMonad m, MonadPlus m) => (String -> m a) -> m a
withHost :: (String -> m a) -> m a
withHost String -> m a
handle =
    do Request
rq <- m Request
forall (m :: * -> *). ServerMonad m => m Request
askRq
       case String -> Request -> Maybe ByteString
forall r. HasHeaders r => String -> r -> Maybe ByteString
getHeader String
"host" Request
rq of
         (Just ByteString
hostBS) -> String -> m a
handle (ByteString -> String
B.unpack ByteString
hostBS)
         Maybe ByteString
_ -> m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero


-- | Pop a path element and parse it using the 'fromReqURI' in the
-- 'FromReqURI' class.
path :: (FromReqURI a, MonadPlus m, ServerMonad m) => (a -> m b) -> m b
path :: (a -> m b) -> m b
path a -> m b
handle = do
    Request
rq <- m Request
forall (m :: * -> *). ServerMonad m => m Request
askRq
    case Request -> [String]
rqPaths Request
rq of
        (String
p:[String]
xs) | Just a
a <- String -> Maybe a
forall a. FromReqURI a => String -> Maybe a
fromReqURI String
p
                            -> (Request -> Request) -> m b -> m b
forall (m :: * -> *) a.
ServerMonad m =>
(Request -> Request) -> m a -> m a
localRq (\Request
newRq -> Request
newRq{rqPaths :: [String]
rqPaths = [String]
xs}) (a -> m b
handle a
a)
        [String]
_ -> m b
forall (m :: * -> *) a. MonadPlus m => m a
mzero

-- | Grab the rest of the URL (dirs + query) and passes it to your
-- handler.
uriRest :: (ServerMonad m) => (String -> m a) -> m a
uriRest :: (String -> m a) -> m a
uriRest String -> m a
handle = m Request
forall (m :: * -> *). ServerMonad m => m Request
askRq m Request -> (Request -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> m a
handle (String -> m a) -> (Request -> String) -> Request -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> String
rqURL

-- | Pop any path element and run the handler.
--
-- Succeeds if a path component was popped. Fails is the remaining path was empty.
anyPath :: (ServerMonad m, MonadPlus m) => m r -> m r
anyPath :: m r -> m r
anyPath m r
x = (String -> m r) -> m r
forall a (m :: * -> *) b.
(FromReqURI a, MonadPlus m, ServerMonad m) =>
(a -> m b) -> m b
path ((String -> m r) -> m r) -> (String -> m r) -> m r
forall a b. (a -> b) -> a -> b
$ (\(String
_::String) -> m r
x)

-- | Guard which checks that the Request URI ends in @\'\/\'@.  Useful
-- for distinguishing between @foo@ and @foo/@
trailingSlash :: (ServerMonad m, MonadPlus m) => m ()
trailingSlash :: m ()
trailingSlash = (Request -> Bool) -> m ()
forall (m :: * -> *).
(ServerMonad m, MonadPlus m) =>
(Request -> Bool) -> m ()
guardRq ((Request -> Bool) -> m ()) -> (Request -> Bool) -> m ()
forall a b. (a -> b) -> a -> b
$ \Request
rq -> (String -> Char
forall a. [a] -> a
last (Request -> String
rqUri Request
rq)) Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/'

-- | The opposite of 'trailingSlash'.
noTrailingSlash :: (ServerMonad m, MonadPlus m) => m ()
noTrailingSlash :: m ()
noTrailingSlash = (Request -> Bool) -> m ()
forall (m :: * -> *).
(ServerMonad m, MonadPlus m) =>
(Request -> Bool) -> m ()
guardRq ((Request -> Bool) -> m ()) -> (Request -> Bool) -> m ()
forall a b. (a -> b) -> a -> b
$ \Request
rq -> (String -> Char
forall a. [a] -> a
last (Request -> String
rqUri Request
rq)) Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/'