{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE TupleSections   #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE CPP #-}
-- | A light-weight, minimalistic reverse HTTP proxy.
module Keter.Proxy
    ( reverseProxy
    , makeSettings
    , ProxySettings(..)
    , TLSConfig (..)
    ) where

import qualified Network.HTTP.Conduit      as HTTP
import qualified Data.CaseInsensitive      as CI
import           Data.Functor ((<&>))
import qualified Keter.HostManager         as HostMan
import           Blaze.ByteString.Builder          (copyByteString, toByteString)
import           Blaze.ByteString.Builder.Html.Word(fromHtmlEscapedByteString)
import           Control.Applicative               ((<$>), (<|>))
import           Control.Monad.Reader              (ask)
import           Control.Monad.IO.Unlift           (withRunInIO)
import           Control.Monad.IO.Class            (liftIO)
import qualified Data.ByteString                   as S
import qualified Data.ByteString.Char8             as S8
#if MIN_VERSION_http_reverse_proxy(0,6,0)
import           Network.Wai.Middleware.Gzip       (def)
#endif
import           Data.Monoid                       (mappend, mempty)
import           Data.Text                         as T (Text, pack, unwords)
import           Data.Text.Encoding                (decodeUtf8With, encodeUtf8)
import           Data.Text.Encoding.Error          (lenientDecode)
import qualified Data.Vector                       as V
import           GHC.Exts (fromString)
import           Keter.Config
import           Keter.Config.Middleware
import           Network.HTTP.Conduit              (Manager)

#if MIN_VERSION_http_reverse_proxy(0,4,2)
import           Network.HTTP.ReverseProxy         (defaultLocalWaiProxySettings)
#endif

#if MIN_VERSION_http_reverse_proxy(0,6,0)
import           Network.HTTP.ReverseProxy         (defaultWaiProxySettings)
#endif

import           Network.HTTP.ReverseProxy         (ProxyDest (ProxyDest),
                                                    SetIpHeader (..),
                                                    WaiProxyResponse (..),
                                                    LocalWaiProxySettings,
                                                    setLpsTimeBound,
                                                    waiProxyToSettings,
                                                    wpsSetIpHeader,
                                                    wpsOnExc,
                                                    wpsGetDest)
import qualified Keter.Rewrite as Rewrite
import           Data.ByteString            (ByteString)
import Keter.Common
import           System.FilePath            (FilePath)
import           Control.Monad.Logger
import           Control.Exception          (SomeException)
import           Network.HTTP.Types                (mkStatus,
                                                    status200,
                                                    status301, status302,
                                                    status303, status307,
                                                    status404, status502)
import qualified Network.Wai                       as Wai
import           Network.Wai.Application.Static    (defaultFileServerSettings,
                                                    ssListing, staticApp)
import qualified Network.Wai.Handler.Warp          as Warp
import qualified Network.Wai.Handler.WarpTLS       as WarpTLS
import qualified Network.TLS.SessionManager        as TLSSession
import           Network.Wai.Middleware.Gzip       (gzip, GzipSettings(..), GzipFiles(..))
import           Prelude                           hiding (FilePath, (++))
import           WaiAppStatic.Listing              (defaultListing)
import qualified Network.TLS as TLS
import qualified System.Directory as Dir
import Keter.Context

import           Data.Version (showVersion)
import qualified Paths_keter as Pkg

#if !MIN_VERSION_http_reverse_proxy(0,6,0)
defaultWaiProxySettings = def
#endif

#if !MIN_VERSION_http_reverse_proxy(0,4,2)
defaultLocalWaiProxySettings = def
#endif


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
Vector (Stanza ())
Map Text Text
NonEmptyVector ListeningPort
PortSettings
kconfigHealthcheckPath :: KeterConfig -> Maybe Text
kconfigRotateLogs :: KeterConfig -> Bool
kconfigProxyException :: KeterConfig -> Maybe String
kconfigMissingHostResponse :: KeterConfig -> Maybe String
kconfigUnknownHostResponse :: KeterConfig -> Maybe String
kconfigCliPort :: KeterConfig -> Maybe Int
kconfigConnectionTimeBound :: KeterConfig -> Int
kconfigEnvironment :: KeterConfig -> Map Text Text
kconfigExternalHttpsPort :: KeterConfig -> Int
kconfigExternalHttpPort :: KeterConfig -> Int
kconfigIpFromHeader :: KeterConfig -> Bool
kconfigBuiltinStanzas :: KeterConfig -> Vector (Stanza ())
kconfigSetuid :: KeterConfig -> Maybe Text
kconfigListeners :: KeterConfig -> NonEmptyVector ListeningPort
kconfigPortPool :: KeterConfig -> PortSettings
kconfigDir :: KeterConfig -> String
kconfigHealthcheckPath :: Maybe Text
kconfigRotateLogs :: Bool
kconfigProxyException :: Maybe String
kconfigMissingHostResponse :: Maybe String
kconfigUnknownHostResponse :: Maybe String
kconfigCliPort :: Maybe Int
kconfigConnectionTimeBound :: Int
kconfigEnvironment :: Map Text Text
kconfigExternalHttpsPort :: Int
kconfigExternalHttpPort :: Int
kconfigIpFromHeader :: Bool
kconfigBuiltinStanzas :: Vector (Stanza ())
kconfigSetuid :: Maybe Text
kconfigListeners :: NonEmptyVector ListeningPort
kconfigPortPool :: PortSettings
kconfigDir :: String
..} <- forall r (m :: * -> *). MonadReader r m => m r
ask
    Manager
