-- SPDX-License-Identifier: Apache-2.0
--
-- Copyright (C) 2023 Bin Jin. All Rights Reserved.

{-# LANGUAGE ViewPatterns #-}
module Network.HProx.Impl
  ( ProxySettings(..)
  , acmeProvider
  , forceSSL
  , healthCheckProvider
  , httpConnectProxy
  , httpGetProxy
  , httpProxy
  , logRequest
  , pacProvider
  , reverseProxy
  ) where

import Control.Applicative        ((<|>))
import Control.Concurrent.Async   (cancel, wait, waitEither, withAsync)
import Control.Exception          (SomeException, try)
import Control.Monad              (forM_, unless, void, when)
import Control.Monad.IO.Class     (liftIO)
import Data.Binary.Builder        qualified as BB
import Data.ByteString            qualified as BS
import Data.ByteString.Base64     (decodeLenient)
import Data.ByteString.Char8      qualified as BS8
import Data.ByteString.Lazy       qualified as LBS
import Data.ByteString.Lazy.Char8 qualified as LBS8
import Data.CaseInsensitive       qualified as CI
import Data.Conduit.Network       qualified as CN
import Data.Text.Encoding         qualified as TE
import Network.HTTP.Client        qualified as HC
import Network.HTTP.ReverseProxy
    (ProxyDest(..), SetIpHeader(..), WaiProxyResponse(..), defaultWaiProxySettings,
    waiProxyToSettings, wpsSetIpHeader, wpsUpgradeToRaw)
import Network.HTTP.Types         qualified as HT
import Network.HTTP.Types.Header  qualified as HT
import System.Timeout             (timeout)

import Data.Conduit
import Data.Maybe
import Network.Wai
import Network.Wai.Middleware.StripHeaders

import Network.HProx.Log
import Network.HProx.Naive
import Network.HProx.Util

data ProxySettings = ProxySettings
  { ProxySettings -> Maybe (ByteString -> Bool)
proxyAuth      :: !(Maybe (BS.ByteString -> Bool))
  , ProxySettings -> Maybe ByteString
passPrompt     :: !(Maybe BS.ByteString)
  , ProxySettings -> Maybe ByteString
wsRemote       :: !(Maybe BS.ByteString)
  , ProxySettings -> [(Maybe ByteString, ByteString, ByteString)]
revRemoteMap   :: ![(Maybe BS.ByteString, BS.ByteString, BS.ByteString)]
  , ProxySettings -> Bool
hideProxyAuth  :: !Bool
  , ProxySettings -> Bool
naivePadding   :: !Bool
  , ProxySettings -> Maybe ByteString
acmeThumbprint :: !(Maybe BS.ByteString)
  , ProxySettings -> Logger
logger         :: !Logger
  }

logRequest :: Request -> LogStr
logRequest :: Request -> LogStr
logRequest Request
req = ByteString -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (Request -> ByteString
requestMethod Request
req) LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<>
    LogStr
" " LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
hostname LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> ByteString -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (Request -> ByteString
rawPathInfo Request
req) LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<>
    LogStr
" " LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> String -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (HttpVersion -> String
forall a. Show a => a -> String
show (HttpVersion -> String) -> HttpVersion -> String
forall a b. (a -> b) -> a -> b
$ Request -> HttpVersion
httpVersion Request
req) LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<>
    LogStr
" " LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> (if Request -> Bool
isSecure Request
req then LogStr
"(tls) " else LogStr
"")
    LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> String -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (SockAddr -> String
forall a. Show a => a -> String
show (SockAddr -> String) -> SockAddr -> String
forall a b. (a -> b) -> a -> b
$ Request -> SockAddr
remoteHost Request
req)
  where
    isConnect :: Bool
isConnect = Request -> ByteString
requestMethod Request
req ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"CONNECT"
    isGet :: Bool
isGet = ByteString
"http://" ByteString -> ByteString -> Bool
`BS.isPrefixOf` Request -> ByteString
rawPathInfo Request
req
    hostname :: LogStr
hostname | Bool
isConnect Bool -> Bool -> Bool
|| Bool
isGet = LogStr
""
             | Bool
otherwise          = ByteString -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"(no-host)" (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Request -> Maybe ByteString
requestHeaderHost Request
req)

httpProxy :: ProxySettings -> HC.Manager -> Middleware
httpProxy :: ProxySettings -> Manager -> Middleware
httpProxy ProxySettings
set Manager
mgr = Middleware
pacProvider Middleware -> Middleware -> Middleware
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProxySettings -> Manager -> Middleware
httpGetProxy ProxySettings
set Manager
mgr Middleware -> Middleware -> Middleware
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProxySettings -> Middleware
httpConnectProxy ProxySettings
set

forceSSL :: ProxySettings -> Middleware
forceSSL :: ProxySettings -> Middleware
forceSSL ProxySettings
pset Application
app Request
req Response -> IO ResponseReceived
respond
    | Request -> Bool
isSecure Request
req               = Application
app Request
req Response -> IO ResponseReceived
respond
    | ProxySettings -> Request -> Bool
redirectWebsocket ProxySettings
pset Request
req = Application
app Request
req Response -> IO ResponseReceived
respond
    | Bool
otherwise                  = Application
redirectToSSL Request
req Response -> IO ResponseReceived
respond

redirectToSSL :: Application
redirectToSSL :: Application
redirectToSSL Request
req Response -> IO ResponseReceived
respond
    | Just ByteString
host <- Request -> Maybe ByteString
requestHeaderHost Request
req = Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseKnownLength
        Status
HT.status301
        [(HeaderName
"Location", ByteString
"https://" ByteString -> ByteString -> ByteString
`BS.append` ByteString
host)]
        ByteString
""
    | Bool
otherwise                          = Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseKnownLength
        (Int -> ByteString -> Status
HT.mkStatus Int
426 ByteString
"Upgrade Required")
        [(HeaderName
"Upgrade", ByteString
"TLS/1.0, HTTP/1.1"), (HeaderName
"Connection", ByteString
"Upgrade")]
        ByteString
""

isProxyHeader :: HT.HeaderName -> Bool
isProxyHeader :: HeaderName -> Bool
isProxyHeader HeaderName
h = ByteString
"proxy" ByteString -> ByteString -> Bool
`BS.isPrefixOf` HeaderName -> ByteString
forall s. CI s -> s
CI.foldedCase HeaderName
h

isForwardedHeader :: HT.HeaderName -> Bool
isForwardedHeader :: HeaderName -> Bool
isForwardedHeader HeaderName
h = ByteString
"x-forwarded" ByteString -> ByteString -> Bool
`BS.isPrefixOf` HeaderName -> ByteString
forall s. CI s -> s
CI.foldedCase HeaderName
h

isCDNHeader :: HT.HeaderName -> Bool
isCDNHeader :: HeaderName -> Bool
isCDNHeader HeaderName
h = ByteString
"cf-" ByteString -> ByteString -> Bool
`BS.isPrefixOf` HeaderName -> ByteString
forall s. CI s -> s
CI.foldedCase HeaderName
h Bool -> Bool -> Bool
|| HeaderName
h HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
"cdn-loop"

isToStripHeader :: HT.HeaderName -> Bool
isToStripHeader :: HeaderName -> Bool
isToStripHeader HeaderName
h = HeaderName -> Bool
isProxyHeader HeaderName
h Bool -> Bool -> Bool
|| HeaderName -> Bool
isForwardedHeader HeaderName
h Bool -> Bool -> Bool
|| HeaderName -> Bool
isCDNHeader HeaderName
h Bool -> Bool -> Bool
|| HeaderName
h HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
"X-Real-IP" Bool -> Bool -> Bool
|| HeaderName
h HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
"X-Scheme"

checkAuth :: ProxySettings -> Request -> Bool
checkAuth :: ProxySettings -> Request -> Bool
checkAuth ProxySettings{Bool
[(Maybe ByteString, ByteString, ByteString)]
Maybe ByteString
Maybe (ByteString -> Bool)
Logger
proxyAuth :: ProxySettings -> Maybe (ByteString -> Bool)
passPrompt :: ProxySettings -> Maybe ByteString
wsRemote :: ProxySettings -> Maybe ByteString
revRemoteMap :: ProxySettings -> [(Maybe ByteString, ByteString, ByteString)]
hideProxyAuth :: ProxySettings -> Bool
naivePadding :: ProxySettings -> Bool
acmeThumbprint :: ProxySettings -> Maybe ByteString
logger :: ProxySettings -> Logger
proxyAuth :: Maybe (ByteString -> Bool)
passPrompt :: Maybe ByteString
wsRemote :: Maybe ByteString
revRemoteMap :: [(Maybe ByteString, ByteString, ByteString)]
hideProxyAuth :: Bool
naivePadding :: Bool
acmeThumbprint :: Maybe ByteString
logger :: Logger
..} Request
req = case (Maybe (ByteString -> Bool)
proxyAuth, Maybe ByteString
authRsp) of
    (Maybe (ByteString -> Bool)
Nothing, Maybe ByteString
_)                -> Bool
True
    (Maybe (ByteString -> Bool)
_, Maybe ByteString
Nothing)                -> Bool
False
    (Just ByteString -> Bool
check, Just ByteString
provided) ->
        let decoded :: ByteString
decoded = ByteString -> ByteString
decodeLenient (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> b
snd ((ByteString, ByteString) -> ByteString)
-> (ByteString, ByteString) -> ByteString
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> (ByteString, ByteString)
BS8.spanEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
' ') ByteString
provided
            authorized :: Bool
authorized = ByteString -> Bool
check ByteString
decoded
            authMsg :: LogStr
authMsg = if Bool
authorized then LogStr
"authorized" else LogStr
"unauthorized"
            logMsg :: LogStr
logMsg = LogStr
authMsg LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
" request (credential: " LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> ByteString -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr ByteString
decoded LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
") from "
                             LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> String -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (SockAddr -> String
forall a. Show a => a -> String
show (Request -> SockAddr
remoteHost Request
req))
        in Logger -> LogLevel -> LogStr -> Bool -> Bool
forall a. Logger -> LogLevel -> LogStr -> a -> a
pureLogger Logger
logger LogLevel
TRACE LogStr
logMsg Bool
authorized
  where
    authRsp :: Maybe ByteString
authRsp = HeaderName -> ResponseHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
HT.hProxyAuthorization (Request -> ResponseHeaders
requestHeaders Request
req)

parseConnectProxy :: Request -> Maybe (BS.ByteString, Int)
parseConnectProxy :: Request -> Maybe (ByteString, Int)
parseConnectProxy Request
req
    | Request -> ByteString
requestMethod Request
req ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"CONNECT" = ByteString -> Maybe (ByteString, Int)
parseHostPort (Request -> ByteString
rawPathInfo Request
req) Maybe (ByteString, Int)
-> Maybe (ByteString, Int) -> Maybe (ByteString, Int)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Request -> Maybe ByteString
requestHeaderHost Request
req Maybe ByteString
-> (ByteString -> Maybe (ByteString, Int))
-> Maybe (ByteString, Int)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Maybe (ByteString, Int)
parseHostPort)
    | Bool
