Add WPDeviceToken

src/Simplex/Messaging/Agent/Store/AgentStore.hs

@@ -278,7 +278,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
@@ -1382,7 +1382,8 @@ deleteCommand db cmdId =
   DB.execute db "DELETE FROM commands WHERE command_id = ?" (Only cmdId)
 
 createNtfToken :: DB.Connection -> NtfToken -> IO ()
-createNtfToken db NtfToken {deviceToken = APNSDeviceToken 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
@@ -1409,10 +1410,12 @@ getSavedNtfToken db = do
       let ntfServer = NtfServer host port keyHash
           ntfDhKeys = (ntfDhPubKey, ntfDhPrivKey)
           ntfMode = fromMaybe NMPeriodic ntfMode_
-       in NtfToken {deviceToken = APNSDeviceToken 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 = APNSDeviceToken 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
@@ -1424,8 +1427,10 @@ updateNtfTokenRegistration db NtfToken {deviceToken = APNSDeviceToken provider t
     (tknId, ntfDhSecret, NTRegistered, Nothing :: Maybe NtfTknAction, updatedAt, provider, token, host, port)
 
 updateDeviceToken :: DB.Connection -> NtfToken -> DeviceToken -> IO ()
-updateDeviceToken db NtfToken {deviceToken = APNSDeviceToken provider token, ntfServer = ProtocolServer {host, port}} (APNSDeviceToken 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|
@@ -1436,7 +1441,8 @@ updateDeviceToken db NtfToken {deviceToken = APNSDeviceToken provider token, ntf
     (toProvider, toToken, NTRegistered, Nothing :: Maybe NtfTknAction, updatedAt, provider, token, host, port)
 
 updateNtfMode :: DB.Connection -> NtfToken -> NotificationsMode -> IO ()
-updateNtfMode db NtfToken {deviceToken = APNSDeviceToken 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
@@ -1448,7 +1454,8 @@ updateNtfMode db NtfToken {deviceToken = APNSDeviceToken provider token, ntfServ
     (ntfMode, updatedAt, provider, token, host, port)
 
 updateNtfToken :: DB.Connection -> NtfToken -> NtfTknStatus -> Maybe NtfTknAction -> IO ()
-updateNtfToken db NtfToken {deviceToken = APNSDeviceToken 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
@@ -1460,7 +1467,8 @@ updateNtfToken db NtfToken {deviceToken = APNSDeviceToken provider token, ntfSer
     (tknStatus, tknAction, updatedAt, provider, token, host, port)
 
 removeNtfToken :: DB.Connection -> NtfToken -> IO ()
-removeNtfToken db NtfToken {deviceToken = APNSDeviceToken provider token, ntfServer = ProtocolServer {host, port}} =
+removeNtfToken db NtfToken {deviceToken, ntfServer = ProtocolServer {host, port}} = do
+  let (provider, token) = deviceTokenFields deviceToken
   DB.execute
     db
     [sql|
@@ -1785,7 +1793,8 @@ getActiveNtfToken db =
       let ntfServer = NtfServer host port keyHash
           ntfDhKeys = (ntfDhPubKey, ntfDhPrivKey)
           ntfMode = fromMaybe NMPeriodic ntfMode_
-       in NtfToken {deviceToken = APNSDeviceToken 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} =

src/Simplex/Messaging/Notifications/Protocol.hs

@@ -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,45 +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 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 (APNSDeviceToken p t) = smpEncode (p, t)
-  smpP = APNSDeviceToken <$> 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 (APNSDeviceToken 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" $> APNSDeviceToken PPApnsNull "test_ntf_token"
-      hexToken = APNSDeviceToken <$> strP <* A.space <*> hexStringP
+      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 (APNSDeviceToken pp t) = J.pairs $ "pushProvider" .= decodeLatin1 (strEncode pp) <> "token" .= decodeLatin1 t
-  toJSON (APNSDeviceToken pp t) = J.object ["pushProvider" .= decodeLatin1 (strEncode pp), "token" .= decodeLatin1 t]
+  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 $ APNSDeviceToken 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,

src/Simplex/Messaging/Notifications/Server.hs

@@ -629,7 +629,8 @@ showServer' = decodeLatin1 . strEncode . host
 
 ntfPush :: NtfPushServer -> M ()
 ntfPush s@NtfPushServer {pushQ} = forever $ do
-  (srvHost_, tkn@NtfTknRec {ntfTknId, token = t@(APNSDeviceToken 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

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)

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

@@ -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 = APNSDeviceToken _ 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 =

src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs

@@ -126,8 +126,9 @@ insertNtfTknQuery =
   |]
 
 replaceNtfToken :: NtfPostgresStore -> NtfTknRec -> IO (Either ErrorType ())
-replaceNtfToken st NtfTknRec {ntfTknId, token = token@(APNSDeviceToken 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
@@ -141,7 +142,7 @@ replaceNtfToken st NtfTknRec {ntfTknId, token = token@(APNSDeviceToken pp ppToke
 
 ntfTknToRow :: NtfTknRec -> NtfTknRow
 ntfTknToRow NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhPrivKey, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt} =
-  let APNSDeviceToken pp ppToken = token
+  let (pp, ppToken) = deviceTokenFields token
       NtfRegCode regCode = tknRegCode
    in (ntfTknId, pp, Binary ppToken, tknStatus, tknVerifyKey, tknDhPrivKey, tknDhSecret, Binary regCode, tknCronInterval, tknUpdatedAt)
 
@@ -151,7 +152,8 @@ getNtfToken st tknId =
     getNtfToken_ st " WHERE token_id = ?" (Only tknId)
 
 findNtfTokenRegistration :: NtfPostgresStore -> NewNtfEntity 'Token -> IO (Either ErrorType (Maybe NtfTknRec))
-findNtfTokenRegistration st (NewNtfTkn (APNSDeviceToken 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))
@@ -179,7 +181,7 @@ ntfTknQuery =
 
 rowToNtfTkn :: NtfTknRow -> NtfTknRec
 rowToNtfTkn (ntfTknId, pp, Binary ppToken, tknStatus, tknVerifyKey, tknDhPrivKey, tknDhSecret, Binary regCode, tknCronInterval, tknUpdatedAt)  =
-  let token = APNSDeviceToken pp ppToken
+  let token = deviceToken' pp ppToken
       tknRegCode = NtfRegCode regCode
    in NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhPrivKey, tknDhSecret, tknRegCode, tknCronInterval, tknUpdatedAt}
 
@@ -374,8 +376,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 = APNSDeviceToken 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 <-