refactor(utils): minor changes for timeoutHandler
This commit is contained in:
parent
4154b1f26b
commit
d1fce58ec2
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user