psManager <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ManagerSettings -> IO Manager
HTTP.newManager ManagerSettings
HTTP.tlsManagerSettings
    ByteString
psMissingHost <- forall r.
Text
-> Maybe String -> r -> (ByteString -> r) -> KeterM KeterConfig r
taggedReadFile Text
"missing-host-response-file" Maybe String
kconfigMissingHostResponse ByteString
defaultMissingHostBody forall a. a -> a
id
    ByteString -> ByteString
psUnknownHost <- forall r.
Text
-> Maybe String -> r -> (ByteString -> r) -> KeterM KeterConfig r
taggedReadFile Text
"unknown-host-response-file" Maybe String
kconfigUnknownHostResponse ByteString -> ByteString
defaultUnknownHostBody forall a b. a -> b -> a
const
    ByteString
psProxyException <- forall r.
Text
-> Maybe String -> r -> (ByteString -> r) -> KeterM KeterConfig r
taggedReadFile Text
"proxy-exception-response-file" Maybe String
kconfigProxyException ByteString
defaultProxyException forall a. a -> a
id
    -- calculate the number of microseconds since the
    -- configuration option is in milliseconds
    let psConnectionTimeBound :: Int
psConnectionTimeBound = Int
kconfigConnectionTimeBound forall a. Num a => a -> a -> a
* Int
1000
    let psIpFromHeader :: Bool
psIpFromHeader = Bool
kconfigIpFromHeader
    let psHealthcheckPath :: Maybe ByteString
psHealthcheckPath = Text -> ByteString
encodeUtf8 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
kconfigHealthcheckPath
    forall (f :: * -> *) a. Applicative f => a -> f a
pure 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))
psHealthcheckPath :: Maybe ByteString
psIpFromHeader :: Bool
psConnectionTimeBound :: Int
psProxyException :: ByteString
psUnknownHost :: ByteString -> ByteString
psMissingHost :: ByteString
psManager :: Manager
psProxyException :: ByteString
psMissingHost :: ByteString
psUnknownHost :: ByteString -> ByteString
psHealthcheckPath :: Maybe ByteString
psConnectionTimeBound :: Int
psIpFromHeader :: Bool
psManager :: Manager
psHostLookup :: ByteString -> IO (Maybe (ProxyAction, Credentials))
..}
    where
        psHostLookup :: ByteString -> IO (Maybe (ProxyAction, Credentials))
psHostLookup = HostManager -> HeaderName -> IO (Maybe (ProxyAction, Credentials))
HostMan.lookupAction HostManager
hostman forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
_               = 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO Bool
Dir.doesFileExist String
file
  if Bool
isExist then forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ByteString
S.readFile String
file) forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ByteString -> r
processContents else do
    String
wd <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO String
Dir.getCurrentDirectory
    forall (m :: * -> *). MonadLogger m => Text -> m ()
logWarnN forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.unwords 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]
    forall (m :: * -> *) a. Monad m => a -> m a
return r
fallback
  where
    quote :: String -> Text
quote = (Text
"'" forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Semigroup a => a -> a -> a
<> Text
"'") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString

reverseProxy :: ListeningPort -> KeterM ProxySettings ()
reverseProxy :: ListeningPort -> KeterM ProxySettings ()
reverseProxy ListeningPort
listener = do
  ProxySettings
settings <- 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 -> 
                  (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 -> 
                  (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 forall a b. (a -> b) -> a -> b
$ String -> [String] -> String -> TLSSettings
WarpTLS.tlsSettingsChain
                          String
cert
                          (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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Application -> KeterM ProxySettings ()
run forall b c a. (b -> c) -> (a -> b) -> a -> c
. GzipSettings -> Middleware
gzip forall a. Default a => a
def{gzipFiles :: GzipFiles
gzipFiles = GzipFiles -> GzipFiles
GzipPreCompressed GzipFiles
GzipIgnore}
  where
    warp :: HostPreference -> Int -> Settings
warp HostPreference
host Int
port = HostPreference -> Settings -> Settings
Warp.setHost HostPreference
host 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@TLS.ServerHooks{Maybe ([ByteString] -> IO ByteString)
IO Bool
[ExtensionRaw] -> IO [ExtensionRaw]
Maybe String -> IO Credentials
CertificateChain -> IO CertificateUsage
Version -> [Cipher] -> Cipher
Measurement -> IO Bool
onClientCertificate :: ServerHooks -> CertificateChain -> IO CertificateUsage
onUnverifiedClientCert :: ServerHooks -> IO Bool
onCipherChoosing :: ServerHooks -> Version -> [Cipher] -> Cipher
onServerNameIndication :: ServerHooks -> Maybe String -> IO Credentials
onNewHandshake :: ServerHooks -> Measurement -> IO Bool
onALPNClientSuggest :: ServerHooks -> Maybe ([ByteString] -> IO ByteString)
onEncryptedExtensionsCreating :: ServerHooks -> [ExtensionRaw] -> IO [ExtensionRaw]
onEncryptedExtensionsCreating :: [ExtensionRaw] -> IO [ExtensionRaw]
onALPNClientSuggest :: Maybe ([ByteString] -> IO ByteString)
onNewHandshake :: Measurement -> IO Bool
onServerNameIndication :: Maybe String -> IO Credentials
onCipherChoosing :: Version -> [Cipher] -> Cipher
onUnverifiedClientCert :: IO Bool
onClientCertificate :: CertificateChain -> IO CertificateUsage
..} = TLSSettings -> ServerHooks
WarpTLS.tlsServerHooks TLSSettings
s
        -- todo: add nested lookup
        newOnServerNameIndication :: Maybe String -> IO Credentials
newOnServerNameIndication (Just String
n) =
             forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty forall a b. (a, b) -> b
snd 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 =
             forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty -- we could return default certificate here
    in
        TLSSettings
s { tlsServerHooks :: ServerHooks
WarpTLS.tlsServerHooks = ServerHooks
newHooks{onServerNameIndication :: Maybe String -> IO Credentials
TLS.onServerNameIndication = Maybe String -> IO Credentials
newOnServerNameIndication}
          , tlsSessionManagerConfig :: Maybe Config
WarpTLS.tlsSessionManagerConfig = if Bool
session then (forall a. a -> Maybe a
Just Config
TLSSession.defaultConfig) else forall a. Maybe a
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
psProxyException :: ByteString
psMissingHost :: ByteString
psUnknownHost :: ByteString -> ByteString
psHealthcheckPath :: Maybe ByteString
psConnectionTimeBound :: Int
psIpFromHeader :: Bool
psManager :: Manager
psHostLookup :: ByteString -> IO (Maybe (ProxyAction, Credentials))
psProxyException :: ProxySettings -> ByteString
psMissingHost :: ProxySettings -> ByteString
psUnknownHost :: ProxySettings -> ByteString -> ByteString
psHealthcheckPath :: ProxySettings -> Maybe ByteString
psConnectionTimeBound :: ProxySettings -> Int
psIpFromHeader :: ProxySettings -> Bool
psManager :: ProxySettings -> Manager
psHostLookup :: ProxySettings
-> ByteString -> IO (Maybe (ProxyAction, Credentials))
..} <- forall r (m :: * -> *). MonadReader r m => m r
ask
    let useHeader :: Bool
useHeader = Bool
psIpFromHeader
    forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. KeterM ProxySettings a -> IO a
rio ->
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (Request -> IO WaiProxyResponse)
-> WaiProxySettings -> Manager -> Application
waiProxyToSettings
           (forall a. HasCallStack => String -> a
error String
"First argument to waiProxyToSettings forced, even thought wpsGetDest provided")
           WaiProxySettings
defaultWaiProxySettings
            { wpsSetIpHeader :: SetIpHeader
wpsSetIpHeader =
                if Bool
useHeader
                    then SetIpHeader
SIHFromHeader
                    else SetIpHeader
SIHFromSocket
            ,  wpsGetDest :: Maybe (Request -> IO (LocalWaiProxySettings, WaiProxyResponse))
wpsGetDest = forall a. a -> Maybe a
Just (ProxySettings
-> Request -> IO (LocalWaiProxySettings, WaiProxyResponse)
getDest ProxySettings
cfg)
            ,  wpsOnExc :: SomeException -> Application
wpsOnExc = (Request -> SomeException -> IO ())
-> ByteString -> SomeException -> Application
handleProxyException (\Request
app SomeException
e -> forall a. KeterM ProxySettings a -> IO a
rio forall a b. (a -> b) -> a -> b
$ Request -> SomeException -> KeterM ProxySettings ()
logException Request
app SomeException
e) ByteString
psProxyException
            } Manager
psManager
  where
    logException :: Wai.Request -> SomeException -> KeterM ProxySettings ()
    logException :: Request -> SomeException -> KeterM ProxySettings ()
logException Request
a SomeException
b = forall (m :: * -> *). MonadLogger m => Text -> m ()
logErrorN forall a b. (a -> b) -> a -> b
$ String -> Text
pack forall a b. (a -> b) -> a -> b
$ 
      String
"Got a proxy exception on request " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Request
a forall a. Semigroup a => a -> a -> a
<> String
" with exception "  forall a. Semigroup a => a -> a -> a
<> 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
psProxyException :: ByteString
psMissingHost :: ByteString
psUnknownHost :: ByteString -> ByteString
psHealthcheckPath :: Maybe ByteString
psConnectionTimeBound :: Int
psIpFromHeader :: Bool
psManager :: Manager
psHostLookup :: ByteString -> IO (Maybe (ProxyAction, Credentials))
psProxyException :: ProxySettings -> ByteString
psMissingHost :: ProxySettings -> ByteString
psUnknownHost :: ProxySettings -> ByteString -> ByteString
psHealthcheckPath :: ProxySettings -> Maybe ByteString
psConnectionTimeBound :: ProxySettings -> Int
psIpFromHeader :: ProxySettings -> Bool
psManager :: ProxySettings -> Manager
psHostLookup :: ProxySettings
-> ByteString -> IO (Maybe (ProxyAction, Credentials))
..} Request
req | Maybe ByteString
psHealthcheckPath forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just (Request -> ByteString
Wai.rawPathInfo Request
req)
      = 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
psProxyException :: ByteString
psMissingHost :: ByteString
psUnknownHost :: ByteString -> ByteString
psHealthcheckPath :: Maybe ByteString
psConnectionTimeBound :: Int
psIpFromHeader :: Bool
psManager :: Manager
psHostLookup :: ByteString -> IO (Maybe (ProxyAction, Credentials))
psProxyException :: ProxySettings -> ByteString
psMissingHost :: ProxySettings -> ByteString
psUnknownHost :: ProxySettings -> ByteString -> ByteString
psHealthcheckPath :: ProxySettings -> Maybe ByteString
psConnectionTimeBound :: ProxySettings -> Int
psIpFromHeader :: ProxySettings -> Bool
psManager :: ProxySettings -> Manager
psHostLookup :: ProxySettings
-> ByteString -> IO (Maybe (ProxyAction, Credentials))
..} Request
req =
        case Request -> Maybe ByteString
Wai.requestHeaderHost Request
req of
            Maybe ByteString
Nothing -> do
              forall (m :: * -> *) a. Monad m => a -> m a
return (LocalWaiProxySettings
defaultLocalWaiProxySettings, Response -> WaiProxyResponse
WPRResponse 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
psProxyException :: ByteString
psMissingHost :: ByteString
psUnknownHost :: ByteString -> ByteString
psHealthcheckPath :: Maybe ByteString
psConnectionTimeBound :: Int
psIpFromHeader :: Bool
psManager :: Manager
psHostLookup :: ByteString -> IO (Maybe (ProxyAction, Credentials))
psProxyException :: ProxySettings -> ByteString
psMissingHost :: ProxySettings -> ByteString
psUnknownHost :: ProxySettings -> ByteString -> ByteString
psHealthcheckPath :: ProxySettings -> Maybe ByteString
psConnectionTimeBound :: ProxySettings -> Int
psIpFromHeader :: ProxySettings -> Bool
psManager :: ProxySettings -> Manager
psHostLookup :: ProxySettings
-> ByteString -> IO (Maybe (ProxyAction, Credentials))
..} 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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)
_ -> 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 (forall a. Eq a => a -> a -> Bool
/= Word8
58) ByteString
host
                    if ByteString
