refactor(utils): minor changes for timeoutHandler

This commit is contained in:
Steffen Jost 2024-01-30 15:32:46 +01:00
parent 4154b1f26b
commit d1fce58ec2
2 changed files with 17 additions and 11 deletions

View File

@ -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

View File

@ -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