{-# 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 (Request, vault, Middleware)
import           Network.Wai.Request   (guessApproot)
import           System.Environment    (getEnvironment)
import           System.IO.Unsafe      (unsafePerformIO)

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
    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 -> Middleware -> IO Middleware
forall (m :: * -> *) a. Monad m => a -> m a
return (Middleware -> IO Middleware) -> Middleware -> IO Middleware
forall a b. (a -> b) -> a -> b
$ ByteString -> Middleware
hardcoded (ByteString -> Middleware) -> ByteString -> Middleware
forall a b. (a -> b) -> a -> b
$ String -> ByteString
S8.pack String
s
        Maybe String
Nothing -> Middleware -> IO Middleware
forall (m :: * -> *) a. Monad m => a -> m a
return 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 (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 (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
showList :: [ApprootMiddlewareNotSetup] -> ShowS
$cshowList :: [ApprootMiddlewareNotSetup] -> ShowS
show :: ApprootMiddlewareNotSetup -> String
$cshow :: ApprootMiddlewareNotSetup -> String
showsPrec :: Int -> ApprootMiddlewareNotSetup -> ShowS
$cshowsPrec :: Int -> 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