{-# 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 :: 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
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Bool
S.null ByteString
bs) forall a b. (a -> b) -> a -> b
$ 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 = forall a. (a -> a) -> a
fix forall a b. (a -> b) -> a -> b
$ \IO ()
loop -> do
    ByteString
bs <- Maybe MaxHeaderLength -> Connection -> IO ByteString
connectionReadLine Maybe MaxHeaderLength
mhl Connection
conn
    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 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 (forall a. Eq a => a -> a -> Bool
== Word8
charLF) ByteString
bs of
            (ByteString
_, ByteString
"") -> do
                let total' :: Int
total' = Int
total forall a. Num a => a -> a -> a
+ ByteString -> Int
S.length ByteString
bs
                case forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MaxHeaderLength -> Int
unMaxHeaderLength Maybe MaxHeaderLength
mhl of
                    Maybe Int
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                    Just Int
n -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
total' forall a. Ord a => a -> a -> Bool
> Int
n) forall a b. (a -> b) -> a -> b
$ forall a. HttpExceptionContent -> IO a
throwHttp HttpExceptionContent
OverlongHeaders
                ByteString
bs' <- Connection -> IO ByteString
connectionRead Connection
conn
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Bool
S.null ByteString
bs') forall a b. (a -> b) -> a -> b
$ forall a. HttpExceptionContent -> IO a
throwHttp HttpExceptionContent
IncompleteHeaders
                ByteString
-> ([ByteString] -> [ByteString]) -> Int -> IO ByteString
go ByteString
bs' ([ByteString] -> [ByteString]
front forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString
bsforall a. a -> [a] -> [a]
:)) Int
total'
            (ByteString
x, Int -> ByteString -> ByteString
S.drop Int
1 -> ByteString
y) -> do
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
S.null ByteString
y) forall a b. (a -> b) -> a -> b
$! Connection -> ByteString -> IO ()
connectionUnread Connection
conn ByteString
y
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ByteString -> ByteString
killCR forall a b. (a -> b) -> a -> b
$! [ByteString] -> ByteString
S.concat forall a b. (a -> b) -> a -> b
$! [ByteString] -> [ByteString]
front [ByteString
x]

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
S.last ByteString
bs forall a. Eq a => a -> a -> Bool
== Word8
charCR = HasCallStack => 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 <- forall a. a -> IO (IORef a)
newIORef [ByteString]
input0
    IORef [ByteString]
ioutput <- forall a. a -> IO (IORef a)
newIORef []
    forall (m :: * -> *) a. Monad m => a -> m a
return (Connection
        { connectionRead :: IO ByteString
connectionRead = forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef [ByteString]
iinput 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 -> forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef [ByteString]
iinput forall a b. (a -> b) -> a -> b
$ \[ByteString]
input -> (ByteString
xforall a. a -> [a] -> [a]
:[ByteString]
input, ())
        , connectionWrite :: ByteString -> IO ()
connectionWrite = \ByteString
x -> forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef [ByteString]
ioutput forall a b. (a -> b) -> a -> b
$ \[ByteString]
output -> ([ByteString]
output forall a. [a] -> [a] -> [a]
++ [ByteString
x], ())
        , connectionClose :: IO ()
connectionClose = forall (m :: * -> *) a. Monad m => a -> m a
return ()
        }, forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef [ByteString]
ioutput forall a b. (a -> b) -> a -> b
$ \[ByteString]
output -> ([], [ByteString]
output), 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 <- 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 <- forall a. a -> IO (IORef a)
newIORef Bool
False

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

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

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

        , connectionWrite :: ByteString -> IO ()
connectionWrite = \ByteString
x -> do
            Bool
closed <- forall a. IORef a -> IO a
readIORef IORef Bool
closedVar
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
closed forall a b. (a -> b) -> a -> b
$ 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' =
    forall a.
(Socket -> IO ())
-> Maybe HostAddress -> [Char] -> Int -> (Socket -> IO a) -> IO a
withSocket Socket -> IO ()
tweakSocket Maybe HostAddress
hostAddress' [Char]
host' Int
port' 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 forall a. (a -> Bool) -> [a] -> ([a], [a])
break (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 { addrSocketType :: SocketType
NS.addrSocketType = SocketType
NS.Stream }
    [AddrInfo]
addrs <- case Maybe HostAddress
hostAddress' of
        Maybe HostAddress
Nothing ->
            Maybe AddrInfo -> Maybe [Char] -> Maybe [Char] -> IO [AddrInfo]
NS.getAddrInfo (forall a. a -> Maybe a
Just AddrInfo
hints) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
strippedHostName [Char]
host') (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show Int
port')
        Just HostAddress
ha ->
            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 (forall a. Enum a => Int -> a
toEnum Int
port') HostAddress
ha
                 , addrCanonName :: Maybe [Char]
NS.addrCanonName = forall a. Maybe a
Nothing
                 }]

    forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracketOnError (forall a. [AddrInfo] -> (AddrInfo -> IO a) -> IO a
firstSuccessful [AddrInfo]
addrs forall a b. (a -> b) -> a -> b
$ 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 =
    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)
            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
_  = forall a. HasCallStack => [Char] -> a
error [Char]
"getAddrInfo returned empty list"
firstSuccessful [AddrInfo]
addresses AddrInfo -> IO a
cb = do
    MVar (Either IOException a)
result <- forall a. IO (MVar a)
newEmptyMVar
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall e a. Exception e => e -> IO a
E.throwIO forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
        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
_ -> 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 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 <- forall (t :: * -> *) a b.
Traversable t =>
t a -> (a -> IO b) -> IO (t b)
forConcurrently (forall a b. [a] -> [b] -> [(a, b)]
zip [AddrInfo]
addresses [Int
0..]) forall a b. (a -> b) -> a -> b
$ \(AddrInfo
addr, Int
n) -> do
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n forall a. Ord a => a -> a -> Bool
> Int
0) forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay forall a b. (a -> b) -> a -> b
$ Int
n forall a. Num a => a -> a -> a
* Int
connectionAttemptDelay
            AddrInfo -> IO (Either IOException a)
tryAddress AddrInfo
addr

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