{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module Network.HTTP.Client.Connection
    ( connectionReadLine
    , connectionReadLineWith
    , connectionDropTillBlankLine
    , connectionUnreadLine
    , 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 :: Maybe MaxHeaderLength -> Connection -> IO ByteString
connectionReadLine :: Maybe MaxHeaderLength -> Connection -> IO ByteString
connectionReadLine Maybe MaxHeaderLength
mhl 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
    Maybe MaxHeaderLength -> Connection -> ByteString -> IO ByteString
connectionReadLineWith Maybe MaxHeaderLength
mhl Connection
conn ByteString
bs

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

connectionReadLineWith :: Maybe MaxHeaderLength -> Connection -> ByteString -> IO ByteString
connectionReadLineWith :: Maybe MaxHeaderLength -> Connection -> ByteString -> IO ByteString
connectionReadLineWith Maybe MaxHeaderLength
mhl Connection
conn ByteString
bs0 =
    ByteString
-> ([ByteString] -> [ByteString]) -> Int -> IO ByteString
go ByteString
bs0 [ByteString] -> [ByteString]
forall a. a -> a
id Int
0
  where
    go :: ByteString
-> ([ByteString] -> [ByteString]) -> Int -> IO ByteString
go ByteString
bs [ByteString] -> [ByteString]
front 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
            (ByteString
_, ByteString
"") -> do
                let total' :: Int
total' = Int
total Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
S.length ByteString
bs
                case (MaxHeaderLength -> Int) -> Maybe MaxHeaderLength -> Maybe Int
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MaxHeaderLength -> Int
unMaxHeaderLength Maybe MaxHeaderLength
mhl of
                    Maybe Int
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                    Just Int
n -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
total' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n) (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'
            (ByteString
x, Int -> ByteString -> ByteString
S.drop Int
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 a. a -> IO a
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]

connectionUnreadLine :: Connection -> ByteString -> IO ()
connectionUnreadLine :: Connection -> ByteString -> IO ()
connectionUnreadLine Connection
conn ByteString
line = do
  Connection -> ByteString -> IO ()
connectionUnread Connection
conn ([Word8] -> ByteString
S.pack [Word8
charCR, Word8
charLF])
  Connection -> ByteString -> IO ()
connectionUnread Connection
conn ByteString
line

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

killCR :: ByteString -> ByteString
killCR :: ByteString -> ByteString
killCR ByteString
bs
    | ByteString -> Bool
S.null ByteString
bs = ByteString
bs
    | HasCallStack => ByteString -> Word8
ByteString -> Word8
S.last ByteString
bs Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
charCR = HasCallStack => ByteString -> ByteString
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 [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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (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
$ \[ByteString]
input ->
            case [ByteString]
input of
                [] -> ([], ByteString
empty)
                ByteString
x:[ByteString]
xs -> ([ByteString]
xs, ByteString
x)
        , connectionUnread :: ByteString -> IO ()
connectionUnread = \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
$ \[ByteString]
input -> (ByteString
xByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[ByteString]
input, ())
        , connectionWrite :: ByteString -> IO ()
connectionWrite = \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
$ \[ByteString]
output -> ([ByteString]
output [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ [ByteString
x], ())
        , connectionClose :: IO ()
connectionClose = () -> IO ()
forall a. a -> IO a
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
$ \[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 IO ByteString
r ByteString -> IO ()
w 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 (\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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Connection -> IO Connection) -> Connection -> IO Connection
forall a b. (a -> b) -> a -> b
$! 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
$ \[ByteString]
stack ->
              case [ByteString]
stack of
                  ByteString
x:[ByteString]
xs -> ([ByteString]
xs, ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
x)
                  [] -> ([], IO ByteString
r)

        , connectionUnread :: ByteString -> IO ()
connectionUnread = \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
$ \[ByteString]
stack -> (ByteString
xByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[ByteString]
stack, ())

        , connectionWrite :: ByteString -> IO ()
connectionWrite = \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 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 -> [Char] -> Int -> IO Connection
openSocketConnection Socket -> IO ()
f = (Socket -> IO ())
-> Int -> Maybe HostAddress -> [Char] -> Int -> IO Connection
openSocketConnectionSize Socket -> IO ()
f Int
8192

openSocketConnectionSize :: (Socket -> IO ())
                         -> Int -- ^ chunk size
                         -> Maybe HostAddress
                         -> String -- ^ host
                         -> Int -- ^ port
                         -> IO Connection
openSocketConnectionSize :: (Socket -> IO ())
-> Int -> Maybe HostAddress -> [Char] -> Int -> IO Connection
openSocketConnectionSize Socket -> IO ()
tweakSocket Int
chunksize Maybe HostAddress
hostAddress' [Char]
host' Int
port' =
    (Socket -> IO ())
-> Maybe HostAddress
-> [Char]
-> Int
-> (Socket -> IO Connection)
-> IO Connection
forall a.
(Socket -> IO ())
-> Maybe HostAddress -> [Char] -> Int -> (Socket -> IO a) -> IO a
withSocket Socket -> IO ()
tweakSocket Maybe HostAddress
hostAddress' [Char]
host' Int
port' ((Socket -> IO Connection) -> IO Connection)
-> (Socket -> IO Connection) -> IO Connection
forall a b. (a -> b) -> a -> b
$ \ 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 :: [Char] -> [Char]
strippedHostName [Char]
hostName =
    case [Char]
hostName of
        Char
'[':Char
'v':[Char]
_ -> [Char]
hostName -- IPvFuture, no obvious way to deal with this
        Char
'[':[Char]
rest ->
            case (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
']') [Char]
rest of
                ([Char]
ipv6, [Char]
"]") -> [Char]
ipv6
                ([Char], [Char])
_ -> [Char]
hostName -- invalid host name
        [Char]
_ -> [Char]
hostName

withSocket :: (Socket -> IO ())
           -> Maybe HostAddress
           -> String -- ^ host
           -> Int -- ^ port
           -> (Socket -> IO a)
           -> IO a
withSocket :: forall a.
(Socket -> IO ())
-> Maybe HostAddress -> [Char] -> Int -> (Socket -> IO a) -> IO a
withSocket Socket -> IO ()
tweakSocket Maybe HostAddress
hostAddress' [Char]
host' Int
port' Socket -> IO a
f = do
    let hints :: AddrInfo
hints = AddrInfo
NS.defaultHints { NS.addrSocketType = NS.Stream }
    [AddrInfo]
addrs <- case Maybe HostAddress
hostAddress' of
        Maybe HostAddress
Nothing ->
            Maybe AddrInfo -> Maybe [Char] -> Maybe [Char] -> IO [AddrInfo]
NS.getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
hints) ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
strippedHostName [Char]
host') ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
port')
        Just HostAddress
ha ->
            [AddrInfo] -> IO [AddrInfo]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
                [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 = ProtocolNumber
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 [Char]
NS.addrCanonName = Maybe [Char]
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 Socket -> IO a
tweakSocket 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
        (\Socket
sock -> do
            Socket -> SocketOption -> Int -> IO ()
NS.setSocketOption Socket
sock SocketOption
NS.NoDelay Int
1
            Socket -> IO a
tweakSocket Socket
sock
            Socket -> SockAddr -> IO ()
NS.connect Socket
sock (AddrInfo -> SockAddr
NS.addrAddress AddrInfo
addr)
            Socket -> IO Socket
forall a. a -> IO a
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 :: forall a. [AddrInfo] -> (AddrInfo -> IO a) -> IO a
firstSuccessful []        AddrInfo -> IO a
_  = [Char] -> IO a
forall a. HasCallStack => [Char] -> a
error [Char]
"getAddrInfo returned empty list"
firstSuccessful [AddrInfo]
addresses 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 a. 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)
            (\Async Bool
_ -> 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 = Int
250 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000

    tryAddresses :: MVar (Either IOException a) -> IO Bool
tryAddresses 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 [Int
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
$ \(AddrInfo
addr, 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
> Int
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 IOException
_) -> 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
            Maybe (Either IOException a)
_               -> [Char] -> IO Bool
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO Bool) -> [Char] -> IO Bool
forall a b. (a -> b) -> a -> b
$ [Char]
"tryAddresses invariant violated: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [AddrInfo] -> [Char]
forall a. Show a => a -> [Char]
show [AddrInfo]
addresses
      where
        tryAddress :: AddrInfo -> IO (Either IOException a)
tryAddress 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
$ \a
_ -> 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 a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either IOException a
r