hprox 0.4.0 → 0.5.0

raw patch · 6 files changed

+330/−79 lines, 6 filesdep +fast-loggerdep +http2dep +http3dep ~randomdep ~warp-tlsPVP ok

version bump matches the API change (PVP)

Dependencies added: fast-logger, http2, http3, quic, tls-session-manager, warp-quic

Dependency ranges changed: random, warp-tls

API changes (from Hackage documentation)

Files

• Changelog.md +6/−0
• README.md +11/−3
• hprox.cabal +30/−6
• src/Network/HProx.hs +172/−54
• src/Network/HProx/Impl.hs +58/−16
• src/Network/HProx/Log.hs +53/−0

@@ -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`)

@@ -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 

@@ -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 <https://github.com/bjin/hprox#readme> 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

@@ -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 "<trace|debug|info|warn|error|none>"+       <> 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))

@@ -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 ->

@@ -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