{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
-- | 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       as S
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, requestHeaderHost)
import           Network.Wai.Request   (appearsSecure, guessApproot)
import           System.Environment    (getEnvironment)
import           System.IO.Unsafe      (unsafePerformIO)

approotKey :: V.Key ByteString
approotKey = unsafePerformIO 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 getRoot app req respond = do
    ar <- getRoot req
    let req' = req { vault = V.insert approotKey ar $ vault req }
    app req' 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 = envFallbackNamed "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 name = do
    env <- getEnvironment
    case lookup name env of
        Just s -> return $ hardcoded $ S8.pack s
        Nothing -> return fromRequest

-- | Hard-code the given value as the approot.
--
-- Since 3.0.7
hardcoded :: ByteString -> Middleware
hardcoded ar = approotMiddleware (const $ return 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 = approotMiddleware (return . guessApproot)

data ApprootMiddlewareNotSetup = ApprootMiddlewareNotSetup
    deriving (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 = fromMaybe (throw ApprootMiddlewareNotSetup) . 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 req = V.lookup approotKey $ vault req