{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}

-- | A light-weight, minimalistic reverse HTTP proxy.
module Keter.Proxy
    ( reverseProxy
    , makeSettings
    , ProxySettings(..)
    , TLSConfig (..)
    ) where

import Blaze.ByteString.Builder (copyByteString, toByteString)
import Blaze.ByteString.Builder.Html.Word (fromHtmlEscapedByteString)
import Control.Applicative ((<|>))
import Control.Exception (SomeException)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.IO.Unlift (withRunInIO)
import Control.Monad.Logger
import Control.Monad.Reader (ask)
import Data.ByteString (ByteString)
import Data.ByteString qualified as S
import Data.ByteString.Char8 qualified as S8
import Data.CaseInsensitive qualified as CI
import Data.Functor ((<&>))
import Data.Text as T (Text, pack, unwords)
import Data.Text.Encoding (decodeUtf8With, encodeUtf8)
import Data.Text.Encoding.Error (lenientDecode)
import Data.Vector qualified as V
import Data.Version (showVersion)
import GHC.Exts (fromString)
import Keter.Common
import Keter.Config
import Keter.Config.Middleware
import Keter.Context
import Keter.HostManager qualified as HostMan
import Keter.Rewrite qualified as Rewrite
import Network.HTTP.Conduit (Manager)
import Network.HTTP.Conduit qualified as HTTP
import Network.HTTP.ReverseProxy
       ( LocalWaiProxySettings
       , ProxyDest(ProxyDest)
       , SetIpHeader(..)
       , WaiProxyResponse(..)
       , defaultLocalWaiProxySettings
       , defaultWaiProxySettings
       , setLpsTimeBound
       , waiProxyToSettings
       , wpsGetDest
       , wpsOnExc
       , wpsSetIpHeader
       )
import Network.HTTP.Types
       ( mkStatus
       , status200
       , status301
       , status302
       , status303
       , status307
       , status404
       , status502
       )
import Network.TLS qualified as TLS
import Network.TLS.SessionManager qualified as TLSSession
import Network.Wai qualified as Wai
import Network.Wai.Application.Static
       (defaultFileServerSettings, ssListing, staticApp)
import Network.Wai.Handler.Warp qualified as Warp
import Network.Wai.Handler.WarpTLS qualified as WarpTLS
import Network.Wai.Middleware.Gzip (GzipFiles(..), GzipSettings(..), def, gzip)
import Paths_keter qualified as Pkg
import Prelude hiding (FilePath, (++))
import System.Directory qualified as Dir
import System.FilePath (FilePath)
import WaiAppStatic.Listing (defaultListing)

data ProxySettings = MkProxySettings
  { -- | Mapping from virtual hostname to port number.
    ProxySettings
-> ByteString -> IO (Maybe (ProxyAction, Credentials))
psHostLookup     :: ByteString -> IO (Maybe (ProxyAction, TLS.Credentials))
  , ProxySettings -> Manager
psManager        :: !Manager
  , ProxySettings -> Bool
psIpFromHeader   :: Bool
  , ProxySettings -> Int
psConnectionTimeBound :: Int
  , ProxySettings -> Maybe ByteString
psHealthcheckPath :: !(Maybe ByteString)
  , ProxySettings -> ByteString -> ByteString
psUnknownHost    :: ByteString -> ByteString
  , ProxySettings -> ByteString
psMissingHost    :: ByteString
  , ProxySettings -> ByteString
psProxyException :: ByteString
  }

makeSettings :: HostMan.HostManager -> KeterM KeterConfig ProxySettings
makeSettings :: HostManager -> KeterM KeterConfig ProxySettings
makeSettings HostManager
hostman = do
    KeterConfig{Bool
Int
String
Maybe Int
Maybe String
Maybe Text
Map Text Text
Vector (Stanza ())
NonEmptyVector ListeningPort
PortSettings
kconfigDir :: String
kconfigPortPool :: PortSettings
kconfigListeners :: NonEmptyVector ListeningPort
kconfigSetuid :: Maybe Text
kconfigBuiltinStanzas :: Vector (Stanza ())
kconfigIpFromHeader :: Bool
kconfigExternalHttpPort :: Int
kconfigExternalHttpsPort :: Int
kconfigEnvironment :: Map Text Text
kconfigConnectionTimeBound :: Int
kconfigCliPort :: Maybe Int
kconfigUnknownHostResponse :: Maybe String
kconfigMissingHostResponse :: Maybe String
kconfigProxyException :: Maybe String
kconfigRotateLogs :: Bool
kconfigHealthcheckPath :: Maybe Text
kconfigDir :: KeterConfig -> String
kconfigPortPool :: KeterConfig -> PortSettings
kconfigListeners :: KeterConfig -> NonEmptyVector ListeningPort
kconfigSetuid :: KeterConfig -> Maybe Text
kconfigBuiltinStanzas :: KeterConfig -> Vector (Stanza ())
kconfigIpFromHeader :: KeterConfig -> Bool
kconfigExternalHttpPort :: KeterConfig -> Int
kconfigExternalHttpsPort :: KeterConfig -> Int
kconfigEnvironment :: KeterConfig -> Map Text Text
kconfigConnectionTimeBound :: KeterConfig -> Int
kconfigCliPort :: KeterConfig -> Maybe Int
kconfigUnknownHostResponse :: KeterConfig -> Maybe String
kconfigMissingHostResponse :: KeterConfig -> Maybe String
kconfigProxyException :: KeterConfig -> Maybe String
kconfigRotateLogs :: KeterConfig -> Bool
kconfigHealthcheckPath :: KeterConfig -> Maybe Text
..} <- KeterM KeterConfig KeterConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
    Manager
