diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,3 +1,9 @@ +## 0.5.0 + +- initial HTTP/3 (QUIC) support +- add logging based on fast-logger +- some minor tweaks + ## 0.4.0 - naiveproxy compatible [padding](https://github.com/klzgrad/naiveproxy/#padding-protocol-an-informal-specification) support (`--naive`) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -19,6 +19,7 @@ * 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). +* HTTP/3 (QUIC) support (`h3` protocol). * 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. @@ -47,13 +48,13 @@ 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/): +* To run `hprox` with TLS encryption on port 443, with certificate of `example.com` obtained with [acme.sh](https://acme.sh/): ```sh -hprox -p 443 -s example.com:/etc/letsencrypt/live/example.com/fullchain.pem:/etc/letsencrypt/live/example.com/privkey.pem +hprox -p 443 -s example.com:$HOME/.acme.sh/example.com/fullchain.cer:$HOME/.acme.sh/example.com/example.com.key ``` -Browsers can be configured with PAC file URL `https://example.com/get/hprox.pac`. +Browsers can be configured with PAC file URL `https://example.com/.hprox/proxy.pac`. * To work with `v2ray-plugin`, with fallback page to [ubuntu archive](http://archive.ubuntu.com/): @@ -64,10 +65,17 @@ Clients will be able to connect with plugin option `tls;host=example.com`. +* Enable HTTP/3 (QUIC) on UDP port 8443, enable DoH support (redirect to 8.8.8.8), and add `naiveproxy` compatible padding: + +```sh +hprox -p 443 -q 8443 -s example.com:fullchain.pem:privkey.pem -a userpass.txt --naive --doh 8.8.8.8 +``` + ### Known Issue * Passwords are currently stored in plain text, please set permission accordingly and avoid using existing password. +* HTTP/3 currently only works on the first domain as specified by `-s/--tls`. ### License diff --git a/hprox.cabal b/hprox.cabal --- a/hprox.cabal +++ b/hprox.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: hprox -version: 0.4.0 +version: 0.5.0 synopsis: a lightweight HTTP proxy server, and more description: Please see the README on GitHub at category: Web @@ -25,6 +25,11 @@ type: git location: https://github.com/bjin/hprox +flag quic + description: Enable QUIC (HTTP/3) support + manual: True + default: False + flag static description: Enable static build manual: True @@ -36,6 +41,7 @@ other-modules: Network.HProx.DoH Network.HProx.Impl + Network.HProx.Log Network.HProx.Util Paths_hprox hs-source-dirs: @@ -55,19 +61,28 @@ , conduit >=1.3 , conduit-extra >=1.3 , dns >=4.0 + , fast-logger >=3.0 , http-client >=0.5 , http-client-tls >=0.3.4 , http-reverse-proxy >=0.4.0 , http-types >=0.12 + , http2 >=4.0 , optparse-applicative >=0.14 - , random + , random >=1.2.1 , tls >=1.5 + , tls-session-manager >=0.0.4 , unix >=2.7 , wai >=3.2.2 , wai-extra >=3.0 , warp >=3.2.8 - , warp-tls >=3.2.5 + , warp-tls >=3.2.12 default-language: Haskell2010 + if flag(quic) + cpp-options: -DQUIC_ENABLED + build-depends: + http3 >=0.0.3 + , quic >=0.1.1 + , warp-quic executable hprox main-is: Main.hs @@ -79,7 +94,7 @@ 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 + 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 build-depends: async >=2.2 , base >=4.12 && <5 @@ -90,19 +105,28 @@ , conduit >=1.3 , conduit-extra >=1.3 , dns >=4.0 + , fast-logger >=3.0 , hprox , http-client >=0.5 , http-client-tls >=0.3.4 , http-reverse-proxy >=0.4.0 , http-types >=0.12 + , http2 >=4.0 , optparse-applicative >=0.14 - , random + , random >=1.2.1 , tls >=1.5 + , tls-session-manager >=0.0.4 , unix >=2.7 , wai >=3.2.2 , wai-extra >=3.0 , warp >=3.2.8 - , warp-tls >=3.2.5 + , warp-tls >=3.2.12 default-language: Haskell2010 + if flag(quic) + cpp-options: -DQUIC_ENABLED + build-depends: + http3 >=0.0.3 + , quic >=0.1.1 + , warp-quic if flag(static) ghc-options: -optl-static diff --git a/src/Network/HProx.hs b/src/Network/HProx.hs --- a/src/Network/HProx.hs +++ b/src/Network/HProx.hs @@ -1,6 +1,9 @@ -- SPDX-License-Identifier: Apache-2.0 --- + -- Copyright (C) 2023 Bin Jin. All Rights Reserved. +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} {-| Instead of running @hprox@ binary directly, you can use this library to run HProx in front of arbitrary WAI 'Application'. @@ -14,49 +17,73 @@ , run ) 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) -import Network.TLS qualified as TLS -import Network.TLS.Extra.Cipher qualified as TLS -import Network.Wai (Application, modifyResponse) +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.HTTP.Types qualified as HT +import Network.TLS qualified as TLS +import Network.TLS.Extra.Cipher qualified as TLS +import Network.TLS.SessionManager qualified as SM +import Network.Wai (Application, rawPathInfo) import Network.Wai.Handler.Warp - (HostPreference, defaultSettings, runSettings, setBeforeMainLoop, setHost, - setNoParsePath, setOnException, setPort, setServerName) + (InvalidRequest (..), defaultSettings, defaultShouldDisplayException, + runSettings, setBeforeMainLoop, setHost, setLogger, 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) + (OnInsecure (..), WarpTLSException, onInsecure, runTLS, tlsAllowedVersions, + tlsCiphers, tlsServerHooks, tlsSessionManager, tlsSettings) import System.Posix.User (UserEntry (..), getUserEntryForName, setUserID) +import Control.Exception (Exception (..)) +import GHC.IO.Exception (IOErrorType (..)) +import Network.HTTP2.Client qualified as H2 +import System.IO.Error (ioeGetErrorType) + +#ifdef QUIC_ENABLED +import Control.Concurrent.Async (mapConcurrently_) +import Data.List (find) +import Network.QUIC qualified as Q +import Network.QUIC.Internal qualified as Q +import Network.Wai.Handler.Warp (setAltSvc) +import Network.Wai.Handler.WarpQUIC (runQUIC) +#endif + +import Control.Monad 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.Log +import Paths_hprox -- | 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 - , _naive :: Bool + { _bind :: Maybe String + , _port :: Int + , _ssl :: [(String, CertFile)] + , _user :: Maybe String + , _auth :: Maybe FilePath + , _ws :: Maybe String + , _rev :: Maybe String + , _doh :: Maybe String + , _naive :: Bool + , _name :: BS8.ByteString + , _loglevel :: LogLevel +#ifdef QUIC_ENABLED + , _quic :: Maybe Int +#endif } -- | Default value of 'Config', same as running @hprox@ without arguments defaultConfig :: Config -defaultConfig = Config Nothing 3000 [] Nothing Nothing Nothing Nothing Nothing False +defaultConfig = Config Nothing 3000 [] Nothing Nothing Nothing Nothing Nothing False "hprox" INFO +#ifdef QUIC_ENABLED + Nothing +#endif -- | Certificate file pairs data CertFile = CertFile @@ -84,7 +111,7 @@ ver = infoOption (showVersion version) (long "version" <> help "show version") config = Config <$> bind - <*> (fromMaybe 3000 <$> port) + <*> port <*> ssl <*> user <*> auth @@ -92,18 +119,25 @@ <*> rev <*> doh <*> naive + <*> name + <*> loglevel +#ifdef QUIC_ENABLED + <*> quic +#endif - bind = optional $ fromString <$> strOption + bind = optional $ strOption ( long "bind" <> short 'b' <> metavar "bind_ip" <> help "ip address to bind on (default: all interfaces)") - port = optional $ option auto + port = option auto ( long "port" <> short 'p' <> metavar "port" - <> help "port number (default 3000)") + <> value 3000 + <> showDefault + <> help "port number") ssl = many $ option (eitherReader parseSSL) ( long "tls" @@ -139,10 +173,30 @@ <> 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)") + ( long "naive" + <> help "add naiveproxy compatible padding (requires TLS)") + name = strOption + ( long "name" + <> metavar "server-name" + <> value "hprox" + <> showDefault + <> help "specify the server name for the 'Server' header") + loglevel = option (maybeReader logLevelReader) + ( long "loglevel" + <> metavar "" + <> value INFO + <> help "specify the logging level (default: info)") + +#ifdef QUIC_ENABLED + quic = optional $ option auto + ( long "quic" + <> short 'q' + <> metavar "port" + <> help "enable QUIC (HTTP/3) on UDP port") +#endif + setuid :: String -> IO () setuid user = getUserEntryForName user >>= setUserID . userID @@ -154,23 +208,54 @@ run :: Application -- ^ fallback application -> Config -- ^ configuration -> IO () -run fallback Config{..} = do +run fallback Config{..} = withLogger (LogStdout 4096) _loglevel $ \logger -> do + logger INFO $ "hprox " <> toLogStr (showVersion version) <> " started" + logger INFO $ "bind to TCP port " <> toLogStr (fromMaybe "[::]" _bind) <> ":" <> toLogStr _port let certfiles = _ssl + certs <- mapM (readCert.snd) certfiles + smgr <- SM.newSessionManager SM.defaultConfig let isSSL = not (null certfiles) (primaryHost, primaryCert) = head certfiles otherCerts = tail $ zip (map fst certfiles) certs - settings = setHost (fromMaybe "*6" _bind) $ + when isSSL $ do + logger INFO $ "read " <> toLogStr (show $ length certs) <> " certificates" + logger INFO $ "primary domain: " <> toLogStr primaryHost + logger INFO $ "other domains: " <> toLogStr (unwords $ map fst otherCerts) + + let settings = setHost (fromString (fromMaybe "*6" _bind)) $ setPort _port $ - setOnException (\_ _ -> return ()) $ + setLogger warpLogger $ + setOnException exceptionHandler $ setNoParsePath True $ - setServerName "Apache" $ + setServerName _name $ maybe id (setBeforeMainLoop . setuid) _user defaultSettings + exceptionHandler req ex + | _loglevel > DEBUG = return () + | not (defaultShouldDisplayException ex) = return () + | Just (ioeGetErrorType -> EOF) <- fromException ex = return () + | Just (H2.BadThingHappen ex') <- fromException ex = exceptionHandler req ex' + | Just (_ :: H2.HTTP2Error) <- fromException ex = return () +#ifdef QUIC_ENABLED + | Just (Q.BadThingHappen ex') <- fromException ex = exceptionHandler req ex' + | Just (_ :: Q.QUICException) <- fromException ex = return () +#endif + | Just (_ :: WarpTLSException) <- fromException ex = return () + | Just ConnectionClosedByPeer <- fromException ex = return () + | otherwise = + logger DEBUG $ "exception: " <> toLogStr (displayException ex) <> + (if (isJust req) then " from: " <> logRequest (fromJust req) else "") + + warpLogger req status _ + | rawPathInfo req == "/.hprox/health" = return () + | otherwise = + logger TRACE $ "(" <> toLogStr (HT.statusCode status) <> ") " <> logRequest req + tlsset' = tlsSettings (certfile primaryCert) (keyfile primaryCert) hooks = (tlsServerHooks tlsset') { TLS.onServerNameIndication = onSNI } @@ -184,18 +269,21 @@ ] tlsset = tlsset' - { tlsServerHooks = hooks - , onInsecure = AllowInsecure - , tlsAllowedVersions = [TLS.TLS13, TLS.TLS12] - , tlsCiphers = TLS.ciphersuite_strong \\ weak_ciphers - } + { tlsServerHooks = hooks + , onInsecure = AllowInsecure + , tlsAllowedVersions = [TLS.TLS13, TLS.TLS12] + , tlsCiphers = TLS.ciphersuite_strong \\ weak_ciphers + , tlsSessionManager = Just smgr + } - onSNI Nothing = fail "SNI: unspecified" + logAndFail msg = logger WARN (toLogStr msg) >> fail msg + + onSNI Nothing = logAndFail "SNI: unspecified" onSNI (Just host) | checkSNI host primaryHost = return mempty | otherwise = lookupSNI host otherCerts - lookupSNI host [] = fail ("SNI: unknown hostname (" ++ show host ++ ")") + lookupSNI host [] = logAndFail ("SNI: unknown hostname (" ++ show host ++ ")") lookupSNI host ((p, cert) : cs) | checkSNI host p = return (TLS.Credentials [cert]) | otherwise = lookupSNI host cs @@ -204,21 +292,51 @@ '*' : '.' : p -> ('.' : p) `isSuffixOf` host p -> host == p - runner | isSSL = runTLS tlsset - | otherwise = runSettings +#ifdef QUIC_ENABLED + alpn _ = return . fromMaybe "" . find (== "h3") + altsvc qport = BS8.concat ["h3=\":", BS8.pack $ show qport ,"\""] + quicset qport = Q.defaultServerConfig + { Q.scAddresses = [(fromString (fromMaybe "0.0.0.0" _bind), fromIntegral qport)] + , Q.scVersions = [Q.Version1, Q.Version2] + , Q.scCredentials = TLS.Credentials [head certs] + , Q.scCiphers = Q.scCiphers Q.defaultServerConfig \\ weak_ciphers + , Q.scALPN = Just alpn + , Q.scUse0RTT = True + , Q.scSessionManager = smgr + } + + runner | not isSSL = runSettings settings + | Just qport <- _quic = \app -> do + logger INFO $ "bind to UDP port " <> toLogStr (fromMaybe "0.0.0.0" _bind) <> ":" <> toLogStr qport + mapConcurrently_ ($ app) + [ runQUIC (quicset qport) settings + , runTLS tlsset (setAltSvc (altsvc qport) settings) + ] + | otherwise = runTLS tlsset settings +#else + runner | isSSL = runTLS tlsset settings + | otherwise = runSettings settings +#endif + pauth <- case _auth of Nothing -> return Nothing - Just f -> Just . flip elem . filter (isJust . BS8.elemIndex ':') . BS8.lines <$> BS8.readFile f + Just f -> do + logger INFO $ "read username and passwords from " <> toLogStr 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) (_naive && isSSL) - proxy = (if isSSL then forceSSL pset else id) $ - modifyResponse (stripHeaders ["Server", "Date"]) $ - gzip def $ + let pset = ProxySettings pauth (Just _name) (BS8.pack <$> _ws) (BS8.pack <$> _rev) (_naive && isSSL) logger + proxy = healthCheckProvider $ + (if isSSL then forceSSL pset else id) $ httpProxy pset manager $ - reverseProxy pset manager fallback + reverseProxy pset manager $ + fallback + when (isJust _ws) $ logger INFO $ "websocket redirect: " <> toLogStr (fromJust _ws) + when (isJust _rev) $ logger INFO $ "reverse proxy: " <> toLogStr (fromJust _rev) + when (isJust _doh) $ logger INFO $ "DNS-over-HTTPS redirect: " <> toLogStr (fromJust _doh) + case _doh of - Nothing -> runner settings proxy - Just doh -> createResolver doh (\resolver -> runner settings (dnsOverHTTPS resolver proxy)) + Nothing -> runner proxy + Just doh -> createResolver doh (\resolver -> runner (dnsOverHTTPS resolver proxy)) 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 @@ -5,9 +5,11 @@ module Network.HProx.Impl ( ProxySettings (..) , forceSSL + , healthCheckProvider , httpConnectProxy , httpGetProxy , httpProxy + , logRequest , pacProvider , reverseProxy ) where @@ -37,7 +39,10 @@ import Data.Conduit import Data.Maybe import Network.Wai +import Network.Wai.Middleware.Gzip +import Network.Wai.Middleware.StripHeaders +import Network.HProx.Log import Network.HProx.Util data ProxySettings = ProxySettings @@ -46,8 +51,21 @@ , wsRemote :: Maybe BS.ByteString , revRemote :: Maybe BS.ByteString , naivePadding :: Bool + , logger :: Logger } +logRequest :: Request -> LogStr +logRequest req = toLogStr (requestMethod req) <> + " " <> hostname <> toLogStr (rawPathInfo req) <> + " " <> toLogStr (show $ httpVersion req) <> + " " <> (if isSecure req then "(tls) " else "") + <> toLogStr (show $ remoteHost req) + where + isConnect = requestMethod req == "CONNECT" + isGet = "http://" `BS.isPrefixOf` rawPathInfo req + hostname | isConnect || isGet = "" + | otherwise = toLogStr (fromMaybe "(no-host)" $ requestHeaderHost req) + httpProxy :: ProxySettings -> HC.Manager -> Middleware httpProxy set mgr = pacProvider . httpGetProxy set mgr . httpConnectProxy set @@ -69,13 +87,16 @@ "" isProxyHeader :: HT.HeaderName -> Bool -isProxyHeader k = "proxy" `BS.isPrefixOf` CI.foldedCase k +isProxyHeader h = "proxy" `BS.isPrefixOf` CI.foldedCase h isForwardedHeader :: HT.HeaderName -> Bool -isForwardedHeader k = "x-forwarded" `BS.isPrefixOf` CI.foldedCase k +isForwardedHeader h = "x-forwarded" `BS.isPrefixOf` CI.foldedCase h +isCDNHeader :: HT.HeaderName -> Bool +isCDNHeader h = "cf-" `BS.isPrefixOf` CI.foldedCase h || h == "cdn-loop" + isToStripHeader :: HT.HeaderName -> Bool -isToStripHeader h = isProxyHeader h || isForwardedHeader h || h == "X-Real-IP" || h == "X-Scheme" +isToStripHeader h = isProxyHeader h || isForwardedHeader h || isCDNHeader h || h == "X-Real-IP" || h == "X-Scheme" checkAuth :: ProxySettings -> Request -> Bool checkAuth ProxySettings{..} req @@ -100,7 +121,7 @@ pacProvider :: Middleware pacProvider fallback req respond - | pathInfo req == ["get", "hprox.pac"], + | pathInfo req == [".hprox", "config.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" @@ -118,16 +139,27 @@ ] | otherwise = fallback req respond +healthCheckProvider :: Middleware +healthCheckProvider fallback req respond + | pathInfo req == [".hprox", "health"] = + respond $ responseKnownLength + HT.status200 + [("Content-Type", "text/plain")] + "okay" + | otherwise = fallback req respond + reverseProxy :: ProxySettings -> HC.Manager -> Middleware reverseProxy ProxySettings{..} mgr fallback - | isReverseProxy = waiProxyToSettings (return.proxyResponseFor) settings mgr + | isReverseProxy = appWrapper $ 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 + (revWrapper, appWrapper) + | revPort == 443 = (WPRModifiedRequestSecure, id) + | otherwise = (WPRModifiedRequest, modifyResponse (stripHeaders ["Server", "Date"])) proxyResponseFor req = revWrapper nreq (ProxyDest revHost revPort) where @@ -142,15 +174,23 @@ ] httpGetProxy :: ProxySettings -> HC.Manager -> Middleware -httpGetProxy pset@ProxySettings{..} mgr fallback = waiProxyToSettings (return.proxyResponseFor) settings mgr +httpGetProxy pset@ProxySettings{..} mgr fallback = appWrapper $ waiProxyToSettings (return.proxyResponseFor) settings mgr where settings = defaultWaiProxySettings { wpsSetIpHeader = SIHNone } + appWrapper = ifRequest isGetProxy (gzip def) + + isGetProxy req = case proxyResponseFor req of + WPRModifiedRequest _ _ -> True + _ -> False + proxyResponseFor req | redirectWebsocket pset req = wsWrapper (ProxyDest wsHost wsPort) - | not isGetProxy = WPRApplication fallback + | not isGETProxy = WPRApplication fallback | checkAuth pset req = WPRModifiedRequest nreq (ProxyDest host port) - | otherwise = WPRResponse (proxyAuthRequiredResponse pset) + | otherwise = + pureLogger logger WARN ("unauthorized request: " <> logRequest req) $ + WPRResponse (proxyAuthRequiredResponse pset) where (wsHost, wsPort) = parseHostPortWithDefault 80 (fromJust wsRemote) wsWrapper = if wsPort == 443 then WPRProxyDestSecure else WPRProxyDest @@ -166,7 +206,7 @@ scheme = lookup "X-Scheme" (requestHeaders req) isHTTP2Proxy = HT.httpMajor (httpVersion req) >= 2 && scheme == Just "http" && isSecure req - isGetProxy = notCONNECT && (isRawPathProxy || isHTTP2Proxy || isJust hostHeader && hasProxyHeader) + isGETProxy = notCONNECT && (isRawPathProxy || isHTTP2Proxy || isJust hostHeader && hasProxyHeader) nreq = req { rawPathInfo = newRawPath @@ -181,10 +221,12 @@ BS.drop (BS.length rawPathPrefix) rawPath httpConnectProxy :: ProxySettings -> Middleware -httpConnectProxy pset fallback req respond +httpConnectProxy pset@ProxySettings{..} fallback req respond | not isConnectProxy = fallback req respond | checkAuth pset req = respondResponse - | otherwise = respond (proxyAuthRequiredResponse pset) + | otherwise = do + logger WARN $ "unauthorized request: " <> logRequest req + respond (proxyAuthRequiredResponse pset) where hostPort' = parseHostPort (rawPathInfo req) <|> (requestHeaderHost req >>= parseHostPort) isConnectProxy = requestMethod req == "CONNECT" && isJust hostPort' @@ -200,7 +242,7 @@ respondResponse | HT.httpMajor (httpVersion req) < 2 = respond $ responseRaw (handleConnect True) backup - | not (naivePadding pset) = respond $ responseStream HT.status200 [] streaming + | not naivePadding = respond $ responseStream HT.status200 [] streaming | otherwise = do padding <- randomPadding respond $ responseStream HT.status200 [("Padding", padding)] streaming @@ -212,7 +254,7 @@ maximumLength = 65535 - 3 - 255 countPaddings = 8 - addStreamPadding = isJust (lookup "Padding" (requestHeaders req)) && naivePadding pset + 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 () @@ -248,10 +290,10 @@ _ -> return () yieldHttp1Response - | naivePadding pset = do + | 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" + | 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 -> diff --git a/src/Network/HProx/Log.hs b/src/Network/HProx/Log.hs new file mode 100644 --- /dev/null +++ b/src/Network/HProx/Log.hs @@ -0,0 +1,53 @@ +-- SPDX-License-Identifier: Apache-2.0 +-- +-- Copyright (C) 2023 Bin Jin. All Rights Reserved. + +module Network.HProx.Log + ( LogLevel (..) + , LogStr + , LogType' (..) + , Logger + , ToLogStr (..) + , logLevelReader + , pureLogger + , withLogger + ) where + +import System.IO.Unsafe (unsafePerformIO) + +import System.Log.FastLogger + +data LogLevel = TRACE + | DEBUG + | INFO + | WARN + | ERROR + | NONE + deriving (Show, Eq, Ord) + +logLevelReader :: String -> Maybe LogLevel +logLevelReader "trace" = Just TRACE +logLevelReader "debug" = Just DEBUG +logLevelReader "info" = Just INFO +logLevelReader "warn" = Just WARN +logLevelReader "error" = Just ERROR +logLevelReader "none" = Just NONE +loglevelReader _ = Nothing + +logWith :: TimedFastLogger -> LogLevel -> LogStr -> IO () +logWith logger level logstr = logger (\time -> toLogStr time <> " [" <> toLogStr (show level) <> "] " <> logstr <> "\n") + +type Logger = LogLevel -> LogStr -> IO () + +{-# NOINLINE pureLogger #-} +pureLogger :: Logger -> LogLevel -> LogStr -> a -> a +pureLogger logger level str a = unsafePerformIO $ logger level str >> return a + +withLogger :: LogType -> LogLevel -> ((LogLevel -> LogStr -> IO ()) -> IO ()) -> IO () +withLogger logType logLevel toRun = do + timeCache <- newTimeCache "%Y/%m/%d %T %Z" + withTimedFastLogger timeCache logType $ \timedLogger -> + let logger level str + | level < logLevel = return () + | otherwise = logWith timedLogger level str + in toRun logger