    {-# 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 :: forall (m :: * -> *).
    (ServerMonad m, MonadPlus m) =>
    (Request -> Bool) -> m ()
    guardRq Request -> Bool
    f = do
        rq <- m Request
    forall (m :: * -> *). ServerMonad m => m Request
    askRq
        unless (f rq) 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 :: forall (m :: * -> *). (ServerMonad m, MonadPlus m) => 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 :: forall (m :: * -> *). (ServerMonad m, MonadPlus m) => 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 method [GET, HEAD]
    -- >        ...
    method :: (ServerMonad m, MonadPlus m, MatchMethod method) => method -> m ()
    method :: forall (m :: * -> *) method.
    (ServerMonad m, MonadPlus m, MatchMethod 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 :: forall (m :: * -> *) method.
    (ServerMonad m, MonadPlus m, MatchMethod method) =>
    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 a b. m a -> m b -> m b
    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 :: forall (m :: * -> *) method.
    (ServerMonad m, MonadPlus m, MatchMethod method) =>
    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 :: forall (m :: * -> *) method b.
    (ServerMonad m, MonadPlus m, MatchMethod method) =>
    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 a b. m a -> 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 :: forall (m :: * -> *). (ServerMonad m, MonadPlus m) => 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 a. [a] -> 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 :: forall (m :: * -> *) a.
    (ServerMonad m, MonadPlus m) =>
    String -> m a -> m a
    dir String
    staticPath m a
    handle =
        do
            rq <- m Request
    forall (m :: * -> *). ServerMonad m => m Request
    askRq
            case rqPaths 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 a. (Request -> Request) -> m a -> m a
    forall (m :: * -> *) a.
    ServerMonad m =>
    (Request -> Request) -> m a -> m a
    localRq (\Request
    newRq -> Request
    newRq{rqPaths = xs}) m a
    handle
                [String]
    _ -> m a
    forall a. 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 :: forall (m :: * -> *) a.
    (ServerMonad m, MonadPlus m) =>
    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 a b. (a -> b -> b) -> b -> [a] -> b
    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 :: forall (m :: * -> *) a.
    (ServerMonad m, MonadPlus m) =>
    String -> m a -> m a
    host String
    desiredHost m a
    handle =
        do rq <- m Request
    forall (m :: * -> *). ServerMonad m => m Request
    askRq
           case getHeader "host" 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 a. 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 :: forall (m :: * -> *) a.
    (ServerMonad m, MonadPlus m) =>
    (String -> m a) -> m a
    withHost String -> m a
    handle =
        do rq <- m Request
    forall (m :: * -> *). ServerMonad m => m Request
    askRq
           case getHeader "host" rq of
             (Just ByteString
    hostBS) -> String -> m a
    handle (ByteString -> String
    B.unpack ByteString
    hostBS)
             Maybe ByteString
    _ -> m a
    forall a. 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 :: forall a (m :: * -> *) b.
    (FromReqURI a, MonadPlus m, ServerMonad m) =>
    (a -> m b) -> m b
    path a -> m b
    handle = do
        rq <- m Request
    forall (m :: * -> *). ServerMonad m => m Request
    askRq
        case rqPaths 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 a. (Request -> Request) -> m a -> m a
    forall (m :: * -> *) a.
    ServerMonad m =>
    (Request -> Request) -> m a -> m a
    localRq (\Request
    newRq -> Request
    newRq{rqPaths = xs}) (a -> m b
    handle a
    a)
            [String]
    _ -> m b
    forall a. m a
    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 :: forall (m :: * -> *) a. ServerMonad m => (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 a b. m a -> (a -> m b) -> m b
    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 :: forall (m :: * -> *) r. (ServerMonad m, MonadPlus m) => 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 :: forall (m :: * -> *). (ServerMonad m, MonadPlus m) => 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. HasCallStack => [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 :: forall (m :: * -> *). (ServerMonad m, MonadPlus m) => 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. HasCallStack => [a] -> a
    last (Request -> String
    rqUri Request
    rq)) Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Char
    '/'