hprox 0.1.0 → 0.1.0.1
raw patch · 6 files changed
+549/−500 lines, 6 filesdep ~base
Dependency ranges changed: base
Files
- HProx.hs +0/−287
- Main.hs +0/−153
- README.md +56/−15
- hprox.cabal +53/−45
- src/HProx.hs +287/−0
- src/Main.hs +153/−0
− HProx.hs
@@ -1,287 +0,0 @@--- SPDX-License-Identifier: Apache-2.0------ Copyright (C) 2019 Bin Jin. All Rights Reserved.-{-# LANGUAGE OverloadedStrings #-}--module HProx- ( ProxySettings(..)- , httpProxy- , pacProvider- , httpGetProxy- , httpConnectProxy- , reverseProxy- , forceSSL- , dumbApp- ) where--import Control.Applicative ((<|>))-import Control.Concurrent.Async (concurrently)-import Control.Exception (SomeException, try)-import Control.Monad (unless, void, when)-import Control.Monad.IO.Class (liftIO)-import qualified Data.Binary.Builder as BB-import qualified Data.ByteString as BS-import Data.ByteString.Base64 (decodeLenient)-import qualified Data.ByteString.Char8 as BS8-import qualified Data.ByteString.Lazy.Char8 as LBS8-import qualified Data.CaseInsensitive as CI-import qualified Data.Conduit.Network as CN-import Data.Maybe (fromJust, fromMaybe, isJust,- isNothing)-import qualified Network.HTTP.Client as HC-import Network.HTTP.ReverseProxy (ProxyDest (..), SetIpHeader (..),- WaiProxyResponse (..),- defaultWaiProxySettings,- waiProxyToSettings, wpsSetIpHeader,- wpsUpgradeToRaw)-import qualified Network.HTTP.Types as HT-import qualified Network.HTTP.Types.Header as HT-import Network.Wai.Internal (getRequestBodyChunk)--import Data.Conduit-import Network.Wai--data ProxySettings = ProxySettings- { proxyAuth :: Maybe (BS.ByteString -> Bool)- , passPrompt :: Maybe BS.ByteString- , wsRemote :: Maybe BS.ByteString- , revRemote :: Maybe BS.ByteString- }--dumbApp :: Application-dumbApp _req respond =- respond $ responseLBS- HT.status200- [("Content-Type", "text/html")] $- LBS8.unlines [ "<html><body><h1>It works!</h1>"- , "<p>This is the default web page for this server.</p>"- , "<p>The web server software is running but no content has been added, yet.</p>"- , "</body></html>"- ]--httpProxy :: ProxySettings -> HC.Manager -> Middleware-httpProxy set mgr = pacProvider . httpGetProxy set mgr . httpConnectProxy set--forceSSL :: Middleware-forceSSL app req respond- | isSecure req = app req respond- | otherwise = redirectToSSL req respond--redirectToSSL :: Application-redirectToSSL req respond- | Just host <- requestHeaderHost req = respond $ responseLBS- HT.status301- [("Location", "https://" `BS.append` host)]- ""- | otherwise = respond $ responseLBS- (HT.mkStatus 426 "Upgrade Required")- [("Upgrade", "TLS/1.0, HTTP/1.1"), ("Connection", "Upgrade")]- ""--parseHostPort :: BS.ByteString -> Maybe (BS.ByteString, Int)-parseHostPort hostPort = do- lastColon <- BS8.elemIndexEnd ':' hostPort- port <- BS8.readInt (BS.drop (lastColon+1) hostPort) >>= checkPort- return (BS.take lastColon hostPort, port)- where- checkPort (p, bs)- | BS.null bs && 1 <= p && p <= 65535 = Just p- | otherwise = Nothing--parseHostPortWithDefault :: Int -> BS.ByteString -> (BS.ByteString, Int)-parseHostPortWithDefault defaultPort hostPort =- fromMaybe (hostPort, defaultPort) $ parseHostPort hostPort--isProxyHeader :: HT.HeaderName -> Bool-isProxyHeader k- | BS.length bs <= 4 = False- | c0 /= 112 && c0 /= 80 = False -- 'p'- | c1 /= 114 && c1 /= 82 = False -- 'r'- | c2 /= 111 && c2 /= 79 = False -- 'o'- | c3 /= 120 && c3 /= 88 = False -- 'x'- | c4 /= 121 && c4 /= 89 = False -- 'y'- | otherwise = True- where- bs = CI.original k- idx = BS.index bs-- c0 = idx 0- c1 = idx 1- c2 = idx 2- c3 = idx 3- c4 = idx 4--isForwardedHeader :: HT.HeaderName -> Bool-isForwardedHeader k- | BS.length bs <= 10 = False- | c0 /= 120 && c0 /= 88 = False -- 'x'- | c1 /= 45 = False -- '-'- | c2 /= 102 && c2 /= 70 = False -- 'f'- | c3 /= 111 && c3 /= 79 = False -- 'o'- | c4 /= 114 && c4 /= 82 = False -- 'r'- | c5 /= 119 && c5 /= 87 = False -- 'w'- | c6 /= 97 && c6 /= 65 = False -- 'a'- | c7 /= 114 && c7 /= 82 = False -- 'r'- | c8 /= 100 && c8 /= 68 = False -- 'd'- | c9 /= 101 && c9 /= 69 = False -- 'e'- | ca /= 100 && ca /= 68 = False -- 'd'- | otherwise = True- where- bs = CI.original k- idx = BS.index bs-- c0 = idx 0- c1 = idx 1- c2 = idx 2- c3 = idx 3- c4 = idx 4- c5 = idx 5- c6 = idx 6- c7 = idx 7- c8 = idx 8- c9 = idx 9- ca = idx 10--isToStripHeader :: HT.HeaderName -> Bool-isToStripHeader h = isProxyHeader h || isForwardedHeader h || h == "X-Real-IP" || h == "X-Scheme"--checkAuth :: ProxySettings -> Request -> Bool-checkAuth pset req- | isNothing pauth = True- | isNothing authRsp = False- | otherwise = fromJust pauth decodedRsp- where- pauth = proxyAuth pset- authRsp = lookup HT.hProxyAuthorization (requestHeaders req)-- decodedRsp = decodeLenient $ snd $ BS8.spanEnd (/=' ') $ fromJust authRsp--proxyAuthRequiredResponse :: ProxySettings -> Response-proxyAuthRequiredResponse pset = responseLBS- HT.status407- [(HT.hProxyAuthenticate, "Basic realm=\"" `BS.append` prompt `BS.append` "\"")]- ""- where- prompt = fromMaybe "hprox" (passPrompt pset)--pacProvider :: Middleware-pacProvider fallback req respond- | pathInfo req == ["get", "hprox.pac"],- Just host' <- lookup "x-forwarded-host" (requestHeaders req) <|> requestHeaderHost req =- let issecure = case lookup "x-forwarded-proto" (requestHeaders req) of- Just proto -> proto == "https"- Nothing -> isSecure req- scheme = if issecure then "HTTPS" else "PROXY"- defaultPort = if issecure then ":443" else ":80"- host | 58 `BS.elem` host' = host' -- ':'- | otherwise = host' `BS.append` defaultPort- in respond $ responseLBS- HT.status200- [("Content-Type", "application/x-ns-proxy-autoconfig")] $- LBS8.unlines [ "function FindProxyForURL(url, host) {"- , LBS8.fromChunks [" return \"", scheme, " ", host, "\";"]- , "}"- ]- | otherwise = fallback req respond--reverseProxy :: ProxySettings -> HC.Manager -> Middleware-reverseProxy pset mgr fallback- | isReverseProxy = waiProxyToSettings (return.proxyResponseFor) settings mgr- | otherwise = fallback- where- settings = defaultWaiProxySettings { wpsSetIpHeader = SIHNone }-- isReverseProxy = isJust (revRemote pset)- (revHost, revPort) = parseHostPortWithDefault 80 (fromJust (revRemote pset))-- proxyResponseFor req = WPRModifiedRequest nreq (ProxyDest revHost revPort)- where- nreq = req- { requestHeaders = hdrs- , requestHeaderHost = Just revHost- }-- hdrs = (HT.hHost, revHost) : [ (hdn, hdv)- | (hdn, hdv) <- requestHeaders req- , not (isToStripHeader hdn) && hdn /= HT.hHost- ]--httpGetProxy :: ProxySettings -> HC.Manager -> Middleware-httpGetProxy pset mgr fallback = waiProxyToSettings (return.proxyResponseFor) settings mgr- where- settings = defaultWaiProxySettings { wpsSetIpHeader = SIHNone }-- proxyResponseFor req- | redirectWebsocket = WPRProxyDest (ProxyDest wsHost wsPort)- | not isGetProxy = WPRApplication fallback- | checkAuth pset req = WPRModifiedRequest nreq (ProxyDest host port)- | otherwise = WPRResponse (proxyAuthRequiredResponse pset)- where- isWebsocket = wpsUpgradeToRaw defaultWaiProxySettings req- redirectWebsocket = isWebsocket && isJust (wsRemote pset)- (wsHost, wsPort) = parseHostPortWithDefault 80 (fromJust (wsRemote pset))-- notCONNECT = requestMethod req /= "CONNECT"- rawPath = rawPathInfo req- rawPathPrefix = "http://"- defaultPort = 80- hostHeader = parseHostPortWithDefault defaultPort <$> requestHeaderHost req-- isRawPathProxy = rawPathPrefix `BS.isPrefixOf` rawPath- hasProxyHeader = any (isProxyHeader.fst) (requestHeaders req)- scheme = lookup "X-Scheme" (requestHeaders req)- isHTTP2Proxy = HT.httpMajor (httpVersion req) >= 2 && scheme == Just "http" && isSecure req-- isGetProxy = notCONNECT && (isRawPathProxy || isHTTP2Proxy || isJust hostHeader && hasProxyHeader)-- nreq = req- { rawPathInfo = newRawPath- , requestHeaders = filter (not.isToStripHeader.fst) $ requestHeaders req- }-- ((host, port), newRawPath)- | isRawPathProxy = (parseHostPortWithDefault defaultPort hostPortP, newRawPathP)- | otherwise = (fromJust hostHeader, rawPath)- where- (hostPortP, newRawPathP) = BS8.span (/='/') $- BS.drop (BS.length rawPathPrefix) rawPath--httpConnectProxy :: ProxySettings -> Middleware-httpConnectProxy pset fallback req respond- | not isConnectProxy = fallback req respond- | checkAuth pset req = respond response- | otherwise = respond (proxyAuthRequiredResponse pset)- where- hostPort' = parseHostPort (rawPathInfo req) <|> (requestHeaderHost req >>= parseHostPort)- isConnectProxy = requestMethod req == "CONNECT" && isJust hostPort'-- Just (host, port) = hostPort'- settings = CN.clientSettings port host-- backup = responseLBS HT.status500 [("Content-Type", "text/plain")]- "HTTP CONNECT tunneling detected, but server does not support responseRaw"-- tryAndCatchAll :: IO a -> IO (Either SomeException a)- tryAndCatchAll = try-- response- | HT.httpMajor (httpVersion req) < 2 = responseRaw (handleConnect True) backup- | otherwise = responseStream HT.status200 [] streaming- where- streaming write flush = do- flush- handleConnect False (getRequestBodyChunk req) (\bs -> write (BB.fromByteString bs) >> flush)-- handleConnect :: Bool -> IO BS.ByteString -> (BS.ByteString -> IO ()) -> IO ()- handleConnect http1 fromClient' toClient' = CN.runTCPClient settings $ \server ->- let toServer = CN.appSink server- fromServer = CN.appSource server- fromClient = do- bs <- liftIO fromClient'- unless (BS.null bs) (yield bs >> fromClient)- toClient = awaitForever (liftIO . toClient')- in do- when http1 $ runConduit $ yield "HTTP/1.1 200 OK\r\n\r\n" .| toClient- void $ tryAndCatchAll $ concurrently- (runConduit (fromClient .| toServer))- (runConduit (fromServer .| toClient))
− Main.hs
@@ -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
README.md view
@@ -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.
hprox.cabal view
@@ -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 at <https://github.com/bjin/hprox#readme>+cabal-version: 1.12 -license: Apache-2.0-license-file: LICENSE-author: Bin Jin-maintainer: bjin@ctrl-d.org-category: Web-build-type: Simple-cabal-version: >=1.10+-- This file has been generated from package.yaml by hpack version 0.31.1.+--+-- see: https://github.com/sol/hpack+--+-- hash: a70b4c08df6e0a53013a5ee56b5e14317c0fb952bc34ad9dd8b9c25954559c83 +name: hprox+version: 0.1.0.1+synopsis: a lightweight HTTP proxy server, and more+description: Please see the README on GitHub at <https://github.com/bjin/hprox#readme>+category: Web+homepage: https://github.com/bjin/hprox#readme+bug-reports: https://github.com/bjin/hprox/issues+author: Bin Jin+maintainer: bjin@ctrl-d.org+copyright: 2019 Bin Jin+license: Apache-2.0+license-file: LICENSE+build-type: Simple extra-source-files:- README.md+ README.md +source-repository head+ type: git+ location: https://github.com/bjin/hprox+ flag static- description:- Enable static build- Default:- False+ description: Enable static build+ manual: True+ default: False executable hprox- main-is:- Main.hs- ghc-options:- -Wall -O2 -threaded -rtsopts "-with-rtsopts=-N -c"- if flag(static)- ghc-options:- -optl-static+ main-is: Main.hs other-modules:- HProx+ HProx+ hs-source-dirs:+ src+ ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N build-depends:- async,- base < 5.0,- base64-bytestring,- binary,- bytestring,- case-insensitive,- conduit,- conduit-extra,- http-client,- http-reverse-proxy >= 0.4.0,- http-types,- optparse-applicative,- tls >= 1.5.0,- unix,- wai >= 3.2.2,- wai-extra,- warp >= 3.2.8,- warp-tls >= 3.2.5- default-language:- Haskell2010+ async+ , base >=4.7 && <5+ , base64-bytestring+ , binary+ , bytestring+ , case-insensitive+ , conduit+ , conduit-extra+ , http-client+ , http-reverse-proxy >=0.4.0+ , http-types+ , optparse-applicative+ , tls >=1.5.0+ , unix+ , wai >=3.2.2+ , wai-extra+ , warp >=3.2.8+ , warp-tls >=3.2.5+ if flag(static)+ ghc-options: -optl-static+ default-language: Haskell2010
+ src/HProx.hs view
@@ -0,0 +1,287 @@+-- SPDX-License-Identifier: Apache-2.0+--+-- Copyright (C) 2019 Bin Jin. All Rights Reserved.+{-# LANGUAGE OverloadedStrings #-}++module HProx+ ( ProxySettings(..)+ , httpProxy+ , pacProvider+ , httpGetProxy+ , httpConnectProxy+ , reverseProxy+ , forceSSL+ , dumbApp+ ) where++import Control.Applicative ((<|>))+import Control.Concurrent.Async (concurrently)+import Control.Exception (SomeException, try)+import Control.Monad (unless, void, when)+import Control.Monad.IO.Class (liftIO)+import qualified Data.Binary.Builder as BB+import qualified Data.ByteString as BS+import Data.ByteString.Base64 (decodeLenient)+import qualified Data.ByteString.Char8 as BS8+import qualified Data.ByteString.Lazy.Char8 as LBS8+import qualified Data.CaseInsensitive as CI+import qualified Data.Conduit.Network as CN+import Data.Maybe (fromJust, fromMaybe, isJust,+ isNothing)+import qualified Network.HTTP.Client as HC+import Network.HTTP.ReverseProxy (ProxyDest (..), SetIpHeader (..),+ WaiProxyResponse (..),+ defaultWaiProxySettings,+ waiProxyToSettings, wpsSetIpHeader,+ wpsUpgradeToRaw)+import qualified Network.HTTP.Types as HT+import qualified Network.HTTP.Types.Header as HT+import Network.Wai.Internal (getRequestBodyChunk)++import Data.Conduit+import Network.Wai++data ProxySettings = ProxySettings+ { proxyAuth :: Maybe (BS.ByteString -> Bool)+ , passPrompt :: Maybe BS.ByteString+ , wsRemote :: Maybe BS.ByteString+ , revRemote :: Maybe BS.ByteString+ }++dumbApp :: Application+dumbApp _req respond =+ respond $ responseLBS+ HT.status200+ [("Content-Type", "text/html")] $+ LBS8.unlines [ "<html><body><h1>It works!</h1>"+ , "<p>This is the default web page for this server.</p>"+ , "<p>The web server software is running but no content has been added, yet.</p>"+ , "</body></html>"+ ]++httpProxy :: ProxySettings -> HC.Manager -> Middleware+httpProxy set mgr = pacProvider . httpGetProxy set mgr . httpConnectProxy set++forceSSL :: Middleware+forceSSL app req respond+ | isSecure req = app req respond+ | otherwise = redirectToSSL req respond++redirectToSSL :: Application+redirectToSSL req respond+ | Just host <- requestHeaderHost req = respond $ responseLBS+ HT.status301+ [("Location", "https://" `BS.append` host)]+ ""+ | otherwise = respond $ responseLBS+ (HT.mkStatus 426 "Upgrade Required")+ [("Upgrade", "TLS/1.0, HTTP/1.1"), ("Connection", "Upgrade")]+ ""++parseHostPort :: BS.ByteString -> Maybe (BS.ByteString, Int)+parseHostPort hostPort = do+ lastColon <- BS8.elemIndexEnd ':' hostPort+ port <- BS8.readInt (BS.drop (lastColon+1) hostPort) >>= checkPort+ return (BS.take lastColon hostPort, port)+ where+ checkPort (p, bs)+ | BS.null bs && 1 <= p && p <= 65535 = Just p+ | otherwise = Nothing++parseHostPortWithDefault :: Int -> BS.ByteString -> (BS.ByteString, Int)+parseHostPortWithDefault defaultPort hostPort =+ fromMaybe (hostPort, defaultPort) $ parseHostPort hostPort++isProxyHeader :: HT.HeaderName -> Bool+isProxyHeader k+ | BS.length bs <= 4 = False+ | c0 /= 112 && c0 /= 80 = False -- 'p'+ | c1 /= 114 && c1 /= 82 = False -- 'r'+ | c2 /= 111 && c2 /= 79 = False -- 'o'+ | c3 /= 120 && c3 /= 88 = False -- 'x'+ | c4 /= 121 && c4 /= 89 = False -- 'y'+ | otherwise = True+ where+ bs = CI.original k+ idx = BS.index bs++ c0 = idx 0+ c1 = idx 1+ c2 = idx 2+ c3 = idx 3+ c4 = idx 4++isForwardedHeader :: HT.HeaderName -> Bool+isForwardedHeader k+ | BS.length bs <= 10 = False+ | c0 /= 120 && c0 /= 88 = False -- 'x'+ | c1 /= 45 = False -- '-'+ | c2 /= 102 && c2 /= 70 = False -- 'f'+ | c3 /= 111 && c3 /= 79 = False -- 'o'+ | c4 /= 114 && c4 /= 82 = False -- 'r'+ | c5 /= 119 && c5 /= 87 = False -- 'w'+ | c6 /= 97 && c6 /= 65 = False -- 'a'+ | c7 /= 114 && c7 /= 82 = False -- 'r'+ | c8 /= 100 && c8 /= 68 = False -- 'd'+ | c9 /= 101 && c9 /= 69 = False -- 'e'+ | ca /= 100 && ca /= 68 = False -- 'd'+ | otherwise = True+ where+ bs = CI.original k+ idx = BS.index bs++ c0 = idx 0+ c1 = idx 1+ c2 = idx 2+ c3 = idx 3+ c4 = idx 4+ c5 = idx 5+ c6 = idx 6+ c7 = idx 7+ c8 = idx 8+ c9 = idx 9+ ca = idx 10++isToStripHeader :: HT.HeaderName -> Bool+isToStripHeader h = isProxyHeader h || isForwardedHeader h || h == "X-Real-IP" || h == "X-Scheme"++checkAuth :: ProxySettings -> Request -> Bool+checkAuth pset req+ | isNothing pauth = True+ | isNothing authRsp = False+ | otherwise = fromJust pauth decodedRsp+ where+ pauth = proxyAuth pset+ authRsp = lookup HT.hProxyAuthorization (requestHeaders req)++ decodedRsp = decodeLenient $ snd $ BS8.spanEnd (/=' ') $ fromJust authRsp++proxyAuthRequiredResponse :: ProxySettings -> Response+proxyAuthRequiredResponse pset = responseLBS+ HT.status407+ [(HT.hProxyAuthenticate, "Basic realm=\"" `BS.append` prompt `BS.append` "\"")]+ ""+ where+ prompt = fromMaybe "hprox" (passPrompt pset)++pacProvider :: Middleware+pacProvider fallback req respond+ | pathInfo req == ["get", "hprox.pac"],+ Just host' <- lookup "x-forwarded-host" (requestHeaders req) <|> requestHeaderHost req =+ let issecure = case lookup "x-forwarded-proto" (requestHeaders req) of+ Just proto -> proto == "https"+ Nothing -> isSecure req+ scheme = if issecure then "HTTPS" else "PROXY"+ defaultPort = if issecure then ":443" else ":80"+ host | 58 `BS.elem` host' = host' -- ':'+ | otherwise = host' `BS.append` defaultPort+ in respond $ responseLBS+ HT.status200+ [("Content-Type", "application/x-ns-proxy-autoconfig")] $+ LBS8.unlines [ "function FindProxyForURL(url, host) {"+ , LBS8.fromChunks [" return \"", scheme, " ", host, "\";"]+ , "}"+ ]+ | otherwise = fallback req respond++reverseProxy :: ProxySettings -> HC.Manager -> Middleware+reverseProxy pset mgr fallback+ | isReverseProxy = waiProxyToSettings (return.proxyResponseFor) settings mgr+ | otherwise = fallback+ where+ settings = defaultWaiProxySettings { wpsSetIpHeader = SIHNone }++ isReverseProxy = isJust (revRemote pset)+ (revHost, revPort) = parseHostPortWithDefault 80 (fromJust (revRemote pset))++ proxyResponseFor req = WPRModifiedRequest nreq (ProxyDest revHost revPort)+ where+ nreq = req+ { requestHeaders = hdrs+ , requestHeaderHost = Just revHost+ }++ hdrs = (HT.hHost, revHost) : [ (hdn, hdv)+ | (hdn, hdv) <- requestHeaders req+ , not (isToStripHeader hdn) && hdn /= HT.hHost+ ]++httpGetProxy :: ProxySettings -> HC.Manager -> Middleware+httpGetProxy pset mgr fallback = waiProxyToSettings (return.proxyResponseFor) settings mgr+ where+ settings = defaultWaiProxySettings { wpsSetIpHeader = SIHNone }++ proxyResponseFor req+ | redirectWebsocket = WPRProxyDest (ProxyDest wsHost wsPort)+ | not isGetProxy = WPRApplication fallback+ | checkAuth pset req = WPRModifiedRequest nreq (ProxyDest host port)+ | otherwise = WPRResponse (proxyAuthRequiredResponse pset)+ where+ isWebsocket = wpsUpgradeToRaw defaultWaiProxySettings req+ redirectWebsocket = isWebsocket && isJust (wsRemote pset)+ (wsHost, wsPort) = parseHostPortWithDefault 80 (fromJust (wsRemote pset))++ notCONNECT = requestMethod req /= "CONNECT"+ rawPath = rawPathInfo req+ rawPathPrefix = "http://"+ defaultPort = 80+ hostHeader = parseHostPortWithDefault defaultPort <$> requestHeaderHost req++ isRawPathProxy = rawPathPrefix `BS.isPrefixOf` rawPath+ hasProxyHeader = any (isProxyHeader.fst) (requestHeaders req)+ scheme = lookup "X-Scheme" (requestHeaders req)+ isHTTP2Proxy = HT.httpMajor (httpVersion req) >= 2 && scheme == Just "http" && isSecure req++ isGetProxy = notCONNECT && (isRawPathProxy || isHTTP2Proxy || isJust hostHeader && hasProxyHeader)++ nreq = req+ { rawPathInfo = newRawPath+ , requestHeaders = filter (not.isToStripHeader.fst) $ requestHeaders req+ }++ ((host, port), newRawPath)+ | isRawPathProxy = (parseHostPortWithDefault defaultPort hostPortP, newRawPathP)+ | otherwise = (fromJust hostHeader, rawPath)+ where+ (hostPortP, newRawPathP) = BS8.span (/='/') $+ BS.drop (BS.length rawPathPrefix) rawPath++httpConnectProxy :: ProxySettings -> Middleware+httpConnectProxy pset fallback req respond+ | not isConnectProxy = fallback req respond+ | checkAuth pset req = respond response+ | otherwise = respond (proxyAuthRequiredResponse pset)+ where+ hostPort' = parseHostPort (rawPathInfo req) <|> (requestHeaderHost req >>= parseHostPort)+ isConnectProxy = requestMethod req == "CONNECT" && isJust hostPort'++ Just (host, port) = hostPort'+ settings = CN.clientSettings port host++ backup = responseLBS HT.status500 [("Content-Type", "text/plain")]+ "HTTP CONNECT tunneling detected, but server does not support responseRaw"++ tryAndCatchAll :: IO a -> IO (Either SomeException a)+ tryAndCatchAll = try++ response+ | HT.httpMajor (httpVersion req) < 2 = responseRaw (handleConnect True) backup+ | otherwise = responseStream HT.status200 [] streaming+ where+ streaming write flush = do+ flush+ handleConnect False (getRequestBodyChunk req) (\bs -> write (BB.fromByteString bs) >> flush)++ handleConnect :: Bool -> IO BS.ByteString -> (BS.ByteString -> IO ()) -> IO ()+ handleConnect http1 fromClient' toClient' = CN.runTCPClient settings $ \server ->+ let toServer = CN.appSink server+ fromServer = CN.appSource server+ fromClient = do+ bs <- liftIO fromClient'+ unless (BS.null bs) (yield bs >> fromClient)+ toClient = awaitForever (liftIO . toClient')+ in do+ when http1 $ runConduit $ yield "HTTP/1.1 200 OK\r\n\r\n" .| toClient+ void $ tryAndCatchAll $ concurrently+ (runConduit (fromClient .| toServer))+ (runConduit (fromServer .| toClient))
+ src/Main.hs view
@@ -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