host' forall a. Eq a => a -> a -> Bool
== ByteString
host
                        then forall (m :: * -> *) a. Monad m => a -> m a
return 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
              forall (m :: * -> *) a. Monad m => a -> m a
return (LocalWaiProxySettings
defaultLocalWaiProxySettings, Response -> WaiProxyResponse
WPRResponse 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 -> 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
psProxyException :: ByteString
psMissingHost :: ByteString
psUnknownHost :: ByteString -> ByteString
psHealthcheckPath :: Maybe ByteString
psConnectionTimeBound :: Int
psIpFromHeader :: Bool
psManager :: Manager
psHostLookup :: ByteString -> IO (Maybe (ProxyAction, Credentials))
psProxyException :: ProxySettings -> ByteString
psMissingHost :: ProxySettings -> ByteString
psUnknownHost :: ProxySettings -> ByteString -> ByteString
psHealthcheckPath :: ProxySettings -> Maybe ByteString
psConnectionTimeBound :: ProxySettings -> Int
psIpFromHeader :: ProxySettings -> Bool
psManager :: ProxySettings -> Manager
psHostLookup :: ProxySettings
-> ByteString -> IO (Maybe (ProxyAction, Credentials))
..} ByteString
host =
        forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Maybe Int -> LocalWaiProxySettings
