{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

module HTTP2.Client.Manager.Internal where

import Control.Concurrent
import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Data.ByteString
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as C8
import Data.IORef
import Data.Map
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Data.Streaming.Network
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Data.Unique
import Foreign.Marshal.Alloc (mallocBytes)
import GHC.IO.Exception
import qualified Network.HTTP2.Client as HTTP2
import qualified Network.Socket as NS
import qualified OpenSSL.Session as SSL
import System.IO.Error
import qualified System.TimeManager
import System.Timeout
import Prelude

data HTTP2Conn = HTTP2Conn
  { HTTP2Conn -> Async ()
backgroundThread :: Async (),
    HTTP2Conn -> IO ()
disconnect :: IO (),
    HTTP2Conn -> MVar ConnectionAction
connectionActionMVar :: MVar ConnectionAction
  }

type TLSEnabled = Bool

type HostName = ByteString

type Port = Int

type Target = (TLSEnabled, HostName, Port)

data ConnectionAction
  = SendRequest Request
  | CloseConnection

data Request = Request
  { -- | The request to be sent.
    Request -> Request
request :: HTTP2.Request,
    -- | Consumer for the response, must not exit until the response body is
    -- completely consumed.
    --
    -- The response consumer has to return 'IO ()' because we want to processes
    -- different requests on one connection and 'HTTP2.run' ties the return type
    -- of response consumer to the return type of itself. Even if the response
    -- consumer returned something else we would need another empty MVar to
    -- write the result, this is being dealt with in
    -- 'sendRequestWithConnection'.
    Request -> Response -> IO ()
responseConsumer :: HTTP2.Response -> IO (),
    -- | There are exceptions which cannot be communicated in a continuation
    -- becasue they can be raised even before the continuation starts. We also
    -- need a way to communicate any exceptions raised by the continuation
    -- itself. This 'MVar' will be written to in any of those cases.
    Request -> MVar SomeException
exceptionMVar :: MVar SomeException
  }

-- | FUTUREWORK: Support HTTPS, perhaps ALPN negotiation can also be used to
-- HTTP1. I think HTTP1 vs HTTP2 can not be negotated without TLS, so perhaps
-- this manager will default to HTTP2.
data Http2Manager = Http2Manager
  { Http2Manager -> TVar (Map Target HTTP2Conn)
connections :: TVar (Map Target HTTP2Conn),
    Http2Manager -> Int
cacheLimit :: Int,
    -- | In microseconds, defaults to 30s
    Http2Manager -> Int
tcpConnectionTimeout :: Int,
    Http2Manager -> SSLContext
sslContext :: SSL.SSLContext,
    Http2Manager -> Bool
sslRemoveTrailingDot :: Bool
  }

defaultHttp2Manager :: IO Http2Manager
defaultHttp2Manager :: IO Http2Manager
defaultHttp2Manager = do
  SSLContext
ctx <- IO SSLContext
SSL.context
  SSLContext -> VerificationMode -> IO ()
SSL.contextSetVerificationMode SSLContext
ctx (VerificationMode -> IO ()) -> VerificationMode -> IO ()
forall a b. (a -> b) -> a -> b
$
    SSL.VerifyPeer
      { vpFailIfNoPeerCert :: Bool
vpFailIfNoPeerCert = Bool
True,
        -- Only relvant when running as server
        vpClientOnce :: Bool
vpClientOnce = Bool
False,
        vpCallback :: Maybe (Bool -> X509StoreCtx -> IO Bool)
vpCallback = Maybe (Bool -> X509StoreCtx -> IO Bool)
forall a. Maybe a
Nothing
      }
  SSLContext -> [ByteString] -> IO ()
SSL.contextSetALPNProtos SSLContext
ctx [ByteString
"h2"]
  SSLContext -> IO Http2Manager
http2ManagerWithSSLCtx SSLContext
ctx

http2ManagerWithSSLCtx :: SSL.SSLContext -> IO Http2Manager
http2ManagerWithSSLCtx :: SSLContext -> IO Http2Manager
http2ManagerWithSSLCtx SSLContext
sslContext = do
  TVar (Map Target HTTP2Conn)
connections <- Map Target HTTP2Conn -> IO (TVar (Map Target HTTP2Conn))
forall a. a -> IO (TVar a)
newTVarIO Map Target HTTP2Conn
forall a. Monoid a => a
mempty
  let cacheLimit :: Int
cacheLimit = Int
20
      tcpConnectionTimeout :: Int
tcpConnectionTimeout = Int
30_000_000
      sslRemoveTrailingDot :: Bool
sslRemoveTrailingDot = Bool
False
  Http2Manager -> IO Http2Manager
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Http2Manager -> IO Http2Manager)
-> Http2Manager -> IO Http2Manager
forall a b. (a -> b) -> a -> b
$ Http2Manager {Bool
Int
SSLContext
TVar (Map Target HTTP2Conn)
connections :: TVar (Map Target HTTP2Conn)
cacheLimit :: Int
tcpConnectionTimeout :: Int
sslContext :: SSLContext
sslRemoveTrailingDot :: Bool
sslContext :: SSLContext
connections :: TVar (Map Target HTTP2Conn)
cacheLimit :: Int
tcpConnectionTimeout :: Int
sslRemoveTrailingDot :: Bool
..}

-- | Warning: This won't affect already established connections
setCacheLimit :: Int -> Http2Manager -> Http2Manager
setCacheLimit :: Int -> Http2Manager -> Http2Manager
setCacheLimit Int
cl Http2Manager
mgr = Http2Manager
mgr {cacheLimit = cl}

-- | Warning: This won't affect already established connections
setSSLContext :: SSL.SSLContext -> Http2Manager -> Http2Manager
setSSLContext :: SSLContext -> Http2Manager -> Http2Manager
setSSLContext SSLContext
ctx Http2Manager
mgr = Http2Manager
mgr {sslContext = ctx}