psManager <- IO Manager -> KeterM KeterConfig Manager
forall a. IO a -> KeterM KeterConfig a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Manager -> KeterM KeterConfig Manager)
-> IO Manager -> KeterM KeterConfig Manager
forall a b. (a -> b) -> a -> b
$ ManagerSettings -> IO Manager
HTTP.newManager ManagerSettings
HTTP.tlsManagerSettings
    ByteString
psMissingHost <- Text
-> Maybe String
-> ByteString
-> (ByteString -> ByteString)
-> KeterM KeterConfig ByteString
forall r.
Text
-> Maybe String -> r -> (ByteString -> r) -> KeterM KeterConfig r
taggedReadFile Text
"missing-host-response-file" Maybe String
kconfigMissingHostResponse ByteString
defaultMissingHostBody ByteString -> ByteString
forall a. a -> a
id
    ByteString -> ByteString
psUnknownHost <- Text
-> Maybe String
-> (ByteString -> ByteString)
-> (ByteString -> ByteString -> ByteString)
-> KeterM KeterConfig (ByteString -> ByteString)
forall r.
Text
-> Maybe String -> r -> (ByteString -> r) -> KeterM KeterConfig r
taggedReadFile Text
"unknown-host-response-file" Maybe String
kconfigUnknownHostResponse ByteString -> ByteString
defaultUnknownHostBody ByteString -> ByteString -> ByteString
forall a b. a -> b -> a
const
    ByteString
psProxyException <- Text
-> Maybe String
-> ByteString
-> (ByteString -> ByteString)
-> KeterM KeterConfig ByteString
forall r.
Text
-> Maybe String -> r -> (ByteString -> r) -> KeterM KeterConfig r
taggedReadFile Text
"proxy-exception-response-file" Maybe String
kconfigProxyException ByteString
defaultProxyException ByteString -> ByteString
forall a. a -> a
id
    -- calculate the number of microseconds since the
    -- configuration option is in milliseconds
    let psConnectionTimeBound :: Int
psConnectionTimeBound = Int
kconfigConnectionTimeBound Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000
    let psIpFromHeader :: Bool
psIpFromHeader = Bool
kconfigIpFromHeader
    let psHealthcheckPath :: Maybe ByteString
psHealthcheckPath = Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Maybe Text -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
kconfigHealthcheckPath
    ProxySettings -> KeterM KeterConfig ProxySettings
forall a. a -> KeterM KeterConfig a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProxySettings -> KeterM KeterConfig ProxySettings)
-> ProxySettings -> KeterM KeterConfig ProxySettings
forall a b. (a -> b) -> a -> b
$ MkProxySettings{Bool
Int
Maybe ByteString
ByteString
Manager
ByteString -> IO (Maybe (ProxyAction, Credentials))
ByteString -> ByteString
psHostLookup :: ByteString -> IO (Maybe (ProxyAction, Credentials))
psManager :: Manager
psIpFromHeader :: Bool
psConnectionTimeBound :: Int
psHealthcheckPath :: Maybe ByteString
psUnknownHost :: ByteString -> ByteString
psMissingHost :: ByteString
psProxyException :: ByteString
psManager :: Manager
psMissingHost :: ByteString
psUnknownHost :: ByteString -> ByteString
psProxyException :: ByteString
psConnectionTimeBound :: Int
psIpFromHeader :: Bool
psHealthcheckPath :: Maybe ByteString
psHostLookup :: ByteString -> IO (Maybe (ProxyAction, Credentials))
..}
    where
        psHostLookup :: ByteString -> IO (Maybe (ProxyAction, Credentials))
psHostLookup = HostManager -> HeaderName -> IO (Maybe (ProxyAction, Credentials))
HostMan.lookupAction HostManager
hostman (HeaderName -> IO (Maybe (ProxyAction, Credentials)))
-> (ByteString -> HeaderName)
-> ByteString
-> IO (Maybe (ProxyAction, Credentials))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
CI.mk


taggedReadFile :: Text -> Maybe FilePath -> r -> (ByteString -> r) -> KeterM KeterConfig r
taggedReadFile :: forall r.
Text
-> Maybe String -> r -> (ByteString -> r) -> KeterM KeterConfig r
taggedReadFile Text
_    Maybe String
Nothing    r
fallback ByteString -> r
_               = r -> KeterM KeterConfig r
forall a. a -> KeterM KeterConfig a
forall (f :: * -> *) a. Applicative f => a -> f a
pure r
fallback
taggedReadFile Text
tag (Just String
file) r
fallback ByteString -> r
processContents = do
  Bool
isExist <- IO Bool -> KeterM KeterConfig Bool
forall a. IO a -> KeterM KeterConfig a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> KeterM KeterConfig Bool)
-> IO Bool -> KeterM KeterConfig Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
Dir.doesFileExist String
file
  if Bool
isExist then IO ByteString -> KeterM KeterConfig ByteString
forall a. IO a -> KeterM KeterConfig a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ByteString
S.readFile String
file) KeterM KeterConfig ByteString
-> (ByteString -> r) -> KeterM KeterConfig r
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ByteString -> r
processContents else do
    String
wd <- IO String -> KeterM KeterConfig String
forall a. IO a -> KeterM KeterConfig a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO String
Dir.getCurrentDirectory
    Text -> KeterM KeterConfig ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logWarnN (Text -> KeterM KeterConfig ())
