hprox 0.5.3 → 0.5.4
raw patch · 6 files changed
+203/−108 lines, 6 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- Network.HProx: Config :: Maybe String -> Int -> [(String, CertFile)] -> Maybe FilePath -> Maybe String -> Maybe String -> Maybe String -> Bool -> Bool -> ByteString -> String -> LogLevel -> Config
+ Network.HProx: Config :: Maybe String -> Int -> [(String, CertFile)] -> Maybe FilePath -> Maybe String -> [(ByteString, ByteString)] -> Maybe String -> Bool -> Bool -> ByteString -> String -> LogLevel -> Config
- Network.HProx: [_rev] :: Config -> Maybe String
+ Network.HProx: [_rev] :: Config -> [(ByteString, ByteString)]
Files
- Changelog.md +7/−0
- hprox.cabal +3/−2
- src/Network/HProx.hs +14/−8
- src/Network/HProx/Impl.hs +41/−72
- src/Network/HProx/Naive.hs +134/−0
- src/Network/HProx/Util.hs +4/−26
Changelog.md view
@@ -1,3 +1,10 @@+## 0.5.4++- routable `--rev` reverse proxy support+- fix `Keep-Alive` header in reverse HTTP/2 proxy+- add nix based build mode+- naiveproxy padding: add protocol negotiation and packet fragmentation + ## 0.5.3 - add macos-aarch64 build
hprox.cabal view
@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.2.+-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack name: hprox-version: 0.5.3+version: 0.5.4 synopsis: a lightweight HTTP proxy server, and more description: Please see the README on GitHub at <https://github.com/bjin/hprox#readme> category: Web@@ -42,6 +42,7 @@ Network.HProx.DoH Network.HProx.Impl Network.HProx.Log+ Network.HProx.Naive Network.HProx.Util Paths_hprox hs-source-dirs:
src/Network/HProx.hs view
@@ -19,7 +19,6 @@ ) where 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)@@ -51,6 +50,7 @@ #endif import Control.Monad+import Data.List import Data.Maybe import Options.Applicative @@ -66,7 +66,7 @@ , _ssl :: [(String, CertFile)] , _auth :: Maybe FilePath , _ws :: Maybe String- , _rev :: Maybe String+ , _rev :: [(BS8.ByteString, BS8.ByteString)] , _doh :: Maybe String , _hide :: Bool , _naive :: Bool@@ -80,7 +80,7 @@ -- | Default value of 'Config', same as running @hprox@ without arguments defaultConfig :: Config-defaultConfig = Config Nothing 3000 [] Nothing Nothing Nothing Nothing False False "hprox" "stdout" INFO+defaultConfig = Config Nothing 3000 [] Nothing Nothing [] Nothing False False "hprox" "stdout" INFO #ifdef QUIC_ENABLED Nothing #endif@@ -107,6 +107,12 @@ [host, cert, key] -> Right (host, CertFile cert key) _ -> Left "invalid format for ssl certificates" + parseRev s@('/':_) = case elemIndices '/' s of+ [] -> Nothing+ indices -> let (prefix, remote) = splitAt (last indices + 1) s+ in Just (BS8.pack prefix, BS8.pack remote)+ parseRev remote = Just ("/", BS8.pack remote)+ desc = "a lightweight HTTP proxy server, and more" ver = infoOption (showVersion version) (long "version" <> help "show version") @@ -157,10 +163,10 @@ <> metavar "remote-host:port" <> help "remote host to handle websocket requests (port 443 indicates HTTPS remote server)") - rev = optional $ strOption+ rev = many $ option (maybeReader parseRev) ( long "rev"- <> metavar "remote-host:port"- <> help "remote host for reverse proxy (port 443 indicates HTTPS remote server)")+ <> metavar "[/prefix/]remote-host:port"+ <> help "remote host for reverse proxy (port 443 indicates HTTPS remote server), optional '/prefix/' can be specified as prefix to be matched (and stripped in proxied request)") doh = optional $ strOption ( long "doh"@@ -331,14 +337,14 @@ Just . flip elem . filter (isJust . BS8.elemIndex ':') . BS8.lines <$> BS8.readFile f manager <- newTlsManager - let pset = ProxySettings pauth (Just _name) (BS8.pack <$> _ws) (BS8.pack <$> _rev) _hide (_naive && isSSL) logger+ let pset = ProxySettings pauth (Just _name) (BS8.pack <$> _ws) (sortOn (negate.BS8.length.fst) _rev) _hide (_naive && isSSL) logger proxy = healthCheckProvider $ (if isSSL then forceSSL pset else id) $ httpProxy pset manager $ reverseProxy pset manager fallback when (isJust _ws) $ logger INFO $ "websocket redirect: " <> toLogStr (fromJust _ws)- when (isJust _rev) $ logger INFO $ "reverse proxy: " <> toLogStr (fromJust _rev)+ unless (null _rev) $ logger INFO $ "reverse proxy: " <> toLogStr (show _rev) when (isJust _doh) $ logger INFO $ "DNS-over-HTTPS redirect: " <> toLogStr (fromJust _doh) case _doh of
src/Network/HProx/Impl.hs view
@@ -26,7 +26,6 @@ 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@@ -43,13 +42,14 @@ import Network.Wai.Middleware.StripHeaders import Network.HProx.Log+import Network.HProx.Naive import Network.HProx.Util data ProxySettings = ProxySettings { proxyAuth :: Maybe (BS.ByteString -> Bool) , passPrompt :: Maybe BS.ByteString , wsRemote :: Maybe BS.ByteString- , revRemote :: Maybe BS.ByteString+ , revRemoteMap :: [(BS.ByteString, BS.ByteString)] , hideProxyAuth :: Bool , naivePadding :: Bool , logger :: Logger@@ -153,29 +153,32 @@ | otherwise = fallback req respond reverseProxy :: ProxySettings -> HC.Manager -> Middleware-reverseProxy ProxySettings{..} mgr fallback- | isReverseProxy = appWrapper $ waiProxyToSettings (return.proxyResponseFor) settings mgr- | otherwise = fallback+reverseProxy ProxySettings{..} mgr fallback =+ modifyResponse (stripHeaders ["Server", "Date", "Keep-Alive"]) $+ waiProxyToSettings (return.proxyResponseFor) settings mgr where settings = defaultWaiProxySettings { wpsSetIpHeader = SIHNone } - isReverseProxy = isJust revRemote- (revHost, revPort) = parseHostPortWithDefault 80 (fromJust revRemote)- (revWrapper, appWrapper)- | revPort == 443 = (WPRModifiedRequestSecure, id)- | otherwise = (WPRModifiedRequest, modifyResponse (stripHeaders ["Server", "Date"]))-- proxyResponseFor req = revWrapper nreq (ProxyDest revHost revPort)+ proxyResponseFor req = go revRemoteMap where- nreq = req- { requestHeaders = hdrs- , requestHeaderHost = Just revHost- }-- hdrs = (HT.hHost, revHost) : [ (hdn, hdv)- | (hdn, hdv) <- requestHeaders req- , not (isToStripHeader hdn) && hdn /= HT.hHost- ]+ go ((prefix, revRemote):left)+ | prefix `BS.isPrefixOf` rawPathInfo req =+ if revPort == 443+ then WPRModifiedRequestSecure nreq (ProxyDest revHost revPort)+ else WPRModifiedRequest nreq (ProxyDest revHost revPort)+ | otherwise = go left+ where+ (revHost, revPort) = parseHostPortWithDefault 80 revRemote+ nreq = req+ { requestHeaders = hdrs+ , requestHeaderHost = Just revHost+ , rawPathInfo = BS.drop (BS.length prefix - 1) (rawPathInfo req)+ }+ hdrs = (HT.hHost, revHost) : [ (hdn, hdv)+ | (hdn, hdv) <- requestHeaders req+ , not (isToStripHeader hdn) && hdn /= HT.hHost+ ]+ go _ = WPRApplication fallback httpGetProxy :: ProxySettings -> HC.Manager -> Middleware httpGetProxy pset@ProxySettings{..} mgr fallback = waiProxyToSettings (return.proxyResponseFor) settings mgr@@ -224,7 +227,9 @@ httpConnectProxy :: ProxySettings -> Middleware httpConnectProxy pset@ProxySettings{..} fallback req respond | not isConnectProxy = fallback req respond- | checkAuth pset req = respondResponse+ | checkAuth pset req = do+ when (isJust mPaddingType) $ logger DEBUG $ "naiveproxy padding type detected: " <> toLogStr (show (fromJust mPaddingType)) <> " for " <> logRequest req+ respondResponse | hideProxyAuth = do logger WARN $ "unauthorized request (hidden without response): " <> logRequest req fallback req respond@@ -255,60 +260,24 @@ res2 <- timeout (secs * 1000000) (wait unfinished) when (isNothing res2) $ cancel unfinished + mPaddingType = if naivePadding then parseRequestForPadding req else Nothing+ respondResponse | HT.httpMajor (httpVersion req) < 2 = respond $ responseRaw (handleConnect True) backup- | not naivePadding = respond $ responseStream HT.status200 [] streaming | otherwise = do- padding <- randomPadding- respond $ responseStream HT.status200 [("Padding", padding)] streaming+ paddingHeaders <- liftIO $ prepareResponseForPadding mPaddingType+ respond $ responseStream HT.status200 paddingHeaders 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-- -- 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 = 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"+ yieldHttp1Response = do+ paddingHeaders <- liftIO $ prepareResponseForPadding mPaddingType+ let headers = [ BB.fromByteString (CI.original hn) <> ": " <> BB.fromByteString hv <> "\r\n"+ | (hn, hv) <- paddingHeaders+ ]+ yield $ LBS.toStrict $ BB.toLazyByteString ("HTTP/1.1 200 OK\r\n" <> mconcat headers <> "\r\n") handleConnect :: Bool -> IO BS.ByteString -> (BS.ByteString -> IO ()) -> IO () handleConnect http1 fromClient' toClient' = CN.runTCPClient settings $ \server ->@@ -319,11 +288,11 @@ unless (BS.null bs) (yield bs >> fromClient) toClient = awaitForever (liftIO . toClient') - clientToServer | addStreamPadding = fromClient .| removePadding countPaddings .| toServer- | otherwise = fromClient .| toServer+ clientToServer | Just padding <- mPaddingType = fromClient .| removePaddingConduit padding .| toServer+ | otherwise = fromClient .| toServer - serverToClient | addStreamPadding = fromServer .| addPadding countPaddings .| toClient- | otherwise = fromServer .| toClient+ serverToClient | Just padding <- mPaddingType = fromServer .| addPaddingConduit padding .| toClient+ | otherwise = fromServer .| toClient in do when http1 $ runConduit $ yieldHttp1Response .| toClient -- gracefully close the other stream after 5 seconds if one side of stream is closed.
+ src/Network/HProx/Naive.hs view
@@ -0,0 +1,134 @@+-- SPDX-License-Identifier: Apache-2.0+--+-- Copyright (C) 2023 Bin Jin. All Rights Reserved.++module Network.HProx.Naive+ ( PaddingType (..)+ , addPaddingConduit+ , parseRequestForPadding+ , prepareResponseForPadding+ , removePaddingConduit+ ) where++import Control.Monad (replicateM, unless)+import Control.Monad.IO.Class (liftIO)+import Data.Binary.Builder qualified as BB+import Data.ByteString qualified as BS+import Data.ByteString.Char8 qualified as BS8+import Data.ByteString.Lazy qualified as LBS+import Data.Conduit.Binary qualified as CB+import Data.Maybe (mapMaybe)+import Network.HTTP.Types.Header qualified as HT+import System.Random (uniformR)+import System.Random.Stateful+ (applyAtomicGen, globalStdGen, runStateGen, uniformRM)++import Data.Conduit+import Network.Wai++randomPadding :: IO BS8.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) '~'))++randInt :: Int -> Int -> IO Int+randInt minv maxv = applyAtomicGen (uniformR (minv, maxv)) globalStdGen++-- https://github.com/klzgrad/naiveproxy/blob/master/src/net/tools/naive/naive_protocol.h#L30C12-L30C23+data PaddingType = NoPadding+ | Variant1+ deriving (Show, Eq, Ord)++parsePaddingType :: BS8.ByteString -> Maybe PaddingType+parsePaddingType "0" = Just NoPadding+parsePaddingType "1" = Just Variant1+parsePaddingType _ = Nothing++showPaddingType :: PaddingType -> BS8.ByteString+showPaddingType NoPadding = "0"+showPaddingType Variant1 = "1"++legacyPaddingHeader :: HT.HeaderName+legacyPaddingHeader = "Padding"++paddingTypeRequestHeader :: HT.HeaderName+paddingTypeRequestHeader = "Padding-Type-Request"++paddingTypeReplyHeader :: HT.HeaderName+paddingTypeReplyHeader = "Padding-Type-Reply"++type PaddingConduit = ConduitT BS.ByteString BS.ByteString IO ()++noPaddingConduit :: PaddingConduit+noPaddingConduit = awaitForever yield++addPaddingConduit :: PaddingType -> PaddingConduit+addPaddingConduit NoPadding = noPaddingConduit+addPaddingConduit Variant1 = addPaddingVariant1 countPaddingsVariant1++removePaddingConduit :: PaddingType -> PaddingConduit+removePaddingConduit NoPadding = noPaddingConduit+removePaddingConduit Variant1 = removePaddingVariant1 countPaddingsVariant1++parseRequestForPadding :: Request -> Maybe PaddingType+parseRequestForPadding req+ | Just paddingTypesStr <- lookup paddingTypeRequestHeader (requestHeaders req) =+ let paddings = mapMaybe parsePaddingType $ BS8.split ',' paddingTypesStr+ in if null paddings then Nothing else Just (head paddings)+ | Just _ <- lookup legacyPaddingHeader (requestHeaders req) = Just Variant1+ | otherwise = Nothing++prepareResponseForPadding :: Maybe PaddingType -> IO [HT.Header]+prepareResponseForPadding Nothing = return []+prepareResponseForPadding (Just paddingType) = do+ rndPadding <- randomPadding+ return [(legacyPaddingHeader, rndPadding), (paddingTypeReplyHeader, showPaddingType paddingType)]++-- see: https://github.com/klzgrad/naiveproxy/blob/master/src/net/tools/naive/naive_protocol.h#L34+countPaddingsVariant1 :: Int+countPaddingsVariant1 = 8++addPaddingVariant1 :: Int -> PaddingConduit+addPaddingVariant1 0 = noPaddingConduit+addPaddingVariant1 n = do+ mbs <- await+ case mbs of+ Nothing -> return ()+ Just bs | BS.null bs -> return ()+ Just bs -> do+ let remaining = min (BS.length bs) (65535 - 3 - 255)+ toConsume <- if remaining > 400 && remaining < 1024+ then liftIO $ randInt 200 300+ else return remaining+ let (bs0, bs1) = BS.splitAt toConsume bs+ unless (BS.null bs1) $ leftover bs1+ let len = BS.length bs0+ minPaddingLen = if len < 100 then 255 - len else 1+ paddingLen <- liftIO $ randInt minPaddingLen 255+ 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)+ addPaddingVariant1 (n - 1)++removePaddingVariant1 :: Int -> PaddingConduit+removePaddingVariant1 0 = noPaddingConduit+removePaddingVariant1 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) >> removePaddingVariant1 (n - 1)+ _ -> return ()
src/Network/HProx/Util.hs view
@@ -5,19 +5,13 @@ module Network.HProx.Util ( parseHostPort , parseHostPortWithDefault- , randomPadding- , randomPaddingLength , responseKnownLength ) where -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 Data.ByteString qualified as BS+import Data.ByteString.Char8 qualified as BS8+import Data.ByteString.Lazy qualified as LBS+import Data.Maybe (fromMaybe) import Network.HTTP.Types (ResponseHeaders, Status) import Network.Wai@@ -35,22 +29,6 @@ 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