haskell cancel-able async impl

cancellation.hs

#!/usr/bin/env stack
{-
 stack
--resolver lts-17.13 runghc
--package HTTP
--package http-conduit
-}
--
--  chapter-9, Parallel-concurrent-programming in haskell
-- chmod 755 ./cancellation.hs && ./cancellation.hs
--
{-
async with thread cancellation
-}
import Network.HTTP.Conduit
import           Control.Concurrent
import Data.Time
import qualified Data.ByteString.Lazy as LB
import Text.Printf
import Control.Exception
import Control.Monad
import System.IO
import Data.Either

data Async a = Async ThreadId (MVar (Either SomeException a) )

async :: IO a -> IO (Async a)
async action = do
  var <- newEmptyMVar
  tid <- forkIO
    ( do
        r <- try action
        putMVar var r
    )
  return (Async tid var)

cancel :: Async a -> IO ()
cancel (Async t _) =  throwTo t ThreadKilled

getURL :: String -> IO LB.ByteString
getURL url = simpleHttp "https://stackoverflow.com"

timeit :: IO a -> IO (a,Double)
timeit action = do
     t0 <- getCurrentTime
     a <- action
     t1 <- getCurrentTime
     return (a, realToFrac (t1 `diffUTCTime` t0))

sites = ["http://www.google.com"
        , "http://www.bing.com"
        , "http://www.yahoo.com"
        , "http://www.wikipedia.com/wiki/Spade"
        , "http://www.wikipedia.com/wiki/Shovel"
        ]

timeDownload :: String -> IO ()
timeDownload url = do
  (page, time) <- timeit $ getURL url
  printf "download %s (%d bytes, %2fs)\n" url(LB.length page) time

wait :: Async a -> IO a
wait a =  do
  r <- waitCatch a
  case r of
    Right a -> return a
    Left e -> throwIO e

waitCatch :: Async a -> IO( Either SomeException a)
waitCatch (Async _ var) = readMVar var

main :: IO()
main = do
  let download url = do r <- getURL url; return (url, r)
  as <- mapM (async . timeDownload) sites
  forkIO $ do
    hSetBuffering stdin NoBuffering
    forever $ do
      c <- getChar
      when ( c == 'q' ) $ mapM_ cancel as

  rs <- mapM waitCatch as
  printf "%d/%d succeeded\n" (length (rights rs)) (length rs)