module Network.Wai.Approot
( smartApproot
) where
import Data.ByteString (ByteString)
import Data.CaseInsensitive (CI, mk)
import qualified Data.Map as Map
import Data.Monoid ((<>))
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Network.HTTP.Types (Header)
import Network.Wai (Request, isSecure, requestHeaderHost,
requestHeaders)
import System.Environment (getEnvironment)
smartApproot :: IO (Request -> IO T.Text)
smartApproot = do
env <- getEnvironment
case lookup "APPROOT" env of
Just ar -> return $ const $ return $ T.pack ar
Nothing -> return $ \req -> return $
let secure = isSecure req || any isSecureHeader (requestHeaders req)
host = maybe "localhost" (decodeUtf8With lenientDecode) (requestHeaderHost req)
in (if secure then "https://" else "http://") <>
host
httpsHeaders :: Map.Map (CI ByteString) (CI ByteString)
httpsHeaders = Map.fromList
[ ("X-Forwarded-Protocol", "https")
, ("X-Forwarded-Ssl", "on")
, ("X-Url-Scheme", "https")
, ("X-Forwarded-Proto", "https")
, ("Front-End-Https", "on")
]
isSecureHeader :: Header -> Bool
isSecureHeader (key, value) =
case Map.lookup key httpsHeaders of
Nothing -> False
Just value' -> valueCI == value'
where
valueCI = mk value