{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module Network.HTTP.Client.Connection
    ( connectionReadLine
    , connectionReadLineWith
    , connectionDropTillBlankLine
    , dummyConnection
    , openSocketConnection
    , openSocketConnectionSize
    , makeConnection
    , socketConnection
    , withSocket
    , strippedHostName
    ) where

import Data.ByteString (ByteString, empty)
import Data.IORef
import Control.Monad
import Control.Concurrent
import Control.Concurrent.Async
import Network.HTTP.Client.Types
import Network.Socket (Socket, HostAddress)
import qualified Network.Socket as NS
import Network.Socket.ByteString (sendAll, recv)
import qualified Control.Exception as E
import qualified Data.ByteString as S
import Data.Foldable (for_)
import Data.Function (fix)
import Data.Maybe (listToMaybe)
import Data.Word (Word8)


connectionReadLine :: Connection -> IO ByteString
connectionReadLine :: Connection -> IO ByteString
connectionReadLine conn :: Connection
conn = do
    ByteString
bs <- Connection -> IO ByteString
connectionRead Connection
conn
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Bool
S.null ByteString
bs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ HttpExceptionContent -> IO ()
forall a. HttpExceptionContent -> IO a
throwHttp HttpExceptionContent
IncompleteHeaders
    Connection -> ByteString -> IO ByteString
connectionReadLineWith Connection
conn ByteString
bs

-- | Keep dropping input until a blank line is found.
connectionDropTillBlankLine :: Connection -> IO ()
connectionDropTillBlankLine :: Connection -> IO ()
connectionDropTillBlankLine conn :: Connection
conn = (IO () -> IO ()) -> IO ()
forall a. (a -> a) -> a
fix ((IO () -> IO ()) -> IO ()) -> (IO () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \loop :: IO ()
loop -> do
    ByteString
bs <- Connection -> IO ByteString
connectionReadLine Connection
conn
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
S.null ByteString
bs) IO ()
loop

connectionReadLineWith :: Connection -> ByteString -> IO ByteString
connectionReadLineWith :: Connection -> ByteString -> IO ByteString
connectionReadLineWith conn :: Connection
conn bs0 :: ByteString
bs0 =
    ByteString
-> ([ByteString] -> [ByteString]) -> Int -> IO ByteString
go ByteString
bs0 [ByteString] -> [ByteString]
forall a. a -> a
id 0
  where
    go :: ByteString
-> ([ByteString] -> [ByteString]) -> Int -> IO ByteString
go bs :: ByteString
bs front :: [ByteString] -> [ByteString]
front total :: Int
total =
        case (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
S.break (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
charLF) ByteString
bs of
            (_, "") -> do
                let total' :: Int
total' = Int
total Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
S.length ByteString
bs
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
total' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 4096) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ HttpExceptionContent -> IO ()
forall a. HttpExceptionContent -> IO a
throwHttp HttpExceptionContent
OverlongHeaders
                ByteString
bs' <- Connection -> IO ByteString
connectionRead Connection
conn
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Bool
S.null ByteString
bs') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ HttpExceptionContent -> IO ()
forall a. HttpExceptionContent -> IO a
throwHttp HttpExceptionContent
IncompleteHeaders
                ByteString
-> ([ByteString] -> [ByteString]) -> Int -> IO ByteString
go ByteString
bs' ([ByteString] -> [ByteString]
front ([ByteString] -> [ByteString])
-> ([ByteString] -> [ByteString]) -> [ByteString] -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString
bsByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:)) Int
total'
            (x :: ByteString
x, Int -> ByteString -> ByteString
S.drop 1 -> ByteString
y) -> do
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
S.null ByteString
y) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$! Connection -> ByteString -> IO ()
connectionUnread Connection
conn ByteString
y
                ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$! ByteString -> ByteString
