diff --git a/changes/2024-06-19T182722-0400.txt b/changes/2024-06-19T182722-0400.txt new file mode 100644 index 0000000000..a7b3659bf5 --- /dev/null +++ b/changes/2024-06-19T182722-0400.txt @@ -0,0 +1,2 @@ +Small fixes to exception safety result in Ctrl-C now working properly +during read-only replay (and other scenarios) diff --git a/src/Chainweb/Mempool/InMem.hs b/src/Chainweb/Mempool/InMem.hs index 0deb727ada..8a275729b1 100644 --- a/src/Chainweb/Mempool/InMem.hs +++ b/src/Chainweb/Mempool/InMem.hs @@ -191,9 +191,7 @@ withInMemoryMempool_ l cfg _v f = do logFunctionText l Debug "Initialized Mempool Monitor" runForeverThrottled lf "Chainweb.Mempool.InMem.withInMemoryMempool_.monitor" 10 (10 * mega) $ do stats <- getMempoolStats m - logFunctionText l Debug "got stats" logFunctionJson l Info stats - logFunctionText l Debug "logged stats" approximateThreadDelay 60_000_000 {- 1 minute -} ------------------------------------------------------------------------------ diff --git a/src/Chainweb/Pact/PactService.hs b/src/Chainweb/Pact/PactService.hs index cf4554eed4..b1f3f6a4cf 100644 --- a/src/Chainweb/Pact/PactService.hs +++ b/src/Chainweb/Pact/PactService.hs @@ -393,7 +393,7 @@ serviceRequests memPoolAccess reqQ = go finishedLock <- newEmptyMVar -- fork a thread to service the request bracket - (forkIO $ + (mask_ $ forkIOWithUnmask $ \restore -> -- We wrap this whole block in `tryAsync` because we -- want to ignore `RequestCancelled` exceptions that -- occur while we are waiting on `takeMVar goLock`. @@ -411,7 +411,7 @@ serviceRequests memPoolAccess reqQ = go takeMVar goLock -- run and report the answer. - tryAny (run act) >>= \case + restore (tryAny (run act)) >>= \case Left ex -> atomically $ writeTVar statusRef (RequestFailed ex) Right r -> atomically $ writeTVar statusRef (RequestDone r) ) @@ -422,12 +422,9 @@ serviceRequests memPoolAccess reqQ = go -- starting work on it beforeStarting <- atomically $ do readTVar statusRef >>= \case - RequestInProgress -> - error "PactService internal error: request in progress before starting" - RequestDone _ -> - error "PactService internal error: request finished before starting" - RequestFailed e -> - return (Left e) + RequestInProgress -> internalError "request in progress before starting" + RequestDone _ -> internalError "request finished before starting" + RequestFailed e -> return (Left e) RequestNotStarted -> do writeTVar statusRef RequestInProgress return (Right ()) @@ -443,7 +440,7 @@ serviceRequests memPoolAccess reqQ = go RequestInProgress -> retry RequestDone _ -> return (Right ()) RequestFailed e -> return (Left e) - RequestNotStarted -> error "PactService internal error: request not started after starting" + RequestNotStarted -> internalError "request not started after starting" ) case maybeException of Left (fromException -> Just AsyncCancelled) -> diff --git a/src/Chainweb/Pact/Service/PactQueue.hs b/src/Chainweb/Pact/Service/PactQueue.hs index b06ca0c66d..330b5ddffd 100644 --- a/src/Chainweb/Pact/Service/PactQueue.hs +++ b/src/Chainweb/Pact/Service/PactQueue.hs @@ -124,9 +124,9 @@ waitForSubmittedRequest statusRef = atomically $ do -- When the continuation terminates, *cancel the request*. -- submitRequestAnd :: PactQueue -> RequestMsg r -> (TVar (RequestStatus r) -> IO a) -> IO a -submitRequestAnd q msg k = mask $ \restore -> do +submitRequestAnd q msg k = uninterruptibleMask $ \restore -> do status <- addRequest q msg - restore (k status) `finally` + restore (k status) `onException` uninterruptibleMask_ (cancelSubmittedRequest status) -- | Submit a request and wait for it to finish; if interrupted by an