{-# 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 qualified Keter.HostManager         as HostMan
import           Blaze.ByteString.Builder          (copyByteString, toByteString)
import           Blaze.ByteString.Builder.Html.Word(fromHtmlEscapedByteString)
import           Control.Applicative               ((<$>), (<|>))
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.Encoding                (decodeUtf8With, encodeUtf8)
import           Data.Text.Encoding.Error          (lenientDecode)
import qualified Data.Vector                       as V
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.Exception          (SomeException)
import           Network.HTTP.Types                (mkStatus,
                                                    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

#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 -> ByteString -> ByteString
psUnkownHost     :: ByteString -> ByteString
  , ProxySettings -> ByteString
psMissingHost    :: ByteString
  , ProxySettings -> ByteString
psProxyException :: ByteString
  , ProxySettings -> Request -> SomeException -> IO ()
psLogException   :: Wai.Request -> SomeException -> IO ()
  }

makeSettings :: (LogMessage -> IO ()) -> KeterConfig -> HostMan.HostManager -> IO ProxySettings
makeSettings :: (LogMessage -> IO ())
-> KeterConfig -> HostManager -> IO ProxySettings
makeSettings LogMessage -> IO ()
log KeterConfig {Bool
Int
FilePath
Maybe Int
Maybe FilePath
Maybe Text
Map Text Text
Vector (Stanza ())
NonEmptyVector ListeningPort
PortSettings
kconfigProxyException :: KeterConfig -> Maybe FilePath
kconfigMissingHostResponse :: KeterConfig -> Maybe FilePath
kconfigUnknownHostResponse :: KeterConfig -> Maybe FilePath
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 -> FilePath
kconfigProxyException :: Maybe FilePath
kconfigMissingHostResponse :: Maybe FilePath
kconfigUnknownHostResponse :: Maybe FilePath
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 :: FilePath
..} HostManager
hostman = do
    Manager
psManager <- ManagerSettings -> IO Manager
HTTP.newManager ManagerSettings
HTTP.tlsManagerSettings
    ByteString
psMissingHost <- case Maybe FilePath
kconfigMissingHostResponse of
      Maybe FilePath
Nothing -> ByteString -> IO ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
defaultMissingHostBody
      Just FilePath
x -> FilePath -> FilePath -> IO ByteString
taggedReadFile FilePath
"unknown-host-response-file" FilePath
x
    ByteString -> ByteString
psUnkownHost <- case Maybe FilePath
kconfigUnknownHostResponse  of
                Maybe FilePath
Nothing -> (ByteString -> ByteString) -> IO (ByteString -> ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString -> ByteString
defaultUnknownHostBody
                Just FilePath
x -> ByteString -> ByteString -> ByteString
forall a b. a -> b -> a
const (ByteString -> ByteString -> ByteString)
-> IO ByteString -> IO (ByteString -> ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> FilePath -> IO ByteString
taggedReadFile FilePath
"missing-host-response-file" FilePath
x
    ByteString
psProxyException <- case Maybe FilePath
kconfigProxyException of
                Maybe FilePath
Nothing -> ByteString -> IO ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
defaultProxyException
                Just FilePath
x -> FilePath -> FilePath -> IO ByteString
taggedReadFile FilePath
"proxy-exception-response-file" FilePath
x
    ProxySettings -> IO ProxySettings
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProxySettings -> IO ProxySettings)
-> ProxySettings -> IO ProxySettings
forall a b. (a -> b) -> a -> b
$ MkProxySettings :: (ByteString -> IO (Maybe (ProxyAction, Credentials)))
-> Manager
-> Bool
-> Int
-> (ByteString -> ByteString)
-> ByteString
-> ByteString
-> (Request -> SomeException -> IO ())
-> ProxySettings
MkProxySettings{Bool
Int
ByteString
Manager
ByteString -> IO (Maybe (ProxyAction, Credentials))
ByteString -> ByteString
Request -> SomeException -> IO ()
psIpFromHeader :: Bool
psConnectionTimeBound :: Int
psHostLookup :: ByteString -> IO (Maybe (ProxyAction, Credentials))
psLogException :: Request -> SomeException -> IO ()
psProxyException :: ByteString
psUnkownHost :: ByteString -> ByteString
psMissingHost :: ByteString
psManager :: Manager
psLogException :: Request -> SomeException -> IO ()
psProxyException :: ByteString
psMissingHost :: ByteString
psUnkownHost :: ByteString -> ByteString
psConnectionTimeBound :: Int
psIpFromHeader :: Bool
psManager :: Manager
psHostLookup :: ByteString -> IO (Maybe (ProxyAction, Credentials))
..}
    where
        psLogException :: Request -> SomeException -> IO ()
psLogException Request
a SomeException
b = LogMessage -> IO ()
log (LogMessage -> IO ()) -> LogMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ Request -> SomeException -> LogMessage
ProxyException Request
a SomeException
b
        psHostLookup :: ByteString -> IO (Maybe (ProxyAction, Credentials))
psHostLookup = HostManager -> HostBS -> IO (Maybe (ProxyAction, Credentials))
HostMan.lookupAction HostManager
hostman (HostBS -> IO (Maybe (ProxyAction, Credentials)))
-> (ByteString -> HostBS)
-> ByteString
-> IO (Maybe (ProxyAction, Credentials))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> HostBS
forall s. FoldCase s => s -> CI s
CI.mk

        -- | calculate the number of microseconds since the
        --   configuration option is in milliseconds
        psConnectionTimeBound :: Int
psConnectionTimeBound = Int
kconfigConnectionTimeBound Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000
        psIpFromHeader :: Bool
psIpFromHeader   = Bool
kconfigIpFromHeader

taggedReadFile :: String -> FilePath -> IO ByteString
taggedReadFile :: FilePath -> FilePath -> IO ByteString
taggedReadFile FilePath
tag FilePath
file = do
        Bool
isExist <- FilePath -> IO Bool
Dir.doesFileExist FilePath
file
        if Bool
isExist then FilePath -> IO ByteString
S.readFile FilePath
file else do
          FilePath
wd <- IO FilePath
Dir.getCurrentDirectory
          FilePath -> IO ByteString
forall a. HasCallStack => FilePath -> a
error (FilePath -> IO ByteString) -> FilePath -> IO ByteString
forall a b. (a -> b) -> a -> b
$ FilePath
"could not find " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
tag FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" on path '" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
file FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"' with working dir '" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
wd FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"'"

reverseProxy :: ProxySettings -> ListeningPort -> IO ()
reverseProxy :: ProxySettings -> ListeningPort -> IO ()
reverseProxy ProxySettings
settings ListeningPort
listener =
    Application -> IO ()
run (Application -> IO ()) -> Application -> IO ()
forall a b. (a -> b) -> a -> b
$ GzipSettings -> Middleware
gzip GzipSettings
forall a. Default a => a
def{gzipFiles :: GzipFiles
gzipFiles = GzipFiles -> GzipFiles
GzipPreCompressed GzipFiles
GzipIgnore} Middleware -> Middleware
forall a b. (a -> b) -> a -> b
$ Bool -> ProxySettings -> Application
withClient Bool
isSecure ProxySettings
settings
  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
    (Application -> IO ()
run, Bool
isSecure) =
        case ListeningPort
listener of
            LPInsecure HostPreference
host Int
port -> (Settings -> Application -> IO ()
Warp.runSettings (HostPreference -> Int -> Settings
warp HostPreference
host Int
port), Bool
False)
            LPSecure HostPreference
host Int
port FilePath
cert Vector FilePath
chainCerts FilePath
key Bool
session -> (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
$ FilePath -> [FilePath] -> FilePath -> TLSSettings
WarpTLS.tlsSettingsChain
                    FilePath
cert
                    (Vector FilePath -> [FilePath]
forall a. Vector a -> [a]
V.toList Vector FilePath
chainCerts)
                    FilePath
key)
                (HostPreference -> Int -> Settings
warp HostPreference
host Int
port), Bool
True)

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 FilePath -> 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 FilePath -> 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 FilePath -> 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 FilePath -> IO Credentials
newOnServerNameIndication (Just FilePath
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 (FilePath -> ByteString
S8.pack FilePath
n)
        newOnServerNameIndication Maybe FilePath
Nothing =
             Credentials -> IO Credentials
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 { tlsServerHooks :: ServerHooks
WarpTLS.tlsServerHooks = ServerHooks
newHooks{onServerNameIndication :: Maybe FilePath -> IO Credentials
TLS.onServerNameIndication = Maybe FilePath -> IO Credentials
newOnServerNameIndication}
          , tlsSessionManagerConfig :: Maybe Config
WarpTLS.tlsSessionManagerConfig = if Bool
session then (Config -> Maybe Config
forall a. a -> Maybe a
Just Config
TLSSession.defaultConfig) else Maybe Config
forall a. Maybe a
Nothing }



withClient :: Bool -- ^ is secure?
           -> ProxySettings
           -> Wai.Application
withClient :: Bool -> ProxySettings -> Application
withClient Bool
isSecure MkProxySettings {Bool
Int
ByteString
Manager
ByteString -> IO (Maybe (ProxyAction, Credentials))
ByteString -> ByteString
Request -> SomeException -> IO ()
psLogException :: Request -> SomeException -> IO ()
psProxyException :: ByteString
psMissingHost :: ByteString
psUnkownHost :: ByteString -> ByteString
psConnectionTimeBound :: Int
psIpFromHeader :: Bool
psManager :: Manager
psHostLookup :: ByteString -> IO (Maybe (ProxyAction, Credentials))
psLogException :: ProxySettings -> Request -> SomeException -> IO ()
psProxyException :: ProxySettings -> ByteString
psMissingHost :: ProxySettings -> ByteString
psUnkownHost :: ProxySettings -> ByteString -> ByteString
psConnectionTimeBound :: ProxySettings -> Int
psIpFromHeader :: ProxySettings -> Bool
psManager :: ProxySettings -> Manager
psHostLookup :: ProxySettings
-> ByteString -> IO (Maybe (ProxyAction, Credentials))
..} =
    (Request -> IO WaiProxyResponse)
-> WaiProxySettings -> Manager -> Application
waiProxyToSettings
       (FilePath -> Request -> IO WaiProxyResponse
forall a. HasCallStack => FilePath -> a
error FilePath
"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 = (Request -> IO (LocalWaiProxySettings, WaiProxyResponse))
-> Maybe (Request -> IO (LocalWaiProxySettings, WaiProxyResponse))
forall a. a -> Maybe a
Just Request -> IO (LocalWaiProxySettings, WaiProxyResponse)
getDest
        ,  wpsOnExc :: SomeException -> Application
wpsOnExc = (Request -> SomeException -> IO ())
-> ByteString -> SomeException -> Application
handleProxyException Request -> SomeException -> IO ()
psLogException ByteString
psProxyException
        } Manager
psManager
  where
    useHeader :: Bool
    useHeader :: Bool
useHeader = Bool
psIpFromHeader

    bound :: Int
    bound :: Int
bound = Int
psConnectionTimeBound

    getDest :: Wai.Request -> IO (LocalWaiProxySettings, WaiProxyResponse)
    getDest :: Request -> IO (LocalWaiProxySettings, WaiProxyResponse)
getDest Request
req =
        case Request -> Maybe ByteString
Wai.requestHeaderHost Request
req of
            Maybe ByteString
Nothing -> do
              (LocalWaiProxySettings, WaiProxyResponse)
-> IO (LocalWaiProxySettings, WaiProxyResponse)
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 -> Request
-> ByteString -> IO (LocalWaiProxySettings, WaiProxyResponse)
processHost Request
req ByteString
host

    processHost :: Wai.Request -> S.ByteString -> IO (LocalWaiProxySettings, WaiProxyResponse)
    processHost :: Request
-> ByteString -> IO (LocalWaiProxySettings, WaiProxyResponse)
processHost 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 (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 (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 (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 (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
psUnkownHost ByteString
host))
            Just ((ProxyActionRaw
action, Bool
requiresSecure), Credentials
_)
                | Bool
requiresSecure Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isSecure -> ByteString
-> Request -> IO (LocalWaiProxySettings, WaiProxyResponse)
forall (m :: * -> *).
Monad m =>
ByteString
-> Request -> m (LocalWaiProxySettings, WaiProxyResponse)
performHttpsRedirect ByteString
host Request
req
                | Bool
otherwise -> Manager
-> Bool
-> Int
-> Request
-> ProxyActionRaw
-> IO (LocalWaiProxySettings, WaiProxyResponse)
performAction Manager
psManager Bool
isSecure Int
bound Request
req ProxyActionRaw
action

    performHttpsRedirect :: ByteString
-> Request -> m (LocalWaiProxySettings, WaiProxyResponse)
performHttpsRedirect ByteString
host =
        (LocalWaiProxySettings, WaiProxyResponse)
-> m (LocalWaiProxySettings, WaiProxyResponse)
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
bound 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 :: Set (CI Text)
-> Int -> Vector RedirectAction -> SSLConfig -> RedirectConfig
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 (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 (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
            { requestHeaders :: RequestHeaders
Wai.requestHeaders = (HostBS
"X-Forwarded-Proto", ByteString
protocol)
                                (HostBS, ByteString) -> RequestHeaders -> RequestHeaders
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
FilePath
[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 -> FilePath
sfconfigSsl :: SSLConfig
sfconfigTimeout :: Maybe Int
sfconfigMiddleware :: [MiddlewareConfig]
sfconfigListings :: Bool
sfconfigHosts :: Set (CI Text)
sfconfigRoot :: FilePath
..}) ->
    (LocalWaiProxySettings, WaiProxyResponse)
-> IO (LocalWaiProxySettings, WaiProxyResponse)
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] -> Middleware
processMiddleware [MiddlewareConfig]
sfconfigMiddleware Middleware -> Middleware
forall a b. (a -> b) -> a -> b
$ StaticSettings -> Application
staticApp (FilePath -> StaticSettings
defaultFileServerSettings FilePath
sfconfigRoot)
        { ssListing :: Maybe Listing
ssListing =
            if Bool
sfconfigListings
                then Listing -> Maybe Listing
forall a. a -> Maybe a
Just Listing
defaultListing
                else Maybe Listing
forall a. Maybe a
Nothing
        })
  (PARedirect RedirectConfig
config) -> (LocalWaiProxySettings, WaiProxyResponse)
-> IO (LocalWaiProxySettings, WaiProxyResponse)
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 (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] -> Middleware
processMiddleware [MiddlewareConfig]
rpconfigMiddleware
                Middleware -> Middleware
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
Set (CI Text)
Vector RedirectAction
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 =
    (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 -> RequestHeaders -> Builder -> Response
Wai.responseBuilder
        Status
status404
        [(HostBS
"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
        [(HostBS
"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
$ FilePath -> ByteString
S8.pack (FilePath -> ByteString) -> FilePath -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> FilePath
forall a. Show a => a -> FilePath
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 -> FilePath -> ByteString
S8.pack (FilePath -> ByteString) -> FilePath -> ByteString
forall a b. (a -> b) -> a -> b
$ Char
':' Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: Int -> FilePath
forall a. Show a => a -> FilePath
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

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
    [(HostBS
"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 -> RequestHeaders -> Builder -> Response
Wai.responseBuilder
    Status
status404
    [(HostBS
"Content-Type", ByteString
"text/html; charset=utf-8"),
     (HostBS
"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