hprox 0.7.0 → 0.7.1

raw patch · 17 files changed

+990/−627 lines, 17 filesdep +streaming-commonsPVP ok

version bump matches the API change (PVP)

Dependencies added: streaming-commons

API changes (from Hackage documentation)

Files

• CHANGELOG.md +14/−0
• README.md +1/−1
• hprox.cabal +9/−6
• src/Network/HProx.hs +12/−14
• src/Network/HProx/Config.hs +2/−2
• src/Network/HProx/DoH.hs +11/−11
• src/Network/HProx/Impl.hs +50/−40
• src/Network/HProx/Naive.hs +2/−2
• src/Network/HProx/Platform/Quic.hs +0/−87
• src/Network/HProx/Platform/Unix.hs +0/−134
• src/Network/HProx/Quic.hs +93/−0
• src/Network/HProx/Runtime.hs +190/−114
• src/Network/HProx/Unix.hs +144/−0
• test/Network/HProx/AuthSpec.hs +29/−105
• test/Network/HProx/ProxySpec.hs +200/−68
• test/Network/HProx/RuntimeSpec.hs +38/−31
• test/Network/HProx/TLSSpec.hs +195/−12

@@ -1,5 +1,19 @@ ## Unreleased +## 0.7.1++### Added+- Added SIGHUP-triggered TLS credential reloading with fingerprint-based change detection+- Added runtime-driven SNI certificate lookup backed by a mutable TLS credential store++### Changed+- Refactored Warp and QUIC to consume dynamic credentials from the runtime store instead of static defaults+- Upgraded stack dependency snapshots and pinned TLS/QUIC-related packages to newer versions++### Fixed+- Stopped QUIC from keeping stale embedded credentials by using callback-based SNI resolution at handshake time+- Fixed CONNECT tunnel handling on HTTP/1 by half-closing upstream writes when client input ends to avoid Windows hangs+ ## 0.7.0  ### Added

@@ -1,7 +1,7 @@ ## hprox  [![CircleCI](https://circleci.com/gh/bjin/hprox.svg?style=shield)](https://circleci.com/gh/bjin/hprox)-[![CirrusCI](https://api.cirrus-ci.com/github/bjin/hprox.svg)](https://cirrus-ci.com/github/bjin/hprox)+[![macos-aarch64](https://github.com/bjin/hprox/actions/workflows/macos-aarch64.yml/badge.svg)](https://github.com/bjin/hprox/actions/workflows/macos-aarch64.yml) [![Release](https://img.shields.io/github/release/bjin/hprox.svg)](https://github.com/bjin/hprox/releases) [![Hackage](https://img.shields.io/hackage/v/hprox.svg)](https://hackage.haskell.org/package/hprox) [![License](https://img.shields.io/github/license/bjin/hprox.svg)](https://github.com/bjin/hprox/blob/master/LICENSE)

@@ -5,14 +5,14 @@ -- see: https://github.com/sol/hpack  name:           hprox-version:        0.7.0+version:        0.7.1 synopsis:       a lightweight HTTP proxy server, and more description:    Please see the README on GitHub at <https://github.com/bjin/hprox#readme> category:       Web homepage:       https://github.com/bjin/hprox#readme bug-reports:    https://github.com/bjin/hprox/issues author:         Bin Jin-maintainer:     bjin@ctrl-d.org+maintainer:     bjin@protonmail.com copyright:      2026 Bin Jin license:        Apache-2.0 license-file:   LICENSE@@ -48,8 +48,8 @@       Network.HProx.Naive       Network.HProx.Route       Network.HProx.Runtime-      Network.HProx.Platform.Quic-      Network.HProx.Platform.Unix+      Network.HProx.Quic+      Network.HProx.Unix       Network.HProx.Util       Paths_hprox   hs-source-dirs:@@ -77,8 +77,10 @@     , http-reverse-proxy >=0.6.0.3     , http-types >=0.12     , http2 >=4.0+    , network     , optparse-applicative >=0.14     , random >=1.2.1+    , streaming-commons >=0.2     , text     , tls >=1.5     , tls-session-manager >=0.0.4@@ -143,10 +145,10 @@       Network.HProx.Impl       Network.HProx.Log       Network.HProx.Naive-      Network.HProx.Platform.Quic-      Network.HProx.Platform.Unix+      Network.HProx.Quic       Network.HProx.Route       Network.HProx.Runtime+      Network.HProx.Unix       Network.HProx.Util       Paths_hprox   hs-source-dirs:@@ -180,6 +182,7 @@     , network     , optparse-applicative     , random+    , streaming-commons     , text     , tls     , tls-session-manager

@@ -17,17 +17,16 @@   , run   ) where -import Control.Monad              (forM_, unless, when)-import Data.Version               (showVersion)-import Network.HTTP.Client.TLS    (newTlsManager)-import Network.TLS.SessionManager qualified as SM-import Network.Wai                (Application)+import Control.Monad           (forM_, unless, when)+import Data.Version            (showVersion)+import Network.HTTP.Client.TLS (newTlsManager)+import Network.Wai             (Application)  import Network.HProx.Auth import Network.HProx.Config import Network.HProx.Log-import Network.HProx.Platform.Unix import Network.HProx.Runtime+import Network.HProx.Unix import Paths_hprox  -- | Run HProx in front of fallback 'Application', with specified 'Config'@@ -42,14 +41,14 @@         in withLogger (logOutputType (runtimeConfigLogOutput runtimeConfig)) _loglevel $ \logger -> do             logger INFO $ "hprox " <> toLogStr (showVersion version) <> " started" -            allCerts <- loadTlsCredentials _ssl-            smgr <- SM.newSessionManager SM.defaultConfig+            credentialStore <- loadTlsCredentialStore _ssl              let isSSL = not (null _ssl)              when isSSL $ do-                logger INFO $ "read " <> toLogStr (show $ length allCerts) <> " certificates"-                logger INFO $ "domains: " <> toLogStr (unwords $ map fst allCerts)+                logger INFO $ "read " <> toLogStr (show $ length _ssl) <> " certificates"+                logger INFO $ "domains: " <> toLogStr (unwords $ map fst _ssl)+                installSighupHandler $ reloadTlsCredentialStore logger credentialStore              let beforeMainLoop = #ifdef OS_UNIX@@ -77,13 +76,12 @@              manager <- newTlsManager -            let proxyRuntime = buildProxyRuntime runtimeConfig conf logger pauth isSSL-                pset = runtimeProxySettings proxyRuntime-                revSorted = runtimeReverseRoutes proxyRuntime+            let pset = buildProxySettings runtimeConfig conf logger pauth isSSL+                revSorted = runtimeConfigReverseRouteTuples runtimeConfig                 proxy = buildProxyApplication isSSL pset manager fallback              forM_ _ws $ \ws -> logger INFO $ "websocket redirect: " <> toLogStr ws             unless (null revSorted) $ logger INFO $ "reverse proxy: " <> toLogStr (show revSorted)             forM_ _doh $ \doh -> logger INFO $ "DNS-over-HTTPS redirect: " <> toLogStr doh -            runProxyServer conf logger settings smgr allCerts proxy+            runProxyServer conf logger settings credentialStore proxy

@@ -95,8 +95,8 @@             indices -> let (prefix, remote) = splitAt (last indices + 1) s                        in Just (Nothing, BS8.pack prefix, BS8.pack remote)         if BS8.null remote-          then Nothing-          else Just (domain, prefix, remote)+        then Nothing+        else Just (domain, prefix, remote)     parseRev0 remote       | null remote = Nothing       | otherwise   = Just (Nothing, "/", BS8.pack remote)

@@ -89,11 +89,11 @@         | otherwise      = do             chunk <- readChunk             if BS.null chunk-              then return $ BS.concat $ reverse chunks-              else do-                  let (accepted, _extra) = BS.splitAt remaining chunk-                      nextRemaining = remaining - BS.length accepted-                  go nextRemaining (accepted : chunks)+            then return $ BS.concat $ reverse chunks+            else do+                let (accepted, _extra) = BS.splitAt remaining chunk+                    nextRemaining = remaining - BS.length accepted+                go nextRemaining (accepted : chunks)  readChunkedRequestBody :: IO BS.ByteString -> Int -> IO BS.ByteString readChunkedRequestBody readChunk maxLength = go 0 []@@ -101,12 +101,12 @@     go total chunks = do         chunk <- readChunk         if BS.null chunk-          then return $ BS.concat $ reverse chunks-          else do-              let nextTotal = total + BS.length chunk-              if nextTotal > maxLength-                then return ""-                else go nextTotal (chunk : chunks)+        then return $ BS.concat $ reverse chunks+        else do+            let nextTotal = total + BS.length chunk+            if nextTotal > maxLength+            then return ""+            else go nextTotal (chunk : chunks)  decodeDoHQuery :: BS8.ByteString -> Maybe DoHRequest decodeDoHQuery dnsQuery =

