extend HTTP2 transport (#632)

* extend HTTP2 transport

* refactor caStore

* HTTP2 body

* enable test

* remove maxBodySize
This commit is contained in:
Evgeny Poberezkin
2023-02-09 23:09:24 +00:00
committed by GitHub
parent ee2a764f93
commit b342b1dc59
10 changed files with 210 additions and 135 deletions
@@ -32,10 +32,12 @@ import qualified Data.ByteString.Lazy.Char8 as LB
import qualified Data.CaseInsensitive as CI
import Data.Int (Int64)
import Data.Map.Strict (Map)
import Data.Maybe (isNothing)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Clock.System
import qualified Data.X509 as X
import qualified Data.X509.CertificateStore as XS
import GHC.Generics (Generic)
import Network.HTTP.Types (HeaderName, Status)
import qualified Network.HTTP.Types as N
@@ -47,6 +49,7 @@ import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Notifications.Protocol
import Simplex.Messaging.Notifications.Server.Store (NtfTknData (..))
import Simplex.Messaging.Protocol (EncNMsgMeta)
import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..))
import Simplex.Messaging.Transport.HTTP2.Client
import Simplex.Messaging.Util (safeDecodeUtf8)
import System.Environment (getEnv)
@@ -97,8 +100,8 @@ readECPrivateKey f = do
data PushNotification
= PNVerification NtfRegCode
| PNMessage PNMessageData
-- | PNAlert Text
| PNCheckMessages
| -- | PNAlert Text
PNCheckMessages
deriving (Show)
data PNMessageData = PNMessageData
@@ -194,9 +197,9 @@ data APNSPushClientConfig = APNSPushClientConfig
appName :: ByteString,
appTeamId :: Text,
apnsPort :: ServiceName,
http2cfg :: HTTP2ClientConfig
http2cfg :: HTTP2ClientConfig,
caStoreFile :: FilePath
}
deriving (Show)
apnsProviderHost :: PushProvider -> HostName
apnsProviderHost = \case
@@ -215,7 +218,8 @@ defaultAPNSPushClientConfig =
appName = "chat.simplex.app",
appTeamId = "5NN7GUYB6T",
apnsPort = "443",
http2cfg = defaultHTTP2ClientConfig
http2cfg = defaultHTTP2ClientConfig {bufferSize = 16384},
caStoreFile = "/etc/ssl/cert.pem"
}
data APNSPushClient = APNSPushClient
@@ -259,8 +263,10 @@ mkApnsJWTToken appTeamId jwtHeader privateKey = do
pure (jwt, signedJWT)
connectHTTPS2 :: HostName -> APNSPushClientConfig -> TVar (Maybe HTTP2Client) -> IO (Either HTTP2ClientError HTTP2Client)
connectHTTPS2 apnsHost APNSPushClientConfig {apnsPort, http2cfg} https2Client = do
r <- getHTTP2Client apnsHost apnsPort http2cfg disconnected
connectHTTPS2 apnsHost APNSPushClientConfig {apnsPort, http2cfg, caStoreFile} https2Client = do
caStore_ <- XS.readCertificateStore caStoreFile
when (isNothing caStore_) $ putStrLn $ "Error loading CertificateStore from " <> caStoreFile
r <- getHTTP2Client apnsHost apnsPort caStore_ http2cfg disconnected
case r of
Right client -> atomically . writeTVar https2Client $ Just client
Left e -> putStrLn $ "Error connecting to APNS: " <> show e
@@ -294,7 +300,8 @@ apnsNotification NtfTknData {tknDhSecret} nonce paddedLen = \case
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 another app event", category = Just ntfCategoryCheckMessage}
-- apnAlert alert = APNSAlert {alert, badge = Nothing, sound = Nothing, category = Nothing}
-- apnAlert alert = APNSAlert {alert, badge = Nothing, sound = Nothing, category = Nothing}
apnsRequest :: APNSPushClient -> ByteString -> APNSNotification -> IO Request
apnsRequest c tkn ntf@APNSNotification {aps} = do
@@ -336,9 +343,9 @@ apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknData {toke
nonce <- atomically $ C.pseudoRandomCbNonce nonceDrg
apnsNtf <- liftEither $ first PPCryptoError $ apnsNotification tkn nonce (paddedNtfLength apnsCfg) pn
req <- liftIO $ apnsRequest c tknStr apnsNtf
HTTP2Response {response, respBody} <- liftHTTPS2 $ sendRequest http2 req
HTTP2Response {response, respBody = HTTP2Body {bodyHead}} <- liftHTTPS2 $ sendRequest http2 req
let status = H.responseStatus response
reason' = maybe "" reason $ J.decodeStrict' respBody
reason' = maybe "" reason $ J.decodeStrict' bodyHead
logDebug $ "APNS response: " <> T.pack (show status) <> " " <> reason'
result status reason'
where