otherwise                      = Maybe (ByteString, Int)
forall a. Maybe a
Nothing

redirectWebsocket :: ProxySettings -> Request -> Bool
redirectWebsocket :: ProxySettings -> Request -> Bool
redirectWebsocket ProxySettings{Bool
[(Maybe ByteString, ByteString, ByteString)]
Maybe ByteString
Maybe (ByteString -> Bool)
Logger
proxyAuth :: ProxySettings -> Maybe (ByteString -> Bool)
passPrompt :: ProxySettings -> Maybe ByteString
wsRemote :: ProxySettings -> Maybe ByteString
revRemoteMap :: ProxySettings -> [(Maybe ByteString, ByteString, ByteString)]
hideProxyAuth :: ProxySettings -> Bool
naivePadding :: ProxySettings -> Bool
acmeThumbprint :: ProxySettings -> Maybe ByteString
logger :: ProxySettings -> Logger
proxyAuth :: Maybe (ByteString -> Bool)
passPrompt :: Maybe ByteString
wsRemote :: Maybe ByteString
revRemoteMap :: [(Maybe ByteString, ByteString, ByteString)]
hideProxyAuth :: Bool
naivePadding :: Bool
acmeThumbprint :: Maybe ByteString
logger :: Logger
..} Request
req = WaiProxySettings -> Request -> Bool
wpsUpgradeToRaw WaiProxySettings
defaultWaiProxySettings Request
req Bool -> Bool -> Bool
&& Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust Maybe ByteString
wsRemote