@@ -22,7 +22,7 @@  import Control.Applicative        ((<|>)) import Control.Concurrent.Async   (cancel, wait, waitEither, withAsync)-import Control.Exception          (IOException, SomeException, throwIO, try)+import Control.Exception          (IOException, SomeException, finally, throwIO, try) import Control.Monad              (forM_, unless, void, when) import Control.Monad.IO.Class     (liftIO) import Data.Binary.Builder        qualified as BB@@ -34,6 +34,7 @@ import Data.CaseInsensitive       qualified as CI import Data.Conduit.Network       qualified as CN import Data.IORef                 (newIORef, readIORef, writeIORef)+import Data.Streaming.Network     qualified as SN import Data.Text.Encoding         qualified as TE import Network.HTTP.Client        qualified as HC import Network.HTTP.ReverseProxy@@ -41,6 +42,7 @@     waiProxyToSettings, wpsSetIpHeader, wpsUpgradeToRaw) import Network.HTTP.Types         qualified as HT import Network.HTTP.Types.Header  qualified as HT+import Network.Socket             qualified as Socket import System.Timeout             (timeout)  import Data.Conduit@@ -245,8 +247,8 @@                 }             dest = ProxyDest (rewriteUpstream rewrite) (rewritePort rewrite)         in if rewriteSecure rewrite-             then WPRModifiedRequestSecure nreq dest-             else WPRModifiedRequest nreq dest+           then WPRModifiedRequestSecure nreq dest+           else WPRModifiedRequest nreq dest  selectHttpProxyTarget :: Request -> Maybe HttpProxyTarget selectHttpProxyTarget req@@ -300,16 +302,16 @@         | Just target@HttpProxyTarget{..} <- selectHttpProxyTarget req = do             authorized <- checkAuth pset req             if authorized-                then return $ WPRModifiedRequest-                    (proxiedRequest target)-                    (ProxyDest httpProxyTargetHost httpProxyTargetPort)-                else if hideProxyAuth-                    then do-                        logger WARN $ "unauthorized request (hidden without response): " <> logRequest req-                        return $ WPRApplication fallback-                    else do-                        logger WARN $ "unauthorized request: " <> logRequest req-                        return $ WPRResponse (proxyAuthRequiredResponse pset)+            then return $ WPRModifiedRequest+                (proxiedRequest target)+                (ProxyDest httpProxyTargetHost httpProxyTargetPort)+            else if hideProxyAuth+                 then do+                     logger WARN $ "unauthorized request (hidden without response): " <> logRequest req+                     return $ WPRApplication fallback+                 else do+                     logger WARN $ "unauthorized request: " <> logRequest req+                     return $ WPRResponse (proxyAuthRequiredResponse pset)         | otherwise = return $ WPRApplication fallback       where         websocketTarget = do@@ -317,8 +319,8 @@             let (wsHost, wsPort) = parseHostPortWithDefault 80 ws                 wsWrapper = if wsPort == 443 then WPRProxyDestSecure else WPRProxyDest             if wpsUpgradeToRaw defaultWaiProxySettings req-              then Just (ProxyDest wsHost wsPort, wsWrapper)-              else Nothing+            then Just (ProxyDest wsHost wsPort, wsWrapper)+            else Nothing          proxiedRequest target@HttpProxyTarget{..} =             let authority = renderHttpProxyAuthority target@@ -342,28 +344,28 @@ httpConnectProxyWith runTCPClient pset@ProxySettings{..} fallback req@(parseConnectProxy -> Just (host, port)) respond = do     authorized <- checkAuth pset req     if authorized-      then do-          forM_ mPaddingType $ \paddingType ->-            logger DEBUG $ "naiveproxy padding type detected: " <> toLogStr (show paddingType) <>-                           " for " <> logRequest req-          responseStarted <- newIORef False-          connected <- tryIOException $ runTCPClient settings (respondResponse responseStarted)-          case connected of-              Right received -> return received-              Left ex        -> do-                  started <- readIORef responseStarted-                  if started-                    then throwIO ex-                    else do-                        logger WARN $ "CONNECT upstream failure for " <> logRequest req <> ": " <> toLogStr (show ex)-                        respond connectFailureResponse-      else if hideProxyAuth-             then do-                 logger WARN $ "unauthorized request (hidden without response): " <> logRequest req-                 fallback req respond-             else do-                 logger WARN $ "unauthorized request: " <> logRequest req-                 respond (proxyAuthRequiredResponse pset)+    then do+        forM_ mPaddingType $ \paddingType ->+          logger DEBUG $ "naiveproxy padding type detected: " <> toLogStr (show paddingType) <>+                         " for " <> logRequest req+        responseStarted <- newIORef False+        connected <- tryIOException $ runTCPClient settings (respondResponse responseStarted)+        case connected of+            Right received -> return received+            Left ex        -> do+                started <- readIORef responseStarted+                if started+                then throwIO ex+                else do+                    logger WARN $ "CONNECT upstream failure for " <> logRequest req <> ": " <> toLogStr (show ex)+                    respond connectFailureResponse+    else if hideProxyAuth+         then do+             logger WARN $ "unauthorized request (hidden without response): " <> logRequest req+             fallback req respond+         else do+             logger WARN $ "unauthorized request: " <> logRequest req+             respond (proxyAuthRequiredResponse pset)   where     settings = CN.clientSettings port host @@ -421,8 +423,9 @@                 unless (BS.null bs) (yield bs >> fromClient)             toClient = awaitForever (liftIO . toClient') -            clientToServer | Just padding <- mPaddingType = fromClient .| removePaddingConduit padding .| toServer-                           | otherwise                    = fromClient .| toServer+            clientToServer+                | Just padding <- mPaddingType = fromClient .| removePaddingConduit padding .| toServer+                | otherwise                    = fromClient .| toServer              serverToClient | Just padding <- mPaddingType = fromServer .| addPaddingConduit padding .| toClient                            | otherwise                    = fromServer .| toClient@@ -430,6 +433,13 @@             when http1 $ runConduit $ yieldHttp1Response .| toClient             -- gracefully close the other stream after 5 seconds if one side of stream is closed.             void $ runStreams 5-                (runConduit clientToServer)+                (runConduit clientToServer `finally` shutdownServerWrite server)                 (runConduit serverToClient)++    shutdownServerWrite :: CN.AppData -> IO ()+    shutdownServerWrite server =+        case SN.appRawSocket server of+            Just sock -> void $ tryIOException $ Socket.shutdown sock Socket.ShutdownSend+            Nothing   -> return ()+ httpConnectProxyWith _ _ fallback req respond = fallback req respond

@@ -163,6 +163,6 @@                 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)+            then return ()+            else yield (LBS.toStrict $ LBS.take len bs) >> removePaddingVariant1 (n - 1)         _otherwise   -> return ()

