Interruptible external processes on Windows. Workaround for this issue: https://ghc.haskell.org/trac/ghc/ticket/7353

win_process_cancel.hs

{-# LANGUAGE ScopedTypeVariables #-}
 
import Control.Applicative
import Control.Exception 
import Control.Concurrent (threadDelay, MVar, newEmptyMVar, putMVar, takeMVar)
import Control.Concurrent.Async (race_, Concurrently(..), waitEither, withAsync)
import System.Process
import System.Exit
import System.IO
import qualified Data.ByteString as B
 
-- Executes two actions concurrently and returns the one that finishes first.
-- If an asynchronous exception is thrown, the second action is terminated
-- first.
race' :: IO a -> IO a -> IO a
race' left right =
    withAsync left $ \a ->
    withAsync right $ \b ->
    fmap (either id id) (waitEither a b)


-- terminate external process on exception, ignore if already dead.
terminateCarefully :: ProcessHandle -> IO ()
terminateCarefully pHandle = 
    catch (terminateProcess pHandle) (\(e::IOException) -> return ())

 
safeExec :: CreateProcess -> IO (B.ByteString, ExitCode)
safeExec cp = 
    bracketOnError 
        (createProcess cp {std_out = CreatePipe})
        (\(_,_        ,_,pHandle) -> terminateCarefully pHandle)  
        (\(_,Just hOut,_,pHandle) -> do
            -- Workaround for a Windows issue.
            latch <- newEmptyMVar
            race' 
               (do -- IO actions are uninterruptible on Windows :(
                  takeMVar latch 
                  contents <- B.hGetContents hOut 
                  ec <- waitForProcess pHandle
                  pure (contents,ec))
               -- Dummy interruptible action that   
               -- receives asynchronous exceptions first
               -- and helps to end the other action.
               (onException 
                   (do 
                      putMVar latch () 
                      -- runs forever unless interrupted
                      runConcurrently empty)
                   (terminateCarefully pHandle))) 
    
main :: IO ()
main = do
    race_ (safeExec $ proc "calc" []) 
          (threadDelay (3*10^6))