{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE CPP #-}
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
{
ProxySettings
-> ByteString -> IO (Maybe (ProxyAction, Credentials))
psHostLookup :: ByteString -> IO (Maybe (ProxyAction, TLS.Credentials))
, ProxySettings -> Manager
psManager :: !Manager
, :: 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
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
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
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
-> 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)
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)
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
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
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
}
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>"
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>"
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",
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