killCR (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$! [ByteString] -> ByteString
S.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$! [ByteString] -> [ByteString]
front [ByteString
x]

charLF, charCR :: Word8
charLF :: Word8
charLF = 10
charCR :: Word8
charCR = 13

killCR :: ByteString -> ByteString
killCR :: ByteString -> ByteString
killCR bs :: ByteString
bs
    | ByteString -> Bool
S.null ByteString
bs = ByteString
bs
    | ByteString -> Word8
S.last ByteString
bs Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
charCR = ByteString -> ByteString
S.init ByteString
bs
    | Bool
otherwise = ByteString
bs

-- | For testing
dummyConnection :: [ByteString] -- ^ input
                -> IO (Connection, IO [ByteString], IO [ByteString]) -- ^ conn, output, input
dummyConnection :: [ByteString] -> IO (Connection, IO [ByteString], IO [ByteString])
dummyConnection input0 :: [ByteString]
input0 = do
    IORef [ByteString]
iinput <- [ByteString] -> IO (IORef [ByteString])
forall a. a -> IO (IORef a)
newIORef [ByteString]
input0
    IORef [ByteString]
ioutput <- [ByteString] -> IO (IORef [ByteString])
forall a. a -> IO (IORef a)
newIORef []
    (Connection, IO [ByteString], IO [ByteString])
-> IO (Connection, IO [ByteString], IO [ByteString])
forall (m :: * -> *) a. Monad m => a -> m a
return (Connection :: IO ByteString
-> (ByteString -> IO ())
-> (ByteString -> IO ())
-> IO ()
-> Connection
Connection
        { connectionRead :: IO ByteString
connectionRead = IORef [ByteString]
-> ([ByteString] -> ([ByteString], ByteString)) -> IO ByteString
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef [ByteString]
iinput (([ByteString] -> ([ByteString], ByteString)) -> IO ByteString)
-> ([ByteString] -> ([ByteString], ByteString)) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \input :: [ByteString]
input ->
            case [ByteString]
input of
                [] -> ([], ByteString
empty)
                x :: ByteString
x:xs :: [ByteString]
xs -> ([ByteString]
xs, ByteString
x)
        , connectionUnread :: ByteString -> IO ()
connectionUnread = \x :: ByteString
x -> IORef [ByteString] -> ([ByteString] -> ([ByteString], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef [ByteString]
iinput (([ByteString] -> ([ByteString], ())) -> IO ())
-> ([ByteString] -> ([ByteString], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \input :: [ByteString]
input -> (ByteString
xByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[ByteString]
input, ())
        , connectionWrite :: ByteString -> IO ()
connectionWrite = \x :: ByteString
x -> IORef [ByteString] -> ([ByteString] -> ([ByteString], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef [ByteString]
ioutput (([ByteString] -> ([ByteString], ())) -> IO ())
-> ([ByteString] -> ([ByteString], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \output :: [ByteString]
output -> ([ByteString]
output [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ [ByteString
x], ())
        , connectionClose :: IO ()
connectionClose = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        }, IORef [ByteString]
-> ([ByteString] -> ([ByteString], [ByteString]))
-> IO [ByteString]
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef [ByteString]
ioutput (([ByteString] -> ([ByteString], [ByteString])) -> IO [ByteString])
-> ([ByteString] -> ([ByteString], [ByteString]))
-> IO [ByteString]
forall a b. (a -> b) -> a -> b
$ \output :: [ByteString]
output -> ([], [ByteString]
output), IORef [ByteString] -> IO [ByteString]
forall a. IORef a -> IO a
readIORef IORef [ByteString]
iinput)

-- | Create a new 'Connection' from a read, write, and close function.
--
-- @since 0.5.3
makeConnection :: IO ByteString -- ^ read
               -> (ByteString -> IO ()) -- ^ write
               -> IO () -- ^ close
               -> IO Connection
makeConnection :: IO ByteString -> (ByteString -> IO ()) -> IO () -> IO Connection
makeConnection r :: IO ByteString
r w :: ByteString -> IO ()
w c :: IO ()
c = do
    IORef [ByteString]
istack <- [ByteString] -> IO (IORef [ByteString])
forall a. a -> IO (IORef a)
newIORef []

    -- it is necessary to make sure we never read from or write to
    -- already closed connection.
    IORef Bool
closedVar <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False

    let close :: IO ()
close = do
          Bool
closed <- IORef Bool -> (Bool -> (Bool, Bool)) -> IO Bool
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef Bool
closedVar (\closed :: Bool
closed -> (Bool
True, Bool
closed))
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
closed (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            IO ()
c

    Weak (IORef [ByteString])
_ <- IORef [ByteString] -> IO () -> IO (Weak (IORef [ByteString]))
forall a. IORef a -> IO () -> IO (Weak (IORef a))
mkWeakIORef IORef [ByteString]
istack IO ()
close
    Connection -> IO Connection
forall (m :: * -> *) a. Monad m => a -> m a
return (Connection -> IO Connection) -> Connection -> IO Connection
forall a b. (a -> b) -> a -> b
$! Connection :: IO ByteString
-> (ByteString -> IO ())
-> (ByteString -> IO ())
-> IO ()
-> Connection
Connection
        { connectionRead :: IO ByteString
connectionRead = do
            Bool
closed <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
closedVar
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
closed (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ HttpExceptionContent -> IO ()
forall a. HttpExceptionContent -> IO a
throwHttp HttpExceptionContent
ConnectionClosed
            IO (IO ByteString) -> IO ByteString
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ByteString) -> IO ByteString)
-> IO (IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ IORef [ByteString]
-> ([ByteString] -> ([ByteString], IO ByteString))
-> IO (IO ByteString)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef [ByteString]
istack (([ByteString] -> ([ByteString], IO ByteString))
 -> IO (IO ByteString))
-> ([ByteString] -> ([ByteString], IO ByteString))
-> IO (IO ByteString)
forall a b. (a -> b) -> a -> b
$ \stack :: [ByteString]
stack ->
              case [ByteString]
stack of
                  x :: ByteString
x:xs :: [ByteString]
xs -> ([ByteString]
xs, ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
x)
                  [] -> ([], IO ByteString
r)

        , connectionUnread :: ByteString -> IO ()
connectionUnread = \x :: ByteString
x -> do
            Bool
closed <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
closedVar
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
closed (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ HttpExceptionContent -> IO ()
forall a. HttpExceptionContent -> IO a
throwHttp HttpExceptionContent
ConnectionClosed
            IORef [ByteString] -> ([ByteString] -> ([ByteString], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef [ByteString]
istack (([ByteString] -> ([ByteString], ())) -> IO ())
-> ([ByteString] -> ([ByteString], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \stack :: [ByteString]
stack -> (ByteString
xByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[ByteString]
stack, ())

        , connectionWrite :: ByteString -> IO ()
connectionWrite = \x :: ByteString
x -> do
            Bool
closed <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
closedVar
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
closed (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ HttpExceptionContent -> IO ()
forall a. HttpExceptionContent -> IO a
throwHttp HttpExceptionContent
ConnectionClosed
            ByteString -> IO ()
w ByteString
x

        , connectionClose :: IO ()
connectionClose = IO ()
close
        }

-- | Create a new 'Connection' from a 'Socket'.
--
-- @since 0.5.3
socketConnection :: Socket
                 -> Int -- ^ chunk size
                 -> IO Connection
socketConnection :: Socket -> Int -> IO Connection
socketConnection socket :: Socket
socket chunksize :: Int
chunksize = IO ByteString -> (ByteString -> IO ()) -> IO () -> IO Connection
makeConnection
    (Socket -> Int -> IO ByteString
recv Socket
socket Int
chunksize)
    (Socket -> ByteString -> IO ()
sendAll Socket
socket)
    (Socket -> IO ()
NS.close Socket
socket)

openSocketConnection :: (Socket -> IO ())
                     -> Maybe HostAddress
                     -> String -- ^ host
                     -> Int -- ^ port
                     -> IO Connection
openSocketConnection :: (Socket -> IO ())
-> Maybe HostAddress -> String -> Int -> IO Connection
openSocketConnection f :: Socket -> IO ()
f = (Socket -> IO ())
-> Int -> Maybe HostAddress -> String -> Int -> IO Connection
openSocketConnectionSize Socket -> IO ()
f 8192

openSocketConnectionSize :: (Socket -> IO ())
                         -> Int -- ^ chunk size
                         -> Maybe HostAddress
                         -> String -- ^ host
                         -> Int -- ^ port
                         -> IO Connection
openSocketConnectionSize :: (Socket -> IO ())
-> Int -> Maybe HostAddress -> String -> Int -> IO Connection
openSocketConnectionSize tweakSocket :: Socket -> IO ()
tweakSocket chunksize :: Int
chunksize hostAddress' :: Maybe HostAddress
hostAddress' host' :: String
host' port' :: Int
port' =
    (Socket -> IO ())
-> Maybe HostAddress
-> String
-> Int
-> (Socket -> IO Connection)
-> IO Connection
forall a.
(Socket -> IO ())
-> Maybe HostAddress -> String -> Int -> (Socket -> IO a) -> IO a
withSocket Socket -> IO ()
tweakSocket Maybe HostAddress
hostAddress' String
host' Int
port' ((Socket -> IO Connection) -> IO Connection)
-> (Socket -> IO Connection) -> IO Connection
forall a b. (a -> b) -> a -> b
$ \ sock :: Socket
sock ->
        Socket -> Int -> IO Connection
socketConnection Socket
sock Int
chunksize

-- | strippedHostName takes a URI host name, as extracted
-- by 'Network.URI.regName', and strips square brackets
-- around IPv6 addresses.
--
-- The result is suitable for passing to services such as
-- name resolution ('Network.Socket.getAddr').
--
-- @since
strippedHostName :: String -> String
strippedHostName :: String -> String
strippedHostName hostName :: String
hostName =
    case String
hostName of
        '[':'v':_ -> String
hostName -- IPvFuture, no obvious way to deal with this
        '[':rest :: String
rest ->
            case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ']') String
rest of
                (ipv6 :: String
ipv6, "]") -> String
ipv6
                _ -> String
hostName -- invalid host name
        _ -> String
hostName

withSocket :: (Socket -> IO ())
           -> Maybe HostAddress
           -> String -- ^ host
           -> Int -- ^ port
           -> (Socket -> IO a)
           -> IO a
withSocket :: (Socket -> IO ())
-> Maybe HostAddress -> String -> Int -> (Socket -> IO a) -> IO a
withSocket tweakSocket :: Socket -> IO ()
tweakSocket hostAddress' :: Maybe HostAddress
hostAddress' host' :: String
host' port' :: Int
port' f :: Socket -> IO a
f = do
    let hints :: AddrInfo
hints = AddrInfo
NS.defaultHints { addrSocketType :: SocketType
NS.addrSocketType = SocketType
NS.Stream }
    [AddrInfo]
addrs <- case Maybe HostAddress
hostAddress' of
        Nothing ->
            Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
NS.getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
hints) (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String -> String
strippedHostName String
host') (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
port')
        Just ha :: HostAddress
ha ->
            [AddrInfo] -> IO [AddrInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return
                [AddrInfo :: [AddrInfoFlag]
-> Family
-> SocketType
-> ProtocolNumber
-> SockAddr
-> Maybe String
-> AddrInfo
NS.AddrInfo
                 { addrFlags :: [AddrInfoFlag]
NS.addrFlags = []
                 , addrFamily :: Family
NS.addrFamily = Family
NS.AF_INET
                 , addrSocketType :: SocketType
NS.addrSocketType = SocketType
NS.Stream
                 , addrProtocol :: ProtocolNumber
NS.addrProtocol = 6 -- tcp
                 , addrAddress :: SockAddr
NS.addrAddress = PortNumber -> HostAddress -> SockAddr
NS.SockAddrInet (Int -> PortNumber
forall a. Enum a => Int -> a
toEnum Int
port') HostAddress
ha
                 , addrCanonName :: Maybe String
NS.addrCanonName = Maybe String
forall a. Maybe a
Nothing
                 }]

    IO Socket -> (Socket -> IO ()) -> (Socket -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracketOnError ([AddrInfo] -> (AddrInfo -> IO Socket) -> IO Socket
forall a. [AddrInfo] -> (AddrInfo -> IO a) -> IO a
firstSuccessful [AddrInfo]
addrs ((AddrInfo -> IO Socket) -> IO Socket)
-> (AddrInfo -> IO Socket) -> IO Socket
forall a b. (a -> b) -> a -> b
$ (Socket -> IO ()) -> AddrInfo -> IO Socket
forall a. (Socket -> IO a) -> AddrInfo -> IO Socket
openSocket Socket -> IO ()
tweakSocket) Socket -> IO ()
NS.close Socket -> IO a
f

openSocket :: (Socket -> IO a) -> AddrInfo -> IO Socket
openSocket tweakSocket :: Socket -> IO a
tweakSocket addr :: AddrInfo
addr =
    IO Socket
-> (Socket -> IO ()) -> (Socket -> IO Socket) -> IO Socket
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracketOnError
        (Family -> SocketType -> ProtocolNumber -> IO Socket
NS.socket (AddrInfo -> Family
NS.addrFamily AddrInfo
addr) (AddrInfo -> SocketType
NS.addrSocketType AddrInfo
addr)
                   (AddrInfo -> ProtocolNumber
NS.addrProtocol AddrInfo
addr))
        Socket -> IO ()
NS.close
        (\sock :: Socket
sock -> do
            Socket -> SocketOption -> Int -> IO ()
NS.setSocketOption Socket
sock SocketOption
NS.NoDelay 1
            Socket -> IO a
tweakSocket Socket
sock
            Socket -> SockAddr -> IO ()
NS.connect Socket
sock (AddrInfo -> SockAddr
NS.addrAddress AddrInfo
addr)
            Socket -> IO Socket
forall (m :: * -> *) a. Monad m => a -> m a
return Socket
sock)

-- Pick up an IP using an approximation of the happy-eyeballs algorithm:
-- https://datatracker.ietf.org/doc/html/rfc8305
--
firstSuccessful :: [NS.AddrInfo] -> (NS.AddrInfo -> IO a) -> IO a
firstSuccessful :: [AddrInfo] -> (AddrInfo -> IO a) -> IO a
firstSuccessful []        _  = String -> IO a
forall a. HasCallStack => String -> a
error "getAddrInfo returned empty list"
firstSuccessful addresses :: [AddrInfo]
addresses cb :: AddrInfo -> IO a
cb = do
    MVar (Either IOException a)
result <- IO (MVar (Either IOException a))
forall a. IO (MVar a)
newEmptyMVar
    (IOException -> IO a)
-> (a -> IO a) -> Either IOException a -> IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either IOException -> IO a
forall e a. Exception e => e -> IO a
E.throwIO a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either IOException a -> IO a) -> IO (Either IOException a) -> IO a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
        IO Bool
-> (Async Bool -> IO (Either IOException a))
-> IO (Either IOException a)
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync (MVar (Either IOException a) -> IO Bool
tryAddresses MVar (Either IOException a)
result)
            (\_ -> MVar (Either IOException a) -> IO (Either IOException a)
forall a. MVar a -> IO a
takeMVar MVar (Either IOException a)
result)
  where
    -- https://datatracker.ietf.org/doc/html/rfc8305#section-5
    connectionAttemptDelay :: Int
connectionAttemptDelay = 250 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 1000

    tryAddresses :: MVar (Either IOException a) -> IO Bool
tryAddresses result :: MVar (Either IOException a)
result = do
        [Either IOException a]
z <- [(AddrInfo, Int)]
-> ((AddrInfo, Int) -> IO (Either IOException a))
-> IO [Either IOException a]
forall (t :: * -> *) a b.
Traversable t =>
t a -> (a -> IO b) -> IO (t b)
forConcurrently ([AddrInfo] -> [Int] -> [(AddrInfo, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [AddrInfo]
addresses [0..]) (((AddrInfo, Int) -> IO (Either IOException a))
 -> IO [Either IOException a])
-> ((AddrInfo, Int) -> IO (Either IOException a))
-> IO [Either IOException a]
forall a b. (a -> b) -> a -> b
$ \(addr :: AddrInfo
addr, n :: Int
n) -> do
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
connectionAttemptDelay
            AddrInfo -> IO (Either IOException a)
tryAddress AddrInfo
addr

        case [Either IOException a] -> Maybe (Either IOException a)
forall a. [a] -> Maybe a
listToMaybe ([Either IOException a] -> [Either IOException a]
forall a. [a] -> [a]
reverse [Either IOException a]
z) of
            Just e :: Either IOException a
e@(Left _) -> MVar (Either IOException a) -> Either IOException a -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar (Either IOException a)
result Either IOException a
e
            _               -> String -> IO Bool
forall a. HasCallStack => String -> a
error (String -> IO Bool) -> String -> IO Bool
forall a b. (a -> b) -> a -> b
$ "tryAddresses invariant violated: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [AddrInfo] -> String
forall a. Show a => a -> String
show [AddrInfo]
addresses
      where
        tryAddress :: AddrInfo -> IO (Either IOException a)
tryAddress addr :: AddrInfo
addr = do
            Either IOException a
r :: Either E.IOException a <- IO a -> IO (Either IOException a)
forall e a. Exception e => IO a -> IO (Either e a)
E.try (IO a -> IO (Either IOException a))
-> IO a -> IO (Either IOException a)
forall a b. (a -> b) -> a -> b
$! AddrInfo -> IO a
cb AddrInfo
addr
            Either IOException a -> (a -> IO Bool) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Either IOException a
r ((a -> IO Bool) -> IO ()) -> (a -> IO Bool) -> IO ()
forall a b. (a -> b) -> a -> b
$ \_ -> MVar (Either IOException a) -> Either IOException a -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar (Either IOException a)
result Either IOException a
r
            Either IOException a -> IO (Either IOException a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either IOException a
r