mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-05-25 01:35:22 +00:00
Merge branch 'webpush_requests' of github.com:p1gp1g/simplexmq into p1gp1g-webpush_requests
This commit is contained in:
Evgeny Poberezkin
@@ -260,6 +260,8 @@ 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
|
||||
Simplex.Messaging.Notifications.Server.Push.APNS.Internal
|
||||
Simplex.Messaging.Notifications.Server.Stats
|
||||
Simplex.Messaging.Notifications.Server.Store
|
||||
@@ -292,6 +294,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.*
|
||||
@@ -304,6 +307,8 @@ library
|
||||
, directory ==1.3.*
|
||||
, filepath ==1.4.*
|
||||
, hourglass ==0.2.*
|
||||
, http-client ==0.7.*
|
||||
, http-client-tls ==0.3.6.*
|
||||
, http-types ==0.12.*
|
||||
, http2 >=4.2.2 && <4.3
|
||||
, iproute ==1.7.*
|
||||
|
||||
@@ -1318,7 +1318,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
|
||||
|
||||
@@ -281,7 +281,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 (DeviceToken (..), NtfSubscriptionId, NtfTknStatus (..), NtfTokenId, SMPQueueNtf (..), deviceTokenFields, deviceToken')
|
||||
import Simplex.Messaging.Notifications.Types
|
||||
import Simplex.Messaging.Parsers (parseAll)
|
||||
import Simplex.Messaging.Protocol
|
||||
@@ -1383,7 +1383,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
|
||||
@@ -1410,10 +1411,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
|
||||
@@ -1425,8 +1428,10 @@ 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, ntfServer = ProtocolServer {host, port}} toDt = do
|
||||
let (provider, token) = deviceTokenFields deviceToken
|
||||
updatedAt <- getCurrentTime
|
||||
let (toProvider, toToken) = deviceTokenFields toDt
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
@@ -1437,7 +1442,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
|
||||
@@ -1449,7 +1455,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
|
||||
@@ -1461,7 +1468,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|
|
||||
@@ -1786,7 +1794,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} =
|
||||
|
||||
@@ -127,6 +127,7 @@ module Simplex.Messaging.Crypto
|
||||
encryptAEAD,
|
||||
decryptAEAD,
|
||||
encryptAESNoPad,
|
||||
encryptAES128NoPad,
|
||||
decryptAESNoPad,
|
||||
authTagSize,
|
||||
randomAesKey,
|
||||
@@ -209,7 +210,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
|
||||
@@ -895,6 +896,8 @@ data CryptoError
|
||||
CERatchetEarlierMessage Word32
|
||||
| -- | duplicate message number
|
||||
CERatchetDuplicateMessage
|
||||
| -- | unable to decode ecc key
|
||||
CryptoInvalidECCKey CE.CryptoError
|
||||
deriving (Eq, Show, Exception)
|
||||
|
||||
aesKeySize :: Int
|
||||
@@ -1021,11 +1024,22 @@ 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
|
||||
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 <- initAEAD128GCM aesKey ivBytes
|
||||
pure . first AuthTag $ AES.aeadSimpleEncrypt aead ad msg authTagSize
|
||||
|
||||
-- | AEAD-GCM decryption with associated data.
|
||||
--
|
||||
-- Used as part of double ratchet encryption.
|
||||
@@ -1125,6 +1139,12 @@ initAEADGCM (Key aesKey) (GCMIV ivBytes) = cryptoFailable $ do
|
||||
cipher <- AES.cipherInit aesKey
|
||||
AES.aeadInit AES.AEAD_GCM cipher ivBytes
|
||||
|
||||
-- this function requires 12 bytes IV, it does not transforms IV.
|
||||
initAEAD128GCM :: Key -> GCMIV -> ExceptT CryptoError IO (AES.AEAD AES128)
|
||||
initAEAD128GCM (Key aesKey) (GCMIV ivBytes) = cryptoFailable $ do
|
||||
cipher <- AES.cipherInit aesKey
|
||||
AES.aeadInit AES.AEAD_GCM cipher ivBytes
|
||||
|
||||
-- | Random AES256 key.
|
||||
randomAesKey :: TVar ChaChaDRG -> STM Key
|
||||
randomAesKey = fmap Key . randomBytes aesKeySize
|
||||
|
||||
@@ -35,6 +35,7 @@ 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 Control.Monad (when)
|
||||
|
||||
data NtfEntity = Token | Subscription
|
||||
deriving (Show)
|
||||
@@ -377,6 +378,7 @@ data PushProvider
|
||||
| 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
|
||||
| PPWebPush -- used for webpush (FCM, UnifiedPush, potentially desktop)
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
instance Encoding PushProvider where
|
||||
@@ -385,12 +387,14 @@ instance Encoding PushProvider where
|
||||
PPApnsProd -> "AP"
|
||||
PPApnsTest -> "AT"
|
||||
PPApnsNull -> "AN"
|
||||
PPWebPush -> "WP"
|
||||
smpP =
|
||||
A.take 2 >>= \case
|
||||
"AD" -> pure PPApnsDev
|
||||
"AP" -> pure PPApnsProd
|
||||
"AT" -> pure PPApnsTest
|
||||
"AN" -> pure PPApnsNull
|
||||
"WP" -> pure PPWebPush
|
||||
_ -> fail "bad PushProvider"
|
||||
|
||||
instance StrEncoding PushProvider where
|
||||
@@ -399,44 +403,116 @@ instance StrEncoding PushProvider where
|
||||
PPApnsProd -> "apns_prod"
|
||||
PPApnsTest -> "apns_test"
|
||||
PPApnsNull -> "apns_null"
|
||||
PPWebPush -> "webpush"
|
||||
strP =
|
||||
A.takeTill (== ' ') >>= \case
|
||||
"apns_dev" -> pure PPApnsDev
|
||||
"apns_prod" -> pure PPApnsProd
|
||||
"apns_test" -> pure PPApnsTest
|
||||
"apns_null" -> pure PPApnsNull
|
||||
"webpush" -> pure PPWebPush
|
||||
_ -> fail "bad PushProvider"
|
||||
|
||||
instance FromField PushProvider where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8
|
||||
|
||||
instance ToField PushProvider where toField = toField . decodeLatin1 . strEncode
|
||||
|
||||
data DeviceToken = DeviceToken PushProvider ByteString
|
||||
data WPEndpoint = WPEndpoint { endpoint::ByteString, auth::ByteString, p256dh::ByteString }
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
instance Encoding WPEndpoint where
|
||||
smpEncode WPEndpoint { endpoint, auth, p256dh } = smpEncode (endpoint, auth, p256dh)
|
||||
smpP = do
|
||||
endpoint <- smpP
|
||||
auth <- smpP
|
||||
p256dh <- smpP
|
||||
pure WPEndpoint { endpoint, auth, p256dh }
|
||||
|
||||
instance StrEncoding WPEndpoint where
|
||||
strEncode WPEndpoint { endpoint, auth, p256dh } = endpoint <> " " <> strEncode auth <> " " <> strEncode p256dh
|
||||
strP = do
|
||||
endpoint <- A.takeWhile (/= ' ')
|
||||
_ <- A.char ' '
|
||||
(auth, p256dh) <- strP
|
||||
-- auth is a 16 bytes long random key
|
||||
when (B.length auth /= 16) $ fail "Invalid auth key length"
|
||||
-- p256dh is a public key on the P-256 curve, encoded in uncompressed format
|
||||
-- 0x04 + the 2 points = 65 bytes
|
||||
when (B.length p256dh /= 65) $ fail "Invalid p256dh key length"
|
||||
when (B.take 1 p256dh /= "\x04") $ fail "Invalid p256dh key, doesn't start with 0x04"
|
||||
pure WPEndpoint { endpoint, auth, p256dh }
|
||||
|
||||
instance ToJSON WPEndpoint where
|
||||
toEncoding WPEndpoint { endpoint, auth, p256dh } = J.pairs $ "endpoint" .= decodeLatin1 endpoint <> "auth" .= decodeLatin1 (strEncode auth) <> "p256dh" .= decodeLatin1 (strEncode p256dh)
|
||||
toJSON WPEndpoint { endpoint, auth, p256dh } = J.object ["endpoint" .= decodeLatin1 endpoint, "auth" .= decodeLatin1 (strEncode auth), "p256dh" .= decodeLatin1 (strEncode p256dh) ]
|
||||
|
||||
instance FromJSON WPEndpoint where
|
||||
parseJSON = J.withObject "WPEndpoint" $ \o -> do
|
||||
endpoint <- encodeUtf8 <$> o .: "endpoint"
|
||||
auth <- strDecode . encodeUtf8 <$?> o .: "auth"
|
||||
p256dh <- strDecode . encodeUtf8 <$?> o .: "p256dh"
|
||||
pure WPEndpoint { endpoint, auth, p256dh }
|
||||
|
||||
data DeviceToken
|
||||
= APNSDeviceToken PushProvider ByteString
|
||||
| WPDeviceToken WPEndpoint
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
instance Encoding DeviceToken where
|
||||
smpEncode (DeviceToken p t) = smpEncode (p, t)
|
||||
smpP = DeviceToken <$> smpP <*> smpP
|
||||
smpEncode token = case token of
|
||||
APNSDeviceToken p t -> smpEncode (p, t)
|
||||
WPDeviceToken t -> smpEncode (PPWebPush, t)
|
||||
smpP = do
|
||||
pp <- smpP
|
||||
case pp of
|
||||
PPWebPush -> WPDeviceToken <$> smpP
|
||||
_ -> APNSDeviceToken pp <$> smpP
|
||||
|
||||
instance StrEncoding DeviceToken where
|
||||
strEncode (DeviceToken p t) = strEncode p <> " " <> t
|
||||
strP = nullToken <|> hexToken
|
||||
strEncode token = case token of
|
||||
APNSDeviceToken p t -> strEncode p <> " " <> t
|
||||
WPDeviceToken t -> strEncode PPWebPush <> " " <> strEncode t
|
||||
strP = nullToken <|> deviceToken
|
||||
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"
|
||||
deviceToken = do
|
||||
pp <- strP_
|
||||
case pp of
|
||||
PPWebPush -> WPDeviceToken <$> strP
|
||||
_ -> APNSDeviceToken pp <$> 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 token = case token of
|
||||
APNSDeviceToken pp t -> J.pairs $ "pushProvider" .= decodeLatin1 (strEncode pp) <> "token" .= decodeLatin1 t
|
||||
WPDeviceToken t -> J.pairs $ "pushProvider" .= decodeLatin1 (strEncode PPWebPush) <> "token" .= toJSON t
|
||||
toJSON token = case token of
|
||||
APNSDeviceToken pp t -> J.object ["pushProvider" .= decodeLatin1 (strEncode pp), "token" .= decodeLatin1 t]
|
||||
WPDeviceToken t -> J.object ["pushProvider" .= decodeLatin1 (strEncode PPWebPush), "token" .= toJSON t]
|
||||
|
||||
instance FromJSON DeviceToken where
|
||||
parseJSON = J.withObject "DeviceToken" $ \o -> do
|
||||
pp <- strDecode . encodeUtf8 <$?> o .: "pushProvider"
|
||||
t <- encodeUtf8 <$> o .: "token"
|
||||
pure $ DeviceToken pp t
|
||||
case pp of
|
||||
PPWebPush -> do
|
||||
WPDeviceToken <$> (o .: "token")
|
||||
_ -> do
|
||||
t <- encodeUtf8 <$> (o .: "token")
|
||||
pure $ APNSDeviceToken pp t
|
||||
|
||||
-- | Returns fields for the device token (pushProvider, token)
|
||||
deviceTokenFields :: DeviceToken -> (PushProvider, ByteString)
|
||||
deviceTokenFields dt = case dt of
|
||||
APNSDeviceToken pp t -> (pp, t)
|
||||
WPDeviceToken t -> (PPWebPush, strEncode t)
|
||||
|
||||
-- | Returns the device token from the fields (pushProvider, token)
|
||||
deviceToken' :: PushProvider -> ByteString -> DeviceToken
|
||||
deviceToken' pp t = case pp of
|
||||
PPWebPush -> WPDeviceToken <$> either error id $ strDecode t
|
||||
_ -> APNSDeviceToken pp t
|
||||
|
||||
-- List of PNMessageData uses semicolon-separated encoding instead of strEncode,
|
||||
-- because strEncode of NonEmpty list uses comma for separator,
|
||||
|
||||
@@ -629,7 +629,8 @@ 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, tknStatus}, ntf) <- atomically (readTBQueue pushQ)
|
||||
let (pp, _) = deviceTokenFields t
|
||||
liftIO $ logDebug $ "sending push notification to " <> T.pack (show pp)
|
||||
st <- asks store
|
||||
case ntf of
|
||||
@@ -675,6 +676,8 @@ ntfPush s@NtfPushServer {pushQ} = forever $ do
|
||||
void $ updateTknStatus st tkn $ NTInvalid $ Just r
|
||||
err e
|
||||
PPPermanentError -> err e
|
||||
PPInvalidPusher -> err e
|
||||
_ -> err e
|
||||
where
|
||||
retryDeliver :: IO (Either PushProviderError ())
|
||||
retryDeliver = do
|
||||
@@ -905,7 +908,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 #-}
|
||||
|
||||
|
||||
@@ -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)
|
||||
@@ -46,6 +47,9 @@ 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)
|
||||
import Network.HTTP.Client.TLS (tlsManagerSettings)
|
||||
|
||||
data NtfServerConfig = NtfServerConfig
|
||||
{ transports :: [(ServiceName, ASrvTransport, AddHTTP)],
|
||||
@@ -160,13 +164,27 @@ newNtfPushServer qSize apnsConfig = do
|
||||
pure NtfPushServer {pushQ, pushClients, apnsConfig}
|
||||
|
||||
newPushClient :: NtfPushServer -> PushProvider -> IO PushProviderClient
|
||||
newPushClient NtfPushServer {apnsConfig, pushClients} pp = do
|
||||
newPushClient s pp = do
|
||||
case pp of
|
||||
PPWebPush -> newWPPushClient s
|
||||
_ -> newAPNSPushClient s pp
|
||||
|
||||
newAPNSPushClient :: NtfPushServer -> PushProvider -> IO PushProviderClient
|
||||
newAPNSPushClient 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
|
||||
pure c
|
||||
|
||||
newWPPushClient :: NtfPushServer -> IO PushProviderClient
|
||||
newWPPushClient NtfPushServer {pushClients} = do
|
||||
logDebug "New WP Client requested"
|
||||
manager <- newManager tlsManagerSettings
|
||||
let c = wpPushProviderClient manager
|
||||
atomically $ TM.insert PPWebPush c pushClients
|
||||
pure c
|
||||
|
||||
getPushClient :: NtfPushServer -> PushProvider -> IO PushProviderClient
|
||||
getPushClient s@NtfPushServer {pushClients} pp =
|
||||
TM.lookupIO pp pushClients >>= maybe (newPushClient s pp) pure
|
||||
|
||||
@@ -36,6 +36,7 @@ import Network.HTTP.Types (Status)
|
||||
import Control.Exception (Exception)
|
||||
import Simplex.Messaging.Notifications.Server.Store.Types (NtfTknRec)
|
||||
import Control.Monad.Except (ExceptT)
|
||||
import GHC.Exception (SomeException)
|
||||
|
||||
data JWTHeader = JWTHeader
|
||||
{ alg :: Text, -- key algorithm, ES256 for APNS
|
||||
@@ -93,6 +94,11 @@ data PushProviderError
|
||||
| PPTokenInvalid NTInvalidReason
|
||||
| PPRetryLater
|
||||
| PPPermanentError
|
||||
| PPInvalidPusher
|
||||
| PPWPInvalidUrl
|
||||
| PPWPRemovedEndpoint
|
||||
| PPWPRequestTooLong
|
||||
| PPWPOtherError SomeException
|
||||
deriving (Show, Exception)
|
||||
|
||||
type PushProviderClient = NtfTknRec -> PushNotification -> ExceptT PushProviderError IO ()
|
||||
|
||||
@@ -130,6 +130,7 @@ apnsProviderHost = \case
|
||||
PPApnsTest -> Just "localhost"
|
||||
PPApnsDev -> Just "api.sandbox.push.apple.com"
|
||||
PPApnsProd -> Just "api.push.apple.com"
|
||||
_ -> Nothing
|
||||
|
||||
defaultAPNSPushClientConfig :: APNSPushClientConfig
|
||||
defaultAPNSPushClientConfig =
|
||||
@@ -256,7 +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 c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknRec {token} pn = do
|
||||
tknStr <- deviceToken token
|
||||
http2 <- liftHTTPS2 $ getApnsHTTP2Client c
|
||||
nonce <- atomically $ C.randomCbNonce nonceDrg
|
||||
apnsNtf <- liftEither $ first PPCryptoError $ apnsNotification tkn nonce (paddedNtfLength apnsCfg) pn
|
||||
@@ -270,6 +272,9 @@ apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknRec {token
|
||||
else logWarn $ "APNS error: " <> T.pack (show status) <> " " <> reason' <> apnsIds response
|
||||
result status reason'
|
||||
where
|
||||
deviceToken t = case t of
|
||||
APNSDeviceToken _ dt -> pure dt
|
||||
_ -> throwE PPInvalidPusher
|
||||
apnsIds response = headerStr "apns-id" <> headerStr "apns-unique-id"
|
||||
where
|
||||
headerStr name =
|
||||
|
||||
@@ -0,0 +1,178 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
|
||||
|
||||
{-# HLINT ignore "Use newtype instead of data" #-}
|
||||
{-# LANGUAGE OverloadedRecordDot #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Simplex.Messaging.Notifications.Server.Push.WebPush where
|
||||
|
||||
import Network.HTTP.Client
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Notifications.Protocol (DeviceToken (WPDeviceToken), WPEndpoint (..), encodePNMessages, PNMessageData)
|
||||
import Simplex.Messaging.Notifications.Server.Store.Types
|
||||
import Simplex.Messaging.Notifications.Server.Push
|
||||
import Control.Monad.Except
|
||||
import Control.Logger.Simple (logDebug)
|
||||
import Simplex.Messaging.Util (tshow)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Exception ( fromException, SomeException, try )
|
||||
import qualified Network.HTTP.Types as N
|
||||
import qualified Data.Aeson as J
|
||||
import Data.Aeson ((.=))
|
||||
import qualified Data.Binary as Bin
|
||||
import qualified Data.Bits as Bits
|
||||
import qualified Data.ByteArray as BA
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import qualified Data.Text.Encoding as T
|
||||
import qualified Data.Text as T
|
||||
import Control.Monad.Trans.Except (throwE)
|
||||
import Crypto.Hash.Algorithms (SHA256)
|
||||
import Crypto.Random (MonadRandom(getRandomBytes))
|
||||
import qualified Crypto.Cipher.Types as CT
|
||||
import qualified Crypto.Error as CE
|
||||
import qualified Crypto.MAC.HMAC as HMAC
|
||||
import qualified Crypto.PubKey.ECC.DH as ECDH
|
||||
import qualified Crypto.PubKey.ECC.Types as ECC
|
||||
import GHC.Base (when)
|
||||
|
||||
wpPushProviderClient :: Manager -> PushProviderClient
|
||||
wpPushProviderClient mg tkn pn = do
|
||||
e <- endpoint tkn
|
||||
r <- liftPPWPError $ parseUrlThrow $ B.unpack e.endpoint
|
||||
logDebug $ "Request to " <> tshow r.host
|
||||
encBody <- body e
|
||||
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
|
||||
}
|
||||
_ <- liftPPWPError $ httpNoBody req mg
|
||||
pure ()
|
||||
where
|
||||
endpoint :: NtfTknRec -> ExceptT PushProviderError IO WPEndpoint
|
||||
endpoint NtfTknRec {token} = do
|
||||
case token of
|
||||
WPDeviceToken e -> pure e
|
||||
_ -> fail "Wrong device token"
|
||||
-- TODO: move to PPIndalidPusher ? WPEndpoint should be invalidated and removed if the key is invalid, but the validation key is never sent
|
||||
body :: WPEndpoint -> ExceptT PushProviderError IO B.ByteString
|
||||
body e = withExceptT PPCryptoError $ wpEncrypt e.auth e.p256dh (BL.toStrict $ encodePN pn)
|
||||
|
||||
-- | encrypt :: auth -> key -> clear -> cipher
|
||||
-- | https://www.rfc-editor.org/rfc/rfc8291#section-3.4
|
||||
wpEncrypt :: B.ByteString -> B.ByteString -> B.ByteString -> ExceptT C.CryptoError IO B.ByteString
|
||||
wpEncrypt auth uaPubKS clearT = do
|
||||
salt :: B.ByteString <- liftIO $ getRandomBytes 16
|
||||
asPrivK <- liftIO $ ECDH.generatePrivate $ ECC.getCurveByName ECC.SEC_p256r1
|
||||
uaPubK <- point uaPubKS
|
||||
let asPubK = BL.toStrict . uncompressEncode . ECDH.calculatePublic (ECC.getCurveByName ECC.SEC_p256r1) $ asPrivK
|
||||
ecdhSecret = ECDH.getShared (ECC.getCurveByName ECC.SEC_p256r1) asPrivK uaPubK
|
||||
prkKey = hmac auth ecdhSecret
|
||||
keyInfo = "WebPush: info\0" <> uaPubKS <> asPubK
|
||||
ikm = hmac prkKey (keyInfo <> "\x01")
|
||||
prk = hmac salt ikm
|
||||
cekInfo = "Content-Encoding: aes128gcm\0" :: B.ByteString
|
||||
cek = takeHM 16 $ hmac prk (cekInfo <> "\x01")
|
||||
nonceInfo = "Content-Encoding: nonce\0" :: B.ByteString
|
||||
nonce = takeHM 12 $ 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 <> asPubK
|
||||
iv <- ivFrom nonce
|
||||
-- The last record uses a padding delimiter octet set to the value 0x02
|
||||
(C.AuthTag (CT.AuthTag tag), cipherT) <- C.encryptAES128NoPad (C.Key cek) iv $ clearT <> "\x02"
|
||||
pure $ header <> cipherT <> BA.convert tag
|
||||
where
|
||||
point :: B.ByteString -> ExceptT C.CryptoError IO ECC.Point
|
||||
point s = withExceptT C.CryptoInvalidECCKey $ uncompressDecode $ BL.fromStrict s
|
||||
hmac k v = HMAC.hmac k v :: HMAC.HMAC SHA256
|
||||
takeHM :: Int -> HMAC.HMAC SHA256 -> B.ByteString
|
||||
takeHM n v = BL.toStrict $ BL.pack $ take n $ BA.unpack v
|
||||
ivFrom :: B.ByteString -> ExceptT C.CryptoError IO C.GCMIV
|
||||
ivFrom s = case C.gcmIV s of
|
||||
Left e -> throwE e
|
||||
Right iv -> pure iv
|
||||
|
||||
-- | Elliptic-Curve-Point-to-Octet-String Conversion without compression
|
||||
-- | as required by RFC8291
|
||||
-- | https://www.secg.org/sec1-v2.pdf#subsubsection.2.3.3
|
||||
uncompressEncode :: ECC.Point -> BL.ByteString
|
||||
uncompressEncode (ECC.Point x y) = "\x04" <>
|
||||
encodeBigInt x <>
|
||||
encodeBigInt y
|
||||
uncompressEncode ECC.PointO = "\0"
|
||||
|
||||
uncompressDecode :: BL.ByteString -> ExceptT CE.CryptoError IO ECC.Point
|
||||
uncompressDecode "\0" = pure ECC.PointO
|
||||
uncompressDecode s = do
|
||||
when (BL.take 1 s /= prefix) $ throwError CE.CryptoError_PointFormatUnsupported
|
||||
when (BL.length s /= 65) $ throwError CE.CryptoError_KeySizeInvalid
|
||||
let s' = BL.drop 1 s
|
||||
x <- decodeBigInt $ BL.take 32 s'
|
||||
y <- decodeBigInt $ BL.drop 32 s'
|
||||
pure $ ECC.Point x y
|
||||
where
|
||||
prefix = "\x04" :: BL.ByteString
|
||||
|
||||
encodeBigInt :: Integer -> BL.ByteString
|
||||
encodeBigInt i = do
|
||||
let s1 = Bits.shiftR i 64
|
||||
s2 = Bits.shiftR s1 64
|
||||
s3 = Bits.shiftR s2 64
|
||||
Bin.encode ( w64 s3, w64 s2, w64 s1, w64 i )
|
||||
where
|
||||
w64 :: Integer -> Bin.Word64
|
||||
w64 = fromIntegral
|
||||
|
||||
decodeBigInt :: BL.ByteString -> ExceptT CE.CryptoError IO Integer
|
||||
decodeBigInt s = do
|
||||
when (BL.length s /= 32) $ throwError CE.CryptoError_PointSizeInvalid
|
||||
let (w3, w2, w1, w0) = Bin.decode s :: (Bin.Word64, Bin.Word64, Bin.Word64, Bin.Word64 )
|
||||
pure $ shift 3 w3 + shift 2 w2 + shift 1 w1 + shift 0 w0
|
||||
where
|
||||
shift i w = Bits.shiftL (fromIntegral w) (64*i)
|
||||
|
||||
encodePN :: PushNotification -> BL.ByteString
|
||||
encodePN pn = J.encode $ case pn of
|
||||
PNVerification code -> J.object [ "verification" .= code ]
|
||||
PNMessage d -> J.object [ "message" .= encodeData d ]
|
||||
PNCheckMessages -> J.object [ "checkMessages" .= True ]
|
||||
where
|
||||
encodeData :: NonEmpty PNMessageData -> String
|
||||
encodeData a = T.unpack . T.decodeUtf8 $ encodePNMessages a
|
||||
|
||||
liftPPWPError :: IO a -> ExceptT PushProviderError IO a
|
||||
liftPPWPError = liftPPWPError' toPPWPError
|
||||
|
||||
liftPPWPError' :: (SomeException -> PushProviderError) -> IO a -> ExceptT PushProviderError IO a
|
||||
liftPPWPError' err a = liftIO (try @SomeException a) >>= either (throwError . err) return
|
||||
|
||||
toPPWPError :: SomeException -> PushProviderError
|
||||
toPPWPError e = case fromException e of
|
||||
Just (InvalidUrlException _ _) -> PPWPInvalidUrl
|
||||
Just (HttpExceptionRequest _ (StatusCodeException resp _)) -> fromStatusCode (responseStatus resp) ("" :: String)
|
||||
_ -> PPWPOtherError 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)
|
||||
@@ -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))
|
||||
@@ -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 <-
|
||||
|
||||
@@ -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
|
||||
|
||||
+1
-1
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user