diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 4e2c18e92..4648cf647 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -35,7 +35,7 @@ import Handler.Utils.Qualification as Handler.Utils import Handler.Utils.Term as Handler.Utils -import Handler.Utils.Concurrent as Handler.Utils +-- import Handler.Utils.Concurrent as Handler.Utils -- only imported when needed import Control.Monad.Logger diff --git a/src/Handler/Utils/Concurrent.hs b/src/Handler/Utils/Concurrent.hs index 60e476a19..1faaff498 100644 --- a/src/Handler/Utils/Concurrent.hs +++ b/src/Handler/Utils/Concurrent.hs @@ -3,30 +3,36 @@ -- SPDX-License-Identifier: AGPL-3.0-or-later module Handler.Utils.Concurrent - ( module Handler.Utils.Concurrent + ( module Handler.Utils.Concurrent ) where +-- NOTE: use `retrySTM` and `checkSTM` instead of `retry` or `check` import Import -import UnliftIO.Concurrent +import UnliftIO.Concurrent as Handler.Utils.Concurrent hiding (yield) + -- | Run a handler action until it finishes or if it exceeds a given number of microseconds via `registerDelay` timeoutHandler :: Int -> HandlerFor site a -> HandlerFor site (Maybe a) timeoutHandler maxWait act = do innerAct <- handlerToIO - (hresult, tid) <- liftIO $ do + (hresult, tid) <- liftIO $ do hresult <- newTVarIO Nothing - tid <- forkIO $ innerAct $ do - res <- act - liftIO $ atomically $ writeTVar hresult $ Just res + tid <- forkIO $ do + res <- innerAct act + atomically $ writeTVar hresult $ Just res return (hresult, tid) res <- liftIO $ do flag <- registerDelay maxWait - atomically $ do - res <- readTVar hresult + atomically $ do out <- readTVar flag + res <- readTVar hresult checkSTM $ out || isJust res return res - when (isNothing res) $ killThread tid - return res + case res of + Nothing -> liftIO $ do + killThread tid + readTVarIO hresult -- read once more after kill to ensure that any result is noticed + _ -> return res +