proxyAuthRequiredResponse :: ProxySettings -> Response
proxyAuthRequiredResponse :: ProxySettings -> Response
proxyAuthRequiredResponse ProxySettings{Bool
[(Maybe ByteString, ByteString, ByteString)]
Maybe ByteString
Maybe (ByteString -> Bool)
Logger
proxyAuth :: ProxySettings -> Maybe (ByteString -> Bool)
passPrompt :: ProxySettings -> Maybe ByteString
wsRemote :: ProxySettings -> Maybe ByteString
revRemoteMap :: ProxySettings -> [(Maybe ByteString, ByteString, ByteString)]
hideProxyAuth :: ProxySettings -> Bool
naivePadding :: ProxySettings -> Bool
acmeThumbprint :: ProxySettings -> Maybe ByteString
logger :: ProxySettings -> Logger
proxyAuth :: Maybe (ByteString -> Bool)
passPrompt :: Maybe ByteString
wsRemote :: Maybe ByteString
revRemoteMap :: [(Maybe ByteString, ByteString, ByteString)]
hideProxyAuth :: Bool
naivePadding :: Bool
acmeThumbprint :: Maybe ByteString
logger :: Logger
..} = Status -> ResponseHeaders -> ByteString -> Response
responseKnownLength
    Status
HT.status407
    [(HeaderName
HT.hProxyAuthenticate, ByteString
"Basic realm=\"" ByteString -> ByteString -> ByteString
`BS.append` ByteString
prompt ByteString -> ByteString -> ByteString
`BS.append` ByteString
"\"")]
    ByteString
""
  where
    prompt :: ByteString
prompt = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"hprox" Maybe ByteString
passPrompt

acmeProvider :: ProxySettings -> Middleware
acmeProvider :: ProxySettings -> Middleware
acmeProvider ProxySettings{Bool
[(Maybe ByteString, ByteString, ByteString)]
Maybe ByteString
Maybe (ByteString -> Bool)
Logger
proxyAuth :: ProxySettings -> Maybe (ByteString -> Bool)
passPrompt :: ProxySettings -> Maybe ByteString
wsRemote :: ProxySettings -> Maybe ByteString
revRemoteMap :: ProxySettings -> [(Maybe ByteString, ByteString, ByteString)]
hideProxyAuth :: ProxySettings -> Bool
naivePadding :: ProxySettings -> Bool
acmeThumbprint :: ProxySettings -> Maybe ByteString
logger :: ProxySettings -> Logger
proxyAuth :: Maybe (ByteString -> Bool)
passPrompt :: Maybe ByteString
wsRemote :: Maybe ByteString
revRemoteMap :: [(Maybe ByteString, ByteString, ByteString)]
hideProxyAuth :: Bool
naivePadding :: Bool
acmeThumbprint :: Maybe ByteString
logger :: Logger
..} Application
app Request
req Response -> IO ResponseReceived
respond
    | Bool -> Bool
not (Request -> Bool
isSecure Request
req)
    , Just ByteString
thumbprint <- Maybe ByteString
acmeThumbprint
    , [Text
".well-known", Text
"acme-challenge", Text
token] <- Request -> [Text]
pathInfo Request
req
        = Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseKnownLength
              Status
HT.status200
              [(HeaderName
"Content-Type", ByteString
"text/plain")] (ByteString -> Response) -> ByteString -> Response
forall a b. (a -> b) -> a -> b
$
              [ByteString] -> ByteString
LBS.fromChunks [Text -> ByteString
TE.encodeUtf8 Text
token, ByteString
".", ByteString
thumbprint]
    | Bool
otherwise
        = Application
app Request
req Response -> IO ResponseReceived
respond

pacProvider :: Middleware
pacProvider :: Middleware
pacProvider Application
fallback Request
req Response -> IO ResponseReceived
respond
    | Request -> [Text]
pathInfo Request
req [Text] -> [Text] -> Bool
forall a. Eq a => a -> a -> Bool
== [Text
".hprox", Text
"config.pac"],
      Just ByteString
host' <- HeaderName -> ResponseHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"x-forwarded-host" (Request -> ResponseHeaders
requestHeaders Request
req) Maybe ByteString -> Maybe ByteString -> Maybe ByteString
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Request -> Maybe ByteString
requestHeaderHost Request
req =
        let issecure :: Bool
issecure = case HeaderName -> ResponseHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"x-forwarded-proto" (Request -> ResponseHeaders
requestHeaders Request
req) of
                Just ByteString
proto -> ByteString
proto ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"https"
                Maybe ByteString
