This is the default web page for this server.
" + , "The web server software is running but no content has been added, yet.
" + , "" + ] + +main :: IO () +main = getConfig >>= run dumbApp diff --git a/hprox.cabal b/hprox.cabal --- a/hprox.cabal +++ b/hprox.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: hprox -version: 0.2.1 +version: 0.3.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 :: ProxySettings -> Middleware -forceSSL pset app req respond - | isSecure req = app req respond - | redirectWebsocket pset 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")] - "" - - -isProxyHeader :: HT.HeaderName -> Bool -isProxyHeader k = "proxy" `BS.isPrefixOf` CI.foldedCase k - -isForwardedHeader :: HT.HeaderName -> Bool -isForwardedHeader k = "x-forwarded" `BS.isPrefixOf` CI.foldedCase k - -isToStripHeader :: HT.HeaderName -> Bool -isToStripHeader h = isProxyHeader h || isForwardedHeader h || h == "X-Real-IP" || h == "X-Scheme" - -checkAuth :: ProxySettings -> Request -> Bool -checkAuth ProxySettings{..} req - | isNothing proxyAuth = True - | isNothing authRsp = False - | otherwise = fromJust proxyAuth decodedRsp - where - authRsp = lookup HT.hProxyAuthorization (requestHeaders req) - - decodedRsp = decodeLenient $ snd $ BS8.spanEnd (/=' ') $ fromJust authRsp - -redirectWebsocket :: ProxySettings -> Request -> Bool -redirectWebsocket ProxySettings{..} req = wpsUpgradeToRaw defaultWaiProxySettings req && isJust wsRemote - -proxyAuthRequiredResponse :: ProxySettings -> Response -proxyAuthRequiredResponse ProxySettings{..} = responseLBS - HT.status407 - [(HT.hProxyAuthenticate, "Basic realm=\"" `BS.append` prompt `BS.append` "\"")] - "" - where - prompt = fromMaybe "hprox" passPrompt - -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 ProxySettings{..} mgr fallback - | isReverseProxy = waiProxyToSettings (return.proxyResponseFor) settings mgr - | otherwise = fallback - where - settings = defaultWaiProxySettings { wpsSetIpHeader = SIHNone } - - isReverseProxy = isJust revRemote - (revHost, revPort) = parseHostPortWithDefault 80 (fromJust revRemote) - revWrapper = if revPort == 443 then WPRModifiedRequestSecure else WPRModifiedRequest - - proxyResponseFor req = revWrapper 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@ProxySettings{..} mgr fallback = waiProxyToSettings (return.proxyResponseFor) settings mgr - where - settings = defaultWaiProxySettings { wpsSetIpHeader = SIHNone } - - proxyResponseFor req - | redirectWebsocket pset req = wsWrapper (ProxyDest wsHost wsPort) - | not isGetProxy = WPRApplication fallback - | checkAuth pset req = WPRModifiedRequest nreq (ProxyDest host port) - | otherwise = WPRResponse (proxyAuthRequiredResponse pset) - where - (wsHost, wsPort) = parseHostPortWithDefault 80 (fromJust wsRemote) - wsWrapper = if wsPort == 443 then WPRProxyDestSecure else WPRProxyDest - - 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 deleted file mode 100644 --- a/src/Main.hs +++ /dev/null @@ -1,178 +0,0 @@ --- SPDX-License-Identifier: Apache-2.0 --- --- Copyright (C) 2023 Bin Jin. All Rights Reserved. -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -module Main where - -import qualified Data.ByteString.Char8 as BS8 -import Data.List (isSuffixOf) -import Data.String (fromString) -import Network.HTTP.Client.TLS (newTlsManager) -import Network.TLS as TLS -import Network.Wai.Handler.Warp (HostPreference, defaultSettings, - runSettings, setBeforeMainLoop, - setHost, setNoParsePath, - setOnException, 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.Version (showVersion) -import Options.Applicative - -import DoH -import HProx (ProxySettings (..), dumbApp, - forceSSL, httpProxy, reverseProxy) -import Paths_hprox (version) - -data Opts = Opts - { _bind :: Maybe HostPreference - , _port :: Int - , _ssl :: [(String, CertFile)] - , _user :: Maybe String - , _auth :: Maybe FilePath - , _ws :: Maybe String - , _rev :: Maybe String - , _doh :: 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 <*> ver <*> opts) (fullDesc <> progDesc desc) - where - parseSSL s = case splitBy ':' s of - [host, cert, key] -> Right (host, CertFile cert key) - _ -> Left "invalid format for ssl certificates" - - desc = "a lightweight HTTP proxy server, and more" - ver = infoOption (showVersion version) (long "version" <> help "show version") - - opts = Opts <$> bind - <*> (fromMaybe 3000 <$> port) - <*> ssl - <*> user - <*> auth - <*> ws - <*> rev - <*> doh - - bind = optional $ fromString <$> strOption - ( long "bind" - <> short 'b' - <> metavar "bind_ip" - <> help "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 specified 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 containing a colon separated user/password pair)") - - ws = optional $ strOption - ( long "ws" - <> metavar "remote-host:port" - <> help "remote host to handle websocket requests (port 443 indicates HTTPS remote server)") - - rev = optional $ strOption - ( long "rev" - <> metavar "remote-host:port" - <> help "remote host for reverse proxy (port 443 indicates HTTPS remote server)") - - doh = optional $ strOption - ( long "doh" - <> metavar "dns-server:port" - <> help "enable DNS-over-HTTPS(DoH) support (53 will be used if port is not specified)") - - -setuid :: String -> IO () -setuid user = getUserEntryForName user >>= setUserID . userID - -main :: IO () -main = do - Opts{..} <- execParser parser - - let certfiles = _ssl - certs <- mapM (readCert.snd) certfiles - - let isSSL = not (null certfiles) - (primaryHost, primaryCert) = head certfiles - otherCerts = tail $ zip (map fst certfiles) certs - - settings = setHost (fromMaybe "*6" _bind) $ - setPort _port $ - setOnException (\_ _ -> return ()) $ - setNoParsePath True $ - setServerName "Apache" $ - maybe id (setBeforeMainLoop . setuid) _user - defaultSettings - - tlsset' = tlsSettings (certfile primaryCert) (keyfile primaryCert) - hooks = (tlsServerHooks tlsset') { onServerNameIndication = onSNI } - tlsset = tlsset' { tlsServerHooks = hooks, onInsecure = AllowInsecure } - - onSNI Nothing = fail "SNI: unspecified" - onSNI (Just host) - | checkSNI host primaryHost = return mempty - | otherwise = lookupSNI host otherCerts - - lookupSNI host [] = fail ("SNI: unknown hostname (" ++ show host ++ ")") - lookupSNI host ((p, cert) : cs) - | checkSNI host p = return (TLS.Credentials [cert]) - | otherwise = lookupSNI host cs - - checkSNI host pattern = case pattern of - '*' : '.' : p -> ('.' : p) `isSuffixOf` host - p -> host == p - - runner | isSSL = runTLS tlsset - | otherwise = runSettings - - pauth <- case _auth of - Nothing -> return Nothing - Just f -> Just . flip elem . filter (isJust . BS8.elemIndex ':') . BS8.lines <$> BS8.readFile f - manager <- newTlsManager - - let pset = ProxySettings pauth Nothing (BS8.pack <$> _ws) (BS8.pack <$> _rev) - proxy = (if isSSL then forceSSL pset else id) $ gzip def $ httpProxy pset manager $ reverseProxy pset manager dumbApp - - case _doh of - Nothing -> runner settings proxy - Just doh -> createResolver doh (\resolver -> runner settings (dnsOverHTTPS resolver proxy)) diff --git a/src/Network/HProx.hs b/src/Network/HProx.hs new file mode 100644 --- /dev/null +++ b/src/Network/HProx.hs @@ -0,0 +1,212 @@ +-- SPDX-License-Identifier: Apache-2.0 +-- +-- Copyright (C) 2023 Bin Jin. All Rights Reserved. +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +{-| Instead of running @hprox@ binary directly, you can use this library + to run HProx in front of arbitrary WAI 'Application'. +-} + +module Network.HProx + ( Config(..) + , CertFile(..) + , defaultConfig + , getConfig + , run + ) where + +import qualified Data.ByteString.Char8 as BS8 +import Data.List (isSuffixOf) +import Data.String (fromString) +import Network.HTTP.Client.TLS (newTlsManager) +import Network.TLS as TLS +import Network.Wai (Application, + modifyResponse) +import Network.Wai.Handler.Warp (HostPreference, + defaultSettings, + runSettings, + setBeforeMainLoop, + setHost, setNoParsePath, + setOnException, setPort, + setServerName) +import Network.Wai.Handler.WarpTLS (OnInsecure (..), + onInsecure, runTLS, + tlsServerHooks, + tlsSettings) +import Network.Wai.Middleware.Gzip (def, gzip) +import Network.Wai.Middleware.StripHeaders (stripHeaders) +import System.Posix.User (UserEntry (..), + getUserEntryForName, + setUserID) + +import Data.Maybe +import Data.Version (showVersion) +import Options.Applicative + +import Network.HProx.DoH +import Network.HProx.Impl (ProxySettings (..), + forceSSL, httpProxy, + reverseProxy) +import Paths_hprox (version) + +-- | Configuration of HProx, see @hprox --help@ for details +data Config = Config + { _bind :: Maybe HostPreference + , _port :: Int + , _ssl :: [(String, CertFile)] + , _user :: Maybe String + , _auth :: Maybe FilePath + , _ws :: Maybe String + , _rev :: Maybe String + , _doh :: Maybe String + } + +-- | Default value of 'Config', same as running @hprox@ without arguments +defaultConfig :: Config +defaultConfig = Config Nothing 3000 [] Nothing Nothing Nothing Nothing Nothing + +-- | Certificate file pairs +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 Config +parser = info (helper <*> ver <*> config) (fullDesc <> progDesc desc) + where + parseSSL s = case splitBy ':' s of + [host, cert, key] -> Right (host, CertFile cert key) + _ -> Left "invalid format for ssl certificates" + + desc = "a lightweight HTTP proxy server, and more" + ver = infoOption (showVersion version) (long "version" <> help "show version") + + config = Config <$> bind + <*> (fromMaybe 3000 <$> port) + <*> ssl + <*> user + <*> auth + <*> ws + <*> rev + <*> doh + + bind = optional $ fromString <$> strOption + ( long "bind" + <> short 'b' + <> metavar "bind_ip" + <> help "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 specified 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 containing a colon separated user/password pair)") + + ws = optional $ strOption + ( long "ws" + <> metavar "remote-host:port" + <> help "remote host to handle websocket requests (port 443 indicates HTTPS remote server)") + + rev = optional $ strOption + ( long "rev" + <> metavar "remote-host:port" + <> help "remote host for reverse proxy (port 443 indicates HTTPS remote server)") + + doh = optional $ strOption + ( long "doh" + <> metavar "dns-server:port" + <> help "enable DNS-over-HTTPS(DoH) support (53 will be used if port is not specified)") + + +setuid :: String -> IO () +setuid user = getUserEntryForName user >>= setUserID . userID + +-- | Read 'Config' from command line arguments +getConfig :: IO Config +getConfig = execParser parser + +-- | Run HProx in front of fallback 'Application', with specified 'Config' +run :: Application -- ^ fallback application + -> Config -- ^ configuration + -> IO () +run fallback Config{..} = do + + let certfiles = _ssl + certs <- mapM (readCert.snd) certfiles + + let isSSL = not (null certfiles) + (primaryHost, primaryCert) = head certfiles + otherCerts = tail $ zip (map fst certfiles) certs + + settings = setHost (fromMaybe "*6" _bind) $ + setPort _port $ + setOnException (\_ _ -> return ()) $ + setNoParsePath True $ + setServerName "Apache" $ + maybe id (setBeforeMainLoop . setuid) _user + defaultSettings + + tlsset' = tlsSettings (certfile primaryCert) (keyfile primaryCert) + hooks = (tlsServerHooks tlsset') { onServerNameIndication = onSNI } + tlsset = tlsset' { tlsServerHooks = hooks, onInsecure = AllowInsecure } + + onSNI Nothing = fail "SNI: unspecified" + onSNI (Just host) + | checkSNI host primaryHost = return mempty + | otherwise = lookupSNI host otherCerts + + lookupSNI host [] = fail ("SNI: unknown hostname (" ++ show host ++ ")") + lookupSNI host ((p, cert) : cs) + | checkSNI host p = return (TLS.Credentials [cert]) + | otherwise = lookupSNI host cs + + checkSNI host pat = case pat of + '*' : '.' : p -> ('.' : p) `isSuffixOf` host + p -> host == p + + runner | isSSL = runTLS tlsset + | otherwise = runSettings + + pauth <- case _auth of + Nothing -> return Nothing + Just f -> Just . flip elem . filter (isJust . BS8.elemIndex ':') . BS8.lines <$> BS8.readFile f + manager <- newTlsManager + + let pset = ProxySettings pauth Nothing (BS8.pack <$> _ws) (BS8.pack <$> _rev) + proxy = (if isSSL then forceSSL pset else id) $ + modifyResponse (stripHeaders ["Server", "Date"]) $ + gzip def $ + httpProxy pset manager $ + reverseProxy pset manager fallback + + case _doh of + Nothing -> runner settings proxy + Just doh -> createResolver doh (\resolver -> runner settings (dnsOverHTTPS resolver proxy)) diff --git a/src/Network/HProx/DoH.hs b/src/Network/HProx/DoH.hs new file mode 100644 --- /dev/null +++ b/src/Network/HProx/DoH.hs @@ -0,0 +1,67 @@ +-- SPDX-License-Identifier: Apache-2.0 +-- +-- Copyright (C) 2023 Bin Jin. All Rights Reserved. +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Network.HProx.DoH + ( createResolver + , dnsOverHTTPS + ) where + +import qualified Data.ByteString.Base64.URL as Base64 +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as LBS +import Network.DNS (DNSHeader (..), DNSMessage (..), + Question (..), ResolvConf (..), + Resolver) +import qualified Network.DNS as DNS +import qualified Network.HTTP.Types as HT + +import Network.Wai + +import Network.HProx.Util + +createResolver :: String -> (Resolver -> IO a) -> IO a +createResolver remote handle = do + seed <- DNS.makeResolvSeed conf + DNS.withResolver seed handle + where + (h, p) = parseHostPortWithDefault 53 (BS8.pack remote) + info = DNS.RCHostPort (BS8.unpack h) (fromIntegral p) + + conf = DNS.defaultResolvConf { resolvInfo = info } + +dnsOverHTTPS :: Resolver -> Middleware +dnsOverHTTPS resolver fallback req respond + | pathInfo req == ["dns-query"] && isSecure req = handleDoH resolver req respond + | otherwise = fallback req respond + +handleDoH :: Resolver -> Application +handleDoH resolver req respond + | requestMethod req == "GET", + [("dns", Just dnsStr)] <- queryString req, + Right dnsQuery <- Base64.decodeUnpadded dnsStr, + Right (DNSMessage { question = [q], header = DNSHeader {..} }) <- DNS.decode dnsQuery = + handleQuery identifier q + | requestMethod req == "POST", + KnownLength len <- requestBodyLength req, + len <= 4096 = do + dnsQuery <- getRequestBodyChunk req + case DNS.decode dnsQuery of + Right (DNSMessage { question = [q], header = DNSHeader {..} }) -> handleQuery identifier q + _ -> respond errorResp + | otherwise = respond errorResp + where + errorResp = responseLBS HT.status400 [("Content-Type", "text/plain")] "invalid dns-over-https request" + + handleQuery ident Question{..} = do + resp <- DNS.lookupRaw resolver qname qtype + respond $ case resp of + Left _ -> errorResp + Right dnsResp@DNSMessage{header = header} -> + let encoded = DNS.encode (dnsResp {header = header {identifier = ident} }) in + responseLBS HT.status200 + [("Content-Type", "application/dns-message"), + ("Content-Length", BS8.pack $ show (BS8.length encoded))] + (LBS.fromStrict encoded) diff --git a/src/Network/HProx/Impl.hs b/src/Network/HProx/Impl.hs new file mode 100644 --- /dev/null +++ b/src/Network/HProx/Impl.hs @@ -0,0 +1,223 @@ +-- SPDX-License-Identifier: Apache-2.0 +-- +-- Copyright (C) 2023 Bin Jin. All Rights Reserved. +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Network.HProx.Impl + ( ProxySettings(..) + , httpProxy + , pacProvider + , httpGetProxy + , httpConnectProxy + , reverseProxy + , forceSSL + ) 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 Data.Conduit +import Network.Wai + +import Network.HProx.Util + +data ProxySettings = ProxySettings + { proxyAuth :: Maybe (BS.ByteString -> Bool) + , passPrompt :: Maybe BS.ByteString + , wsRemote :: Maybe BS.ByteString + , revRemote :: Maybe BS.ByteString + } + +httpProxy :: ProxySettings -> HC.Manager -> Middleware +httpProxy set mgr = pacProvider . httpGetProxy set mgr . httpConnectProxy set + +forceSSL :: ProxySettings -> Middleware +forceSSL pset app req respond + | isSecure req = app req respond + | redirectWebsocket pset 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")] + "" + + +isProxyHeader :: HT.HeaderName -> Bool +isProxyHeader k = "proxy" `BS.isPrefixOf` CI.foldedCase k + +isForwardedHeader :: HT.HeaderName -> Bool +isForwardedHeader k = "x-forwarded" `BS.isPrefixOf` CI.foldedCase k + +isToStripHeader :: HT.HeaderName -> Bool +isToStripHeader h = isProxyHeader h || isForwardedHeader h || h == "X-Real-IP" || h == "X-Scheme" + +checkAuth :: ProxySettings -> Request -> Bool +checkAuth ProxySettings{..} req + | isNothing proxyAuth = True + | isNothing authRsp = False + | otherwise = fromJust proxyAuth decodedRsp + where + authRsp = lookup HT.hProxyAuthorization (requestHeaders req) + + decodedRsp = decodeLenient $ snd $ BS8.spanEnd (/=' ') $ fromJust authRsp + +redirectWebsocket :: ProxySettings -> Request -> Bool +redirectWebsocket ProxySettings{..} req = wpsUpgradeToRaw defaultWaiProxySettings req && isJust wsRemote + +proxyAuthRequiredResponse :: ProxySettings -> Response +proxyAuthRequiredResponse ProxySettings{..} = responseLBS + HT.status407 + [(HT.hProxyAuthenticate, "Basic realm=\"" `BS.append` prompt `BS.append` "\"")] + "" + where + prompt = fromMaybe "hprox" passPrompt + +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 ProxySettings{..} mgr fallback + | isReverseProxy = waiProxyToSettings (return.proxyResponseFor) settings mgr + | otherwise = fallback + where + settings = defaultWaiProxySettings { wpsSetIpHeader = SIHNone } + + isReverseProxy = isJust revRemote + (revHost, revPort) = parseHostPortWithDefault 80 (fromJust revRemote) + revWrapper = if revPort == 443 then WPRModifiedRequestSecure else WPRModifiedRequest + + proxyResponseFor req = revWrapper 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@ProxySettings{..} mgr fallback = waiProxyToSettings (return.proxyResponseFor) settings mgr + where + settings = defaultWaiProxySettings { wpsSetIpHeader = SIHNone } + + proxyResponseFor req + | redirectWebsocket pset req = wsWrapper (ProxyDest wsHost wsPort) + | not isGetProxy = WPRApplication fallback + | checkAuth pset req = WPRModifiedRequest nreq (ProxyDest host port) + | otherwise = WPRResponse (proxyAuthRequiredResponse pset) + where + (wsHost, wsPort) = parseHostPortWithDefault 80 (fromJust wsRemote) + wsWrapper = if wsPort == 443 then WPRProxyDestSecure else WPRProxyDest + + 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/Network/HProx/Util.hs b/src/Network/HProx/Util.hs new file mode 100644 --- /dev/null +++ b/src/Network/HProx/Util.hs @@ -0,0 +1,25 @@ +-- SPDX-License-Identifier: Apache-2.0 +-- +-- Copyright (C) 2023 Bin Jin. All Rights Reserved. +module Network.HProx.Util + ( parseHostPort + , parseHostPortWithDefault + ) where + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import Data.Maybe (fromMaybe) + +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 diff --git a/src/Util.hs b/src/Util.hs deleted file mode 100644 --- a/src/Util.hs +++ /dev/null @@ -1,25 +0,0 @@ --- SPDX-License-Identifier: Apache-2.0 --- --- Copyright (C) 2023 Bin Jin. All Rights Reserved. -module Util ( - parseHostPort, - parseHostPortWithDefault -) where - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS8 -import Data.Maybe (fromMaybe) - -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