From 7ed2232e9f4792f22cde40174f3d8c660f18237f Mon Sep 17 00:00:00 2001
From: Benjamin Koch <snowball@c3pb.de>
Date: Sun, 13 Dec 2020 06:40:31 +0100
Subject: [PATCH] Apply workaround for race condition in System.Process.Typed
---
src/QBar/Blocks/Script.hs | 33 ++++++++++++++++++++++++++-------
1 file changed, 26 insertions(+), 7 deletions(-)
diff --git a/src/QBar/Blocks/Script.hs b/src/QBar/Blocks/Script.hs
index 9f8811f..8f55daa 100644
--- a/src/QBar/Blocks/Script.hs
+++ b/src/QBar/Blocks/Script.hs
@@ -6,7 +6,8 @@ import QBar.Core
import QBar.TagParser
import QBar.Time
-import Control.Exception (IOException)
+import Control.Exception (IOException, handle)
+import Control.Concurrent (threadDelay)
import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
import Data.Aeson (encode)
import qualified Data.ByteString.Lazy.Char8 as C8
@@ -41,7 +42,7 @@ pollScriptBlock interval path = runPollBlock' interval $ forever $ yieldBlockUpd
scriptBlock :: Bool -> FilePath -> Block
-- The outer catchP only catches errors that occur during process creation
-scriptBlock clickEvents path = catchP startScriptProcess (handleError Nothing)
+scriptBlock clickEvents path = startScriptProcess
where
handleError :: Maybe ExitCode -> IOException -> Block
handleError exitCode exc = case result of
@@ -57,16 +58,34 @@ scriptBlock clickEvents path = catchP startScriptProcess (handleError Nothing)
(True, Just ExitSuccess) -> Right exitBlock
(True, Just (ExitFailure nr)) ->
Left $ "exit code " <> T.pack (show nr)
+ (True, Nothing) ->
+ -- This will happen if we hit the race condition (see below)
+ -- or the process closes its stdout without exiting.
+ Left $ "exit code unavailable"
_ -> Left $ T.pack (show exc)
+ ignoreIOException :: a -> IO a -> IO a
+ ignoreIOException errValue = handle $ \(_ :: IOException) -> return errValue
handleErrorWithProcess :: (Process i o e) -> IOException -> Block
handleErrorWithProcess process exc = do
- exitCode <- getExitCode process
- stopProcess process
+ -- We want to know whether the process has already exited or we are
+ -- killing it because of some other error. stopProcess determines
+ -- that but it doesn't tell us. getExitCode is unreliable before
+ -- stopProcess because it will return Nothing while the waiter threat
+ -- hasn't noticed that the process is dead.
+ -- Furthermore, stopProcess may fail in waitForProcess if the process
+ -- has died really quickly.
+ -- I don't think there is anything we can do about this. We do try
+ -- to make the races less likely by waiting a bit.
+ exitCode <- liftIO $ do
+ threadDelay 100000
+ ignoreIOException Nothing (getExitCode process)
+ <* ignoreIOException () (stopProcess process)
handleError exitCode exc
startScriptProcess :: Block
- startScriptProcess = if clickEvents
- then startScriptProcessWithEvents
- else startScriptProcessNoEvents
+ startScriptProcess = flip catchP (handleError Nothing) $
+ if clickEvents
+ then startScriptProcessWithEvents
+ else startScriptProcessNoEvents
startScriptProcessNoEvents :: Block
startScriptProcessNoEvents = do
let processConfig = setStdin closed $ setStdout createPipe $ shell path
--
GitLab