-- | Remove traling dots in hostname while verifying hostname in the certificate
-- presented by the server. For instance, when connecting with
-- 'foo.example.com.' (Note the trailing dot) by default most SSL libraries fail
-- hostname verification if the server has a certificate for 'foo.example.com'
-- (Note the lack of a trailing dot). Setting this flag makes the hostname
-- verification succeed for these hosts. However, this will make the hostname
-- verification fail if the host presents a certificate which does have a
-- trailing dot.
--
-- Discussion about why this is not implemented as a flag on 'SSLContext':
-- https://github.com/openssl/openssl/issues/11560
--
-- Warning: This won't affect already established connections
setSSLRemoveTrailingDot :: Bool -> Http2Manager -> Http2Manager
setSSLRemoveTrailingDot :: Bool -> Http2Manager -> Http2Manager
setSSLRemoveTrailingDot Bool
b Http2Manager
mgr = Http2Manager
mgr {sslRemoveTrailingDot = b}

-- | In microseconds
setTCPConnectionTimeout :: Int -> Http2Manager -> Http2Manager
setTCPConnectionTimeout :: Int -> Http2Manager -> Http2Manager
setTCPConnectionTimeout Int
n Http2Manager
mgr = Http2Manager
mgr {tcpConnectionTimeout = n}

-- | Does not check whether connection is actually running. Users should use
-- 'withHTTP2Request'. This function is good for testing.
sendRequestWithConnection :: HTTP2Conn -> HTTP2.Request -> (HTTP2.Response -> IO r) -> IO r
sendRequestWithConnection :: forall r. HTTP2Conn -> Request -> (Response -> IO r) -> IO r
sendRequestWithConnection HTTP2Conn
conn Request
req Response -> IO r
k = do
  MVar r
result :: MVar r <- IO (MVar r)
forall a. IO (MVar a)
newEmptyMVar
  MVar SomeException
threadKilled :: MVar SomeException <- IO (MVar SomeException)
forall a. IO (MVar a)
newEmptyMVar
  MVar ConnectionAction -> ConnectionAction -> IO ()
forall a. MVar a -> a -> IO ()
putMVar (HTTP2Conn -> MVar ConnectionAction
connectionActionMVar HTTP2Conn
conn) (Request -> ConnectionAction
SendRequest (Request -> (Response -> IO ()) -> MVar SomeException -> Request
Request Request
req (MVar r -> r -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar r
result (r -> IO ()) -> (Response -> IO r) -> Response -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Response -> IO r
k) MVar SomeException
threadKilled))
  IO r -> IO SomeException -> IO (Either r SomeException)
forall a b. IO a -> IO b -> IO (Either a b)
race (MVar r -> IO r
forall a. MVar a -> IO a
takeMVar MVar r
result) (MVar SomeException -> IO SomeException
forall a. MVar a -> IO a
takeMVar MVar SomeException
threadKilled) IO (Either r SomeException)
-> (Either r SomeException -> IO r) -> IO r
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left r
r -> r -> IO r
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure r
r
    Right (SomeException e
e) -> e -> IO r
forall a e. Exception e => e -> a
throw e
e

-- | Make an HTTP2 request, if it is the first time the 'Http2Manager' sees this
-- target, it creates the connection and keeps it around for
-- any subsequent requests. Subsequest requests try to use this connection, in
-- case the connection is already dead (e.g. the background thread has
-- finished), a new connection is created.
--
-- It is important that the continuation provided by the caller of this function
-- consumes the response body completely before it returns.
--
-- NOTE: If many concurrent requests are made to the same server using a single
-- instance of 'Http2Manager', it could cause the manager to make multiple
-- connections to the server. Eventually only one connection will be kept open.
-- This, in theory, would cause some contention over 'STM' based 'Map' that the
-- 'Http2Manager' keeps and so could decrease throughput. In cases where many
-- concurrent requests are to be made, it might be best to ensure that a
-- connection exists using 'connectIfNotAlreadyConnected' before making all the
-- requests.
withHTTP2Request :: Http2Manager -> Target -> HTTP2.Request -> (HTTP2.Response -> IO a) -> IO a
withHTTP2Request :: forall a.
Http2Manager -> Target -> Request -> (Response -> IO a) -> IO a
withHTTP2Request Http2Manager
mgr Target
target Request
req Response -> IO a
k = do
  HTTP2Conn
conn <- Http2Manager -> Target -> IO HTTP2Conn
getOrMakeConnection Http2Manager
mgr Target
target
  HTTP2Conn -> Request -> (Response -> IO a) -> IO a
forall r. HTTP2Conn -> Request -> (Response -> IO r) -> IO r
sendRequestWithConnection HTTP2Conn
conn Request
req Response -> IO a
k

-- | Temporary workaround for https://github.com/kazu-yamamoto/http2/issues/102
withHTTP2RequestOnSingleUseConn :: Http2Manager -> Target -> HTTP2.Request -> (HTTP2.Response -> IO a) -> IO a
withHTTP2RequestOnSingleUseConn :: forall a.
Http2Manager -> Target -> Request -> (Response -> IO a) -> IO a
withHTTP2RequestOnSingleUseConn Http2Manager {Bool
Int
SSLContext
TVar (Map Target HTTP2Conn)
connections :: Http2Manager -> TVar (Map Target HTTP2Conn)
cacheLimit :: Http2Manager -> Int
tcpConnectionTimeout :: Http2Manager -> Int
sslContext :: Http2Manager -> SSLContext
sslRemoveTrailingDot :: Http2Manager -> Bool
connections :: TVar (Map Target HTTP2Conn)
cacheLimit :: Int
tcpConnectionTimeout :: Int
sslContext :: SSLContext
sslRemoveTrailingDot :: Bool
..} Target
target Request
req Response -> IO a
k = do
  MVar ConnectionAction
sendReqMVar <- IO (MVar ConnectionAction)
forall a. IO (MVar a)
newEmptyMVar
  Async ()