-> ([Text] -> Text) -> [Text] -> KeterM KeterConfig ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.unwords ([Text] -> KeterM KeterConfig ())
-> [Text] -> KeterM KeterConfig ()
forall a b. (a -> b) -> a -> b
$ [Text
"could not find", Text
tag, Text
"on path", String -> Text
quote String
file, Text
"with working dir", String -> Text
quote String
wd]
    r -> KeterM KeterConfig r
forall a. a -> KeterM KeterConfig a
forall (m :: * -> *) a. Monad m => a -> m a
return r
fallback
  where
    quote :: String -> Text
quote = (Text
"'" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'") (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. IsString a => String -> a
fromString

reverseProxy :: ListeningPort -> KeterM ProxySettings ()
reverseProxy :: ListeningPort -> KeterM ProxySettings ()
reverseProxy ListeningPort
listener = do
  ProxySettings
settings <- KeterM ProxySettings ProxySettings
forall r (m :: * -> *). MonadReader r m => m r
ask
  let (Application -> KeterM ProxySettings ()
run, Bool
isSecure) =
          case ListeningPort
listener of
              LPInsecure HostPreference
host Int
port ->
                  (IO () -> KeterM ProxySettings ()
forall a. IO a -> KeterM ProxySettings a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> KeterM ProxySettings ())
-> (Application -> IO ()) -> Application -> KeterM ProxySettings ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Settings -> Application -> IO ()
Warp.runSettings (HostPreference -> Int -> Settings
warp HostPreference
host Int
port), Bool
False)
              LPSecure HostPreference
host Int
port String
cert Vector String
chainCerts String
key Bool
session ->
                  (IO () -> KeterM ProxySettings ()
forall a. IO a -> KeterM ProxySettings a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> KeterM ProxySettings ())
-> (Application -> IO ()) -> Application -> KeterM ProxySettings ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TLSSettings -> Settings -> Application -> IO ()
WarpTLS.runTLS
                      ((ByteString -> IO (Maybe (ProxyAction, Credentials)))
-> Bool -> TLSSettings -> TLSSettings
connectClientCertificates (ProxySettings
-> ByteString -> IO (Maybe (ProxyAction, Credentials))
psHostLookup ProxySettings
settings) Bool
session (TLSSettings -> TLSSettings) -> TLSSettings -> TLSSettings
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String -> TLSSettings
WarpTLS.tlsSettingsChain
                          String
cert
                          (Vector String -> [String]
forall a. Vector a -> [a]
V.toList Vector String
chainCerts)
                          String
key)
                      (HostPreference -> Int -> Settings
warp HostPreference
host Int
port), Bool
True)
  Bool -> KeterM ProxySettings Application
withClient Bool
isSecure KeterM ProxySettings Application
-> (Application -> KeterM ProxySettings ())
-> KeterM ProxySettings ()
forall a b.
KeterM ProxySettings a
-> (a -> KeterM ProxySettings b) -> KeterM ProxySettings b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Application -> KeterM ProxySettings ()
run (Application -> KeterM ProxySettings ())
-> (Application -> Application)
-> Application
-> KeterM ProxySettings ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GzipSettings -> Application -> Application
gzip GzipSettings
def{gzipFiles = GzipPreCompressed GzipIgnore}
  where
    warp :: HostPreference -> Int -> Settings
warp HostPreference
host Int
port = HostPreference -> Settings -> Settings
Warp.setHost HostPreference
host (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$ Int -> Settings -> Settings
Warp.setPort Int
port Settings
Warp.defaultSettings

connectClientCertificates :: (ByteString -> IO (Maybe (ProxyAction, TLS.Credentials))) -> Bool -> WarpTLS.TLSSettings -> WarpTLS.TLSSettings
connectClientCertificates :: (ByteString -> IO (Maybe (ProxyAction, Credentials)))
-> Bool -> TLSSettings -> TLSSettings
connectClientCertificates ByteString -> IO (Maybe (ProxyAction, Credentials))
hl Bool
session TLSSettings
s =
    let
        newHooks :: ServerHooks
newHooks = TLSSettings -> ServerHooks
WarpTLS.tlsServerHooks TLSSettings
s
        -- todo: add nested lookup
        newOnServerNameIndication :: Maybe String -> IO Credentials
newOnServerNameIndication (Just String
n) =
             Credentials
-> ((ProxyAction, Credentials) -> Credentials)
-> Maybe (ProxyAction, Credentials)
-> Credentials
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Credentials
forall a. Monoid a => a
mempty (ProxyAction, Credentials) -> Credentials
forall a b. (a, b) -> b
snd (Maybe (ProxyAction, Credentials) -> Credentials)
-> IO (Maybe (ProxyAction, Credentials)) -> IO Credentials
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> IO (Maybe (ProxyAction, Credentials))
hl (String -> ByteString
S8.pack String
n)
        newOnServerNameIndication Maybe String
Nothing =
             Credentials -> IO Credentials
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Credentials
forall a. Monoid a => a
mempty -- we could return default certificate here
    in
        TLSSettings
s { WarpTLS.tlsServerHooks = newHooks{TLS.onServerNameIndication = newOnServerNameIndication}
          , WarpTLS.tlsSessionManagerConfig = if session then Just TLSSession.defaultConfig else Nothing }


withClient :: Bool -- ^ is secure?
           -> KeterM ProxySettings Wai.Application
withClient :: Bool -> KeterM ProxySettings Application
withClient Bool
isSecure = do
    cfg :: ProxySettings
cfg@MkProxySettings{Bool
Int
Maybe ByteString
ByteString
Manager
ByteString -> IO (Maybe (ProxyAction, Credentials))
ByteString -> ByteString
psHostLookup :: ProxySettings
-> ByteString -> IO (Maybe (ProxyAction, Credentials))
psManager :: ProxySettings -> Manager
psIpFromHeader :: ProxySettings -> Bool
psConnectionTimeBound :: ProxySettings -> Int
psHealthcheckPath :: ProxySettings -> Maybe ByteString
psUnknownHost :: ProxySettings -> ByteString -> ByteString
psMissingHost :: ProxySettings -> ByteString
psProxyException :: ProxySettings -> ByteString
psHostLookup :: ByteString -> IO (Maybe (ProxyAction, Credentials))
psManager :: Manager
psIpFromHeader :: Bool
psConnectionTimeBound :: Int
psHealthcheckPath :: Maybe ByteString
psUnknownHost :: ByteString -> ByteString
psMissingHost :: ByteString
psProxyException :: ByteString
..} <- KeterM ProxySettings ProxySettings
forall r (m :: * -> *). MonadReader r m => m r
ask
    let useHeader :: Bool
useHeader = Bool
psIpFromHeader
    ((forall a. KeterM ProxySettings a -> IO a) -> IO Application)
-> KeterM ProxySettings Application
forall b.
((forall a. KeterM ProxySettings a -> IO a) -> IO b)
-> KeterM ProxySettings b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. KeterM ProxySettings a -> IO a) -> IO Application)
 -> KeterM ProxySettings Application)
