{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}

module Simplex.Messaging.Transport.HTTP2
  ( HTTP2Body (..),
    HTTP2BodyChunk (..),
    defaultHTTP2BufferSize,
    withHTTP2,
    http2TLSParams,
    getHTTP2Body,
    httpALPN,
    httpALPN11,
  ) where

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 (ALPN, TLS, Transport (cGet, cPut))
import Simplex.Messaging.Transport.Buffer
import qualified System.TimeManager as TI

defaultHTTP2BufferSize :: BufferSize
defaultHTTP2BufferSize :: BufferSize
defaultHTTP2BufferSize = BufferSize
32768

withHTTP2 :: BufferSize -> (Config -> IO a) -> IO () -> TLS p -> IO a
withHTTP2 :: forall a (p :: TransportPeer).
BufferSize -> (Config -> IO a) -> IO () -> TLS p -> IO a
withHTTP2 BufferSize
sz Config -> IO a
run IO ()
fin TLS p
c = IO Config -> (Config -> IO ()) -> (Config -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracket (TLS p -> BufferSize -> IO Config
forall (p :: TransportPeer). TLS p -> BufferSize -> IO Config
allocHTTP2Config TLS p
c BufferSize
sz) (\Config
cfg -> Config -> IO ()
freeSimpleConfig Config
cfg IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`E.finally` IO ()
fin) Config -> IO a
run

allocHTTP2Config :: TLS p -> BufferSize -> IO Config
allocHTTP2Config :: forall (p :: TransportPeer). TLS p -> BufferSize -> IO Config
allocHTTP2Config TLS p
c BufferSize
sz = do
  Ptr Word8
buf <- BufferSize -> IO (Ptr Word8)
forall a. BufferSize -> IO (Ptr a)
mallocBytes BufferSize
sz
  Manager
tm <- BufferSize -> IO Manager
TI.initialize (BufferSize -> IO Manager) -> BufferSize -> IO Manager
forall a b. (a -> b) -> a -> b
$ BufferSize
30 BufferSize -> BufferSize -> BufferSize
forall a. Num a => a -> a -> a
* BufferSize
1000000
  Config -> IO Config
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    Config
      { confWriteBuffer :: Ptr Word8
confWriteBuffer = Ptr Word8
buf,
        confBufferSize :: BufferSize
confBufferSize = BufferSize
sz,
        confSendAll :: ALPN -> IO ()
confSendAll = TLS p -> ALPN -> IO ()
forall (p :: TransportPeer). TLS p -> ALPN -> IO ()
forall (c :: TransportPeer -> *) (p :: TransportPeer).
Transport c =>
c p -> ALPN -> IO ()
cPut TLS p
c,
        confReadN :: BufferSize -> IO ALPN
confReadN = TLS p -> BufferSize -> IO ALPN
forall (p :: TransportPeer). TLS p -> BufferSize -> IO ALPN
forall (c :: TransportPeer -> *) (p :: TransportPeer).
Transport c =>
c p -> BufferSize -> IO ALPN
cGet TLS p
c,
        confPositionReadMaker :: PositionReadMaker
confPositionReadMaker = PositionReadMaker
defaultPositionReadMaker,
        confTimeoutManager :: Manager
confTimeoutManager = Manager
tm,
        confMySockAddr :: SockAddr
confMySockAddr = PortNumber -> HostAddress -> SockAddr
SockAddrInet PortNumber
0 HostAddress
0,
        confPeerSockAddr :: SockAddr
confPeerSockAddr = PortNumber -> HostAddress -> SockAddr
SockAddrInet PortNumber
0 HostAddress
0
      }

http2TLSParams :: T.Supported
http2TLSParams :: Supported
http2TLSParams =
  Supported
forall a. Default a => a
def
    { T.supportedVersions = [T.TLS13, T.TLS12],
      T.supportedCiphers = TE.ciphersuite_strong_det,
      T.supportedSecureRenegotiation = False
    }

data HTTP2Body = HTTP2Body
  { HTTP2Body -> ALPN
bodyHead :: ByteString,
    HTTP2Body -> BufferSize
bodySize :: Int,
    HTTP2Body -> Maybe (BufferSize -> IO ALPN)
bodyPart :: Maybe (Int -> IO ByteString),
    HTTP2Body -> TBuffer
bodyBuffer :: TBuffer
  }

class HTTP2BodyChunk a where
  getBodyChunk :: a -> IO ByteString
  getBodySize :: a -> Maybe Int

instance HTTP2BodyChunk HC.Response where
  getBodyChunk :: Response -> IO ALPN
getBodyChunk = Response -> IO ALPN
HC.getResponseBodyChunk
  {-# INLINE getBodyChunk #-}
  getBodySize :: Response -> Maybe BufferSize
getBodySize = Response -> Maybe BufferSize
HC.responseBodySize
  {-# INLINE getBodySize #-}

instance HTTP2BodyChunk HS.Request where
  getBodyChunk :: Request -> IO ALPN
getBodyChunk = Request -> IO ALPN
HS.getRequestBodyChunk
  {-# INLINE getBodyChunk #-}
  getBodySize :: Request -> Maybe BufferSize
getBodySize = Request -> Maybe BufferSize
HS.requestBodySize
  {-# INLINE getBodySize #-}

getHTTP2Body :: HTTP2BodyChunk a => a -> Int -> IO HTTP2Body
getHTTP2Body :: forall a. HTTP2BodyChunk a => a -> BufferSize -> IO HTTP2Body
getHTTP2Body a
r BufferSize
n = do
  TBuffer
bodyBuffer <- IO TBuffer
newTBuffer
  let getPart :: BufferSize -> IO ALPN
getPart BufferSize
n' = TBuffer -> BufferSize -> Maybe BufferSize -> IO ALPN -> IO ALPN
getBuffered TBuffer
bodyBuffer BufferSize
n' Maybe BufferSize
forall a. Maybe a
Nothing (IO ALPN -> IO ALPN) -> IO ALPN -> IO ALPN
forall a b. (a -> b) -> a -> b
$ a -> IO ALPN
forall a. HTTP2BodyChunk a => a -> IO ALPN
getBodyChunk a
r
  ALPN
bodyHead <- BufferSize -> IO ALPN
getPart BufferSize
n
  let bodySize :: BufferSize
bodySize = BufferSize -> Maybe BufferSize -> BufferSize
forall a. a -> Maybe a -> a
fromMaybe BufferSize
0 (Maybe BufferSize -> BufferSize) -> Maybe BufferSize -> BufferSize
forall a b. (a -> b) -> a -> b
$ a -> Maybe BufferSize
forall a. HTTP2BodyChunk a => a -> Maybe BufferSize
getBodySize a
r
      -- TODO check bodySize once it is set
      bodyPart :: Maybe (BufferSize -> IO ALPN)
bodyPart = if ALPN -> BufferSize
B.length ALPN
bodyHead BufferSize -> BufferSize -> Bool
forall a. Eq a => a -> a -> Bool
== BufferSize
n then (BufferSize -> IO ALPN) -> Maybe (BufferSize -> IO ALPN)
forall a. a -> Maybe a
Just BufferSize -> IO ALPN
getPart else Maybe (BufferSize -> IO ALPN)
forall a. Maybe a
Nothing
  HTTP2Body -> IO HTTP2Body
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HTTP2Body {ALPN
bodyHead :: ALPN
bodyHead :: ALPN
bodyHead, BufferSize
bodySize :: BufferSize
bodySize :: BufferSize
bodySize, Maybe (BufferSize -> IO ALPN)
bodyPart :: Maybe (BufferSize -> IO ALPN)
bodyPart :: Maybe (BufferSize -> IO ALPN)
bodyPart, TBuffer
bodyBuffer :: TBuffer
bodyBuffer :: TBuffer
bodyBuffer}

httpALPN :: [ALPN]
httpALPN :: [ALPN]
httpALPN = [ALPN
"h2", ALPN
"http/1.1"]

httpALPN11 :: ALPN
httpALPN11 :: ALPN
httpALPN11 = ALPN
"http/1.1"