haskell aysnc implementation using stm

stmAsync.hs

#!/usr/bin/env stack

{-
 stack
--resolver lts-17.13 runghc
--package HTTP
--package http-conduit
-}
--
--  chapter-10, Parallel-concurrent-programming in haskell
-- chmod 755 ./stmAsync.hs && ./stmAsync.hs
--
import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception
import qualified Data.ByteString.Lazy as LB
import Data.Time
import Network.HTTP.Conduit
import Text.Printf

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

async :: IO a -> IO (Async a)
async  action = do
  var <- newEmptyTMVarIO
  t <- forkFinally action (atomically . putTMVar var)
  return $ Async t var

waitCatchSTM :: Async a -> STM ( Either SomeException a )
waitCatchSTM (Async _ var) = readTMVar var

waitSTM :: Async a -> STM a
waitSTM a = do
  r <- waitCatchSTM a
  case r of
    Left e -> throwSTM e
    Right a -> return a
  
waitEither :: Async a -> Async b -> IO (Either a b)
waitEither  a b = atomically $
 ( Left <$> waitSTM a) `orElse` (Right <$> waitSTM b)

waitAny :: [Async a] -> IO a
waitAny asyncs = atomically $ foldr orElse retry $ waitSTM <$> asyncs

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

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

sites =
  [ "https://google.com"
  , "https://en.wikipedia.org/wiki/Wikipedia:About"
  , "https://www.bing.com"
  , "https://en.wikipedia.org/wiki/Muhammad_Iqbal"
  , "https://en.wikipedia.org/wiki/Main_Page"
  ]

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