Nothing    -> Request -> Bool
isSecure Request
req
            scheme :: ByteString
scheme = if Bool
issecure then ByteString
"HTTPS" else ByteString
"PROXY"
            defaultPort :: ByteString
defaultPort = if Bool
issecure then ByteString
":443" else ByteString
":80"
            host :: ByteString
host | Word8
58 Word8 -> ByteString -> Bool
`BS.elem` ByteString
host' = ByteString
host' -- ':'
                 | Bool
otherwise          = ByteString
host' ByteString -> ByteString -> ByteString
`BS.append` ByteString
defaultPort
        in Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseKnownLength
               Status
HT.status200
               [(HeaderName
"Content-Type", ByteString
"application/x-ns-proxy-autoconfig")] (ByteString -> Response) -> ByteString -> Response
forall a b. (a -> b) -> a -> b
$
               [ByteString] -> ByteString
LBS8.unlines [ ByteString
"function FindProxyForURL(url, host) {"
                            , [ByteString] -> ByteString
LBS8.fromChunks [ByteString
"  return \"", ByteString
scheme, ByteString
" ", ByteString
host, ByteString
"\";"]
                            , ByteString
"}"
                            ]
    | Bool
otherwise = Application
fallback Request
req Response -> IO ResponseReceived
respond

healthCheckProvider :: Middleware
healthCheckProvider :: Middleware
healthCheckProvider Application
fallback Request
req Response -> IO ResponseReceived
respond
    | Request -> [Text]
pathInfo Request
req [Text] -> [Text] -> Bool
forall a. Eq a => a -> a -> Bool
== [Text
".hprox", Text
"health"] =
        Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseKnownLength
            Status
HT.status200
            [(HeaderName
"Content-Type", ByteString
"text/plain")]
            ByteString
"okay"
    | Bool
otherwise = Application
fallback Request
req Response -> IO ResponseReceived
respond

reverseProxy :: ProxySettings -> HC.Manager -> Middleware
reverseProxy :: ProxySettings -> Manager -> Middleware
reverseProxy ProxySettings{Bool
[(Maybe ByteString, ByteString, ByteString)]
Maybe ByteString
Maybe (ByteString -> Bool)
Logger
proxyAuth :: ProxySettings -> Maybe (ByteString -> Bool)
passPrompt :: ProxySettings -> Maybe ByteString
wsRemote :: ProxySettings -> Maybe ByteString
revRemoteMap :: ProxySettings -> [(Maybe ByteString, ByteString, ByteString)]
hideProxyAuth :: ProxySettings -> Bool
naivePadding :: ProxySettings -> Bool
acmeThumbprint :: ProxySettings -> Maybe ByteString
logger :: ProxySettings -> Logger
proxyAuth :: Maybe (ByteString -> Bool)
passPrompt :: Maybe ByteString
wsRemote :: Maybe ByteString
revRemoteMap :: [(Maybe ByteString, ByteString, ByteString)]
hideProxyAuth :: Bool
naivePadding :: Bool
acmeThumbprint :: Maybe ByteString
logger :: Logger
..} Manager
mgr Application
fallback =
    (Response -> Response) -> Middleware
modifyResponse ([ByteString] -> Response -> Response
stripHeaders [ByteString
"Server", ByteString
"Date", ByteString
"Keep-Alive"]) Middleware -> Middleware
forall a b. (a -> b) -> a -> b
$
        (Request -> IO WaiProxyResponse)
-> WaiProxySettings -> Manager -> Application
waiProxyToSettings (WaiProxyResponse -> IO WaiProxyResponse
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return(WaiProxyResponse -> IO WaiProxyResponse)
-> (Request -> WaiProxyResponse) -> Request -> IO WaiProxyResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Request -> WaiProxyResponse
proxyResponseFor) WaiProxySettings
settings Manager
mgr
  where
    settings :: WaiProxySettings
settings = WaiProxySettings
defaultWaiProxySettings { wpsSetIpHeader = SIHNone }

    checkDomain :: Maybe a -> Maybe a -> Bool
checkDomain Maybe a
Nothing Maybe a
_         = Bool
True
    checkDomain Maybe a
_ Maybe a
Nothing         = Bool
False
    checkDomain (Just a
a) (Just a
b) = a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
b

    proxyResponseFor :: Request -> WaiProxyResponse
proxyResponseFor Request
req = [(Maybe ByteString, ByteString, ByteString)] -> WaiProxyResponse
go [(Maybe ByteString, ByteString, ByteString)]
revRemoteMap
      where
        go :: [(Maybe ByteString, ByteString, ByteString)] -> WaiProxyResponse
go ((Maybe ByteString
mTargetHost, ByteString
prefix, ByteString
revRemote):[(Maybe ByteString, ByteString, ByteString)]
left)
          | Maybe ByteString -> Maybe ByteString -> Bool
forall {a}. Eq a => Maybe a -> Maybe a -> Bool
checkDomain Maybe ByteString
mTargetHost Maybe ByteString
mReqHost Bool -> Bool -> Bool
&& ByteString
prefix ByteString -> ByteString -> Bool
`BS.isPrefixOf` Request -> ByteString
rawPathInfo Request
req =
            if Int
revPort Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
443
                then Request -> ProxyDest -> WaiProxyResponse
WPRModifiedRequestSecure Request
nreq (ByteString -> Int -> ProxyDest
ProxyDest ByteString
revHost Int
revPort)
                else Request -> ProxyDest -> WaiProxyResponse
WPRModifiedRequest Request
nreq (ByteString -> Int -> ProxyDest
ProxyDest ByteString
revHost Int
revPort)
          | Bool
otherwise = [(Maybe ByteString, ByteString, ByteString)] -> WaiProxyResponse
go [(Maybe ByteString, ByteString, ByteString)]
left
          where
            mReqHost :: Maybe ByteString