addjustGlobalBound Int
psConnectionTimeBound forall a. Maybe a
Nothing,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> WaiProxyResponse
WPRResponse forall b c a. (b -> c) -> (a -> b) -> a -> c
. RedirectConfig -> Request -> Response
redirectApp RedirectConfig
config
      where
        host' :: CI Text
host' = forall s. FoldCase s => s -> CI s
CI.mk forall a b. (a -> b) -> a -> b
$ OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode ByteString
host
        config :: RedirectConfig
config = RedirectConfig
            { redirconfigHosts :: Set (CI Text)
redirconfigHosts = forall a. Monoid a => a
mempty
            , redirconfigStatus :: Int
redirconfigStatus = Int
301
            , redirconfigActions :: Vector RedirectAction
redirconfigActions = forall a. a -> Vector a
V.singleton forall a b. (a -> b) -> a -> b
$ SourcePath -> RedirectDest -> RedirectAction
RedirectAction SourcePath
SPAny
                                 forall a b. (a -> b) -> a -> b
$ Bool -> CI Text -> Maybe Int -> RedirectDest
RDPrefix Bool
True CI Text
host' 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 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. a -> Maybe a
Just Int
bound of
           Just Int
x | Int
x forall a. Ord a => a -> a -> Bool
> Int
0 -> forall a. a -> Maybe a
Just Int
x
           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) ->
    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' forall a b. (a -> b) -> a -> b
$ ByteString -> Int -> ProxyDest
ProxyDest ByteString
"127.0.0.1" Int
port)
      where
        req' :: Request
req' = Request
req
            { requestHeaders :: RequestHeaders
Wai.requestHeaders = (HeaderName
"X-Forwarded-Proto", ByteString
protocol)
                                forall a. a -> [a] -> [a]
: Request -> RequestHeaders
Wai.requestHeaders Request
req
            }
        protocol :: ByteString
protocol
            | Bool
isSecure = ByteString
"https"
            | Bool
otherwise = ByteString
"http"
  (PAStatic StaticFilesConfig {Bool
String
[MiddlewareConfig]
Maybe Int
Set (CI Text)
SSLConfig
sfconfigSsl :: StaticFilesConfig -> SSLConfig
sfconfigTimeout :: StaticFilesConfig -> Maybe Int
sfconfigMiddleware :: StaticFilesConfig -> [MiddlewareConfig]
sfconfigListings :: StaticFilesConfig -> Bool
sfconfigHosts :: StaticFilesConfig -> Set (CI Text)
sfconfigRoot :: StaticFilesConfig -> String
sfconfigSsl :: SSLConfig
sfconfigTimeout :: Maybe Int
sfconfigMiddleware :: [MiddlewareConfig]
sfconfigListings :: Bool
sfconfigHosts :: Set (CI Text)
sfconfigRoot :: String
..}) ->
    forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Maybe Int -> LocalWaiProxySettings
