[Haskell-cafe] Guidance on using asynchronous exceptions

[Yang]

To follow up on my previous post ("Asynchronous Exceptions and the
RealWorld"), I've decided to put together something more concrete in
the hopes of eliciting response.

I'm trying to write a library of higher-level concurrency
abstractions, in particular for asynchronous systems programming. The 
principal goal here is composability and safety. Ideally, one can apply 
combinators on any existing (IO a), not just procedures written for this 
library. But that seems like a pipe dream at this point.

In the code below, the running theme is process orchestration. (I've put 
TODOs at places where I'm blocked - no pun intended.)

I'm currently worried that what I'm trying to do is simply impossible in
Concurrent Haskell. I'm bewildered by the design decisions in the
asynchronous exceptions paper. I'm also wondering if there are any
efforts under way to reform this situation. I found some relevant
posts below hinting at this, but I'm not sure what the status is
today.

(Something like this is straightforward to build if I abandon
Concurrent Haskell and use cooperative threading, and if the
operations I wanted to perform could be done asynchronously.)

Relevant papers
---------------

http://citeseer.ist.psu.edu/415348.html
http://research.microsoft.com/users/simonpj/papers/concurrent-haskell.ps.gz
http://www.haskell.org/~simonmar/papers/web-server.ps.gz

Relevant posts/threads
----------------------

http://osdir.com/ml/lang.haskell.prime/2006-04/msg00032.html
http://osdir.com/ml/lang.haskell.general/2001-11/msg00131.html
http://www.haskell.org/pipermail/haskell-prime/2006-April/001280.html
http://www.haskell.org/pipermail/haskell-prime/2006-April/001290.html
http://www.nabble.com/throwTo---block-statements-considered-harmful-tf2780268.html#a7758038
http://www.nabble.com/What-guarantees-(if-any)-do-interruptible-operations-have-in-presence-of-asynchronous-exceptions--tf2761696.html#a7699555

Misc
----

http://lambda-the-ultimate.org/node/1570
Advanced Exception Handling Mechanisms
http://www.springerlink.com/content/3723wg2t81248027/
http://64.233.169.104/search?q=cache:c4pS0FDKMXcJ:www.cs.ioc.ee/tfp-icfp-gpce05/tfp-proc/06num.pdf+concurrency+interrupts+abort+safe+asynchronous+exceptions+threads&h
http://64.233.169.104/search?q=cache:hmC-jl-iNkoJ:www.jot.fm/issues/issue_2007_11/article4.pdf+concurrency+interrupts+abort+safe+asynchronous+exceptions+threads&hl=en
http://www.mathematik.uni-marburg.de/~eden/paper/edenEuropar03.pdf


Code
====

module Main where

import Control.Concurrent
import Control.Concurrent.MVar
import Control.Exception
import Control.Monad
import Prelude hiding (log)
import System.IO
import System.Posix.Signals
import System.Process

log = putStrLn

startProc cmd = runCommand cmd
stopProc  p   = terminateProcess p
waitProc  p   = waitForProcess p

-- Run a process, blocking on it until it exits. If we're interrupted,
-- terminate the process. (IIRC, terminateProcess issues SIGTERM, and
-- the documentation is buggy; more detailed code should go here later
-- to retry with SIGKILL.)
runProc cmd = do
   log "launching proc"
   p <- startProc cmd
   waitProc p                -- TODO allow interrupts only at this point
     `finally` ( log "stopping" >> stopProc p >> log "stopped" )

-- Sleep for n seconds.
timeout n = do
   log "sleeping"
   threadDelay (n * 1000000) -- TODO allow interrupts only at this point
   log "waking"

-- TODO is there any way to block *only* the Cancel exception? (Even
-- if this could be done, though, it's still not a modular approach.)
spawn :: IO a -> (a -> IO ()) -> IO ThreadId
spawn f y = forkIO (block (f >>= y))

-- The any/sum/choice combinator. On return, guarantee that both tasks
-- have stopped.
(<|>) :: IO a -> IO b -> IO (Either a b)
a <|> b = do
   result <- newEmptyMVar :: IO (MVar (Either a b))
   tida   <- newEmptyMVar :: IO (MVar ThreadId)
   tidb   <- newEmptyMVar :: IO (MVar ThreadId)

   let yield lr x = do let name = case lr x of
                                    Left  _ -> "a"
                                    Right _ -> "b"
                       log $ "saving result of " ++ name
                       putMVar result (lr x)
                       log $ "saved result of " ++ name

                       let other = case lr x of
                                     Left  _ -> tidb
                                     Right _ -> tida
                       log "taking other"
                       t <- takeMVar other
                       log "killing other"
                       -- Later: replace the following with a throwTo
                       -- so as to notify (rather than kill) the thread
                       -- with a Cancel
                       killThread t

   ta <- spawn a (yield Left)
   tb <- spawn b (yield Right)
   putMVar tida ta
   putMVar tidb tb

   log "waiting for result"
   res <- takeMVar result

   -- TODO wait for both tasks to have stopped

   log "returning result"
   return res

-- simple test --

cmd1 = "for i in `seq 1`; do sleep 1; echo hello; done"
cmd2 = "for i in `seq 3`; do sleep 1; echo world; done"

main = do
   -- TODO for some reason, cmd2 doesn't get terminated.
   result <- runProc cmd1 <|> runProc cmd2
   case result of
     Left  _ -> putStrLn "finished process"
     Right _ -> putStrLn "got exception"