{-# 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.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                         (pack)
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.Monad.Logger
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
import Keter.Context

#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
  }

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
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
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 <- case Maybe String
kconfigMissingHostResponse of
      Maybe String
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
defaultMissingHostBody
      Just String
x -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> String -> IO ByteString
taggedReadFile String
"unknown-host-response-file" String
x
    ByteString -> ByteString
psUnkownHost <- case Maybe String
kconfigUnknownHostResponse  of
                Maybe String
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString -> ByteString
defaultUnknownHostBody
                Just String
x ->  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> String -> IO ByteString
taggedReadFile String
"missing-host-response-file" String
x
    ByteString
psProxyException <- case Maybe String
kconfigProxyException of
                Maybe String
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
defaultProxyException
                Just String
x -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> String -> IO ByteString
taggedReadFile String
"proxy-exception-response-file" String
x
    -- 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
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ MkProxySettings{Bool
Int
ByteString
Manager
ByteString -> IO (Maybe (ProxyAction, Credentials))
ByteString -> ByteString
psHostLookup :: ByteString -> IO (Maybe (ProxyAction, Credentials))
psIpFromHeader :: Bool
psConnectionTimeBound :: Int
psProxyException :: ByteString
psUnkownHost :: ByteString -> ByteString
psMissingHost :: ByteString
psManager :: Manager
psProxyException :: ByteString
psMissingHost :: ByteString
psUnkownHost :: ByteString -> 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 :: String -> FilePath -> IO ByteString
taggedReadFile :: String -> String -> IO ByteString
taggedReadFile String
tag String
file = do
        Bool
isExist <- String -> IO Bool
Dir.doesFileExist String
file
        if Bool
isExist then String -> IO ByteString
S.readFile String
file else do
          String
wd <- IO String
Dir.getCurrentDirectory
          forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"could not find " forall a. Semigroup a => a -> a -> a
<> String
tag forall a. Semigroup a => a -> a -> a
<> String
" on path '" forall a. Semigroup a => a -> a -> a
<> String
file forall a. Semigroup a => a -> a -> a
<> String
"' with working dir '" forall a. Semigroup a => a -> a -> a
<> String
wd forall a. Semigroup a => a -> a -> a
<> String
"'"

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
ByteString
Manager
ByteString -> IO (Maybe (ProxyAction, Credentials))
ByteString -> ByteString
psProxyException :: ByteString
psMissingHost :: ByteString
psUnkownHost :: ByteString -> ByteString
psConnectionTimeBound :: Int
psIpFromHeader :: Bool
psManager :: Manager
psHostLookup :: ByteString -> IO (Maybe (ProxyAction, Credentials))
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))
..} <- 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)
    getDest :: ProxySettings
-> Request -> IO (LocalWaiProxySettings, WaiProxyResponse)
getDest cfg :: ProxySettings
cfg@MkProxySettings{Bool
Int
ByteString
Manager
ByteString -> IO (Maybe (ProxyAction, Credentials))
ByteString -> ByteString
psProxyException :: ByteString
psMissingHost :: ByteString
psUnkownHost :: ByteString -> ByteString
psConnectionTimeBound :: Int
psIpFromHeader :: Bool
psManager :: Manager
psHostLookup :: ByteString -> IO (Maybe (ProxyAction, Credentials))
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
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
ByteString
Manager
ByteString -> IO (Maybe (ProxyAction, Credentials))
ByteString -> ByteString
psProxyException :: ByteString
psMissingHost :: ByteString
psUnkownHost :: ByteString -> ByteString
psConnectionTimeBound :: Int
psIpFromHeader :: Bool
psManager :: Manager
psHostLookup :: ByteString -> IO (Maybe (ProxyAction, Credentials))
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
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
psUnkownHost 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
ByteString
Manager
ByteString -> IO (Maybe (ProxyAction, Credentials))
ByteString -> ByteString
psProxyException :: ByteString
psMissingHost :: ByteString
psUnkownHost :: ByteString -> ByteString
psConnectionTimeBound :: Int
psIpFromHeader :: Bool
psManager :: Manager
psHostLookup :: ByteString -> IO (Maybe (ProxyAction, Credentials))
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))
..} 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
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 =
    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

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