diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -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 diff --git a/hprox.cabal b/hprox.cabal --- a/hprox.cabal +++ b/hprox.cabal @@ -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 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: diff --git a/src/Network/HProx.hs b/src/Network/HProx.hs --- a/src/Network/HProx.hs +++ b/src/Network/HProx.hs @@ -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 diff --git a/src/Network/HProx/Impl.hs b/src/Network/HProx/Impl.hs --- a/src/Network/HProx/Impl.hs +++ b/src/Network/HProx/Impl.hs @@ -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. diff --git a/src/Network/HProx/Naive.hs b/src/Network/HProx/Naive.hs new file mode 100644 --- /dev/null +++ b/src/Network/HProx/Naive.hs @@ -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 () diff --git a/src/Network/HProx/Util.hs b/src/Network/HProx/Util.hs --- a/src/Network/HProx/Util.hs +++ b/src/Network/HProx/Util.hs @@ -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