{-# 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 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
{
ProxySettings
-> ByteString -> IO (Maybe (ProxyAction, Credentials))
psHostLookup :: ByteString -> IO (Maybe (ProxyAction, TLS.Credentials))
, ProxySettings -> Manager
psManager :: !Manager
, :: 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
..} <- KeterM KeterConfig KeterConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
Manager
psManager <- IO Manager -> KeterM KeterConfig Manager
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Manager -> KeterM KeterConfig Manager)
-> IO Manager -> KeterM KeterConfig Manager
forall a b. (a -> b) -> a -> b
$ ManagerSettings -> IO Manager
HTTP.newManager ManagerSettings
HTTP.tlsManagerSettings
ByteString
psMissingHost <- case Maybe String
kconfigMissingHostResponse of
Maybe String
Nothing -> ByteString -> KeterM KeterConfig ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
defaultMissingHostBody
Just String
x -> IO ByteString -> KeterM KeterConfig ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> KeterM KeterConfig ByteString)
-> IO ByteString -> KeterM KeterConfig ByteString
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 -> (ByteString -> ByteString)
-> KeterM KeterConfig (ByteString -> ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString -> ByteString
defaultUnknownHostBody
Just String
x -> (ByteString -> ByteString -> ByteString)
-> KeterM KeterConfig ByteString
-> KeterM KeterConfig (ByteString -> ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> ByteString -> ByteString
forall a b. a -> b -> a
const (KeterM KeterConfig ByteString
-> KeterM KeterConfig (ByteString -> ByteString))
-> KeterM KeterConfig ByteString
-> KeterM KeterConfig (ByteString -> ByteString)
forall a b. (a -> b) -> a -> b
$ IO ByteString -> KeterM KeterConfig ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> KeterM KeterConfig ByteString)
-> IO ByteString -> KeterM KeterConfig ByteString
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 -> ByteString -> KeterM KeterConfig ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
defaultProxyException
Just String
x -> IO ByteString -> KeterM KeterConfig ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> KeterM KeterConfig ByteString)
-> IO ByteString -> KeterM KeterConfig ByteString
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ByteString
taggedReadFile String
"proxy-exception-response-file" String
x
let psConnectionTimeBound :: Int
psConnectionTimeBound = Int
kconfigConnectionTimeBound Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000
let psIpFromHeader :: Bool
psIpFromHeader = Bool
kconfigIpFromHeader
ProxySettings -> KeterM KeterConfig ProxySettings
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProxySettings -> KeterM KeterConfig ProxySettings)
-> ProxySettings -> KeterM KeterConfig ProxySettings
forall a b. (a -> b) -> a -> b
$ MkProxySettings :: (ByteString -> IO (Maybe (ProxyAction, Credentials)))
-> Manager
-> Bool
-> Int
-> (ByteString -> ByteString)
-> ByteString
-> ByteString
-> ProxySettings
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 (HeaderName -> IO (Maybe (ProxyAction, Credentials)))
-> (ByteString -> HeaderName)
-> ByteString
-> IO (Maybe (ProxyAction, Credentials))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
CI.mk
taggedReadFile :: 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
String -> IO ByteString
forall a. HasCallStack => String -> a
error (String -> IO ByteString) -> String -> IO ByteString
forall a b. (a -> b) -> a -> b
$ String
"could not find " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
tag String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" on path '" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
file String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"' with working dir '" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
wd String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"'"
reverseProxy :: ListeningPort -> KeterM ProxySettings ()
reverseProxy :: ListeningPort -> KeterM ProxySettings ()
reverseProxy ListeningPort
listener = do
ProxySettings
settings <- KeterM ProxySettings ProxySettings
forall r (m :: * -> *). MonadReader r m => m r
ask
let (Application -> KeterM ProxySettings ()
run, Bool
isSecure) =
case ListeningPort
listener of
LPInsecure HostPreference
host Int
port ->
(IO () -> KeterM ProxySettings ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> KeterM ProxySettings ())
-> (Application -> IO ()) -> Application -> KeterM ProxySettings ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Settings -> Application -> IO ()
Warp.runSettings (HostPreference -> Int -> Settings
warp HostPreference
host Int
port), Bool
False)
LPSecure HostPreference
host Int
port String
cert Vector String
chainCerts String
key Bool
session ->
(IO () -> KeterM ProxySettings ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> KeterM ProxySettings ())
-> (Application -> IO ()) -> Application -> KeterM ProxySettings ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TLSSettings -> Settings -> Application -> IO ()
WarpTLS.runTLS
((ByteString -> IO (Maybe (ProxyAction, Credentials)))
-> Bool -> TLSSettings -> TLSSettings
connectClientCertificates (ProxySettings
-> ByteString -> IO (Maybe (ProxyAction, Credentials))
psHostLookup ProxySettings
settings) Bool
session (TLSSettings -> TLSSettings) -> TLSSettings -> TLSSettings
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String -> TLSSettings
WarpTLS.tlsSettingsChain
String
cert
(Vector String -> [String]
forall a. Vector a -> [a]
V.toList Vector String
chainCerts)
String
key)
(HostPreference -> Int -> Settings
warp HostPreference
host Int
port), Bool
True)
Bool -> KeterM ProxySettings Application
withClient Bool
isSecure KeterM ProxySettings Application
-> (Application -> KeterM ProxySettings ())
-> KeterM ProxySettings ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Application -> KeterM ProxySettings ()
run (Application -> KeterM ProxySettings ())
-> (Application -> Application)
-> Application
-> KeterM ProxySettings ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GzipSettings -> Application -> Application
gzip GzipSettings
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 (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$ Int -> Settings -> Settings
Warp.setPort Int
port Settings
Warp.defaultSettings
connectClientCertificates :: (ByteString -> IO (Maybe (ProxyAction, TLS.Credentials))) -> Bool -> WarpTLS.TLSSettings -> WarpTLS.TLSSettings
connectClientCertificates :: (ByteString -> IO (Maybe (ProxyAction, Credentials)))
-> Bool -> TLSSettings -> TLSSettings
connectClientCertificates ByteString -> IO (Maybe (ProxyAction, Credentials))
hl Bool
session TLSSettings
s =
let
newHooks :: ServerHooks
newHooks@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) =
Credentials
-> ((ProxyAction, Credentials) -> Credentials)
-> Maybe (ProxyAction, Credentials)
-> Credentials
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Credentials
forall a. Monoid a => a
mempty (ProxyAction, Credentials) -> Credentials
forall a b. (a, b) -> b
snd (Maybe (ProxyAction, Credentials) -> Credentials)
-> IO (Maybe (ProxyAction, Credentials)) -> IO Credentials
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> IO (Maybe (ProxyAction, Credentials))
hl (String -> ByteString
S8.pack String
n)
newOnServerNameIndication Maybe String
Nothing =
Credentials -> IO Credentials
forall (m :: * -> *) a. Monad m => a -> m a
return Credentials
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 (Config -> Maybe Config
forall a. a -> Maybe a
Just Config
TLSSession.defaultConfig) else Maybe Config
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
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))
..} <- KeterM ProxySettings ProxySettings
forall r (m :: * -> *). MonadReader r m => m r
ask
let useHeader :: Bool
useHeader = Bool
psIpFromHeader
((forall a. KeterM ProxySettings a -> IO a) -> IO Application)
-> KeterM ProxySettings Application
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. KeterM ProxySettings a -> IO a) -> IO Application)
-> KeterM ProxySettings Application)
-> ((forall a. KeterM ProxySettings a -> IO a) -> IO Application)
-> KeterM ProxySettings Application
forall a b. (a -> b) -> a -> b
$ \forall a. KeterM ProxySettings a -> IO a
rio ->
Application -> IO Application
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Application -> IO Application) -> Application -> IO Application
forall a b. (a -> b) -> a -> b
$ (Request -> IO WaiProxyResponse)
-> WaiProxySettings -> Manager -> Application
waiProxyToSettings
(String -> Request -> IO WaiProxyResponse
forall a. HasCallStack => String -> a
error String
"First argument to waiProxyToSettings forced, even thought wpsGetDest provided")
WaiProxySettings
defaultWaiProxySettings
{ wpsSetIpHeader :: 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 (ProxySettings
-> Request -> IO (LocalWaiProxySettings, WaiProxyResponse)
getDest ProxySettings
cfg)
, wpsOnExc :: SomeException -> Application
wpsOnExc = (Request -> SomeException -> IO ())
-> ByteString -> SomeException -> Application
handleProxyException (\Request
app SomeException
e -> KeterM ProxySettings () -> IO ()
forall a. KeterM ProxySettings a -> IO a
rio (KeterM ProxySettings () -> IO ())
-> KeterM ProxySettings () -> IO ()
forall a b. (a -> b) -> a -> b
$ Request -> SomeException -> KeterM ProxySettings ()
logException Request
app SomeException
e) ByteString
psProxyException
} Manager
psManager
where
logException :: Wai.Request -> SomeException -> KeterM ProxySettings ()
logException :: Request -> SomeException -> KeterM ProxySettings ()
logException Request
a SomeException
b = Text -> KeterM ProxySettings ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logErrorN (Text -> KeterM ProxySettings ())
-> Text -> KeterM ProxySettings ()
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$
String
"Got a proxy exception on request " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Request -> String
forall a. Show a => a -> String
show Request
a String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" with exception " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SomeException -> String
forall a. Show a => a -> String
show SomeException
b
getDest :: ProxySettings -> Wai.Request -> IO (LocalWaiProxySettings, WaiProxyResponse)
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
(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 -> 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
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
(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 -> ProxySettings
-> ByteString
-> Request
-> IO (LocalWaiProxySettings, WaiProxyResponse)
forall {m :: * -> *}.
Monad m =>
ProxySettings
-> ByteString
-> Request
-> m (LocalWaiProxySettings, WaiProxyResponse)
performHttpsRedirect ProxySettings
cfg ByteString
host Request
req
| Bool
otherwise -> Manager
-> Bool
-> Int
-> Request
-> ProxyActionRaw
-> IO (LocalWaiProxySettings, WaiProxyResponse)
performAction Manager
psManager Bool
isSecure Int
psConnectionTimeBound Request
req ProxyActionRaw
action
performHttpsRedirect :: ProxySettings
-> ByteString
-> Request
-> m (LocalWaiProxySettings, WaiProxyResponse)
performHttpsRedirect MkProxySettings{Bool
Int
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 =
(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
psConnectionTimeBound Maybe Int
forall a. Maybe a
Nothing,) (WaiProxyResponse -> (LocalWaiProxySettings, WaiProxyResponse))
-> (Request -> WaiProxyResponse)
-> Request
-> (LocalWaiProxySettings, WaiProxyResponse)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> WaiProxyResponse
WPRResponse (Response -> WaiProxyResponse)
-> (Request -> Response) -> Request -> WaiProxyResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RedirectConfig -> Request -> Response
redirectApp RedirectConfig
config
where
host' :: CI Text
host' = Text -> CI Text
forall s. FoldCase s => s -> CI s
CI.mk (Text -> CI Text) -> Text -> CI Text
forall a b. (a -> b) -> a -> b
$ OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode ByteString
host
config :: RedirectConfig
config = RedirectConfig :: 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
}
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 = (HeaderName
"X-Forwarded-Proto", ByteString
protocol)
(HeaderName, 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
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
..}) ->
(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] -> Application -> Application
processMiddleware [MiddlewareConfig]
sfconfigMiddleware (Application -> Application) -> Application -> Application
forall a b. (a -> b) -> a -> b
$ StaticSettings -> Application
staticApp (String -> StaticSettings
defaultFileServerSettings String
sfconfigRoot)
{ ssListing :: 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] -> Application -> Application
processMiddleware [MiddlewareConfig]
rpconfigMiddleware
(Application -> Application) -> Application -> Application
forall a b. (a -> b) -> a -> b
$ Manager -> ReverseProxyConfig -> Application
Rewrite.simpleReverseProxy Manager
psManager ReverseProxyConfig
config
)
redirectApp :: RedirectConfig -> Wai.Request -> Wai.Response
redirectApp :: RedirectConfig -> Request -> Response
redirectApp RedirectConfig {Int
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
[(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 (ByteString -> Status) -> ByteString -> Status
forall a b. (a -> b) -> a -> b
$ String -> ByteString
S8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
i
mkUrl :: RedirectDest -> ByteString
mkUrl (RDUrl Text
url) = Text -> ByteString
encodeUtf8 Text
url
mkUrl (RDPrefix Bool
isSecure CI Text
host Maybe Int
mport) = [ByteString] -> ByteString
S.concat
[ if Bool
isSecure then ByteString
"https://" else ByteString
"http://"
, Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ CI Text -> Text
forall s. CI s -> s
CI.original CI Text
host
, case Maybe Int
mport of
Maybe Int
Nothing -> ByteString
""
Just Int
port
| Bool
isSecure Bool -> Bool -> Bool
&& Int
port Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
443 -> ByteString
""
| Bool -> Bool
not Bool
isSecure Bool -> Bool -> Bool
&& Int
port Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
80 -> ByteString
""
| Bool
otherwise -> String -> ByteString
S8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Char
':' Char -> String -> String
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show Int
port
, Request -> ByteString
Wai.rawPathInfo Request
req
, Request -> ByteString
Wai.rawQueryString Request
req
]
handleProxyException :: (Wai.Request -> SomeException -> IO ()) -> ByteString -> SomeException -> Wai.Application
handleProxyException :: (Request -> SomeException -> IO ())
-> ByteString -> SomeException -> Application
handleProxyException Request -> SomeException -> IO ()
handleException ByteString
onexceptBody SomeException
except Request
req Response -> IO ResponseReceived
respond = do
Request -> SomeException -> IO ()
handleException Request
req SomeException
except
Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ ByteString -> Response
missingHostResponse ByteString
onexceptBody
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")]
(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>"
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 (Builder -> ByteString)
-> (ByteString -> Builder) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
fromHtmlEscapedByteString