mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-04-27 08:35:15 +00:00
Evgeny Poberezkin
85 lines
2.7 KiB
Haskell
85 lines
2.7 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
|
|
module Simplex.Messaging.Transport.HTTP2 where
|
|
|
|
import Control.Concurrent.STM
|
|
import qualified Control.Exception as E
|
|
import Data.ByteString.Char8 (ByteString)
|
|
import qualified Data.ByteString.Char8 as B
|
|
import Data.Default (def)
|
|
import Data.Maybe (fromMaybe)
|
|
import Foreign (mallocBytes)
|
|
import Network.HPACK (BufferSize)
|
|
import Network.HTTP2.Client (Config (..), defaultPositionReadMaker, freeSimpleConfig)
|
|
import qualified Network.HTTP2.Client as HC
|
|
import qualified Network.HTTP2.Server as HS
|
|
import Network.Socket (SockAddr (..))
|
|
import qualified Network.TLS as T
|
|
import qualified Network.TLS.Extra as TE
|
|
import Simplex.Messaging.Transport (SessionId, TLS (tlsUniq), Transport (cGet, cPut))
|
|
import Simplex.Messaging.Transport.Buffer
|
|
import qualified System.TimeManager as TI
|
|
|
|
defaultHTTP2BufferSize :: BufferSize
|
|
defaultHTTP2BufferSize = 32768
|
|
|
|
withHTTP2 :: BufferSize -> (Config -> SessionId -> IO a) -> TLS -> IO a
|
|
withHTTP2 sz run c = E.bracket (allocHTTP2Config c sz) freeSimpleConfig (`run` tlsUniq c)
|
|
|
|
allocHTTP2Config :: TLS -> BufferSize -> IO Config
|
|
allocHTTP2Config c sz = do
|
|
buf <- mallocBytes sz
|
|
tm <- TI.initialize $ 30 * 1000000
|
|
pure
|
|
Config
|
|
{ confWriteBuffer = buf,
|
|
confBufferSize = sz,
|
|
confSendAll = cPut c,
|
|
confReadN = cGet c,
|
|
confPositionReadMaker = defaultPositionReadMaker,
|
|
confTimeoutManager = tm,
|
|
confMySockAddr = SockAddrInet 0 0,
|
|
confPeerSockAddr = SockAddrInet 0 0
|
|
}
|
|
|
|
http2TLSParams :: T.Supported
|
|
http2TLSParams =
|
|
def
|
|
{ T.supportedVersions = [T.TLS13, T.TLS12],
|
|
T.supportedCiphers = TE.ciphersuite_strong_det,
|
|
T.supportedSecureRenegotiation = False
|
|
}
|
|
|
|
data HTTP2Body = HTTP2Body
|
|
{ bodyHead :: ByteString,
|
|
bodySize :: Int,
|
|
bodyPart :: Maybe (Int -> IO ByteString),
|
|
bodyBuffer :: TBuffer
|
|
}
|
|
|
|
class HTTP2BodyChunk a where
|
|
getBodyChunk :: a -> IO ByteString
|
|
getBodySize :: a -> Maybe Int
|
|
|
|
instance HTTP2BodyChunk HC.Response where
|
|
getBodyChunk = HC.getResponseBodyChunk
|
|
{-# INLINE getBodyChunk #-}
|
|
getBodySize = HC.responseBodySize
|
|
{-# INLINE getBodySize #-}
|
|
|
|
instance HTTP2BodyChunk HS.Request where
|
|
getBodyChunk = HS.getRequestBodyChunk
|
|
{-# INLINE getBodyChunk #-}
|
|
getBodySize = HS.requestBodySize
|
|
{-# INLINE getBodySize #-}
|
|
|
|
getHTTP2Body :: HTTP2BodyChunk a => a -> Int -> IO HTTP2Body
|
|
getHTTP2Body r n = do
|
|
bodyBuffer <- atomically newTBuffer
|
|
let getPart n' = getBuffered bodyBuffer n' Nothing $ getBodyChunk r
|
|
bodyHead <- getPart n
|
|
let bodySize = fromMaybe 0 $ getBodySize r
|
|
-- TODO check bodySize once it is set
|
|
bodyPart = if B.length bodyHead == n then Just getPart else Nothing
|
|
pure HTTP2Body {bodyHead, bodySize, bodyPart, bodyBuffer}
|