diff --git a/simplexmq.cabal b/simplexmq.cabal index e4845924a..476b0a4be 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -258,6 +258,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 diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs index ff36af4c3..fe2574eab 100644 --- a/src/Simplex/Messaging/Notifications/Server.hs +++ b/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 diff --git a/src/Simplex/Messaging/Notifications/Server/Env.hs b/src/Simplex/Messaging/Notifications/Server/Env.hs index b0eafbc63..7ed258b9a 100644 --- a/src/Simplex/Messaging/Notifications/Server/Env.hs +++ b/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)], diff --git a/src/Simplex/Messaging/Notifications/Server/Push.hs b/src/Simplex/Messaging/Notifications/Server/Push.hs new file mode 100644 index 000000000..edb671212 --- /dev/null +++ b/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 () diff --git a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs index 39aeb9329..2337fa7fd 100644 --- a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs +++ b/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}