mReqHost = (ByteString -> ByteString) -> Maybe ByteString -> Maybe ByteString
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ByteString, Int) -> ByteString
forall a b. (a, b) -> a
fst ((ByteString, Int) -> ByteString)
-> (ByteString -> (ByteString, Int)) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> (ByteString, Int)
parseHostPortWithDefault (String -> Int
forall a. HasCallStack => String -> a
error String
"unused port number")) (Request -> Maybe ByteString
requestHeaderHost Request
req)
            (ByteString
revHost, Int
revPort) = Int -> ByteString -> (ByteString, Int)
parseHostPortWithDefault Int
80 ByteString
revRemote
            nreq :: Request
nreq = Request
req
              { requestHeaders = hdrs
              , requestHeaderHost = Just revHost
              , rawPathInfo = BS.drop (BS.length prefix - 1) (rawPathInfo req)
              }
            hdrs :: ResponseHeaders
hdrs = (HeaderName
HT.hHost, ByteString
revHost) (HeaderName, ByteString) -> ResponseHeaders -> ResponseHeaders
forall a. a -> [a] -> [a]
: [ (HeaderName
hdn, ByteString
hdv)
                                         | (HeaderName
hdn, ByteString
hdv) <- Request -> ResponseHeaders
requestHeaders Request
req
                                         , Bool -> Bool
not (HeaderName -> Bool
isToStripHeader HeaderName
hdn) Bool -> Bool -> Bool
&& HeaderName
hdn HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
/= HeaderName
HT.hHost
                                         ]
        go [(Maybe ByteString, ByteString, ByteString)]
_ = Application -> WaiProxyResponse
WPRApplication Application
fallback

httpGetProxy :: ProxySettings -> HC.Manager -> Middleware
httpGetProxy :: ProxySettings -> Manager -> Middleware
httpGetProxy pset :: ProxySettings
pset@ProxySettings{Bool
[(Maybe ByteString, ByteString, ByteString)]
Maybe ByteString
Maybe (ByteString -> Bool)
Logger
proxyAuth :: ProxySettings -> Maybe (ByteString -> Bool)
passPrompt :: ProxySettings -> Maybe ByteString
wsRemote :: ProxySettings -> Maybe ByteString
revRemoteMap :: ProxySettings -> [(Maybe ByteString, ByteString, ByteString)]
hideProxyAuth :: ProxySettings -> Bool
naivePadding :: ProxySettings -> Bool
acmeThumbprint :: ProxySettings -> Maybe ByteString
logger :: ProxySettings -> Logger
proxyAuth :: Maybe (ByteString -> Bool)
passPrompt :: Maybe ByteString
wsRemote :: Maybe ByteString
revRemoteMap :: [(Maybe ByteString, ByteString, ByteString)]
hideProxyAuth :: Bool
naivePadding :: Bool
acmeThumbprint :: Maybe ByteString
logger :: Logger
..} Manager
mgr Application
fallback = (Request -> IO WaiProxyResponse)
-> WaiProxySettings -> Manager -> Application
waiProxyToSettings (WaiProxyResponse -> IO WaiProxyResponse
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return(WaiProxyResponse -> IO WaiProxyResponse)
-> (Request -> WaiProxyResponse) -> Request -> IO WaiProxyResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Request -> WaiProxyResponse
proxyResponseFor) WaiProxySettings
settings Manager
mgr
  where
    settings :: WaiProxySettings
settings = WaiProxySettings
defaultWaiProxySettings { wpsSetIpHeader = SIHNone }

    proxyResponseFor :: Request -> WaiProxyResponse
proxyResponseFor Request
req
        | ProxySettings -> Request -> Bool
redirectWebsocket ProxySettings
pset Request
req = ProxyDest -> WaiProxyResponse
wsWrapper (ByteString -> Int -> ProxyDest
ProxyDest ByteString
wsHost Int
wsPort)
        | Bool -> Bool
not Bool
isGETProxy             = Application -> WaiProxyResponse
WPRApplication Application
fallback
        | ProxySettings -> Request -> Bool
checkAuth ProxySettings
pset Request
req         = Request -> ProxyDest -> WaiProxyResponse
WPRModifiedRequest Request
nreq (ByteString -> Int -> ProxyDest
ProxyDest ByteString
host Int
port)
        | Bool
hideProxyAuth              =
            Logger
-> LogLevel -> LogStr -> WaiProxyResponse -> WaiProxyResponse
forall a. Logger -> LogLevel -> LogStr -> a -> a
pureLogger Logger
logger LogLevel
WARN (LogStr
"unauthorized request (hidden without response): " LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> Request -> LogStr
logRequest Request
req) (WaiProxyResponse -> WaiProxyResponse)
-> WaiProxyResponse -> WaiProxyResponse
forall a b. (a -> b) -> a -> b
$
            Application -> WaiProxyResponse
WPRApplication Application
fallback
        | Bool
otherwise                  =
            Logger
-> LogLevel -> LogStr -> WaiProxyResponse -> WaiProxyResponse
forall a. Logger -> LogLevel -> LogStr -> a -> a
pureLogger Logger
logger LogLevel
WARN (LogStr
"unauthorized request: " LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> Request -> LogStr
logRequest Request
req) (WaiProxyResponse -> WaiProxyResponse)
-> WaiProxyResponse -> WaiProxyResponse
forall a b. (a -> b) -> a -> b
$
            Response -> WaiProxyResponse
WPRResponse (ProxySettings -> Response
proxyAuthRequiredResponse ProxySettings
pset)
      where
        (ByteString
wsHost, Int
wsPort) = Int -> ByteString -> (ByteString, Int)
parseHostPortWithDefault Int
80 (Maybe ByteString -> ByteString
forall a. HasCallStack => Maybe a -> a
fromJust Maybe ByteString
wsRemote)
        wsWrapper :: ProxyDest -> WaiProxyResponse