@@ -1,87 +0,0 @@--- SPDX-License-Identifier: Apache-2.0------ Copyright (C) 2026 Bin Jin. All Rights Reserved.--{-# LANGUAGE CPP #-}--module Network.HProx.Platform.Quic-  ( quicAddressPlan-  , quicAltSvc-  , quicUse0RTT-  , runQuicAndTls-  ) where--import Data.ByteString.Char8       qualified as BS8-import Network.TLS                 qualified as TLS-import Network.Wai                 (Application)-import Network.Wai.Handler.Warp    (Settings)-import Network.Wai.Handler.WarpTLS (TLSSettings, runTLS)--import Network.HProx.Log--#ifdef QUIC_ENABLED-import Control.Concurrent.Async     (mapConcurrently_)-import Data.Default.Class           (def)-import Data.List                    (find)-import Data.Maybe                   (fromMaybe)-import Data.String                  (fromString)-import Network.QUIC.Internal        qualified as Q-import Network.Wai.Handler.Warp     (setAltSvc)-import Network.Wai.Handler.WarpQUIC (runQUIC)-#endif--quicAltSvc :: Int -> BS8.ByteString-quicAltSvc port = BS8.concat ["h3=\":", BS8.pack $ show port, "\""]--quicAddressPlan :: Maybe String -> Int -> [(String, Int)]--- Keep both wildcard sockets explicit: relying on an IPv6 wildcard socket--- to receive IPv4 traffic depends on the host IPV6_V6ONLY default, while--- QUIC creates one UDP socket per planned address and does not force that--- socket option.-quicAddressPlan Nothing port     = [("0.0.0.0", port), ("::", port)]-quicAddressPlan (Just bind) port = [(bind, port)]--quicUse0RTT :: Bool-quicUse0RTT = False--runQuicAndTls-    :: Logger-    -> Maybe String-    -> Settings-    -> TLSSettings-    -> (Maybe String -> IO TLS.Credentials)-    -> TLS.SessionManager-    -> TLS.Credential-    -> Int-    -> Application-    -> IO ()-#ifdef QUIC_ENABLED-runQuicAndTls logger bind settings tlsSettings onSNI sessionManager defaultCert qport app = do-    logger INFO $ "bind to UDP port " <> toLogStr (fromMaybe "all interfaces" bind) <> ":" <> toLogStr qport-    mapConcurrently_ ($ app)-        [ runQUIC (buildQuicServerConfig bind onSNI sessionManager defaultCert qport) settings-        , runTLS tlsSettings (setAltSvc (quicAltSvc qport) settings)-        ]--alpn :: Q.Version -> [BS8.ByteString] -> IO BS8.ByteString-alpn _ protocols = return $ fromMaybe "" $ find (== "h3") protocols--buildQuicServerConfig-    :: Maybe String-    -> (Maybe String -> IO TLS.Credentials)-    -> TLS.SessionManager-    -> TLS.Credential-    -> Int-    -> Q.ServerConfig-buildQuicServerConfig bind onSNI sessionManager cert port = Q.defaultServerConfig-    { Q.scAddresses      = [(fromString host, fromIntegral bindPort) | (host, bindPort) <- quicAddressPlan bind port]-    , Q.scVersions       = [Q.Version1, Q.Version2]-    , Q.scCredentials    = TLS.Credentials [cert]-    , Q.scALPN           = Just alpn-    , Q.scTlsHooks       = def { TLS.onServerNameIndication = onSNI }-    , Q.scUse0RTT        = quicUse0RTT-    , Q.scSessionManager = sessionManager-    }-#else-runQuicAndTls _ _ settings tlsSettings _ _ _ _ app = runTLS tlsSettings settings app-#endif

@@ -1,134 +0,0 @@--- SPDX-License-Identifier: Apache-2.0------ Copyright (C) 2026 Bin Jin. All Rights Reserved.--{-# LANGUAGE CPP                 #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Network.HProx.Platform.Unix-  ( PrivilegeDropPlan(..)-  , ResolvedGroup(..)-  , ResolvedUser(..)-  , dropRootPriviledge-  , planPrivilegeDrop-  ) where--import Control.Applicative-import Control.Monad-import Data.List           (nub, sort)--import Network.HProx.Log--#ifdef OS_UNIX-import Control.Exception    (SomeException, catch)-import System.Exit-import System.Posix.Process (exitImmediately)-import System.Posix.User-#endif--type PrivilegeID = Integer--data ResolvedUser = ResolvedUser-    { resolvedUserName           :: String-    , resolvedUserID             :: PrivilegeID-    , resolvedUserPrimaryGroupID :: PrivilegeID-    }-  deriving (Eq, Show)--data ResolvedGroup = ResolvedGroup-    { resolvedGroupName    :: String-    , resolvedGroupID      :: PrivilegeID-    , resolvedGroupMembers :: [String]-    }-  deriving (Eq, Show)--data PrivilegeDropPlan = PrivilegeDropPlan-    { privilegeDropUserName            :: Maybe String-    , privilegeDropUserID              :: Maybe PrivilegeID-    , privilegeDropGroupName           :: Maybe String-    , privilegeDropGroupID             :: Maybe PrivilegeID-    , privilegeDropSupplementaryGroups :: [PrivilegeID]-    }-  deriving (Eq, Show)--planPrivilegeDrop :: Maybe ResolvedUser -> Maybe ResolvedGroup -> [ResolvedGroup] -> PrivilegeDropPlan-planPrivilegeDrop userEntry groupEntry allGroups = PrivilegeDropPlan-    { privilegeDropUserName            = resolvedUserName <$> userEntry-    , privilegeDropUserID              = resolvedUserID <$> userEntry-    , privilegeDropGroupName           = resolvedGroupName <$> groupEntry-    , privilegeDropGroupID             = finalGroupID-    , privilegeDropSupplementaryGroups = supplementaryGroups-    }-  where-    finalGroupID = resolvedGroupID <$> groupEntry <|> resolvedUserPrimaryGroupID <$> userEntry-    supplementaryGroups = case (resolvedUserName <$> userEntry, finalGroupID) of-        (Just name, Just primaryGroupID) ->-            nub $ primaryGroupID : [resolvedGroupID entry | entry <- allGroups, name `elem` resolvedGroupMembers entry]-        _otherwise                       -> []--#ifdef OS_UNIX-dropRootPriviledge :: Logger -> Maybe String -> Maybe String -> IO Bool-dropRootPriviledge _ Nothing Nothing = return False-dropRootPriviledge logger user groupName' = do-    currentUser <- getRealUserID-    currentGroup <- getRealGroupID-    if currentUser /= 0 || currentGroup /= 0-      then do-          logger WARN $ "Unable to setuid/setgid without root priviledge" <>-                        ", userID=" <> toLogStr (show currentUser) <>-                        ", groupID=" <> toLogStr (show currentGroup)-          return False-      else do-          let abort msg = logger ERROR msg >> exitImmediately (ExitFailure 1)-          let resolveUser entry = ResolvedUser (userName entry) (fromIntegral $ userID entry) (fromIntegral $ userGroupID entry)-              resolveGroup entry = ResolvedGroup (groupName entry) (fromIntegral $ groupID entry) (groupMembers entry)-          resolvedUser <- fmap resolveUser <$> mapM getUserEntryForName user-          resolvedGroup <- fmap resolveGroup <$> mapM getGroupEntryForName groupName'-          allGroups <- maybe (return []) (const $ map resolveGroup <$> getAllGroupEntries) resolvedUser-          let plan = planPrivilegeDrop resolvedUser resolvedGroup allGroups-          case privilegeDropUserName plan of-              Just userName' -> do-                  logger INFO $ "set supplementary groups for " <> toLogStr userName'-                  setGroups $ map fromIntegral $ privilegeDropSupplementaryGroups plan-              Nothing ->-                  forM_ (privilegeDropGroupID plan) $ \_ -> do-                      logger INFO "clear supplementary groups"-                      setGroups []-          forM_ (privilegeDropGroupID plan) $ \gid -> do-              logger INFO $ "setgid to " <> maybe (toLogStr $ show gid) toLogStr (privilegeDropGroupName plan)-              setGroupID $ fromIntegral gid-              verifyGroupID abort gid-          forM_ (privilegeDropUserID plan) $ \uid -> do-              logger INFO $ "setuid to " <> maybe (toLogStr $ show uid) toLogStr (privilegeDropUserName plan)-              setUserID $ fromIntegral uid-              verifyUserID abort uid-          verifySupplementaryGroups abort $ privilegeDropSupplementaryGroups plan-          logger DEBUG "testing setuid(0), verify that root priviledge can't be regranted"-          catch (setUserID 0) $ \(_ :: SomeException) -> logger DEBUG "setuid(0) failed as expected"-          changedUser <- getRealUserID-          when (changedUser == 0) $ abort "unable to drop root priviledge, aborting"-          return True--verifyUserID :: (LogStr -> IO ()) -> PrivilegeID -> IO ()-verifyUserID abort expectedUserID = do-    realUserID <- getRealUserID-    effectiveUserID <- getEffectiveUserID-    when (fromIntegral realUserID /= expectedUserID || fromIntegral effectiveUserID /= expectedUserID || realUserID == 0) $-        abort "failed to setuid, aborting"--verifyGroupID :: (LogStr -> IO ()) -> PrivilegeID -> IO ()-verifyGroupID abort expectedGroupID = do-    realGroupID <- getRealGroupID-    effectiveGroupID <- getEffectiveGroupID-    when (fromIntegral realGroupID /= expectedGroupID || fromIntegral effectiveGroupID /= expectedGroupID || realGroupID == 0) $-        abort "failed to setgid, aborting"--verifySupplementaryGroups :: (LogStr -> IO ()) -> [PrivilegeID] -> IO ()-verifySupplementaryGroups abort expectedGroups = do-    changedGroups <- map fromIntegral <$> getGroups-    when (sort (nub changedGroups) /= sort (nub expectedGroups)) $-        abort "failed to set supplementary groups, aborting"-#else-dropRootPriviledge :: Logger -> Maybe String -> Maybe String -> IO Bool-dropRootPriviledge _ _ _ = return False-#endif

@@ -0,0 +1,93 @@+-- SPDX-License-Identifier: Apache-2.0+--+-- Copyright (C) 2026 Bin Jin. All Rights Reserved.++{-# LANGUAGE CPP #-}++module Network.HProx.Quic+  ( quicAddressPlan+  , quicAltSvc+#ifdef QUIC_ENABLED+  , buildQuicServerConfig+  , quicSessionManagerConfig+#endif+  , quicUse0RTT+  , runQuicAndTls+  ) where++import Data.ByteString.Char8       qualified as BS8+import Network.TLS                 qualified as TLS+import Network.Wai                 (Application)+import Network.Wai.Handler.Warp    (Settings)+import Network.Wai.Handler.WarpTLS (TLSSettings, runTLS)++import Network.HProx.Log++#ifdef QUIC_ENABLED+import Control.Concurrent.Async     (mapConcurrently_)+import Data.Default.Class           (def)+import Data.List                    (find)+import Data.Maybe                   (fromMaybe)+import Data.String                  (fromString)+import Network.QUIC.Internal        qualified as Q+import Network.TLS.SessionManager   qualified as SM+import Network.Wai.Handler.Warp     (setAltSvc)+import Network.Wai.Handler.WarpQUIC (runQUIC)+#endif++quicAltSvc :: Int -> BS8.ByteString+quicAltSvc port = BS8.concat ["h3=\":", BS8.pack $ show port, "\""]++quicAddressPlan :: Maybe String -> Int -> [(String, Int)]+-- Keep both wildcard sockets explicit: relying on an IPv6 wildcard socket+-- to receive IPv4 traffic depends on the host IPV6_V6ONLY default, while+-- QUIC creates one UDP socket per planned address and does not force that+-- socket option.+quicAddressPlan Nothing port     = [("0.0.0.0", port), ("::", port)]+quicAddressPlan (Just bind) port = [(bind, port)]++quicUse0RTT :: Bool+quicUse0RTT = False++runQuicAndTls+    :: Logger+    -> Maybe String+    -> Settings+    -> TLSSettings+    -> (Maybe String -> IO TLS.Credentials)+    -> Int+    -> Application+    -> IO ()+#ifdef QUIC_ENABLED+runQuicAndTls logger bind settings tlsSettings onSNI qport app = do+    logger INFO $ "bind to UDP port " <> toLogStr (fromMaybe "all interfaces" bind) <> ":" <> toLogStr qport+    sessionManager <- SM.newSessionManager quicSessionManagerConfig+    mapConcurrently_ ($ app)+        [ runQUIC (buildQuicServerConfig bind onSNI sessionManager qport) settings+        , runTLS tlsSettings (setAltSvc (quicAltSvc qport) settings)+        ]++alpn :: Q.Version -> [BS8.ByteString] -> IO BS8.ByteString+alpn _ protocols = return $ fromMaybe "" $ find (== "h3") protocols++buildQuicServerConfig+    :: Maybe String+    -> (Maybe String -> IO TLS.Credentials)+    -> TLS.SessionManager+    -> Int+    -> Q.ServerConfig+buildQuicServerConfig bind onSNI sessionManager port = Q.defaultServerConfig+    { Q.scAddresses      = [(fromString host, fromIntegral bindPort) | (host, bindPort) <- quicAddressPlan bind port]+    , Q.scVersions       = [Q.Version1, Q.Version2]+    , Q.scCredentials    = TLS.Credentials []+    , Q.scALPN           = Just alpn+    , Q.scTlsHooks       = def { TLS.onServerNameIndication = onSNI }+    , Q.scUse0RTT        = quicUse0RTT+    , Q.scSessionManager = sessionManager+    }++quicSessionManagerConfig :: SM.Config+quicSessionManagerConfig = SM.defaultConfig { SM.dbMaxSize = 0 }+#else+runQuicAndTls _ _ settings tlsSettings _ _ app = runTLS tlsSettings settings app+#endif

@@ -6,38 +6,47 @@ {-# LANGUAGE ScopedTypeVariables #-}  module Network.HProx.Runtime-  ( ProxyRuntime(..)+  ( LoadedCredential(..)   , RunnerPlan(..)   , RuntimeConfig(..)-  , StartupStep(..)+  , TlsCredentialLoader+  , TlsCredentialStore   , WarpRuntimePlan(..)   , buildProxyApplication-  , buildProxyRuntime+  , buildProxySettings   , buildRuntimeConfig   , buildTlsSettings   , buildWarpRuntimePlan   , buildWarpSettings-  , defaultCertificate+  , loadTlsCredentialFromMemory+  , loadTlsCredentialStore   , loadTlsCredentials   , lookupSNICredentials+  , lookupSNICredentialsFromStore   , lookupSNIHost+  , lookupTlsCredentialStore+  , newTlsCredentialStore+  , readTlsCredentialStore+  , reloadTlsCredentialStore   , runProxyServer   , runtimeExceptionToLog   , selectRunnerPlan-  , shouldIgnoreRuntimeException   , shouldSuppressAccessLog-  , shouldWrapDNSOverHTTPS   , sniPatternMatches-  , startupOrder   , validateRuntimeConfig   ) where +import Control.Concurrent.MVar     (MVar, newMVar, withMVar) import Control.Exception     (IOException, SomeException, displayException, fromException, try)+import Control.Monad               (zipWithM)+import Crypto.Hash                 qualified as Hash+import Data.ByteString             qualified as BS import Data.ByteString.Char8       qualified as BS8 import Data.Default.Class          (def)+import Data.IORef                  (IORef, atomicWriteIORef, newIORef, readIORef) import Data.List                   (sortOn)-import Data.Maybe                  (fromMaybe, isJust, isNothing)+import Data.Maybe                  (fromMaybe, isJust) import Data.Ord                    (Down(..)) import Data.String                 (fromString) import GHC.IO.Exception            (IOErrorType(..))@@ -56,8 +65,8 @@ import System.IO.Error (ioeGetErrorType)  #ifdef QUIC_ENABLED-import Network.HProx.Platform.Quic-import Network.QUIC.Internal       qualified as Q+import Network.HProx.Quic+import Network.QUIC.Internal qualified as Q #endif  import Network.HProx.Config@@ -73,11 +82,6 @@     }   deriving (Eq, Show) -data ProxyRuntime = ProxyRuntime-    { runtimeProxySettings :: !ProxySettings-    , runtimeReverseRoutes :: ![(Maybe BS8.ByteString, BS8.ByteString, BS8.ByteString)]-    }- data WarpRuntimePlan = WarpRuntimePlan     { runtimeBindHost    :: !String     , runtimePort        :: !Int@@ -92,19 +96,23 @@     | QuicAndTlsRunner !Int   deriving (Eq, Show) -data StartupStep-    = InitializeLogger-    | LogStartup-    | ReadCertificates-    | CreateTlsSessionManager-    | BuildSettingsAndRunner-    | LoadProxyAuth-    | CreateHttpManager-    | BuildProxyApplication-    | LogRuntimeConfig-    | StartRunner+data LoadedCredential credential = LoadedCredential+    { loadedCredentialValue                  :: !credential+    , loadedCredentialCertificateFingerprint :: !(Hash.Digest Hash.SHA256)+    , loadedCredentialKeyFingerprint         :: !(Hash.Digest Hash.SHA256)+    }   deriving (Eq, Show) +type TlsCredentialLoader credential =+    CertFile -> IO (Either String (LoadedCredential credential))++data TlsCredentialStore credential = TlsCredentialStore+    { tlsCredentialStoreSources    :: ![(String, CertFile)]+    , tlsCredentialStoreSnapshot   :: !(IORef [(String, LoadedCredential credential)])+    , tlsCredentialStoreReloadLock :: !(MVar ())+    , tlsCredentialStoreLoader     :: !(TlsCredentialLoader credential)+    }+ buildRuntimeConfig :: Config -> RuntimeConfig buildRuntimeConfig Config{..} = RuntimeConfig     { runtimeConfigLogOutput          = parseLogOutput _log@@ -114,28 +122,25 @@   where     revSorted = sortOn (\(a,b,_) -> Down (isJust a, BS8.length b)) _rev -buildProxyRuntime :: RuntimeConfig -> Config -> Logger -> Maybe (BS8.ByteString -> Bool) -> Bool -> ProxyRuntime-buildProxyRuntime RuntimeConfig{..} Config{..} logger pauth isSSL = ProxyRuntime-    { runtimeProxySettings = ProxySettings-          { proxyAuth      = pauth-          , passPrompt     = Just _name-          , wsRemote       = _ws-          , revRemoteMap   = runtimeConfigReverseRoutes-          , hideProxyAuth  = _hide-          , naivePadding   = _naive && isSSL-          , acmeThumbprint = _acme-          , logger         = logger-          }-    , runtimeReverseRoutes = runtimeConfigReverseRouteTuples+buildProxySettings :: RuntimeConfig -> Config -> Logger -> Maybe (BS8.ByteString -> Bool) -> Bool -> ProxySettings+buildProxySettings RuntimeConfig{..} Config{..} logger pauth isSSL = ProxySettings+    { proxyAuth      = pauth+    , passPrompt     = Just _name+    , wsRemote       = _ws+    , revRemoteMap   = runtimeConfigReverseRoutes+    , hideProxyAuth  = _hide+    , naivePadding   = _naive && isSSL+    , acmeThumbprint = _acme+    , logger         = logger     }  buildProxyApplication :: Bool -> ProxySettings -> HC.Manager -> Application -> Application buildProxyApplication isSSL pset manager fallback =     healthCheckProvider $-        acmeProvider pset $-            (if isSSL then forceSSL pset else id) $-                httpProxy pset manager $-                    reverseProxy pset manager fallback+    acmeProvider pset $+    (if isSSL then forceSSL pset else id) $+    httpProxy pset manager $+    reverseProxy pset manager fallback  selectRunnerPlan :: Config -> [(String, a)] -> RunnerPlan #ifdef QUIC_ENABLED@@ -148,9 +153,6 @@     _  -> TlsWarpRunner #endif -shouldWrapDNSOverHTTPS :: Config -> Bool-shouldWrapDNSOverHTTPS Config{..} = isJust _doh- validateRuntimeConfig :: Config -> Either String () validateRuntimeConfig Config{..} = do     validatePortField "--port" _port@@ -163,58 +165,33 @@     | port >= 1 && port <= 65535 = Right ()     | otherwise                  = Left $ "invalid " <> field <> ": " <> show port <> " (expected 1..65535)" -startupOrder :: [StartupStep]-startupOrder =-    [ InitializeLogger-    , LogStartup-    , ReadCertificates-    , CreateTlsSessionManager-    , BuildSettingsAndRunner-    , LoadProxyAuth-    , CreateHttpManager-    , BuildProxyApplication-    , LogRuntimeConfig-    , StartRunner-    ]- runProxyServer     :: Config     -> Logger     -> Settings-    -> TLS.SessionManager-    -> [(String, TLS.Credential)]+    -> TlsCredentialStore TLS.Credential     -> Application     -> IO ()-runProxyServer conf@Config{..} logger settings sessionManager certs app = do+runProxyServer conf@Config{..} logger settings credentialStore app = do     logger INFO $ "bind to TCP port " <> toLogStr (fromMaybe "[::]" _bind) <> ":" <> toLogStr _port     case _doh of         Nothing  -> runner app         Just doh -> createResolver doh (\resolver -> runner (dnsOverHTTPS resolver app))     where-      runner = case (selectRunnerPlan conf certs, defaultCertificate certs) of-          (PlainWarpRunner, _) -> runSettings settings-          (TlsWarpRunner, Just defaultCert) ->-              runTLS (buildTlsSettings sessionManager certs defaultCert) settings+      runner = case selectRunnerPlan conf (tlsCredentialStoreSources credentialStore) of+          PlainWarpRunner -> runSettings settings+          TlsWarpRunner ->+              runTLS (buildTlsSettings lookupSNICredentials') settings #ifdef QUIC_ENABLED-          (QuicAndTlsRunner qport, Just defaultCert) ->-              runQuicAndTls-                logger-                _bind-                settings-                (buildTlsSettings sessionManager certs defaultCert)-                lookupSNICredentials'-                sessionManager-                defaultCert-                qport+          QuicAndTlsRunner qport ->+              runQuicAndTls logger _bind settings (buildTlsSettings lookupSNICredentials') lookupSNICredentials' qport #else-          (QuicAndTlsRunner _, Just defaultCert) ->-              runTLS (buildTlsSettings sessionManager certs defaultCert) settings-#endif-          (_, Nothing) -> runSettings settings-#ifdef QUIC_ENABLED-      lookupSNICredentials' host = lookupSNICredentials host certs+          QuicAndTlsRunner _ ->+              runTLS (buildTlsSettings lookupSNICredentials') settings #endif +      lookupSNICredentials' host = lookupSNICredentialsFromStore host credentialStore+ buildWarpRuntimePlan :: Config -> WarpRuntimePlan buildWarpRuntimePlan Config{..} = WarpRuntimePlan     { runtimeBindHost    = fromMaybe "*6" _bind@@ -226,12 +203,12 @@ buildWarpSettings :: Config -> Logger -> Maybe (IO ()) -> Settings buildWarpSettings config logger beforeMainLoop =     applyBeforeMainLoop $-        setHost (fromString (runtimeBindHost plan)) $-            setPort (runtimePort plan) $-                setLogger (warpAccessLogger logger) $-                    setOnException (runtimeExceptionHandler logger (_loglevel config)) $-                        setNoParsePath (runtimeNoParsePath plan) $-                            setServerName (runtimeServerName plan) defaultSettings+    setHost (fromString (runtimeBindHost plan)) $+    setPort (runtimePort plan) $+    setLogger (warpAccessLogger logger) $+    setOnException (runtimeExceptionHandler logger (_loglevel config)) $+    setNoParsePath (runtimeNoParsePath plan) $+    setServerName (runtimeServerName plan) defaultSettings   where     plan = buildWarpRuntimePlan config     applyBeforeMainLoop = maybe id setBeforeMainLoop beforeMainLoop@@ -242,7 +219,7 @@         Nothing    -> return ()         Just ex' ->             logger DEBUG $ "exception: " <> toLogStr (displayException ex') <>-              maybe "" (\req' -> " from: " <> logRequest req') req+                maybe "" (\req' -> " from: " <> logRequest req') req  warpAccessLogger :: Logger -> Request -> HT.Status -> Maybe Integer -> IO () warpAccessLogger logger req status _@@ -253,9 +230,6 @@ shouldSuppressAccessLog :: Request -> Bool shouldSuppressAccessLog req = rawPathInfo req == "/.hprox/health" -shouldIgnoreRuntimeException :: LogLevel -> SomeException -> Bool-shouldIgnoreRuntimeException logLevel ex = isNothing (runtimeExceptionToLog logLevel ex)- runtimeExceptionToLog :: LogLevel -> SomeException -> Maybe SomeException runtimeExceptionToLog logLevel ex     | logLevel > DEBUG                                 = Nothing@@ -272,39 +246,141 @@     | Just ConnectionClosedByPeer <- fromException ex  = Nothing     | otherwise                                        = Just ex +loadTlsCredentialStore :: [(String, CertFile)] -> IO (TlsCredentialStore TLS.Credential)+loadTlsCredentialStore = newTlsCredentialStore loadTlsCredential+ loadTlsCredentials :: [(String, CertFile)] -> IO [(String, TLS.Credential)]-loadTlsCredentials certFiles = mapM readTlsCredential certFiles+loadTlsCredentials certFiles = readTlsCredentialStore =<< loadTlsCredentialStore certFiles++newTlsCredentialStore+    :: TlsCredentialLoader credential+    -> [(String, CertFile)]+    -> IO (TlsCredentialStore credential)+newTlsCredentialStore loader certFiles = do+    loadedCredentials <- mapM (loadInitialTlsCredential loader) certFiles+    snapshot <- newIORef loadedCredentials+    reloadLock <- newMVar ()+    return TlsCredentialStore+        { tlsCredentialStoreSources    = certFiles+        , tlsCredentialStoreSnapshot   = snapshot+        , tlsCredentialStoreReloadLock = reloadLock+        , tlsCredentialStoreLoader     = loader+        }++readTlsCredentialStore :: TlsCredentialStore credential -> IO [(String, credential)]+readTlsCredentialStore TlsCredentialStore{..} =+    map (fmap loadedCredentialValue) <$> readIORef tlsCredentialStoreSnapshot++reloadTlsCredentialStore :: Logger -> TlsCredentialStore credential -> IO ()+reloadTlsCredentialStore logger store@TlsCredentialStore{..} =+    withMVar tlsCredentialStoreReloadLock $ \() -> do+        logger INFO "SIGHUP received; reloading TLS certificates"+        oldSnapshot <- readIORef tlsCredentialStoreSnapshot+        newSnapshot <- zipWithM (reloadTlsCredential logger store) tlsCredentialStoreSources oldSnapshot+        atomicWriteIORef tlsCredentialStoreSnapshot newSnapshot+        logger INFO "TLS certificate reload completed"++loadInitialTlsCredential+    :: TlsCredentialLoader credential+    -> (String, CertFile)+    -> IO (String, LoadedCredential credential)+loadInitialTlsCredential loader (name, certFile) = do+    loaded <- try (loader certFile)+    case loaded of+        Left (err :: IOException) -> failWithTlsCredentialContext name certFile $ displayException err+        Right (Left err)          -> failWithTlsCredentialContext name certFile err+        Right (Right credential)  -> return (name, credential)++reloadTlsCredential+    :: Logger+    -> TlsCredentialStore credential+    -> (String, CertFile)+    -> (String, LoadedCredential credential)+    -> IO (String, LoadedCredential credential)+reloadTlsCredential logger TlsCredentialStore{..} (name, certFile) (_, oldCredential) = do+    loaded <- try (tlsCredentialStoreLoader certFile)+    case loaded of+        Left (err :: IOException) -> reloadFailed $ displayException err+        Right (Left err)          -> reloadFailed err+        Right (Right credential)+            | loadedCredentialBytesChanged oldCredential credential -> do+                logger INFO $ "installed reloaded TLS credential for " <> toLogStr (show name) <>+                    " (certificate: " <> toLogStr (certfile certFile) <>+                    ", key: " <> toLogStr (keyfile certFile) <> ")"+                return (name, credential)+            | otherwise -> return (name, oldCredential)   where-    readTlsCredential (name, CertFile cert key) = do-        loadedCredential <- try (TLS.credentialLoadX509 cert key)-        case loadedCredential of-            Left err -> failWithContext name cert key $ displayException (err :: IOException)-            Right (Left err) -> failWithContext name cert key err-            Right (Right credential) -> return (name, credential)+    reloadFailed err = do+        logTlsCredentialReloadFailure logger name certFile err+        return (name, oldCredential) -    failWithContext name cert key err =-        ioError $ userError $-            "failed to load TLS credential for " ++ show name ++-            " (certificate: " ++ cert ++ ", key: " ++ key ++ "): " ++ err+loadedCredentialBytesChanged :: LoadedCredential credential -> LoadedCredential credential -> Bool+loadedCredentialBytesChanged oldCredential newCredential =+    loadedCredentialCertificateFingerprint oldCredential /= loadedCredentialCertificateFingerprint newCredential ||+    loadedCredentialKeyFingerprint oldCredential /= loadedCredentialKeyFingerprint newCredential -buildTlsSettings :: TLS.SessionManager -> [(String, TLS.Credential)] -> TLS.Credential -> TLSSettings-buildTlsSettings sessionManager certs defaultCert = defaultTlsSettings-    { tlsServerHooks     = def { TLS.onServerNameIndication = lookupSNICredentials' }-    , tlsCredentials     = Just (TLS.Credentials [defaultCert])+loadTlsCredential :: TlsCredentialLoader TLS.Credential+loadTlsCredential (CertFile cert key) = do+    certBytes <- BS.readFile cert+    keyBytes <- BS.readFile key+    return $ loadTlsCredentialFromMemory certBytes keyBytes++loadTlsCredentialFromMemory :: BS.ByteString -> BS.ByteString -> Either String (LoadedCredential TLS.Credential)+loadTlsCredentialFromMemory certBytes keyBytes =+    case TLS.credentialLoadX509FromMemory certBytes keyBytes of+        Left err -> Left err+        Right credential@(TLS.CertificateChain chain, _)+            | null chain -> Left "loaded TLS credential has an empty certificate chain"+            | otherwise  -> Right LoadedCredential+                { loadedCredentialValue                  = credential+                , loadedCredentialCertificateFingerprint = fingerprintBytes certBytes+                , loadedCredentialKeyFingerprint         = fingerprintBytes keyBytes+                }++fingerprintBytes :: BS.ByteString -> Hash.Digest Hash.SHA256+fingerprintBytes = Hash.hash++failWithTlsCredentialContext :: String -> CertFile -> String -> IO a+failWithTlsCredentialContext name (CertFile cert key) err =+    ioError $ userError $+        "failed to load TLS credential for " ++ show name +++        " (certificate: " ++ cert ++ ", key: " ++ key ++ "): " ++ err++logTlsCredentialReloadFailure :: Logger -> String -> CertFile -> String -> IO ()+logTlsCredentialReloadFailure logger name (CertFile cert key) err =+    logger ERROR $+        "failed to reload TLS credential for " <> toLogStr (show name) <>+        " (certificate: " <> toLogStr cert <>+        ", key: " <> toLogStr key <> "): " <> toLogStr err++buildTlsSettings :: (Maybe String -> IO TLS.Credentials) -> TLSSettings+buildTlsSettings onSNI = defaultTlsSettings+    { tlsServerHooks     = def { TLS.onServerNameIndication = onSNI }+    , tlsCredentials     = Just (TLS.Credentials [])     , onInsecure         = AllowInsecure     , tlsAllowedVersions = [TLS.TLS13, TLS.TLS12]-    , tlsSessionManager  = Just sessionManager+    , tlsSessionManager  = Nothing     }-  where-    lookupSNICredentials' host = lookupSNICredentials host certs  lookupSNICredentials :: Maybe String -> [(String, TLS.Credential)] -> IO TLS.Credentials lookupSNICredentials host certs =     either fail (return . TLS.Credentials . (: [])) (lookupSNIHost host certs) -defaultCertificate :: [(String, a)] -> Maybe a-defaultCertificate []              = Nothing-defaultCertificate ((_, cert) : _) = Just cert+lookupSNICredentialsFromStore :: Maybe String -> TlsCredentialStore TLS.Credential -> IO TLS.Credentials+lookupSNICredentialsFromStore host store =+    TLS.Credentials . (: []) <$> lookupTlsCredentialStore host store++lookupTlsCredentialStore :: Maybe String -> TlsCredentialStore credential -> IO credential+lookupTlsCredentialStore host TlsCredentialStore{..} = do+    snapshot <- readIORef tlsCredentialStoreSnapshot+    case host of+        Nothing ->+            case snapshot of+                []             -> fail "SNI: no TLS credentials configured"+                (_, value) : _ -> return $ loadedCredentialValue value+        Just _ ->+            either fail (return . loadedCredentialValue) (lookupSNIHost host snapshot)+  lookupSNIHost :: Maybe String -> [(String, a)] -> Either String a lookupSNIHost Nothing _ = Left "SNI: unspecified"

@@ -0,0 +1,144 @@+-- SPDX-License-Identifier: Apache-2.0+--+-- Copyright (C) 2026 Bin Jin. All Rights Reserved.++{-# LANGUAGE CPP                 #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Network.HProx.Unix+  ( PrivilegeDropPlan(..)+  , ResolvedGroup(..)+  , ResolvedUser(..)+  , dropRootPriviledge+  , installSighupHandler+  , planPrivilegeDrop+  ) where++import Control.Applicative+import Control.Monad+import Data.List           (nub, sort)++import Network.HProx.Log++#ifdef OS_UNIX+import Control.Exception    (SomeException, catch)+import System.Exit+import System.Posix.Process (exitImmediately)+import System.Posix.Signals (Handler(Catch), installHandler, sigHUP)+import System.Posix.User+#endif++type PrivilegeID = Integer++data ResolvedUser = ResolvedUser+    { resolvedUserName           :: String+    , resolvedUserID             :: PrivilegeID+    , resolvedUserPrimaryGroupID :: PrivilegeID+    }+  deriving (Eq, Show)++data ResolvedGroup = ResolvedGroup+    { resolvedGroupName    :: String+    , resolvedGroupID      :: PrivilegeID+    , resolvedGroupMembers :: [String]+    }+  deriving (Eq, Show)++data PrivilegeDropPlan = PrivilegeDropPlan+    { privilegeDropUserName            :: Maybe String+    , privilegeDropUserID              :: Maybe PrivilegeID+    , privilegeDropGroupName           :: Maybe String+    , privilegeDropGroupID             :: Maybe PrivilegeID+    , privilegeDropSupplementaryGroups :: [PrivilegeID]+    }+  deriving (Eq, Show)++planPrivilegeDrop :: Maybe ResolvedUser -> Maybe ResolvedGroup -> [ResolvedGroup] -> PrivilegeDropPlan+planPrivilegeDrop userEntry groupEntry allGroups = PrivilegeDropPlan+    { privilegeDropUserName            = resolvedUserName <$> userEntry+    , privilegeDropUserID              = resolvedUserID <$> userEntry+    , privilegeDropGroupName           = resolvedGroupName <$> groupEntry+    , privilegeDropGroupID             = finalGroupID+    , privilegeDropSupplementaryGroups = supplementaryGroups+    }+  where+    finalGroupID = resolvedGroupID <$> groupEntry <|> resolvedUserPrimaryGroupID <$> userEntry+    supplementaryGroups = case (resolvedUserName <$> userEntry, finalGroupID) of+        (Just name, Just primaryGroupID) ->+            nub $ primaryGroupID : [resolvedGroupID entry | entry <- allGroups, name `elem` resolvedGroupMembers entry]+        _otherwise                       -> []++#ifdef OS_UNIX+installSighupHandler :: IO () -> IO ()+installSighupHandler action = do+    _ <- installHandler sigHUP (Catch action) Nothing+    return ()++dropRootPriviledge :: Logger -> Maybe String -> Maybe String -> IO Bool+dropRootPriviledge _ Nothing Nothing = return False+dropRootPriviledge logger user groupName' = do+    currentUser <- getRealUserID+    currentGroup <- getRealGroupID+    if currentUser /= 0 || currentGroup /= 0+    then do+        logger WARN $ "Unable to setuid/setgid without root priviledge" <>+                      ", userID=" <> toLogStr (show currentUser) <>+                      ", groupID=" <> toLogStr (show currentGroup)+        return False+    else do+        let abort msg = logger ERROR msg >> exitImmediately (ExitFailure 1)+        let resolveUser entry = ResolvedUser (userName entry) (fromIntegral $ userID entry) (fromIntegral $ userGroupID entry)+            resolveGroup entry = ResolvedGroup (groupName entry) (fromIntegral $ groupID entry) (groupMembers entry)+        resolvedUser <- fmap resolveUser <$> mapM getUserEntryForName user+        resolvedGroup <- fmap resolveGroup <$> mapM getGroupEntryForName groupName'+        allGroups <- maybe (return []) (const $ map resolveGroup <$> getAllGroupEntries) resolvedUser+        let plan = planPrivilegeDrop resolvedUser resolvedGroup allGroups+        case privilegeDropUserName plan of+            Just userName' -> do+                logger INFO $ "set supplementary groups for " <> toLogStr userName'+                setGroups $ map fromIntegral $ privilegeDropSupplementaryGroups plan+            Nothing ->+                forM_ (privilegeDropGroupID plan) $ \_ -> do+                    logger INFO "clear supplementary groups"+                    setGroups []+        forM_ (privilegeDropGroupID plan) $ \gid -> do+            logger INFO $ "setgid to " <> maybe (toLogStr $ show gid) toLogStr (privilegeDropGroupName plan)+            setGroupID $ fromIntegral gid+            verifyGroupID abort gid+        forM_ (privilegeDropUserID plan) $ \uid -> do+            logger INFO $ "setuid to " <> maybe (toLogStr $ show uid) toLogStr (privilegeDropUserName plan)+            setUserID $ fromIntegral uid+            verifyUserID abort uid+        verifySupplementaryGroups abort $ privilegeDropSupplementaryGroups plan+        logger DEBUG "testing setuid(0), verify that root priviledge can't be regranted"+        catch (setUserID 0) $ \(_ :: SomeException) -> logger DEBUG "setuid(0) failed as expected"+        changedUser <- getRealUserID+        when (changedUser == 0) $ abort "unable to drop root priviledge, aborting"+        return True++verifyUserID :: (LogStr -> IO ()) -> PrivilegeID -> IO ()+verifyUserID abort expectedUserID = do+    realUserID <- getRealUserID+    effectiveUserID <- getEffectiveUserID+    when (fromIntegral realUserID /= expectedUserID || fromIntegral effectiveUserID /= expectedUserID || realUserID == 0) $+        abort "failed to setuid, aborting"++verifyGroupID :: (LogStr -> IO ()) -> PrivilegeID -> IO ()+verifyGroupID abort expectedGroupID = do+    realGroupID <- getRealGroupID+    effectiveGroupID <- getEffectiveGroupID+    when (fromIntegral realGroupID /= expectedGroupID || fromIntegral effectiveGroupID /= expectedGroupID || realGroupID == 0) $+        abort "failed to setgid, aborting"++verifySupplementaryGroups :: (LogStr -> IO ()) -> [PrivilegeID] -> IO ()+verifySupplementaryGroups abort expectedGroups = do+    changedGroups <- map fromIntegral <$> getGroups+    when (sort (nub changedGroups) /= sort (nub expectedGroups)) $+        abort "failed to set supplementary groups, aborting"+#else+dropRootPriviledge :: Logger -> Maybe String -> Maybe String -> IO Bool+dropRootPriviledge _ _ _ = return False++installSighupHandler :: IO () -> IO ()+installSighupHandler _ = return ()+#endif

@@ -6,22 +6,14 @@   ( spec   ) where -import Control.Concurrent        (threadDelay)-import Control.Concurrent.Async  (cancel, withAsync)-import Control.Exception         (SomeException, bracket, finally, try)-import Data.ByteString           qualified as BS-import Data.ByteString.Char8     qualified as BS8+import Control.Exception     (bracket)+import Data.ByteString       qualified as BS+import Data.ByteString.Char8 qualified as BS8 import Data.IORef-import Data.Maybe                (mapMaybe)-import Network.HTTP.Types        qualified as HT-import Network.Socket-import Network.Socket.ByteString qualified as SocketBS-import Network.Wai               (Application, responseLBS)-import System.Directory          (removeFile)-import System.IO                 (hClose, openTempFile)-import System.Log.FastLogger     qualified as FL+import System.Directory      (removeFile)+import System.IO             (hClose, openTempFile)+import System.Log.FastLogger qualified as FL -import Network.HProx import Network.HProx.Auth import Network.HProx.Util @@ -30,38 +22,38 @@ spec :: Spec spec =   describe "auth file handling" $ do-    it "does not require proxy auth when no auth file is configured" $-      withHProx Nothing $ \port -> do-        response <- rawHttpRequest port $ BS8.concat-          [ "GET http://127.0.0.1:"-          , BS8.pack (show port)-          , "/.hprox/health HTTP/1.1\r\nHost: 127.0.0.1:"-          , BS8.pack (show port)-          , "\r\n\r\n"-          ]-        responseStatus response `shouldBe` HT.status200+    it "does not require proxy auth when no auth file is configured" $ do+      verifier <- loadProxyAuth (\_ _ -> return ()) Nothing+      case verifier of+        Nothing -> return ()+        Just _  -> expectationFailure "expected no proxy auth verifier"      it "hashes plaintext entries, ignores invalid lines, and rewrites salted entries" $       withTempAuthFile "alice:secret\ninvalid-line\nbob:too:many:fields\n" $ \path -> do-        withHProx (Just path) $ \_port -> do-          rewritten <- BS8.lines <$> BS.readFile path-          case rewritten of-            [line] -> case passwordReader line of-              Just ("alice", Salted salt hash) -> do-                line `shouldBe` passwordWriter "alice" (PasswordSalted salt hash)-                verifyPassword (PasswordSalted salt hash) "secret" `shouldBe` True-                verifyPassword (PasswordSalted salt hash) "wrong" `shouldBe` False-              parsed -> expectationFailure $ "unexpected rewritten auth line: " <> show parsed-            lines' -> expectationFailure $ "unexpected rewritten auth file line count: " <> show (length lines')+        verifier <- loadProxyAuth (\_ _ -> return ()) (Just path)+        case verifier of+          Just verify -> do+            verify "alice:secret" `shouldBe` True+            verify "alice:wrong" `shouldBe` False+          Nothing -> expectationFailure "expected proxy auth verifier"+        rewritten <- BS8.lines <$> BS.readFile path+        case rewritten of+          [line] -> case passwordReader line of+            Just ("alice", Salted salt hash) -> do+              line `shouldBe` passwordWriter "alice" (PasswordSalted salt hash)+              verifyPassword (PasswordSalted salt hash) "secret" `shouldBe` True+              verifyPassword (PasswordSalted salt hash) "wrong" `shouldBe` False+            parsed -> expectationFailure $ "unexpected rewritten auth line: " <> show parsed+          lines' -> expectationFailure $ "unexpected rewritten auth file line count: " <> show (length lines')      it "keeps an already salted file unchanged" $ do       salted <- hashPasswordWithRandomSalt (PlainText "secret")       let line = passwordWriter "alice" salted           original = line <> "\n"       withTempAuthFile original $ \path -> do-        withHProx (Just path) $ \_port -> do-          rewritten <- BS.readFile path-          rewritten `shouldBe` original+        _ <- loadProxyAuth (\_ _ -> return ()) (Just path)+        rewritten <- BS.readFile path+        rewritten `shouldBe` original      it "normalizes CRLF plaintext entries before hashing and verification" $       withTempAuthFile "alice:secret\r\n" $ \path -> do@@ -98,71 +90,3 @@      cleanup (path, ()) = removeFile path -withHProx :: Maybe FilePath -> (Int -> IO a) -> IO a-withHProx authPath action = do-  port <- getFreePort-  let conf = defaultConfig-        { _bind     = Just "127.0.0.1"-        , _port     = port-        , _auth     = authPath-        , _log      = "none"-        , _loglevel = NONE-        }-  withAsync (run fallback conf) $ \server -> do-    waitForHealth port-    action port `finally` cancel server--fallback :: Application-fallback _req respond = respond $ responseLBS HT.status200 [] "fallback"--getFreePort :: IO Int-getFreePort = bracket open close socketPortInt-  where-    open = do-      sock <- socket AF_INET Stream defaultProtocol-      setSocketOption sock ReuseAddr 1-      bind sock (SockAddrInet 0 (tupleToHostAddress (127, 0, 0, 1)))-      return sock--    socketPortInt sock = fromIntegral <$> socketPort sock--waitForHealth :: Int -> IO ()-waitForHealth port = go (200 :: Int)-  where-    go 0 = expectationFailure "hprox server did not become ready"-    go attempts = do-      response <- try (rawHttpRequest port $ BS8.concat-        [ "GET /.hprox/health HTTP/1.1\r\nHost: 127.0.0.1:"-        , BS8.pack (show port)-        , "\r\n\r\n"-        ]) :: IO (Either SomeException BS.ByteString)-      case response of-        Right bytes | responseStatus bytes == HT.status200 -> return ()-        _                                                  -> threadDelay 10000 >> go (attempts - 1)--rawHttpRequest :: Int -> BS.ByteString -> IO BS.ByteString-rawHttpRequest port request = bracket open close sendReceive-  where-    open = do-      sock <- socket AF_INET Stream defaultProtocol-      connect sock (SockAddrInet (fromIntegral port) (tupleToHostAddress (127, 0, 0, 1)))-      return sock--    sendReceive sock = do-      SocketBS.sendAll sock request-      SocketBS.recv sock 4096--responseStatus :: BS.ByteString -> HT.Status-responseStatus response =-  case mapMaybe parseStatusLine (take 1 $ BS8.lines response) of-    status : _ -> status-    []         -> HT.mkStatus 0 "invalid response"--parseStatusLine :: BS.ByteString -> Maybe HT.Status-parseStatusLine line = case BS8.words line of-  _version : codeBytes : reasonWords -> do-    (code, rest) <- BS8.readInt codeBytes-    if BS.null rest-      then Just $ HT.mkStatus code $ BS8.unwords reasonWords-      else Nothing-  _ -> Nothing

@@ -6,23 +6,32 @@   ( spec   ) where -import Control.Concurrent.Async   (withAsync)-import Control.Exception          (AsyncException(..), SomeException, bracket, throwIO, try)-import Control.Monad              (unless)-import Data.ByteString.Base64     qualified as B64-import Data.ByteString.Char8      qualified as BS8-import Data.ByteString.Lazy       qualified as LBS-import Data.ByteString.Lazy.Char8 qualified as LBS8+import Control.Concurrent              (forkIO)+import Control.Concurrent.Async        (withAsync)+import Control.Concurrent.MVar         (newEmptyMVar, putMVar, takeMVar)+import Control.Exception+    (AsyncException(..), IOException, SomeException, bracket, bracketOnError, finally, throwIO, try)+import Control.Monad                   (unless)+import Data.ByteString                 qualified as BS+import Data.ByteString.Base64          qualified as B64+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.IORef-import Network.HTTP.Client        qualified as HC-import Network.HTTP.Types         qualified as HT-import Network.HTTP.Types.Header  qualified as HT+import Data.Maybe                      (fromMaybe, mapMaybe)+import Data.Streaming.Network          qualified as CN+import Data.Streaming.Network.Internal (AppData(..))+import Network.HTTP.Client             qualified as HC+import Network.HTTP.Types              qualified as HT+import Network.HTTP.Types.Header       qualified as HT import Network.Socket-import Network.Socket.ByteString  qualified as SocketBS+import Network.Socket.ByteString       qualified as SocketBS import Network.Wai-import Network.Wai.Handler.Warp   qualified as Warp+import Network.Wai.Internal            (Response(..), ResponseReceived(..)) import Network.Wai.Test-import System.Log.FastLogger      qualified as FL+import System.Log.FastLogger           qualified as FL+import System.Timeout                  (timeout)  import Network.HProx.Impl @@ -37,7 +46,7 @@       lookup "Proxy-Authenticate" (simpleHeaders response) `shouldBe` Just "Basic realm=\"hprox\""      it "accepts valid Basic credentials" $-      Warp.testWithApplication (pure observeProxyRequestApp) $ \port -> do+      withRawHttpServer (const "ok") $ \port -> do         response <- runProxyApp (httpProxy authorizedSettings) (proxyRequestForPort port basicAliceSecret)         simpleStatus response `shouldBe` HT.status200 @@ -54,7 +63,7 @@       simpleStatus response `shouldBe` HT.status407      it "redacts proxy auth passwords in trace logs" $-      Warp.testWithApplication (pure observeProxyRequestApp) $ \port -> do+      withRawHttpServer (const "ok") $ \port -> do         logs <- newIORef []         let loggingSettings = authorizedSettings               { logger = \_ msg -> modifyIORef' logs (LBS.fromStrict (FL.fromLogStr msg) :)@@ -83,11 +92,10 @@       simpleStatus response `shouldBe` fallbackStatus       simpleBody response `shouldBe` fallbackBody -    it "establishes an HTTP/1 CONNECT tunnel after upstream connection succeeds" $-      withTcpEchoServer $ \targetPort ->-        Warp.testWithApplication (pure $ httpConnectProxy authorizedSettings fallback) $ \proxyPort -> do-          response <- rawConnectRoundTrip proxyPort targetPort-          response `shouldBe` "ping"+    it "establishes an HTTP/1 CONNECT tunnel after upstream connection succeeds" $ do+      response <- rawConnectRoundTrip+      response `shouldBe` "ping"+     it "returns 502 when upstream CONNECT fails before tunnel establishment" $ do       port <- getFreePort       response <- runConnectApp authorizedSettings (connectRequestFor "127.0.0.1" port HT.http11)@@ -180,7 +188,7 @@    describe "HTTP proxy upstream requests" $     it "uses absolute URI authority for Host and strips proxy boundary headers" $-      Warp.testWithApplication (pure observeProxyRequestApp) $ \port -> do+      withRawHttpServer observeRawProxyRequestBody $ \port -> do         let authority = "127.0.0.1:" <> BS8.pack (show port)             responseBody = LBS8.lines . simpleBody             proxiedReq = defaultRequest@@ -210,10 +218,115 @@                      , "False"                      , "True"                      ]++-- Keep proxy upstream tests independent of Warp's Windows accept loop.+withRawHttpServer :: (BS.ByteString -> LBS.ByteString) -> (Int -> IO a) -> IO a+withRawHttpServer responseBody action =+  bracket open cleanup run+  where+    open = do+      accepted <- newIORef Nothing+      sock <- openTcpServerSocket+      return (sock, accepted)++    cleanup (sock, accepted) = do+      closeIgnoringErrors sock+      readIORef accepted >>= mapM_ closeIgnoringErrors++    run server@(sock, _) = do+      done <- newEmptyMVar+      _ <- forkIO $ try (acceptAndRespond server) >>= putMVar done+      result <- action . fromIntegral =<< socketPort sock+      serverResult <- timeout 2000000 (takeMVar done)+      case serverResult of+        Just (Left ex) -> throwIO (ex :: SomeException)+        _              -> return result++    acceptAndRespond (sock, accepted) =+      bracket (acceptClient sock accepted) closeIgnoringErrors $ \conn -> do+        requestBytes <- recvHttpRequest conn+        sendHttpResponse conn $ responseBody requestBytes++    acceptClient sock accepted = do+      (conn, _) <- accept sock+      writeIORef accepted (Just conn)+      return conn++openTcpServerSocket :: IO Socket+openTcpServerSocket = bracketOnError open closeIgnoringErrors $ \sock -> do+  setSocketOption sock ReuseAddr 1+  bind sock (SockAddrInet 0 loopbackAddress)+  listen sock (max 2048 maxListenQueue)+  return sock+  where+    open = socket AF_INET Stream defaultProtocol++recvHttpRequest :: Socket -> IO BS.ByteString+recvHttpRequest conn = go BS.empty+  where+    go received+      | "\r\n\r\n" `BS.isInfixOf` received = return received+      | BS.length received > 65536 = ioError $ userError "upstream HTTP request headers exceeded test limit"+      | otherwise = do+          chunk <- recvWithTimeout conn+          if BS.null chunk+            then ioError $ userError "upstream HTTP request ended before headers completed"+            else go (received <> chunk)++sendHttpResponse :: Socket -> LBS.ByteString -> IO ()+sendHttpResponse conn body =+  let strictBody = LBS.toStrict body+  in SocketBS.sendAll conn $ BS8.concat+       [ "HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\nContent-Length: "+       , BS8.pack (show $ BS.length strictBody)+       , "\r\nConnection: close\r\n\r\n"+       , strictBody+       ]++closeIgnoringErrors :: Socket -> IO ()+closeIgnoringErrors sock = do+  closed <- try (close sock) :: IO (Either IOException ())+  case closed of+    Left _   -> return ()+    Right () -> return ()++observeRawProxyRequestBody :: BS.ByteString -> LBS.ByteString+observeRawProxyRequestBody requestBytes =+  LBS8.unlines+    [ LBS.fromStrict $ headerValue HT.hHost+    , LBS.fromStrict $ headerValue HT.hHost+    , LBS8.pack $ show $ hasHeader HT.hProxyAuthorization+    , LBS8.pack $ show $ hasHeader "Forwarded"+    , LBS8.pack $ show $ hasHeader "X-Forwarded-For"+    , LBS8.pack $ show $ hasHeader "Proxy-Connection"+    , LBS8.pack $ show $ hasHeader "cf-ray"+    , LBS8.pack $ show $ hasHeader "User-Agent"+    ]+  where+    headers = mapMaybe parseHeader $ takeWhile (not . BS.null) $ drop 1 $ map trimCR $ BS8.lines requestBytes+    normalizedHeaders = [(CI.mk name, value) | (name, value) <- headers]++    headerValue name = fromMaybe "" $ lookup name normalizedHeaders+    hasHeader name = lookup name normalizedHeaders /= Nothing++    parseHeader line =+      let (name, rest) = BS8.break (== ':') line+      in if BS.null rest+         then Nothing+         else Just (name, BS8.dropWhile (== ' ') $ BS.drop 1 rest)++    trimCR line+      | "\r" `BS.isSuffixOf` line = BS.init line+      | otherwise                 = line+ runProxyApp :: (HC.Manager -> Middleware) -> Request -> IO SResponse  runProxyApp middleware req = do-  manager <- HC.newManager HC.defaultManagerSettings+  manager <- HC.newManager $+    HC.managerSetProxy HC.noProxy HC.defaultManagerSettings+      { HC.managerIdleConnectionCount = 0+      , HC.managerResponseTimeout = HC.responseTimeoutMicro 2000000+      }   runSession (srequest $ SRequest req "") (middleware manager fallback)  runConnectApp :: ProxySettings -> Request -> IO SResponse@@ -292,46 +405,81 @@     socketPortInt sock = fromIntegral <$> socketPort sock  withTcpEchoServer :: (Int -> IO a) -> IO a-withTcpEchoServer action = bracket open close run+withTcpEchoServer action = do+  accepted <- newIORef Nothing+  bracket (open accepted) cleanup run   where-    open = do-      sock <- socket AF_INET Stream defaultProtocol-      setSocketOption sock ReuseAddr 1-      bind sock (SockAddrInet 0 loopbackAddress)-      listen sock 1-      return sock+    open accepted = do+      sock <- openTcpServerSocket+      return (sock, accepted) -    run sock =-      withAsync (bracket (fst <$> accept sock) close echoLoop) $ \_ ->-        action . fromIntegral =<< socketPort sock+    cleanup (sock, accepted) = do+      closeIgnoringErrors sock+      readIORef accepted >>= mapM_ closeIgnoringErrors +    run server@(sock, _) =+      withAsync (acceptAndEcho server) $ \_ ->+        (action . fromIntegral =<< socketPort sock) `finally` cleanup server++    acceptAndEcho (sock, accepted) =+      bracket (acceptClient sock accepted) closeIgnoringErrors echoLoop++    acceptClient sock accepted = do+      (conn, _) <- accept sock+      writeIORef accepted (Just conn)+      return conn+     echoLoop conn = do       bs <- SocketBS.recv conn 4096       unless (BS8.null bs) $ do         SocketBS.sendAll conn bs         echoLoop conn -rawConnectRoundTrip :: Int -> Int -> IO BS8.ByteString-rawConnectRoundTrip proxyPort targetPort = bracket open close $ \sock -> do-  SocketBS.sendAll sock $ BS8.concat-    [ "CONNECT 127.0.0.1:"-    , BS8.pack (show targetPort)-    , " HTTP/1.1\r\nHost: 127.0.0.1:"-    , BS8.pack (show targetPort)-    , "\r\nProxy-Authorization: "-    , basicAliceSecret-    , "\r\n\r\n"-    ]-  response <- SocketBS.recv sock 4096-  response `shouldSatisfy` BS8.isPrefixOf "HTTP/1.1 200"-  SocketBS.sendAll sock "ping"-  SocketBS.recv sock 4096-  where-    open = do-      sock <- socket AF_INET Stream defaultProtocol-      connect sock (SockAddrInet (fromIntegral proxyPort) loopbackAddress)-      return sock +-- Exercise the HTTP/1 raw response path without running a nested Warp server.+rawConnectRoundTrip :: IO BS8.ByteString+rawConnectRoundTrip = do+  outbound <- newIORef []+  clientChunks <- newIORef ["ping", ""]+  let targetHost = "127.0.0.1"+      targetPort = 18443+      runTCPClient settings app = do+        CN.getHost settings `shouldBe` targetHost+        CN.getPort settings `shouldBe` targetPort+        inbound <- newEmptyMVar+        app AppData+          { appRead' = takeMVar inbound+          , appWrite' = \bytes -> do+              putMVar inbound bytes+              putMVar inbound BS.empty+          , appSockAddr' = SockAddrInet 0 loopbackAddress+          , appLocalAddr' = Nothing+          , appCloseConnection' = return ()+          , appRawSocket' = Nothing+          }+      nextClientChunk =+        atomicModifyIORef' clientChunks $ \chunks ->+          case chunks of+            []     -> ([], BS.empty)+            x : xs -> (xs, x)+      respondRaw (ResponseRaw raw _) = do+        raw nextClientChunk (\bytes -> modifyIORef' outbound (bytes :))+        return ResponseReceived+      respondRaw _ = expectationFailure "expected HTTP/1 raw CONNECT response" >> return ResponseReceived+  _ <- httpConnectProxyWith runTCPClient authorizedSettings fallback (connectRequestFor targetHost targetPort HT.http11) respondRaw+  sent <- BS.concat . reverse <$> readIORef outbound+  sent `shouldSatisfy` BS8.isPrefixOf "HTTP/1.1 200"+  case BS.breakSubstring "\r\n\r\n" sent of+    (_, body) | not (BS.null body) -> return $ BS.drop 4 body+    _                             -> expectationFailure "raw CONNECT response did not contain an HTTP header terminator" >> return BS.empty++recvWithTimeout :: Socket -> IO BS8.ByteString+recvWithTimeout sock = do+  received <- timeout 2000000 (SocketBS.recv sock 4096)+  case received of+    Just bytes -> return bytes+    Nothing    -> ioError $ userError "timed out waiting for proxy socket response"+ loopbackAddress :: HostAddress loopbackAddress = tupleToHostAddress (127, 0, 0, 1) @@ -371,19 +519,3 @@   , logger         = \_ _ -> return ()   } -observeProxyRequestApp :: Application-observeProxyRequestApp req respond = respond $ responseLBS-  HT.status200-  [("Content-Type", "text/plain")]-  (LBS8.unlines-     [ LBS.fromStrict $ maybe "" id $ requestHeaderHost req-     , LBS.fromStrict $ maybe "" id $ lookup HT.hHost (requestHeaders req)-     , LBS8.pack $ show $ hasHeader HT.hProxyAuthorization-     , LBS8.pack $ show $ hasHeader "Forwarded"-     , LBS8.pack $ show $ hasHeader "X-Forwarded-For"-     , LBS8.pack $ show $ hasHeader "Proxy-Connection"-     , LBS8.pack $ show $ hasHeader "cf-ray"-     , LBS8.pack $ show $ hasHeader "User-Agent"-     ])-  where-    hasHeader name = lookup name (requestHeaders req) /= Nothing

@@ -9,19 +9,22 @@   ) where  import Control.Exception           (SomeException, displayException, toException)+import Data.Maybe                  (isJust, isNothing) import GHC.IO.Exception            (IOErrorType(..)) import Network.HTTP2.Client        qualified as H2+import Network.TLS                 qualified as TLS import Network.Wai import Network.Wai.Handler.Warp import Network.Wai.Handler.WarpTLS import System.IO.Error             (mkIOError)  #ifdef QUIC_ENABLED-import Network.HProx.Platform.Quic-import Network.QUIC.Internal       qualified as Q+import Network.HProx.Quic+import Network.QUIC.Internal      qualified as Q+import Network.TLS.SessionManager qualified as SM #endif #ifdef OS_UNIX-import Network.HProx.Platform.Unix+import Network.HProx.Unix #endif  import Network.HProx.Config@@ -84,6 +87,16 @@           , runtimeNoParsePath = True           } +    it "uses dynamic SNI credentials and disables reusable TLS sessions" $ do+      let settings = buildTlsSettings $ \_ -> return $ TLS.Credentials []+      case tlsCredentials settings of+        Just (TLS.Credentials credentials) -> credentials `shouldBe` []+        Nothing -> expectationFailure "expected explicit empty TLS credentials"+      case tlsSessionManager settings of+        Nothing -> return ()+        Just _  -> expectationFailure "expected disabled TLS session manager"+      TLS.Credentials credentials <- TLS.onServerNameIndication (tlsServerHooks settings) Nothing+      credentials `shouldBe` []   describe "runner selection" $ do     it "selects the plain Warp runner when no certificates are configured" $       selectRunnerPlan defaultConfig [] `shouldBe` PlainWarpRunner@@ -104,6 +117,19 @@       quicAddressPlan Nothing 8443 `shouldBe` [("0.0.0.0", 8443), ("::", 8443)]       quicAddressPlan (Just "127.0.0.1") 8443 `shouldBe` [("127.0.0.1", 8443)]       quicAltSvc 8443 `shouldBe` "h3=\":8443\""++    it "builds QUIC TLS config without stale credentials" $ do+      sessionManager <- SM.newSessionManager quicSessionManagerConfig+      let onSNI host =+            if host == Just "example.com"+              then return $ TLS.Credentials []+              else fail $ "unexpected SNI host: " <> show host+          config = buildQuicServerConfig Nothing onSNI sessionManager 8443+      SM.dbMaxSize quicSessionManagerConfig `shouldBe` 0+      case Q.scCredentials config of+        TLS.Credentials credentials -> credentials `shouldBe` []+      TLS.Credentials credentials <- TLS.onServerNameIndication (Q.scTlsHooks config) (Just "example.com")+      credentials `shouldBe` [] #endif #ifdef OS_UNIX   describe "privilege drop planning" $ do@@ -148,25 +174,6 @@           } #endif -  describe "DoH wrapping decision" $ do-    it "wraps the application only when a DoH resolver is configured" $ do-      shouldWrapDNSOverHTTPS defaultConfig `shouldBe` False-      shouldWrapDNSOverHTTPS defaultConfig { _doh = Just "127.0.0.1:53" } `shouldBe` True--  describe "startup side-effect order" $-    it "documents the current run startup order" $-      startupOrder `shouldBe`-        [ InitializeLogger-        , LogStartup-        , ReadCertificates-        , CreateTlsSessionManager-        , BuildSettingsAndRunner-        , LoadProxyAuth-        , CreateHttpManager-        , BuildProxyApplication-        , LogRuntimeConfig-        , StartRunner-        ]   describe "access log filtering" $ do     it "suppresses health-check access logs" $       shouldSuppressAccessLog defaultRequest { rawPathInfo = "/.hprox/health" } `shouldBe` True@@ -176,31 +183,31 @@    describe "runtime exception filtering" $ do     it "suppresses all exception logs above DEBUG level" $-      shouldIgnoreRuntimeException INFO displayedException `shouldBe` True+      runtimeExceptionToLog INFO displayedException `shouldSatisfy` isNothing      it "keeps ordinary displayable exceptions at DEBUG level" $-      shouldIgnoreRuntimeException DEBUG displayedException `shouldBe` False+      runtimeExceptionToLog DEBUG displayedException `shouldSatisfy` isJust      it "unwraps HTTP/2 wrappers before selecting the exception to log" $       fmap displayException (runtimeExceptionToLog DEBUG (toException (H2.BadThingHappen displayedException)))         `shouldBe` Just (displayException displayedException)      it "suppresses EOF IO exceptions" $-      shouldIgnoreRuntimeException DEBUG eofException `shouldBe` True+      runtimeExceptionToLog DEBUG eofException `shouldSatisfy` isNothing      it "suppresses HTTP/2 errors and recursively classified HTTP/2 wrappers" $ do-      shouldIgnoreRuntimeException DEBUG (toException H2.ConnectionIsClosed) `shouldBe` True-      shouldIgnoreRuntimeException DEBUG (toException (H2.BadThingHappen eofException)) `shouldBe` True+      runtimeExceptionToLog DEBUG (toException H2.ConnectionIsClosed) `shouldSatisfy` isNothing+      runtimeExceptionToLog DEBUG (toException (H2.BadThingHappen eofException)) `shouldSatisfy` isNothing  #ifdef QUIC_ENABLED     it "suppresses QUIC errors and recursively classified QUIC wrappers" $ do-      shouldIgnoreRuntimeException DEBUG (toException Q.ConnectionIsReset) `shouldBe` True-      shouldIgnoreRuntimeException DEBUG (toException (Q.BadThingHappen eofException)) `shouldBe` True+      runtimeExceptionToLog DEBUG (toException Q.ConnectionIsReset) `shouldSatisfy` isNothing+      runtimeExceptionToLog DEBUG (toException (Q.BadThingHappen eofException)) `shouldSatisfy` isNothing #endif      it "suppresses Warp TLS and peer-close exceptions" $ do-      shouldIgnoreRuntimeException DEBUG (toException InsecureConnectionDenied) `shouldBe` True-      shouldIgnoreRuntimeException DEBUG (toException ConnectionClosedByPeer) `shouldBe` True+      runtimeExceptionToLog DEBUG (toException InsecureConnectionDenied) `shouldSatisfy` isNothing+      runtimeExceptionToLog DEBUG (toException ConnectionClosedByPeer) `shouldSatisfy` isNothing  displayedException :: SomeException displayedException = toException $ userError "display me"

@@ -6,22 +6,27 @@   ( spec   ) where -import Control.Exception     (ErrorCall, SomeException, displayException, fromException, try)+import Control.Exception+    (ErrorCall, SomeException, bracket, displayException, fromException, try)+import Crypto.Hash           qualified as Hash+import Data.ByteString       qualified as BS+import Data.ByteString.Char8 qualified as BS8+import Data.IORef            (modifyIORef', newIORef, readIORef)+import Data.List             (isInfixOf) import Data.Maybe            (isNothing) import Network.HProx.Config  (CertFile(..))+import Network.HProx.Log     (LogLevel(..), Logger) import Network.HProx.Runtime import Network.TLS           qualified as TLS -import System.Directory (getTemporaryDirectory, removeFile)-import System.IO        (hClose, openTempFile)+import System.Directory      (getTemporaryDirectory, removeFile)+import System.IO             (hClose, openTempFile)+import System.Log.FastLogger (fromLogStr) import Test.Hspec  spec :: Spec spec = do   describe "SNI selection" $ do-    it "keeps the first configured certificate as the default certificate" $-      defaultCertificate certFixtures `shouldBe` Just "first-cert"-     it "matches exact SNI hostnames case-insensitively" $ do       lookupSNIHost (Just "EXAMPLE.com") [("example.com", "cert" :: String), ("other.example", "other")]         `shouldBe` Right "cert"@@ -52,7 +57,7 @@       lookupSNIHost Nothing [("example.com", "cert" :: String)]         `shouldBe` Left "SNI: unspecified" -  describe "TLS credential loading" $+  describe "TLS credential loading" $ do     it "throws a contextual IO exception when certificate loading fails" $ do       certPath <- missingPath "hprox-missing-cert.pem"       keyPath <- missingPath "hprox-missing-key.pem"@@ -66,12 +71,94 @@           message `shouldContain` keyPath         Right _ -> expectationFailure "expected TLS credential loading to fail" -certFixtures :: [(String, String)]-certFixtures =-  [ ("first.example", "first-cert")-  , ("second.example", "second-cert")-  ]+    it "rejects production credentials with an empty certificate chain" $+      loadTlsCredentialFromMemory "not a certificate" testPrivateKey+        `shouldBe` Left "loaded TLS credential has an empty certificate chain" +    it "keeps the old production credential when reload parses an empty certificate chain" $+      withTempCredential "hprox-valid" testCertificate testPrivateKey $ \certFile -> do+        store <- loadTlsCredentialStore [("example.com", certFile)]+        oldSnapshot <- readTlsCredentialStore store+        writeCredentialFiles certFile "not a certificate" testPrivateKey+        (logger, readLogs) <- captureLogger+        reloadTlsCredentialStore logger store+        readTlsCredentialStore store `shouldReturn` oldSnapshot+        logs <- readLogs+        let errorMessages = [message | (ERROR, message) <- logs]+        length errorMessages `shouldBe` 1+        unlines errorMessages `shouldContain` "example.com"+        unlines errorMessages `shouldContain` certfile certFile+        unlines errorMessages `shouldContain` keyfile certFile+        unlines errorMessages `shouldContain` "empty certificate chain"++  describe "reloadable TLS credential store" $ do+    it "looks up SNI credentials from the current store snapshot" $+      withTempCredential "hprox-store" "cert-a" "key-a" $ \certFile -> do+        store <- newTlsCredentialStore testCredentialLoader [("example.com", certFile)]+        lookupTlsCredentialStore (Just "example.com") store `shouldReturn` "cert-a:key-a"+        writeCredentialFiles certFile "cert-b" "key-b"+        (logger, _) <- captureLogger+        reloadTlsCredentialStore logger store+        lookupTlsCredentialStore (Just "example.com") store `shouldReturn` "cert-b:key-b"++    it "selects the current first configured credential for missing SNI" $+      withTempCredential "hprox-first" "first-cert" "first-key" $ \firstCert ->+      withTempCredential "hprox-second" "second-cert" "second-key" $ \secondCert -> do+        store <- newTlsCredentialStore testCredentialLoader+          [ ("first.example", firstCert)+          , ("second.example", secondCert)+          ]+        lookupTlsCredentialStore Nothing store `shouldReturn` "first-cert:first-key"+        writeCredentialFiles firstCert "new-first-cert" "new-first-key"+        (logger, _) <- captureLogger+        reloadTlsCredentialStore logger store+        lookupTlsCredentialStore Nothing store `shouldReturn` "new-first-cert:new-first-key"++    it "logs an install message only for changed credentials" $+      withTempCredential "hprox-first" "first-cert" "first-key" $ \firstCert ->+      withTempCredential "hprox-second" "second-cert" "second-key" $ \secondCert -> do+        store <- newTlsCredentialStore testCredentialLoader+          [ ("first.example", firstCert)+          , ("second.example", secondCert)+          ]+        writeCredentialFiles firstCert "new-first-cert" "new-first-key"+        (logger, readLogs) <- captureLogger+        reloadTlsCredentialStore logger store+        readTlsCredentialStore store `shouldReturn`+          [ ("first.example", "new-first-cert:new-first-key")+          , ("second.example", "second-cert:second-key")+          ]+        logs <- readLogs+        let installMessages = [message | (INFO, message) <- logs, "installed reloaded TLS credential" `isInfixOf` message]+        length installMessages `shouldBe` 1+        unlines installMessages `shouldContain` "first.example"+        unlines installMessages `shouldContain` certfile firstCert+        unlines installMessages `shouldNotSatisfy` isInfixOf (certfile secondCert)++    it "keeps a failed entry, updates successful entries, and logs failure context" $+      withTempCredential "hprox-first" "first-cert" "first-key" $ \firstCert ->+      withTempCredential "hprox-second" "second-cert" "second-key" $ \secondCert -> do+        store <- newTlsCredentialStore failingCredentialLoader+          [ ("first.example", firstCert)+          , ("second.example", secondCert)+          ]+        writeCredentialFiles firstCert "bad-cert" "first-key"+        writeCredentialFiles secondCert "new-second-cert" "new-second-key"+        (logger, readLogs) <- captureLogger+        reloadTlsCredentialStore logger store+        readTlsCredentialStore store `shouldReturn`+          [ ("first.example", "first-cert:first-key")+          , ("second.example", "new-second-cert:new-second-key")+          ]+        logs <- readLogs+        let errorMessages = [message | (ERROR, message) <- logs]+        length errorMessages `shouldBe` 1+        unlines errorMessages `shouldContain` "first.example"+        unlines errorMessages `shouldContain` certfile firstCert+        unlines errorMessages `shouldContain` keyfile firstCert+        unlines errorMessages `shouldContain` "bad test credential"++ missingPath :: String -> IO FilePath missingPath template = do   tmpDir <- getTemporaryDirectory@@ -79,3 +166,99 @@   hClose handle   removeFile path   return path++type CapturedLogs = [(LogLevel, String)]++captureLogger :: IO (Logger, IO CapturedLogs)+captureLogger = do+  ref <- newIORef []+  let logger level message =+        modifyIORef' ref (++ [(level, BS8.unpack $ fromLogStr message)])+  return (logger, readIORef ref)++testCredentialLoader :: TlsCredentialLoader String+testCredentialLoader certFile = do+  certBytes <- BS.readFile $ certfile certFile+  keyBytes <- BS.readFile $ keyfile certFile+  return $ Right LoadedCredential+    { loadedCredentialValue = credentialValue certBytes keyBytes+    , loadedCredentialCertificateFingerprint = fingerprintBytes certBytes+    , loadedCredentialKeyFingerprint = fingerprintBytes keyBytes+    }++failingCredentialLoader :: TlsCredentialLoader String+failingCredentialLoader certFile = do+  certBytes <- BS.readFile $ certfile certFile+  keyBytes <- BS.readFile $ keyfile certFile+  if certBytes == "bad-cert"+    then return $ Left "bad test credential"+    else return $ Right LoadedCredential+      { loadedCredentialValue = credentialValue certBytes keyBytes+      , loadedCredentialCertificateFingerprint = fingerprintBytes certBytes+      , loadedCredentialKeyFingerprint = fingerprintBytes keyBytes+      }++credentialValue :: BS.ByteString -> BS.ByteString -> String+credentialValue certBytes keyBytes =+  BS8.unpack certBytes <> ":" <> BS8.unpack keyBytes++fingerprintBytes :: BS.ByteString -> Hash.Digest Hash.SHA256+fingerprintBytes = Hash.hash++withTempCredential :: String -> BS.ByteString -> BS.ByteString -> (CertFile -> IO a) -> IO a+withTempCredential template certBytes keyBytes =+  bracket acquire release+  where+    acquire = do+      tmpDir <- getTemporaryDirectory+      (certPath, certHandle) <- openTempFile tmpDir $ template <> "-cert.pem"+      (keyPath, keyHandle) <- openTempFile tmpDir $ template <> "-key.pem"+      hClose certHandle+      hClose keyHandle+      let certFile = CertFile certPath keyPath+      writeCredentialFiles certFile certBytes keyBytes+      return certFile++    release (CertFile certPath keyPath) = do+      removeFile certPath+      removeFile keyPath++writeCredentialFiles :: CertFile -> BS.ByteString -> BS.ByteString -> IO ()+writeCredentialFiles (CertFile certPath keyPath) certBytes keyBytes = do+  BS.writeFile certPath certBytes+  BS.writeFile keyPath keyBytes++testPrivateKey :: BS.ByteString+testPrivateKey = BS8.pack $+  "-----BEGIN PRIVATE KEY-----\n" <>+  "MIICeAIBADANBgkqhkiG9w0BAQEFAASCAmIwggJeAgEAAoGBAOWBh4304R0FzpHZ\n" <>+  "PltVBN0lZ3WRqF/ETDhtqR071G/d7lkikLu0QXP7pCaDK4rHcHSm3TmE1Flcyc94\n" <>+  "wfFIVJinXEiJd+bp1Yk/ZWkWTYMEX5OuYzWBhciULt+ekMz8I2W+gtFUyu5rL9M9\n" <>+  "DaNPwQijTxYaykBJ4uXzUjxm7NwhAgMBAAECgYB6ndeUak6TOPUCSzTbivLMTB2Y\n" <>+  "XLe+YpvuUfhWXA7FraaYDLWS81084Cb1RINQ4/ka+cOb5XGmRMK1i+jiRiibWw38\n" <>+  "R/j0xZhsHSaGSuFlP189O+eA00q34vw0cvKxl1OJGcRF8/lq4qrpgh63iAM+EAC/\n" <>+  "9ncMbpkQrmfluuuOAQJBAP6TLeVAnKnj4i0MtuN1xhofZ3Kdr2Ds1cbHxpeT/yE1\n" <>+  "Q8HZEIynoFVfTZe2fJs0V6YlLlv4lJhfIXy/EixrmvECQQDmymzKz5hJhxlWNLLy\n" <>+  "3t92gh3o03u5ijM7c+HVLJZVI4Co2ai9f0aRifOWKRAbmth5zUVDcJG53jMaQeQQ\n" <>+  "D3QxAkEAyR0AvwHCQjyza5+FxEBAllaE5PlJmarAX99nNkxG27c2pieTeWrbsVYu\n" <>+  "+FHEMuCw9aKd8y54Rb+xttlDxC/mIQJBAMLuUrlyYhQokdPoKwVMDb6Q5CZVCfmK\n" <>+  "qv8aP7LIOCmtFOyI+ycjKz2eISnBgSNvxEwMfuYZXFx7OvqAkNqn0uECQQC59Uk/\n" <>+  "yEl0AkTKP2tcn55afpArQfPdZbIns6koiAMpoyxJPTsB2wL9b77Z8cNfgknFQVpP\n" <>+  "vpX74UfeEF0AYB7t\n" <>+  "-----END PRIVATE KEY-----\n"++testCertificate :: BS.ByteString+testCertificate = BS8.pack $+  "-----BEGIN CERTIFICATE-----\n" <>+  "MIICCDCCAXGgAwIBAgIUdG9y2ED6kiMvkMveoyy1uxRoeIUwDQYJKoZIhvcNAQEL\n" <>+  "BQAwFjEUMBIGA1UEAwwLZXhhbXBsZS5jb20wHhcNMjYwNTI2MTUzMzQyWhcNMjYw\n" <>+  "NTI3MTUzMzQyWjAWMRQwEgYDVQQDDAtleGFtcGxlLmNvbTCBnzANBgkqhkiG9w0B\n" <>+  "AQEFAAOBjQAwgYkCgYEA5YGHjfThHQXOkdk+W1UE3SVndZGoX8RMOG2pHTvUb93u\n" <>+  "WSKQu7RBc/ukJoMrisdwdKbdOYTUWVzJz3jB8UhUmKdcSIl35unViT9laRZNgwRf\n" <>+  "k65jNYGFyJQu356QzPwjZb6C0VTK7msv0z0No0/BCKNPFhrKQEni5fNSPGbs3CEC\n" <>+  "AwEAAaNTMFEwHQYDVR0OBBYEFIVxo9w8xVcdjoMDWXAc45756MAsMB8GA1UdIwQY\n" <>+  "MBaAFIVxo9w8xVcdjoMDWXAc45756MAsMA8GA1UdEwEB/wQFMAMBAf8wDQYJKoZI\n" <>+  "hvcNAQELBQADgYEApCff6vbA5sIRVjRuxSj0Lw37RI6Qb8vaXDELxIrmXVL4b3al\n" <>+  "fLV9eJ54Lmv5mws+mziC2Nohvh6nW343oRip85u8OfalLi5enxq7FnWoXeOPVUmr\n" <>+  "8DnHkJjatk0TVsvV6JLHeJDzX/Pqw4G8JrBYbQVgOqsfWw6bk2vkrHzYOgA=\n" <>+  "-----END CERTIFICATE-----\n"