waitany haskell aync impl

myAsync.hs

#!/usr/bin/env stack

{-
 stack
--resolver lts-17.13 runghc
--package HTTP
--package http-conduit
-}
--
--  chapter-8, Parallel-concurrent-programming in haskell
-- chmod 755 ./myAsync.hs && ./myAsync.hs
--

import Control.Concurrent
  ( MVar,
    forkFinally,
    forkIO,
    newEmptyMVar,
    putMVar,
    readMVar,
    takeMVar,
  )
import Control.Exception
import Data.ByteString as B
import qualified Data.ByteString.Lazy as LB
import Data.Time
import Network.HTTP.Conduit
import Text.Printf

newtype Async a = Async (MVar (Either SomeException a))

async :: IO a -> IO (Async a)
async action = do
  var <- newEmptyMVar
  forkFinally action (putMVar var)
  return (Async var)

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

waitAny :: [Async a] -> IO a
waitAny as = do
  m <- newEmptyMVar
  let forkwait a = forkIO $ do
        r <- try (wait a)
        putMVar m r
  mapM_ forkwait as
  wait (Async m)

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

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

main :: IO ()
main = do
  let download url = do r <- getURL url; return (url, r)
  as <- mapM (async . download) sites
  (url, r) <- waitAny as
  printf "%s was first (%d bytes)\n" url (LB.length r)
  mapM_ wait as