addjustGlobalBound Int
globalBound Maybe Int
sfconfigTimeout, Application -> WaiProxyResponse
WPRApplication forall a b. (a -> b) -> a -> b
$ [MiddlewareConfig] -> Middleware
processMiddleware [MiddlewareConfig]
sfconfigMiddleware forall a b. (a -> b) -> a -> b
$ StaticSettings -> Application
staticApp (String -> StaticSettings
defaultFileServerSettings String
sfconfigRoot)
        { ssListing :: Maybe Listing
ssListing =
            if Bool
sfconfigListings
                then forall a. a -> Maybe a
Just Listing
defaultListing
                else forall a. Maybe a
Nothing
        })
  (PARedirect RedirectConfig
config) -> forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Maybe Int -> LocalWaiProxySettings
addjustGlobalBound Int
globalBound forall a. Maybe a
Nothing, Response -> WaiProxyResponse
WPRResponse forall a b. (a -> b) -> a -> b
$ RedirectConfig -> Request -> Response
redirectApp RedirectConfig
config Request
req)
  (PAReverseProxy ReverseProxyConfig
config [MiddlewareConfig]
rpconfigMiddleware Maybe Int
tbound) ->
       forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Maybe Int -> LocalWaiProxySettings
addjustGlobalBound Int
globalBound Maybe Int
tbound, Application -> WaiProxyResponse
WPRApplication
                forall a b. (a -> b) -> a -> b
$ [MiddlewareConfig] -> Middleware
processMiddleware [MiddlewareConfig]
rpconfigMiddleware
                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
redirconfigSsl :: SSLConfig
redirconfigActions :: Vector RedirectAction
redirconfigStatus :: Int
redirconfigHosts :: Set (CI Text)
redirconfigSsl :: RedirectConfig -> SSLConfig
redirconfigActions :: RedirectConfig -> Vector RedirectAction
redirconfigStatus :: RedirectConfig -> Int
redirconfigHosts :: RedirectConfig -> Set (CI Text)
..} Request
req =
    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 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 forall a. Eq a => a -> a -> Bool
== Request -> ByteString
Wai.rawPathInfo Request
req = ByteString -> Response
sendTo forall a b. (a -> b) -> a -> b
$ RedirectDest -> ByteString
mkUrl RedirectDest
dest
        | Bool
otherwise = Response
other

    noAction :: Response
noAction = Status -> RequestHeaders -> 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 -> RequestHeaders -> 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 forall a b. (a -> b) -> a -> b
$ String -> ByteString
S8.pack forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ 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 forall a. Eq a => a -> a -> Bool
== Int
443 -> ByteString
""
                | Bool -> Bool
not Bool
isSecure Bool -> Bool -> Bool
&& Int
port forall a. Eq a => a -> a -> Bool
== Int
80 -> ByteString
""
                | Bool
otherwise -> String -> ByteString
S8.pack forall a b. (a -> b) -> a -> b
$ Char
':' forall a. a -> [a] -> [a]
: 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 forall a b. (a -> b) -> a -> b
$ ByteString -> Response
missingHostResponse ByteString
onexceptBody

healthcheckResponse :: Wai.Response
healthcheckResponse :: Response
healthcheckResponse = Status -> RequestHeaders -> Builder -> Response
Wai.responseBuilder
    Status
status200
    [(HeaderName
"Content-Type", ByteString
"text/plain; charset=utf-8")]
    forall a b. (a -> b) -> a -> b
$ Builder
"Keter " forall a. Semigroup a => a -> a -> a
<> (ByteString -> Builder
copyByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
S8.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> String
showVersion) Version
Pkg.version
               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 -> RequestHeaders -> Builder -> Response
Wai.responseBuilder
    Status
status502
    [(HeaderName
"Content-Type", ByteString
"text/html; charset=utf-8")]
    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>"
  forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
escapeHtml ByteString
host 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 -> RequestHeaders -> 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
fromHtmlEscapedByteString