hprox 0.2.1 → 0.3.0
raw patch · 12 files changed
+595/−511 lines, 12 filesdep +hprox
Dependencies added: hprox
Files
- Changelog.md +3/−0
- README.md +1/−1
- app/Main.hs +25/−0
- hprox.cabal +39/−6
- src/DoH.hs +0/−66
- src/HProx.hs +0/−235
- src/Main.hs +0/−178
- src/Network/HProx.hs +212/−0
- src/Network/HProx/DoH.hs +67/−0
- src/Network/HProx/Impl.hs +223/−0
- src/Network/HProx/Util.hs +25/−0
- src/Util.hs +0/−25
+ Changelog.md view
@@ -0,0 +1,3 @@+## 0.3.0++- initial version with exposed library interface
README.md view
@@ -19,7 +19,7 @@ * Reverse proxy support (redirect requests to a fallback server). * DNS-over-HTTPS (DoH) support. * Implemented as a middleware, compatible with any Haskell Web Application built with `wai` interface.- Defaults to fallback to a dumb application which simulate the default empty page from Apache.+ See [library documents](https://hackage.haskell.org/package/hprox) for details. ### Installation
+ app/Main.hs view
@@ -0,0 +1,25 @@+-- SPDX-License-Identifier: Apache-2.0+--+-- Copyright (C) 2023 Bin Jin. All Rights Reserved.+{-# LANGUAGE OverloadedStrings #-}+module Main (main) where++import qualified Data.ByteString.Lazy.Char8 as LBS8+import qualified Network.HTTP.Types as HT+import Network.Wai++import Network.HProx++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>"+ ]++main :: IO ()+main = getConfig >>= run dumbApp
hprox.cabal view
@@ -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 at <https://github.com/bjin/hprox#readme> category: Web@@ -19,6 +19,7 @@ build-type: Simple extra-source-files: README.md+ Changelog.md source-repository head type: git@@ -29,16 +30,47 @@ manual: True default: False +library+ exposed-modules:+ Network.HProx+ other-modules:+ Network.HProx.DoH+ Network.HProx.Impl+ Network.HProx.Util+ Paths_hprox+ hs-source-dirs:+ src+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints+ build-depends:+ async >=2.2+ , base >=4.12 && <5+ , base64-bytestring >=1.1+ , binary >=0.8+ , bytestring >=0.10+ , case-insensitive >=1.2+ , conduit >=1.3+ , conduit-extra >=1.3+ , dns >=4.0+ , http-client >=0.5+ , http-client-tls >=0.3.4+ , http-reverse-proxy >=0.4.0+ , http-types >=0.12+ , optparse-applicative >=0.14+ , tls >=1.5+ , unix >=2.7+ , wai >=3.2.2+ , wai-extra >=3.0+ , warp >=3.2.8+ , warp-tls >=3.2.5+ default-language: Haskell2010+ executable hprox main-is: Main.hs other-modules:- DoH- HProx Paths_hprox- Util hs-source-dirs:- src- ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N+ app+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N -O2 build-depends: async >=2.2 , base >=4.12 && <5@@ -49,6 +81,7 @@ , conduit >=1.3 , conduit-extra >=1.3 , dns >=4.0+ , hprox , http-client >=0.5 , http-client-tls >=0.3.4 , http-reverse-proxy >=0.4.0
− src/DoH.hs
@@ -1,66 +0,0 @@--- SPDX-License-Identifier: Apache-2.0------ Copyright (C) 2023 Bin Jin. All Rights Reserved.-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}--module 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 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)
− src/HProx.hs
@@ -1,235 +0,0 @@--- SPDX-License-Identifier: Apache-2.0------ Copyright (C) 2023 Bin Jin. All Rights Reserved.-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}--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 Data.Conduit-import Network.Wai--import Util--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 :: 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))
− src/Main.hs
@@ -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))
+ src/Network/HProx.hs view
@@ -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))
+ src/Network/HProx/DoH.hs view
@@ -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)
+ src/Network/HProx/Impl.hs view
@@ -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))
+ src/Network/HProx/Util.hs view
@@ -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
− src/Util.hs
@@ -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