mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-10-23 06:32:22 +00:00
interval notifications (TCRN command) (#352)
* notifications: periodic notifications * agent: allow repeat token registrations, delete old tokens from notification server (e.g., when database is moved to another device) * decrypt token verification code in the agent * check token status, send TCRN on registration if it was enabled * fix http2/apns response handling for error responses (also, APNS seems not to send content-length header?)
This commit is contained in:
Evgeny Poberezkin authored and GitHub committed
1 parent
45ddecc4b8
commit
9d8a9c4fe4
15 files changed
+312
-190
No files matched your search
@@ -33,6 +33,12 @@ ntfRegisterToken c pKey newTkn =
|
||||
ntfVerifyToken :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> NtfRegCode -> ExceptT ProtocolClientError IO ()
|
||||
ntfVerifyToken c pKey tknId code = okNtfCommand (TVFY code) c pKey tknId
|
||||
|
||||
ntfCheckToken :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> ExceptT ProtocolClientError IO NtfTknStatus
|
||||
ntfCheckToken c pKey tknId =
|
||||
sendNtfCommand c (Just pKey) tknId TCHK >>= \case
|
||||
NRTkn stat -> pure stat
|
||||
_ -> throwE PCEUnexpectedResponse
|
||||
|
||||
ntfDeleteToken :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> ExceptT ProtocolClientError IO ()
|
||||
ntfDeleteToken = okNtfCommand TDEL
|
||||
|
||||
@@ -48,7 +54,7 @@ ntfCreateSubsciption c pKey newSub =
|
||||
ntfCheckSubscription :: NtfClient -> C.APrivateSignKey -> NtfSubscriptionId -> ExceptT ProtocolClientError IO NtfSubStatus
|
||||
ntfCheckSubscription c pKey subId =
|
||||
sendNtfCommand c (Just pKey) subId SCHK >>= \case
|
||||
NRStat stat -> pure stat
|
||||
NRSub stat -> pure stat
|
||||
_ -> throwE PCEUnexpectedResponse
|
||||
|
||||
ntfDeleteSubscription :: NtfClient -> C.APrivateSignKey -> NtfSubscriptionId -> ExceptT ProtocolClientError IO ()
|
||||
@@ -65,7 +71,7 @@ okNtfCommand cmd c pKey entId =
|
||||
_ -> throwE PCEUnexpectedResponse
|
||||
|
||||
data NtfTknAction
|
||||
= NTARegister C.APublicVerifyKey -- public key to send to the server
|
||||
= NTARegister
|
||||
| NTAVerify NtfRegCode -- code to verify token
|
||||
| NTACheck
|
||||
| NTACron Word16
|
||||
@@ -74,14 +80,14 @@ data NtfTknAction
|
||||
|
||||
instance Encoding NtfTknAction where
|
||||
smpEncode = \case
|
||||
NTARegister key -> smpEncode ('R', key)
|
||||
NTARegister -> "R"
|
||||
NTAVerify code -> smpEncode ('V', code)
|
||||
NTACheck -> "C"
|
||||
NTACron interval -> smpEncode ('I', interval)
|
||||
NTADelete -> "D"
|
||||
smpP =
|
||||
A.anyChar >>= \case
|
||||
'R' -> NTARegister <$> smpP
|
||||
'R' -> pure NTARegister
|
||||
'V' -> NTAVerify <$> smpP
|
||||
'C' -> pure NTACheck
|
||||
'I' -> NTACron <$> smpP
|
||||
@@ -96,8 +102,12 @@ data NtfToken = NtfToken
|
||||
{ deviceToken :: DeviceToken,
|
||||
ntfServer :: NtfServer,
|
||||
ntfTokenId :: Maybe NtfTokenId,
|
||||
-- | key used by the ntf server to verify transmissions
|
||||
ntfPubKey :: C.APublicVerifyKey,
|
||||
-- | key used by the ntf client to sign transmissions
|
||||
ntfPrivKey :: C.APrivateSignKey,
|
||||
-- | client's DH keys (to repeat registration if necessary)
|
||||
ntfDhKeys :: C.KeyPair 'C.X25519,
|
||||
-- | shared DH secret used to encrypt/decrypt notifications e2e
|
||||
ntfDhSecret :: Maybe C.DhSecretX25519,
|
||||
-- | token status
|
||||
@@ -107,14 +117,16 @@ data NtfToken = NtfToken
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
newNtfToken :: DeviceToken -> NtfServer -> C.APrivateSignKey -> C.APublicVerifyKey -> NtfToken
|
||||
newNtfToken deviceToken ntfServer ntfPrivKey ntfPubKey =
|
||||
newNtfToken :: DeviceToken -> NtfServer -> C.ASignatureKeyPair -> C.KeyPair 'C.X25519 -> NtfToken
|
||||
newNtfToken deviceToken ntfServer (ntfPubKey, ntfPrivKey) ntfDhKeys =
|
||||
NtfToken
|
||||
{ deviceToken,
|
||||
ntfServer,
|
||||
ntfTokenId = Nothing,
|
||||
ntfPubKey,
|
||||
ntfPrivKey,
|
||||
ntfDhKeys,
|
||||
ntfDhSecret = Nothing,
|
||||
ntfTknStatus = NTNew,
|
||||
ntfTknAction = Just $ NTARegister ntfPubKey
|
||||
}
|
||||
ntfTknAction = Just NTARegister
|
||||
}
|
||||
@@ -16,6 +16,7 @@ import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Kind
|
||||
import Data.Maybe (isNothing)
|
||||
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
|
||||
import Data.Type.Equality
|
||||
import Data.Word (Word16)
|
||||
import Database.SQLite.Simple.FromField (FromField (..))
|
||||
@@ -51,6 +52,7 @@ instance NtfEntityI 'Subscription where sNtfEntity = SSubscription
|
||||
data NtfCommandTag (e :: NtfEntity) where
|
||||
TNEW_ :: NtfCommandTag 'Token
|
||||
TVFY_ :: NtfCommandTag 'Token
|
||||
TCHK_ :: NtfCommandTag 'Token
|
||||
TDEL_ :: NtfCommandTag 'Token
|
||||
TCRN_ :: NtfCommandTag 'Token
|
||||
SNEW_ :: NtfCommandTag 'Subscription
|
||||
@@ -66,6 +68,7 @@ instance NtfEntityI e => Encoding (NtfCommandTag e) where
|
||||
smpEncode = \case
|
||||
TNEW_ -> "TNEW"
|
||||
TVFY_ -> "TVFY"
|
||||
TCHK_ -> "TCHK"
|
||||
TDEL_ -> "TDEL"
|
||||
TCRN_ -> "TCRN"
|
||||
SNEW_ -> "SNEW"
|
||||
@@ -82,6 +85,7 @@ instance ProtocolMsgTag NtfCmdTag where
|
||||
decodeTag = \case
|
||||
"TNEW" -> Just $ NCT SToken TNEW_
|
||||
"TVFY" -> Just $ NCT SToken TVFY_
|
||||
"TCHK" -> Just $ NCT SToken TCHK_
|
||||
"TDEL" -> Just $ NCT SToken TDEL_
|
||||
"TCRN" -> Just $ NCT SToken TCRN_
|
||||
"SNEW" -> Just $ NCT SSubscription SNEW_
|
||||
@@ -147,6 +151,8 @@ data NtfCommand (e :: NtfEntity) where
|
||||
TNEW :: NewNtfEntity 'Token -> NtfCommand 'Token
|
||||
-- | verify token - uses e2e encrypted random string sent to the device via PN to confirm that the device has the token
|
||||
TVFY :: NtfRegCode -> NtfCommand 'Token
|
||||
-- | check token status
|
||||
TCHK :: 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
|
||||
@@ -171,6 +177,7 @@ instance NtfEntityI e => ProtocolEncoding (NtfCommand e) where
|
||||
encodeProtocol = \case
|
||||
TNEW newTkn -> e (TNEW_, ' ', newTkn)
|
||||
TVFY code -> e (TVFY_, ' ', code)
|
||||
TCHK -> e TCHK_
|
||||
TDEL -> e TDEL_
|
||||
TCRN int -> e (TCRN_, ' ', int)
|
||||
SNEW newSub -> e (SNEW_, ' ', newSub)
|
||||
@@ -209,6 +216,7 @@ instance ProtocolEncoding NtfCmd where
|
||||
NtfCmd SToken <$> case tag of
|
||||
TNEW_ -> TNEW <$> _smpP
|
||||
TVFY_ -> TVFY <$> _smpP
|
||||
TCHK_ -> pure TCHK
|
||||
TDEL_ -> pure TDEL
|
||||
TCRN_ -> TCRN <$> _smpP
|
||||
NCT SSubscription tag ->
|
||||
@@ -224,7 +232,8 @@ data NtfResponseTag
|
||||
= NRId_
|
||||
| NROk_
|
||||
| NRErr_
|
||||
| NRStat_
|
||||
| NRTkn_
|
||||
| NRSub_
|
||||
| NRPong_
|
||||
deriving (Show)
|
||||
|
||||
@@ -233,7 +242,8 @@ instance Encoding NtfResponseTag where
|
||||
NRId_ -> "ID"
|
||||
NROk_ -> "OK"
|
||||
NRErr_ -> "ERR"
|
||||
NRStat_ -> "STAT"
|
||||
NRTkn_ -> "TKN"
|
||||
NRSub_ -> "SUB"
|
||||
NRPong_ -> "PONG"
|
||||
smpP = messageTagP
|
||||
|
||||
@@ -242,7 +252,8 @@ instance ProtocolMsgTag NtfResponseTag where
|
||||
"ID" -> Just NRId_
|
||||
"OK" -> Just NROk_
|
||||
"ERR" -> Just NRErr_
|
||||
"STAT" -> Just NRStat_
|
||||
"TKN" -> Just NRTkn_
|
||||
"SUB" -> Just NRSub_
|
||||
"PONG" -> Just NRPong_
|
||||
_ -> Nothing
|
||||
|
||||
@@ -250,7 +261,8 @@ data NtfResponse
|
||||
= NRId NtfEntityId C.PublicKeyX25519
|
||||
| NROk
|
||||
| NRErr ErrorType
|
||||
| NRStat NtfSubStatus
|
||||
| NRTkn NtfTknStatus
|
||||
| NRSub NtfSubStatus
|
||||
| NRPong
|
||||
|
||||
instance ProtocolEncoding NtfResponse where
|
||||
@@ -259,7 +271,8 @@ instance ProtocolEncoding NtfResponse where
|
||||
NRId entId dhKey -> e (NRId_, ' ', entId, dhKey)
|
||||
NROk -> e NROk_
|
||||
NRErr err -> e (NRErr_, ' ', err)
|
||||
NRStat stat -> e (NRStat_, ' ', stat)
|
||||
NRTkn stat -> e (NRTkn_, ' ', stat)
|
||||
NRSub stat -> e (NRSub_, ' ', stat)
|
||||
NRPong -> e NRPong_
|
||||
where
|
||||
e :: Encoding a => a -> ByteString
|
||||
@@ -269,7 +282,8 @@ instance ProtocolEncoding NtfResponse where
|
||||
NRId_ -> NRId <$> _smpP <*> smpP
|
||||
NROk_ -> pure NROk
|
||||
NRErr_ -> NRErr <$> _smpP
|
||||
NRStat_ -> NRStat <$> _smpP
|
||||
NRTkn_ -> NRTkn <$> _smpP
|
||||
NRSub_ -> NRSub <$> _smpP
|
||||
NRPong_ -> pure NRPong
|
||||
|
||||
checkCredentials (_, _, entId, _) cmd = case cmd of
|
||||
@@ -301,22 +315,22 @@ instance Encoding SMPQueueNtf where
|
||||
(smpServer, notifierId, notifierKey) <- smpP
|
||||
pure $ SMPQueueNtf smpServer notifierId notifierKey
|
||||
|
||||
data PushProvider = PPApple
|
||||
data PushProvider = PPApns
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
instance Encoding PushProvider where
|
||||
smpEncode = \case
|
||||
PPApple -> "A"
|
||||
PPApns -> "A"
|
||||
smpP =
|
||||
A.anyChar >>= \case
|
||||
'A' -> pure PPApple
|
||||
'A' -> pure PPApns
|
||||
_ -> fail "bad PushProvider"
|
||||
|
||||
instance TextEncoding PushProvider where
|
||||
textEncode = \case
|
||||
PPApple -> "apple"
|
||||
PPApns -> "apple"
|
||||
textDecode = \case
|
||||
"apple" -> Just PPApple
|
||||
"apple" -> Just PPApns
|
||||
_ -> Nothing
|
||||
|
||||
instance FromField PushProvider where fromField = fromTextField_ textDecode
|
||||
@@ -363,7 +377,7 @@ instance Encoding NtfSubStatus where
|
||||
"ACTIVE" -> pure NSActive
|
||||
"END" -> pure NSEnd
|
||||
"SMP_AUTH" -> pure NSSMPAuth
|
||||
_ -> fail "bad NtfError"
|
||||
_ -> fail "bad NtfSubStatus"
|
||||
|
||||
data NtfTknStatus
|
||||
= -- | Token created in DB
|
||||
@@ -380,26 +394,27 @@ data NtfTknStatus
|
||||
NTExpired
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance TextEncoding NtfTknStatus where
|
||||
textEncode = \case
|
||||
NTNew -> "new"
|
||||
NTRegistered -> "registered"
|
||||
NTInvalid -> "invalid"
|
||||
NTConfirmed -> "confirmed"
|
||||
NTActive -> "active"
|
||||
NTExpired -> "expired"
|
||||
textDecode = \case
|
||||
"new" -> Just NTNew
|
||||
"registered" -> Just NTRegistered
|
||||
"invalid" -> Just NTInvalid
|
||||
"confirmed" -> Just NTConfirmed
|
||||
"active" -> Just NTActive
|
||||
"expired" -> Just NTExpired
|
||||
_ -> Nothing
|
||||
instance Encoding NtfTknStatus where
|
||||
smpEncode = \case
|
||||
NTNew -> "NEW"
|
||||
NTRegistered -> "REGISTERED"
|
||||
NTInvalid -> "INVALID"
|
||||
NTConfirmed -> "CONFIRMED"
|
||||
NTActive -> "ACTIVE"
|
||||
NTExpired -> "EXPIRED"
|
||||
smpP =
|
||||
A.takeTill (== ' ') >>= \case
|
||||
"NEW" -> pure NTNew
|
||||
"REGISTERED" -> pure NTRegistered
|
||||
"INVALID" -> pure NTInvalid
|
||||
"CONFIRMED" -> pure NTConfirmed
|
||||
"ACTIVE" -> pure NTActive
|
||||
"EXPIRED" -> pure NTExpired
|
||||
_ -> fail "bad NtfTknStatus"
|
||||
|
||||
instance FromField NtfTknStatus where fromField = fromTextField_ textDecode
|
||||
instance FromField NtfTknStatus where fromField = fromTextField_ $ either (const Nothing) Just . smpDecode . encodeUtf8
|
||||
|
||||
instance ToField NtfTknStatus where toField = toField . textEncode
|
||||
instance ToField NtfTknStatus where toField = toField . decodeLatin1 . smpEncode
|
||||
|
||||
checkEntity :: forall t e e'. (NtfEntityI e, NtfEntityI e') => t e' -> Either String (t e)
|
||||
checkEntity c = case testEquality (sNtfEntity @e) (sNtfEntity @e') of
|
||||
|
||||
@@ -10,11 +10,13 @@
|
||||
|
||||
module Simplex.Messaging.Notifications.Server where
|
||||
|
||||
import Control.Logger.Simple
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.IO.Unlift (MonadUnliftIO)
|
||||
import Control.Monad.Reader
|
||||
import Crypto.Random (MonadRandom)
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.Text as T
|
||||
import Network.Socket (ServiceName)
|
||||
import Simplex.Messaging.Client.Agent
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
@@ -26,9 +28,12 @@ import Simplex.Messaging.Notifications.Transport
|
||||
import Simplex.Messaging.Protocol (ErrorType (..), SignedTransmission, Transmission, encodeTransmission, tGet, tPut)
|
||||
import qualified Simplex.Messaging.Protocol as SMP
|
||||
import Simplex.Messaging.Server
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Transport (ATransport (..), THandle (..), TProxy, Transport)
|
||||
import Simplex.Messaging.Transport.Server (runTransportServer)
|
||||
import Simplex.Messaging.Util
|
||||
import UnliftIO (async, uninterruptibleCancel)
|
||||
import UnliftIO.Concurrent (threadDelay)
|
||||
import UnliftIO.Exception
|
||||
import UnliftIO.STM
|
||||
|
||||
@@ -106,7 +111,7 @@ ntfSubscriber NtfSubscriber {subQ, smpAgent = ca@SMPClientAgent {msgQ, agentQ}}
|
||||
ntfPush :: MonadUnliftIO m => NtfPushServer -> m ()
|
||||
ntfPush s@NtfPushServer {pushQ} = liftIO . forever . runExceptT $ do
|
||||
(tkn@NtfTknData {token = DeviceToken pp _, tknStatus}, ntf) <- atomically (readTBQueue pushQ)
|
||||
liftIO $ putStrLn $ "sending push notification to " <> show pp
|
||||
logDebug $ "sending push notification to " <> T.pack (show pp)
|
||||
status <- readTVarIO tknStatus
|
||||
case (status, ntf) of
|
||||
(_, PNVerification _) -> do
|
||||
@@ -116,13 +121,13 @@ ntfPush s@NtfPushServer {pushQ} = liftIO . forever . runExceptT $ do
|
||||
(NTActive, PNCheckMessages) -> do
|
||||
deliverNotification pp tkn ntf
|
||||
_ -> do
|
||||
liftIO $ putStrLn "bad notification token status"
|
||||
logError "bad notification token status"
|
||||
where
|
||||
deliverNotification :: PushProvider -> PushProviderClient
|
||||
deliverNotification pp tkn ntf = do
|
||||
deliver <- liftIO $ getPushClient s pp
|
||||
-- TODO retry later based on the error
|
||||
deliver tkn ntf `catchError` \e -> liftIO (putStrLn $ "Push provider error (" <> show pp <> "): " <> show e) >> throwError e
|
||||
deliver tkn ntf `catchError` \e -> logError (T.pack $ "Push provider error (" <> show pp <> "): " <> show e) >> throwError e
|
||||
|
||||
runNtfClientTransport :: (Transport c, MonadUnliftIO m, MonadReader NtfEnv m) => THandle c -> m ()
|
||||
runNtfClientTransport th@THandle {sessionId} = do
|
||||
@@ -138,14 +143,14 @@ clientDisconnected NtfServerClient {connected} = atomically $ writeTVar connecte
|
||||
|
||||
receive :: (Transport c, MonadUnliftIO m, MonadReader NtfEnv m) => THandle c -> NtfServerClient -> m ()
|
||||
receive th NtfServerClient {rcvQ, sndQ} = forever $ do
|
||||
t@(_, _, (corrId, subId, cmdOrError)) <- tGet th
|
||||
liftIO $ putStrLn "receive"
|
||||
t@(_, _, (corrId, entId, cmdOrError)) <- tGet th
|
||||
logDebug "received transmission"
|
||||
case cmdOrError of
|
||||
Left e -> write sndQ (corrId, subId, NRErr e)
|
||||
Left e -> write sndQ (corrId, entId, NRErr e)
|
||||
Right cmd ->
|
||||
verifyNtfTransmission t cmd >>= \case
|
||||
VRVerified req -> write rcvQ req
|
||||
VRFailed -> write sndQ (corrId, subId, NRErr AUTH)
|
||||
VRFailed -> write sndQ (corrId, entId, NRErr AUTH)
|
||||
where
|
||||
write q t = atomically $ writeTBQueue q t
|
||||
|
||||
@@ -159,41 +164,31 @@ data VerificationResult = VRVerified NtfRequest | VRFailed
|
||||
verifyNtfTransmission ::
|
||||
forall m. (MonadUnliftIO m, MonadReader NtfEnv m) => SignedTransmission NtfCmd -> NtfCmd -> m VerificationResult
|
||||
verifyNtfTransmission (sig_, signed, (corrId, entId, _)) cmd = do
|
||||
st <- asks store
|
||||
case cmd of
|
||||
NtfCmd SToken (TNEW n@(NewNtfTkn _ k _)) ->
|
||||
-- TODO check that token is not already in store, if it is - verify that the saved key is the same
|
||||
NtfCmd SToken c@(TNEW n@(NewNtfTkn _ k _)) -> do
|
||||
r_ <- atomically $ getNtfToken st entId
|
||||
pure $
|
||||
if verifyCmdSignature sig_ signed k
|
||||
then VRVerified (NtfReqNew corrId (ANE SToken n))
|
||||
then case r_ of
|
||||
Just r@(NtfTkn NtfTknData {tknVerifyKey})
|
||||
| k == tknVerifyKey -> tknCmd r c
|
||||
| otherwise -> VRFailed
|
||||
_ -> VRVerified (NtfReqNew corrId (ANE SToken n))
|
||||
else VRFailed
|
||||
NtfCmd SToken c -> do
|
||||
st <- asks store
|
||||
atomically (getNtfToken st entId) >>= \case
|
||||
Just r@(NtfTkn NtfTknData {tknVerifyKey}) ->
|
||||
pure $
|
||||
if verifyCmdSignature sig_ signed tknVerifyKey
|
||||
then VRVerified (NtfReqCmd SToken r (corrId, entId, c))
|
||||
else VRFailed
|
||||
_ -> pure VRFailed -- TODO dummy verification
|
||||
r_ <- atomically $ getNtfToken st entId
|
||||
pure $ case r_ of
|
||||
Just r@(NtfTkn NtfTknData {tknVerifyKey})
|
||||
| verifyCmdSignature sig_ signed tknVerifyKey -> tknCmd r c
|
||||
| otherwise -> VRFailed
|
||||
_ -> maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed
|
||||
_ -> pure VRFailed
|
||||
|
||||
-- do
|
||||
-- st <- asks store
|
||||
-- case cmd of
|
||||
-- NCSubCreate tokenId smpQueue -> verifyCreateCmd verifyKey newSub <$> atomically (getNtfSubViaSMPQueue st smpQueue)
|
||||
-- _ -> verifySubCmd <$> atomically (getNtfSub st subId)
|
||||
-- where
|
||||
-- verifyCreateCmd k newSub sub_
|
||||
-- | verifyCmdSignature sig_ signed k = case sub_ of
|
||||
-- Just sub -> if k == subVerifyKey sub then VRCommand sub else VRFail
|
||||
-- _ -> VRCreate newSub
|
||||
-- | otherwise = VRFail
|
||||
-- verifySubCmd = \case
|
||||
-- Just sub -> if verifyCmdSignature sig_ signed $ subVerifyKey sub then VRCommand sub else VRFail
|
||||
-- _ -> maybe False (dummyVerifyCmd signed) sig_ `seq` VRFail
|
||||
where
|
||||
tknCmd r c = VRVerified (NtfReqCmd SToken r (corrId, entId, c))
|
||||
|
||||
client :: forall m. (MonadUnliftIO m, MonadReader NtfEnv m) => NtfServerClient -> NtfSubscriber -> NtfPushServer -> m ()
|
||||
client NtfServerClient {rcvQ, sndQ} NtfSubscriber {subQ = _} NtfPushServer {pushQ} =
|
||||
client NtfServerClient {rcvQ, sndQ} NtfSubscriber {subQ = _} NtfPushServer {pushQ, intervalNotifiers} =
|
||||
forever $
|
||||
atomically (readTBQueue rcvQ)
|
||||
>>= processCommand
|
||||
@@ -202,30 +197,68 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {subQ = _} NtfPushServer {push
|
||||
processCommand :: NtfRequest -> m (Transmission NtfResponse)
|
||||
processCommand = \case
|
||||
NtfReqNew corrId (ANE SToken newTkn@(NewNtfTkn _ _ dhPubKey)) -> do
|
||||
liftIO $ putStrLn "TNEW"
|
||||
logDebug "TNEW - new token"
|
||||
st <- asks store
|
||||
(srvDhPubKey, srvDrivDhKey) <- liftIO C.generateKeyPair'
|
||||
let dhSecret = C.dh' dhPubKey srvDrivDhKey
|
||||
ks@(srvDhPubKey, srvDhPrivKey) <- liftIO C.generateKeyPair'
|
||||
let dhSecret = C.dh' dhPubKey srvDhPrivKey
|
||||
tknId <- getId
|
||||
regCode <- getRegCode
|
||||
atomically $ do
|
||||
tkn <- mkNtfTknData newTkn dhSecret regCode
|
||||
tkn <- mkNtfTknData newTkn ks dhSecret regCode
|
||||
addNtfToken st tknId tkn
|
||||
writeTBQueue pushQ (tkn, PNVerification regCode)
|
||||
pure (corrId, "", NRId tknId srvDhPubKey)
|
||||
NtfReqCmd SToken (NtfTkn NtfTknData {tknStatus, tknRegCode}) (corrId, tknId, cmd) -> do
|
||||
NtfReqCmd SToken (NtfTkn tkn@NtfTknData {tknStatus, tknRegCode, tknDhSecret, tknDhKeys = (srvDhPubKey, srvDhPrivKey)}) (corrId, tknId, cmd) -> do
|
||||
status <- readTVarIO tknStatus
|
||||
(corrId,tknId,) <$> case cmd of
|
||||
TNEW _newTkn -> do
|
||||
liftIO $ putStrLn "TNEW'"
|
||||
pure NROk -- TODO when duplicate token sent
|
||||
TNEW (NewNtfTkn _ _ dhPubKey) -> do
|
||||
logDebug "TNEW - registered token"
|
||||
let dhSecret = C.dh' dhPubKey srvDhPrivKey
|
||||
-- it is required that DH secret is the same, to avoid failed verifications if notification is delaying
|
||||
if tknDhSecret == dhSecret
|
||||
then do
|
||||
atomically $ writeTBQueue pushQ (tkn, PNVerification tknRegCode)
|
||||
pure $ NRId tknId srvDhPubKey
|
||||
else pure $ NRErr AUTH
|
||||
TVFY code -- this allows repeated verification for cases when client connection dropped before server response
|
||||
| (status == NTRegistered || status == NTConfirmed || status == NTActive) && tknRegCode == code -> do
|
||||
logDebug "TVFY - token verified"
|
||||
atomically $ writeTVar tknStatus NTActive
|
||||
pure NROk
|
||||
| otherwise -> pure $ NRErr AUTH
|
||||
TDEL -> pure NROk
|
||||
TCRN _int -> pure NROk
|
||||
| otherwise -> do
|
||||
logDebug "TVFY - incorrect code or token status"
|
||||
pure $ NRErr AUTH
|
||||
TCHK -> pure $ NRTkn status
|
||||
TDEL -> do
|
||||
logDebug "TDEL"
|
||||
st <- asks store
|
||||
atomically $ deleteNtfToken st tknId
|
||||
pure NROk
|
||||
TCRN 0 ->
|
||||
logDebug "TCRN 0"
|
||||
>> atomically (TM.lookupDelete tknId intervalNotifiers)
|
||||
>>= mapM_ (uninterruptibleCancel . action)
|
||||
>> pure NROk
|
||||
TCRN int
|
||||
| int < 20 -> pure $ NRErr QUOTA
|
||||
| otherwise -> do
|
||||
logDebug "TCRN"
|
||||
atomically (TM.lookup tknId intervalNotifiers) >>= \case
|
||||
Nothing -> runIntervalNotifier int
|
||||
Just IntervalNotifier {interval, action} ->
|
||||
unless (interval == int) $ do
|
||||
uninterruptibleCancel action
|
||||
runIntervalNotifier int
|
||||
pure NROk
|
||||
where
|
||||
runIntervalNotifier interval = do
|
||||
action <- async . intervalNotifier $ fromIntegral interval * 1000000 * 60
|
||||
let notifier = IntervalNotifier {action, token = tkn, interval}
|
||||
atomically $ TM.insert tknId notifier intervalNotifiers
|
||||
where
|
||||
intervalNotifier delay = forever $ do
|
||||
threadDelay delay
|
||||
atomically $ writeTBQueue pushQ (tkn, PNCheckMessages)
|
||||
NtfReqNew corrId (ANE SSubscription _newSub) -> pure (corrId, "", NROk)
|
||||
NtfReqCmd SSubscription _sub (corrId, subId, cmd) ->
|
||||
(corrId,subId,) <$> case cmd of
|
||||
|
||||
@@ -7,9 +7,11 @@
|
||||
|
||||
module Simplex.Messaging.Notifications.Server.Env where
|
||||
|
||||
import Control.Concurrent.Async (Async)
|
||||
import Control.Monad.IO.Unlift
|
||||
import Crypto.Random
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import Data.Word (Word16)
|
||||
import Data.X509.Validation (Fingerprint (..))
|
||||
import Network.Socket
|
||||
import qualified Network.TLS as T
|
||||
@@ -59,7 +61,7 @@ newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsCo
|
||||
subscriber <- atomically $ newNtfSubscriber subQSize smpAgentCfg
|
||||
pushServer <- atomically $ newNtfPushServer pushQSize apnsConfig
|
||||
-- TODO not creating APNS client on start to pass CI test, has to be replaced with mock APNS server
|
||||
-- void . liftIO $ newPushClient pushServer PPApple
|
||||
-- void . liftIO $ newPushClient pushServer PPApns
|
||||
tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile
|
||||
Fingerprint fp <- liftIO $ loadFingerprint caCertificateFile
|
||||
pure NtfEnv {config, subscriber, pushServer, store, idsDrg, tlsServerParams, serverIdentity = C.KeyHash fp}
|
||||
@@ -78,20 +80,28 @@ newNtfSubscriber qSize smpAgentCfg = do
|
||||
data NtfPushServer = NtfPushServer
|
||||
{ pushQ :: TBQueue (NtfTknData, PushNotification),
|
||||
pushClients :: TMap PushProvider PushProviderClient,
|
||||
intervalNotifiers :: TMap NtfTokenId IntervalNotifier,
|
||||
apnsConfig :: APNSPushClientConfig
|
||||
}
|
||||
|
||||
data IntervalNotifier = IntervalNotifier
|
||||
{ action :: Async (),
|
||||
token :: NtfTknData,
|
||||
interval :: Word16
|
||||
}
|
||||
|
||||
newNtfPushServer :: Natural -> APNSPushClientConfig -> STM NtfPushServer
|
||||
newNtfPushServer qSize apnsConfig = do
|
||||
pushQ <- newTBQueue qSize
|
||||
pushClients <- TM.empty
|
||||
pure NtfPushServer {pushQ, pushClients, apnsConfig}
|
||||
intervalNotifiers <- TM.empty
|
||||
pure NtfPushServer {pushQ, pushClients, intervalNotifiers, apnsConfig}
|
||||
|
||||
newPushClient :: NtfPushServer -> PushProvider -> IO PushProviderClient
|
||||
newPushClient NtfPushServer {apnsConfig, pushClients} = \case
|
||||
PPApple -> do
|
||||
PPApns -> do
|
||||
c <- apnsPushProviderClient <$> createAPNSPushClient apnsConfig
|
||||
atomically $ TM.insert PPApple c pushClients
|
||||
atomically $ TM.insert PPApns c pushClients
|
||||
pure c
|
||||
|
||||
getPushClient :: NtfPushServer -> PushProvider -> IO PushProviderClient
|
||||
|
||||
@@ -1,12 +1,16 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
|
||||
|
||||
{-# HLINT ignore "Use newtype instead of data" #-}
|
||||
|
||||
module Simplex.Messaging.Notifications.Server.Push.APNS where
|
||||
|
||||
import Control.Logger.Simple
|
||||
import Control.Monad.Except
|
||||
import Crypto.Hash.Algorithms (SHA256 (..))
|
||||
import qualified Crypto.PubKey.ECC.ECDSA as EC
|
||||
@@ -20,6 +24,7 @@ import Data.Aeson (FromJSON, ToJSON, (.=))
|
||||
import qualified Data.Aeson as J
|
||||
import qualified Data.Aeson.Encoding as JE
|
||||
import Data.Bifunctor (first)
|
||||
import qualified Data.ByteString.Base64 as B64
|
||||
import qualified Data.ByteString.Base64.URL as U
|
||||
import Data.ByteString.Builder (lazyByteString)
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
@@ -27,7 +32,6 @@ import qualified Data.ByteString.Lazy.Char8 as LB
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import Data.Int (Int64)
|
||||
import Data.Map.Strict (Map)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (decodeUtf8With)
|
||||
@@ -226,7 +230,7 @@ getApnsJWTToken APNSPushClient {apnsCfg = APNSPushClientConfig {appTeamId, token
|
||||
atomically $ writeTVar jwtToken t
|
||||
pure signedJWT'
|
||||
where
|
||||
jwtTokenAge (JWTToken _ JWTClaims {iat}) = (iat -) . systemSeconds <$> getSystemTime
|
||||
jwtTokenAge (JWTToken _ JWTClaims {iat}) = subtract iat . systemSeconds <$> getSystemTime
|
||||
|
||||
mkApnsJWTToken :: Text -> JWTHeader -> EC.PrivateKey -> IO (JWTToken, SignedJWTToken)
|
||||
mkApnsJWTToken appTeamId jwtHeader privateKey = do
|
||||
@@ -256,15 +260,15 @@ apnsNotification :: NtfTknData -> C.CbNonce -> Int -> PushNotification -> Either
|
||||
apnsNotification NtfTknData {tknDhSecret} nonce paddedLen = \case
|
||||
PNVerification (NtfRegCode code) ->
|
||||
encrypt code $ \code' ->
|
||||
apn APNSBackground {contentAvailable = 1} . Just $ J.object ["verification" .= code']
|
||||
apn APNSBackground {contentAvailable = 1} . Just $ J.object ["verification" .= code', "nonce" .= nonce]
|
||||
PNMessage srv nId ->
|
||||
encrypt (strEncode srv <> "/" <> strEncode nId) $ \ntfQueue ->
|
||||
apn apnMutableContent . Just $ J.object ["checkMessage" .= ntfQueue]
|
||||
apn apnMutableContent . Just $ J.object ["checkMessage" .= ntfQueue, "nonce" .= nonce]
|
||||
PNAlert text -> Right $ apn (apnAlert $ APNSAlertText text) Nothing
|
||||
PNCheckMessages -> Right $ apn APNSBackground {contentAvailable = 1} . Just $ J.object ["checkMessages" .= True]
|
||||
where
|
||||
encrypt :: ByteString -> (Text -> APNSNotification) -> Either C.CryptoError APNSNotification
|
||||
encrypt ntfData f = f . safeDecodeUtf8 . U.encode <$> C.cbEncrypt tknDhSecret nonce ntfData paddedLen
|
||||
encrypt ntfData f = f . safeDecodeUtf8 . B64.encode <$> C.cbEncrypt tknDhSecret nonce ntfData paddedLen
|
||||
apn aps notificationData = APNSNotification {aps, notificationData}
|
||||
apnMutableContent = APNSMutableContent {mutableContent = 1, alert = APNSAlertText "Encrypted message or some other app event", category = Nothing}
|
||||
apnAlert alert = APNSAlert {alert, badge = Nothing, sound = Nothing, category = Nothing}
|
||||
@@ -300,40 +304,39 @@ data PushProviderError
|
||||
|
||||
type PushProviderClient = NtfTknData -> PushNotification -> ExceptT PushProviderError IO ()
|
||||
|
||||
newtype APNSErrorReponse = APNSErrorReponse {reason :: Text}
|
||||
-- this is not a newtype on purpose to have a correct JSON encoding as a record
|
||||
data APNSErrorReponse = APNSErrorReponse {reason :: Text}
|
||||
deriving (Generic, FromJSON)
|
||||
|
||||
apnsPushProviderClient :: APNSPushClient -> PushProviderClient
|
||||
apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknData {token = DeviceToken PPApple tknStr} pn = do
|
||||
apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknData {token = DeviceToken PPApns tknStr} pn = do
|
||||
http2 <- liftHTTPS2 $ getApnsHTTP2Client c
|
||||
nonce <- atomically $ C.pseudoRandomCbNonce nonceDrg
|
||||
apnsNtf <- liftEither $ first PPCryptoError $ apnsNotification tkn nonce (paddedNtfLength apnsCfg) pn
|
||||
liftIO $ putStrLn $ "APNS notification: " <> show apnsNtf
|
||||
req <- liftIO $ apnsRequest c tknStr apnsNtf
|
||||
liftIO $ putStrLn $ "APNS request: " <> show req
|
||||
HTTP2Response {response, respBody} <- liftHTTPS2 $ sendRequest http2 req
|
||||
let status = H.responseStatus response
|
||||
reason = fromMaybe "" $ J.decodeStrict' =<< respBody
|
||||
liftIO $ putStrLn $ "APNS response: " <> show status <> " " <> T.unpack reason
|
||||
result status reason
|
||||
reason' = maybe "?" reason $ J.decodeStrict' respBody
|
||||
logDebug $ "APNS response: " <> T.pack (show status) <> " " <> reason'
|
||||
result status reason'
|
||||
where
|
||||
result :: Maybe Status -> Text -> ExceptT PushProviderError IO ()
|
||||
result status reason
|
||||
result status reason'
|
||||
| status == Just N.ok200 = pure ()
|
||||
| status == Just N.badRequest400 =
|
||||
case reason of
|
||||
case reason' of
|
||||
"BadDeviceToken" -> throwError PPTokenInvalid
|
||||
"DeviceTokenNotForTopic" -> throwError PPTokenInvalid
|
||||
"TopicDisallowed" -> throwError PPPermanentError
|
||||
_ -> err status reason
|
||||
| status == Just N.forbidden403 = case reason of
|
||||
_ -> err status reason'
|
||||
| status == Just N.forbidden403 = case reason' of
|
||||
"ExpiredProviderToken" -> throwError PPPermanentError -- there should be no point retrying it as the token was refreshed
|
||||
"InvalidProviderToken" -> throwError PPPermanentError
|
||||
_ -> err status reason
|
||||
_ -> err status reason'
|
||||
| status == Just N.gone410 = throwError PPTokenInvalid
|
||||
| status == Just N.serviceUnavailable503 = liftIO (disconnectApnsHTTP2Client c) >> throwError PPRetryLater
|
||||
-- Just tooManyRequests429 -> TODO TooManyRequests - too many requests for the same token
|
||||
| otherwise = err status reason
|
||||
| otherwise = err status reason'
|
||||
err :: Maybe Status -> Text -> ExceptT PushProviderError IO ()
|
||||
err s r = throwError $ PPResponseError s r
|
||||
liftHTTPS2 a = ExceptT $ first PPConnection <$> a
|
||||
|
||||
@@ -28,14 +28,15 @@ data NtfTknData = NtfTknData
|
||||
{ token :: DeviceToken,
|
||||
tknStatus :: TVar NtfTknStatus,
|
||||
tknVerifyKey :: C.APublicVerifyKey,
|
||||
tknDhKeys :: C.KeyPair 'C.X25519,
|
||||
tknDhSecret :: C.DhSecretX25519,
|
||||
tknRegCode :: NtfRegCode
|
||||
}
|
||||
|
||||
mkNtfTknData :: NewNtfEntity 'Token -> C.DhSecretX25519 -> NtfRegCode -> STM NtfTknData
|
||||
mkNtfTknData (NewNtfTkn token tknVerifyKey _) tknDhSecret tknRegCode = do
|
||||
mkNtfTknData :: NewNtfEntity 'Token -> C.KeyPair 'C.X25519 -> C.DhSecretX25519 -> NtfRegCode -> STM NtfTknData
|
||||
mkNtfTknData (NewNtfTkn token tknVerifyKey _) tknDhKeys tknDhSecret tknRegCode = do
|
||||
tknStatus <- newTVar NTRegistered
|
||||
pure NtfTknData {token, tknStatus, tknVerifyKey, tknDhSecret, tknRegCode}
|
||||
pure NtfTknData {token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode}
|
||||
|
||||
-- data NtfSubscriptionsStore = NtfSubscriptionsStore
|
||||
|
||||
@@ -64,8 +65,12 @@ getNtfToken st tknId = NtfTkn <$$> TM.lookup tknId (tokens st)
|
||||
|
||||
addNtfToken :: NtfStore -> NtfTokenId -> NtfTknData -> STM ()
|
||||
addNtfToken st tknId tkn@NtfTknData {token} = do
|
||||
TM.insert tknId tkn (tokens st)
|
||||
TM.insert token tknId (tokenIds st)
|
||||
TM.insert tknId tkn $ tokens st
|
||||
TM.insert token tknId $ tokenIds st
|
||||
|
||||
deleteNtfToken :: NtfStore -> NtfTokenId -> STM ()
|
||||
deleteNtfToken st tknId = do
|
||||
TM.lookupDelete tknId (tokens st) >>= mapM_ (\NtfTknData {token} -> TM.delete token $ tokenIds st)
|
||||
|
||||
-- getNtfRec :: NtfStore -> SNtfEntity e -> NtfEntityId -> STM (Maybe (NtfEntityRec e))
|
||||
-- getNtfRec st ent entId = case ent of
|
||||
|
||||
Reference in new issue
Block a user