    {-# LANGUAGE DeriveDataTypeable #-}
    -- | Middleware for establishing the root of the application.
    --
    -- Many application need the ability to create URLs referring back to the
    -- application itself. For example: generate RSS feeds or sitemaps, giving
    -- users copy-paste links, or sending emails. In many cases, the approot can be
    -- determined correctly from the request headers. However, some things can
    -- prevent this, especially reverse proxies. This module provides multiple ways
    -- of configuring approot discovery, and functions for applications to get that
    -- approot.
    --
    -- Approots are structured such that they can be prepended to a string such as
    -- @/foo/bar?baz=bin@. For example, if your application is hosted on
    -- example.com using HTTPS, the approot would be @https://example.com@. Note
    -- the lack of a trailing slash.
    module Network.Wai.Middleware.Approot
        ( -- * Middleware
          approotMiddleware
          -- * Common providers
        , envFallback
        , envFallbackNamed
        , hardcoded
        , fromRequest
          -- * Functions for applications
        , getApproot
        , getApprootMay
        ) where

    import Control.Exception (Exception, throw)
    import Data.ByteString (ByteString)
    import qualified Data.ByteString.Char8 as S8
    import Data.Maybe (fromMaybe)
    import Data.Typeable (Typeable)
    import qualified Data.Vault.Lazy as V
    import Network.Wai (Middleware, Request, vault)
    import System.Environment (getEnvironment)
    import System.IO.Unsafe (unsafePerformIO)

    import Network.Wai.Request (guessApproot)

    approotKey :: V.Key ByteString
    approotKey :: Key ByteString
    approotKey = IO (Key ByteString) -> Key ByteString
    forall a. IO a -> a
    unsafePerformIO IO (Key ByteString)
    forall a. IO (Key a)
    V.newKey
    {-# NOINLINE approotKey #-}

    -- | The most generic version of the middleware, allowing you to provide a
    -- function to get the approot for each request. For many use cases, one of the
    -- helper functions provided by this module will give the necessary
    -- functionality more conveniently.
    --
    -- Since 3.0.7
    approotMiddleware :: (Request -> IO ByteString) -- ^ get the approot
                      -> Middleware
    approotMiddleware :: (Request -> IO ByteString) -> Middleware
    approotMiddleware Request -> IO ByteString
    getRoot Application
    app Request
    req Response -> IO ResponseReceived
    respond = do
        ByteString
    ar <- Request -> IO ByteString
    getRoot Request
    req
        let req' :: Request
    req' = Request
    req { vault :: Vault
    vault = Key ByteString -> ByteString -> Vault -> Vault
    forall a. Key a -> a -> Vault -> Vault
    V.insert Key ByteString
    approotKey ByteString
    ar (Vault -> Vault) -> Vault -> Vault
    forall a b. (a -> b) -> a -> b
    $ Request -> Vault
    vault Request
    req }
        Application
    app Request
    req' Response -> IO ResponseReceived
    respond

    -- | Same as @'envFallbackNamed' "APPROOT"@.
    --
    -- The environment variable @APPROOT@ is used by Keter, School of Haskell, and yesod-devel.
    --
    -- Since 3.0.7
    envFallback :: IO Middleware
    envFallback :: IO Middleware
    envFallback = String -> IO Middleware
    envFallbackNamed String
    "APPROOT"

    -- | Produce a middleware that takes the approot from the given environment
    -- variable, falling back to the behavior of 'fromRequest' if the variable is
    -- not set.
    --
    -- Since 3.0.7
    envFallbackNamed :: String -> IO Middleware
    envFallbackNamed :: String -> IO Middleware
    envFallbackNamed String
    name = do
        [(String, String)]
    env <- IO [(String, String)]
    getEnvironment
        Middleware -> IO Middleware
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (Middleware -> IO Middleware) -> Middleware -> IO Middleware
    forall a b. (a -> b) -> a -> b
    $ case String -> [(String, String)] -> Maybe String
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup String
    name [(String, String)]
    env of
            Just String
    s -> ByteString -> Middleware
    hardcoded (ByteString -> Middleware) -> ByteString -> Middleware
    forall a b. (a -> b) -> a -> b
    $ String -> ByteString
    S8.pack String
    s
            Maybe String
    Nothing -> Middleware
    fromRequest

    -- | Hard-code the given value as the approot.
    --
    -- Since 3.0.7
    hardcoded :: ByteString -> Middleware
    hardcoded :: ByteString -> Middleware
    hardcoded ByteString
    ar = (Request -> IO ByteString) -> Middleware
    approotMiddleware (IO ByteString -> Request -> IO ByteString
    forall a b. a -> b -> a
    const (IO ByteString -> Request -> IO ByteString)
    -> IO ByteString -> Request -> IO ByteString
    forall a b. (a -> b) -> a -> b
    $ ByteString -> IO ByteString
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ByteString
    ar)

    -- | Get the approot by analyzing the request. This is not a full-proof
    -- approach, but in many common cases will work. Situations that can break this
    -- are:
    --
    -- * Requests which spoof headers and imply the connection is over HTTPS
    --
    -- * Reverse proxies that change ports in surprising ways
    --
    -- * Invalid Host headers
    --
    -- * Reverse proxies which modify the path info
    --
    -- Normally trusting headers in this way is insecure, however in the case of
    -- approot, the worst that can happen is that the client will get an incorrect
    -- URL. If you are relying on the approot for some security-sensitive purpose,
    -- it is highly recommended to use @hardcoded@, which cannot be spoofed.
    --
    -- Since 3.0.7
    fromRequest :: Middleware
    fromRequest :: Middleware
    fromRequest = (Request -> IO ByteString) -> Middleware
    approotMiddleware (ByteString -> IO ByteString
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (ByteString -> IO ByteString)
    -> (Request -> ByteString) -> Request -> IO ByteString
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Request -> ByteString
    guessApproot)

    data ApprootMiddlewareNotSetup = ApprootMiddlewareNotSetup
        deriving (Int -> ApprootMiddlewareNotSetup -> ShowS
    [ApprootMiddlewareNotSetup] -> ShowS
    ApprootMiddlewareNotSetup -> String
    (Int -> ApprootMiddlewareNotSetup -> ShowS)
    -> (ApprootMiddlewareNotSetup -> String)
    -> ([ApprootMiddlewareNotSetup] -> ShowS)
    -> Show ApprootMiddlewareNotSetup
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> ApprootMiddlewareNotSetup -> ShowS
    showsPrec :: Int -> ApprootMiddlewareNotSetup -> ShowS
    $cshow :: ApprootMiddlewareNotSetup -> String
    show :: ApprootMiddlewareNotSetup -> String
    $cshowList :: [ApprootMiddlewareNotSetup] -> ShowS
    showList :: [ApprootMiddlewareNotSetup] -> ShowS
    Show, Typeable)
    instance Exception ApprootMiddlewareNotSetup

    -- | Get the approot set by the middleware. If the middleware is not in use,
    -- then this function will return an exception. For a total version of the
    -- function, see 'getApprootMay'.
    --
    -- Since 3.0.7
    getApproot :: Request -> ByteString
    getApproot :: Request -> ByteString
    getApproot = ByteString -> Maybe ByteString -> ByteString
    forall a. a -> Maybe a -> a
    fromMaybe (ApprootMiddlewareNotSetup -> ByteString
    forall a e. Exception e => e -> a
    throw ApprootMiddlewareNotSetup
    ApprootMiddlewareNotSetup) (Maybe ByteString -> ByteString)
    -> (Request -> Maybe ByteString) -> Request -> ByteString
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Request -> Maybe ByteString
    getApprootMay

    -- | A total version of 'getApproot', which returns 'Nothing' if the middleware
    -- is not in use.
    --
    -- Since 3.0.7
    getApprootMay :: Request -> Maybe ByteString
    getApprootMay :: Request -> Maybe ByteString
    getApprootMay Request
    req = Key ByteString -> Vault -> Maybe ByteString
    forall a. Key a -> Vault -> Maybe a
    V.lookup Key ByteString
    approotKey (Vault -> Maybe ByteString) -> Vault -> Maybe ByteString
    forall a b. (a -> b) -> a -> b
    $ Request -> Vault
    vault Request
    req