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

module Network.HProx.Impl
  ( ProxySettings (..)
  , 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              (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 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 -> Logger
logger        :: Logger
  }

logRequest :: Request -> LogStr
logRequest :: Request -> LogStr
logRequest Request
req = forall msg. ToLogStr msg => msg -> LogStr
toLogStr (Request -> ByteString
requestMethod Request
req) forall a. Semigroup a => a -> a -> a
<>
    LogStr
" " forall a. Semigroup a => a -> a -> a
<> LogStr
hostname forall a. Semigroup a => a -> a -> a
<> forall msg. ToLogStr msg => msg -> LogStr
toLogStr (Request -> ByteString
rawPathInfo Request
req) forall a. Semigroup a => a -> a -> a
<>
    LogStr
" " forall a. Semigroup a => a -> a -> a
<> forall msg. ToLogStr msg => msg -> LogStr
toLogStr (forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Request -> HttpVersion
httpVersion Request
req) forall a. Semigroup a => a -> a -> a
<>
    LogStr
" " forall a. Semigroup a => a -> a -> a
<> (if Request -> Bool
isSecure Request
req then LogStr
"(tls) " else LogStr
"")
    forall a. Semigroup a => a -> a -> a
<> forall msg. ToLogStr msg => msg -> LogStr
toLogStr (forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Request -> SockAddr
remoteHost Request
req)
  where
    isConnect :: Bool
isConnect = Request -> ByteString
requestMethod Request
req 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          = forall msg. ToLogStr msg => msg -> LogStr
toLogStr (forall a. a -> Maybe a -> a
fromMaybe ByteString
"(no-host)" 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProxySettings -> Manager -> Middleware
httpGetProxy ProxySettings
set Manager
mgr 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 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 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` 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` 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` forall s. CI s -> s
CI.foldedCase HeaderName
h Bool -> Bool -> Bool
|| HeaderName
h 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 forall a. Eq a => a -> a -> Bool
== HeaderName
"X-Real-IP" Bool -> Bool -> Bool
|| HeaderName
h 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
logger :: Logger
naivePadding :: Bool
hideProxyAuth :: Bool
revRemoteMap :: [(Maybe ByteString, ByteString, ByteString)]
wsRemote :: Maybe ByteString
passPrompt :: Maybe ByteString
proxyAuth :: Maybe (ByteString -> Bool)
logger :: ProxySettings -> Logger
naivePadding :: ProxySettings -> Bool
hideProxyAuth :: ProxySettings -> Bool
revRemoteMap :: ProxySettings -> [(Maybe ByteString, ByteString, ByteString)]
wsRemote :: ProxySettings -> Maybe ByteString
passPrompt :: ProxySettings -> Maybe ByteString
proxyAuth :: ProxySettings -> Maybe (ByteString -> Bool)
..} Request
req
    | forall a. Maybe a -> Bool
isNothing Maybe (ByteString -> Bool)
proxyAuth = Bool
True
    | forall a. Maybe a -> Bool
isNothing Maybe ByteString
authRsp   = Bool
False
    | Bool
otherwise           =
        forall a. Logger -> LogLevel -> LogStr -> a -> a
pureLogger Logger
logger LogLevel
TRACE (LogStr
authMsg forall a. Semigroup a => a -> a -> a
<> LogStr
" request (credential: " forall a. Semigroup a => a -> a -> a
<> forall msg. ToLogStr msg => msg -> LogStr
toLogStr ByteString
decodedRsp forall a. Semigroup a => a -> a -> a
<> LogStr
") from " forall a. Semigroup a => a -> a -> a
<> forall msg. ToLogStr msg => msg -> LogStr
toLogStr (forall a. Show a => a -> String
show (Request -> SockAddr
remoteHost Request
req))) Bool
authorized
  where
    authRsp :: Maybe ByteString
authRsp = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
HT.hProxyAuthorization (Request -> ResponseHeaders
requestHeaders Request
req)
    decodedRsp :: ByteString
decodedRsp = ByteString -> ByteString
decodeLenient forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> (ByteString, ByteString)
BS8.spanEnd (forall a. Eq a => a -> a -> Bool
/=Char
' ') forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => Maybe a -> a
fromJust Maybe ByteString
authRsp

    authorized :: Bool
authorized = forall a. HasCallStack => Maybe a -> a
fromJust Maybe (ByteString -> Bool)
proxyAuth ByteString
decodedRsp
    authMsg :: LogStr
authMsg = if Bool
authorized then LogStr
"authorized" else LogStr
"unauthorized"

redirectWebsocket :: ProxySettings -> Request -> Bool
redirectWebsocket :: ProxySettings -> Request -> Bool
redirectWebsocket ProxySettings{Bool
[(Maybe ByteString, ByteString, ByteString)]
Maybe ByteString
Maybe (ByteString -> Bool)
Logger
logger :: Logger
naivePadding :: Bool
hideProxyAuth :: Bool
revRemoteMap :: [(Maybe ByteString, ByteString, ByteString)]
wsRemote :: Maybe ByteString
passPrompt :: Maybe ByteString
proxyAuth :: Maybe (ByteString -> Bool)
logger :: ProxySettings -> Logger
naivePadding :: ProxySettings -> Bool
hideProxyAuth :: ProxySettings -> Bool
revRemoteMap :: ProxySettings -> [(Maybe ByteString, ByteString, ByteString)]
wsRemote :: ProxySettings -> Maybe ByteString
passPrompt :: ProxySettings -> Maybe ByteString
proxyAuth :: ProxySettings -> Maybe (ByteString -> Bool)
..} Request
req = WaiProxySettings -> Request -> Bool
wpsUpgradeToRaw WaiProxySettings
defaultWaiProxySettings Request
req Bool -> Bool -> 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
logger :: Logger
naivePadding :: Bool
hideProxyAuth :: Bool
revRemoteMap :: [(Maybe ByteString, ByteString, ByteString)]
wsRemote :: Maybe ByteString
passPrompt :: Maybe ByteString
proxyAuth :: Maybe (ByteString -> Bool)
logger :: ProxySettings -> Logger
naivePadding :: ProxySettings -> Bool
hideProxyAuth :: ProxySettings -> Bool
revRemoteMap :: ProxySettings -> [(Maybe ByteString, ByteString, ByteString)]
wsRemote :: ProxySettings -> Maybe ByteString
passPrompt :: ProxySettings -> Maybe ByteString
proxyAuth :: ProxySettings -> Maybe (ByteString -> Bool)
..} = 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 = forall a. a -> Maybe a -> a
fromMaybe ByteString
"hprox" Maybe ByteString
passPrompt

pacProvider :: Middleware
pacProvider :: Middleware
pacProvider Application
fallback Request
req Response -> IO ResponseReceived
respond
    | Request -> [Text]
pathInfo Request
req forall a. Eq a => a -> a -> Bool
== [Text
".hprox", Text
"config.pac"],
      Just ByteString
host' <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"x-forwarded-host" (Request -> ResponseHeaders
requestHeaders Request
req) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Request -> Maybe ByteString
requestHeaderHost Request
req =
        let issecure :: Bool
issecure = case 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 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 forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseKnownLength
               Status
HT.status200
               [(HeaderName
"Content-Type", ByteString
"application/x-ns-proxy-autoconfig")] 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 forall a. Eq a => a -> a -> Bool
== [Text
".hprox", Text
"health"] =
        Response -> IO ResponseReceived
respond 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
logger :: Logger
naivePadding :: Bool
hideProxyAuth :: Bool
revRemoteMap :: [(Maybe ByteString, ByteString, ByteString)]
wsRemote :: Maybe ByteString
passPrompt :: Maybe ByteString
proxyAuth :: Maybe (ByteString -> Bool)
logger :: ProxySettings -> Logger
naivePadding :: ProxySettings -> Bool
hideProxyAuth :: ProxySettings -> Bool
revRemoteMap :: ProxySettings -> [(Maybe ByteString, ByteString, ByteString)]
wsRemote :: ProxySettings -> Maybe ByteString
passPrompt :: ProxySettings -> Maybe ByteString
proxyAuth :: ProxySettings -> Maybe (ByteString -> Bool)
..} Manager
mgr Application
fallback =
    (Response -> Response) -> Middleware
modifyResponse ([ByteString] -> Response -> Response
stripHeaders [ByteString
"Server", ByteString
"Date", ByteString
"Keep-Alive"]) forall a b. (a -> b) -> a -> b
$
        (Request -> IO WaiProxyResponse)
-> WaiProxySettings -> Manager -> Application
waiProxyToSettings (forall (m :: * -> *) a. Monad m => a -> m a
returnforall b c a. (b -> c) -> (a -> b) -> a -> c
.Request -> WaiProxyResponse
proxyResponseFor) WaiProxySettings
settings Manager
mgr
  where
    settings :: WaiProxySettings
settings = WaiProxySettings
defaultWaiProxySettings { wpsSetIpHeader :: SetIpHeader
wpsSetIpHeader = SetIpHeader
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 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)
          | 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 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> (ByteString, Int)
parseHostPortWithDefault (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 :: ResponseHeaders
requestHeaders = ResponseHeaders
hdrs
              , requestHeaderHost :: Maybe ByteString
requestHeaderHost = forall a. a -> Maybe a
Just ByteString
revHost
              , rawPathInfo :: ByteString
rawPathInfo = Int -> ByteString -> ByteString
BS.drop (ByteString -> Int
BS.length ByteString
prefix forall a. Num a => a -> a -> a
- Int
1) (Request -> ByteString
rawPathInfo Request
req)
              }
            hdrs :: ResponseHeaders
hdrs = (HeaderName
HT.hHost, ByteString
revHost) 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 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
logger :: Logger
naivePadding :: Bool
hideProxyAuth :: Bool
revRemoteMap :: [(Maybe ByteString, ByteString, ByteString)]
wsRemote :: Maybe ByteString
passPrompt :: Maybe ByteString
proxyAuth :: Maybe (ByteString -> Bool)
logger :: ProxySettings -> Logger
naivePadding :: ProxySettings -> Bool
hideProxyAuth :: ProxySettings -> Bool
revRemoteMap :: ProxySettings -> [(Maybe ByteString, ByteString, ByteString)]
wsRemote :: ProxySettings -> Maybe ByteString
passPrompt :: ProxySettings -> Maybe ByteString
proxyAuth :: ProxySettings -> Maybe (ByteString -> Bool)
..} Manager
mgr Application
fallback = (Request -> IO WaiProxyResponse)
-> WaiProxySettings -> Manager -> Application
waiProxyToSettings (forall (m :: * -> *) a. Monad m => a -> m a
returnforall b c a. (b -> c) -> (a -> b) -> a -> c
.Request -> WaiProxyResponse
proxyResponseFor) WaiProxySettings
settings Manager
mgr
  where
    settings :: WaiProxySettings
settings = WaiProxySettings
defaultWaiProxySettings { wpsSetIpHeader :: SetIpHeader
wpsSetIpHeader = SetIpHeader
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              =
            forall a. Logger -> LogLevel -> LogStr -> a -> a
pureLogger Logger
logger LogLevel
WARN (LogStr
"unauthorized request (hidden without response): " forall a. Semigroup a => a -> a -> a
<> Request -> LogStr
logRequest Request
req) forall a b. (a -> b) -> a -> b
$
            Application -> WaiProxyResponse
WPRApplication Application
fallback
        | Bool
otherwise                  =
            forall a. Logger -> LogLevel -> LogStr -> a -> a
pureLogger Logger
logger LogLevel
WARN (LogStr
"unauthorized request: " forall a. Semigroup a => a -> a -> a
<> Request -> LogStr
logRequest Request
req) 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 (forall a. HasCallStack => Maybe a -> a
fromJust Maybe ByteString
wsRemote)
        wsWrapper :: ProxyDest -> WaiProxyResponse
wsWrapper = if Int
wsPort 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 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 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 = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (HeaderName -> Bool
isProxyHeaderforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a b. (a, b) -> a
fst) (Request -> ResponseHeaders
requestHeaders Request
req)
        scheme :: Maybe ByteString
scheme = 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) forall a. Ord a => a -> a -> Bool
>= Int
2 Bool -> Bool -> Bool
&& Maybe ByteString
scheme forall a. Eq a => a -> a -> Bool
== 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
|| forall a. Maybe a -> Bool
isJust Maybe (ByteString, Int)
hostHeader Bool -> Bool -> Bool
&& Bool
hasProxyHeader)

        nreq :: Request
nreq = Request
req
          { rawPathInfo :: ByteString
rawPathInfo = ByteString
newRawPath
          , requestHeaders :: ResponseHeaders
requestHeaders = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
notforall b c a. (b -> c) -> (a -> b) -> a -> c
.HeaderName -> Bool
isToStripHeaderforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ Request -> ResponseHeaders
requestHeaders Request
req
          }

        ((ByteString
host, Int
port), ByteString
newRawPath)
            | Bool
isRawPathProxy  = (Int -> ByteString -> (ByteString, Int)
parseHostPortWithDefault Int
defaultPort ByteString
hostPortP, ByteString
newRawPathP)
            | Bool
otherwise       = (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 (forall a. Eq a => a -> a -> Bool
/=Char
'/') 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
logger :: Logger
naivePadding :: Bool
hideProxyAuth :: Bool
revRemoteMap :: [(Maybe ByteString, ByteString, ByteString)]
wsRemote :: Maybe ByteString
passPrompt :: Maybe ByteString
proxyAuth :: Maybe (ByteString -> Bool)
logger :: ProxySettings -> Logger
naivePadding :: ProxySettings -> Bool
hideProxyAuth :: ProxySettings -> Bool
revRemoteMap :: ProxySettings -> [(Maybe ByteString, ByteString, ByteString)]
wsRemote :: ProxySettings -> Maybe ByteString
passPrompt :: ProxySettings -> Maybe ByteString
proxyAuth :: ProxySettings -> Maybe (ByteString -> Bool)
..} Application
fallback Request
req Response -> IO ResponseReceived
respond
    | Bool -> Bool
not Bool
isConnectProxy = Application
fallback Request
req Response -> IO ResponseReceived
respond
    | ProxySettings -> Request -> Bool
checkAuth ProxySettings
pset Request
req = do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust Maybe PaddingType
mPaddingType) forall a b. (a -> b) -> a -> b
$ Logger
logger LogLevel
DEBUG forall a b. (a -> b) -> a -> b
$ LogStr
"naiveproxy padding type detected: " forall a. Semigroup a => a -> a -> a
<> forall msg. ToLogStr msg => msg -> LogStr
toLogStr (forall a. Show a => a -> String
show (forall a. HasCallStack => Maybe a -> a
fromJust Maybe PaddingType
mPaddingType)) forall a. Semigroup a => a -> a -> a
<> LogStr
" for " forall a. Semigroup a => a -> a -> a
<> Request -> LogStr
logRequest Request
req
        IO ResponseReceived
respondResponse
    | Bool
hideProxyAuth      = do
        Logger
logger LogLevel
WARN forall a b. (a -> b) -> a -> b
$ LogStr
"unauthorized request (hidden without response): " 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 forall a b. (a -> b) -> a -> b
$ LogStr
"unauthorized request: " forall a. Semigroup a => a -> a -> a
<> Request -> LogStr
logRequest Request
req
        Response -> IO ResponseReceived
respond (ProxySettings -> Response
proxyAuthRequiredResponse ProxySettings
pset)
  where
    hostPort' :: Maybe (ByteString, Int)
hostPort' = ByteString -> Maybe (ByteString, Int)
parseHostPort (Request -> ByteString
rawPathInfo Request
req) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Request -> Maybe ByteString
requestHeaderHost Request
req forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Maybe (ByteString, Int)
parseHostPort)
    isConnectProxy :: Bool
isConnectProxy = Request -> ByteString
requestMethod Request
req forall a. Eq a => a -> a -> Bool
== ByteString
"CONNECT" Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isJust Maybe (ByteString, Int)
hostPort'

    Just (ByteString
host, Int
port) = Maybe (ByteString, Int)
hostPort'
    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 = 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 = forall a. IO a -> IO (Either SomeException a)
tryAndCatchAll forall a b. (a -> b) -> a -> b
$
        forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync IO ()
left forall a b. (a -> b) -> a -> b
$ \Async ()
l -> do
            forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync IO ()
right forall a b. (a -> b) -> a -> b
$ \Async ()
r -> do
                Either () ()
res1 <- 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
                        Either () ()
_      -> Async ()
l
                Maybe ()
res2 <- forall a. Int -> IO a -> IO (Maybe a)
timeout (Int
secs forall a. Num a => a -> a -> a
* Int
1000000) (forall a. Async a -> IO a
wait Async ()
unfinished)
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isNothing Maybe ()
res2) forall a b. (a -> b) -> a -> b
$ forall a. Async a -> IO ()
cancel Async ()
unfinished

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

    respondResponse :: IO ResponseReceived
respondResponse
        | HttpVersion -> Int
HT.httpMajor (Request -> HttpVersion
httpVersion Request
req) forall a. Ord a => a -> a -> Bool
< Int
2 = Response -> IO ResponseReceived
respond 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Maybe PaddingType -> IO ResponseHeaders
prepareResponseForPadding Maybe PaddingType
mPaddingType
            Response -> IO ResponseReceived
respond forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> StreamingBody -> Response
responseStream Status
HT.status200 ResponseHeaders
paddingHeaders 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) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
flush)

    yieldHttp1Response :: ConduitT i ByteString IO ()
yieldHttp1Response = do
        ResponseHeaders
paddingHeaders <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Maybe PaddingType -> IO ResponseHeaders
prepareResponseForPadding Maybe PaddingType
mPaddingType
        let headers :: [Builder]
headers = [ ByteString -> Builder
BB.fromByteString (forall s. CI s -> s
CI.original HeaderName
hn) forall a. Semigroup a => a -> a -> a
<> Builder
": " forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
BB.fromByteString ByteString
hv forall a. Semigroup a => a -> a -> a
<> Builder
"\r\n"
                      | (HeaderName
hn, ByteString
hv) <- ResponseHeaders
paddingHeaders
                      ]
        forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.toStrict forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
BB.toLazyByteString (Builder
"HTTP/1.1 200 OK\r\n" forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat [Builder]
headers 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' = forall a. ClientSettings -> (AppData -> IO a) -> IO a
CN.runTCPClient ClientSettings
settings forall a b. (a -> b) -> a -> b
$ \AppData
server ->
        let toServer :: ConduitT ByteString o IO ()
toServer = forall ad (m :: * -> *) o.
(HasReadWrite ad, MonadIO m) =>
ad -> ConduitT ByteString o m ()
CN.appSink AppData
server
            fromServer :: ConduitT i ByteString IO ()
fromServer = 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ByteString
fromClient'
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
BS.null ByteString
bs) (forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield ByteString
bs forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ConduitT i ByteString IO ()
fromClient)
            toClient :: ConduitT ByteString o IO ()
toClient = forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 = forall {i}. ConduitT i ByteString IO ()
fromClient forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| PaddingType -> PaddingConduit
removePaddingConduit PaddingType
padding forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall {o}. ConduitT ByteString o IO ()
toServer
                           | Bool
otherwise                    = forall {i}. ConduitT i ByteString IO ()
fromClient forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall {o}. ConduitT ByteString o IO ()
toServer

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