Merge branch 'master' into unified-push

* Move generic push functions to Push.hs

* Fix move push

* minor changes

---------

Co-authored-by: Evgeny <evgeny@poberezkin.com>

simplexmq.cabal

@@ -264,6 +264,7 @@ library
               Simplex.Messaging.Notifications.Server.Env
               Simplex.Messaging.Notifications.Server.Main
               Simplex.Messaging.Notifications.Server.Prometheus
+              Simplex.Messaging.Notifications.Server.Push
               Simplex.Messaging.Notifications.Server.Push.APNS
               Simplex.Messaging.Notifications.Server.Push.APNS.Internal
               Simplex.Messaging.Notifications.Server.Stats

src/Simplex/Messaging/Notifications/Server.hs

@@ -56,7 +56,7 @@ import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Server.Control
 import Simplex.Messaging.Notifications.Server.Env
 import Simplex.Messaging.Notifications.Server.Prometheus
-import Simplex.Messaging.Notifications.Server.Push.APNS (PushNotification (..), PushProviderError (..))
+import Simplex.Messaging.Notifications.Server.Push (PushNotification(..), PushProviderError(..))
 import Simplex.Messaging.Notifications.Server.Stats
 import Simplex.Messaging.Notifications.Server.Store (NtfSTMStore, TokenNtfMessageRecord (..), stmStoreTokenLastNtf)
 import Simplex.Messaging.Notifications.Server.Store.Postgres

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

