-
-
Save cptwunderlich/41ef69d2d014fd1948c0d5a07043c9e4 to your computer and use it in GitHub Desktop.
Haskell async - race successful tasks
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| cabal-version: 3.4 | |
| name: async-test | |
| version: 0.1.0.0 | |
| build-type: Simple | |
| common warnings | |
| ghc-options: -Wall | |
| executable async-test | |
| import: warnings | |
| main-is: Main.hs | |
| ghc-options: -threaded -rtsopts -debug | |
| build-depends: base ^>= 4.18.3.0, | |
| async ^>= 2.2.5 | |
| default-language: GHC2021 |
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| module Main where | |
| import Control.Concurrent.Async | |
| import Control.Exception (Exception, bracket, throwIO) | |
| import Debug.Trace | |
| import Control.Concurrent (threadDelay) | |
| data TimeoutException = TimeoutException | |
| deriving Show | |
| instance Exception TimeoutException | |
| -- Race a list of actions and return the first one to | |
| -- _successfully_ finish. Fails if all actions fail. | |
| raceAnySuccess :: [IO a] -> IO a | |
| raceAnySuccess tasks = | |
| bracket | |
| (trace "acquire" $ mapM async tasks) | |
| (trace "release" cancelMany) | |
| (trace "waitForSuccess" waitForSuccess) | |
| where | |
| waitForSuccess :: [Async a] -> IO a | |
| waitForSuccess [] = error "All tasks failed!" | |
| waitForSuccess asyncs = do | |
| (completed, result) <- waitAnyCatch asyncs | |
| case result of | |
| Right val -> trace "success" $ return val | |
| Left _ -> | |
| let remaining = trace "filtering" $ filter (/= completed) asyncs | |
| in trace "recursive" $ waitForSuccess remaining | |
| forever :: IO String | |
| forever = threadDelay 10000 >> forever | |
| terminates :: IO String | |
| terminates = threadDelay 1000000 >> pure "terminates" | |
| fails :: IO String | |
| fails = threadDelay 1000 >> throwIO TimeoutException | |
| main :: IO () | |
| main = do | |
| putStrLn "Started" | |
| msg <- raceAnySuccess $ terminates : fails : replicate 5000 forever | |
| putStrLn msg | |
| putStrLn "Finished" |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment