diff --git a/simplexmq.cabal b/simplexmq.cabal index f6ab07e08..57ceaa599 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -266,6 +266,7 @@ library Simplex.Messaging.Notifications.Server.Prometheus Simplex.Messaging.Notifications.Server.Push Simplex.Messaging.Notifications.Server.Push.APNS + Simplex.Messaging.Notifications.Server.Push.WebPush Simplex.Messaging.Notifications.Server.Push.APNS.Internal Simplex.Messaging.Notifications.Server.Stats Simplex.Messaging.Notifications.Server.Store @@ -298,6 +299,7 @@ library , attoparsec ==0.14.* , base >=4.14 && <5 , base64-bytestring >=1.0 && <1.3 + , binary ==0.8.* , composition ==1.0.* , constraints >=0.12 && <0.14 , containers ==0.6.* @@ -341,6 +343,8 @@ library case-insensitive ==1.2.* , hashable ==1.4.* , ini ==0.4.1 + , http-client ==0.7.* + , http-client-tls ==0.3.6.* , optparse-applicative >=0.15 && <0.17 , process ==1.6.* , temporary ==1.3.* @@ -510,6 +514,7 @@ test-suite simplexmq-test AgentTests.NotificationTests NtfClient NtfServerTests + NtfWPTests PostgresSchemaDump hs-source-dirs: tests diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index c19d4aeea..e75e356a2 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -201,7 +201,7 @@ import qualified Simplex.Messaging.Crypto.ShortLink as SL import qualified Simplex.Messaging.Crypto.Ratchet as CR import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfRegCode (NtfRegCode), NtfTknStatus (..), NtfTokenId, PNMessageData (..), pnMessagesP) +import Simplex.Messaging.Notifications.Protocol (ADeviceToken, NtfRegCode (NtfRegCode), NtfTknStatus (..), NtfTokenId, PNMessageData (..), pnMessagesP) import Simplex.Messaging.Notifications.Types import Simplex.Messaging.Parsers (defaultJSON, parse) import Simplex.Messaging.Protocol @@ -619,24 +619,24 @@ reconnectAllServers c = do reconnectServerClients c ntfClients -- | Register device notifications token -registerNtfToken :: AgentClient -> NetworkRequestMode -> DeviceToken -> NotificationsMode -> AE NtfTknStatus +registerNtfToken :: AgentClient -> NetworkRequestMode -> ADeviceToken -> NotificationsMode -> AE NtfTknStatus registerNtfToken c = withAgentEnv c .:. registerNtfToken' c {-# INLINE registerNtfToken #-} -- | Verify device notifications token -verifyNtfToken :: AgentClient -> NetworkRequestMode -> DeviceToken -> C.CbNonce -> ByteString -> AE () +verifyNtfToken :: AgentClient -> NetworkRequestMode -> ADeviceToken -> C.CbNonce -> ByteString -> AE () verifyNtfToken c = withAgentEnv c .:: verifyNtfToken' c {-# INLINE verifyNtfToken #-} -checkNtfToken :: AgentClient -> NetworkRequestMode -> DeviceToken -> AE NtfTknStatus +checkNtfToken :: AgentClient -> NetworkRequestMode -> ADeviceToken -> AE NtfTknStatus checkNtfToken c = withAgentEnv c .: checkNtfToken' c {-# INLINE checkNtfToken #-} -deleteNtfToken :: AgentClient -> DeviceToken -> AE () +deleteNtfToken :: AgentClient -> ADeviceToken -> AE () deleteNtfToken c = withAgentEnv c . deleteNtfToken' c {-# INLINE deleteNtfToken #-} -getNtfToken :: AgentClient -> AE (DeviceToken, NtfTknStatus, NotificationsMode, NtfServer) +getNtfToken :: AgentClient -> AE (ADeviceToken, NtfTknStatus, NotificationsMode, NtfServer) getNtfToken c = withAgentEnv c $ getNtfToken' c {-# INLINE getNtfToken #-} @@ -2453,7 +2453,7 @@ checkUserServers name srvs = unless (any (\ServerCfg {enabled} -> enabled) srvs) $ logWarn (name <> ": all passed servers are disabled, using all servers.") -registerNtfToken' :: AgentClient -> NetworkRequestMode -> DeviceToken -> NotificationsMode -> AM NtfTknStatus +registerNtfToken' :: AgentClient -> NetworkRequestMode -> ADeviceToken -> NotificationsMode -> AM NtfTknStatus registerNtfToken' c nm suppliedDeviceToken suppliedNtfMode = withStore' c getSavedNtfToken >>= \case Just tkn@NtfToken {deviceToken = savedDeviceToken, ntfTokenId, ntfTknStatus, ntfTknAction, ntfMode = savedNtfMode} -> do @@ -2530,7 +2530,7 @@ registerNtfToken' c nm suppliedDeviceToken suppliedNtfMode = ns <- asks ntfSupervisor atomically $ nsUpdateToken ns tkn {deviceToken = suppliedDeviceToken, ntfTknStatus = NTRegistered, ntfMode = suppliedNtfMode} -verifyNtfToken' :: AgentClient -> NetworkRequestMode -> DeviceToken -> C.CbNonce -> ByteString -> AM () +verifyNtfToken' :: AgentClient -> NetworkRequestMode -> ADeviceToken -> C.CbNonce -> ByteString -> AM () verifyNtfToken' c nm deviceToken nonce code = withStore' c getSavedNtfToken >>= \case Just tkn@NtfToken {deviceToken = savedDeviceToken, ntfTokenId = Just tknId, ntfDhSecret = Just dhSecret, ntfMode} -> do @@ -2549,7 +2549,7 @@ setCronInterval c nm tknId tkn = do cron <- asks $ ntfCron . config void $ forkIO $ void $ runExceptT $ agentNtfSetCronInterval c nm tknId tkn cron -checkNtfToken' :: AgentClient -> NetworkRequestMode -> DeviceToken -> AM NtfTknStatus +checkNtfToken' :: AgentClient -> NetworkRequestMode -> ADeviceToken -> AM NtfTknStatus checkNtfToken' c nm deviceToken = withStore' c getSavedNtfToken >>= \case Just tkn@NtfToken {deviceToken = savedDeviceToken, ntfTokenId = Just tknId, ntfTknAction} -> do @@ -2563,7 +2563,7 @@ checkNtfToken' c nm deviceToken = pure status _ -> throwE $ CMD PROHIBITED "checkNtfToken: no token" -deleteNtfToken' :: AgentClient -> DeviceToken -> AM () +deleteNtfToken' :: AgentClient -> ADeviceToken -> AM () deleteNtfToken' c deviceToken = withStore' c getSavedNtfToken >>= \case Just tkn@NtfToken {deviceToken = savedDeviceToken} -> do @@ -2572,7 +2572,7 @@ deleteNtfToken' c deviceToken = deleteNtfSubs c NSCSmpDelete _ -> throwE $ CMD PROHIBITED "deleteNtfToken: no token" -getNtfToken' :: AgentClient -> AM (DeviceToken, NtfTknStatus, NotificationsMode, NtfServer) +getNtfToken' :: AgentClient -> AM (ADeviceToken, NtfTknStatus, NotificationsMode, NtfServer) getNtfToken' c = withStore' c getSavedNtfToken >>= \case Just NtfToken {deviceToken, ntfTknStatus, ntfMode, ntfServer} -> pure (deviceToken, ntfTknStatus, ntfMode, ntfServer) diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 217a1682a..8b845ffac 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -1322,7 +1322,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 = ADT SAPNS $ 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 @@ -1972,7 +1972,7 @@ agentNtfCheckToken :: AgentClient -> NetworkRequestMode -> NtfTokenId -> NtfToke agentNtfCheckToken c nm tknId NtfToken {ntfServer, ntfPrivKey} = withNtfClient c nm ntfServer tknId "TCHK" $ \ntf -> ntfCheckToken ntf nm ntfPrivKey tknId -agentNtfReplaceToken :: AgentClient -> NetworkRequestMode -> NtfTokenId -> NtfToken -> DeviceToken -> AM () +agentNtfReplaceToken :: AgentClient -> NetworkRequestMode -> NtfTokenId -> NtfToken -> ADeviceToken -> AM () agentNtfReplaceToken c nm tknId NtfToken {ntfServer, ntfPrivKey} token = withNtfClient c nm ntfServer tknId "TRPL" $ \ntf -> ntfReplaceToken ntf nm ntfPrivKey tknId token diff --git a/src/Simplex/Messaging/Agent/Store/AgentStore.hs b/src/Simplex/Messaging/Agent/Store/AgentStore.hs index ef66eca38..dcc118265 100644 --- a/src/Simplex/Messaging/Agent/Store/AgentStore.hs +++ b/src/Simplex/Messaging/Agent/Store/AgentStore.hs @@ -294,7 +294,7 @@ import Simplex.Messaging.Crypto.Ratchet (PQEncryption (..), PQSupport (..), Ratc import qualified Simplex.Messaging.Crypto.Ratchet as CR import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfSubscriptionId, NtfTknStatus (..), NtfTokenId, SMPQueueNtf (..)) +import Simplex.Messaging.Notifications.Protocol (ADeviceToken (..), NtfSubscriptionId, NtfTknStatus (..), NtfTokenId, SMPQueueNtf (..), deviceToken', deviceTokenFields) import Simplex.Messaging.Notifications.Types import Simplex.Messaging.Parsers (parseAll) import Simplex.Messaging.Protocol @@ -1420,7 +1420,8 @@ 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, ntfServer = srv@ProtocolServer {host, port}, ntfTokenId, ntfPubKey, ntfPrivKey, ntfDhKeys = (ntfDhPubKey, ntfDhPrivKey), ntfDhSecret, ntfTknStatus, ntfTknAction, ntfMode} = do + let (provider, token) = deviceTokenFields deviceToken upsertNtfServer_ db srv DB.execute db @@ -1447,10 +1448,12 @@ 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} + deviceToken = deviceToken' provider dt + in NtfToken {deviceToken, 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, ntfServer = ProtocolServer {host, port}} tknId ntfDhSecret = do + let (provider, token) = deviceTokenFields deviceToken updatedAt <- getCurrentTime DB.execute db @@ -1461,9 +1464,11 @@ 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.Connection -> NtfToken -> ADeviceToken -> IO () +updateDeviceToken db NtfToken {deviceToken, ntfServer = ProtocolServer {host, port}} toDt = do + let (provider, token) = deviceTokenFields deviceToken updatedAt <- getCurrentTime + let (toProvider, toToken) = deviceTokenFields toDt DB.execute db [sql| @@ -1474,7 +1479,8 @@ 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, ntfServer = ProtocolServer {host, port}} ntfMode = do + let (provider, token) = deviceTokenFields deviceToken updatedAt <- getCurrentTime DB.execute db @@ -1486,7 +1492,8 @@ 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, ntfServer = ProtocolServer {host, port}} tknStatus tknAction = do + let (provider, token) = deviceTokenFields deviceToken updatedAt <- getCurrentTime DB.execute db @@ -1498,7 +1505,8 @@ 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, ntfServer = ProtocolServer {host, port}} = do + let (provider, token) = deviceTokenFields deviceToken DB.execute db [sql| @@ -1823,7 +1831,8 @@ 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} + deviceToken = deviceToken' provider dt + in NtfToken {deviceToken, 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/Crypto.hs b/src/Simplex/Messaging/Crypto.hs index 9cc78acb3..1fa2c6d4c 100644 --- a/src/Simplex/Messaging/Crypto.hs +++ b/src/Simplex/Messaging/Crypto.hs @@ -128,6 +128,7 @@ module Simplex.Messaging.Crypto encryptAEAD, decryptAEAD, encryptAESNoPad, + encryptAES128NoPad, decryptAESNoPad, authTagSize, randomAesKey, @@ -210,7 +211,7 @@ import Control.Exception (Exception) import Control.Monad import Control.Monad.Except import Control.Monad.Trans.Except -import Crypto.Cipher.AES (AES256) +import Crypto.Cipher.AES (AES256, AES128) import qualified Crypto.Cipher.Types as AES import qualified Crypto.Cipher.XSalsa as XSalsa import qualified Crypto.Error as CE @@ -1039,9 +1040,20 @@ encryptAESNoPad :: Key -> GCMIV -> ByteString -> ExceptT CryptoError IO (AuthTag encryptAESNoPad key iv = encryptAEADNoPad key iv "" {-# INLINE encryptAESNoPad #-} +-- Used to encrypt WebPush notifications +-- This function requires 12 bytes IV, it does not transform IV. +encryptAES128NoPad :: Key -> GCMIV -> ByteString -> ExceptT CryptoError IO (AuthTag, ByteString) +encryptAES128NoPad key iv = encryptAEAD128NoPad key iv "" +{-# INLINE encryptAES128NoPad #-} + encryptAEADNoPad :: Key -> GCMIV -> ByteString -> ByteString -> ExceptT CryptoError IO (AuthTag, ByteString) encryptAEADNoPad aesKey ivBytes ad msg = do - aead <- initAEADGCM aesKey ivBytes + aead <- initAEADGCM @AES256 aesKey ivBytes + pure . first AuthTag $ AES.aeadSimpleEncrypt aead ad msg authTagSize + +encryptAEAD128NoPad :: Key -> GCMIV -> ByteString -> ByteString -> ExceptT CryptoError IO (AuthTag, ByteString) +encryptAEAD128NoPad aesKey ivBytes ad msg = do + aead <- initAEADGCM @AES128 aesKey ivBytes pure . first AuthTag $ AES.aeadSimpleEncrypt aead ad msg authTagSize -- | AEAD-GCM decryption with associated data. @@ -1063,7 +1075,7 @@ decryptAESNoPad key iv = decryptAEADNoPad key iv "" decryptAEADNoPad :: Key -> GCMIV -> ByteString -> ByteString -> AuthTag -> ExceptT CryptoError IO ByteString decryptAEADNoPad aesKey iv ad msg (AuthTag tag) = do - aead <- initAEADGCM aesKey iv + aead <- initAEADGCM @AES256 aesKey iv maybeError AESDecryptError (AES.aeadSimpleDecrypt aead ad msg tag) maxMsgLen :: Int @@ -1138,7 +1150,7 @@ initAEAD (Key aesKey) (IV ivBytes) = do AES.aeadInit AES.AEAD_GCM cipher iv -- this function requires 12 bytes IV, it does not transforms IV. -initAEADGCM :: Key -> GCMIV -> ExceptT CryptoError IO (AES.AEAD AES256) +initAEADGCM :: forall c. AES.BlockCipher c => Key -> GCMIV -> ExceptT CryptoError IO (AES.AEAD c) initAEADGCM (Key aesKey) (GCMIV ivBytes) = cryptoFailable $ do cipher <- AES.cipherInit aesKey AES.aeadInit AES.AEAD_GCM cipher ivBytes diff --git a/src/Simplex/Messaging/Notifications/Client.hs b/src/Simplex/Messaging/Notifications/Client.hs index a5c8f555a..339b8ff4a 100644 --- a/src/Simplex/Messaging/Notifications/Client.hs +++ b/src/Simplex/Messaging/Notifications/Client.hs @@ -43,7 +43,7 @@ ntfCheckToken c nm pKey tknId = NRTkn stat -> pure stat r -> throwE $ unexpectedResponse r -ntfReplaceToken :: NtfClient -> NetworkRequestMode -> C.APrivateAuthKey -> NtfTokenId -> DeviceToken -> ExceptT NtfClientError IO () +ntfReplaceToken :: NtfClient -> NetworkRequestMode -> C.APrivateAuthKey -> NtfTokenId -> ADeviceToken -> ExceptT NtfClientError IO () ntfReplaceToken c nm pKey tknId token = okNtfCommand (TRPL token) c nm pKey tknId ntfDeleteToken :: NtfClient -> NetworkRequestMode -> C.APrivateAuthKey -> NtfTokenId -> ExceptT NtfClientError IO () diff --git a/src/Simplex/Messaging/Notifications/Protocol.hs b/src/Simplex/Messaging/Notifications/Protocol.hs index 0b5889bb7..06f644267 100644 --- a/src/Simplex/Messaging/Notifications/Protocol.hs +++ b/src/Simplex/Messaging/Notifications/Protocol.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -12,6 +13,7 @@ module Simplex.Messaging.Notifications.Protocol where import Control.Applicative (optional, (<|>)) +import qualified Crypto.PubKey.ECC.Types as ECC import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.=)) import qualified Data.Aeson as J import qualified Data.Aeson.Encoding as JE @@ -26,7 +28,7 @@ import Data.Maybe (isNothing) import Data.Text.Encoding (decodeLatin1, encodeUtf8) import Data.Time.Clock.System import Data.Type.Equality -import Data.Word (Word16) +import Data.Word (Word16, Word64) import Simplex.Messaging.Agent.Protocol (updateSMPServerHosts) import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..), fromTextField_) import qualified Simplex.Messaging.Crypto as C @@ -35,6 +37,10 @@ import Simplex.Messaging.Encoding.String import Simplex.Messaging.Notifications.Transport (NTFVersion, invalidReasonNTFVersion, ntfClientHandshake) import Simplex.Messaging.Protocol hiding (Command (..), CommandTag (..)) import Simplex.Messaging.Util (eitherToMaybe, (<$?>)) +import qualified Data.ByteString.Lazy as BL +import qualified Data.Binary as Bin +import qualified Data.Bits as Bits +import Network.HTTP.Client (Request, parseUrlThrow) data NtfEntity = Token | Subscription deriving (Show) @@ -127,7 +133,7 @@ instance ToJSON NtfRegCode where toEncoding = strToJEncoding data NewNtfEntity (e :: NtfEntity) where - NewNtfTkn :: DeviceToken -> NtfPublicAuthKey -> C.PublicKeyX25519 -> NewNtfEntity 'Token + NewNtfTkn :: ADeviceToken -> NtfPublicAuthKey -> C.PublicKeyX25519 -> NewNtfEntity 'Token NewNtfSub :: NtfTokenId -> SMPQueueNtf -> NtfPrivateAuthKey -> NewNtfEntity 'Subscription deriving instance Show (NewNtfEntity e) @@ -172,7 +178,7 @@ data NtfCommand (e :: NtfEntity) where -- | check token status TCHK :: NtfCommand 'Token -- | replace device token (while keeping all existing subscriptions) - TRPL :: DeviceToken -> NtfCommand 'Token + TRPL :: ADeviceToken -> NtfCommand 'Token -- | delete token - all subscriptions will be removed and no more notifications will be sent TDEL :: NtfCommand 'Token -- | enable periodic background notification to fetch the new messages - interval is in minutes, minimum is 20, 0 to disable @@ -372,14 +378,86 @@ instance StrEncoding SMPQueueNtf where notifierId <- A.char '/' *> strP pure SMPQueueNtf {smpServer, notifierId} -data PushProvider +data PushType = APNS | WebPush deriving (Eq, Ord, Show) + +data SPushType (p :: PushType) where + SAPNS :: SPushType 'APNS + SWebPush :: SPushType 'WebPush + +toPushType :: SPushType p -> PushType +toPushType = \case + SAPNS -> APNS + SWebPush -> WebPush + +deriving instance Show (SPushType p) + +class PushTypeI (p :: PushType) where sPushType :: SPushType p + +instance PushTypeI 'APNS where sPushType = SAPNS + +instance PushTypeI 'WebPush where sPushType = SWebPush + +instance TestEquality SPushType where + testEquality SAPNS SAPNS = Just Refl + testEquality SWebPush SWebPush = Just Refl + testEquality _ _ = Nothing + +checkPushType :: forall t p p'. (PushTypeI p, PushTypeI p') => t p' -> Either String (t p) +checkPushType c = case testEquality (sPushType @p) (sPushType @p') of + Just Refl -> Right c + Nothing -> Left "bad push type" + +data PushProvider (p :: PushType) where + PPAPNS :: APNSProvider -> PushProvider 'APNS + PPWP :: WPProvider -> PushProvider 'WebPush + +deriving instance Eq (PushProvider p) + +deriving instance Ord (PushProvider p) + +deriving instance Show (PushProvider p) + +data APushProvider = forall p. PushTypeI p => APP (SPushType p) (PushProvider p) + +instance Eq APushProvider where + APP pt p == APP pt' p' = case testEquality pt pt' of + Just Refl -> p == p' + Nothing -> False + +instance Ord APushProvider where + APP pt t `compare` APP pt' t' = case testEquality pt pt' of + Just Refl -> t `compare` t' + Nothing -> toPushType pt `compare` toPushType pt' + +deriving instance Show APushProvider + +data APNSProvider = PPApnsDev -- provider for Apple development environment | PPApnsProd -- production environment, including TestFlight | PPApnsTest -- used for tests, to use APNS mock server | PPApnsNull -- used to test servers from the client - does not communicate with APNS deriving (Eq, Ord, Show) -instance Encoding PushProvider where +newtype WPSrvLoc = WPSrvLoc SrvLoc + deriving (Eq, Ord, Show) + +newtype WPProvider = WPP WPSrvLoc + deriving (Eq, Ord, Show) + +instance PushTypeI p => Encoding (PushProvider p) where + smpEncode = \case + PPAPNS p -> smpEncode p + PPWP p -> smpEncode p + smpP = (\(APP _ p) -> checkPushType p) <$?> smpP + +instance Encoding APushProvider where + smpEncode (APP _ p) = smpEncode p + smpP = + A.peekChar' >>= \case + 'A' -> APP SAPNS . PPAPNS <$> smpP + _ -> APP SWebPush . PPWP <$> smpP + +instance Encoding APNSProvider where smpEncode = \case PPApnsDev -> "AD" PPApnsProd -> "AP" @@ -391,9 +469,22 @@ instance Encoding PushProvider where "AP" -> pure PPApnsProd "AT" -> pure PPApnsTest "AN" -> pure PPApnsNull - _ -> fail "bad PushProvider" + _ -> fail "bad APNSProvider" + +instance PushTypeI p => StrEncoding (PushProvider p) where + strEncode = \case + PPAPNS p -> strEncode p + PPWP p -> strEncode p + strP = (\(APP _ p) -> checkPushType p) <$?> strP + +instance StrEncoding APushProvider where + strEncode (APP _ p) = strEncode p + strP = + A.peekChar' >>= \case + 'a' -> APP SAPNS . PPAPNS <$> strP + _ -> APP SWebPush . PPWP <$> strP -instance StrEncoding PushProvider where +instance StrEncoding APNSProvider where strEncode = \case PPApnsDev -> "apns_dev" PPApnsProd -> "apns_prod" @@ -405,38 +496,251 @@ instance StrEncoding PushProvider where "apns_prod" -> pure PPApnsProd "apns_test" -> pure PPApnsTest "apns_null" -> pure PPApnsNull - _ -> fail "bad PushProvider" + _ -> fail "bad APNSProvider" + +instance Encoding WPSrvLoc where + smpEncode (WPSrvLoc srv) = smpEncode srv + smpP = WPSrvLoc <$> smpP + +instance StrEncoding WPSrvLoc where + strEncode (WPSrvLoc srv) = "https://" <> strEncode srv + strP = WPSrvLoc <$> ("https://" *> strP) + +instance Encoding WPProvider where + smpEncode (WPP srv) = "WP" <> smpEncode srv + smpP = WPP <$> ("WP" *> smpP) -instance FromField PushProvider where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8 +instance StrEncoding WPProvider where + strEncode (WPP srv) = "webpush " <> strEncode srv + strP = WPP <$> ("webpush " *> strP) -instance ToField PushProvider where toField = toField . decodeLatin1 . strEncode +instance FromField APushProvider where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8 -data DeviceToken = DeviceToken PushProvider ByteString +instance ToField APushProvider where toField = toField . decodeLatin1 . strEncode + +newtype WPAuth = WPAuth {unWPAuth :: ByteString} deriving (Eq, Ord, Show) + +toWPAuth :: ByteString -> Either String WPAuth +toWPAuth s + | B.length s == 16 = Right $ WPAuth s + | otherwise = Left "bad WPAuth" + +newtype WPP256dh = WPP256dh ECC.PublicPoint + deriving (Eq, Show) + +-- This Ord instance for ECC point is quite arbitrary, it is needed because token is used as Map key +instance Ord WPP256dh where + compare (WPP256dh p1) (WPP256dh p2) = case (p1, p2) of + (ECC.PointO, ECC.PointO) -> EQ + (ECC.PointO, _) -> GT + (_, ECC.PointO) -> LT + (ECC.Point x1 y1, ECC.Point x2 y2) -> compare (x1, y1) (x2, y2) + +data WPKey = WPKey + { wpAuth :: WPAuth, + wpP256dh :: WPP256dh + } + deriving (Eq, Ord, Show) + +-- | Elliptic-Curve-Point-to-Octet-String Conversion without compression +-- | as required by RFC8291 +-- | https://www.secg.org/sec1-v2.pdf#subsubsection.2.3.3 +uncompressEncodePoint :: ECC.Point -> ByteString +uncompressEncodePoint (ECC.Point x y) = "\x04" <> encodeBigInt x <> encodeBigInt y +uncompressEncodePoint ECC.PointO = "\0" + +uncompressDecodePoint :: ByteString -> Either String ECC.Point +uncompressDecodePoint "\0" = pure ECC.PointO +uncompressDecodePoint s + | B.null s = Left "KeySizeInvalid" + | B.head s /= '\x04' = Left "PointFormatUnsupported" + | B.length s /= 65 = Left "KeySizeInvalid" + | otherwise = do + let s' = B.drop 1 s + x <- decodeBigInt $ B.take 32 s' + y <- decodeBigInt $ B.drop 32 s' + pure $ ECC.Point x y + +-- Used to test encryption against the RFC8291 Example - which gives the AS private key +uncompressDecodePrivateNumber :: ByteString -> Either String ECC.PrivateNumber +uncompressDecodePrivateNumber s + | B.length s /= 32 = Left "KeySizeInvalid" + | otherwise = decodeBigInt s + +uncompressEncode :: WPP256dh -> ByteString +uncompressEncode (WPP256dh p) = uncompressEncodePoint p + +uncompressDecode :: ByteString -> Either String WPP256dh +uncompressDecode bs = WPP256dh <$> uncompressDecodePoint bs + +encodeBigInt :: Integer -> ByteString +encodeBigInt i = + let s1 = Bits.shiftR i 64 + s2 = Bits.shiftR s1 64 + s3 = Bits.shiftR s2 64 + in BL.toStrict $ Bin.encode (w64 s3, w64 s2, w64 s1, w64 i) + where + w64 :: Integer -> Word64 + w64 = fromIntegral + +decodeBigInt :: ByteString -> Either String Integer +decodeBigInt s + | B.length s /= 32 = Left "PointSizeInvalid" + | otherwise = do + let (w3, w2, w1, w0) = Bin.decode (BL.fromStrict s) :: (Word64, Word64, Word64, Word64) + in Right $ shift 3 w3 + shift 2 w2 + shift 1 w1 + fromIntegral w0 + where + shift i w = Bits.shiftL (fromIntegral w) (64 * i) + +data WPTokenParams = WPTokenParams + { wpPath :: ByteString, + wpKey :: WPKey + } deriving (Eq, Ord, Show) -instance Encoding DeviceToken where - smpEncode (DeviceToken p t) = smpEncode (p, t) - smpP = DeviceToken <$> smpP <*> smpP +instance Encoding WPAuth where + smpEncode = smpEncode . unWPAuth + smpP = toWPAuth <$?> smpP -instance StrEncoding DeviceToken where - strEncode (DeviceToken p t) = strEncode p <> " " <> t - strP = nullToken <|> hexToken +instance StrEncoding WPAuth where + strEncode = strEncode . unWPAuth + strP = toWPAuth <$?> strP + +instance Encoding WPP256dh where + smpEncode p = smpEncode $ uncompressEncode p + smpP = uncompressDecode <$?> smpP + +instance StrEncoding WPP256dh where + strEncode p = strEncode $ uncompressEncode p + strP = uncompressDecode <$?> strP + +instance Encoding WPKey where + smpEncode WPKey {wpAuth, wpP256dh} = smpEncode (wpAuth, wpP256dh) + smpP = do + wpAuth <- smpP + wpP256dh <- smpP + pure WPKey {wpAuth, wpP256dh} + +instance StrEncoding WPKey where + strEncode WPKey {wpAuth, wpP256dh} = strEncode (wpAuth, wpP256dh) + strP = do + (wpAuth, wpP256dh) <- strP + pure WPKey {wpAuth, wpP256dh} + +instance Encoding WPTokenParams where + smpEncode WPTokenParams {wpPath, wpKey} = smpEncode (wpPath, wpKey) + smpP = do + wpPath <- smpP + wpKey <- smpP + pure WPTokenParams {wpPath, wpKey} + +instance StrEncoding WPTokenParams where + strEncode WPTokenParams {wpPath, wpKey} = wpPath <> " " <> strEncode wpKey + strP = do + wpPath <- A.takeWhile (/= ' ') + _ <- A.char ' ' + wpKey <- strP + pure WPTokenParams {wpPath, wpKey} + +data DeviceToken (p :: PushType) where + APNSDeviceToken :: APNSProvider -> ByteString -> DeviceToken 'APNS + WPDeviceToken :: WPProvider -> WPTokenParams -> DeviceToken 'WebPush + +deriving instance Eq (DeviceToken p) + +deriving instance Ord (DeviceToken p) + +deriving instance Show (DeviceToken p) + +data ADeviceToken = forall p. PushTypeI p => ADT (SPushType p) (DeviceToken p) + +instance Eq ADeviceToken where + ADT p t == ADT p' t' = case testEquality p p' of + Just Refl -> t == t' + Nothing -> False + +instance Ord ADeviceToken where + ADT p t `compare` ADT p' t' = case testEquality p p' of + Just Refl -> t `compare` t' + Nothing -> toPushType p `compare` toPushType p' + +deriving instance Show ADeviceToken + +tokenPushProvider :: DeviceToken p -> PushProvider p +tokenPushProvider = \case + APNSDeviceToken p _ -> PPAPNS p + WPDeviceToken p _ -> PPWP p + +instance PushTypeI p => Encoding (DeviceToken p) where + smpEncode = \case + APNSDeviceToken p t -> smpEncode (p, t) + WPDeviceToken p t -> smpEncode (p, t) + smpP = (\(ADT _ t) -> checkPushType t) <$?> smpP + +instance Encoding ADeviceToken where + smpEncode (ADT _ t) = smpEncode t + smpP = + smpP >>= \case + APP _ (PPAPNS p) -> ADT SAPNS . APNSDeviceToken p <$> smpP + APP _ (PPWP p) -> ADT SWebPush . WPDeviceToken p <$> smpP + +instance PushTypeI p => StrEncoding (DeviceToken p) where + strEncode token = case token of + APNSDeviceToken p t -> strEncode p <> " " <> t + -- We don't do strEncode (p, t), because we don't want any space between + -- p (e.g. webpush https://localhost) and t.wpPath (e.g /random) + WPDeviceToken p t -> strEncode p <> strEncode t + strP = (\(ADT _ t) -> checkPushType t) <$?> strP + +instance StrEncoding ADeviceToken where + strEncode (ADT _ t) = strEncode t + strP = nullToken <|> deviceToken where - nullToken = "apns_null test_ntf_token" $> DeviceToken PPApnsNull "test_ntf_token" - hexToken = DeviceToken <$> strP <* A.space <*> hexStringP - hexStringP = + nullToken = "apns_null test_ntf_token" $> ADT SAPNS (APNSDeviceToken PPApnsNull "test_ntf_token") + deviceToken :: A.Parser ADeviceToken + deviceToken = + strP >>= \case + APP _ (PPAPNS p) -> ADT SAPNS . APNSDeviceToken p <$> hexStringP + APP _ (PPWP p) -> do + t <- WPDeviceToken p <$> strP + _ <- wpRequest t + pure $ ADT SWebPush t + hexStringP = do + _ <- A.space 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] - -instance FromJSON DeviceToken where - parseJSON = J.withObject "DeviceToken" $ \o -> do - pp <- strDecode . encodeUtf8 <$?> o .: "pushProvider" - t <- encodeUtf8 <$> o .: "token" - pure $ DeviceToken pp t +instance ToJSON (DeviceToken 'APNS) where + toEncoding = \case + APNSDeviceToken p t -> J.pairs $ "pushProvider" .= decodeLatin1 (strEncode p) <> "token" .= decodeLatin1 t + toJSON = \case + APNSDeviceToken p t -> J.object ["pushProvider" .= decodeLatin1 (strEncode p), "token" .= decodeLatin1 t] + +instance FromJSON (DeviceToken 'APNS) where + parseJSON = J.withObject "DeviceToken" $ \o -> + (strDecode @(PushProvider 'APNS) . encodeUtf8 <$?> o .: "pushProvider") >>= \case + PPAPNS p -> APNSDeviceToken p . encodeUtf8 <$> (o .: "token") + +-- | Returns fields for the device token (pushProvider, token) +-- TODO [webpush] save token as separate fields +deviceTokenFields :: ADeviceToken -> (APushProvider, ByteString) +deviceTokenFields = \case + ADT _ (APNSDeviceToken p t) -> (APP SAPNS (PPAPNS p), t) + ADT _ (WPDeviceToken p t) -> (APP SWebPush (PPWP p), strEncode t) + +-- | Returns the device token from the fields (pushProvider, token) +-- TODO [webpush] read token as separate fields, don't use `error` +deviceToken' :: APushProvider -> ByteString -> ADeviceToken +deviceToken' pp t = case pp of + APP _ (PPAPNS p) -> ADT SAPNS $ APNSDeviceToken p t + APP _ (PPWP p) -> ADT SWebPush . WPDeviceToken p <$> either error id $ strDecode t + +wpRequest :: MonadFail m => DeviceToken 'WebPush -> m Request +wpRequest (WPDeviceToken (WPP s) params) = do + let endpoint = strEncode s <> wpPath params + case parseUrlThrow $ B.unpack endpoint of + Left _ -> fail "Invalid URL" + Right r -> pure r -- 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 7e8acac81..2ca59e863 100644 --- a/src/Simplex/Messaging/Notifications/Server.hs +++ b/src/Simplex/Messaging/Notifications/Server.hs @@ -629,18 +629,18 @@ 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) - liftIO $ logDebug $ "sending push notification to " <> T.pack (show pp) + (srvHost_, tkn@NtfTknRec {ntfTknId, token = t@(ADT _ token), tknStatus}, ntf) <- atomically (readTBQueue pushQ) + logDebug $ "sending push notification to " <> tshow (tokenPushProvider token) st <- asks store case ntf of PNVerification _ -> - liftIO (deliverNotification st pp tkn ntf) >>= \case + liftIO (deliverNotification st tkn token ntf) >>= \case Right _ -> do void $ liftIO $ setTknStatusConfirmed st tkn incNtfStatT t ntfVrfDelivered Left _ -> incNtfStatT t ntfVrfFailed PNCheckMessages -> do - liftIO (deliverNotification st pp tkn ntf) >>= \case + liftIO (deliverNotification st tkn token ntf) >>= \case Right _ -> do void $ liftIO $ updateTokenCronSentAt st ntfTknId . systemSeconds =<< getSystemTime incNtfStatT t ntfCronDelivered @@ -648,7 +648,7 @@ ntfPush s@NtfPushServer {pushQ} = forever $ do PNMessage {} -> checkActiveTkn tknStatus $ do stats <- asks serverStats liftIO $ updatePeriodStats (activeTokens stats) ntfTknId - liftIO (deliverNotification st pp tkn ntf) >>= \case + liftIO (deliverNotification st tkn token ntf) >>= \case Left _ -> do incNtfStatT t ntfFailed liftIO $ mapM_ (`incServerStat` ntfFailedOwn stats) srvHost_ @@ -661,10 +661,10 @@ ntfPush s@NtfPushServer {pushQ} = forever $ do checkActiveTkn status action | status == NTActive = action | otherwise = liftIO $ logError "bad notification token status" - deliverNotification :: NtfPostgresStore -> PushProvider -> NtfTknRec -> PushNotification -> IO (Either PushProviderError ()) - deliverNotification st pp tkn@NtfTknRec {ntfTknId} ntf = do + deliverNotification :: NtfPostgresStore -> NtfTknRec -> DeviceToken p -> PushNotification -> IO (Either PushProviderError ()) + deliverNotification st tkn@NtfTknRec {ntfTknId} token ntf = do deliver <- getPushClient s pp - runExceptT (deliver tkn ntf) >>= \case + runExceptT (deliver tkn token ntf) >>= \case Right _ -> pure $ Right () Left e -> case e of PPConnection _ -> retryDeliver @@ -675,11 +675,13 @@ ntfPush s@NtfPushServer {pushQ} = forever $ do void $ updateTknStatus st tkn $ NTInvalid $ Just r err e PPPermanentError -> err e + _ -> err e where + pp = tokenPushProvider token retryDeliver :: IO (Either PushProviderError ()) retryDeliver = do deliver <- newPushClient s pp - runExceptT (deliver tkn ntf) >>= \case + runExceptT (deliver tkn token ntf) >>= \case Right _ -> pure $ Right () Left e -> case e of PPTokenInvalid r -> do @@ -904,8 +906,9 @@ withNtfStore stAction continue = do Left e -> pure $ NRErr e Right a -> continue a -incNtfStatT :: DeviceToken -> (NtfServerStats -> IORef Int) -> M () -incNtfStatT (DeviceToken PPApnsNull _) _ = pure () +-- TODO [webpush] track webpush statistics separately +incNtfStatT :: ADeviceToken -> (NtfServerStats -> IORef Int) -> M () +incNtfStatT (ADT _ (APNSDeviceToken PPApnsNull _)) _ = pure () incNtfStatT _ statSel = incNtfStat statSel {-# INLINE incNtfStatT #-} diff --git a/src/Simplex/Messaging/Notifications/Server/Env.hs b/src/Simplex/Messaging/Notifications/Server/Env.hs index 7ed258b9a..44a8be4af 100644 --- a/src/Simplex/Messaging/Notifications/Server/Env.hs +++ b/src/Simplex/Messaging/Notifications/Server/Env.hs @@ -25,6 +25,7 @@ import Simplex.Messaging.Client (ProtocolClientConfig (..)) import Simplex.Messaging.Client.Agent 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 import Simplex.Messaging.Notifications.Server.Stats import Simplex.Messaging.Notifications.Server.Store (newNtfSTMStore) @@ -45,7 +46,9 @@ 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) +import Simplex.Messaging.Notifications.Server.Push.WebPush (wpPushProviderClient) +import Network.HTTP.Client (newManager, ManagerSettings (..), Request (..), Manager) +import Network.HTTP.Client.TLS (tlsManagerSettings) data NtfServerConfig = NtfServerConfig { transports :: [(ServiceName, ASrvTransport, AddHTTP)], @@ -149,27 +152,52 @@ data SMPSubscriber = SMPSubscriber data NtfPushServer = NtfPushServer { pushQ :: TBQueue (Maybe T.Text, NtfTknRec, PushNotification), -- Maybe Text is a hostname of "own" server - pushClients :: TMap PushProvider PushProviderClient, + apnsPushClients :: TMap APNSProvider (PushProviderClient 'APNS), + webPushClients :: TMap WPProvider (PushProviderClient 'WebPush), apnsConfig :: APNSPushClientConfig } newNtfPushServer :: Natural -> APNSPushClientConfig -> IO NtfPushServer newNtfPushServer qSize apnsConfig = do pushQ <- newTBQueueIO qSize - pushClients <- TM.emptyIO - pure NtfPushServer {pushQ, pushClients, apnsConfig} - -newPushClient :: NtfPushServer -> PushProvider -> IO PushProviderClient -newPushClient NtfPushServer {apnsConfig, pushClients} pp = do - c <- case apnsProviderHost pp of - Nothing -> pure $ \_ _ -> pure () - Just host -> apnsPushProviderClient <$> createAPNSPushClient host apnsConfig - atomically $ TM.insert pp c pushClients + apnsPushClients <- TM.emptyIO + webPushClients <- TM.emptyIO + pure NtfPushServer {pushQ, apnsPushClients, webPushClients, apnsConfig} + +newPushClient :: NtfPushServer -> PushProvider p -> IO (PushProviderClient p) +newPushClient s = \case + PPWP p -> newWPPushClient s p + PPAPNS p -> newAPNSPushClient s p + +newAPNSPushClient :: NtfPushServer -> APNSProvider -> IO (PushProviderClient 'APNS) +newAPNSPushClient NtfPushServer {apnsConfig, apnsPushClients} pp = case apnsProviderHost pp of + Nothing -> pure $ \_ _ _ -> pure () + Just host -> do + c <- apnsPushProviderClient <$> createAPNSPushClient host apnsConfig + atomically $ TM.insert pp c apnsPushClients + pure c + +newWPPushClient :: NtfPushServer -> WPProvider -> IO (PushProviderClient 'WebPush) +newWPPushClient NtfPushServer {webPushClients} pp = do + logDebug "New WP Client requested" + -- We use one http manager per push server (which may be used by different clients) + c <- wpPushProviderClient <$> wpHTTPManager + atomically $ TM.insert pp c webPushClients pure c -getPushClient :: NtfPushServer -> PushProvider -> IO PushProviderClient -getPushClient s@NtfPushServer {pushClients} pp = - TM.lookupIO pp pushClients >>= maybe (newPushClient s pp) pure +wpHTTPManager :: IO Manager +wpHTTPManager = newManager tlsManagerSettings { + -- Ideally, we should be able to override the domain resolution to + -- disable requests to non-public IPs. The risk is very limited as + -- we allow https only, and the body is encrypted. Disabling redirections + -- avoids cross-protocol redir (https => http/unix) + managerModifyRequest = \r -> pure r {redirectCount = 0} + } + +getPushClient :: NtfPushServer -> PushProvider p -> IO (PushProviderClient p) +getPushClient s = \case + PPAPNS p -> TM.lookupIO p (apnsPushClients s) >>= maybe (newAPNSPushClient s p) pure + PPWP p -> TM.lookupIO p (webPushClients s) >>= maybe (newWPPushClient s p) pure data NtfRequest = NtfReqNew CorrId ANewNtfEntity diff --git a/src/Simplex/Messaging/Notifications/Server/Push.hs b/src/Simplex/Messaging/Notifications/Server/Push.hs index edb671212..48fee76f0 100644 --- a/src/Simplex/Messaging/Notifications/Server/Push.hs +++ b/src/Simplex/Messaging/Notifications/Server/Push.hs @@ -93,6 +93,10 @@ data PushProviderError | PPTokenInvalid NTInvalidReason | PPRetryLater | PPPermanentError + | PPWPInvalidUrl + | PPWPRemovedEndpoint + | PPWPRequestTooLong + | PPWPOtherError Text deriving (Show, Exception) -type PushProviderClient = NtfTknRec -> PushNotification -> ExceptT PushProviderError IO () +type PushProviderClient p = NtfTknRec -> DeviceToken p -> 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 2337fa7fd..f25f977f5 100644 --- a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs +++ b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -124,7 +126,7 @@ data APNSPushClientConfig = APNSPushClientConfig caStoreFile :: FilePath } -apnsProviderHost :: PushProvider -> Maybe HostName +apnsProviderHost :: APNSProvider -> Maybe HostName apnsProviderHost = \case PPApnsNull -> Nothing PPApnsTest -> Just "localhost" @@ -255,8 +257,8 @@ 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 :: APNSPushClient -> PushProviderClient 'APNS +apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn (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/Push/WebPush.hs b/src/Simplex/Messaging/Notifications/Server/Push/WebPush.hs new file mode 100644 index 000000000..f756a0e14 --- /dev/null +++ b/src/Simplex/Messaging/Notifications/Server/Push/WebPush.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Use newtype instead of data" #-} + +module Simplex.Messaging.Notifications.Server.Push.WebPush where + +import Control.Exception (SomeException, fromException, try) +import Control.Logger.Simple (logDebug) +import Control.Monad +import Control.Monad.Except +import Control.Monad.IO.Class (liftIO) +import Crypto.Hash.Algorithms (SHA256) +import qualified Crypto.MAC.HMAC as HMAC +import qualified Crypto.PubKey.ECC.DH as ECDH +import qualified Crypto.PubKey.ECC.Types as ECC +import Crypto.Random (MonadRandom(getRandomBytes)) +import Data.Aeson ((.=)) +import qualified Data.Aeson as J +import qualified Data.Binary as Bin +import qualified Data.ByteArray as BA +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy as BL +import Network.HTTP.Client +import qualified Network.HTTP.Types as N +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), PushType (..), WPAuth (..), WPKey (..), WPTokenParams (..), WPP256dh (..), uncompressEncodePoint, wpRequest) +import Simplex.Messaging.Notifications.Server.Push +import Simplex.Messaging.Util (liftError', tshow) + +wpPushProviderClient :: Manager -> PushProviderClient 'WebPush +wpPushProviderClient mg _ t@(WPDeviceToken _ params) pn = do + -- TODO [webpush] this function should accept type that is restricted to WP token (so, possibly WPProvider and WPTokenParams) + -- parsing will happen in DeviceToken parser, so it won't fail here + r <- wpRequest t + logDebug $ "Web Push request to " <> tshow (host r) + encBody <- withExceptT PPCryptoError $ wpEncrypt (wpKey params) (BL.toStrict $ encodeWPN pn) + let requestHeaders = + [ ("TTL", "2592000"), -- 30 days + ("Urgency", "high"), + ("Content-Encoding", "aes128gcm") + -- TODO: topic for pings and interval + ] + req = + r + { method = "POST", + requestHeaders, + requestBody = RequestBodyBS encBody, + redirectCount = 0 + } + void $ liftError' toPPWPError $ try $ httpNoBody req mg + +-- | encrypt :: UA key -> clear -> cipher +-- | https://www.rfc-editor.org/rfc/rfc8291#section-3.4 +wpEncrypt :: WPKey -> ByteString -> ExceptT C.CryptoError IO ByteString +wpEncrypt wpKey clearT = do + salt :: ByteString <- liftIO $ getRandomBytes 16 + asPrivK <- liftIO $ ECDH.generatePrivate $ ECC.getCurveByName ECC.SEC_p256r1 + wpEncrypt' wpKey asPrivK salt clearT + +-- | encrypt :: UA key -> AS key -> salt -> clear -> cipher +-- | https://www.rfc-editor.org/rfc/rfc8291#section-3.4 +wpEncrypt' :: WPKey -> ECC.PrivateNumber -> ByteString -> ByteString -> ExceptT C.CryptoError IO ByteString +wpEncrypt' WPKey {wpAuth, wpP256dh = WPP256dh uaPubK} asPrivK salt clearT = do + let uaPubKS = uncompressEncodePoint $ uaPubK + let asPubKS = uncompressEncodePoint . ECDH.calculatePublic (ECC.getCurveByName ECC.SEC_p256r1) $ asPrivK + ecdhSecret = ECDH.getShared (ECC.getCurveByName ECC.SEC_p256r1) asPrivK uaPubK + prkKey = hmac (unWPAuth wpAuth) ecdhSecret + keyInfo = "WebPush: info\0" <> uaPubKS <> asPubKS + ikm = hmac prkKey (keyInfo <> "\x01") + prk = hmac salt ikm + cekInfo = "Content-Encoding: aes128gcm\0" :: ByteString + cek = B.take 16 $ BA.convert $ hmac prk (cekInfo <> "\x01") + nonceInfo = "Content-Encoding: nonce\0" :: ByteString + nonce = B.take 12 $ BA.convert $ hmac prk (nonceInfo <> "\x01") + rs = BL.toStrict $ Bin.encode (4096 :: Bin.Word32) -- with RFC8291, it's ok to always use 4096 because there is only one single record and the final record can be smaller than rs (RFC8188) + idlen = BL.toStrict $ Bin.encode (65 :: Bin.Word8) -- with RFC8291, keyid is the pubkey, so always 65 bytes + header = salt <> rs <> idlen <> asPubKS + iv <- ivFrom nonce + -- The last record uses a padding delimiter octet set to the value 0x02 + (C.AuthTag tag, cipherT) <- C.encryptAES128NoPad (C.Key cek) iv $ clearT <> "\x02" + -- Uncomment to see intermediate values, to compare with RFC8291 example + -- liftIO . print $ strEncode (BA.convert ecdhSecret :: ByteString) + -- liftIO . print . strEncode $ takeHM 32 prkKey + -- liftIO . print $ strEncode cek + -- liftIO . print $ strEncode cipherT + pure $ header <> cipherT <> BA.convert tag + where + hmac k v = HMAC.hmac k v :: HMAC.HMAC SHA256 + ivFrom :: ByteString -> ExceptT C.CryptoError IO C.GCMIV + ivFrom s = liftEither $ C.gcmIV s + +encodeWPN :: PushNotification -> BL.ByteString +encodeWPN pn = J.encode $ case pn of + PNVerification code -> J.object ["verification" .= code] + -- This hack prevents sending unencrypted message metadata in notifications, as we do not use it in the client - it simply receives all messages on each notification. + -- If we decide to change it to pull model as used in iOS, we can change JSON key to "message" with any payload, as the current clients would interpret it as "checkMessages". + -- In this case an additional encryption layer would need to be added here, in the same way as with APNS notifications. + PNMessage _ -> J.object ["checkMessages" .= True] + PNCheckMessages -> J.object ["checkMessages" .= True] + +toPPWPError :: SomeException -> PushProviderError +toPPWPError e = case fromException e of + Just (InvalidUrlException _ _) -> PPWPInvalidUrl + Just (HttpExceptionRequest _ (StatusCodeException resp _)) -> fromStatusCode (responseStatus resp) ("" :: String) + _ -> PPWPOtherError $ tshow e + where + fromStatusCode status reason + | status == N.status200 = PPWPRemovedEndpoint + | status == N.status410 = PPWPRemovedEndpoint + | status == N.status413 = PPWPRequestTooLong + | status == N.status429 = PPRetryLater + | status >= N.status500 = PPRetryLater + | otherwise = PPResponseError (Just status) (tshow reason) diff --git a/src/Simplex/Messaging/Notifications/Server/Store.hs b/src/Simplex/Messaging/Notifications/Server/Store.hs index cb22af000..14d67350f 100644 --- a/src/Simplex/Messaging/Notifications/Server/Store.hs +++ b/src/Simplex/Messaging/Notifications/Server/Store.hs @@ -33,7 +33,7 @@ import Simplex.Messaging.Util (whenM, ($>>=)) data NtfSTMStore = NtfSTMStore { tokens :: TMap NtfTokenId NtfTknData, -- multiple registrations exist to protect from malicious registrations if token is compromised - tokenRegistrations :: TMap DeviceToken (TMap ByteString NtfTokenId), + tokenRegistrations :: TMap ADeviceToken (TMap ByteString NtfTokenId), subscriptions :: TMap NtfSubscriptionId NtfSubData, tokenSubscriptions :: TMap NtfTokenId (TVar (Set NtfSubscriptionId)), subscriptionLookup :: TMap SMPQueueNtf NtfSubscriptionId, @@ -54,7 +54,7 @@ newNtfSTMStore = do data NtfTknData = NtfTknData { ntfTknId :: NtfTokenId, - token :: DeviceToken, + token :: ADeviceToken, tknStatus :: TVar NtfTknStatus, tknVerifyKey :: NtfPublicAuthKey, tknDhKeys :: C.KeyPairX25519, diff --git a/src/Simplex/Messaging/Notifications/Server/Store/Migrations.hs b/src/Simplex/Messaging/Notifications/Server/Store/Migrations.hs index 6a53ff4a2..b07efa101 100644 --- a/src/Simplex/Messaging/Notifications/Server/Store/Migrations.hs +++ b/src/Simplex/Messaging/Notifications/Server/Store/Migrations.hs @@ -12,7 +12,8 @@ import Text.RawString.QQ (r) ntfServerSchemaMigrations :: [(String, Text, Maybe Text)] ntfServerSchemaMigrations = [ ("20250417_initial", m20250417_initial, Nothing), - ("20250517_service_cert", m20250517_service_cert, Just down_m20250517_service_cert) + ("20250517_service_cert", m20250517_service_cert, Just down_m20250517_service_cert), + ("20250916_webpush", m20250916_webpush, Just down_m20250916_webpush) ] -- | The list of migrations in ascending order by date @@ -78,7 +79,7 @@ CREATE INDEX idx_last_notifications_token_id_sent_at ON last_notifications(token CREATE INDEX idx_last_notifications_subscription_id ON last_notifications(subscription_id); CREATE UNIQUE INDEX idx_last_notifications_token_subscription ON last_notifications(token_id, subscription_id); - |] + |] m20250517_service_cert :: Text m20250517_service_cert = @@ -89,7 +90,7 @@ ALTER TABLE subscriptions ADD COLUMN ntf_service_assoc BOOLEAN NOT NULL DEFAULT DROP INDEX idx_subscriptions_smp_server_id_status; CREATE INDEX idx_subscriptions_smp_server_id_ntf_service_status ON subscriptions(smp_server_id, ntf_service_assoc, status); - |] + |] down_m20250517_service_cert :: Text down_m20250517_service_cert = @@ -100,4 +101,33 @@ CREATE INDEX idx_subscriptions_smp_server_id_status ON subscriptions(smp_server_ ALTER TABLE smp_servers DROP COLUMN ntf_service_id; ALTER TABLE subscriptions DROP COLUMN ntf_service_assoc; - |] + |] + +m20250916_webpush :: Text +m20250916_webpush = + [r| +CREATE TABLE webpush_servers( + wp_server_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY, + wp_host TEXT NOT NULL, + wp_port TEXT NOT NULL, + wp_keyhash BYTEA NOT NULL +); + +ALTER TABLE tokens + ADD COLUMN wp_server_id BIGINT REFERENCES webpush_servers ON DELETE RESTRICT ON UPDATE RESTRICT, + ADD COLUMN wp_path TEXT, + ADD COLUMN wp_auth BYTEA, + ADD COLUMN wp_key BYTEA; + |] + +down_m20250916_webpush :: Text +down_m20250916_webpush = + [r| +ALTER TABLE tokens + DROP COLUMN wp_server_id, + DROP COLUMN wp_path, + DROP COLUMN wp_auth, + DROP COLUMN wp_key; + +DROP TABLE webpush_servers; + |] diff --git a/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs b/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs index 80d946c8b..63d21ff2b 100644 --- a/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs +++ b/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs @@ -128,8 +128,9 @@ 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, tknStatus, tknRegCode = code@(NtfRegCode regCode)} = withFastDB "replaceNtfToken" st $ \db -> runExceptT $ do + let (pp, ppToken) = deviceTokenFields token ExceptT $ assertUpdated <$> DB.execute db @@ -143,7 +144,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 (pp, ppToken) = deviceTokenFields token NtfRegCode regCode = tknRegCode in (ntfTknId, pp, Binary ppToken, tknStatus, tknVerifyKey, tknDhPrivKey, tknDhSecret, Binary regCode, tknCronInterval, tknUpdatedAt) @@ -153,7 +154,8 @@ 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 token tknVerifyKey _) = do + let (pp, ppToken) = deviceTokenFields token 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)) @@ -170,7 +172,7 @@ updateTokenDate st db NtfTknRec {ntfTknId, tknUpdatedAt} = do void $ DB.execute db "UPDATE tokens SET updated_at = ? WHERE token_id = ?" (ts, ntfTknId) withLog "updateTokenDate" st $ \sl -> logUpdateTokenTime sl ntfTknId ts -type NtfTknRow = (NtfTokenId, PushProvider, Binary ByteString, NtfTknStatus, NtfPublicAuthKey, C.PrivateKeyX25519, C.DhSecretX25519, Binary ByteString, Word16, Maybe SystemDate) +type NtfTknRow = (NtfTokenId, APushProvider, Binary ByteString, NtfTknStatus, NtfPublicAuthKey, C.PrivateKeyX25519, C.DhSecretX25519, Binary ByteString, Word16, Maybe SystemDate) ntfTknQuery :: Query ntfTknQuery = @@ -181,7 +183,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 = deviceToken' pp ppToken tknRegCode = NtfRegCode regCode in NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhPrivKey, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt} @@ -376,8 +378,9 @@ 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} = withFastDB' "setTokenActive" st $ \db -> do + let (pp, ppToken) = deviceTokenFields token updateTknStatus_ st db tkn NTActive -- this removes other instances of the same token, e.g. because of repeated token registration attempts tknIds <- diff --git a/src/Simplex/Messaging/Notifications/Server/Store/Types.hs b/src/Simplex/Messaging/Notifications/Server/Store/Types.hs index abac8d14e..9f9e9e7f3 100644 --- a/src/Simplex/Messaging/Notifications/Server/Store/Types.hs +++ b/src/Simplex/Messaging/Notifications/Server/Store/Types.hs @@ -13,14 +13,14 @@ import Data.Maybe (fromMaybe) import Data.Word (Word16) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfRegCode, NtfSubStatus, NtfSubscriptionId, NtfTokenId, NtfTknStatus, SMPQueueNtf) +import Simplex.Messaging.Notifications.Protocol (ADeviceToken, NtfRegCode, NtfSubStatus, NtfSubscriptionId, NtfTokenId, NtfTknStatus, SMPQueueNtf) import Simplex.Messaging.Notifications.Server.Store (NtfSubData (..), NtfTknData (..)) import Simplex.Messaging.Protocol (NotifierId, NtfPrivateAuthKey, NtfPublicAuthKey) import Simplex.Messaging.SystemTime data NtfTknRec = NtfTknRec { ntfTknId :: NtfTokenId, - token :: DeviceToken, + token :: ADeviceToken, tknStatus :: NtfTknStatus, tknVerifyKey :: NtfPublicAuthKey, tknDhPrivKey :: C.PrivateKeyX25519, diff --git a/src/Simplex/Messaging/Notifications/Server/Store/ntf_server_schema.sql b/src/Simplex/Messaging/Notifications/Server/Store/ntf_server_schema.sql index 3b155fa1a..535652b68 100644 --- a/src/Simplex/Messaging/Notifications/Server/Store/ntf_server_schema.sql +++ b/src/Simplex/Messaging/Notifications/Server/Store/ntf_server_schema.sql @@ -92,7 +92,31 @@ CREATE TABLE ntf_server.tokens ( reg_code bytea NOT NULL, cron_interval bigint NOT NULL, cron_sent_at bigint, - updated_at bigint + updated_at bigint, + wp_server_id bigint, + wp_path text, + wp_auth bytea, + wp_key bytea +); + + + +CREATE TABLE ntf_server.webpush_servers ( + wp_server_id bigint NOT NULL, + wp_host text NOT NULL, + wp_port text NOT NULL, + wp_keyhash bytea NOT NULL +); + + + +ALTER TABLE ntf_server.webpush_servers ALTER COLUMN wp_server_id ADD GENERATED ALWAYS AS IDENTITY ( + SEQUENCE NAME ntf_server.webpush_servers_wp_server_id_seq + START WITH 1 + INCREMENT BY 1 + NO MINVALUE + NO MAXVALUE + CACHE 1 ); @@ -122,6 +146,11 @@ ALTER TABLE ONLY ntf_server.tokens +ALTER TABLE ONLY ntf_server.webpush_servers + ADD CONSTRAINT webpush_servers_pkey PRIMARY KEY (wp_server_id); + + + CREATE INDEX idx_last_notifications_subscription_id ON ntf_server.last_notifications USING btree (subscription_id); @@ -178,3 +207,8 @@ ALTER TABLE ONLY ntf_server.subscriptions +ALTER TABLE ONLY ntf_server.tokens + ADD CONSTRAINT tokens_wp_server_id_fkey FOREIGN KEY (wp_server_id) REFERENCES ntf_server.webpush_servers(wp_server_id) ON UPDATE RESTRICT ON DELETE RESTRICT; + + + diff --git a/src/Simplex/Messaging/Notifications/Server/StoreLog.hs b/src/Simplex/Messaging/Notifications/Server/StoreLog.hs index 7c71ddb08..8602f23e1 100644 --- a/src/Simplex/Messaging/Notifications/Server/StoreLog.hs +++ b/src/Simplex/Messaging/Notifications/Server/StoreLog.hs @@ -46,7 +46,7 @@ import System.IO data NtfStoreLogRecord = CreateToken NtfTknRec | TokenStatus NtfTokenId NtfTknStatus - | UpdateToken NtfTokenId DeviceToken NtfRegCode + | UpdateToken NtfTokenId ADeviceToken NtfRegCode | TokenCron NtfTokenId Word16 | DeleteToken NtfTokenId | UpdateTokenTime NtfTokenId SystemDate @@ -94,7 +94,7 @@ logCreateToken s = logNtfStoreRecord s . CreateToken logTokenStatus :: StoreLog 'WriteMode -> NtfTokenId -> NtfTknStatus -> IO () logTokenStatus s tknId tknStatus = logNtfStoreRecord s $ TokenStatus tknId tknStatus -logUpdateToken :: StoreLog 'WriteMode -> NtfTokenId -> DeviceToken -> NtfRegCode -> IO () +logUpdateToken :: StoreLog 'WriteMode -> NtfTokenId -> ADeviceToken -> NtfRegCode -> IO () logUpdateToken s tknId token regCode = logNtfStoreRecord s $ UpdateToken tknId token regCode logTokenCron :: StoreLog 'WriteMode -> NtfTokenId -> Word16 -> IO () diff --git a/src/Simplex/Messaging/Notifications/Types.hs b/src/Simplex/Messaging/Notifications/Types.hs index a7665b5b2..a574ee40a 100644 --- a/src/Simplex/Messaging/Notifications/Types.hs +++ b/src/Simplex/Messaging/Notifications/Types.hs @@ -42,7 +42,7 @@ instance FromField NtfTknAction where fromField = blobFieldDecoder smpDecode instance ToField NtfTknAction where toField = toField . Binary . smpEncode data NtfToken = NtfToken - { deviceToken :: DeviceToken, + { deviceToken :: ADeviceToken, ntfServer :: NtfServer, ntfTokenId :: Maybe NtfTokenId, -- TODO combine keys to key pair as the types should match @@ -63,7 +63,7 @@ data NtfToken = NtfToken } deriving (Show) -newNtfToken :: DeviceToken -> NtfServer -> C.AAuthKeyPair -> C.KeyPairX25519 -> NotificationsMode -> NtfToken +newNtfToken :: ADeviceToken -> NtfServer -> C.AAuthKeyPair -> C.KeyPairX25519 -> NotificationsMode -> NtfToken newNtfToken deviceToken ntfServer (ntfPubKey, ntfPrivKey) ntfDhKeys ntfMode = NtfToken { deviceToken, diff --git a/src/Simplex/Messaging/ServiceScheme.hs b/src/Simplex/Messaging/ServiceScheme.hs index 3cd828aa7..1f9fe22e1 100644 --- a/src/Simplex/Messaging/ServiceScheme.hs +++ b/src/Simplex/Messaging/ServiceScheme.hs @@ -9,6 +9,7 @@ import qualified Data.ByteString.Char8 as B import Data.Functor (($>)) import Network.Socket (HostName, ServiceName) import Simplex.Messaging.Encoding.String (StrEncoding (..)) +import Simplex.Messaging.Encoding (Encoding(..)) data ServiceScheme = SSSimplex | SSAppServer SrvLoc deriving (Eq, Show) @@ -24,6 +25,12 @@ instance StrEncoding ServiceScheme where data SrvLoc = SrvLoc HostName ServiceName deriving (Eq, Ord, Show) +instance Encoding SrvLoc where + smpEncode (SrvLoc h s) = smpEncode (h, s) + smpP = do + (h, s) <- smpP + pure $ SrvLoc h s + instance StrEncoding SrvLoc where strEncode (SrvLoc host port) = B.pack $ host <> if null port then "" else ':' : port strP = SrvLoc <$> host <*> (port <|> pure "") diff --git a/tests/AgentTests/NotificationTests.hs b/tests/AgentTests/NotificationTests.hs index 6a1c5cef9..bce2361b5 100644 --- a/tests/AgentTests/NotificationTests.hs +++ b/tests/AgentTests/NotificationTests.hs @@ -196,13 +196,13 @@ testNtfMatrix ps@(_, msType) runTest = do cfg' = cfgMS msType cfgVPrev' = cfgVPrev msType -registerNtfToken :: AgentClient -> DeviceToken -> NotificationsMode -> AE NtfTknStatus +registerNtfToken :: AgentClient -> ADeviceToken -> NotificationsMode -> AE NtfTknStatus registerNtfToken c = A.registerNtfToken c NRMInteractive -checkNtfToken :: AgentClient -> DeviceToken -> AE NtfTknStatus +checkNtfToken :: AgentClient -> ADeviceToken -> AE NtfTknStatus checkNtfToken c = A.checkNtfToken c NRMInteractive -verifyNtfToken :: AgentClient -> DeviceToken -> C.CbNonce -> ByteString -> AE () +verifyNtfToken :: AgentClient -> ADeviceToken -> C.CbNonce -> ByteString -> AE () verifyNtfToken c = A.verifyNtfToken c NRMInteractive runNtfTestCfg :: HasCallStack => (ASrvTransport, AStoreType) -> AgentMsgId -> AServerConfig -> NtfServerConfig -> AgentConfig -> AgentConfig -> (APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> IO () @@ -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 = ADT SAPNS $ 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 = ADT SAPNS $ 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 = ADT SAPNS $ 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 = ADT SAPNS $ 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 = ADT SAPNS $ 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 = ADT SAPNS $ 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 @@ -355,7 +355,7 @@ testNtfTokenServerRestartReverifyTimeout t apns = do SET tkn_status = ?, tkn_action = ? WHERE provider = ? AND device_token = ? |] - (NTConfirmed, Just (NTAVerify code), PPApnsTest, "abcd" :: ByteString) + (NTConfirmed, Just (NTAVerify code), APP SAPNS (PPAPNS PPApnsTest), "abcd" :: ByteString) Just NtfToken {ntfTknStatus = NTConfirmed, ntfTknAction = Just (NTAVerify _)} <- withTransaction store getSavedNtfToken pure () threadDelay 1500000 @@ -369,7 +369,7 @@ testNtfTokenServerRestartReverifyTimeout t apns = do testNtfTokenServerRestartReregister :: ASrvTransport -> APNSMockServer -> IO () testNtfTokenServerRestartReregister t apns = do - let tkn = DeviceToken PPApnsTest "abcd" + let tkn = ADT SAPNS $ 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 = ADT SAPNS $ APNSDeviceToken PPApnsTest "abcd" withAgent 1 agentCfg initAgentServers testDB $ \a@AgentClient {agentEnv = Env {store}} -> do withNtfServer t $ runRight $ do NTRegistered <- registerNtfToken a tkn NMPeriodic @@ -409,7 +409,7 @@ testNtfTokenServerRestartReregisterTimeout t apns = do SET tkn_id = NULL, tkn_dh_secret = NULL, tkn_status = ?, tkn_action = ? WHERE provider = ? AND device_token = ? |] - (NTNew, Just NTARegister, PPApnsTest, "abcd" :: ByteString) + (NTNew, Just NTARegister, APP SAPNS (PPAPNS PPApnsTest), "abcd" :: ByteString) Just NtfToken {ntfTokenId = Nothing, ntfTknStatus = NTNew, ntfTknAction = Just NTARegister} <- withTransaction store getSavedNtfToken pure () threadDelay 1000000 @@ -434,7 +434,7 @@ getTestNtfTokenPort a = testNtfTokenMultipleServers :: ASrvTransport -> APNSMockServer -> IO () testNtfTokenMultipleServers t apns = do - let tkn = DeviceToken PPApnsTest "abcd" + let tkn = ADT SAPNS $ 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 = ADT SAPNS $ 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 + ADT _ APNSDeviceToken {} <- registerTestToken alice "abcd" NMInstant apns -- bob registers notification token - DeviceToken {} <- registerTestToken bob "bcde" NMInstant apns + ADT _ APNSDeviceToken {} <- registerTestToken bob "bcde" NMInstant apns -- establish connection liftIO $ threadDelay 50000 (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe @@ -643,9 +643,9 @@ testNotificationSubscriptionNewConnection apns baseId alice bob = where msgId = subtract baseId -registerTestToken :: AgentClient -> ByteString -> NotificationsMode -> APNSMockServer -> ExceptT AgentErrorType IO DeviceToken +registerTestToken :: AgentClient -> ByteString -> NotificationsMode -> APNSMockServer -> ExceptT AgentErrorType IO ADeviceToken registerTestToken a token mode apns = do - let tkn = DeviceToken PPApnsTest token + let tkn = ADT SAPNS $ APNSDeviceToken PPApnsTest token NTRegistered <- registerNtfToken a tkn mode Just APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}} <- timeout 1000000 $ getMockNotification apns tkn @@ -1023,7 +1023,7 @@ testMessage_ apns a aId b bId msg = do get a =##> \case ("", c, Msg msg') -> c == bId && msg == msg'; _ -> False ackMessage a bId msgId Nothing -messageNotification :: HasCallStack => APNSMockServer -> DeviceToken -> ExceptT AgentErrorType IO (C.CbNonce, ByteString) +messageNotification :: HasCallStack => APNSMockServer -> ADeviceToken -> ExceptT AgentErrorType IO (C.CbNonce, ByteString) messageNotification apns tkn = do 500000 `timeout` getMockNotification apns tkn >>= \case Nothing -> error "no notification" diff --git a/tests/NtfClient.hs b/tests/NtfClient.hs index 30b648401..53e02a191 100644 --- a/tests/NtfClient.hs +++ b/tests/NtfClient.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLists #-} @@ -41,7 +42,7 @@ import Simplex.Messaging.Client (ProtocolClientConfig (..), chooseTransportHost, import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding -import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfResponse) +import Simplex.Messaging.Notifications.Protocol (ADeviceToken (..), DeviceToken (..), NtfResponse) import Simplex.Messaging.Notifications.Server (runNtfServerBlocking) import Simplex.Messaging.Notifications.Server.Env import Simplex.Messaging.Notifications.Server.Push.APNS @@ -60,6 +61,7 @@ import UnliftIO.Async import UnliftIO.Concurrent import qualified UnliftIO.Exception as E import UnliftIO.STM +import Control.Exception (throwIO) testHost :: NonEmpty TransportHost testHost = "localhost" @@ -292,8 +294,9 @@ getAPNSMockServer config@HTTP2ServerConfig {qSize} = do putStrLn $ "runAPNSMockServer J.decodeStrict' error, reqBody: " <> show bodyHead sendApnsResponse $ APNSRespError N.badRequest400 "bad_request_body" -getMockNotification :: MonadIO m => APNSMockServer -> DeviceToken -> m APNSMockRequest -getMockNotification APNSMockServer {notifications} (DeviceToken _ token) = do +getMockNotification :: MonadIO m => APNSMockServer -> ADeviceToken -> m APNSMockRequest +getMockNotification _ (ADT _ WPDeviceToken {}) = liftIO . throwIO $ userError "Invalid pusher" +getMockNotification APNSMockServer {notifications} (ADT _ (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..8c295df15 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 = ADT SAPNS $ 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' = ADT SAPNS $ 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 = ADT SAPNS $ 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 diff --git a/tests/NtfWPTests.hs b/tests/NtfWPTests.hs new file mode 100644 index 000000000..5d30d3b57 --- /dev/null +++ b/tests/NtfWPTests.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DataKinds #-} + +module NtfWPTests where + +import Test.Hspec hiding (fit, it) +import Util +import Simplex.Messaging.Encoding.String (StrEncoding(..)) +import qualified Data.ByteString as B +import qualified Crypto.PubKey.ECC.Types as ECC +import Simplex.Messaging.Notifications.Protocol +import Simplex.Messaging.Notifications.Server.Push.WebPush (wpEncrypt', encodeWPN) +import Control.Monad.Except (runExceptT) +import qualified Data.ByteString.Lazy as BL +import Simplex.Messaging.Notifications.Server.Push +import Data.List.NonEmpty (NonEmpty ((:|))) +import qualified Simplex.Messaging.Crypto as C +import Data.Time.Clock.System (SystemTime(..)) +import Data.Either (isLeft) + +ntfWPTests :: Spec +ntfWPTests = describe "NTF Protocol" $ do + it "decode WPDeviceToken from string" testWPDeviceTokenStrEncoding + it "decode invalid WPDeviceToken" testInvalidWPDeviceTokenStrEncoding + it "Encrypt RFC8291 example" testWPEncryption + it "PushNotifications encoding" testPNEncoding + +testWPDeviceTokenStrEncoding :: Expectation +testWPDeviceTokenStrEncoding = do + let ts = "webpush https://localhost/secret AQ3VfRX3_F38J3ltcmMVRg BKuw4WxupnnrZHqk6vCwoms4tOpitZMvFdR9eAn54yOPY4q9jpXOpl-Ui_FwbIy8ZbFCnuaS7RnO02ahuL4XxIM" + -- let ts = "apns_null test_ntf_token" + -- let ts = "apns_test 11111111222222223333333344444444" + + let auth = either error id $ strDecode "AQ3VfRX3_F38J3ltcmMVRg" + let pk = either error id $ strDecode "BKuw4WxupnnrZHqk6vCwoms4tOpitZMvFdR9eAn54yOPY4q9jpXOpl-Ui_FwbIy8ZbFCnuaS7RnO02ahuL4XxIM" + let params :: WPTokenParams = either error id $ strDecode "/secret AQ3VfRX3_F38J3ltcmMVRg BKuw4WxupnnrZHqk6vCwoms4tOpitZMvFdR9eAn54yOPY4q9jpXOpl-Ui_FwbIy8ZbFCnuaS7RnO02ahuL4XxIM" + wpPath params `shouldBe` "/secret" + let key = wpKey params + wpAuth key `shouldBe` auth + wpP256dh key `shouldBe` pk + + let pp@(WPP s) :: WPProvider = either error id $ strDecode "webpush https://localhost" + + let parsed = either error id $ strDecode ts + parsed `shouldBe` WPDeviceToken pp params + -- TODO: strEncoding should be base64url _without padding_ + -- strEncode parsed `shouldBe` ts + + strEncode s <> wpPath params `shouldBe` "https://localhost/secret" + +testInvalidWPDeviceTokenStrEncoding :: Expectation +testInvalidWPDeviceTokenStrEncoding = do + -- http-client parser parseUrlThrow is very very lax, + -- e.g "https://#1" is a valid URL. But that is the same parser + -- we use to send the requests, so that's fine. + let ts = "webpush https://localhost:/ AQ3VfRX3_F38J3ltcmMVRg BKuw4WxupnnrZHqk6vCwoms4tOpitZMvFdR9eAn54yOPY4q9jpXOpl-Ui_FwbIy8ZbFCnuaS7RnO02ahuL4XxIM" + let t = strDecode ts :: Either String ADeviceToken + t `shouldSatisfy` isLeft + +-- | Example from RFC8291 +testWPEncryption :: Expectation +testWPEncryption = do + let clearT :: B.ByteString = "When I grow up, I want to be a watermelon" + let pParams :: WPTokenParams = either error id $ strDecode "/push/JzLQ3raZJfFBR0aqvOMsLrt54w4rJUsV BTBZMqHH6r4Tts7J_aSIgg BCVxsr7N_eNgVRqvHtD0zTZsEc6-VV-JvLexhqUzORcxaOzi6-AYWXvTBHm4bjyPjs7Vd8pZGH6SRpkNtoIAiw4" + let salt :: B.ByteString = either error id $ strDecode "DGv6ra1nlYgDCS1FRnbzlw" + let privBS :: B.ByteString = either error id $ strDecode "yfWPiYE-n46HLnH0KqZOF1fJJU3MYrct3AELtAQ-oRw" + asPriv :: ECC.PrivateNumber <- case uncompressDecodePrivateNumber privBS of + Left e -> fail $ "Cannot decode PrivateNumber from b64 " <> show e + Right p -> pure p + mCip <- runExceptT $ wpEncrypt' (wpKey pParams) asPriv salt clearT + cipher <- case mCip of + Left _ -> fail "Cannot encrypt clear text" + Right c -> pure c + strEncode cipher `shouldBe` "DGv6ra1nlYgDCS1FRnbzlwAAEABBBP4z9KsN6nGRTbVYI_c7VJSPQTBtkgcy27mlmlMoZIIgDll6e3vCYLocInmYWAmS6TlzAC8wEqKK6PBru3jl7A_yl95bQpu6cVPTpK4Mqgkf1CXztLVBSt2Ks3oZwbuwXPXLWyouBWLVWGNWQexSgSxsj_Qulcy4a-fN" + +testPNEncoding :: Expectation +testPNEncoding = do + let pnVerif = PNVerification (NtfRegCode "abcd") + pnCheck = PNCheckMessages + pnMess = pnM "MyMessage" + enc pnCheck `shouldBe` "{\"checkMessages\":true}" + enc pnVerif `shouldBe` "{\"verification\":\"YWJjZA==\"}" + enc pnMess `shouldBe` "{\"checkMessages\":true}" + where + enc p = BL.toStrict $ encodeWPN p + pnM :: B.ByteString -> PushNotification + pnM m = do + let smpQ = either error id $ strDecode "smp://AAAA@l/AAAA" + let now = MkSystemTime 1761827386 0 + PNMessage $ PNMessageData smpQ now (C.cbNonce "nonce") m :| [] diff --git a/tests/Test.hs b/tests/Test.hs index 3e36e192d..611a6e241 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -45,6 +45,7 @@ import AgentTests.SchemaDump (schemaDumpTest) #if defined(dbServerPostgres) import NtfServerTests (ntfServerTests) import NtfClient (ntfTestServerDBConnectInfo, ntfTestStoreDBOpts) +import NtfWPTests (ntfWPTests) import PostgresSchemaDump (postgresSchemaDumpTest) import SMPClient (testServerDBConnectInfo, testStoreDBOpts) import Simplex.Messaging.Notifications.Server.Store.Migrations (ntfServerMigrations) @@ -139,6 +140,7 @@ main = do -- before (pure $ ASType SQSPostgres SMSJournal) smpProxyTests describe "SMP proxy, postgres-only message store" $ before (pure $ ASType SQSPostgres SMSPostgres) smpProxyTests + describe "NTF WP tests" ntfWPTests #endif -- xdescribe "SMP client agent, server jornal message store" $ agentTests (transport @TLS, ASType SQSMemory SMSJournal) describe "SMP client agent, server memory message store" $ agentTests (transport @TLS, ASType SQSMemory SMSMemory)