thread <- IO (Async ()) -> IO (Async ())
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Async ()) -> IO (Async ()))
-> (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ SSLContext
-> Target -> Int -> Bool -> Int -> MVar ConnectionAction -> IO ()
startPersistentHTTP2Connection SSLContext
sslContext Target
target Int
cacheLimit Bool
sslRemoveTrailingDot Int
tcpConnectionTimeout MVar ConnectionAction
sendReqMVar
  let newConn :: HTTP2Conn
newConn = Async () -> IO () -> MVar ConnectionAction -> HTTP2Conn
HTTP2Conn Async ()
thread (MVar ConnectionAction -> ConnectionAction -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ConnectionAction
sendReqMVar ConnectionAction
CloseConnection) MVar ConnectionAction
sendReqMVar
  HTTP2Conn -> Request -> (Response -> IO a) -> IO a
forall r. HTTP2Conn -> Request -> (Response -> IO r) -> IO r
sendRequestWithConnection HTTP2Conn
newConn Request
req ((Response -> IO a) -> IO a) -> (Response -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Response
resp -> do
    Response -> IO a
k Response
resp IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* HTTP2Conn -> IO ()
disconnect HTTP2Conn
newConn

-- | Connects to a server if it is not already connected, useful when making
-- many concurrent requests. This way the first few requests don't have to fight
-- for making a connection This way the first few requests don't have to fight
-- for making a connection.
connectIfNotAlreadyConnected :: Http2Manager -> Target -> IO ()
connectIfNotAlreadyConnected :: Http2Manager -> Target -> IO ()
connectIfNotAlreadyConnected Http2Manager
mgr Target
target = IO HTTP2Conn -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO HTTP2Conn -> IO ()) -> IO HTTP2Conn -> IO ()
forall a b. (a -> b) -> a -> b
$ Http2Manager -> Target -> IO HTTP2Conn
getOrMakeConnection Http2Manager
mgr Target
target

-- | Gets a connection if it exists and is alive, otherwise connects to the
-- given 'Target'.
getOrMakeConnection :: Http2Manager -> Target -> IO HTTP2Conn
getOrMakeConnection :: Http2Manager -> Target -> IO HTTP2Conn
getOrMakeConnection mgr :: Http2Manager
mgr@Http2Manager {Bool
Int
SSLContext
TVar (Map Target HTTP2Conn)
connections :: Http2Manager -> TVar (Map Target HTTP2Conn)
cacheLimit :: Http2Manager -> Int
tcpConnectionTimeout :: Http2Manager -> Int
sslContext :: Http2Manager -> SSLContext
sslRemoveTrailingDot :: Http2Manager -> Bool
connections :: TVar (Map Target HTTP2Conn)
cacheLimit :: Int
tcpConnectionTimeout :: Int
sslContext :: SSLContext
sslRemoveTrailingDot :: Bool
..} Target
target = do
  Maybe HTTP2Conn
mConn <- STM (Maybe HTTP2Conn) -> IO (Maybe HTTP2Conn)
forall a. STM a -> IO a
atomically (STM (Maybe HTTP2Conn) -> IO (Maybe HTTP2Conn))
-> STM (Maybe HTTP2Conn) -> IO (Maybe HTTP2Conn)
forall a b. (a -> b) -> a -> b
$ Http2Manager -> Target -> STM (Maybe HTTP2Conn)
getConnection Http2Manager
mgr Target
target
  IO HTTP2Conn
-> (HTTP2Conn -> IO HTTP2Conn) -> Maybe HTTP2Conn -> IO HTTP2Conn
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO HTTP2Conn
connect HTTP2Conn -> IO HTTP2Conn
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe HTTP2Conn
mConn
  where
    -- Ensures that any old connection is preserved. This is required to ensure
    -- that concurrent calls to this function don't cause the connections to
    -- leak.
    insertNewConn :: HTTP2Conn -> STM (Bool, HTTP2Conn)
    insertNewConn :: HTTP2Conn -> STM (Bool, HTTP2Conn)
insertNewConn HTTP2Conn
newConn = do
      TVar (Map Target HTTP2Conn)
-> (Map Target HTTP2Conn
    -> ((Bool, HTTP2Conn), Map Target HTTP2Conn))
-> STM (Bool, HTTP2Conn)
forall s a. TVar s -> (s -> (a, s)) -> STM a
stateTVar TVar (Map Target HTTP2Conn)
connections ((Map Target HTTP2Conn
  -> ((Bool, HTTP2Conn), Map Target HTTP2Conn))
 -> STM (Bool, HTTP2Conn))
-> (Map Target HTTP2Conn
    -> ((Bool, HTTP2Conn), Map Target HTTP2Conn))
-> STM (Bool, HTTP2Conn)
forall a b. (a -> b) -> a -> b
$ \Map Target HTTP2Conn
conns ->
        case Target -> Map Target HTTP2Conn -> Maybe HTTP2Conn
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Target
target Map Target HTTP2Conn
conns of
          Maybe HTTP2Conn
Nothing -> ((Bool
True, HTTP2Conn
newConn), Target -> HTTP2Conn -> Map Target HTTP2Conn -> Map Target HTTP2Conn
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Target
target HTTP2Conn
newConn Map Target HTTP2Conn
conns)
          Just HTTP2Conn
alreadyEstablishedConn -> ((Bool
False, HTTP2Conn
alreadyEstablishedConn), Map Target HTTP2Conn
conns)

    connect :: IO HTTP2Conn
    connect :: IO HTTP2Conn
connect = do
      MVar ConnectionAction
sendReqMVar <- IO (MVar ConnectionAction)
forall a. IO (MVar a)
newEmptyMVar
      Async ()
thread <- IO (Async ()) -> IO (Async ())
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Async ()) -> IO (Async ()))
-> (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ SSLContext
-> Target -> Int -> Bool -> Int -> MVar ConnectionAction -> IO ()
startPersistentHTTP2Connection SSLContext
sslContext Target
target Int
cacheLimit Bool
sslRemoveTrailingDot Int
tcpConnectionTimeout MVar ConnectionAction
sendReqMVar
      let newConn :: HTTP2Conn
newConn = Async () -> IO () -> MVar ConnectionAction -> HTTP2Conn
HTTP2Conn Async ()
thread (MVar ConnectionAction -> ConnectionAction -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ConnectionAction
sendReqMVar ConnectionAction
CloseConnection) MVar ConnectionAction
sendReqMVar
      (Bool
inserted, HTTP2Conn
finalConn) <- STM (Bool, HTTP2Conn) -> IO (Bool, HTTP2Conn)
forall a. STM a -> IO a
atomically (STM (Bool, HTTP2Conn) -> IO (Bool, HTTP2Conn))
-> STM (Bool, HTTP2Conn) -> IO (Bool, HTTP2Conn)
forall a b. (a -> b) -> a -> b
$ HTTP2Conn -> STM (Bool, HTTP2Conn)
insertNewConn HTTP2Conn
newConn
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
inserted (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        -- It is possible that the connection won't leak because it is waiting
        -- on an MVar and as soon as it gets removed from the map and GC collects
        -- the 'HTTP2Conn', the connection thread _should_ in theory get
        -- 'BlockedIndefinitelyOnMVar' exception. So perhaps this is useless?
        HTTP2Conn -> IO ()
disconnect HTTP2Conn
newConn
      HTTP2Conn -> IO HTTP2Conn
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HTTP2Conn
finalConn

-- | Removes connection from map if it is not alive anymore
getConnection :: Http2Manager -> Target -> STM (Maybe HTTP2Conn)
getConnection :: Http2Manager -> Target -> STM (Maybe HTTP2Conn)
getConnection Http2Manager
mgr Target
target = do
  Map Target HTTP2Conn
conns <- TVar (Map Target HTTP2Conn) -> STM (Map Target HTTP2Conn)
forall a. TVar a -> STM a
readTVar (Http2Manager -> TVar (Map Target HTTP2Conn)
connections Http2Manager
mgr)
  case Target -> Map Target HTTP2Conn -> Maybe HTTP2Conn
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Target
target Map Target HTTP2Conn
conns of
    Maybe HTTP2Conn
Nothing -> Maybe HTTP2Conn -> STM (Maybe HTTP2Conn)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe HTTP2Conn
forall a. Maybe a
Nothing
    Just HTTP2Conn
conn ->
      -- If there is a connection for the target, ensure that it is alive
      -- before using it.
      Async () -> STM (Maybe (Either SomeException ()))
forall a. Async a -> STM (Maybe (Either SomeException a))
pollSTM (HTTP2Conn -> Async ()
backgroundThread HTTP2Conn
conn) STM (Maybe (Either SomeException ()))
-> (Maybe (Either SomeException ()) -> STM (Maybe HTTP2Conn))
-> STM (Maybe HTTP2Conn)
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe (Either SomeException ())
Nothing -> Maybe HTTP2Conn -> STM (Maybe HTTP2Conn)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HTTP2Conn -> Maybe HTTP2Conn
forall a. a -> Maybe a
Just HTTP2Conn
conn)
        Just Either SomeException ()
_ -> do
          -- Maybe there is value in logging any exceptions we
          -- recieve here. But logging in STM will be tricky, and the threads
          -- running requests on the connection which got an exception would've
          -- anyway recieved the exception, so maybe it is not as valueable.
          TVar (Map Target HTTP2Conn) -> Map Target HTTP2Conn -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (Http2Manager -> TVar (Map Target HTTP2Conn)
connections Http2Manager
mgr) (Map Target HTTP2Conn -> STM ()) -> Map Target HTTP2Conn -> STM ()
forall a b. (a -> b) -> a -> b
$ Target -> Map Target HTTP2Conn -> Map Target HTTP2Conn
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Target
target Map Target HTTP2Conn
conns
          Maybe HTTP2Conn -> STM (Maybe HTTP2Conn)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe HTTP2Conn
forall a. Maybe a
Nothing

-- | Disconnects HTTP2 connection if there exists one. Will hang around until
-- all the ongoing requests complete. This would throw an error if the
-- background thread maintaining the connection throws an error, e.g. there was
-- a TLS error or the connection was already disconnected with error.
disconnectTarget :: Http2Manager -> Target -> IO ()
disconnectTarget :: Http2Manager -> Target -> IO ()
disconnectTarget Http2Manager
mgr Target
target = do
  Maybe HTTP2Conn
mConn <- STM (Maybe HTTP2Conn) -> IO (Maybe HTTP2Conn)
forall a. STM a -> IO a
atomically (STM (Maybe HTTP2Conn) -> IO (Maybe HTTP2Conn))
-> STM (Maybe HTTP2Conn) -> IO (Maybe HTTP2Conn)
forall a b. (a -> b) -> a -> b
$ Http2Manager -> Target -> STM (Maybe HTTP2Conn)
getConnection Http2Manager
mgr Target
target
  case Maybe HTTP2Conn
mConn of
    Maybe HTTP2Conn
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just HTTP2Conn
conn -> do
      HTTP2Conn -> IO ()
disconnect HTTP2Conn
conn
      Async () -> IO ()
forall a. Async a -> IO a
wait (HTTP2Conn -> Async ()
backgroundThread HTTP2Conn
conn)
        IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` (STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ())
-> ((Map Target HTTP2Conn -> Map Target HTTP2Conn) -> STM ())
-> (Map Target HTTP2Conn -> Map Target HTTP2Conn)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar (Map Target HTTP2Conn)
-> (Map Target HTTP2Conn -> Map Target HTTP2Conn) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (Http2Manager -> TVar (Map Target HTTP2Conn)
connections Http2Manager
mgr) ((Map Target HTTP2Conn -> Map Target HTTP2Conn) -> IO ())
-> (Map Target HTTP2Conn -> Map Target HTTP2Conn) -> IO ()
forall a b. (a -> b) -> a -> b
$ Target -> Map Target HTTP2Conn -> Map Target HTTP2Conn
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Target
target)

-- | Disconnects HTTP2 connection if there exists one. If the background thread
-- running the connection does not finish within 1 second, it is canceled.
-- Errors from the background thread running the connection are not propagated.
--
-- NOTE: Any requests in progress might not finish correctly.
disconnectTargetWithTimeout :: Http2Manager -> Target -> Int -> IO ()
disconnectTargetWithTimeout :: Http2Manager -> Target -> Int -> IO ()
disconnectTargetWithTimeout Http2Manager
mgr Target
target Int
microSeconds = do
  Maybe HTTP2Conn
mConn <- STM (Maybe HTTP2Conn) -> IO (Maybe HTTP2Conn)
forall a. STM a -> IO a
atomically (STM (Maybe HTTP2Conn) -> IO (Maybe HTTP2Conn))
-> STM (Maybe HTTP2Conn) -> IO (Maybe HTTP2Conn)
forall a b. (a -> b) -> a -> b
$ Http2Manager -> Target -> STM (Maybe HTTP2Conn)
getConnection Http2Manager
mgr Target
target
  case Maybe HTTP2Conn
mConn of
    Maybe HTTP2Conn
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just HTTP2Conn
conn -> do
      HTTP2Conn -> IO ()
disconnect HTTP2Conn
conn

      -- Wait with timeout using two threads:
      -- 1. background thread which _should_ be exiting soon
      -- 2. sleep for given number of microseconds.
      --
      -- whenever one of them finishes, the other is canceled. Errors are
      -- ignored.
      --
      -- All of this to say wait max 1 second for the background thread to
      -- finish.
      let waitWithTimeout :: IO ()
waitWithTimeout = do
            Async ()
waitOneSec <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
microSeconds
            IO (Async (), Either SomeException ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Async (), Either SomeException ()) -> IO ())
-> IO (Async (), Either SomeException ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ [Async ()] -> IO (Async (), Either SomeException ())
forall a. [Async a] -> IO (Async a, Either SomeException a)
waitAnyCatchCancel [Async ()
waitOneSec, HTTP2Conn -> Async ()
backgroundThread HTTP2Conn
conn]

      IO ()
waitWithTimeout
        IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` (STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ())
-> ((Map Target HTTP2Conn -> Map Target HTTP2Conn) -> STM ())
-> (Map Target HTTP2Conn -> Map Target HTTP2Conn)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar (Map Target HTTP2Conn)
-> (Map Target HTTP2Conn -> Map Target HTTP2Conn) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (Http2Manager -> TVar (Map Target HTTP2Conn)
connections Http2Manager
mgr) ((Map Target HTTP2Conn -> Map Target HTTP2Conn) -> IO ())
-> (Map Target HTTP2Conn -> Map Target HTTP2Conn) -> IO ()
forall a b. (a -> b) -> a -> b
$ Target -> Map Target HTTP2Conn -> Map Target HTTP2Conn
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Target
target)

