Revert "async exception safety for coprocesses"

This reverts commit 7013798df5.
This commit is contained in:
Joey Hess 2020-07-06 15:11:28 -04:00
parent 6b8c961e1f
commit d66fc1a464
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
5 changed files with 32 additions and 48 deletions

View file

@ -1,7 +1,7 @@
{- Interface for running a shell command as a coprocess,
- sending it queries and getting back results.
-
- Copyright 2012-2020 Joey Hess <id@joeyh.name>
- Copyright 2012-2013 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
@ -62,46 +62,28 @@ stop ch = do
let p = proc (coProcessCmd $ coProcessSpec s) (coProcessParams $ coProcessSpec s)
forceSuccessProcess p (coProcessPid s)
{- Note that concurrent queries are not safe to perform; caller should
- serialize calls to query.
-
- To handle a restartable process, any IO exception thrown by the send and
{- To handle a restartable process, any IO exception thrown by the send and
- receive actions are assumed to mean communication with the process
- failed, and the query is re-run with a new process.
-
- If an async exception is received during a query, the state of
- communication with the process is unknown, so it is killed, and a new
- one started so the CoProcessHandle can continue to be used by other
- threads.
-}
- failed, and the failed action is re-run with a new process. -}
query :: CoProcessHandle -> (Handle -> IO a) -> (Handle -> IO b) -> IO b
query ch send receive = uninterruptibleMask $ \unmask ->
unmask (readMVar ch >>= restartable)
`catchAsync` forcerestart
query ch send receive = do
s <- readMVar ch
restartable s (send $ coProcessTo s) $ const $
restartable s (hFlush $ coProcessTo s) $ const $
restartable s (receive $ coProcessFrom s)
return
where
go s = do
void $ send $ coProcessTo s
hFlush $ coProcessTo s
receive $ coProcessFrom s
restartable s
restartable s a cont
| coProcessNumRestarts (coProcessSpec s) > 0 =
catchMaybeIO (go s)
>>= maybe (restart s increstarts restartable) return
| otherwise = go s
increstarts s = s { coProcessNumRestarts = coProcessNumRestarts s - 1 }
restart s f cont = do
void $ tryNonAsync $ do
maybe restart cont =<< catchMaybeIO a
| otherwise = cont =<< a
restart = do
s <- takeMVar ch
void $ catchMaybeIO $ do
hClose $ coProcessTo s
hClose $ coProcessFrom s
void $ waitForProcess $ coProcessPid s
s' <- withMVarMasked ch $ \_ -> start' (f (coProcessSpec s))
cont s'
forcerestart ex = do
s <- readMVar ch
terminateProcess (coProcessPid s)
restart s id $ \s' -> void $ swapMVar ch s'
either throwM throwM ex
s' <- start' $ (coProcessSpec s)
{ coProcessNumRestarts = coProcessNumRestarts (coProcessSpec s) - 1 }
putMVar ch s'
query ch send receive