-> ((forall a. KeterM ProxySettings a -> IO a) -> IO Application)
-> KeterM ProxySettings Application
forall a b. (a -> b) -> a -> b
$ \forall a. KeterM ProxySettings a -> IO a
rio ->
        Application -> IO Application
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Application -> IO Application) -> Application -> IO Application
forall a b. (a -> b) -> a -> b
$ (Request -> IO WaiProxyResponse)
-> WaiProxySettings -> Manager -> Application
waiProxyToSettings
           (String -> Request -> IO WaiProxyResponse
forall a. HasCallStack => String -> a
error String
"First argument to waiProxyToSettings forced, even thought wpsGetDest provided")
           WaiProxySettings
defaultWaiProxySettings
            { wpsSetIpHeader =
                if useHeader
                    then SIHFromHeader
                    else SIHFromSocket
            ,  wpsGetDest = Just (getDest cfg)
            ,  wpsOnExc = handleProxyException (\Request
app SomeException
e -> KeterM ProxySettings () -> IO ()
forall a. KeterM ProxySettings a -> IO a
rio (KeterM ProxySettings () -> IO ())
-> KeterM ProxySettings () -> IO ()
forall a b. (a -> b) -> a -> b
$ Request -> SomeException -> KeterM ProxySettings ()
logException Request
app SomeException
e) psProxyException
            } Manager
psManager
  where
    logException :: Wai.Request -> SomeException -> KeterM ProxySettings ()
    logException :: Request -> SomeException -> KeterM ProxySettings ()
logException Request
a SomeException
b = Text -> KeterM ProxySettings ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logErrorN (Text -> KeterM ProxySettings ())
-> Text -> KeterM ProxySettings ()
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$
      String
"Got a proxy exception on request " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Request -> String
forall a. Show a => a -> String
show Request
a String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" with exception "  String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SomeException -> String
forall a. Show a => a -> String
show SomeException
b


    getDest :: ProxySettings -> Wai.Request -> IO (LocalWaiProxySettings, WaiProxyResponse)
    -- respond to healthckecks, regardless of Host header value and presence
    getDest :: ProxySettings
-> Request -> IO (LocalWaiProxySettings, WaiProxyResponse)
getDest MkProxySettings{Bool
Int
Maybe ByteString
ByteString
Manager
ByteString -> IO (Maybe (ProxyAction, Credentials))
ByteString -> ByteString
psHostLookup :: ProxySettings
-> ByteString -> IO (Maybe (ProxyAction, Credentials))
psManager :: ProxySettings -> Manager
psIpFromHeader :: ProxySettings -> Bool
psConnectionTimeBound :: ProxySettings -> Int
psHealthcheckPath :: ProxySettings -> Maybe ByteString
psUnknownHost :: ProxySettings -> ByteString -> ByteString
psMissingHost :: ProxySettings -> ByteString
psProxyException :: ProxySettings -> ByteString
psHostLookup :: ByteString -> IO (Maybe (ProxyAction, Credentials))
psManager :: Manager
psIpFromHeader :: Bool
psConnectionTimeBound :: Int
psHealthcheckPath :: Maybe ByteString
psUnknownHost :: ByteString -> ByteString
psMissingHost :: ByteString
psProxyException :: ByteString
..} Request
req | Maybe ByteString
psHealthcheckPath Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (Request -> ByteString
Wai.rawPathInfo Request
req)
      = (LocalWaiProxySettings, WaiProxyResponse)
-> IO (LocalWaiProxySettings, WaiProxyResponse)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (LocalWaiProxySettings
defaultLocalWaiProxySettings, Response -> WaiProxyResponse
WPRResponse Response
healthcheckResponse)
    -- inspect Host header to determine which App to proxy to
    getDest cfg :: ProxySettings
