This is the default web page for this server.
" - , "The web server software is running but no content has been added, yet.
" - , "" - ] - -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)) diff --git a/Main.hs b/Main.hs deleted file mode 100644 --- a/Main.hs +++ /dev/null @@ -1,153 +0,0 @@ --- SPDX-License-Identifier: Apache-2.0 --- --- Copyright (C) 2019 Bin Jin. All Rights Reserved. -{-# LANGUAGE OverloadedStrings #-} - -module Main where - -import qualified Data.ByteString.Char8 as BS8 -import Data.String (fromString) -import qualified Network.HTTP.Client as HC -import Network.TLS as TLS -import Network.Wai.Handler.Warp (HostPreference, defaultSettings, - runSettings, setBeforeMainLoop, - setHost, setNoParsePath, setPort, - setServerName) -import Network.Wai.Handler.WarpTLS (OnInsecure (..), onInsecure, - runTLS, tlsServerHooks, - tlsSettings) -import Network.Wai.Middleware.Gzip (def, gzip) -import System.Posix.User (UserEntry (..), - getUserEntryForName, setUserID) - -import Data.Maybe -import Data.Monoid ((<>)) -import Options.Applicative - -import HProx (ProxySettings (..), dumbApp, - forceSSL, httpProxy, reverseProxy) - -data Opts = Opts - { _bind :: Maybe HostPreference - , _port :: Int - , _ssl :: [(String, CertFile)] - , _user :: Maybe String - , _auth :: Maybe FilePath - , _ws :: Maybe String - , _rev :: Maybe String - } - -data CertFile = CertFile - { certfile :: FilePath - , keyfile :: FilePath - } - -readCert :: CertFile -> IO TLS.Credential -readCert (CertFile c k) = either error id <$> TLS.credentialLoadX509 c k - -splitBy :: Eq a => a -> [a] -> [[a]] -splitBy _ [] = [[]] -splitBy c (x:xs) - | c == x = [] : splitBy c xs - | otherwise = let y:ys = splitBy c xs in (x:y):ys - -parser :: ParserInfo Opts -parser = info (helper <*> opts) fullDesc - where - parseSSL s = case splitBy ':' s of - [host, cert, key] -> Right (host, CertFile cert key) - _ -> Left "invalid format for ssl certificates" - - opts = Opts <$> bind - <*> (fromMaybe 3000 <$> port) - <*> ssl - <*> user - <*> auth - <*> ws - <*> rev - - bind = optional $ fromString <$> strOption - ( long "bind" - <> short 'b' - <> metavar "bind_ip" - <> help "The address to bind on (default: all interfaces)") - - port = optional $ option auto - ( long "port" - <> short 'p' - <> metavar "port" - <> help "port number (default 3000)") - - ssl = many $ option (eitherReader parseSSL) - ( long "ssl" - <> short 's' - <> metavar "hostname:cerfile:keyfile" - <> help "enable SSL and specify a SSL certificates") - - user = optional $ strOption - ( long "user" - <> short 'u' - <> metavar "nobody" - <> help "setuid after binding port") - - auth = optional $ strOption - ( long "auth" - <> short 'a' - <> metavar "users.txt" - <> help "password file for proxy authentication (each line with a colon separated user/pass pair)") - - ws = optional $ strOption - ( long "ws" - <> metavar "remote-host:80" - <> help "remote host to handle websocket requests") - - rev = optional $ strOption - ( long "rev" - <> metavar "remote-host:80" - <> help "remote host for revere proxy") - - -setuid :: String -> IO () -setuid user = getUserEntryForName user >>= setUserID . userID - -main :: IO () -main = do - opts <- execParser parser - - let certfiles = _ssl opts - certs <- mapM (readCert.snd) certfiles - - let isSSL = not (null certfiles) - (primaryHost, primaryCert) = head certfiles - otherCerts = tail $ zip (map fst certfiles) certs - - settings = setNoParsePath True $ - setServerName "Apache" $ - maybe id (setBeforeMainLoop . setuid) (_user opts) - defaultSettings - - tlsset' = tlsSettings (certfile primaryCert) (keyfile primaryCert) - hooks = (tlsServerHooks tlsset') { onServerNameIndication = onSNI } - tlsset = tlsset' { tlsServerHooks = hooks, onInsecure = AllowInsecure } - - failSNI = fail "SNI" >> return mempty - onSNI Nothing = failSNI - onSNI (Just host) - | host == primaryHost = return mempty - | otherwise = case lookup host otherCerts of - Nothing -> failSNI - Just cert -> return (TLS.Credentials [cert]) - - runner | isSSL = runTLS tlsset - | otherwise = runSettings - - pauth <- case _auth opts of - Nothing -> return Nothing - Just f -> Just . flip elem . filter (isJust . BS8.elemIndex ':') . BS8.lines <$> BS8.readFile f - manager <- HC.newManager HC.defaultManagerSettings - - let pset = ProxySettings pauth Nothing (BS8.pack <$> _ws opts) (BS8.pack <$> _rev opts) - proxy = (if isSSL then forceSSL else id) $ gzip def $ httpProxy pset manager $ reverseProxy pset manager dumbApp - port = _port opts - - runner (setHost (fromMaybe "*6" (_bind opts)) $ setPort port settings) proxy diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,31 +1,72 @@ ## hprox -hprox is a lightweight HTTP/HTTPS proxy server. +[](https://circleci.com/gh/bjin/hprox) +[](https://packdeps.haskellers.com/feed?needle=hprox) +[](https://github.com/bjin/hprox/releases) +[](https://hackage.haskell.org/package/hprox) +[](https://github.com/bjin/hprox/blob/master/LICENSE) +`hprox` is a lightweight HTTP/HTTPS proxy server. + ### Features -* Basic HTTP proxy support, including HTTP GET/HTTP CONNECT support. +* Basic HTTP proxy functionality. * Simple password authentication. -* HTTPS encryption support, requires a valid certificate. Supports TLS 1.3 and - HTTP 2 out of box. This mode is also known as SPDY Proxy. -* TLS SNI validation in HTTPS mode. Blocks connections with wrong domain name. -* Provide PAC file for easy client side configuration. Supports Chrome and Firefox. -* Can run upon any Haskell Web Application with `wai` interface. Defaults to - a dumb application which simulate the default empty page from Apache. -* websocket redirection. Compatible with v2ray-plugin for shadowsocks. -* Reverse proxy support. Redirect requests to a fallback server. - -Use `hprox --help` to list the options for further details. +* TLS encryption (requires a valid certificate). Supports TLS 1.3 and HTTP 2, also known as SPDY Proxy. +* TLS SNI validation (blocks all clients with invalid domain name). +* Provide PAC file for easy client side configuration (supports Chrome and Firefox). +* Websocket redirection (compatible with [v2ray-plugin for shadowsocks](https://github.com/shadowsocks/v2ray-plugin)). +* Reverse proxy support (redirect requests to a fallback server). +* Implemented as a middleware, compatible with any Haskell Web Application with `wai` interface. + Defaults to fallback to a dumb application which simulate the default empty page from Apache. ### Installation -Only Linux and macOS are supported. [stack](https://docs.haskellstack.org/en/stable/README/#how-to-install) is required to build `hprox`. +`hprox` should build and work on all unix-like OS with `ghc` support, but it's only +been tested on Linux and macOS. +[stack](https://docs.haskellstack.org/en/stable/README/#how-to-install) is required to build `hprox`. + ```sh +stack setup stack install ``` +### Usage + +Use `hprox --help` to list options with detailed explanation. + +* To run `hprox` on port 8080, with simple password authentication: + +```sh +echo "user:pass" > userpass.txt +chmod 600 userpass.txt +hprox -p 8080 -a userpass.txt +``` + +* To run `hprox` with TLS encryption on port 443, with certificate of `example.com` obtained with [certbot](https://certbot.eff.org/): + +```sh +hprox -p 443 -s example.com:/etc/letsencrypt/live/example.com/fullchain.pem:/etc/letsencrypt/live/example.com/privkey.pem +``` + +Browsers can then be configured with PAC file URL `https://example.com/get/hprox.pac`. + +* To work with `v2ray-plugin`, with fallback page to ubuntu mirrors: + +```sh +v2ray-plugin -server -localPort 8080 -mode websocket -host example.com -remotePort xxxx +hprox -p 443 -s example.com:fullchain.pem:privkey.pem --ws 127.0.0.1:8080 --rev archive.ubuntu.com:80 +``` + +Clients will be able to connect with option `tls;host=example.com`. + ### Known Issue -* Only HTTP server are supported for websocket and reverse proxy redirection. -* Passwords are stored in plain text for now, please avoid using existing password. +* Only HTTP servers are supported as websocket and reverse proxy redirection destination. +* Passwords are currently stored in plain text, please set permission accordingly and + avoid using existing password. + +### License + +`hprox` is licensed under the Apache license. See LICENSE file for details. diff --git a/hprox.cabal b/hprox.cabal --- a/hprox.cabal +++ b/hprox.cabal @@ -1,54 +1,62 @@ -name: hprox -version: 0.1.0 -synopsis: a lightweight HTTP proxy server, and more -description: - Please see the README on GitHub atThis is the default web page for this server.
" + , "The web server software is running but no content has been added, yet.
" + , "" + ] + +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)) diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,153 @@ +-- SPDX-License-Identifier: Apache-2.0 +-- +-- Copyright (C) 2019 Bin Jin. All Rights Reserved. +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import qualified Data.ByteString.Char8 as BS8 +import Data.String (fromString) +import qualified Network.HTTP.Client as HC +import Network.TLS as TLS +import Network.Wai.Handler.Warp (HostPreference, defaultSettings, + runSettings, setBeforeMainLoop, + setHost, setNoParsePath, setPort, + setServerName) +import Network.Wai.Handler.WarpTLS (OnInsecure (..), onInsecure, + runTLS, tlsServerHooks, + tlsSettings) +import Network.Wai.Middleware.Gzip (def, gzip) +import System.Posix.User (UserEntry (..), + getUserEntryForName, setUserID) + +import Data.Maybe +import Data.Monoid ((<>)) +import Options.Applicative + +import HProx (ProxySettings (..), dumbApp, + forceSSL, httpProxy, reverseProxy) + +data Opts = Opts + { _bind :: Maybe HostPreference + , _port :: Int + , _ssl :: [(String, CertFile)] + , _user :: Maybe String + , _auth :: Maybe FilePath + , _ws :: Maybe String + , _rev :: Maybe String + } + +data CertFile = CertFile + { certfile :: FilePath + , keyfile :: FilePath + } + +readCert :: CertFile -> IO TLS.Credential +readCert (CertFile c k) = either error id <$> TLS.credentialLoadX509 c k + +splitBy :: Eq a => a -> [a] -> [[a]] +splitBy _ [] = [[]] +splitBy c (x:xs) + | c == x = [] : splitBy c xs + | otherwise = let y:ys = splitBy c xs in (x:y):ys + +parser :: ParserInfo Opts +parser = info (helper <*> opts) fullDesc + where + parseSSL s = case splitBy ':' s of + [host, cert, key] -> Right (host, CertFile cert key) + _ -> Left "invalid format for ssl certificates" + + opts = Opts <$> bind + <*> (fromMaybe 3000 <$> port) + <*> ssl + <*> user + <*> auth + <*> ws + <*> rev + + bind = optional $ fromString <$> strOption + ( long "bind" + <> short 'b' + <> metavar "bind_ip" + <> help "the ip address to bind on (default: all interfaces)") + + port = optional $ option auto + ( long "port" + <> short 'p' + <> metavar "port" + <> help "port number (default 3000)") + + ssl = many $ option (eitherReader parseSSL) + ( long "tls" + <> short 's' + <> metavar "hostname:cerfile:keyfile" + <> help "enable TLS and specify a domain and associated TLS certificate (can be used multiple times for multiple domains)") + + user = optional $ strOption + ( long "user" + <> short 'u' + <> metavar "nobody" + <> help "setuid after binding port") + + auth = optional $ strOption + ( long "auth" + <> short 'a' + <> metavar "userpass.txt" + <> help "password file for proxy authentication (plain text file with lines each containaing a colon separated user/password pair)") + + ws = optional $ strOption + ( long "ws" + <> metavar "remote-host:80" + <> help "remote host to handle websocket requests (http server only)") + + rev = optional $ strOption + ( long "rev" + <> metavar "remote-host:80" + <> help "remote host for revere proxy (http server only)") + + +setuid :: String -> IO () +setuid user = getUserEntryForName user >>= setUserID . userID + +main :: IO () +main = do + opts <- execParser parser + + let certfiles = _ssl opts + certs <- mapM (readCert.snd) certfiles + + let isSSL = not (null certfiles) + (primaryHost, primaryCert) = head certfiles + otherCerts = tail $ zip (map fst certfiles) certs + + settings = setNoParsePath True $ + setServerName "Apache" $ + maybe id (setBeforeMainLoop . setuid) (_user opts) + defaultSettings + + tlsset' = tlsSettings (certfile primaryCert) (keyfile primaryCert) + hooks = (tlsServerHooks tlsset') { onServerNameIndication = onSNI } + tlsset = tlsset' { tlsServerHooks = hooks, onInsecure = AllowInsecure } + + failSNI = fail "SNI" >> return mempty + onSNI Nothing = failSNI + onSNI (Just host) + | host == primaryHost = return mempty + | otherwise = case lookup host otherCerts of + Nothing -> failSNI + Just cert -> return (TLS.Credentials [cert]) + + runner | isSSL = runTLS tlsset + | otherwise = runSettings + + pauth <- case _auth opts of + Nothing -> return Nothing + Just f -> Just . flip elem . filter (isJust . BS8.elemIndex ':') . BS8.lines <$> BS8.readFile f + manager <- HC.newManager HC.defaultManagerSettings + + let pset = ProxySettings pauth Nothing (BS8.pack <$> _ws opts) (BS8.pack <$> _rev opts) + proxy = (if isSSL then forceSSL else id) $ gzip def $ httpProxy pset manager $ reverseProxy pset manager dumbApp + port = _port opts + + runner (setHost (fromMaybe "*6" (_bind opts)) $ setPort port settings) proxy