summaryrefslogtreecommitdiff
path: root/src/HProx.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/HProx.hs')
-rw-r--r--src/HProx.hs287
1 files changed, 287 insertions, 0 deletions
diff --git a/src/HProx.hs b/src/HProx.hs
new file mode 100644
index 0000000..87252ef
--- /dev/null
+++ b/src/HProx.hs
@@ -0,0 +1,287 @@
+-- SPDX-License-Identifier: Apache-2.0
+--
+-- Copyright (C) 2019 Bin Jin. All Rights Reserved.
+{-# LANGUAGE OverloadedStrings #-}
+
+module HProx
+ ( ProxySettings(..)
+ , httpProxy
+ , pacProvider
+ , httpGetProxy
+ , httpConnectProxy
+ , reverseProxy
+ , forceSSL
+ , dumbApp
+ ) where
+
+import Control.Applicative ((<|>))
+import Control.Concurrent.Async (concurrently)
+import Control.Exception (SomeException, try)
+import Control.Monad (unless, void, when)
+import Control.Monad.IO.Class (liftIO)
+import qualified Data.Binary.Builder as BB
+import qualified Data.ByteString as BS
+import Data.ByteString.Base64 (decodeLenient)
+import qualified Data.ByteString.Char8 as BS8
+import qualified Data.ByteString.Lazy.Char8 as LBS8
+import qualified Data.CaseInsensitive as CI
+import qualified Data.Conduit.Network as CN
+import Data.Maybe (fromJust, fromMaybe, isJust,
+ isNothing)
+import qualified Network.HTTP.Client as HC
+import Network.HTTP.ReverseProxy (ProxyDest (..), SetIpHeader (..),
+ WaiProxyResponse (..),
+ defaultWaiProxySettings,
+ waiProxyToSettings, wpsSetIpHeader,
+ wpsUpgradeToRaw)
+import qualified Network.HTTP.Types as HT
+import qualified Network.HTTP.Types.Header as HT
+import Network.Wai.Internal (getRequestBodyChunk)
+
+import Data.Conduit
+import Network.Wai
+
+data ProxySettings = ProxySettings
+ { proxyAuth :: Maybe (BS.ByteString -> Bool)
+ , passPrompt :: Maybe BS.ByteString
+ , wsRemote :: Maybe BS.ByteString
+ , revRemote :: Maybe BS.ByteString
+ }
+
+dumbApp :: Application
+dumbApp _req respond =
+ respond $ responseLBS
+ HT.status200
+ [("Content-Type", "text/html")] $
+ LBS8.unlines [ "<html><body><h1>It works!</h1>"
+ , "<p>This is the default web page for this server.</p>"
+ , "<p>The web server software is running but no content has been added, yet.</p>"
+ , "</body></html>"
+ ]
+
+httpProxy :: ProxySettings -> HC.Manager -> Middleware
+httpProxy set mgr = pacProvider . httpGetProxy set mgr . httpConnectProxy set
+
+forceSSL :: Middleware
+forceSSL app req respond
+ | isSecure req = app req respond
+ | otherwise = redirectToSSL req respond
+
+redirectToSSL :: Application
+redirectToSSL req respond
+ | Just host <- requestHeaderHost req = respond $ responseLBS
+ HT.status301
+ [("Location", "https://" `BS.append` host)]
+ ""
+ | otherwise = respond $ responseLBS
+ (HT.mkStatus 426 "Upgrade Required")
+ [("Upgrade", "TLS/1.0, HTTP/1.1"), ("Connection", "Upgrade")]
+ ""
+
+parseHostPort :: BS.ByteString -> Maybe (BS.ByteString, Int)
+parseHostPort hostPort = do
+ lastColon <- BS8.elemIndexEnd ':' hostPort
+ port <- BS8.readInt (BS.drop (lastColon+1) hostPort) >>= checkPort
+ return (BS.take lastColon hostPort, port)
+ where
+ checkPort (p, bs)
+ | BS.null bs && 1 <= p && p <= 65535 = Just p
+ | otherwise = Nothing
+
+parseHostPortWithDefault :: Int -> BS.ByteString -> (BS.ByteString, Int)
+parseHostPortWithDefault defaultPort hostPort =
+ fromMaybe (hostPort, defaultPort) $ parseHostPort hostPort
+
+isProxyHeader :: HT.HeaderName -> Bool
+isProxyHeader k
+ | BS.length bs <= 4 = False
+ | c0 /= 112 && c0 /= 80 = False -- 'p'
+ | c1 /= 114 && c1 /= 82 = False -- 'r'
+ | c2 /= 111 && c2 /= 79 = False -- 'o'
+ | c3 /= 120 && c3 /= 88 = False -- 'x'
+ | c4 /= 121 && c4 /= 89 = False -- 'y'
+ | otherwise = True
+ where
+ bs = CI.original k
+ idx = BS.index bs
+
+ c0 = idx 0
+ c1 = idx 1
+ c2 = idx 2
+ c3 = idx 3
+ c4 = idx 4
+
+isForwardedHeader :: HT.HeaderName -> Bool
+isForwardedHeader k
+ | BS.length bs <= 10 = False
+ | c0 /= 120 && c0 /= 88 = False -- 'x'
+ | c1 /= 45 = False -- '-'
+ | c2 /= 102 && c2 /= 70 = False -- 'f'
+ | c3 /= 111 && c3 /= 79 = False -- 'o'
+ | c4 /= 114 && c4 /= 82 = False -- 'r'
+ | c5 /= 119 && c5 /= 87 = False -- 'w'
+ | c6 /= 97 && c6 /= 65 = False -- 'a'
+ | c7 /= 114 && c7 /= 82 = False -- 'r'
+ | c8 /= 100 && c8 /= 68 = False -- 'd'
+ | c9 /= 101 && c9 /= 69 = False -- 'e'
+ | ca /= 100 && ca /= 68 = False -- 'd'
+ | otherwise = True
+ where
+ bs = CI.original k
+ idx = BS.index bs
+
+ c0 = idx 0
+ c1 = idx 1
+ c2 = idx 2
+ c3 = idx 3
+ c4 = idx 4
+ c5 = idx 5
+ c6 = idx 6
+ c7 = idx 7
+ c8 = idx 8
+ c9 = idx 9
+ ca = idx 10
+
+isToStripHeader :: HT.HeaderName -> Bool
+isToStripHeader h = isProxyHeader h || isForwardedHeader h || h == "X-Real-IP" || h == "X-Scheme"
+
+checkAuth :: ProxySettings -> Request -> Bool
+checkAuth pset req
+ | isNothing pauth = True
+ | isNothing authRsp = False
+ | otherwise = fromJust pauth decodedRsp
+ where
+ pauth = proxyAuth pset
+ authRsp = lookup HT.hProxyAuthorization (requestHeaders req)
+
+ decodedRsp = decodeLenient $ snd $ BS8.spanEnd (/=' ') $ fromJust authRsp
+
+proxyAuthRequiredResponse :: ProxySettings -> Response
+proxyAuthRequiredResponse pset = responseLBS
+ HT.status407
+ [(HT.hProxyAuthenticate, "Basic realm=\"" `BS.append` prompt `BS.append` "\"")]
+ ""
+ where
+ prompt = fromMaybe "hprox" (passPrompt pset)
+
+pacProvider :: Middleware
+pacProvider fallback req respond
+ | pathInfo req == ["get", "hprox.pac"],
+ Just host' <- lookup "x-forwarded-host" (requestHeaders req) <|> requestHeaderHost req =
+ let issecure = case lookup "x-forwarded-proto" (requestHeaders req) of
+ Just proto -> proto == "https"
+ Nothing -> isSecure req
+ scheme = if issecure then "HTTPS" else "PROXY"
+ defaultPort = if issecure then ":443" else ":80"
+ host | 58 `BS.elem` host' = host' -- ':'
+ | otherwise = host' `BS.append` defaultPort
+ in respond $ responseLBS
+ HT.status200
+ [("Content-Type", "application/x-ns-proxy-autoconfig")] $
+ LBS8.unlines [ "function FindProxyForURL(url, host) {"
+ , LBS8.fromChunks [" return \"", scheme, " ", host, "\";"]
+ , "}"
+ ]
+ | otherwise = fallback req respond
+
+reverseProxy :: ProxySettings -> HC.Manager -> Middleware
+reverseProxy pset mgr fallback
+ | isReverseProxy = waiProxyToSettings (return.proxyResponseFor) settings mgr
+ | otherwise = fallback
+ where
+ settings = defaultWaiProxySettings { wpsSetIpHeader = SIHNone }
+
+ isReverseProxy = isJust (revRemote pset)
+ (revHost, revPort) = parseHostPortWithDefault 80 (fromJust (revRemote pset))
+
+ proxyResponseFor req = WPRModifiedRequest nreq (ProxyDest revHost revPort)
+ where
+ nreq = req
+ { requestHeaders = hdrs
+ , requestHeaderHost = Just revHost
+ }
+
+ hdrs = (HT.hHost, revHost) : [ (hdn, hdv)
+ | (hdn, hdv) <- requestHeaders req
+ , not (isToStripHeader hdn) && hdn /= HT.hHost
+ ]
+
+httpGetProxy :: ProxySettings -> HC.Manager -> Middleware
+httpGetProxy pset mgr fallback = waiProxyToSettings (return.proxyResponseFor) settings mgr
+ where
+ settings = defaultWaiProxySettings { wpsSetIpHeader = SIHNone }
+
+ proxyResponseFor req
+ | redirectWebsocket = WPRProxyDest (ProxyDest wsHost wsPort)
+ | not isGetProxy = WPRApplication fallback
+ | checkAuth pset req = WPRModifiedRequest nreq (ProxyDest host port)
+ | otherwise = WPRResponse (proxyAuthRequiredResponse pset)
+ where
+ isWebsocket = wpsUpgradeToRaw defaultWaiProxySettings req
+ redirectWebsocket = isWebsocket && isJust (wsRemote pset)
+ (wsHost, wsPort) = parseHostPortWithDefault 80 (fromJust (wsRemote pset))
+
+ notCONNECT = requestMethod req /= "CONNECT"
+ rawPath = rawPathInfo req
+ rawPathPrefix = "http://"
+ defaultPort = 80
+ hostHeader = parseHostPortWithDefault defaultPort <$> requestHeaderHost req
+
+ isRawPathProxy = rawPathPrefix `BS.isPrefixOf` rawPath
+ hasProxyHeader = any (isProxyHeader.fst) (requestHeaders req)
+ scheme = lookup "X-Scheme" (requestHeaders req)
+ isHTTP2Proxy = HT.httpMajor (httpVersion req) >= 2 && scheme == Just "http" && isSecure req
+
+ isGetProxy = notCONNECT && (isRawPathProxy || isHTTP2Proxy || isJust hostHeader && hasProxyHeader)
+
+ nreq = req
+ { rawPathInfo = newRawPath
+ , requestHeaders = filter (not.isToStripHeader.fst) $ requestHeaders req
+ }
+
+ ((host, port), newRawPath)
+ | isRawPathProxy = (parseHostPortWithDefault defaultPort hostPortP, newRawPathP)
+ | otherwise = (fromJust hostHeader, rawPath)
+ where
+ (hostPortP, newRawPathP) = BS8.span (/='/') $
+ BS.drop (BS.length rawPathPrefix) rawPath
+
+httpConnectProxy :: ProxySettings -> Middleware
+httpConnectProxy pset fallback req respond
+ | not isConnectProxy = fallback req respond
+ | checkAuth pset req = respond response
+ | otherwise = respond (proxyAuthRequiredResponse pset)
+ where
+ hostPort' = parseHostPort (rawPathInfo req) <|> (requestHeaderHost req >>= parseHostPort)
+ isConnectProxy = requestMethod req == "CONNECT" && isJust hostPort'
+
+ Just (host, port) = hostPort'
+ settings = CN.clientSettings port host
+
+ backup = responseLBS HT.status500 [("Content-Type", "text/plain")]
+ "HTTP CONNECT tunneling detected, but server does not support responseRaw"
+
+ tryAndCatchAll :: IO a -> IO (Either SomeException a)
+ tryAndCatchAll = try
+
+ response
+ | HT.httpMajor (httpVersion req) < 2 = responseRaw (handleConnect True) backup
+ | otherwise = responseStream HT.status200 [] streaming
+ where
+ streaming write flush = do
+ flush
+ handleConnect False (getRequestBodyChunk req) (\bs -> write (BB.fromByteString bs) >> flush)
+
+ handleConnect :: Bool -> IO BS.ByteString -> (BS.ByteString -> IO ()) -> IO ()
+ handleConnect http1 fromClient' toClient' = CN.runTCPClient settings $ \server ->
+ let toServer = CN.appSink server
+ fromServer = CN.appSource server
+ fromClient = do
+ bs <- liftIO fromClient'
+ unless (BS.null bs) (yield bs >> fromClient)
+ toClient = awaitForever (liftIO . toClient')
+ in do
+ when http1 $ runConduit $ yield "HTTP/1.1 200 OK\r\n\r\n" .| toClient
+ void $ tryAndCatchAll $ concurrently
+ (runConduit (fromClient .| toServer))
+ (runConduit (fromServer .| toClient))