{-# 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
{
Request -> Request
request :: HTTP2.Request,
Request -> Response -> IO ()
responseConsumer :: HTTP2.Response -> IO (),
Request -> MVar SomeException
exceptionMVar :: MVar SomeException
}
data Http2Manager = Http2Manager
{ Http2Manager -> TVar (Map Target HTTP2Conn)
connections :: TVar (Map Target HTTP2Conn),
Http2Manager -> Int
cacheLimit :: Int,
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,
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
..}
setCacheLimit :: Int -> Http2Manager -> Http2Manager
setCacheLimit :: Int -> Http2Manager -> Http2Manager
setCacheLimit Int
cl Http2Manager
mgr = Http2Manager
mgr {cacheLimit = cl}
setSSLContext :: SSL.SSLContext -> Http2Manager -> Http2Manager
setSSLContext :: SSLContext -> Http2Manager -> Http2Manager
setSSLContext SSLContext
ctx Http2Manager
mgr = Http2Manager
mgr {sslContext = ctx}
setSSLRemoveTrailingDot :: Bool -> Http2Manager -> Http2Manager
setSSLRemoveTrailingDot :: Bool -> Http2Manager -> Http2Manager
setSSLRemoveTrailingDot Bool
b Http2Manager
mgr = Http2Manager
mgr {sslRemoveTrailingDot = b}
setTCPConnectionTimeout :: Int -> Http2Manager -> Http2Manager
setTCPConnectionTimeout :: Int -> Http2Manager -> Http2Manager
setTCPConnectionTimeout Int
n Http2Manager
mgr = Http2Manager
mgr {tcpConnectionTimeout = n}
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
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
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
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
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
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
HTTP2Conn -> IO ()
disconnect HTTP2Conn
newConn
HTTP2Conn -> IO HTTP2Conn
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HTTP2Conn
finalConn
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 ->
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
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
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)
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
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 ->
Int ->
Bool ->
Int ->
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
}
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
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 ()
cleanupThreadsWith :: SomeException -> IO ()
cleanupThreadsWith (SomeException e
e) = 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 ()
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
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
(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
$
(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, ()))
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
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
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
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
}