cfg@MkProxySettings{Bool
Int
Maybe ByteString
ByteString
Manager
ByteString -> IO (Maybe (ProxyAction, Credentials))
ByteString -> ByteString
psHostLookup :: ProxySettings
-> ByteString -> IO (Maybe (ProxyAction, Credentials))
psManager :: ProxySettings -> Manager
psIpFromHeader :: ProxySettings -> Bool
psConnectionTimeBound :: ProxySettings -> Int
psHealthcheckPath :: ProxySettings -> Maybe ByteString
psUnknownHost :: ProxySettings -> ByteString -> ByteString
psMissingHost :: ProxySettings -> ByteString
psProxyException :: ProxySettings -> ByteString
psHostLookup :: ByteString -> IO (Maybe (ProxyAction, Credentials))
psManager :: Manager
psIpFromHeader :: Bool
psConnectionTimeBound :: Int
psHealthcheckPath :: Maybe ByteString
psUnknownHost :: ByteString -> ByteString
psMissingHost :: ByteString
psProxyException :: ByteString
..} Request
req =
        case Request -> Maybe ByteString
Wai.requestHeaderHost Request
req of
            Maybe ByteString
Nothing -> do
              (LocalWaiProxySettings, WaiProxyResponse)
-> IO (LocalWaiProxySettings, WaiProxyResponse)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (LocalWaiProxySettings
defaultLocalWaiProxySettings, Response -> WaiProxyResponse
WPRResponse (Response -> WaiProxyResponse) -> Response -> WaiProxyResponse
forall a b. (a -> b) -> a -> b
$ ByteString -> Response
missingHostResponse ByteString
psMissingHost)
            Just ByteString
host -> ProxySettings
-> Request
-> ByteString
-> IO (LocalWaiProxySettings, WaiProxyResponse)
processHost ProxySettings
cfg Request
req ByteString
host

    processHost :: ProxySettings -> Wai.Request -> S.ByteString -> IO (LocalWaiProxySettings, WaiProxyResponse)
    processHost :: ProxySettings
-> Request
-> ByteString
-> IO (LocalWaiProxySettings, WaiProxyResponse)
processHost cfg :: ProxySettings
cfg@MkProxySettings{Bool
Int
Maybe ByteString
ByteString
Manager
ByteString -> IO (Maybe (ProxyAction, Credentials))
ByteString -> ByteString
psHostLookup :: ProxySettings
-> ByteString -> IO (Maybe (ProxyAction, Credentials))
psManager :: ProxySettings -> Manager
psIpFromHeader :: ProxySettings -> Bool
psConnectionTimeBound :: ProxySettings -> Int
psHealthcheckPath :: ProxySettings -> Maybe ByteString
psUnknownHost :: ProxySettings -> ByteString -> ByteString
psMissingHost :: ProxySettings -> ByteString
psProxyException :: ProxySettings -> ByteString
psHostLookup :: ByteString -> IO (Maybe (ProxyAction, Credentials))
psManager :: Manager
psIpFromHeader :: Bool
psConnectionTimeBound :: Int
psHealthcheckPath :: Maybe ByteString
psUnknownHost :: ByteString -> ByteString
psMissingHost :: ByteString
psProxyException :: ByteString
..} Request
req ByteString
host = do
        -- Perform two levels of lookup. First: look up the entire host. If
        -- that fails, try stripping off any port number and try again.
        Maybe (ProxyAction, Credentials)
mport <- IO (Maybe (ProxyAction, Credentials))
-> IO (Maybe (ProxyAction, Credentials))
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (ProxyAction, Credentials))
 -> IO (Maybe (ProxyAction, Credentials)))
-> IO (Maybe (ProxyAction, Credentials))
-> IO (Maybe (ProxyAction, Credentials))
forall a b. (a -> b) -> a -> b
$ do
            Maybe (ProxyAction, Credentials)
mport1 <- ByteString -> IO (Maybe (ProxyAction, Credentials))
psHostLookup ByteString
host
            case Maybe (ProxyAction, Credentials)
mport1 of
                Just (ProxyAction, Credentials)
_ -> Maybe (ProxyAction, Credentials)
-> IO (Maybe (ProxyAction, Credentials))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (ProxyAction, Credentials)
mport1
                Maybe (ProxyAction, Credentials)
Nothing -> do
                    let host' :: ByteString
host' = (Word8 -> Bool) -> ByteString -> ByteString
S.takeWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
58) ByteString
host
                    if ByteString
host' ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
host
                        then Maybe (ProxyAction, Credentials)
-> IO (Maybe (ProxyAction, Credentials))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (ProxyAction, Credentials)
forall a. Maybe a
Nothing
                        else ByteString -> IO (Maybe (ProxyAction, Credentials))
psHostLookup ByteString
host'
        case Maybe (ProxyAction, Credentials)
mport of
            Maybe (ProxyAction, Credentials)
Nothing -> do -- we don't know the host that was asked for
              (LocalWaiProxySettings, WaiProxyResponse)
-> IO (LocalWaiProxySettings, WaiProxyResponse)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (LocalWaiProxySettings
defaultLocalWaiProxySettings, Response -> WaiProxyResponse
WPRResponse (Response -> WaiProxyResponse) -> Response -> WaiProxyResponse
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> Response
unknownHostResponse ByteString
host (ByteString -> ByteString
psUnknownHost ByteString
host))
            Just ((ProxyActionRaw
action, Bool
requiresSecure), Credentials
_)
                | Bool
requiresSecure Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isSecure -> ProxySettings
-> ByteString
-> Request
-> IO (LocalWaiProxySettings, WaiProxyResponse)
forall {m :: * -> *}.
Monad m =>
ProxySettings
-> ByteString
-> Request
-> m (LocalWaiProxySettings, WaiProxyResponse)
performHttpsRedirect ProxySettings
cfg ByteString
host Request
req
                | Bool
otherwise -> Manager
-> Bool
-> Int
-> Request
-> ProxyActionRaw
-> IO (LocalWaiProxySettings, WaiProxyResponse)
performAction Manager
psManager Bool
isSecure Int
psConnectionTimeBound Request
req ProxyActionRaw
action

    performHttpsRedirect :: ProxySettings
