Approot.hs

{-# 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 = 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
    pure $ case lookup name env of
        Just s -> hardcoded $ S8.pack s
        Nothing -> 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