startPersistentHTTP2Connection ::
  SSL.SSLContext ->
  Target ->
  -- cacheLimit
  Int ->
  -- sslRemoveTrailingDot
  Bool ->
  -- | TCP connect timeout in microseconds
  Int ->
  -- MVar used to communicate requests or the need to close the connection.  (We could use a
  -- queue here to queue several requests, but since the requestor has to wait for the
  -- response, it might as well block before sending off the request.)
  MVar ConnectionAction ->
  IO ()
startPersistentHTTP2Connection :: SSLContext
-> Target -> Int -> Bool -> Int -> MVar ConnectionAction -> IO ()
startPersistentHTTP2Connection SSLContext
ctx (Bool
tlsEnabled, ByteString
hostname, Int
port) Int
cl Bool
removeTrailingDot Int
tcpConnectTimeout MVar ConnectionAction
sendReqMVar = do
  IORef (Map Unique (Async (), MVar SomeException))
liveReqs <- Map Unique (Async (), MVar SomeException)
-> IO (IORef (Map Unique (Async (), MVar SomeException)))
forall a. a -> IO (IORef a)
newIORef Map Unique (Async (), MVar SomeException)
forall a. Monoid a => a
mempty
  let clientConfig :: ClientConfig
clientConfig =
        ClientConfig