wsWrapper = if Int
wsPort Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
443 then ProxyDest -> WaiProxyResponse
WPRProxyDestSecure else ProxyDest -> WaiProxyResponse
WPRProxyDest

        notCONNECT :: Bool
notCONNECT = Request -> ByteString
requestMethod Request
req ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"CONNECT"
        rawPath :: ByteString
rawPath = Request -> ByteString
rawPathInfo Request
req
        rawPathPrefix :: ByteString
rawPathPrefix = ByteString
"http://"
        defaultPort :: Int
defaultPort = Int
80
        hostHeader :: Maybe (ByteString, Int)
hostHeader = Int -> ByteString -> (ByteString, Int)
parseHostPortWithDefault Int
defaultPort (ByteString -> (ByteString, Int))
-> Maybe ByteString -> Maybe (ByteString, Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Request -> Maybe ByteString
requestHeaderHost Request
req

        isRawPathProxy :: Bool
isRawPathProxy = ByteString
rawPathPrefix ByteString -> ByteString -> Bool
`BS.isPrefixOf` ByteString
rawPath
        hasProxyHeader :: Bool
hasProxyHeader = ((HeaderName, ByteString) -> Bool) -> ResponseHeaders -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (HeaderName -> Bool
isProxyHeader(HeaderName -> Bool)
-> ((HeaderName, ByteString) -> HeaderName)
-> (HeaderName, ByteString)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(HeaderName, ByteString) -> HeaderName
forall a b. (a, b) -> a
fst) (Request -> ResponseHeaders
requestHeaders Request
req)
        scheme :: Maybe ByteString
scheme = HeaderName -> ResponseHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"X-Scheme" (Request -> ResponseHeaders
requestHeaders Request
req)
        isHTTP2Proxy :: Bool
isHTTP2Proxy = HttpVersion -> Int
HT.httpMajor (Request -> HttpVersion
httpVersion Request
req) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2 Bool -> Bool -> Bool
&& Maybe ByteString
scheme Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"http" Bool -> Bool -> Bool
&& Request -> Bool
isSecure Request
req

        isGETProxy :: Bool
isGETProxy = Bool
notCONNECT Bool -> Bool -> Bool
&& (Bool
isRawPathProxy Bool -> Bool -> Bool
|| Bool
isHTTP2Proxy Bool -> Bool -> Bool
|| Maybe (ByteString, Int) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (ByteString, Int)
hostHeader Bool -> Bool -> Bool
&& Bool
hasProxyHeader)

        nreq :: Request
nreq = Request
req
          { rawPathInfo = newRawPath
          , requestHeaders = filter (not.isToStripHeader.fst) $ requestHeaders req
          }

        ((ByteString
host, Int
port), ByteString
newRawPath)
            | Bool
isRawPathProxy  = (Int -> ByteString -> (ByteString, Int)
parseHostPortWithDefault Int
defaultPort ByteString
hostPortP, ByteString
newRawPathP)
            | Bool
otherwise       = (Maybe (ByteString, Int) -> (ByteString, Int)
forall a. HasCallStack => Maybe a -> a
fromJust Maybe (ByteString, Int)
hostHeader, ByteString
rawPath)
          where
            (ByteString
hostPortP, ByteString
newRawPathP) = (Char -> Bool) -> ByteString -> (ByteString, ByteString)
BS8.span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'/') (ByteString -> (ByteString, ByteString))
-> ByteString -> (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$
                Int -> ByteString -> ByteString
BS.drop (ByteString -> Int
BS.length ByteString
rawPathPrefix) ByteString
rawPath

httpConnectProxy :: ProxySettings -> Middleware
httpConnectProxy :: ProxySettings -> Middleware
httpConnectProxy pset :: ProxySettings
pset@ProxySettings{Bool
[(Maybe ByteString, ByteString, ByteString)]
Maybe ByteString
Maybe (ByteString -> Bool)
Logger
proxyAuth :: ProxySettings -> Maybe (ByteString -> Bool)
passPrompt :: ProxySettings -> Maybe ByteString
wsRemote :: ProxySettings -> Maybe ByteString
revRemoteMap :: ProxySettings -> [(Maybe ByteString, ByteString, ByteString)]
hideProxyAuth :: ProxySettings -> Bool
naivePadding :: ProxySettings -> Bool
acmeThumbprint :: ProxySettings -> Maybe ByteString
logger :: ProxySettings -> Logger
proxyAuth :: Maybe (ByteString -> Bool)
passPrompt :: Maybe ByteString
wsRemote :: Maybe ByteString
revRemoteMap :: [(Maybe ByteString, ByteString, ByteString)]
hideProxyAuth :: Bool
naivePadding :: Bool
acmeThumbprint :: Maybe ByteString
logger :: Logger
..} Application
fallback req :: Request
req@(Request -> Maybe (ByteString, Int)
parseConnectProxy -> Just (ByteString
host, Int
port)) Response -> IO ResponseReceived
respond
    | ProxySettings -> Request -> Bool
checkAuth ProxySettings
pset Request
req = do
        Maybe PaddingType -> (PaddingType -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe PaddingType
mPaddingType ((PaddingType -> IO ()) -> IO ())
-> (PaddingType -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \PaddingType
paddingType ->
            Logger
logger LogLevel
DEBUG (LogStr -> IO ()) -> LogStr -> IO ()
forall a b. (a -> b) -> a -> b
$ LogStr
"naiveproxy padding type detected: " LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> String -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (PaddingType -> String
forall a. Show a => a -> String
show PaddingType
paddingType) LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<>
                           LogStr
" for " LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> Request -> LogStr
logRequest Request
req
        IO ResponseReceived
respondResponse
    | Bool
hideProxyAuth      = do
        Logger
logger LogLevel
WARN (LogStr -> IO ()) -> LogStr -> IO ()
forall a b. (a -> b) -> a -> b
$ LogStr
"unauthorized request (hidden without response): " LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> Request -> LogStr
logRequest Request
req
        Application
fallback Request
req Response -> IO ResponseReceived
respond
    | Bool
otherwise          = do
        Logger
logger LogLevel
WARN (LogStr -> IO ()) -> LogStr -> IO ()
forall a b. (a -> b) -> a -> b
$ LogStr
"unauthorized request: " LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> Request -> LogStr
logRequest Request
req
        Response -> IO ResponseReceived
respond (ProxySettings -> Response
proxyAuthRequiredResponse ProxySettings
pset)
  where
    settings :: ClientSettings
settings = Int -> ByteString -> ClientSettings
CN.clientSettings Int
port ByteString
host

    backup :: Response
backup = Status -> ResponseHeaders -> ByteString -> Response
responseKnownLength Status
HT.status500 [(HeaderName
"Content-Type", ByteString
"text/plain")]
        ByteString
"HTTP CONNECT tunneling detected, but server does not support responseRaw"

    tryAndCatchAll :: IO a -> IO (Either SomeException a)
    tryAndCatchAll :: forall a. IO a -> IO (Either SomeException a)
tryAndCatchAll = IO a -> IO (Either SomeException a)
forall e a. Exception e => IO a -> IO (Either e a)
try

    runStreams :: Int -> IO () -> IO () -> IO (Either SomeException ())
    runStreams :: Int -> IO () -> IO () -> IO (Either SomeException ())
runStreams Int
secs IO ()
left IO ()
right = IO () -> IO (Either SomeException ())
forall a. IO a -> IO (Either SomeException a)
tryAndCatchAll (IO () -> IO (Either SomeException ()))
-> IO () -> IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$
        IO () -> (Async () -> IO ()) -> IO ()
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync IO ()
left ((Async () -> IO ()) -> IO ()) -> (Async () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Async ()
l -> do
            IO () -> (Async () -> IO ()) -> IO ()
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync IO ()
right ((Async () -> IO ()) -> IO ()) -> (Async () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Async ()
r -> do
                Either () ()
res1 <- Async () -> Async () -> IO (Either () ())
forall a b. Async a -> Async b -> IO (Either a b)
waitEither Async ()
l Async ()
r
                let unfinished :: Async ()
unfinished = case Either () ()
res1 of
                        Left ()
_  -> Async ()
r
                        Right ()
_ -> Async ()
l
                Maybe ()
res2 <- Int -> IO () -> IO (Maybe ())
forall a. Int -> IO a -> IO (Maybe a)
timeout (Int
secs Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000000) (Async () -> IO ()
forall a. Async a -> IO a
wait Async ()
unfinished)
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe () -> Bool
forall a. Maybe a -> Bool
isNothing Maybe ()
res2) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Async () -> IO ()
forall a. Async a -> IO ()
cancel Async ()
unfinished

    mPaddingType :: Maybe PaddingType
mPaddingType = if Bool
naivePadding then Request -> Maybe PaddingType
parseRequestForPadding Request
req else Maybe PaddingType
forall a. Maybe a
Nothing

    respondResponse :: IO ResponseReceived
respondResponse
        | HttpVersion -> Int
HT.httpMajor (Request -> HttpVersion
httpVersion Request
req) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 = Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ (IO ByteString -> (ByteString -> IO ()) -> IO ())
-> Response -> Response
responseRaw (Bool -> IO ByteString -> (ByteString -> IO ()) -> IO ()
handleConnect Bool
True) Response
backup
        | Bool
otherwise                          = do
            ResponseHeaders
paddingHeaders <- IO ResponseHeaders -> IO ResponseHeaders
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ResponseHeaders -> IO ResponseHeaders)
-> IO ResponseHeaders -> IO ResponseHeaders
forall a b. (a -> b) -> a -> b
$ Maybe PaddingType -> IO ResponseHeaders
prepareResponseForPadding Maybe PaddingType
mPaddingType
            Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> StreamingBody -> Response
responseStream Status
HT.status200 ResponseHeaders
paddingHeaders StreamingBody
forall {a}. (Builder -> IO a) -> IO () -> IO ()
streaming
      where
        streaming :: (Builder -> IO a) -> IO () -> IO ()
streaming Builder -> IO a
write IO ()
flush = do
            IO ()
flush
            Bool -> IO ByteString -> (ByteString -> IO ()) -> IO ()
handleConnect Bool
False (Request -> IO ByteString
getRequestBodyChunk Request
req) (\ByteString
bs -> Builder -> IO a
write (ByteString -> Builder
BB.fromByteString ByteString
bs) IO a -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
flush)

    yieldHttp1Response :: ConduitT i ByteString IO ()
yieldHttp1Response = do
        ResponseHeaders
paddingHeaders <- IO ResponseHeaders -> ConduitT i ByteString IO ResponseHeaders
forall a. IO a -> ConduitT i ByteString IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ResponseHeaders -> ConduitT i ByteString IO ResponseHeaders)
-> IO ResponseHeaders -> ConduitT i ByteString IO ResponseHeaders
forall a b. (a -> b) -> a -> b
$ Maybe PaddingType -> IO ResponseHeaders
prepareResponseForPadding Maybe PaddingType
mPaddingType
        let headers :: [Builder]
headers = [ ByteString -> Builder
BB.fromByteString (HeaderName -> ByteString
forall s. CI s -> s
CI.original HeaderName
hn) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
": " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
BB.fromByteString ByteString
hv Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\r\n"
                      | (HeaderName
hn, ByteString
hv) <- ResponseHeaders
paddingHeaders
                      ]
        ByteString -> ConduitT i ByteString IO ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (ByteString -> ConduitT i ByteString IO ())
-> ByteString -> ConduitT i ByteString IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
BB.toLazyByteString (Builder
"HTTP/1.1 200 OK\r\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [Builder]
headers Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\r\n")

    handleConnect :: Bool -> IO BS.ByteString -> (BS.ByteString -> IO ()) -> IO ()
    handleConnect :: Bool -> IO ByteString -> (ByteString -> IO ()) -> IO ()
handleConnect Bool
http1 IO ByteString
fromClient' ByteString -> IO ()
toClient' = ClientSettings -> (AppData -> IO ()) -> IO ()
forall a. ClientSettings -> (AppData -> IO a) -> IO a
CN.runTCPClient ClientSettings
settings ((AppData -> IO ()) -> IO ()) -> (AppData -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \AppData
server ->
        let toServer :: ConduitT ByteString o IO ()
toServer = AppData -> ConduitT ByteString o IO ()
forall ad (m :: * -> *) o.
(HasReadWrite ad, MonadIO m) =>
ad -> ConduitT ByteString o m ()
CN.appSink AppData
server
            fromServer :: ConduitT i ByteString IO ()
fromServer = AppData -> ConduitT i ByteString IO ()
forall ad (m :: * -> *) i.
(HasReadWrite ad, MonadIO m) =>
ad -> ConduitT i ByteString m ()
CN.appSource AppData
server
            fromClient :: ConduitT i ByteString IO ()
fromClient = do
                ByteString
bs <- IO ByteString -> ConduitT i ByteString IO ByteString
forall a. IO a -> ConduitT i ByteString IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ByteString
fromClient'
                Bool -> ConduitT i ByteString IO () -> ConduitT i ByteString IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
BS.null ByteString
bs) (ByteString -> ConduitT i ByteString IO ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield ByteString
bs ConduitT i ByteString IO ()
-> ConduitT i ByteString IO () -> ConduitT i ByteString IO ()
forall a b.
ConduitT i ByteString IO a
-> ConduitT i ByteString IO b -> ConduitT i ByteString IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ConduitT i ByteString IO ()
fromClient)
            toClient :: ConduitT ByteString o IO ()
toClient = (ByteString -> ConduitT ByteString o IO ())
-> ConduitT ByteString o IO ()
forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever (IO () -> ConduitT ByteString o IO ()
forall a. IO a -> ConduitT ByteString o IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ConduitT ByteString o IO ())
-> (ByteString -> IO ())
-> ByteString
-> ConduitT ByteString o IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> IO ()
toClient')

            clientToServer :: ConduitT a c IO ()
clientToServer | Just PaddingType
padding <- Maybe PaddingType
mPaddingType = ConduitT a ByteString IO ()
forall {i}. ConduitT i ByteString IO ()
fromClient ConduitT a ByteString IO ()
-> ConduitT ByteString c IO () -> ConduitT a c IO ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| PaddingType -> ConduitT ByteString ByteString IO ()
removePaddingConduit PaddingType
padding ConduitT ByteString ByteString IO ()
-> ConduitT ByteString c IO () -> ConduitT ByteString c IO ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT ByteString c IO ()
forall {o}. ConduitT ByteString o IO ()
toServer
                           | Bool
otherwise                    = ConduitT a ByteString IO ()
forall {i}. ConduitT i ByteString IO ()
fromClient ConduitT a ByteString IO ()
-> ConduitT ByteString c IO () -> ConduitT a c IO ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT ByteString c IO ()
forall {o}. ConduitT ByteString o IO ()
toServer

            serverToClient :: ConduitT a c IO ()
serverToClient | Just PaddingType
padding <- Maybe PaddingType
mPaddingType = ConduitT a ByteString IO ()
forall {i}. ConduitT i ByteString IO ()
fromServer ConduitT a ByteString IO ()
-> ConduitT ByteString c IO () -> ConduitT a c IO ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| PaddingType -> ConduitT ByteString ByteString IO ()
addPaddingConduit PaddingType
padding ConduitT ByteString ByteString IO ()
-> ConduitT ByteString c IO () -> ConduitT ByteString c IO ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT ByteString c IO ()
forall {o}. ConduitT ByteString o IO ()
toClient
                           | Bool
otherwise                    = ConduitT a ByteString IO ()
forall {i}. ConduitT i ByteString IO ()
fromServer ConduitT a ByteString IO ()
-> ConduitT ByteString c IO () -> ConduitT a c IO ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT ByteString c IO ()
forall {o}. ConduitT ByteString o IO ()
toClient
        in do
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
http1 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ConduitT () Void IO () -> IO ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void IO () -> IO ())
-> ConduitT () Void IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ConduitT () ByteString IO ()
forall {i}. ConduitT i ByteString IO ()
yieldHttp1Response ConduitT () ByteString IO ()
-> ConduitT ByteString Void IO () -> ConduitT () Void IO ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT ByteString Void IO ()
forall {o}. ConduitT ByteString o IO ()
toClient
            -- gracefully close the other stream after 5 seconds if one side of stream is closed.
            IO (Either SomeException ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either SomeException ()) -> IO ())
-> IO (Either SomeException ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO () -> IO () -> IO (Either SomeException ())
runStreams Int
5
                (ConduitT () Void IO () -> IO ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit ConduitT () Void IO ()
forall {a} {c}. ConduitT a c IO ()
clientToServer)
                (ConduitT () Void IO () -> IO ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit ConduitT () Void IO ()
forall {a} {c}. ConduitT a c IO ()
serverToClient)
httpConnectProxy ProxySettings
_ Application
fallback Request
req Response -> IO ResponseReceived
respond = Application
fallback Request
req Response -> IO ResponseReceived
respond