Haskell implementation of the 'Happy Eyeballs' (also called 'Fast Fallback') algorithm - https://en.wikipedia.org/wiki/Happy_Eyeballs

HappyEyeballs.hs

#!/usr/bin/env stack
{- stack script
 --compile
 --copy-bins
 --resolver lts-16.28
 --install-ghc
 --package "async random time monad-loops"
 --ghc-options=-Wall
-}

import Control.Concurrent (threadDelay)
import Control.Concurrent.Async
  ( Async,
    AsyncCancelled (..),
    async,
    cancel,
    waitAny,
  )
import Control.Exception (finally, fromException, try)
import Control.Monad.Loops (iterateUntilM)
import Data.Time.Clock (getCurrentTime)
import Data.Time.Format (defaultTimeLocale, formatTime)
import System.Random (randomRIO)

-- Haskell implementation of the 'Happy Eyeballs' (also called 'Fast Fallback')
-- https://en.wikipedia.org/wiki/Happy_Eyeballs
-- More info: https://youtu.be/oLkfnc_UMcE?t=332
-- The IO `action` is just a simple delay here.
-- Can be replaced with any other long-running IO action
--     (waiting on sockets, etc.)
-- The algorithm itself is just two functions:
--     `happyEyeballs` and `runWithTimeout`

timeoutMs :: Int
timeoutMs = 1000

numActions :: Int
numActions = 10

actionTimeMinMs :: Int
actionTimeMinMs = 800

actionTimeMaxMs :: Int
actionTimeMaxMs = 4000

logMsg :: String -> IO ()
logMsg msg = do
  now <- getCurrentTime
  let ds = formatTime defaultTimeLocale "%Y/%m/%d %H:%M:%S.%3q" now
  putStrLn $ "[" ++ ds ++ "] " ++ msg

action :: Int -> IO Bool
action i =
  let wait :: IO Bool
      wait = do
        delay <- randomRIO (actionTimeMinMs, actionTimeMaxMs)
        logMsg $ "Starting action " ++ show i ++ " (" ++ show delay ++ "ms)"
        threadDelay (delay * 1000)
        r <- randomRIO (1, 4) :: IO Int
        return (r == 1)
   in do
        r <- try wait
        case r of
          Right b -> do
            if b
              then logMsg ("Action " ++ show i ++ " succeeded")
              else logMsg ("Action " ++ show i ++ " failed")
            return b
          Left e -> do
            case fromException e of
              Just AsyncCancelled -> logMsg $ "Action " ++ show i ++ " cancelled"
              Nothing -> logMsg $ "Unknown exception in action " ++ show i
            return False

timeout :: IO Bool
timeout = do
  threadDelay (timeoutMs * 1000)
  logMsg "It's taking too long !"
  return True

runWithTimeout :: [Async Bool] -> Async Bool -> IO (Maybe [Async Bool])
runWithTimeout as a = do
  at <- async timeout
  (ab, b) <- waitAny (at : a : as) `finally` cancel at
  return $
    if ab == at
      then Just (a : as)
      else
        if b
          then Nothing
          else Just $ filter (/= ab) (a : as)

happyEyeballs :: [IO Bool] -> IO ()
happyEyeballs actions = do
  _ <- iterateUntilM nomore io ([], actions)
  return ()
  where
    nomore ([], []) = True
    nomore _ = False
    io (as, ios)
      | not $ null ios = do
        na <- async $ head ios
        r <- runWithTimeout as na
        case r of
          Just bs -> return (bs, tail ios)
          Nothing -> do
            mapM_ cancel (na : as)
            return ([], [])
      | otherwise = do
        (fa, a) <- waitAny as
        if a
          then do
            mapM_ cancel as
            return ([], [])
          else return (filter (/= fa) as, [])

main :: IO ()
main =
  let actions = action <$> [1 .. numActions]
   in happyEyeballs actions
   

Some output of this program:

• total failure

  # stack happy-eyeballs.hs
  [2021/01/10 11:03:24.915] Starting action 1 (3885ms)
  [2021/01/10 11:03:25.916] It's taking too long !
  [2021/01/10 11:03:25.916] Starting action 2 (2448ms)
  [2021/01/10 11:03:26.917] It's taking too long !
  [2021/01/10 11:03:26.917] Starting action 3 (2218ms)
  [2021/01/10 11:03:27.919] It's taking too long !
  [2021/01/10 11:03:27.919] Starting action 4 (905ms)
  [2021/01/10 11:03:28.365] Action 2 failed
  [2021/01/10 11:03:28.365] Starting action 5 (3876ms)
  [2021/01/10 11:03:28.800] Action 1 failed
  [2021/01/10 11:03:28.801] Starting action 6 (3504ms)
  [2021/01/10 11:03:28.824] Action 4 failed
  [2021/01/10 11:03:28.824] Starting action 7 (2996ms)
  [2021/01/10 11:03:29.136] Action 3 failed
  [2021/01/10 11:03:29.136] Starting action 8 (2398ms)
  [2021/01/10 11:03:30.137] It's taking too long !
  [2021/01/10 11:03:30.138] Starting action 9 (1415ms)
  [2021/01/10 11:03:31.139] It's taking too long !
  [2021/01/10 11:03:31.139] Starting action 10 (3651ms)
  [2021/01/10 11:03:31.535] Action 8 failed
  [2021/01/10 11:03:31.553] Action 9 failed
  [2021/01/10 11:03:31.821] Action 7 failed
  [2021/01/10 11:03:32.242] Action 5 failed
  [2021/01/10 11:03:32.305] Action 6 failed
  [2021/01/10 11:03:34.791] Action 10 failed
  

• success of action 5

  # stack happy-eyeballs.hs
  [2021/01/10 11:07:17.784] Starting action 1 (1364ms)
  [2021/01/10 11:07:18.785] It's taking too long !
  [2021/01/10 11:07:18.786] Starting action 2 (3724ms)
  [2021/01/10 11:07:19.149] Action 1 failed
  [2021/01/10 11:07:19.149] Starting action 3 (2629ms)
  [2021/01/10 11:07:20.150] It's taking too long !
  [2021/01/10 11:07:20.150] Starting action 4 (1357ms)
  [2021/01/10 11:07:21.152] It's taking too long !
  [2021/01/10 11:07:21.152] Starting action 5 (839ms)
  [2021/01/10 11:07:21.508] Action 4 failed
  [2021/01/10 11:07:21.508] Starting action 6 (2882ms)
  [2021/01/10 11:07:21.778] Action 3 failed
  [2021/01/10 11:07:21.778] Starting action 7 (3307ms)
  [2021/01/10 11:07:21.992] Action 5 succeeded
  [2021/01/10 11:07:21.992] Action 7 cancelled
  [2021/01/10 11:07:21.992] Action 6 cancelled
  [2021/01/10 11:07:21.992] Action 2 cancelled