-> ByteString
-> Request
-> m (LocalWaiProxySettings, WaiProxyResponse)
performHttpsRedirect MkProxySettings{Bool
Int
Maybe ByteString
ByteString
Manager
ByteString -> IO (Maybe (ProxyAction, Credentials))
ByteString -> ByteString
psHostLookup :: ProxySettings
-> ByteString -> IO (Maybe (ProxyAction, Credentials))
psManager :: ProxySettings -> Manager
psIpFromHeader :: ProxySettings -> Bool
psConnectionTimeBound :: ProxySettings -> Int
psHealthcheckPath :: ProxySettings -> Maybe ByteString
psUnknownHost :: ProxySettings -> ByteString -> ByteString
psMissingHost :: ProxySettings -> ByteString
psProxyException :: ProxySettings -> ByteString
psHostLookup :: ByteString -> IO (Maybe (ProxyAction, Credentials))
psManager :: Manager
psIpFromHeader :: Bool
psConnectionTimeBound :: Int
psHealthcheckPath :: Maybe ByteString
psUnknownHost :: ByteString -> ByteString
psMissingHost :: ByteString
psProxyException :: ByteString
..} ByteString
host =
        (LocalWaiProxySettings, WaiProxyResponse)
-> m (LocalWaiProxySettings, WaiProxyResponse)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((LocalWaiProxySettings, WaiProxyResponse)
 -> m (LocalWaiProxySettings, WaiProxyResponse))
-> (Request -> (LocalWaiProxySettings, WaiProxyResponse))
-> Request
-> m (LocalWaiProxySettings, WaiProxyResponse)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Maybe Int -> LocalWaiProxySettings
addjustGlobalBound Int
psConnectionTimeBound Maybe Int
forall a. Maybe a
Nothing,) (WaiProxyResponse -> (LocalWaiProxySettings, WaiProxyResponse))
-> (Request -> WaiProxyResponse)
-> Request
-> (LocalWaiProxySettings, WaiProxyResponse)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> WaiProxyResponse
WPRResponse (Response -> WaiProxyResponse)
-> (Request -> Response) -> Request -> WaiProxyResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RedirectConfig -> Request -> Response
redirectApp RedirectConfig
config
      where
        host' :: CI Text
host' = Text -> CI Text
forall s. FoldCase s => s -> CI s
CI.mk (Text -> CI Text) -> Text -> CI Text
forall a b. (a -> b) -> a -> b
$ OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode ByteString
host
        config :: RedirectConfig
config = RedirectConfig
            { redirconfigHosts :: Set (CI Text)
redirconfigHosts = Set (CI Text)
forall a. Monoid a => a
mempty
            , redirconfigStatus :: Int
redirconfigStatus = Int
301
            , redirconfigActions :: Vector RedirectAction
redirconfigActions = RedirectAction -> Vector RedirectAction
forall a. a -> Vector a
V.singleton (RedirectAction -> Vector RedirectAction)
-> RedirectAction -> Vector RedirectAction
forall a b. (a -> b) -> a -> b
$ SourcePath -> RedirectDest -> RedirectAction
RedirectAction SourcePath
SPAny
                                 (RedirectDest -> RedirectAction) -> RedirectDest -> RedirectAction
forall a b. (a -> b) -> a -> b
$ Bool -> CI Text -> Maybe Int -> RedirectDest
RDPrefix Bool
True CI Text
host' Maybe Int
forall a. Maybe a
Nothing
            , redirconfigSsl :: SSLConfig
redirconfigSsl = SSLConfig
SSLTrue
            }

-- FIXME This is a workaround for
-- https://github.com/snoyberg/keter/issues/29. After some research, it
-- seems like Warp is behaving properly here. I'm still not certain why the
-- http call (from http-conduit) inside waiProxyToSettings could ever block
-- infinitely without the server it's connecting to going down, so that
-- requires more research. Meanwhile, this prevents the file descriptor
-- leak from occurring.
addjustGlobalBound :: Int -> Maybe Int -> LocalWaiProxySettings
addjustGlobalBound :: Int -> Maybe Int -> LocalWaiProxySettings
addjustGlobalBound Int
bound Maybe Int
to = Maybe Int
go Maybe Int -> LocalWaiProxySettings -> LocalWaiProxySettings
`setLpsTimeBound` LocalWaiProxySettings
defaultLocalWaiProxySettings
  where
    go :: Maybe Int
go = case Maybe Int
to Maybe Int -> Maybe Int -> Maybe Int
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
bound of
           Just Int
x | Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
x
           Maybe Int
_              -> Maybe Int
forall a. Maybe a
Nothing


performAction :: Manager -> Bool -> Int -> Wai.Request -> ProxyActionRaw -> IO (LocalWaiProxySettings, WaiProxyResponse)
performAction :: Manager
-> Bool
-> Int
-> Request
-> ProxyActionRaw
-> IO (LocalWaiProxySettings, WaiProxyResponse)
performAction Manager
psManager Bool
isSecure Int
globalBound Request
req = \case
  (PAPort Int
port Maybe Int
tbound) ->
    (LocalWaiProxySettings, WaiProxyResponse)
-> IO (LocalWaiProxySettings, WaiProxyResponse)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Maybe Int -> LocalWaiProxySettings
addjustGlobalBound Int
globalBound Maybe Int
tbound, Request -> ProxyDest -> WaiProxyResponse
WPRModifiedRequest Request
req' (ProxyDest -> WaiProxyResponse) -> ProxyDest -> WaiProxyResponse
forall a b. (a -> b) -> a -> b
$ ByteString -> Int -> ProxyDest
ProxyDest ByteString
"127.0.0.1" Int
port)
      where
        req' :: Request
req' = Request
req
            { Wai.requestHeaders = ("X-Forwarded-Proto", protocol)
                                : Wai.requestHeaders req
            }
        protocol :: ByteString
protocol
            | Bool
isSecure = ByteString
"https"
            | Bool
otherwise = ByteString
"http"
  (PAStatic StaticFilesConfig {Bool
String
[MiddlewareConfig]
Maybe Int
Set (CI Text)
SSLConfig
sfconfigRoot :: String
sfconfigHosts :: Set (CI Text)
sfconfigListings :: Bool
sfconfigMiddleware :: [MiddlewareConfig]
sfconfigTimeout :: Maybe Int
sfconfigSsl :: SSLConfig
sfconfigRoot :: StaticFilesConfig -> String
sfconfigHosts :: StaticFilesConfig -> Set (CI Text)
sfconfigListings :: StaticFilesConfig -> Bool
sfconfigMiddleware :: StaticFilesConfig -> [MiddlewareConfig]
sfconfigTimeout :: StaticFilesConfig -> Maybe Int
sfconfigSsl :: StaticFilesConfig -> SSLConfig
..}) ->
    (LocalWaiProxySettings, WaiProxyResponse)
-> IO (LocalWaiProxySettings, WaiProxyResponse)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Maybe Int -> LocalWaiProxySettings
addjustGlobalBound Int
globalBound Maybe Int
sfconfigTimeout, Application -> WaiProxyResponse
WPRApplication (Application -> WaiProxyResponse)
-> Application -> WaiProxyResponse
forall a b. (a -> b) -> a -> b
$ [MiddlewareConfig] -> Application -> Application
processMiddleware [MiddlewareConfig]
sfconfigMiddleware (Application -> Application) -> Application -> Application
forall a b. (a -> b) -> a -> b
$ StaticSettings -> Application
staticApp (String -> StaticSettings
defaultFileServerSettings String
sfconfigRoot)
        { ssListing =
            if sfconfigListings
                then Just defaultListing
                else Nothing
        })
  (PARedirect RedirectConfig
config) -> (LocalWaiProxySettings, WaiProxyResponse)
-> IO (LocalWaiProxySettings, WaiProxyResponse)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Maybe Int -> LocalWaiProxySettings
addjustGlobalBound Int
globalBound Maybe Int
forall a. Maybe a
Nothing, Response -> WaiProxyResponse
WPRResponse (Response -> WaiProxyResponse) -> Response -> WaiProxyResponse
forall a b. (a -> b) -> a -> b
$ RedirectConfig -> Request -> Response
redirectApp RedirectConfig
config Request
req)
  (PAReverseProxy ReverseProxyConfig
config [MiddlewareConfig]
rpconfigMiddleware Maybe Int
tbound) ->
       (LocalWaiProxySettings, WaiProxyResponse)
-> IO (LocalWaiProxySettings, WaiProxyResponse)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Maybe Int -> LocalWaiProxySettings
addjustGlobalBound Int
globalBound Maybe Int
tbound, Application -> WaiProxyResponse
WPRApplication
                (Application -> WaiProxyResponse)
-> Application -> WaiProxyResponse
forall a b. (a -> b) -> a -> b
$ [MiddlewareConfig] -> Application -> Application
processMiddleware [MiddlewareConfig]
rpconfigMiddleware
                (Application -> Application) -> Application -> Application
forall a b. (a -> b) -> a -> b
$ Manager -> ReverseProxyConfig -> Application
Rewrite.simpleReverseProxy Manager
psManager ReverseProxyConfig
config
              )

redirectApp :: RedirectConfig -> Wai.Request -> Wai.Response
redirectApp :: RedirectConfig -> Request -> Response
redirectApp RedirectConfig {Int
Vector RedirectAction
Set (CI Text)
SSLConfig
redirconfigHosts :: RedirectConfig -> Set (CI Text)
redirconfigStatus :: RedirectConfig -> Int
redirconfigActions :: RedirectConfig -> Vector RedirectAction
redirconfigSsl :: RedirectConfig -> SSLConfig
redirconfigHosts :: Set (CI Text)
redirconfigStatus :: Int
redirconfigActions :: Vector RedirectAction
redirconfigSsl :: SSLConfig
..} Request
req =
    (RedirectAction -> Response -> Response)
-> Response -> Vector RedirectAction -> Response
forall a b. (a -> b -> b) -> b -> Vector a -> b
V.foldr RedirectAction -> Response -> Response
checkAction Response
noAction Vector RedirectAction
redirconfigActions
  where
    checkAction :: RedirectAction -> Response -> Response
checkAction (RedirectAction SourcePath
SPAny RedirectDest
dest) Response
_ = ByteString -> Response
sendTo (ByteString -> Response) -> ByteString -> Response
forall a b. (a -> b) -> a -> b
$ RedirectDest -> ByteString
mkUrl RedirectDest
dest
    checkAction (RedirectAction (SPSpecific Text
path) RedirectDest
dest) Response
other
        | Text -> ByteString
encodeUtf8 Text
path ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== Request -> ByteString
Wai.rawPathInfo Request
req = ByteString -> Response
sendTo (ByteString -> Response) -> ByteString -> Response
forall a b. (a -> b) -> a -> b
$ RedirectDest -> ByteString
mkUrl RedirectDest
dest
        | Bool
otherwise = Response
other

    noAction :: Response
noAction = Status -> [Header] -> Builder -> Response
Wai.responseBuilder
        Status
