From e90c15bb90eca295ad312ce286c8e495c6db275d Mon Sep 17 00:00:00 2001 From: sim Date: Thu, 26 Jun 2025 16:59:25 +0200 Subject: [PATCH 1/3] Move generic push functions to Push.hs --- .../Messaging/Notifications/Server/Push.hs | 81 +++++++++++++++++++ .../Notifications/Server/Push/APNS.hs | 59 +------------- 2 files changed, 82 insertions(+), 58 deletions(-) create mode 100644 src/Simplex/Messaging/Notifications/Server/Push.hs diff --git a/src/Simplex/Messaging/Notifications/Server/Push.hs b/src/Simplex/Messaging/Notifications/Server/Push.hs new file mode 100644 index 000000000..0320b8c51 --- /dev/null +++ b/src/Simplex/Messaging/Notifications/Server/Push.hs @@ -0,0 +1,81 @@ +{-# 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) + +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) diff --git a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs index 39aeb9329..da647253e 100644 --- a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs +++ b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs @@ -16,14 +16,8 @@ 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 +26,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 +44,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 +54,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) From c08c3794bab8f816f7692240ee0c90033c35a759 Mon Sep 17 00:00:00 2001 From: sim Date: Fri, 11 Jul 2025 16:48:38 +0200 Subject: [PATCH 2/3] Fix move push --- simplexmq.cabal | 1 + src/Simplex/Messaging/Notifications/Server.hs | 3 ++- .../Messaging/Notifications/Server/Env.hs | 1 + .../Messaging/Notifications/Server/Push.hs | 18 ++++++++++++++++++ .../Notifications/Server/Push/APNS.hs | 12 ------------ 5 files changed, 22 insertions(+), 13 deletions(-) diff --git a/simplexmq.cabal b/simplexmq.cabal index e96f3f1db..dc56e4ff3 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -259,6 +259,7 @@ library Simplex.Messaging.Notifications.Server.Main Simplex.Messaging.Notifications.Server.Prometheus Simplex.Messaging.Notifications.Server.Push.APNS + Simplex.Messaging.Notifications.Server.Push Simplex.Messaging.Notifications.Server.Push.APNS.Internal Simplex.Messaging.Notifications.Server.Stats Simplex.Messaging.Notifications.Server.Store diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs index ac274dc08..76dca88f9 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 @@ -675,6 +675,7 @@ ntfPush s@NtfPushServer {pushQ} = forever $ do void $ updateTknStatus st tkn $ NTInvalid $ Just r err e PPPermanentError -> err e + PPInvalidPusher -> err e where retryDeliver :: IO (Either PushProviderError ()) retryDeliver = do 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 index 0320b8c51..3c7e57c6a 100644 --- a/src/Simplex/Messaging/Notifications/Server/Push.hs +++ b/src/Simplex/Messaging/Notifications/Server/Push.hs @@ -30,6 +30,12 @@ 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 @@ -79,3 +85,15 @@ data PushNotification | -- | PNAlert Text PNCheckMessages deriving (Show) + +data PushProviderError + = PPConnection HTTP2ClientError + | PPCryptoError C.CryptoError + | PPResponseError (Maybe Status) Text + | PPTokenInvalid NTInvalidReason + | PPRetryLater + | PPPermanentError + | PPInvalidPusher + 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 da647253e..2337fa7fd 100644 --- a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs +++ b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs @@ -10,7 +10,6 @@ module Simplex.Messaging.Notifications.Server.Push.APNS where -import Control.Exception (Exception) import Control.Logger.Simple import Control.Monad import Control.Monad.Except @@ -251,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} From e7e7c9bfa1e13c4bd9e491d81c71da2efef840aa Mon Sep 17 00:00:00 2001 From: sim Date: Wed, 27 Aug 2025 11:13:25 +0200 Subject: [PATCH 3/3] Rename APNSDeviceToken --- src/Simplex/Messaging/Agent/Client.hs | 2 +- .../Messaging/Agent/Store/AgentStore.hs | 16 ++++++------ .../Messaging/Notifications/Protocol.hs | 19 +++++++------- src/Simplex/Messaging/Notifications/Server.hs | 4 +-- .../Notifications/Server/Push/APNS.hs | 2 +- .../Notifications/Server/Store/Postgres.hs | 10 +++---- tests/AgentTests/NotificationTests.hs | 26 +++++++++---------- tests/NtfClient.hs | 2 +- tests/NtfServerTests.hs | 6 ++--- 9 files changed, 44 insertions(+), 43 deletions(-) diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 39b3534c0..da2bea5e5 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -1316,7 +1316,7 @@ runNTFServerTest c@AgentClient {presetDomains} nm userId (ProtoServerWithAuth sr (nKey, npKey) <- atomically $ C.generateAuthKeyPair a g (dhKey, _) <- atomically $ C.generateKeyPair g r <- runExceptT $ do - let deviceToken = DeviceToken PPApnsNull "test_ntf_token" + let deviceToken = APNSDeviceToken PPApnsNull "test_ntf_token" (tknId, _) <- liftError (testErr TSCreateNtfToken) $ ntfRegisterToken ntf nm npKey (NewNtfTkn deviceToken nKey dhKey) liftError (testErr TSDeleteNtfToken) $ ntfDeleteToken ntf nm npKey tknId ok <- netTimeoutInt (tcpTimeout $ networkConfig cfg) nm `timeout` closeProtocolClient ntf diff --git a/src/Simplex/Messaging/Agent/Store/AgentStore.hs b/src/Simplex/Messaging/Agent/Store/AgentStore.hs index e10f48c8f..e19c34f32 100644 --- a/src/Simplex/Messaging/Agent/Store/AgentStore.hs +++ b/src/Simplex/Messaging/Agent/Store/AgentStore.hs @@ -1382,7 +1382,7 @@ deleteCommand db cmdId = DB.execute db "DELETE FROM commands WHERE command_id = ?" (Only cmdId) createNtfToken :: DB.Connection -> NtfToken -> IO () -createNtfToken db NtfToken {deviceToken = DeviceToken provider token, ntfServer = srv@ProtocolServer {host, port}, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhKeys = (ntfDhPubKey, ntfDhPrivKey), ntfDhSecret, ntfTknStatus, ntfTknAction, ntfMode} = do +createNtfToken db NtfToken {deviceToken = APNSDeviceToken provider token, ntfServer = srv@ProtocolServer {host, port}, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhKeys = (ntfDhPubKey, ntfDhPrivKey), ntfDhSecret, ntfTknStatus, ntfTknAction, ntfMode} = do upsertNtfServer_ db srv DB.execute db @@ -1409,10 +1409,10 @@ getSavedNtfToken db = do let ntfServer = NtfServer host port keyHash ntfDhKeys = (ntfDhPubKey, ntfDhPrivKey) ntfMode = fromMaybe NMPeriodic ntfMode_ - in NtfToken {deviceToken = DeviceToken provider dt, ntfServer, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhKeys, ntfDhSecret, ntfTknStatus, ntfTknAction, ntfMode} + in NtfToken {deviceToken = APNSDeviceToken provider dt, ntfServer, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhKeys, ntfDhSecret, ntfTknStatus, ntfTknAction, ntfMode} updateNtfTokenRegistration :: DB.Connection -> NtfToken -> NtfTokenId -> C.DhSecretX25519 -> IO () -updateNtfTokenRegistration db NtfToken {deviceToken = DeviceToken provider token, ntfServer = ProtocolServer {host, port}} tknId ntfDhSecret = do +updateNtfTokenRegistration db NtfToken {deviceToken = APNSDeviceToken provider token, ntfServer = ProtocolServer {host, port}} tknId ntfDhSecret = do updatedAt <- getCurrentTime DB.execute db @@ -1424,7 +1424,7 @@ updateNtfTokenRegistration db NtfToken {deviceToken = DeviceToken provider token (tknId, ntfDhSecret, NTRegistered, Nothing :: Maybe NtfTknAction, updatedAt, provider, token, host, port) updateDeviceToken :: DB.Connection -> NtfToken -> DeviceToken -> IO () -updateDeviceToken db NtfToken {deviceToken = DeviceToken provider token, ntfServer = ProtocolServer {host, port}} (DeviceToken toProvider toToken) = do +updateDeviceToken db NtfToken {deviceToken = APNSDeviceToken provider token, ntfServer = ProtocolServer {host, port}} (APNSDeviceToken toProvider toToken) = do updatedAt <- getCurrentTime DB.execute db @@ -1436,7 +1436,7 @@ updateDeviceToken db NtfToken {deviceToken = DeviceToken provider token, ntfServ (toProvider, toToken, NTRegistered, Nothing :: Maybe NtfTknAction, updatedAt, provider, token, host, port) updateNtfMode :: DB.Connection -> NtfToken -> NotificationsMode -> IO () -updateNtfMode db NtfToken {deviceToken = DeviceToken provider token, ntfServer = ProtocolServer {host, port}} ntfMode = do +updateNtfMode db NtfToken {deviceToken = APNSDeviceToken provider token, ntfServer = ProtocolServer {host, port}} ntfMode = do updatedAt <- getCurrentTime DB.execute db @@ -1448,7 +1448,7 @@ updateNtfMode db NtfToken {deviceToken = DeviceToken provider token, ntfServer = (ntfMode, updatedAt, provider, token, host, port) updateNtfToken :: DB.Connection -> NtfToken -> NtfTknStatus -> Maybe NtfTknAction -> IO () -updateNtfToken db NtfToken {deviceToken = DeviceToken provider token, ntfServer = ProtocolServer {host, port}} tknStatus tknAction = do +updateNtfToken db NtfToken {deviceToken = APNSDeviceToken provider token, ntfServer = ProtocolServer {host, port}} tknStatus tknAction = do updatedAt <- getCurrentTime DB.execute db @@ -1460,7 +1460,7 @@ updateNtfToken db NtfToken {deviceToken = DeviceToken provider token, ntfServer (tknStatus, tknAction, updatedAt, provider, token, host, port) removeNtfToken :: DB.Connection -> NtfToken -> IO () -removeNtfToken db NtfToken {deviceToken = DeviceToken provider token, ntfServer = ProtocolServer {host, port}} = +removeNtfToken db NtfToken {deviceToken = APNSDeviceToken provider token, ntfServer = ProtocolServer {host, port}} = DB.execute db [sql| @@ -1785,7 +1785,7 @@ getActiveNtfToken db = let ntfServer = NtfServer host port keyHash ntfDhKeys = (ntfDhPubKey, ntfDhPrivKey) ntfMode = fromMaybe NMPeriodic ntfMode_ - in NtfToken {deviceToken = DeviceToken provider dt, ntfServer, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhKeys, ntfDhSecret, ntfTknStatus, ntfTknAction, ntfMode} + in NtfToken {deviceToken = APNSDeviceToken provider dt, ntfServer, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhKeys, ntfDhSecret, ntfTknStatus, ntfTknAction, ntfMode} getNtfRcvQueue :: DB.Connection -> SMPQueueNtf -> IO (Either StoreError (ConnId, Int64, RcvNtfDhSecret, Maybe UTCTime)) getNtfRcvQueue db SMPQueueNtf {smpServer = (SMPServer host port _), notifierId} = diff --git a/src/Simplex/Messaging/Notifications/Protocol.hs b/src/Simplex/Messaging/Notifications/Protocol.hs index 0b5889bb7..1c7bf5cff 100644 --- a/src/Simplex/Messaging/Notifications/Protocol.hs +++ b/src/Simplex/Messaging/Notifications/Protocol.hs @@ -411,32 +411,33 @@ instance FromField PushProvider where fromField = fromTextField_ $ eitherToMaybe instance ToField PushProvider where toField = toField . decodeLatin1 . strEncode -data DeviceToken = DeviceToken PushProvider ByteString +data DeviceToken + = APNSDeviceToken PushProvider ByteString deriving (Eq, Ord, Show) instance Encoding DeviceToken where - smpEncode (DeviceToken p t) = smpEncode (p, t) - smpP = DeviceToken <$> smpP <*> smpP + smpEncode (APNSDeviceToken p t) = smpEncode (p, t) + smpP = APNSDeviceToken <$> smpP <*> smpP instance StrEncoding DeviceToken where - strEncode (DeviceToken p t) = strEncode p <> " " <> t + strEncode (APNSDeviceToken p t) = strEncode p <> " " <> t strP = nullToken <|> hexToken where - nullToken = "apns_null test_ntf_token" $> DeviceToken PPApnsNull "test_ntf_token" - hexToken = DeviceToken <$> strP <* A.space <*> hexStringP + nullToken = "apns_null test_ntf_token" $> APNSDeviceToken PPApnsNull "test_ntf_token" + hexToken = APNSDeviceToken <$> strP <* A.space <*> hexStringP hexStringP = A.takeWhile (`B.elem` "0123456789abcdef") >>= \s -> if even (B.length s) then pure s else fail "odd number of hex characters" instance ToJSON DeviceToken where - toEncoding (DeviceToken pp t) = J.pairs $ "pushProvider" .= decodeLatin1 (strEncode pp) <> "token" .= decodeLatin1 t - toJSON (DeviceToken pp t) = J.object ["pushProvider" .= decodeLatin1 (strEncode pp), "token" .= decodeLatin1 t] + toEncoding (APNSDeviceToken pp t) = J.pairs $ "pushProvider" .= decodeLatin1 (strEncode pp) <> "token" .= decodeLatin1 t + toJSON (APNSDeviceToken pp t) = J.object ["pushProvider" .= decodeLatin1 (strEncode pp), "token" .= decodeLatin1 t] instance FromJSON DeviceToken where parseJSON = J.withObject "DeviceToken" $ \o -> do pp <- strDecode . encodeUtf8 <$?> o .: "pushProvider" t <- encodeUtf8 <$> o .: "token" - pure $ DeviceToken pp t + pure $ APNSDeviceToken pp t -- List of PNMessageData uses semicolon-separated encoding instead of strEncode, -- because strEncode of NonEmpty list uses comma for separator, diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs index 76dca88f9..859cbe142 100644 --- a/src/Simplex/Messaging/Notifications/Server.hs +++ b/src/Simplex/Messaging/Notifications/Server.hs @@ -629,7 +629,7 @@ showServer' = decodeLatin1 . strEncode . host ntfPush :: NtfPushServer -> M () ntfPush s@NtfPushServer {pushQ} = forever $ do - (srvHost_, tkn@NtfTknRec {ntfTknId, token = t@(DeviceToken pp _), tknStatus}, ntf) <- atomically (readTBQueue pushQ) + (srvHost_, tkn@NtfTknRec {ntfTknId, token = t@(APNSDeviceToken pp _), tknStatus}, ntf) <- atomically (readTBQueue pushQ) liftIO $ logDebug $ "sending push notification to " <> T.pack (show pp) st <- asks store case ntf of @@ -906,7 +906,7 @@ withNtfStore stAction continue = do Right a -> continue a incNtfStatT :: DeviceToken -> (NtfServerStats -> IORef Int) -> M () -incNtfStatT (DeviceToken PPApnsNull _) _ = pure () +incNtfStatT (APNSDeviceToken PPApnsNull _) _ = pure () incNtfStatT _ statSel = incNtfStat statSel {-# INLINE incNtfStatT #-} diff --git a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs index 2337fa7fd..b9b2700ce 100644 --- a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs +++ b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs @@ -256,7 +256,7 @@ data APNSErrorResponse = APNSErrorResponse {reason :: Text} $(JQ.deriveFromJSON defaultJSON ''APNSErrorResponse) apnsPushProviderClient :: APNSPushClient -> PushProviderClient -apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknRec {token = DeviceToken _ tknStr} pn = do +apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknRec {token = APNSDeviceToken _ tknStr} pn = do http2 <- liftHTTPS2 $ getApnsHTTP2Client c nonce <- atomically $ C.randomCbNonce nonceDrg apnsNtf <- liftEither $ first PPCryptoError $ apnsNotification tkn nonce (paddedNtfLength apnsCfg) pn diff --git a/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs b/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs index b6f23047f..0c8600510 100644 --- a/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs +++ b/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs @@ -126,7 +126,7 @@ insertNtfTknQuery = |] replaceNtfToken :: NtfPostgresStore -> NtfTknRec -> IO (Either ErrorType ()) -replaceNtfToken st NtfTknRec {ntfTknId, token = token@(DeviceToken pp ppToken), tknStatus, tknRegCode = code@(NtfRegCode regCode)} = +replaceNtfToken st NtfTknRec {ntfTknId, token = token@(APNSDeviceToken pp ppToken), tknStatus, tknRegCode = code@(NtfRegCode regCode)} = withFastDB "replaceNtfToken" st $ \db -> runExceptT $ do ExceptT $ assertUpdated <$> DB.execute @@ -141,7 +141,7 @@ replaceNtfToken st NtfTknRec {ntfTknId, token = token@(DeviceToken pp ppToken), ntfTknToRow :: NtfTknRec -> NtfTknRow ntfTknToRow NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhPrivKey, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt} = - let DeviceToken pp ppToken = token + let APNSDeviceToken pp ppToken = token NtfRegCode regCode = tknRegCode in (ntfTknId, pp, Binary ppToken, tknStatus, tknVerifyKey, tknDhPrivKey, tknDhSecret, Binary regCode, tknCronInterval, tknUpdatedAt) @@ -151,7 +151,7 @@ getNtfToken st tknId = getNtfToken_ st " WHERE token_id = ?" (Only tknId) findNtfTokenRegistration :: NtfPostgresStore -> NewNtfEntity 'Token -> IO (Either ErrorType (Maybe NtfTknRec)) -findNtfTokenRegistration st (NewNtfTkn (DeviceToken pp ppToken) tknVerifyKey _) = +findNtfTokenRegistration st (NewNtfTkn (APNSDeviceToken pp ppToken) tknVerifyKey _) = getNtfToken_ st " WHERE push_provider = ? AND push_provider_token = ? AND verify_key = ?" (pp, Binary ppToken, tknVerifyKey) getNtfToken_ :: ToRow q => NtfPostgresStore -> Query -> q -> IO (Either ErrorType (Maybe NtfTknRec)) @@ -179,7 +179,7 @@ ntfTknQuery = rowToNtfTkn :: NtfTknRow -> NtfTknRec rowToNtfTkn (ntfTknId, pp, Binary ppToken, tknStatus, tknVerifyKey, tknDhPrivKey, tknDhSecret, Binary regCode, tknCronInterval, tknUpdatedAt) = - let token = DeviceToken pp ppToken + let token = APNSDeviceToken pp ppToken tknRegCode = NtfRegCode regCode in NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhPrivKey, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt} @@ -374,7 +374,7 @@ setTknStatusConfirmed st NtfTknRec {ntfTknId} = when (updated > 0) $ withLog "updateTknStatus" st $ \sl -> logTokenStatus sl ntfTknId NTConfirmed setTokenActive :: NtfPostgresStore -> NtfTknRec -> IO (Either ErrorType ()) -setTokenActive st tkn@NtfTknRec {ntfTknId, token = DeviceToken pp ppToken} = +setTokenActive st tkn@NtfTknRec {ntfTknId, token = APNSDeviceToken pp ppToken} = withFastDB' "setTokenActive" st $ \db -> do updateTknStatus_ st db tkn NTActive -- this removes other instances of the same token, e.g. because of repeated token registration attempts diff --git a/tests/AgentTests/NotificationTests.hs b/tests/AgentTests/NotificationTests.hs index c7be1a3e2..acd4699a3 100644 --- a/tests/AgentTests/NotificationTests.hs +++ b/tests/AgentTests/NotificationTests.hs @@ -218,7 +218,7 @@ runNtfTestCfg (t, msType) baseId smpCfg ntfCfg aCfg bCfg runTest = do testNotificationToken :: APNSMockServer -> IO () testNotificationToken apns = do withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight_ $ do - let tkn = DeviceToken PPApnsTest "abcd" + let tkn = APNSDeviceToken PPApnsTest "abcd" NTRegistered <- registerNtfToken a tkn NMPeriodic APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- getMockNotification apns tkn @@ -242,7 +242,7 @@ v .-> key = do testNtfTokenRepeatRegistration :: APNSMockServer -> IO () testNtfTokenRepeatRegistration apns = do withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight_ $ do - let tkn = DeviceToken PPApnsTest "abcd" + let tkn = APNSDeviceToken PPApnsTest "abcd" NTRegistered <- registerNtfToken a tkn NMPeriodic APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- getMockNotification apns tkn @@ -261,7 +261,7 @@ testNtfTokenRepeatRegistration apns = do testNtfTokenSecondRegistration :: APNSMockServer -> IO () testNtfTokenSecondRegistration apns = withAgentClients2 $ \a a' -> runRight_ $ do - let tkn = DeviceToken PPApnsTest "abcd" + let tkn = APNSDeviceToken PPApnsTest "abcd" NTRegistered <- registerNtfToken a tkn NMPeriodic APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- getMockNotification apns tkn @@ -290,7 +290,7 @@ testNtfTokenSecondRegistration apns = testNtfTokenServerRestart :: ASrvTransport -> APNSMockServer -> IO () testNtfTokenServerRestart t apns = do - let tkn = DeviceToken PPApnsTest "abcd" + let tkn = APNSDeviceToken PPApnsTest "abcd" ntfData <- withAgent 1 agentCfg initAgentServers testDB $ \a -> withNtfServer t $ runRight $ do NTRegistered <- registerNtfToken a tkn NMPeriodic @@ -311,7 +311,7 @@ testNtfTokenServerRestart t apns = do testNtfTokenServerRestartReverify :: ASrvTransport -> APNSMockServer -> IO () testNtfTokenServerRestartReverify t apns = do - let tkn = DeviceToken PPApnsTest "abcd" + let tkn = APNSDeviceToken PPApnsTest "abcd" withAgent 1 agentCfg initAgentServers testDB $ \a -> do ntfData <- withNtfServer t $ runRight $ do NTRegistered <- registerNtfToken a tkn NMPeriodic @@ -334,7 +334,7 @@ testNtfTokenServerRestartReverify t apns = do testNtfTokenServerRestartReverifyTimeout :: ASrvTransport -> APNSMockServer -> IO () testNtfTokenServerRestartReverifyTimeout t apns = do - let tkn = DeviceToken PPApnsTest "abcd" + let tkn = APNSDeviceToken PPApnsTest "abcd" withAgent 1 agentCfg initAgentServers testDB $ \a@AgentClient {agentEnv = Env {store}} -> do (nonce, verification) <- withNtfServer t $ runRight $ do NTRegistered <- registerNtfToken a tkn NMPeriodic @@ -369,7 +369,7 @@ testNtfTokenServerRestartReverifyTimeout t apns = do testNtfTokenServerRestartReregister :: ASrvTransport -> APNSMockServer -> IO () testNtfTokenServerRestartReregister t apns = do - let tkn = DeviceToken PPApnsTest "abcd" + let tkn = APNSDeviceToken PPApnsTest "abcd" withAgent 1 agentCfg initAgentServers testDB $ \a -> withNtfServer t $ runRight $ do NTRegistered <- registerNtfToken a tkn NMPeriodic @@ -393,7 +393,7 @@ testNtfTokenServerRestartReregister t apns = do testNtfTokenServerRestartReregisterTimeout :: ASrvTransport -> APNSMockServer -> IO () testNtfTokenServerRestartReregisterTimeout t apns = do - let tkn = DeviceToken PPApnsTest "abcd" + let tkn = APNSDeviceToken PPApnsTest "abcd" withAgent 1 agentCfg initAgentServers testDB $ \a@AgentClient {agentEnv = Env {store}} -> do withNtfServer t $ runRight $ do NTRegistered <- registerNtfToken a tkn NMPeriodic @@ -434,7 +434,7 @@ getTestNtfTokenPort a = testNtfTokenMultipleServers :: ASrvTransport -> APNSMockServer -> IO () testNtfTokenMultipleServers t apns = do - let tkn = DeviceToken PPApnsTest "abcd" + let tkn = APNSDeviceToken PPApnsTest "abcd" withAgent 1 agentCfg initAgentServers2 testDB $ \a -> withNtfServerThreadOn t ntfTestPort ntfTestDBCfg $ \ntf -> withNtfServerThreadOn t ntfTestPort2 ntfTestDBCfg2 $ \ntf2 -> runRight_ $ do @@ -554,7 +554,7 @@ testNotificationSubscriptionExistingConnection apns baseId alice@AgentClient {ag get alice ##> ("", bobId, CON) get bob ##> ("", aliceId, CON) -- register notification token - let tkn = DeviceToken PPApnsTest "abcd" + let tkn = APNSDeviceToken PPApnsTest "abcd" NTRegistered <- registerNtfToken alice tkn NMInstant APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- getMockNotification apns tkn @@ -607,9 +607,9 @@ testNotificationSubscriptionNewConnection :: HasCallStack => APNSMockServer -> A testNotificationSubscriptionNewConnection apns baseId alice bob = runRight_ $ do -- alice registers notification token - DeviceToken {} <- registerTestToken alice "abcd" NMInstant apns + APNSDeviceToken {} <- registerTestToken alice "abcd" NMInstant apns -- bob registers notification token - DeviceToken {} <- registerTestToken bob "bcde" NMInstant apns + APNSDeviceToken {} <- registerTestToken bob "bcde" NMInstant apns -- establish connection liftIO $ threadDelay 50000 (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe @@ -645,7 +645,7 @@ testNotificationSubscriptionNewConnection apns baseId alice bob = registerTestToken :: AgentClient -> ByteString -> NotificationsMode -> APNSMockServer -> ExceptT AgentErrorType IO DeviceToken registerTestToken a token mode apns = do - let tkn = DeviceToken PPApnsTest token + let tkn = APNSDeviceToken PPApnsTest token NTRegistered <- registerNtfToken a tkn mode Just APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}} <- timeout 1000000 $ getMockNotification apns tkn diff --git a/tests/NtfClient.hs b/tests/NtfClient.hs index 30b648401..bd833446c 100644 --- a/tests/NtfClient.hs +++ b/tests/NtfClient.hs @@ -293,7 +293,7 @@ getAPNSMockServer config@HTTP2ServerConfig {qSize} = do sendApnsResponse $ APNSRespError N.badRequest400 "bad_request_body" getMockNotification :: MonadIO m => APNSMockServer -> DeviceToken -> m APNSMockRequest -getMockNotification APNSMockServer {notifications} (DeviceToken _ token) = do +getMockNotification APNSMockServer {notifications} (APNSDeviceToken _ token) = do atomically $ TM.lookup token notifications >>= maybe retry readTBQueue getAnyMockNotification :: MonadIO m => APNSMockServer -> m APNSMockRequest diff --git a/tests/NtfServerTests.hs b/tests/NtfServerTests.hs index a4f0a7d62..c4dd72b24 100644 --- a/tests/NtfServerTests.hs +++ b/tests/NtfServerTests.hs @@ -107,7 +107,7 @@ testNotificationSubscription (ATransport t, msType) createQueue = (nPub, nKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (tknPub, tknKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g - let tkn = DeviceToken PPApnsTest "abcd" + let tkn = APNSDeviceToken PPApnsTest "abcd" withAPNSMockServer $ \apns -> smpTest2 t msType $ \rh sh -> ntfTest t $ \nh -> do @@ -160,7 +160,7 @@ testNotificationSubscription (ATransport t, msType) createQueue = (msgBody, "hello") #== "delivered from queue" Resp "6" _ OK <- signSendRecv rh rKey ("6", rId, ACK mId1) -- replace token - let tkn' = DeviceToken PPApnsTest "efgh" + let tkn' = APNSDeviceToken PPApnsTest "efgh" RespNtf "7" tId' NROk <- signSendRecvNtf nh tknKey ("7", tId, TRPL tkn') tId `shouldBe` tId' APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData2}} <- @@ -237,7 +237,7 @@ registerToken nh apns token = do g <- C.newRandom (tknPub, tknKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g - let tkn = DeviceToken PPApnsTest token + let tkn = APNSDeviceToken PPApnsTest token RespNtf "1" NoEntity (NRTknId tId ntfDh) <- signSendRecvNtf nh tknKey ("1", NoEntity, TNEW $ NewNtfTkn tkn tknPub dhPub) APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- getMockNotification apns tkn