hprox 0.3.0 → 0.4.0
raw patch · 8 files changed
+239/−126 lines, 8 filesdep +randomPVP ok
version bump matches the API change (PVP)
Dependencies added: random
API changes (from Hackage documentation)
+ Network.HProx: [_naive] :: Config -> Bool
- Network.HProx: Config :: Maybe HostPreference -> Int -> [(String, CertFile)] -> Maybe String -> Maybe FilePath -> Maybe String -> Maybe String -> Maybe String -> Config
+ Network.HProx: Config :: Maybe HostPreference -> Int -> [(String, CertFile)] -> Maybe String -> Maybe FilePath -> Maybe String -> Maybe String -> Maybe String -> Bool -> Config
Files
- Changelog.md +5/−0
- README.md +1/−0
- app/Main.hs +19/−12
- hprox.cabal +11/−1
- src/Network/HProx.hs +59/−47
- src/Network/HProx/DoH.hs +11/−15
- src/Network/HProx/Impl.hs +99/−48
- src/Network/HProx/Util.hs +34/−3
Changelog.md view
@@ -1,3 +1,8 @@+## 0.4.0++- naiveproxy compatible [padding](https://github.com/klzgrad/naiveproxy/#padding-protocol-an-informal-specification) support (`--naive`)+- strong TLS settings as advised by [SSL Labs ssltest](https://www.ssllabs.com/ssltest)+ ## 0.3.0 - initial version with exposed library interface
README.md view
@@ -18,6 +18,7 @@ * Websocket redirection (compatible with [v2ray-plugin](https://github.com/shadowsocks/v2ray-plugin)). * Reverse proxy support (redirect requests to a fallback server). * DNS-over-HTTPS (DoH) support.+* [naiveproxy](https://github.com/klzgrad/naiveproxy) compatible [padding](https://github.com/klzgrad/naiveproxy/#padding-protocol-an-informal-specification) (HTTP Connect proxy). * Implemented as a middleware, compatible with any Haskell Web Application built with `wai` interface. See [library documents](https://hackage.haskell.org/package/hprox) for details.
app/Main.hs view
@@ -1,25 +1,32 @@ -- 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+module Main+ ( main+ ) where -import Network.HProx+import Data.ByteString.Char8 qualified as BS8+import Data.ByteString.Lazy.Char8 qualified as LBS8+import Network.HTTP.Types qualified 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>"- ]+ [ ("Content-Type", "text/html")+ , ("Content-Length", BS8.pack (show (LBS8.length body)))+ ]+ body+ where+ body = 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.3.0+version: 0.4.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@@ -40,6 +40,10 @@ Paths_hprox hs-source-dirs: src+ default-extensions:+ ImportQualifiedPost+ OverloadedStrings+ RecordWildCards 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@@ -56,6 +60,7 @@ , http-reverse-proxy >=0.4.0 , http-types >=0.12 , optparse-applicative >=0.14+ , random , tls >=1.5 , unix >=2.7 , wai >=3.2.2@@ -70,6 +75,10 @@ Paths_hprox hs-source-dirs: app+ default-extensions:+ ImportQualifiedPost+ OverloadedStrings+ RecordWildCards 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@@ -87,6 +96,7 @@ , http-reverse-proxy >=0.4.0 , http-types >=0.12 , optparse-applicative >=0.14+ , random , tls >=1.5 , unix >=2.7 , wai >=3.2.2
src/Network/HProx.hs view
@@ -1,70 +1,62 @@ -- 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(..)+ ( CertFile (..)+ , Config (..) , 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.ByteString.Char8 qualified as BS8+import Data.List (isSuffixOf, (\\))+import Data.String (fromString)+import Data.Version (showVersion)+import Network.HTTP.Client.TLS (newTlsManager)+import Network.TLS qualified as TLS+import Network.TLS.Extra.Cipher qualified 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, tlsAllowedVersions, tlsCiphers,+ 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 Data.Maybe+import Options.Applicative -import Network.HProx.DoH-import Network.HProx.Impl (ProxySettings (..),- forceSSL, httpProxy,- reverseProxy)-import Paths_hprox (version)+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+ { _bind :: Maybe HostPreference+ , _port :: Int+ , _ssl :: [(String, CertFile)]+ , _user :: Maybe String+ , _auth :: Maybe FilePath+ , _ws :: Maybe String+ , _rev :: Maybe String+ , _doh :: Maybe String+ , _naive :: Bool } -- | Default value of 'Config', same as running @hprox@ without arguments defaultConfig :: Config-defaultConfig = Config Nothing 3000 [] Nothing Nothing Nothing Nothing Nothing+defaultConfig = Config Nothing 3000 [] Nothing Nothing Nothing Nothing Nothing False -- | Certificate file pairs data CertFile = CertFile@@ -99,6 +91,7 @@ <*> ws <*> rev <*> doh+ <*> naive bind = optional $ fromString <$> strOption ( long "bind"@@ -145,7 +138,11 @@ <> metavar "dns-server:port" <> help "enable DNS-over-HTTPS(DoH) support (53 will be used if port is not specified)") + naive = switch+ ( long "naive"+ <> help "add naiveproxy compatible padding (requires TLS)") + setuid :: String -> IO () setuid user = getUserEntryForName user >>= setUserID . userID @@ -175,9 +172,24 @@ defaultSettings tlsset' = tlsSettings (certfile primaryCert) (keyfile primaryCert)- hooks = (tlsServerHooks tlsset') { onServerNameIndication = onSNI }- tlsset = tlsset' { tlsServerHooks = hooks, onInsecure = AllowInsecure }+ hooks = (tlsServerHooks tlsset') { TLS.onServerNameIndication = onSNI } + -- https://www.ssllabs.com/ssltest+ weak_ciphers = [ TLS.cipher_ECDHE_RSA_AES256CBC_SHA384+ , TLS.cipher_ECDHE_RSA_AES256CBC_SHA+ , TLS.cipher_AES256CCM_SHA256+ , TLS.cipher_AES256GCM_SHA384+ , TLS.cipher_AES256_SHA256+ , TLS.cipher_AES256_SHA1+ ]++ tlsset = tlsset'+ { tlsServerHooks = hooks+ , onInsecure = AllowInsecure+ , tlsAllowedVersions = [TLS.TLS13, TLS.TLS12]+ , tlsCiphers = TLS.ciphersuite_strong \\ weak_ciphers+ }+ onSNI Nothing = fail "SNI: unspecified" onSNI (Just host) | checkSNI host primaryHost = return mempty@@ -200,7 +212,7 @@ 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)+ let pset = ProxySettings pauth Nothing (BS8.pack <$> _ws) (BS8.pack <$> _rev) (_naive && isSSL) proxy = (if isSSL then forceSSL pset else id) $ modifyResponse (stripHeaders ["Server", "Date"]) $ gzip def $
src/Network/HProx/DoH.hs view
@@ -1,26 +1,23 @@ -- 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 Data.ByteString.Base64.URL qualified as Base64+import Data.ByteString.Char8 qualified as BS8+import Data.ByteString.Lazy qualified as LBS+import Network.DNS+ (DNSHeader (..), DNSMessage (..), Question (..), ResolvConf (..), Resolver)+import Network.DNS qualified as DNS+import Network.HTTP.Types qualified as HT -import Network.Wai+import Network.Wai -import Network.HProx.Util+import Network.HProx.Util createResolver :: String -> (Resolver -> IO a) -> IO a createResolver remote handle = do@@ -61,7 +58,6 @@ 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))]+ responseKnownLength HT.status200+ [("Content-Type", "application/dns-message")] (LBS.fromStrict encoded)
src/Network/HProx/Impl.hs view
@@ -1,52 +1,51 @@ -- SPDX-License-Identifier: Apache-2.0 -- -- Copyright (C) 2023 Bin Jin. All Rights Reserved.-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-} module Network.HProx.Impl- ( ProxySettings(..)+ ( ProxySettings (..)+ , forceSSL+ , httpConnectProxy+ , httpGetProxy , 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 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 Data.Binary.Builder qualified as BB+import Data.ByteString qualified as BS+import Data.ByteString.Base64 (decodeLenient)+import Data.ByteString.Char8 qualified as BS8+import Data.ByteString.Lazy qualified as LBS+import Data.ByteString.Lazy.Char8 qualified as LBS8+import Data.CaseInsensitive qualified as CI+import Data.Conduit.Binary qualified as CB+import Data.Conduit.Network qualified as CN+import Network.HTTP.Client qualified as HC+import Network.HTTP.ReverseProxy+ (ProxyDest (..), SetIpHeader (..), WaiProxyResponse (..),+ defaultWaiProxySettings, waiProxyToSettings, wpsSetIpHeader,+ wpsUpgradeToRaw)+import Network.HTTP.Types qualified as HT+import Network.HTTP.Types.Header qualified as HT -import Data.Conduit-import Network.Wai+import Data.Conduit+import Data.Maybe+import Network.Wai -import Network.HProx.Util+import Network.HProx.Util data ProxySettings = ProxySettings- { proxyAuth :: Maybe (BS.ByteString -> Bool)- , passPrompt :: Maybe BS.ByteString- , wsRemote :: Maybe BS.ByteString- , revRemote :: Maybe BS.ByteString+ { proxyAuth :: Maybe (BS.ByteString -> Bool)+ , passPrompt :: Maybe BS.ByteString+ , wsRemote :: Maybe BS.ByteString+ , revRemote :: Maybe BS.ByteString+ , naivePadding :: Bool } httpProxy :: ProxySettings -> HC.Manager -> Middleware@@ -60,16 +59,15 @@ redirectToSSL :: Application redirectToSSL req respond- | Just host <- requestHeaderHost req = respond $ responseLBS+ | Just host <- requestHeaderHost req = respond $ responseKnownLength HT.status301 [("Location", "https://" `BS.append` host)] ""- | otherwise = respond $ responseLBS+ | otherwise = respond $ responseKnownLength (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 @@ -93,7 +91,7 @@ redirectWebsocket ProxySettings{..} req = wpsUpgradeToRaw defaultWaiProxySettings req && isJust wsRemote proxyAuthRequiredResponse :: ProxySettings -> Response-proxyAuthRequiredResponse ProxySettings{..} = responseLBS+proxyAuthRequiredResponse ProxySettings{..} = responseKnownLength HT.status407 [(HT.hProxyAuthenticate, "Basic realm=\"" `BS.append` prompt `BS.append` "\"")] ""@@ -111,7 +109,7 @@ defaultPort = if issecure then ":443" else ":80" host | 58 `BS.elem` host' = host' -- ':' | otherwise = host' `BS.append` defaultPort- in respond $ responseLBS+ in respond $ responseKnownLength HT.status200 [("Content-Type", "application/x-ns-proxy-autoconfig")] $ LBS8.unlines [ "function FindProxyForURL(url, host) {"@@ -185,7 +183,7 @@ httpConnectProxy :: ProxySettings -> Middleware httpConnectProxy pset fallback req respond | not isConnectProxy = fallback req respond- | checkAuth pset req = respond response+ | checkAuth pset req = respondResponse | otherwise = respond (proxyAuthRequiredResponse pset) where hostPort' = parseHostPort (rawPathInfo req) <|> (requestHeaderHost req >>= parseHostPort)@@ -194,20 +192,67 @@ Just (host, port) = hostPort' settings = CN.clientSettings port host - backup = responseLBS HT.status500 [("Content-Type", "text/plain")]+ backup = responseKnownLength 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+ respondResponse+ | HT.httpMajor (httpVersion req) < 2 = respond $ responseRaw (handleConnect True) backup+ | not (naivePadding pset) = respond $ responseStream HT.status200 [] streaming+ | otherwise = do+ padding <- randomPadding+ respond $ responseStream HT.status200 [("Padding", padding)] streaming where streaming write flush = do flush handleConnect False (getRequestBodyChunk req) (\bs -> write (BB.fromByteString bs) >> flush) + maximumLength = 65535 - 3 - 255+ countPaddings = 8++ addStreamPadding = isJust (lookup "Padding" (requestHeaders req)) && naivePadding pset++ -- see: https://github.com/klzgrad/naiveproxy/#padding-protocol-an-informal-specification+ addPadding :: Int -> ConduitT BS.ByteString BS.ByteString IO ()+ addPadding 0 = awaitForever yield+ addPadding n = do+ mbs <- await+ case mbs of+ Nothing -> return ()+ Just bs | BS.null bs -> return ()+ Just bs -> do+ let (bs0, bs1) = BS.splitAt maximumLength bs+ unless (BS.null bs1) $ leftover bs1+ let len = BS.length bs0+ paddingLen <- liftIO randomPaddingLength+ let header = mconcat (map (BB.singleton.fromIntegral) [len `div` 256, len `mod` 256, paddingLen])+ body = BB.fromByteString bs0+ tailer = BB.fromByteString (BS.replicate paddingLen 0)+ yield $ LBS.toStrict $ BB.toLazyByteString (header <> body <> tailer)+ addPadding (n - 1)++ removePadding :: Int -> ConduitT BS.ByteString BS.ByteString IO ()+ removePadding 0 = awaitForever yield+ removePadding n = do+ header <- CB.take 3+ case LBS.unpack header of+ [b0, b1, b2] -> do+ let len = fromIntegral b0 * 256 + fromIntegral b1+ paddingLen = fromIntegral b2+ bs <- CB.take (fromIntegral (len + paddingLen))+ if LBS.length bs /= len + paddingLen+ then return ()+ else yield (LBS.toStrict $ LBS.take len bs) >> removePadding (n - 1)+ _ -> return ()++ yieldHttp1Response+ | naivePadding pset = do+ padding <- BB.fromByteString <$> liftIO randomPadding+ yield $ LBS.toStrict $ BB.toLazyByteString ("HTTP/1.1 200 OK\r\nPadding: " <> padding <> "\r\n\r\n")+ | otherwise = yield "HTTP/1.1 200 OK\r\n\r\n"+ handleConnect :: Bool -> IO BS.ByteString -> (BS.ByteString -> IO ()) -> IO () handleConnect http1 fromClient' toClient' = CN.runTCPClient settings $ \server -> let toServer = CN.appSink server@@ -216,8 +261,14 @@ bs <- liftIO fromClient' unless (BS.null bs) (yield bs >> fromClient) toClient = awaitForever (liftIO . toClient')++ clientToServer | addStreamPadding = fromClient .| removePadding countPaddings .| toServer+ | otherwise = fromClient .| toServer++ serverToClient | addStreamPadding = fromServer .| addPadding countPaddings .| toClient+ | otherwise = fromServer .| toClient in do- when http1 $ runConduit $ yield "HTTP/1.1 200 OK\r\n\r\n" .| toClient+ when http1 $ runConduit $ yieldHttp1Response .| toClient void $ tryAndCatchAll $ concurrently- (runConduit (fromClient .| toServer))- (runConduit (fromServer .| toClient))+ (runConduit clientToServer)+ (runConduit serverToClient)
src/Network/HProx/Util.hs view
@@ -1,15 +1,27 @@ -- SPDX-License-Identifier: Apache-2.0 -- -- Copyright (C) 2023 Bin Jin. All Rights Reserved.+ module Network.HProx.Util ( parseHostPort , parseHostPortWithDefault+ , randomPadding+ , randomPaddingLength+ , responseKnownLength ) where -import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as BS8-import Data.Maybe (fromMaybe)+import Control.Monad (replicateM)+import Data.ByteString qualified as BS+import Data.ByteString.Char8 qualified as BS8+import Data.ByteString.Lazy qualified as LBS+import Data.Maybe (fromMaybe)+import System.Random (uniformR)+import System.Random.Stateful+ (applyAtomicGen, globalStdGen, runStateGen, uniformRM) +import Network.HTTP.Types (ResponseHeaders, Status)+import Network.Wai+ parseHostPort :: BS.ByteString -> Maybe (BS.ByteString, Int) parseHostPort hostPort = do lastColon <- BS8.elemIndexEnd ':' hostPort@@ -23,3 +35,22 @@ parseHostPortWithDefault :: Int -> BS.ByteString -> (BS.ByteString, Int) parseHostPortWithDefault defaultPort hostPort = fromMaybe (hostPort, defaultPort) $ parseHostPort hostPort++randomPadding :: IO BS.ByteString+randomPadding = applyAtomicGen generate globalStdGen+ where+ nonHuffman = "!#$()+<>?@[]^`{}"+ countNonHuffman = length nonHuffman++ generate g0 = runStateGen g0 $ \gen -> do+ len <- uniformRM (32, 63) gen+ prefix <- replicateM 24 $ do+ idx <- uniformRM (0, countNonHuffman - 1) gen+ return $ nonHuffman !! idx+ return (BS8.pack (prefix ++ replicate (len - 24) '~'))++randomPaddingLength :: IO Int+randomPaddingLength = applyAtomicGen (uniformR (1, 255)) globalStdGen++responseKnownLength :: Status -> ResponseHeaders -> LBS.ByteString -> Response+responseKnownLength status headers bs = responseLBS status (headers ++ [("Content-Length", BS8.pack $ show (LBS.length bs))]) bs