status404
        [(HeaderName
"Content-Type", ByteString
"text/plain")]
        (ByteString -> Builder
copyByteString ByteString
"File not found")

    sendTo :: ByteString -> Response
sendTo ByteString
url = Status -> [Header] -> Builder -> Response
Wai.responseBuilder
        Status
status
        [(HeaderName
"Location", ByteString
url)]
        (ByteString -> Builder
copyByteString ByteString
url)

    status :: Status
status =
        case Int
redirconfigStatus of
            Int
301 -> Status
status301
            Int
302 -> Status
status302
            Int
303 -> Status
status303
            Int
307 -> Status
status307
            Int
i   -> Int -> ByteString -> Status
mkStatus Int
i (ByteString -> Status) -> ByteString -> Status
forall a b. (a -> b) -> a -> b
$ String -> ByteString
S8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
i

    mkUrl :: RedirectDest -> ByteString
mkUrl (RDUrl Text
url) = Text -> ByteString
encodeUtf8 Text
url
    mkUrl (RDPrefix Bool
isSecure CI Text
host Maybe Int
mport) = [ByteString] -> ByteString
S.concat
        [ if Bool
isSecure then ByteString
"https://" else ByteString
"http://"
        , Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ CI Text -> Text
forall s. CI s -> s
CI.original CI Text
host
        , case Maybe Int
mport of
            Maybe Int
Nothing -> ByteString
""
            Just Int
port
                | Bool
isSecure Bool -> Bool -> Bool
&& Int
port Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
443 -> ByteString
""
                | Bool -> Bool
not Bool
isSecure Bool -> Bool -> Bool
&& Int
port Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
80 -> ByteString
""
                | Bool
otherwise -> String -> ByteString
S8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Char
':' Char -> String -> String
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show Int
port
        , Request -> ByteString
Wai.rawPathInfo Request
req
        , Request -> ByteString
Wai.rawQueryString Request
req
        ]

handleProxyException :: (Wai.Request -> SomeException -> IO ()) -> ByteString -> SomeException -> Wai.Application
handleProxyException :: (Request -> SomeException -> IO ())
-> ByteString -> SomeException -> Application
handleProxyException Request -> SomeException -> IO ()
handleException ByteString
onexceptBody SomeException
except Request
req Response -> IO ResponseReceived
respond = do
  Request -> SomeException -> IO ()
handleException Request
req SomeException
except
  Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ ByteString -> Response
missingHostResponse ByteString
onexceptBody

healthcheckResponse :: Wai.Response
healthcheckResponse :: Response
healthcheckResponse = Status -> [Header] -> Builder -> Response
Wai.responseBuilder
    Status
status200
    [(HeaderName
"Content-Type", ByteString
"text/plain; charset=utf-8")]
    (Builder -> Response) -> Builder -> Response
forall a b. (a -> b) -> a -> b
$ Builder
"Keter " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (ByteString -> Builder
copyByteString (ByteString -> Builder)
-> (Version -> ByteString) -> Version -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
S8.pack (String -> ByteString)
-> (Version -> String) -> Version -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> String
showVersion) Version
Pkg.version
               Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
" is doing okay!\n"

defaultProxyException :: ByteString
defaultProxyException :: ByteString
defaultProxyException = ByteString
"<!DOCTYPE html>\n<html><head><title>Welcome to Keter</title></head><body><h1>Welcome to Keter</h1><p>There was a proxy error, check the keter logs for details.</p></body></html>"

defaultMissingHostBody :: ByteString
defaultMissingHostBody :: ByteString
defaultMissingHostBody = ByteString
"<!DOCTYPE html>\n<html><head><title>Welcome to Keter</title></head><body><h1>Welcome to Keter</h1><p>You did not provide a virtual hostname for this request.</p></body></html>"

-- | Error, no host found in the header
missingHostResponse :: ByteString -> Wai.Response
missingHostResponse :: ByteString -> Response
missingHostResponse ByteString
missingHost = Status -> [Header] -> Builder -> Response
Wai.responseBuilder
    Status
status502
    [(HeaderName
"Content-Type", ByteString
"text/html; charset=utf-8")]
    (Builder -> Response) -> Builder -> Response
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
copyByteString ByteString
missingHost

defaultUnknownHostBody :: ByteString -> ByteString
defaultUnknownHostBody :: ByteString -> ByteString
defaultUnknownHostBody ByteString
host =
  ByteString
"<!DOCTYPE html>\n<html><head><title>Welcome to Keter</title></head><body><h1>Welcome to Keter</h1><p>The hostname you have provided, <code>"
  ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
escapeHtml ByteString
host ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"</code>, is not recognized.</p></body></html>"

-- | We found a host in the header, but we don't know about the host asked for.
unknownHostResponse :: ByteString -> ByteString -> Wai.Response
unknownHostResponse :: ByteString -> ByteString -> Response
unknownHostResponse ByteString
host ByteString
body = Status -> [Header] -> Builder -> Response
Wai.responseBuilder
    Status
status404
    [(HeaderName
"Content-Type", ByteString
"text/html; charset=utf-8"),
     (HeaderName
"X-Forwarded-Host",
      -- if an attacker manages to insert line breaks somehow,
      -- this is also vulnerable.
      ByteString -> ByteString
escapeHtml ByteString
host
     )]
    (ByteString -> Builder
copyByteString ByteString
body)

escapeHtml :: ByteString -> ByteString
escapeHtml :: ByteString -> ByteString
escapeHtml = Builder -> ByteString
toByteString (Builder -> ByteString)
-> (ByteString -> Builder) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
fromHtmlEscapedByteString