diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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) diff --git a/hprox.cabal b/hprox.cabal --- a/hprox.cabal +++ b/hprox.cabal @@ -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 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 diff --git a/src/Network/HProx.hs b/src/Network/HProx.hs --- a/src/Network/HProx.hs +++ b/src/Network/HProx.hs @@ -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 diff --git a/src/Network/HProx/Config.hs b/src/Network/HProx/Config.hs --- a/src/Network/HProx/Config.hs +++ b/src/Network/HProx/Config.hs @@ -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) diff --git a/src/Network/HProx/DoH.hs b/src/Network/HProx/DoH.hs --- a/src/Network/HProx/DoH.hs +++ b/src/Network/HProx/DoH.hs @@ -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 = diff --git a/src/Network/HProx/Impl.hs b/src/Network/HProx/Impl.hs --- a/src/Network/HProx/Impl.hs +++ b/src/Network/HProx/Impl.hs @@ -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 diff --git a/src/Network/HProx/Naive.hs b/src/Network/HProx/Naive.hs --- a/src/Network/HProx/Naive.hs +++ b/src/Network/HProx/Naive.hs @@ -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 () diff --git a/src/Network/HProx/Platform/Quic.hs b/src/Network/HProx/Platform/Quic.hs deleted file mode 100644 --- a/src/Network/HProx/Platform/Quic.hs +++ /dev/null @@ -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 diff --git a/src/Network/HProx/Platform/Unix.hs b/src/Network/HProx/Platform/Unix.hs deleted file mode 100644 --- a/src/Network/HProx/Platform/Unix.hs +++ /dev/null @@ -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 diff --git a/src/Network/HProx/Quic.hs b/src/Network/HProx/Quic.hs new file mode 100644 --- /dev/null +++ b/src/Network/HProx/Quic.hs @@ -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 diff --git a/src/Network/HProx/Runtime.hs b/src/Network/HProx/Runtime.hs --- a/src/Network/HProx/Runtime.hs +++ b/src/Network/HProx/Runtime.hs @@ -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" diff --git a/src/Network/HProx/Unix.hs b/src/Network/HProx/Unix.hs new file mode 100644 --- /dev/null +++ b/src/Network/HProx/Unix.hs @@ -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 diff --git a/test/Network/HProx/AuthSpec.hs b/test/Network/HProx/AuthSpec.hs --- a/test/Network/HProx/AuthSpec.hs +++ b/test/Network/HProx/AuthSpec.hs @@ -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 diff --git a/test/Network/HProx/ProxySpec.hs b/test/Network/HProx/ProxySpec.hs --- a/test/Network/HProx/ProxySpec.hs +++ b/test/Network/HProx/ProxySpec.hs @@ -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 diff --git a/test/Network/HProx/RuntimeSpec.hs b/test/Network/HProx/RuntimeSpec.hs --- a/test/Network/HProx/RuntimeSpec.hs +++ b/test/Network/HProx/RuntimeSpec.hs @@ -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" diff --git a/test/Network/HProx/TLSSpec.hs b/test/Network/HProx/TLSSpec.hs --- a/test/Network/HProx/TLSSpec.hs +++ b/test/Network/HProx/TLSSpec.hs @@ -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"