From 7d4225eb11fdc7df4fe6d3c3b0d6a0f0c5d54071 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Wed, 13 Nov 2024 16:08:58 +0900 Subject: [PATCH 1/6] warp-tls: ignoring synchronous exceptions only --- warp-tls/Network/Wai/Handler/WarpTLS.hs | 15 +++++++++++++-- 1 file changed, 13 insertions(+), 2 deletions(-) diff --git a/warp-tls/Network/Wai/Handler/WarpTLS.hs b/warp-tls/Network/Wai/Handler/WarpTLS.hs index 6f70d1e32..3c0560fa6 100644 --- a/warp-tls/Network/Wai/Handler/WarpTLS.hs +++ b/warp-tls/Network/Wai/Handler/WarpTLS.hs @@ -335,6 +335,17 @@ mkConn tlsset set s params = do ---------------------------------------------------------------- +isAsyncException :: Exception e => e -> Bool +isAsyncException e = + case E.fromException (E.toException e) of + Just (E.SomeAsyncException _) -> True + Nothing -> False + +throughAsync :: IO a -> SomeException -> IO a +throughAsync action (SomeException e) + | isAsyncException e = E.throwIO e + | otherwise = action + httpOverTls :: TLS.TLSParams params => TLSSettings @@ -360,13 +371,13 @@ httpOverTls TLSSettings{..} set s bs0 params = case mconn of Nothing -> throwIO IncompleteHeaders Just conn -> return conn - wrappedRecvN recvN n = handle (\(SomeException _) -> mempty) $ recvN n + wrappedRecvN recvN n = handle (throughAsync (return "")) $ recvN n backend recvN = TLS.Backend { TLS.backendFlush = return () #if MIN_VERSION_network(3,1,1) , TLS.backendClose = - gracefulClose s 5000 `E.catch` \(SomeException _) -> return () + gracefulClose s 5000 `E.catch` throughAsync (return ()) #else , TLS.backendClose = close s #endif From 9a436e3ee30f32c4b02d16d146e622c9c3b53536 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Wed, 13 Nov 2024 16:23:39 +0900 Subject: [PATCH 2/6] warp: rethrowing asynchronous exceptions if caught. --- warp/Network/Wai/Handler/Warp/HTTP1.hs | 1 + warp/Network/Wai/Handler/Warp/HTTP2.hs | 2 +- warp/Network/Wai/Handler/Warp/Imports.hs | 14 ++++++++++++++ warp/Network/Wai/Handler/Warp/Run.hs | 4 ++-- 4 files changed, 18 insertions(+), 3 deletions(-) diff --git a/warp/Network/Wai/Handler/Warp/HTTP1.hs b/warp/Network/Wai/Handler/Warp/HTTP1.hs index 8ad016f55..a6bb5a492 100644 --- a/warp/Network/Wai/Handler/Warp/HTTP1.hs +++ b/warp/Network/Wai/Handler/Warp/HTTP1.hs @@ -204,6 +204,7 @@ processRequest settings ii conn app th istatus src req mremainingRef idxhdr next Right ResponseReceived -> return () Left (e :: SomeException) | Just (ExceptionInsideResponseBody e') <- fromException e -> throwIO e' + | isAsyncException e -> throwIO e | otherwise -> do keepAlive <- sendErrorResponse settings ii conn th istatus req e settingsOnException settings (Just req) e diff --git a/warp/Network/Wai/Handler/Warp/HTTP2.hs b/warp/Network/Wai/Handler/Warp/HTTP2.hs index 0a722afbc..50e7e35a9 100644 --- a/warp/Network/Wai/Handler/Warp/HTTP2.hs +++ b/warp/Network/Wai/Handler/Warp/HTTP2.hs @@ -152,7 +152,7 @@ wrappedRecvN th slowlorisSize readN bufsize = do return bs where handler :: E.SomeException -> IO ByteString - handler _ = return "" + handler = throughAsync (return "") -- connClose must not be called here since Run:fork calls it goaway :: Connection -> H2.ErrorCodeId -> ByteString -> IO () diff --git a/warp/Network/Wai/Handler/Warp/Imports.hs b/warp/Network/Wai/Handler/Warp/Imports.hs index ff0fd3199..3bc45a956 100644 --- a/warp/Network/Wai/Handler/Warp/Imports.hs +++ b/warp/Network/Wai/Handler/Warp/Imports.hs @@ -10,9 +10,12 @@ module Network.Wai.Handler.Warp.Imports ( module Data.Word, module Data.Maybe, module Numeric, + throughAsync, + isAsyncException, ) where import Control.Applicative +import Control.Exception import Control.Monad import Data.Bits import Data.ByteString.Internal (ByteString (..)) @@ -23,3 +26,14 @@ import Data.Monoid import Data.Ord import Data.Word import Numeric + +isAsyncException :: Exception e => e -> Bool +isAsyncException e = + case fromException (toException e) of + Just (SomeAsyncException _) -> True + Nothing -> False + +throughAsync :: IO a -> SomeException -> IO a +throughAsync action (SomeException e) + | isAsyncException e = throwIO e + | otherwise = action diff --git a/warp/Network/Wai/Handler/Warp/Run.hs b/warp/Network/Wai/Handler/Warp/Run.hs index 37bd1f7a0..085960613 100644 --- a/warp/Network/Wai/Handler/Warp/Run.hs +++ b/warp/Network/Wai/Handler/Warp/Run.hs @@ -81,7 +81,7 @@ socketConnection _ s = do else settingsGracefulCloseTimeout1 set if tm == 0 then close s - else gracefulClose s tm `E.catch` \(E.SomeException _) -> return () + else gracefulClose s tm `E.catch` throughAsync (return ()) #else , connClose = close s #endif @@ -179,7 +179,7 @@ runSettingsSocket set@Settings{settingsAccept = accept'} socket app = do (s, sa) <- accept' socket setSocketCloseOnExec s -- NoDelay causes an error for AF_UNIX. - setSocketOption s NoDelay 1 `E.catch` \(E.SomeException _) -> return () + setSocketOption s NoDelay 1 `E.catch` throughAsync (return ()) conn <- socketConnection set s return (conn, sa) From 88b67b4fcefb20d83f0897ce8baa33932af5d4fb Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Thu, 14 Nov 2024 07:23:02 +0900 Subject: [PATCH 3/6] using isAsyncException around fromException --- warp/Network/Wai/Handler/Warp/HTTP1.hs | 1 + warp/Network/Wai/Handler/Warp/HTTP2.hs | 1 + warp/Network/Wai/Handler/Warp/Settings.hs | 8 ++++---- 3 files changed, 6 insertions(+), 4 deletions(-) diff --git a/warp/Network/Wai/Handler/Warp/HTTP1.hs b/warp/Network/Wai/Handler/Warp/HTTP1.hs index a6bb5a492..cec13758c 100644 --- a/warp/Network/Wai/Handler/Warp/HTTP1.hs +++ b/warp/Network/Wai/Handler/Warp/HTTP1.hs @@ -122,6 +122,7 @@ http1server settings ii conn transport app addr th istatus src = | Just NoKeepAliveRequest <- fromException e = return () -- No valid request | Just (BadFirstLine _) <- fromException e = return () + | isAsyncException e = throwIO e | otherwise = do _ <- sendErrorResponse diff --git a/warp/Network/Wai/Handler/Warp/HTTP2.hs b/warp/Network/Wai/Handler/Warp/HTTP2.hs index 50e7e35a9..3e473354a 100644 --- a/warp/Network/Wai/Handler/Warp/HTTP2.hs +++ b/warp/Network/Wai/Handler/Warp/HTTP2.hs @@ -110,6 +110,7 @@ http2server label settings ii transport addr app h2req0 aux0 response = do | Just E.ThreadKilled <- E.fromException e -> return () -- killed by the local timeout manager | Just T.TimeoutThread <- E.fromException e -> return () + | isAsyncException e -> E.throwIO e | otherwise -> do S.settingsOnException settings (Just req) e let ersp = S.settingsOnExceptionResponse settings e diff --git a/warp/Network/Wai/Handler/Warp/Settings.hs b/warp/Network/Wai/Handler/Warp/Settings.hs index f397f5e30..882b77cb5 100644 --- a/warp/Network/Wai/Handler/Warp/Settings.hs +++ b/warp/Network/Wai/Handler/Warp/Settings.hs @@ -9,7 +9,7 @@ module Network.Wai.Handler.Warp.Settings where -import Control.Exception (SomeException, fromException) +import Control.Exception (SomeException(..), fromException, throw) import qualified Data.ByteString.Builder as Builder import qualified Data.ByteString.Char8 as C8 import Data.Streaming.Network (HostPreference) @@ -17,7 +17,7 @@ import qualified Data.Text as T import qualified Data.Text.IO as TIO import Data.Version (showVersion) import GHC.IO (IO (IO), unsafeUnmask) -import GHC.IO.Exception (AsyncException (ThreadKilled), IOErrorType (..)) +import GHC.IO.Exception (IOErrorType (..)) import GHC.Prim (fork#) import qualified Network.HTTP.Types as H import Network.Socket (SockAddr, Socket, accept) @@ -228,12 +228,11 @@ defaultSettings = -- Since 2.1.3 defaultShouldDisplayException :: SomeException -> Bool defaultShouldDisplayException se - | Just ThreadKilled <- fromException se = False | Just (_ :: InvalidRequest) <- fromException se = False | Just (ioeGetErrorType -> et) <- fromException se , et == ResourceVanished || et == InvalidArgument = False - | Just TimeoutThread <- fromException se = False + | isAsyncException se = False | otherwise = True -- | Printing an exception to standard error @@ -255,6 +254,7 @@ defaultOnException _ e = -- Since 3.2.27 defaultOnExceptionResponse :: SomeException -> Response defaultOnExceptionResponse e + | isAsyncException e = throw e | Just PayloadTooLarge <- fromException e = responseLBS H.status413 From af20093a4ca05851c6d65bdcfaf01398f01e1496 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Tue, 19 Nov 2024 06:09:03 +0900 Subject: [PATCH 4/6] holding Weak ThreadId to prevent thread leak again. We now have listThreads. So, it would be nice to revisit the old idea. --- time-manager/System/TimeManager.hs | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/time-manager/System/TimeManager.hs b/time-manager/System/TimeManager.hs index 5e3a7e097..4bfcfc926 100644 --- a/time-manager/System/TimeManager.hs +++ b/time-manager/System/TimeManager.hs @@ -28,12 +28,13 @@ module System.TimeManager ( TimeoutThread (..), ) where -import Control.Concurrent (myThreadId) +import Control.Concurrent (myThreadId, mkWeakThreadId) import qualified Control.Exception as E import Control.Reaper import Data.IORef (IORef) import qualified Data.IORef as I import Data.Typeable (Typeable) +import GHC.Weak (deRefWeak) ---------------------------------------------------------------- @@ -107,14 +108,14 @@ register mgr !onTimeout = do -- | Registering a timeout action of killing this thread. registerKillThread :: Manager -> TimeoutAction -> IO Handle registerKillThread m onTimeout = do - -- If we hold ThreadId, the stack and data of the thread is leaked. - -- If we hold Weak ThreadId, the stack is released. However, its - -- data is still leaked probably because of a bug of GHC. - -- So, let's just use ThreadId and release ThreadId by - -- overriding the timeout action by "cancel". tid <- myThreadId + wtid <- mkWeakThreadId tid -- First run the timeout action in case the child thread is masked. - register m $ onTimeout `E.finally` E.throwTo tid TimeoutThread + register m $ onTimeout `E.finally` do + mtid <- deRefWeak wtid + case mtid of + Nothing -> return () + Just tid' -> E.throwTo tid' TimeoutThread data TimeoutThread = TimeoutThread deriving (Typeable) From a3854304b88cd9719f3cc9a94a2aa0b8150ba55b Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Tue, 19 Nov 2024 12:43:01 +0900 Subject: [PATCH 5/6] removing the tricky code. --- auto-update/Control/Reaper.hs | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/auto-update/Control/Reaper.hs b/auto-update/Control/Reaper.hs index 0f1d76cb7..34db68a75 100644 --- a/auto-update/Control/Reaper.hs +++ b/auto-update/Control/Reaper.hs @@ -207,8 +207,12 @@ reaper settings@ReaperSettings{..} stateRef tidRef = do !merge <- reaperAction wl -- Merging the left jobs and new jobs. -- If there is no jobs, this thread finishes. - next <- atomicModifyIORef' stateRef (check merge) - next + cont <- atomicModifyIORef' stateRef (check merge) + if cont + then + reaper settings stateRef tidRef + else + writeIORef tidRef Nothing where swapWithEmpty NoReaper = error "Control.Reaper.reaper: unexpected NoReaper (1)" swapWithEmpty (Workload wl) = (Workload reaperEmpty, wl) @@ -216,9 +220,9 @@ reaper settings@ReaperSettings{..} stateRef tidRef = do check _ NoReaper = error "Control.Reaper.reaper: unexpected NoReaper (2)" check merge (Workload wl) -- If there is no job, reaper is terminated. - | reaperNull wl' = (NoReaper, writeIORef tidRef Nothing) + | reaperNull wl' = (NoReaper, False) -- If there are jobs, carry them out. - | otherwise = (Workload wl', reaper settings stateRef tidRef) + | otherwise = (Workload wl', True) where wl' = merge wl From 1400f27fb2a832aa863c0c70ae803823da5ce86b Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Tue, 19 Nov 2024 14:05:09 +0900 Subject: [PATCH 6/6] prevent calling "connClose" twice. TimeManager is leaking because of "BlockedOnMVar". Both TimeManger and Reaper do not use MVar at all. TLS "bye" is the only registered function which uses MVar. When TimeManager kills Warp, "bye" is called twice. One is via "bracket", the other is by TimeManager. This ensures that "bye" is called only once. --- warp/Network/Wai/Handler/Warp/Run.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/warp/Network/Wai/Handler/Warp/Run.hs b/warp/Network/Wai/Handler/Warp/Run.hs index 085960613..98d8a63c9 100644 --- a/warp/Network/Wai/Handler/Warp/Run.hs +++ b/warp/Network/Wai/Handler/Warp/Run.hs @@ -369,7 +369,7 @@ fork set mkConn addr app counter ii = settingsFork set $ \unmask -> do -- above ensures the connection is closed. when goingon $ serveConnection conn ii th addr transport set app where - register = T.registerKillThread (timeoutManager ii) (connClose conn) + register = T.registerKillThread (timeoutManager ii) (return ()) cancel = T.cancel onOpen adr = increase counter >> settingsOnOpen set adr