HTTP2.defaultClientConfig
          { HTTP2.scheme = if tlsEnabled then "https" else "http",
            HTTP2.authority = C8.unpack hostname,
            HTTP2.cacheLimit = cl
          }
      -- Sends error to requests which show up too late, i.e. after the
      -- connection is already closed
      tooLateNotifier :: e -> IO b
tooLateNotifier e
e = IO () -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO b) -> IO () -> IO b
forall a b. (a -> b) -> a -> b
$ do
        MVar ConnectionAction -> IO ConnectionAction
forall a. MVar a -> IO a
takeMVar MVar ConnectionAction
sendReqMVar IO ConnectionAction -> (ConnectionAction -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          SendRequest Request {MVar SomeException
Request
Response -> IO ()
request :: Request -> Request
responseConsumer :: Request -> Response -> IO ()
exceptionMVar :: Request -> MVar SomeException
request :: Request
responseConsumer :: Response -> IO ()
exceptionMVar :: MVar SomeException
..} -> do
            -- No need to get stuck here
            IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar SomeException -> SomeException -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar SomeException
exceptionMVar (e -> SomeException
forall e. Exception e => e -> SomeException
SomeException e
e)
          ConnectionAction
CloseConnection -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

      -- Sends errors to the request threads when an error occurs
      cleanupThreadsWith :: SomeException -> IO ()
cleanupThreadsWith (SomeException e
e) = do
        -- Is it really OK to cancel the remaining threads even when throwing
        -- 'ConnectionAlreadyClosed', there is a chance that they could finish,
        -- but how would we know here?
        ((Async (), MVar SomeException) -> IO ())
-> Map Unique (Async (), MVar SomeException) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(Async ()
thread, MVar SomeException
_) -> Async () -> e -> IO ()
forall e a. Exception e => Async a -> e -> IO ()
cancelWith Async ()
thread e
e) (Map Unique (Async (), MVar SomeException) -> IO ())
-> IO (Map Unique (Async (), MVar SomeException)) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef (Map Unique (Async (), MVar SomeException))
-> IO (Map Unique (Async (), MVar SomeException))
forall a. IORef a -> IO a
readIORef IORef (Map Unique (Async (), MVar SomeException))
liveReqs
        -- Spawns a thread that will hang around for 1 second to deal with
        -- the race betwen main thread sending a request and this thread
        -- already having stoped waiting for new requests. Sending requests
        -- after 'handleRequests' has finsihed just causes the main thread
        -- to hang until recieving 'BlockedIndefinitelyOnMVar'.
        --
        -- 1 second is hopefully enough to ensure that this thread is seen
        -- as finished.
        IO (Async ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Async ()) -> IO ()) -> IO (Async ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ IO Any -> IO () -> IO ()
forall a b. IO a -> IO b -> IO ()
race_ (e -> IO Any
forall {e} {b}. Exception e => e -> IO b
tooLateNotifier e
e) (Int -> IO ()
threadDelay Int
1_000_000)

      hostnameForTLS :: ByteString
hostnameForTLS =
        if Bool
removeTrailingDot
          then ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
hostname (ByteString -> ByteString -> Maybe ByteString
stripSuffix ByteString
"." ByteString
hostname)
          else ByteString
hostname
      transportConfig :: Maybe TLSParams
transportConfig
        | Bool
tlsEnabled = TLSParams -> Maybe TLSParams
forall a. a -> Maybe a
Just (TLSParams -> Maybe TLSParams) -> TLSParams -> Maybe TLSParams
forall a b. (a -> b) -> a -> b
$ SSLContext -> ByteString -> TLSParams
TLSParams SSLContext
ctx ByteString
hostnameForTLS
        | Bool
otherwise = Maybe TLSParams
forall a. Maybe a
Nothing

  (SomeException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle SomeException -> IO ()
cleanupThreadsWith (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    IO Socket -> (Socket -> IO ()) -> (Socket -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO Socket
connectTCPWithTimeout Socket -> IO ()
NS.close ((Socket -> IO ()) -> IO ()) -> (Socket -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Socket
sock -> do
      IO Transport
-> (Transport -> IO ()) -> (Transport -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Socket -> Maybe TLSParams -> IO Transport
mkTransport Socket
sock Maybe TLSParams
transportConfig) Transport -> IO ()
cleanupTransport ((Transport -> IO ()) -> IO ()) -> (Transport -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Transport
transport ->
        IO Config -> (Config -> IO ()) -> (Config -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Transport -> IO Config
allocHTTP2Config Transport
transport) Config -> IO ()
HTTP2.freeSimpleConfig ((Config -> IO ()) -> IO ()) -> (Config -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Config
http2Cfg -> do
          let runAction :: IO ()
runAction = ClientConfig -> Config -> Client () -> IO ()
forall a. ClientConfig -> Config -> Client a -> IO a
HTTP2.run ClientConfig
clientConfig Config
http2Cfg (Client () -> IO ()) -> Client () -> IO ()
forall a b. (a -> b) -> a -> b
$ \SendRequest
sendReq Aux
_aux -> do
                IORef (Map Unique (Async (), MVar SomeException))
-> SendReqFn -> IO ()
handleRequests IORef (Map Unique (Async (), MVar SomeException))
liveReqs SendReqFn
SendRequest
sendReq
          -- Any request threads still hanging about after 'runAction' finishes
          -- are canceled with 'ConnectionAlreadyClosed'.
          (IO () -> IO () -> IO ()) -> IO () -> IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
finally (SomeException -> IO ()
cleanupThreadsWith (ConnectionAlreadyClosed -> SomeException
forall e. Exception e => e -> SomeException
SomeException ConnectionAlreadyClosed
ConnectionAlreadyClosed)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            -- Any exceptions thrown will get re-thrown to any running requests,
            -- handle at the top level is not good as 'finally' wrapping this
            -- function would kill all threads with some other exception.
            (SomeException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle SomeException -> IO ()
cleanupThreadsWith (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
              IO ()
runAction
  where
    handleRequests :: IORef LiveReqs -> SendReqFn -> IO ()
    handleRequests :: IORef (Map Unique (Async (), MVar SomeException))
-> SendReqFn -> IO ()
handleRequests IORef (Map Unique (Async (), MVar SomeException))
liveReqs SendReqFn
sendReq = do
      let waitAndFork :: IO ()
waitAndFork = do
            ConnectionAction
reqOrStop <- MVar ConnectionAction -> IO ConnectionAction
forall a. MVar a -> IO a
takeMVar MVar ConnectionAction
sendReqMVar
            case ConnectionAction
reqOrStop of
              SendRequest r :: Request
r@(Request {MVar SomeException
Request
Response -> IO ()
request :: Request -> Request
responseConsumer :: Request -> Response -> IO ()
exceptionMVar :: Request -> MVar SomeException
request :: Request
responseConsumer :: Response -> IO ()
exceptionMVar :: MVar SomeException
..}) -> do
                IORef (Map Unique (Async (), MVar SomeException))
-> SendReqFn -> Request -> IO ()
processRequest IORef (Map Unique (Async (), MVar SomeException))
liveReqs SendReqFn
sendReq Request
r
                  IO () -> [Handler ()] -> IO ()
forall a. IO a -> [Handler a] -> IO a
`catches` MVar SomeException -> [Handler ()]
exceptionHandlers MVar SomeException
exceptionMVar
                IO ()
waitAndFork
              ConnectionAction
CloseConnection -> do
                ((Async (), MVar SomeException) -> IO ())
-> Map Unique (Async (), MVar SomeException) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Async () -> IO ()
forall a. Async a -> IO a
wait (Async () -> IO ())
-> ((Async (), MVar SomeException) -> Async ())
-> (Async (), MVar SomeException)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Async (), MVar SomeException) -> Async ()
forall a b. (a, b) -> a
fst) (Map Unique (Async (), MVar SomeException) -> IO ())
-> IO (Map Unique (Async (), MVar SomeException)) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef (Map Unique (Async (), MVar SomeException))
-> IO (Map Unique (Async (), MVar SomeException))
forall a. IORef a -> IO a
readIORef IORef (Map Unique (Async (), MVar SomeException))
liveReqs
      IO ()
waitAndFork

    processRequest :: IORef LiveReqs -> SendReqFn -> Request -> IO ()
    processRequest :: IORef (Map Unique (Async (), MVar SomeException))
-> SendReqFn -> Request -> IO ()
processRequest IORef (Map Unique (Async (), MVar SomeException))
liveReqs SendReqFn
sendReq Request {MVar SomeException
Request
Response -> IO ()
request :: Request -> Request
responseConsumer :: Request -> Response -> IO ()
exceptionMVar :: Request -> MVar SomeException
request :: Request
responseConsumer :: Response -> IO ()
exceptionMVar :: MVar SomeException
..} = do
      Unique
unique <- IO Unique
newUnique
      Async ()
thread <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ do
        let actionWithHandlers :: IO ()
actionWithHandlers =
              SendReqFn
sendReq Request
request Response -> IO ()
responseConsumer
                IO () -> [Handler ()] -> IO ()
forall a. IO a -> [Handler a] -> IO a
`catches` MVar SomeException -> [Handler ()]
exceptionHandlers MVar SomeException
exceptionMVar
            cleanup :: IO ()
cleanup = do
              IORef (Map Unique (Async (), MVar SomeException))
-> (Map Unique (Async (), MVar SomeException)
    -> (Map Unique (Async (), MVar SomeException), ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Map Unique (Async (), MVar SomeException))
liveReqs (\Map Unique (Async (), MVar SomeException)
m -> (Unique
-> Map Unique (Async (), MVar SomeException)
-> Map Unique (Async (), MVar SomeException)
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Unique
unique Map Unique (Async (), MVar SomeException)
m, ()))
        IO ()
actionWithHandlers IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` IO ()
cleanup
      IORef (Map Unique (Async (), MVar SomeException))
-> (Map Unique (Async (), MVar SomeException)
    -> (Map Unique (Async (), MVar SomeException), ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Map Unique (Async (), MVar SomeException))
liveReqs (\Map Unique (Async (), MVar SomeException)
m -> (Unique
-> (Async (), MVar SomeException)
-> Map Unique (Async (), MVar SomeException)
-> Map Unique (Async (), MVar SomeException)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Unique
unique (Async ()
thread, MVar SomeException
exceptionMVar) Map Unique (Async (), MVar SomeException)
m, ()))

    -- Specially handle 'ConnectionAlreadyClosed' otherwise it shows up as 'SomeAsyncException'
    tooLateHandler :: MVar SomeException -> ConnectionAlreadyClosed -> IO ()
tooLateHandler MVar SomeException
threadKilled e :: ConnectionAlreadyClosed
e@ConnectionAlreadyClosed
ConnectionAlreadyClosed =
      MVar SomeException -> SomeException -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar SomeException
threadKilled (ConnectionAlreadyClosed -> SomeException
forall e. Exception e => e -> SomeException
SomeException ConnectionAlreadyClosed
e)
    generalHandler :: MVar a -> a -> IO ()
generalHandler MVar a
threadKilled a
e = MVar a -> a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar a
threadKilled a
e
    exceptionHandlers :: MVar SomeException -> [Handler ()]
exceptionHandlers MVar SomeException
threadKilled = [(ConnectionAlreadyClosed -> IO ()) -> Handler ()
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((ConnectionAlreadyClosed -> IO ()) -> Handler ())
-> (ConnectionAlreadyClosed -> IO ()) -> Handler ()
forall a b. (a -> b) -> a -> b
$ MVar SomeException -> ConnectionAlreadyClosed -> IO ()
tooLateHandler MVar SomeException
threadKilled, (SomeException -> IO ()) -> Handler ()
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((SomeException -> IO ()) -> Handler ())
-> (SomeException -> IO ()) -> Handler ()
forall a b. (a -> b) -> a -> b
$ MVar SomeException -> SomeException -> IO ()
forall a. MVar a -> a -> IO ()
generalHandler MVar SomeException
threadKilled]

    connectTCPWithTimeout :: IO NS.Socket
    connectTCPWithTimeout :: IO Socket
connectTCPWithTimeout = do
      Maybe Socket
mSock <- Int -> IO Socket -> IO (Maybe Socket)
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
tcpConnectTimeout (IO Socket -> IO (Maybe Socket)) -> IO Socket -> IO (Maybe Socket)
forall a b. (a -> b) -> a -> b
$ (Socket, SockAddr) -> Socket
forall a b. (a, b) -> a
fst ((Socket, SockAddr) -> Socket)
-> IO (Socket, SockAddr) -> IO Socket
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Int -> IO (Socket, SockAddr)
getSocketTCP ByteString
hostname Int
port
      case Maybe Socket
mSock of
        Just Socket
sock -> Socket -> IO Socket
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Socket
sock
        Maybe Socket
Nothing -> do
          let errStr :: [Char]
errStr =
                [Char]
"TCP connection with "
                  [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
Text.unpack (ByteString -> Text
Text.decodeUtf8 ByteString
hostname)
                  [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
":"
                  [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
port
                  [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" took longer than "
                  [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
tcpConnectTimeout
                  [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" microseconds"
          IOError -> IO Socket
forall {e} {b}. Exception e => e -> IO b
throwIO (IOError -> IO Socket) -> IOError -> IO Socket
forall a b. (a -> b) -> a -> b
$ IOErrorType -> [Char] -> Maybe Handle -> Maybe [Char] -> IOError
mkIOError IOErrorType
TimeExpired [Char]
errStr Maybe Handle
forall a. Maybe a
Nothing Maybe [Char]
forall a. Maybe a
Nothing

type LiveReqs = Map Unique (Async (), MVar SomeException)

type SendReqFn = HTTP2.Request -> (HTTP2.Response -> IO ()) -> IO ()

data Transport
  = InsecureTransport NS.Socket
  | SecureTransport SSL.SSL

data TLSParams = TLSParams
  { TLSParams -> SSLContext
context :: SSL.SSLContext,
    TLSParams -> ByteString
hostname :: HostName
  }

mkTransport :: NS.Socket -> Maybe TLSParams -> IO Transport
mkTransport :: Socket -> Maybe TLSParams -> IO Transport
mkTransport Socket
sock Maybe TLSParams
Nothing = Transport -> IO Transport
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Transport -> IO Transport) -> Transport -> IO Transport
forall a b. (a -> b) -> a -> b
$ Socket -> Transport
InsecureTransport Socket
sock
mkTransport Socket
sock (Just TLSParams {SSLContext
ByteString
context :: TLSParams -> SSLContext
hostname :: TLSParams -> ByteString
context :: SSLContext
hostname :: ByteString
..}) = do
  SSL
ssl <- SSLContext -> Socket -> IO SSL
SSL.connection SSLContext
context Socket
sock
  let hostnameStr :: [Char]
hostnameStr = Text -> [Char]
Text.unpack (Text -> [Char]) -> Text -> [Char]
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
Text.decodeUtf8 ByteString
hostname
  -- Perhaps a hook at enable/disable or customize this would be nice.
  -- OpenSSL also supports a callback.
  SSL -> [Char] -> IO ()
SSL.setTlsextHostName SSL
ssl [Char]
hostnameStr
  SSL -> [Char] -> IO ()
SSL.enableHostnameValidation SSL
ssl [Char]
hostnameStr
  SSL -> IO ()
SSL.connect SSL
ssl
  Transport -> IO Transport
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Transport -> IO Transport) -> Transport -> IO Transport
forall a b. (a -> b) -> a -> b
$ SSL -> Transport
SecureTransport SSL
ssl

cleanupTransport :: Transport -> IO ()
cleanupTransport :: Transport -> IO ()
cleanupTransport (InsecureTransport Socket
_) = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
cleanupTransport (SecureTransport SSL
ssl) = SSL -> ShutdownType -> IO ()
SSL.shutdown SSL
ssl ShutdownType
SSL.Unidirectional

data ConnectionAlreadyClosed = ConnectionAlreadyClosed
  deriving (Int -> ConnectionAlreadyClosed -> [Char] -> [Char]
[ConnectionAlreadyClosed] -> [Char] -> [Char]
ConnectionAlreadyClosed -> [Char]
(Int -> ConnectionAlreadyClosed -> [Char] -> [Char])
-> (ConnectionAlreadyClosed -> [Char])
-> ([ConnectionAlreadyClosed] -> [Char] -> [Char])
-> Show ConnectionAlreadyClosed
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> ConnectionAlreadyClosed -> [Char] -> [Char]
showsPrec :: Int -> ConnectionAlreadyClosed -> [Char] -> [Char]
$cshow :: ConnectionAlreadyClosed -> [Char]
show :: ConnectionAlreadyClosed -> [Char]
$cshowList :: [ConnectionAlreadyClosed] -> [Char] -> [Char]
showList :: [ConnectionAlreadyClosed] -> [Char] -> [Char]
Show)

instance Exception ConnectionAlreadyClosed

bufsize :: Int
bufsize :: Int
bufsize = Int
4096

allocHTTP2Config :: Transport -> IO HTTP2.Config
allocHTTP2Config :: Transport -> IO Config
allocHTTP2Config (InsecureTransport Socket
sock) = Socket -> Int -> IO Config
HTTP2.allocSimpleConfig Socket
sock Int
bufsize
allocHTTP2Config (SecureTransport SSL
ssl) = do
  Ptr Word8
buf <- Int -> IO (Ptr Word8)
forall a. Int -> IO (Ptr a)
mallocBytes Int
bufsize
  Manager
timmgr <- Int -> IO Manager
System.TimeManager.initialize (Int -> IO Manager) -> Int -> IO Manager
forall a b. (a -> b) -> a -> b
$ Int
30 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000000
  -- Sometimes the frame header says that the payload length is 0. Reading 0
  -- bytes multiple times seems to be causing errors in openssl. I cannot figure
  -- out why. The previous implementation didn't try to read from the socket
  -- when trying to read 0 bytes, so special handling for 0 maintains that
  -- behaviour.
  let readData :: ByteString -> Int -> IO ByteString
readData ByteString
acc Int
0 = ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
acc
      readData ByteString
acc Int
n = do
        -- Handling SSL.ConnectionAbruptlyTerminated as a stream end
        -- (some sites terminate SSL connection right after returning the data).
        ByteString
chunk <- SSL -> Int -> IO ByteString
SSL.read SSL
ssl Int
n IO ByteString
-> (ConnectionAbruptlyTerminated -> IO ByteString) -> IO ByteString
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(ConnectionAbruptlyTerminated
_ :: SSL.ConnectionAbruptlyTerminated) -> ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
forall a. Monoid a => a
mempty
        let chunkLen :: Int
chunkLen = ByteString -> Int
BS.length ByteString
chunk
        if
          | Int
chunkLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
|| Int
chunkLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n ->
              ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString
acc ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
chunk)
          | Int
chunkLen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n ->
              [Char] -> IO ByteString
forall a. HasCallStack => [Char] -> a
error [Char]
"openssl: SSL.read returned more bytes than asked for, this is probably a bug"
          | Bool
otherwise ->
              ByteString -> Int -> IO ByteString
readData (ByteString
acc ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
chunk) (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
chunkLen)
  let s :: Socket
s = Socket -> Maybe Socket -> Socket
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Socket
forall a. HasCallStack => [Char] -> a
error [Char]
"http2-manager: SSL without socket") (Maybe Socket -> Socket) -> Maybe Socket -> Socket
forall a b. (a -> b) -> a -> b
$ SSL -> Maybe Socket
SSL.sslSocket SSL
ssl
  SockAddr
mysa <- Socket -> IO SockAddr
NS.getSocketName Socket
s
  SockAddr
peersa <- Socket -> IO SockAddr
NS.getPeerName Socket
s

  Config -> IO Config
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    HTTP2.Config
      { confWriteBuffer :: Ptr Word8
HTTP2.confWriteBuffer = Ptr Word8
buf,
        confBufferSize :: Int
HTTP2.confBufferSize = Int
bufsize,
        confSendAll :: ByteString -> IO ()
HTTP2.confSendAll = SSL -> ByteString -> IO ()
SSL.write SSL
ssl,
        confReadN :: Int -> IO ByteString
HTTP2.confReadN = ByteString -> Int -> IO ByteString
readData ByteString
forall a. Monoid a => a
mempty,
        confPositionReadMaker :: PositionReadMaker
HTTP2.confPositionReadMaker = PositionReadMaker
HTTP2.defaultPositionReadMaker,
        confTimeoutManager :: Manager
HTTP2.confTimeoutManager = Manager
timmgr,
        confMySockAddr :: SockAddr
HTTP2.confMySockAddr = SockAddr
mysa,
        confPeerSockAddr :: SockAddr
HTTP2.confPeerSockAddr = SockAddr
peersa
      }