test notification token with agent and notifications server (#353)

* test notification token with agent and notifications server

* notification server test with APNS mock

* set environment variables in the test

* use base64url encoding in encrypted notification data

src/Simplex/Messaging/Notifications/Server/Env.hs

@@ -8,6 +8,7 @@
 module Simplex.Messaging.Notifications.Server.Env where
 
 import Control.Concurrent.Async (Async)
+import Control.Monad (void)
 import Control.Monad.IO.Unlift
 import Crypto.Random
 import Data.ByteString.Char8 (ByteString)
@@ -61,7 +62,7 @@ newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsCo
   subscriber <- atomically $ newNtfSubscriber subQSize smpAgentCfg
   pushServer <- atomically $ newNtfPushServer pushQSize apnsConfig
   -- TODO not creating APNS client on start to pass CI test, has to be replaced with mock APNS server
-  -- void . liftIO $ newPushClient pushServer PPApns
+  void . liftIO $ newPushClient pushServer PPApns
   tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile
   Fingerprint fp <- liftIO $ loadFingerprint caCertificateFile
   pure NtfEnv {config, subscriber, pushServer, store, idsDrg, tlsServerParams, serverIdentity = C.KeyHash fp}

src/Simplex/Messaging/Notifications/Server/Push/APNS.hs

@@ -24,7 +24,6 @@ import Data.Aeson (FromJSON, ToJSON, (.=))
 import qualified Data.Aeson as J
 import qualified Data.Aeson.Encoding as JE
 import Data.Bifunctor (first)
-import qualified Data.ByteString.Base64 as B64
 import qualified Data.ByteString.Base64.URL as U
 import Data.ByteString.Builder (lazyByteString)
 import Data.ByteString.Char8 (ByteString)
@@ -37,8 +36,8 @@ import qualified Data.Text as T
 import Data.Text.Encoding (decodeUtf8With)
 import Data.Time.Clock.System
 import qualified Data.X509 as X
-import GHC.Generics
-import Network.HTTP.Types (HeaderName, Status, hAuthorization, methodPost)
+import GHC.Generics (Generic)
+import Network.HTTP.Types (HeaderName, Status)
 import qualified Network.HTTP.Types as N
 import Network.HTTP2.Client (Request)
 import qualified Network.HTTP2.Client as H
@@ -48,7 +47,7 @@ import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Server.Subscriptions (NtfTknData (..))
 import Simplex.Messaging.Protocol (NotifierId, SMPServer)
-import Simplex.Messaging.Transport.Client.HTTP2
+import Simplex.Messaging.Transport.HTTP2.Client
 import System.Environment (getEnv)
 import UnliftIO.STM
 
@@ -177,9 +176,9 @@ data APNSPushClientConfig = APNSPushClientConfig
     paddedNtfLength :: Int,
     appName :: ByteString,
     appTeamId :: Text,
-    apnHost :: HostName,
-    apnPort :: ServiceName,
-    https2cfg :: HTTP2SClientConfig
+    apnsHost :: HostName,
+    apnsPort :: ServiceName,
+    http2cfg :: HTTP2ClientConfig
   }
   deriving (Show)
 
@@ -193,13 +192,13 @@ defaultAPNSPushClientConfig =
       paddedNtfLength = 256,
       appName = "chat.simplex.app",
       appTeamId = "5NN7GUYB6T",
-      apnHost = "api.sandbox.push.apple.com",
-      apnPort = "443",
-      https2cfg = defaultHTTP2SClientConfig
+      apnsHost = "api.sandbox.push.apple.com",
+      apnsPort = "443",
+      http2cfg = defaultHTTP2ClientConfig
     }
 
 data APNSPushClient = APNSPushClient