@@ -45,6 +45,7 @@ import Simplex.Messaging.Transport.Server (AddHTTP, ServerCredentials, Transport
 import System.Exit (exitFailure)
 import System.Mem.Weak (Weak)
 import UnliftIO.STM
+import Simplex.Messaging.Notifications.Server.Push (PushNotification, PushProviderClient)
 
 data NtfServerConfig = NtfServerConfig
   { transports :: [(ServiceName, ASrvTransport, AddHTTP)],

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

@@ -0,0 +1,98 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+
+{-# HLINT ignore "Use newtype instead of data" #-}
+
+module Simplex.Messaging.Notifications.Server.Push where
+
+import Crypto.Hash.Algorithms (SHA256 (..))
+import qualified Crypto.PubKey.ECC.ECDSA as EC
+import qualified Crypto.PubKey.ECC.Types as ECT
+import qualified Crypto.Store.PKCS8 as PK
+import Data.ASN1.BinaryEncoding (DER (..))
+import Data.ASN1.Encoding
+import Data.ASN1.Types
+import Data.Aeson (ToJSON)
+import qualified Data.Aeson as J
+import qualified Data.Aeson.TH as JQ
+import qualified Data.ByteString.Base64.URL as U
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Lazy.Char8 as LB
+import Data.Int (Int64)
+import Data.List.NonEmpty (NonEmpty (..))
+import Data.Text (Text)
+import Data.Time.Clock.System
+import qualified Data.X509 as X
+import Simplex.Messaging.Notifications.Protocol
+import Simplex.Messaging.Parsers (defaultJSON)
+import Simplex.Messaging.Transport.HTTP2.Client (HTTP2ClientError)
+import qualified Simplex.Messaging.Crypto as C
+import Network.HTTP.Types (Status)
+import Control.Exception (Exception)
+import Simplex.Messaging.Notifications.Server.Store.Types (NtfTknRec)
+import Control.Monad.Except (ExceptT)
+
+data JWTHeader = JWTHeader
+  { alg :: Text, -- key algorithm, ES256 for APNS
+    kid :: Text -- key ID
+  }
+  deriving (Show)
+
+data JWTClaims = JWTClaims
+  { iss :: Text, -- issuer, team ID for APNS
+    iat :: Int64 -- issue time, seconds from epoch
+  }
+  deriving (Show)
+
+data JWTToken = JWTToken JWTHeader JWTClaims
+  deriving (Show)
+
+mkJWTToken :: JWTHeader -> Text -> IO JWTToken
+mkJWTToken hdr iss = do
+  iat <- systemSeconds <$> getSystemTime
+  pure $ JWTToken hdr JWTClaims {iss, iat}
+
+type SignedJWTToken = ByteString
+
+$(JQ.deriveToJSON defaultJSON ''JWTHeader)
+
+$(JQ.deriveToJSON defaultJSON ''JWTClaims)
+
+signedJWTToken :: EC.PrivateKey -> JWTToken -> IO SignedJWTToken
+signedJWTToken pk (JWTToken hdr claims) = do
+  let hc = jwtEncode hdr <> "." <> jwtEncode claims
+  sig <- EC.sign pk SHA256 hc
+  pure $ hc <> "." <> serialize sig
+  where
+    jwtEncode :: ToJSON a => a -> ByteString
+    jwtEncode = U.encodeUnpadded . LB.toStrict . J.encode
+    serialize sig = U.encodeUnpadded $ encodeASN1' DER [Start Sequence, IntVal (EC.sign_r sig), IntVal (EC.sign_s sig), End Sequence]
+
+readECPrivateKey :: FilePath -> IO EC.PrivateKey
+readECPrivateKey f = do
+  -- this pattern match is specific to APNS key type, it may need to be extended for other push providers
+  [PK.Unprotected (X.PrivKeyEC X.PrivKeyEC_Named {privkeyEC_name, privkeyEC_priv})] <- PK.readKeyFile f
+  pure EC.PrivateKey {private_curve = ECT.getCurveByName privkeyEC_name, private_d = privkeyEC_priv}
+
+data PushNotification
+  = PNVerification NtfRegCode
+  | PNMessage (NonEmpty PNMessageData)
+  | -- | PNAlert Text
+    PNCheckMessages
+  deriving (Show)
+
+data PushProviderError
+  = PPConnection HTTP2ClientError
+  | PPCryptoError C.CryptoError
+  | PPResponseError (Maybe Status) Text
+  | PPTokenInvalid NTInvalidReason
+  | PPRetryLater
+  | PPPermanentError
+  deriving (Show, Exception)
+
+type PushProviderClient = NtfTknRec -> PushNotification -> ExceptT PushProviderError IO ()

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

@@ -10,20 +10,13 @@
 
 module Simplex.Messaging.Notifications.Server.Push.APNS where
 
-import Control.Exception (Exception)
 import Control.Logger.Simple
 import Control.Monad
 import Control.Monad.Except
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Except
-import Crypto.Hash.Algorithms (SHA256 (..))
 import qualified Crypto.PubKey.ECC.ECDSA as EC
-import qualified Crypto.PubKey.ECC.Types as ECT
 import Crypto.Random (ChaChaDRG)
-import qualified Crypto.Store.PKCS8 as PK
-import Data.ASN1.BinaryEncoding (DER (..))
-import Data.ASN1.Encoding
-import Data.ASN1.Types
 import Data.Aeson (ToJSON, (.=))
 import qualified Data.Aeson as J
 import qualified Data.Aeson.Encoding as JE
@@ -32,18 +25,15 @@ import Data.Bifunctor (first)
 import qualified Data.ByteString.Base64.URL as U
 import Data.ByteString.Builder (lazyByteString)
 import Data.ByteString.Char8 (ByteString)
-import qualified Data.ByteString.Lazy.Char8 as LB
 import qualified Data.CaseInsensitive as CI
 import Data.Int (Int64)
 import Data.List (find)
-import Data.List.NonEmpty (NonEmpty (..))
 import Data.Map.Strict (Map)
 import Data.Maybe (isNothing)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding (encodeUtf8)
 import Data.Time.Clock.System
-import qualified Data.X509 as X
 import qualified Data.X509.CertificateStore as XS
 import Network.HPACK.Token as HT
 import Network.HTTP.Types (Status)
@@ -53,6 +43,7 @@ import qualified Network.HTTP2.Client as H
 import Network.Socket (HostName, ServiceName)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Notifications.Protocol
+import Simplex.Messaging.Notifications.Server.Push
 import Simplex.Messaging.Notifications.Server.Push.APNS.Internal
 import Simplex.Messaging.Notifications.Server.Store.Types (NtfTknRec (..))
 import Simplex.Messaging.Parsers (defaultJSON)
@@ -62,55 +53,6 @@ import Simplex.Messaging.Util (safeDecodeUtf8, tshow)
 import System.Environment (getEnv)
 import UnliftIO.STM
 
-data JWTHeader = JWTHeader
-  { alg :: Text, -- key algorithm, ES256 for APNS
-    kid :: Text -- key ID
-  }
-  deriving (Show)
-
-data JWTClaims = JWTClaims
-  { iss :: Text, -- issuer, team ID for APNS
-    iat :: Int64 -- issue time, seconds from epoch
-  }
-  deriving (Show)
-
-data JWTToken = JWTToken JWTHeader JWTClaims
-  deriving (Show)
-
-mkJWTToken :: JWTHeader -> Text -> IO JWTToken
-mkJWTToken hdr iss = do
-  iat <- systemSeconds <$> getSystemTime
-  pure $ JWTToken hdr JWTClaims {iss, iat}
-
-type SignedJWTToken = ByteString
-
-$(JQ.deriveToJSON defaultJSON ''JWTHeader)
-
-$(JQ.deriveToJSON defaultJSON ''JWTClaims)
-
-signedJWTToken :: EC.PrivateKey -> JWTToken -> IO SignedJWTToken
-signedJWTToken pk (JWTToken hdr claims) = do
-  let hc = jwtEncode hdr <> "." <> jwtEncode claims
-  sig <- EC.sign pk SHA256 hc
-  pure $ hc <> "." <> serialize sig
-  where
-    jwtEncode :: ToJSON a => a -> ByteString
-    jwtEncode = U.encodeUnpadded . LB.toStrict . J.encode
-    serialize sig = U.encodeUnpadded $ encodeASN1' DER [Start Sequence, IntVal (EC.sign_r sig), IntVal (EC.sign_s sig), End Sequence]
-
-readECPrivateKey :: FilePath -> IO EC.PrivateKey
-readECPrivateKey f = do
-  -- this pattern match is specific to APNS key type, it may need to be extended for other push providers
-  [PK.Unprotected (X.PrivKeyEC X.PrivKeyEC_Named {privkeyEC_name, privkeyEC_priv})] <- PK.readKeyFile f
-  pure EC.PrivateKey {private_curve = ECT.getCurveByName privkeyEC_name, private_d = privkeyEC_priv}
-
-data PushNotification
-  = PNVerification NtfRegCode
-  | PNMessage (NonEmpty PNMessageData)
-  | -- | PNAlert Text
-    PNCheckMessages
-  deriving (Show)
-
 data APNSNotification = APNSNotification {aps :: APNSNotificationBody, notificationData :: Maybe J.Value}
   deriving (Show)
 
@@ -308,17 +250,6 @@ apnsRequest c tkn ntf@APNSNotification {aps} = do
       APNSBackground {} -> "background"
       _ -> "alert"
 
-data PushProviderError
-  = PPConnection HTTP2ClientError
-  | PPCryptoError C.CryptoError
-  | PPResponseError (Maybe Status) Text
-  | PPTokenInvalid NTInvalidReason
-  | PPRetryLater
-  | PPPermanentError
-  deriving (Show, Exception)
-
-type PushProviderClient = NtfTknRec -> PushNotification -> ExceptT PushProviderError IO ()
-
 -- this is not a newtype on purpose to have a correct JSON encoding as a record
 data APNSErrorResponse = APNSErrorResponse {reason :: Text}