-  { https2Client :: TVar (Maybe HTTPS2Client),
+  { https2Client :: TVar (Maybe HTTP2Client),
     privateKey :: EC.PrivateKey,
     jwtHeader :: JWTHeader,
     jwtToken :: TVar (JWTToken, SignedJWTToken),
@@ -213,7 +212,6 @@ createAPNSPushClient apnsCfg@APNSPushClientConfig {authKeyFileEnv, authKeyAlg, a
   void $ connectHTTPS2 apnsCfg https2Client
   privateKey <- readECPrivateKey =<< getEnv authKeyFileEnv
   authKeyId <- T.pack <$> getEnv authKeyIdEnv
-  putStrLn $ authKeyIdEnv <> "=" <> T.unpack authKeyId
   let jwtHeader = JWTHeader {alg = authKeyAlg, kid = authKeyId}
   jwtToken <- newTVarIO =<< mkApnsJWTToken appTeamId jwtHeader privateKey
   nonceDrg <- drgNew >>= newTVarIO
@@ -238,9 +236,9 @@ mkApnsJWTToken appTeamId jwtHeader privateKey = do
   signedJWT <- signedJWTToken privateKey jwt
   pure (jwt, signedJWT)
 
-connectHTTPS2 :: APNSPushClientConfig -> TVar (Maybe HTTPS2Client) -> IO (Either HTTPS2ClientError HTTPS2Client)
-connectHTTPS2 APNSPushClientConfig {apnHost, apnPort, https2cfg} https2Client = do
-  r <- getHTTPS2Client apnHost apnPort https2cfg disconnected
+connectHTTPS2 :: APNSPushClientConfig -> TVar (Maybe HTTP2Client) -> IO (Either HTTP2ClientError HTTP2Client)
+connectHTTPS2 APNSPushClientConfig {apnsHost, apnsPort, http2cfg} https2Client = do
+  r <- getHTTP2Client apnsHost apnsPort http2cfg disconnected
   case r of
     Right client -> atomically . writeTVar https2Client $ Just client
     Left e -> putStrLn $ "Error connecting to APNS: " <> show e
@@ -248,13 +246,13 @@ connectHTTPS2 APNSPushClientConfig {apnHost, apnPort, https2cfg} https2Client =
   where
     disconnected = atomically $ writeTVar https2Client Nothing
 
-getApnsHTTP2Client :: APNSPushClient -> IO (Either HTTPS2ClientError HTTPS2Client)
+getApnsHTTP2Client :: APNSPushClient -> IO (Either HTTP2ClientError HTTP2Client)
 getApnsHTTP2Client APNSPushClient {https2Client, apnsCfg} =
   readTVarIO https2Client >>= maybe (connectHTTPS2 apnsCfg https2Client) (pure . Right)
 
 disconnectApnsHTTP2Client :: APNSPushClient -> IO ()
 disconnectApnsHTTP2Client APNSPushClient {https2Client} =
-  readTVarIO https2Client >>= mapM_ closeHTTPS2Client >> atomically (writeTVar https2Client Nothing)
+  readTVarIO https2Client >>= mapM_ closeHTTP2Client >> atomically (writeTVar https2Client Nothing)
 
 apnsNotification :: NtfTknData -> C.CbNonce -> Int -> PushNotification -> Either C.CryptoError APNSNotification
 apnsNotification NtfTknData {tknDhSecret} nonce paddedLen = \case
@@ -268,7 +266,7 @@ apnsNotification NtfTknData {tknDhSecret} nonce paddedLen = \case
   PNCheckMessages -> Right $ apn APNSBackground {contentAvailable = 1} . Just $ J.object ["checkMessages" .= True]
   where
     encrypt :: ByteString -> (Text -> APNSNotification) -> Either C.CryptoError APNSNotification
-    encrypt ntfData f = f . safeDecodeUtf8 . B64.encode <$> C.cbEncrypt tknDhSecret nonce ntfData paddedLen
+    encrypt ntfData f = f . safeDecodeUtf8 . U.encode <$> C.cbEncrypt tknDhSecret nonce ntfData paddedLen
     apn aps notificationData = APNSNotification {aps, notificationData}
     apnMutableContent = APNSMutableContent {mutableContent = 1, alert = APNSAlertText "Encrypted message or some other app event", category = Nothing}
     apnAlert alert = APNSAlert {alert, badge = Nothing, sound = Nothing, category = Nothing}
@@ -277,13 +275,13 @@ apnsNotification NtfTknData {tknDhSecret} nonce paddedLen = \case
 apnsRequest :: APNSPushClient -> ByteString -> APNSNotification -> IO Request
 apnsRequest c tkn ntf@APNSNotification {aps} = do
   signedJWT <- getApnsJWTToken c
-  pure $ H.requestBuilder methodPost path (headers signedJWT) (lazyByteString $ J.encode ntf)
+  pure $ H.requestBuilder N.methodPost path (headers signedJWT) (lazyByteString $ J.encode ntf)
   where
     path = "/3/device/" <> tkn
     headers signedJWT =
       [ (hApnsTopic, appName $ apnsCfg (c :: APNSPushClient)),
         (hApnsPushType, pushType aps),
-        (hAuthorization, "bearer " <> signedJWT)
+        (N.hAuthorization, "bearer " <> signedJWT)
       ]
         <> [(hApnsPriority, "5") | isBackground aps]
     isBackground = \case
@@ -294,7 +292,7 @@ apnsRequest c tkn ntf@APNSNotification {aps} = do
       _ -> "alert"
 
 data PushProviderError
-  = PPConnection HTTPS2ClientError
+  = PPConnection HTTP2ClientError
   | PPCryptoError C.CryptoError
   | PPResponseError (Maybe Status) Text
   | PPTokenInvalid
@@ -305,7 +303,7 @@ data PushProviderError
 type PushProviderClient = NtfTknData -> PushNotification -> ExceptT PushProviderError IO ()
 
 -- this is not a newtype on purpose to have a correct JSON encoding as a record
-data APNSErrorReponse = APNSErrorReponse {reason :: Text}
+data APNSErrorResponse = APNSErrorResponse {reason :: Text}
   deriving (Generic, FromJSON)
 
 apnsPushProviderClient :: APNSPushClient -> PushProviderClient
@@ -316,7 +314,7 @@ apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknData {toke
   req <- liftIO $ apnsRequest c tknStr apnsNtf
   HTTP2Response {response, respBody} <- liftHTTPS2 $ sendRequest http2 req
   let status = H.responseStatus response
-      reason' = maybe "?" reason $ J.decodeStrict' respBody
+      reason' = maybe "" reason $ J.decodeStrict' respBody
   logDebug $ "APNS response: " <> T.pack (show status) <> " " <> reason'
   result status reason'
   where

src/Simplex/Messaging/Transport/Client/HTTP2.hs

@@ -1,159 +0,0 @@
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module Simplex.Messaging.Transport.Client.HTTP2 where
-
-import Control.Concurrent.Async
-import Control.Exception (IOException, catch, finally)
-import qualified Control.Exception as E
-import Control.Logger.Simple (logDebug)
-import Control.Monad.Except
-import Data.ByteString.Char8 (ByteString)
-import qualified Data.ByteString.Char8 as B
-import Data.Default (def)
-import Data.Maybe (isNothing)
-import qualified Data.Text as T
-import qualified Data.X509.CertificateStore as XS
-import Foreign (mallocBytes)
-import Network.HPACK (BufferSize, HeaderTable)
-import Network.HTTP2.Client (ClientConfig (..), Config (..), Request, Response)
-import qualified Network.HTTP2.Client as H
-import Network.Socket (HostName, ServiceName)
-import qualified Network.TLS as T
-import qualified Network.TLS.Extra as TE
-import Numeric.Natural (Natural)
-import Simplex.Messaging.Transport (TLS, Transport (cGet, cPut))
-import Simplex.Messaging.Transport.Client (runTLSTransportClient)
-import Simplex.Messaging.Transport.KeepAlive (KeepAliveOpts)
-import qualified System.TimeManager as TI
-import UnliftIO.STM
-import UnliftIO.Timeout
-
-data HTTPS2Client = HTTPS2Client
-  { action :: Async (),
-    connected :: TVar Bool,
-    host :: HostName,
-    port :: ServiceName,
-    config :: HTTP2SClientConfig,
-    reqQ :: TBQueue (Request, TMVar HTTP2Response)
-  }
-
-data HTTP2Response = HTTP2Response
-  { response :: Response,
-    respBody :: ByteString,
-    respTrailers :: Maybe HeaderTable
-  }
-
-data HTTP2SClientConfig = HTTP2SClientConfig
-  { qSize :: Natural,
-    connTimeout :: Int,
-    tcpKeepAlive :: Maybe KeepAliveOpts,
-    caStoreFile :: FilePath,
-    suportedTLSParams :: T.Supported
-  }
-  deriving (Show)
-
-defaultHTTP2SClientConfig :: HTTP2SClientConfig
-defaultHTTP2SClientConfig =
-  HTTP2SClientConfig
-    { qSize = 64,
-      connTimeout = 10000000,
-      tcpKeepAlive = Nothing,
-      caStoreFile = "/etc/ssl/cert.pem",
-      suportedTLSParams =
-        def
-          { T.supportedVersions = [T.TLS13, T.TLS12],
-            T.supportedCiphers = TE.ciphersuite_strong_det,
-            T.supportedSecureRenegotiation = False
-          }
-    }
-
-data HTTPS2ClientError = HCResponseTimeout | HCNetworkError | HCIOError IOException
-  deriving (Show)
-
-getHTTPS2Client :: HostName -> ServiceName -> HTTP2SClientConfig -> IO () -> IO (Either HTTPS2ClientError HTTPS2Client)
-getHTTPS2Client host port config@HTTP2SClientConfig {tcpKeepAlive, connTimeout, caStoreFile, suportedTLSParams} disconnected =
-  (atomically mkHTTPS2Client >>= runClient)
-    `catch` \(e :: IOException) -> pure . Left $ HCIOError e
-  where
-    mkHTTPS2Client :: STM HTTPS2Client
-    mkHTTPS2Client = do
-      connected <- newTVar False
-      reqQ <- newTBQueue $ qSize config
-      pure HTTPS2Client {action = undefined, connected, host, port, config, reqQ}
-
-    runClient :: HTTPS2Client -> IO (Either HTTPS2ClientError HTTPS2Client)
-    runClient c = do
-      cVar <- newEmptyTMVarIO
-      caStore <- XS.readCertificateStore caStoreFile
-      when (isNothing caStore) . putStrLn $ "Error loading CertificateStore from " <> caStoreFile
-      action <-
-        async $
-          runHTTPS2Client suportedTLSParams caStore host port tcpKeepAlive (client c cVar)
-            `finally` atomically (putTMVar cVar $ Left HCNetworkError)
-      conn_ <- connTimeout `timeout` atomically (takeTMVar cVar)
-      pure $ case conn_ of
-        Just (Right ()) -> Right c {action}
-        Just (Left e) -> Left e
-        Nothing -> Left HCNetworkError
-
-    client :: HTTPS2Client -> TMVar (Either HTTPS2ClientError ()) -> (Request -> (Response -> IO ()) -> IO ()) -> IO ()
-    client c cVar sendReq = do
-      atomically $ do
-        writeTVar (connected c) True
-        putTMVar cVar $ Right ()
-      process c sendReq `finally` disconnected
-
-    process :: HTTPS2Client -> (Request -> (Response -> IO ()) -> IO ()) -> IO ()
-    process HTTPS2Client {reqQ} sendReq = forever $ do
-      (req, respVar) <- atomically $ readTBQueue reqQ
-      sendReq req $ \r -> do
-        let writeResp respBody respTrailers = atomically $ putTMVar respVar HTTP2Response {response = r, respBody, respTrailers}
-        respBody <- getResponseBody r ""
-        respTrailers <- H.getResponseTrailers r
-        writeResp respBody respTrailers
-
-    getResponseBody :: Response -> ByteString -> IO ByteString
-    getResponseBody r s =
-      H.getResponseBodyChunk r >>= \chunk ->
-        if B.null chunk then pure s else getResponseBody r $ s <> chunk
-
--- | Disconnects client from the server and terminates client threads.
-closeHTTPS2Client :: HTTPS2Client -> IO ()
--- TODO disconnect
-closeHTTPS2Client = uninterruptibleCancel . action
-
-sendRequest :: HTTPS2Client -> Request -> IO (Either HTTPS2ClientError HTTP2Response)
-sendRequest HTTPS2Client {reqQ, config} req = do
-  resp <- newEmptyTMVarIO
-  atomically $ writeTBQueue reqQ (req, resp)
-  maybe (Left HCResponseTimeout) Right <$> (connTimeout config `timeout` atomically (takeTMVar resp))
-
-runHTTPS2Client :: T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe KeepAliveOpts -> ((Request -> (Response -> IO ()) -> IO ()) -> IO ()) -> IO ()
-runHTTPS2Client tlsParams caStore host port keepAliveOpts client =
-  runTLSTransportClient tlsParams caStore host port Nothing keepAliveOpts https2Client
-  where
-    cfg = ClientConfig "https" (B.pack host) 20
-    https2Client :: TLS -> IO ()
-    https2Client c =
-      E.bracket
-        (allocTlsConfig c 16384)
-        H.freeSimpleConfig
-        (\conf -> H.run cfg conf client)
-
-    allocTlsConfig :: TLS -> BufferSize -> IO Config
-    allocTlsConfig c sz = do
-      buf <- mallocBytes sz
-      tm <- TI.initialize $ 30 * 1000000
-      pure
-        Config
-          { confWriteBuffer = buf,
-            confBufferSize = sz,
-            confSendAll = cPut c,
-            confReadN = cGet c,
-            confPositionReadMaker = H.defaultPositionReadMaker,
-            confTimeoutManager = tm
-          }

src/Simplex/Messaging/Transport/HTTP2.hs

@@ -0,0 +1,36 @@
+module Simplex.Messaging.Transport.HTTP2 where
+
+import qualified Control.Exception as E
+import Data.Default (def)
+import Foreign (mallocBytes)
+import Network.HPACK (BufferSize)
+import Network.HTTP2.Client (Config (..), defaultPositionReadMaker, freeSimpleConfig)
+import qualified Network.TLS as T
+import qualified Network.TLS.Extra as TE
+import Simplex.Messaging.Transport (TLS, Transport (cGet, cPut))
+import qualified System.TimeManager as TI
+
+withTlsConfig :: TLS -> BufferSize -> (Config -> IO ()) -> IO ()
+withTlsConfig c sz = E.bracket (allocTlsConfig c sz) freeSimpleConfig
+
+allocTlsConfig :: TLS -> BufferSize -> IO Config
+allocTlsConfig 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
+      }
+
+http2TLSParams :: T.Supported
+http2TLSParams =
+  def
+    { T.supportedVersions = [T.TLS13, T.TLS12],
+      T.supportedCiphers = TE.ciphersuite_strong_det,
+      T.supportedSecureRenegotiation = False
+    }

src/Simplex/Messaging/Transport/HTTP2/Client.hs

@@ -0,0 +1,128 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Simplex.Messaging.Transport.HTTP2.Client where
+
+import Control.Concurrent.Async
+import Control.Exception (IOException)
+import qualified Control.Exception as E
+import Control.Monad.Except
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
+import Data.Maybe (isNothing)
+import qualified Data.X509.CertificateStore as XS
+import Network.HPACK (HeaderTable)
+import Network.HTTP2.Client (ClientConfig (..), Request, Response)
+import qualified Network.HTTP2.Client as H
+import Network.Socket (HostName, ServiceName)
+import qualified Network.TLS as T
+import Numeric.Natural (Natural)
+import Simplex.Messaging.Transport.Client (runTLSTransportClient)
+import Simplex.Messaging.Transport.HTTP2 (http2TLSParams, withTlsConfig)
+import Simplex.Messaging.Transport.KeepAlive (KeepAliveOpts)
+import UnliftIO.STM
+import UnliftIO.Timeout
+
+data HTTP2Client = HTTP2Client
+  { action :: Async (),
+    connected :: TVar Bool,
+    host :: HostName,
+    port :: ServiceName,
+    config :: HTTP2ClientConfig,
+    reqQ :: TBQueue (Request, TMVar HTTP2Response)
+  }
+
+data HTTP2Response = HTTP2Response
+  { response :: Response,
+    respBody :: ByteString,
+    respTrailers :: Maybe HeaderTable
+  }
+
+data HTTP2ClientConfig = HTTP2ClientConfig
+  { qSize :: Natural,
+    connTimeout :: Int,
+    tcpKeepAlive :: Maybe KeepAliveOpts,
+    caStoreFile :: FilePath,
+    suportedTLSParams :: T.Supported
+  }
+  deriving (Show)
+
+defaultHTTP2ClientConfig :: HTTP2ClientConfig
+defaultHTTP2ClientConfig =
+  HTTP2ClientConfig
+    { qSize = 64,
+      connTimeout = 10000000,
+      tcpKeepAlive = Nothing,
+      caStoreFile = "/etc/ssl/cert.pem",
+      suportedTLSParams = http2TLSParams
+    }
+
+data HTTP2ClientError = HCResponseTimeout | HCNetworkError | HCNetworkError1 | HCIOError IOException
+  deriving (Show)
+
+getHTTP2Client :: HostName -> ServiceName -> HTTP2ClientConfig -> IO () -> IO (Either HTTP2ClientError HTTP2Client)
+getHTTP2Client host port config@HTTP2ClientConfig {tcpKeepAlive, connTimeout, caStoreFile, suportedTLSParams} disconnected =
+  (atomically mkHTTPS2Client >>= runClient)
+    `E.catch` \(e :: IOException) -> pure . Left $ HCIOError e
+  where
+    mkHTTPS2Client :: STM HTTP2Client
+    mkHTTPS2Client = do
+      connected <- newTVar False
+      reqQ <- newTBQueue $ qSize config
+      pure HTTP2Client {action = undefined, connected, host, port, config, reqQ}
+
+    runClient :: HTTP2Client -> IO (Either HTTP2ClientError HTTP2Client)
+    runClient c = do
+      cVar <- newEmptyTMVarIO
+      caStore <- XS.readCertificateStore caStoreFile
+      when (isNothing caStore) . putStrLn $ "Error loading CertificateStore from " <> caStoreFile
+      action <-
+        async $
+          runHTTP2Client suportedTLSParams caStore host port tcpKeepAlive (client c cVar)
+            `E.finally` atomically (putTMVar cVar $ Left HCNetworkError)
+      conn_ <- connTimeout `timeout` atomically (takeTMVar cVar)
+      pure $ case conn_ of
+        Just (Right ()) -> Right c {action}
+        Just (Left e) -> Left e
+        Nothing -> Left HCNetworkError1
+
+    client :: HTTP2Client -> TMVar (Either HTTP2ClientError ()) -> (Request -> (Response -> IO ()) -> IO ()) -> IO ()
+    client c cVar sendReq = do
+      atomically $ do
+        writeTVar (connected c) True
+        putTMVar cVar $ Right ()
+      process c sendReq `E.finally` disconnected
+
+    process :: HTTP2Client -> (Request -> (Response -> IO ()) -> IO ()) -> IO ()
+    process HTTP2Client {reqQ} sendReq = forever $ do
+      (req, respVar) <- atomically $ readTBQueue reqQ
+      sendReq req $ \r -> do
+        let writeResp respBody respTrailers = atomically $ putTMVar respVar HTTP2Response {response = r, respBody, respTrailers}
+        respBody <- getResponseBody r ""
+        respTrailers <- H.getResponseTrailers r
+        writeResp respBody respTrailers
+
+    getResponseBody :: Response -> ByteString -> IO ByteString
+    getResponseBody r s =
+      H.getResponseBodyChunk r >>= \chunk ->
+        if B.null chunk then pure s else getResponseBody r $ s <> chunk
+
+-- | Disconnects client from the server and terminates client threads.
+closeHTTP2Client :: HTTP2Client -> IO ()
+-- TODO disconnect
+closeHTTP2Client = uninterruptibleCancel . action
+
+sendRequest :: HTTP2Client -> Request -> IO (Either HTTP2ClientError HTTP2Response)
+sendRequest HTTP2Client {reqQ, config} req = do
+  resp <- newEmptyTMVarIO
+  atomically $ writeTBQueue reqQ (req, resp)
+  maybe (Left HCResponseTimeout) Right <$> (connTimeout config `timeout` atomically (takeTMVar resp))
+
+runHTTP2Client :: T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe KeepAliveOpts -> ((Request -> (Response -> IO ()) -> IO ()) -> IO ()) -> IO ()
+runHTTP2Client tlsParams caStore host port keepAliveOpts client =
+  runTLSTransportClient tlsParams caStore host port Nothing keepAliveOpts $ \c ->
+    withTlsConfig c 16384 (`run` client)
+  where
+    run = H.run $ ClientConfig "https" (B.pack host) 20

src/Simplex/Messaging/Transport/HTTP2/Server.hs

@@ -0,0 +1,70 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Simplex.Messaging.Transport.HTTP2.Server where
+
+import Control.Concurrent.Async (Async, async, uninterruptibleCancel)
+import Control.Concurrent.STM
+import Control.Monad
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as B
+import Network.HPACK (HeaderTable)
+import Network.HTTP2.Server (Aux, PushPromise, Request, Response)
+import qualified Network.HTTP2.Server as H
+import Network.Socket
+import qualified Network.TLS as T
+import Numeric.Natural (Natural)
+import Simplex.Messaging.Transport.HTTP2 (withTlsConfig)
+import Simplex.Messaging.Transport.Server (loadSupportedTLSServerParams, runTransportServer)
+
+type HTTP2ServerFunc = (Request -> (Response -> IO ()) -> IO ())
+
+data HTTP2ServerConfig = HTTP2ServerConfig
+  { qSize :: Natural,
+    http2Port :: ServiceName,
+    serverSupported :: T.Supported,
+    caCertificateFile :: FilePath,
+    privateKeyFile :: FilePath,
+    certificateFile :: FilePath
+  }
+  deriving (Show)
+
+data HTTP2Request = HTTP2Request
+  { request :: Request,
+    reqBody :: ByteString,
+    reqTrailers :: Maybe HeaderTable,
+    sendResponse :: Response -> IO ()
+  }
+
+data HTTP2Server = HTTP2Server
+  { action :: Async (),
+    reqQ :: TBQueue HTTP2Request
+  }
+
+getHTTP2Server :: HTTP2ServerConfig -> IO HTTP2Server
+getHTTP2Server HTTP2ServerConfig {qSize, http2Port, serverSupported, caCertificateFile, certificateFile, privateKeyFile} = do
+  tlsServerParams <- loadSupportedTLSServerParams serverSupported caCertificateFile certificateFile privateKeyFile
+  started <- newEmptyTMVarIO
+  reqQ <- newTBQueueIO qSize
+  action <- async $
+    runHTTP2Server started http2Port tlsServerParams $ \r sendResponse -> do
+      reqBody <- getRequestBody r ""
+      reqTrailers <- H.getRequestTrailers r
+      atomically $ writeTBQueue reqQ HTTP2Request {request = r, reqBody, reqTrailers, sendResponse}
+  void . atomically $ takeTMVar started
+  pure HTTP2Server {action, reqQ}
+  where
+    getRequestBody :: Request -> ByteString -> IO ByteString
+    getRequestBody r s =
+      H.getRequestBodyChunk r >>= \chunk ->
+        if B.null chunk then pure s else getRequestBody r $ s <> chunk
+
+closeHTTP2Server :: HTTP2Server -> IO ()
+closeHTTP2Server = uninterruptibleCancel . action
+
+runHTTP2Server :: TMVar Bool -> ServiceName -> T.ServerParams -> HTTP2ServerFunc -> IO ()
+runHTTP2Server started port serverParams http2Server =
+  runTransportServer started port serverParams $ \c -> withTlsConfig c 16384 (`H.run` server)
+  where
+    server :: Request -> Aux -> (Response -> [PushPromise] -> IO ()) -> IO ()
+    server req _aux sendResp = http2Server req (`sendResp` [])

src/Simplex/Messaging/Transport/Server.hs

@@ -4,6 +4,7 @@
 
 module Simplex.Messaging.Transport.Server
   ( runTransportServer,
+    loadSupportedTLSServerParams,
     loadTLSServerParams,
     loadFingerprint,
     smpServerHandshake,
@@ -71,7 +72,10 @@ startTCPServer started port = withSocketsDo $ resolve >>= open >>= setStarted
     setStarted sock = atomically (tryPutTMVar started True) >> pure sock
 
 loadTLSServerParams :: FilePath -> FilePath -> FilePath -> IO T.ServerParams
-loadTLSServerParams caCertificateFile certificateFile privateKeyFile =
+loadTLSServerParams = loadSupportedTLSServerParams supportedParameters
+
+loadSupportedTLSServerParams :: T.Supported -> FilePath -> FilePath -> FilePath -> IO T.ServerParams
+loadSupportedTLSServerParams serverSupported caCertificateFile certificateFile privateKeyFile =
   fromCredential <$> loadServerCredential
   where
     loadServerCredential :: IO T.Credential
@@ -85,7 +89,7 @@ loadTLSServerParams caCertificateFile certificateFile privateKeyFile =
         { T.serverWantClientCert = False,
           T.serverShared = def {T.sharedCredentials = T.Credentials [credential]},
           T.serverHooks = def,
-          T.serverSupported = supportedParameters
+          T.serverSupported = serverSupported
         }
 
 loadFingerprint :: FilePath -> IO Fingerprint