mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-05-31 00:34:35 +00:00
ntf server implementation, updated ntf protocol, ntf client based on refactored protocol client, bare-bones SMP agent to manage ntf connections (to connect to ntf server) (#338)
* process ntf server commands * when subscription is re-created and it was ENDed, resubscribe to SMP * SMPClientAgent draft * SMPClientAgent: remove double tracking of subscriptions * subscriber frame * PING error now throws error to restart SMPClient for more reliable re-connection (#342) * increase TCP timeout to 5 sec * add pragmas and vacuum db (#343) * vacuum in each connection to enable auto-vacuum (#344) * update protocol, token verification * refactor SMPClient to ProtocoClient, to use with notification server protocol * notification server client, managing notification clients in the agent * stub for push payload Co-authored-by: JRoberts <8711996+jr-simplex@users.noreply.github.com>
This commit is contained in:
Evgeny Poberezkin
committed by
GitHub
GitHub
parent
4e1184d9eb
commit
d31958855f
@@ -0,0 +1,55 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Simplex.Messaging.Notifications.Client where
|
||||
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Trans.Except
|
||||
import Data.Word (Word16)
|
||||
import Simplex.Messaging.Client
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Notifications.Protocol
|
||||
|
||||
type NtfClient = ProtocolClient NtfResponse
|
||||
|
||||
registerNtfToken :: NtfClient -> C.APrivateSignKey -> NewNtfEntity 'Token -> ExceptT ProtocolClientError IO (NtfTokenId, C.PublicKeyX25519)
|
||||
registerNtfToken c pKey newTkn =
|
||||
sendNtfCommand c (Just pKey) "" (TNEW newTkn) >>= \case
|
||||
NRId tknId dhKey -> pure (tknId, dhKey)
|
||||
_ -> throwE PCEUnexpectedResponse
|
||||
|
||||
verifyNtfToken :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> NtfRegistrationCode -> ExceptT ProtocolClientError IO ()
|
||||
verifyNtfToken c pKey tknId code = okNtfCommand (TVFY code) c pKey tknId
|
||||
|
||||
deleteNtfToken :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> ExceptT ProtocolClientError IO ()
|
||||
deleteNtfToken = okNtfCommand TDEL
|
||||
|
||||
enableNtfCron :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> Word16 -> ExceptT ProtocolClientError IO ()
|
||||
enableNtfCron c pKey tknId int = okNtfCommand (TCRN int) c pKey tknId
|
||||
|
||||
createNtfSubsciption :: NtfClient -> C.APrivateSignKey -> NewNtfEntity 'Subscription -> ExceptT ProtocolClientError IO (NtfSubscriptionId, C.PublicKeyX25519)
|
||||
createNtfSubsciption c pKey newSub =
|
||||
sendNtfCommand c (Just pKey) "" (SNEW newSub) >>= \case
|
||||
NRId tknId dhKey -> pure (tknId, dhKey)
|
||||
_ -> throwE PCEUnexpectedResponse
|
||||
|
||||
checkNtfSubscription :: NtfClient -> C.APrivateSignKey -> NtfSubscriptionId -> ExceptT ProtocolClientError IO NtfSubStatus
|
||||
checkNtfSubscription c pKey subId =
|
||||
sendNtfCommand c (Just pKey) subId SCHK >>= \case
|
||||
NRStat stat -> pure stat
|
||||
_ -> throwE PCEUnexpectedResponse
|
||||
|
||||
deleteNfgSubscription :: NtfClient -> C.APrivateSignKey -> NtfSubscriptionId -> ExceptT ProtocolClientError IO ()
|
||||
deleteNfgSubscription = okNtfCommand SDEL
|
||||
|
||||
-- | Send notification server command
|
||||
sendNtfCommand :: NtfEntityI e => NtfClient -> Maybe C.APrivateSignKey -> NtfEntityId -> NtfCommand e -> ExceptT ProtocolClientError IO NtfResponse
|
||||
sendNtfCommand c pKey entId = sendProtocolCommand c pKey entId . NtfCmd sNtfEntity
|
||||
|
||||
okNtfCommand :: NtfEntityI e => NtfCommand e -> NtfClient -> C.APrivateSignKey -> NtfEntityId -> ExceptT ProtocolClientError IO ()
|
||||
okNtfCommand cmd c pKey entId =
|
||||
sendNtfCommand c (Just pKey) entId cmd >>= \case
|
||||
NROk -> return ()
|
||||
_ -> throwE PCEUnexpectedResponse
|
||||
@@ -1,6 +1,11 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module Simplex.Messaging.Notifications.Protocol where
|
||||
@@ -8,154 +13,333 @@ module Simplex.Messaging.Notifications.Protocol where
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Kind
|
||||
import Data.Maybe (isNothing)
|
||||
import Data.Type.Equality
|
||||
import Data.Word (Word16)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Protocol
|
||||
import Simplex.Messaging.Protocol hiding (Command (..), CommandTag (..))
|
||||
import Simplex.Messaging.Util ((<$?>))
|
||||
|
||||
data NtfCommandTag
|
||||
= NCCreate_
|
||||
| NCCheck_
|
||||
| NCToken_
|
||||
| NCDelete_
|
||||
data NtfEntity = Token | Subscription
|
||||
deriving (Show)
|
||||
|
||||
instance Encoding NtfCommandTag where
|
||||
data SNtfEntity :: NtfEntity -> Type where
|
||||
SToken :: SNtfEntity 'Token
|
||||
SSubscription :: SNtfEntity 'Subscription
|
||||
|
||||
instance TestEquality SNtfEntity where
|
||||
testEquality SToken SToken = Just Refl
|
||||
testEquality SSubscription SSubscription = Just Refl
|
||||
testEquality _ _ = Nothing
|
||||
|
||||
deriving instance Show (SNtfEntity e)
|
||||
|
||||
class NtfEntityI (e :: NtfEntity) where sNtfEntity :: SNtfEntity e
|
||||
|
||||
instance NtfEntityI 'Token where sNtfEntity = SToken
|
||||
|
||||
instance NtfEntityI 'Subscription where sNtfEntity = SSubscription
|
||||
|
||||
data NtfCommandTag (e :: NtfEntity) where
|
||||
TNEW_ :: NtfCommandTag 'Token
|
||||
TVFY_ :: NtfCommandTag 'Token
|
||||
TDEL_ :: NtfCommandTag 'Token
|
||||
TCRN_ :: NtfCommandTag 'Token
|
||||
SNEW_ :: NtfCommandTag 'Subscription
|
||||
SCHK_ :: NtfCommandTag 'Subscription
|
||||
SDEL_ :: NtfCommandTag 'Subscription
|
||||
PING_ :: NtfCommandTag 'Subscription
|
||||
|
||||
deriving instance Show (NtfCommandTag e)
|
||||
|
||||
data NtfCmdTag = forall e. NtfEntityI e => NCT (SNtfEntity e) (NtfCommandTag e)
|
||||
|
||||
instance NtfEntityI e => Encoding (NtfCommandTag e) where
|
||||
smpEncode = \case
|
||||
NCCreate_ -> "CREATE"
|
||||
NCCheck_ -> "CHECK"
|
||||
NCToken_ -> "TOKEN"
|
||||
NCDelete_ -> "DELETE"
|
||||
TNEW_ -> "TNEW"
|
||||
TVFY_ -> "TVFY"
|
||||
TDEL_ -> "TDEL"
|
||||
TCRN_ -> "TCRN"
|
||||
SNEW_ -> "SNEW"
|
||||
SCHK_ -> "SCHK"
|
||||
SDEL_ -> "SDEL"
|
||||
PING_ -> "PING"
|
||||
smpP = messageTagP
|
||||
|
||||
instance ProtocolMsgTag NtfCommandTag where
|
||||
instance Encoding NtfCmdTag where
|
||||
smpEncode (NCT _ t) = smpEncode t
|
||||
smpP = messageTagP
|
||||
|
||||
instance ProtocolMsgTag NtfCmdTag where
|
||||
decodeTag = \case
|
||||
"CREATE" -> Just NCCreate_
|
||||
"CHECK" -> Just NCCheck_
|
||||
"TOKEN" -> Just NCToken_
|
||||
"DELETE" -> Just NCDelete_
|
||||
"TNEW" -> Just $ NCT SToken TNEW_
|
||||
"TVFY" -> Just $ NCT SToken TVFY_
|
||||
"TDEL" -> Just $ NCT SToken TDEL_
|
||||
"TCRN" -> Just $ NCT SToken TCRN_
|
||||
"SNEW" -> Just $ NCT SSubscription SNEW_
|
||||
"SCHK" -> Just $ NCT SSubscription SCHK_
|
||||
"SDEL" -> Just $ NCT SSubscription SDEL_
|
||||
"PING" -> Just $ NCT SSubscription PING_
|
||||
_ -> Nothing
|
||||
|
||||
data NtfCommand
|
||||
= NCCreate DeviceToken SMPQueueNtfUri C.APublicVerifyKey C.PublicKeyX25519
|
||||
| NCCheck
|
||||
| NCToken DeviceToken
|
||||
| NCDelete
|
||||
instance NtfEntityI e => ProtocolMsgTag (NtfCommandTag e) where
|
||||
decodeTag s = decodeTag s >>= (\(NCT _ t) -> checkEntity' t)
|
||||
|
||||
instance Protocol NtfCommand where
|
||||
type Tag NtfCommand = NtfCommandTag
|
||||
type NtfRegistrationCode = ByteString
|
||||
|
||||
data NewNtfEntity (e :: NtfEntity) where
|
||||
NewNtfTkn :: DeviceToken -> C.APublicVerifyKey -> C.PublicKeyX25519 -> NewNtfEntity 'Token
|
||||
NewNtfSub :: NtfTokenId -> SMPQueueNtf -> NewNtfEntity 'Subscription
|
||||
|
||||
data ANewNtfEntity = forall e. NtfEntityI e => ANE (SNtfEntity e) (NewNtfEntity e)
|
||||
|
||||
instance NtfEntityI e => Encoding (NewNtfEntity e) where
|
||||
smpEncode = \case
|
||||
NewNtfTkn tkn verifyKey dhPubKey -> smpEncode ('T', tkn, verifyKey, dhPubKey)
|
||||
NewNtfSub tknId smpQueue -> smpEncode ('S', tknId, smpQueue)
|
||||
smpP = (\(ANE _ c) -> checkEntity c) <$?> smpP
|
||||
|
||||
instance Encoding ANewNtfEntity where
|
||||
smpEncode (ANE _ e) = smpEncode e
|
||||
smpP =
|
||||
A.anyChar >>= \case
|
||||
'T' -> ANE SToken <$> (NewNtfTkn <$> smpP <*> smpP <*> smpP)
|
||||
'S' -> ANE SSubscription <$> (NewNtfSub <$> smpP <*> smpP)
|
||||
_ -> fail "bad ANewNtfEntity"
|
||||
|
||||
instance Protocol NtfResponse where
|
||||
type ProtocolCommand NtfResponse = NtfCmd
|
||||
protocolPing = NtfCmd SSubscription PING
|
||||
protocolError = \case
|
||||
NRErr e -> Just e
|
||||
_ -> Nothing
|
||||
|
||||
data NtfCommand (e :: NtfEntity) where
|
||||
-- | register new device token for notifications
|
||||
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 :: NtfRegistrationCode -> 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
|
||||
TCRN :: Word16 -> NtfCommand 'Token
|
||||
-- | create SMP subscription
|
||||
SNEW :: NewNtfEntity 'Subscription -> NtfCommand 'Subscription
|
||||
-- | check SMP subscription status (response is STAT)
|
||||
SCHK :: NtfCommand 'Subscription
|
||||
-- | delete SMP subscription
|
||||
SDEL :: NtfCommand 'Subscription
|
||||
-- | keep-alive command
|
||||
PING :: NtfCommand 'Subscription
|
||||
|
||||
data NtfCmd = forall e. NtfEntityI e => NtfCmd (SNtfEntity e) (NtfCommand e)
|
||||
|
||||
instance NtfEntityI e => ProtocolEncoding (NtfCommand e) where
|
||||
type Tag (NtfCommand e) = NtfCommandTag e
|
||||
encodeProtocol = \case
|
||||
NCCreate token smpQueue verifyKey dhKey -> e (NCCreate_, ' ', token, smpQueue, verifyKey, dhKey)
|
||||
NCCheck -> e NCCheck_
|
||||
NCToken token -> e (NCToken_, ' ', token)
|
||||
NCDelete -> e NCDelete_
|
||||
TNEW newTkn -> e (TNEW_, ' ', newTkn)
|
||||
TVFY code -> e (TVFY_, ' ', code)
|
||||
TDEL -> e TDEL_
|
||||
TCRN int -> e (TCRN_, ' ', int)
|
||||
SNEW newSub -> e (SNEW_, ' ', newSub)
|
||||
SCHK -> e SCHK_
|
||||
SDEL -> e SDEL_
|
||||
PING -> e PING_
|
||||
where
|
||||
e :: Encoding a => a -> ByteString
|
||||
e = smpEncode
|
||||
|
||||
protocolP = \case
|
||||
NCCreate_ -> NCCreate <$> _smpP <*> smpP <*> smpP <*> smpP
|
||||
NCCheck_ -> pure NCCheck
|
||||
NCToken_ -> NCToken <$> _smpP
|
||||
NCDelete_ -> pure NCDelete
|
||||
protocolP tag = (\(NtfCmd _ c) -> checkEntity c) <$?> protocolP (NCT (sNtfEntity @e) tag)
|
||||
|
||||
checkCredentials (sig, _, subId, _) cmd = case cmd of
|
||||
-- CREATE must have signature but NOT subscription ID
|
||||
NCCreate {}
|
||||
| isNothing sig -> Left $ CMD NO_AUTH
|
||||
| not (B.null subId) -> Left $ CMD HAS_AUTH
|
||||
| otherwise -> Right cmd
|
||||
-- other client commands must have both signature and subscription ID
|
||||
checkCredentials (sig, _, entityId, _) cmd = case cmd of
|
||||
-- TNEW and SNEW must have signature but NOT token/subscription IDs
|
||||
TNEW {} -> sigNoEntity
|
||||
SNEW {} -> sigNoEntity
|
||||
PING
|
||||
| isNothing sig && B.null entityId -> Right cmd
|
||||
| otherwise -> Left $ CMD HAS_AUTH
|
||||
-- other client commands must have both signature and entity ID
|
||||
_
|
||||
| isNothing sig || B.null subId -> Left $ CMD NO_AUTH
|
||||
| isNothing sig || B.null entityId -> Left $ CMD NO_AUTH
|
||||
| otherwise -> Right cmd
|
||||
where
|
||||
sigNoEntity
|
||||
| isNothing sig = Left $ CMD NO_AUTH
|
||||
| not (B.null entityId) = Left $ CMD HAS_AUTH
|
||||
| otherwise = Right cmd
|
||||
|
||||
instance ProtocolEncoding NtfCmd where
|
||||
type Tag NtfCmd = NtfCmdTag
|
||||
encodeProtocol (NtfCmd _ c) = encodeProtocol c
|
||||
|
||||
protocolP = \case
|
||||
NCT SToken tag ->
|
||||
NtfCmd SToken <$> case tag of
|
||||
TNEW_ -> TNEW <$> _smpP
|
||||
TVFY_ -> TVFY <$> _smpP
|
||||
TDEL_ -> pure TDEL
|
||||
TCRN_ -> TCRN <$> _smpP
|
||||
NCT SSubscription tag ->
|
||||
NtfCmd SSubscription <$> case tag of
|
||||
SNEW_ -> SNEW <$> _smpP
|
||||
SCHK_ -> pure SCHK
|
||||
SDEL_ -> pure SDEL
|
||||
PING_ -> pure PING
|
||||
|
||||
checkCredentials t (NtfCmd e c) = NtfCmd e <$> checkCredentials t c
|
||||
|
||||
data NtfResponseTag
|
||||
= NRSubId_
|
||||
= NRId_
|
||||
| NROk_
|
||||
| NRErr_
|
||||
| NRStat_
|
||||
| NRPong_
|
||||
deriving (Show)
|
||||
|
||||
instance Encoding NtfResponseTag where
|
||||
smpEncode = \case
|
||||
NRSubId_ -> "ID"
|
||||
NRId_ -> "ID"
|
||||
NROk_ -> "OK"
|
||||
NRErr_ -> "ERR"
|
||||
NRStat_ -> "STAT"
|
||||
NRPong_ -> "PONG"
|
||||
smpP = messageTagP
|
||||
|
||||
instance ProtocolMsgTag NtfResponseTag where
|
||||
decodeTag = \case
|
||||
"ID" -> Just NRSubId_
|
||||
"ID" -> Just NRId_
|
||||
"OK" -> Just NROk_
|
||||
"ERR" -> Just NRErr_
|
||||
"STAT" -> Just NRStat_
|
||||
"PONG" -> Just NRPong_
|
||||
_ -> Nothing
|
||||
|
||||
data NtfResponse
|
||||
= NRSubId C.PublicKeyX25519
|
||||
= NRId NtfEntityId C.PublicKeyX25519
|
||||
| NROk
|
||||
| NRErr ErrorType
|
||||
| NRStat NtfStatus
|
||||
| NRStat NtfSubStatus
|
||||
| NRPong
|
||||
|
||||
instance Protocol NtfResponse where
|
||||
instance ProtocolEncoding NtfResponse where
|
||||
type Tag NtfResponse = NtfResponseTag
|
||||
encodeProtocol = \case
|
||||
NRSubId dhKey -> e (NRSubId_, ' ', dhKey)
|
||||
NRId entId dhKey -> e (NRId_, ' ', entId, dhKey)
|
||||
NROk -> e NROk_
|
||||
NRErr err -> e (NRErr_, ' ', err)
|
||||
NRStat stat -> e (NRStat_, ' ', stat)
|
||||
NRPong -> e NRPong_
|
||||
where
|
||||
e :: Encoding a => a -> ByteString
|
||||
e = smpEncode
|
||||
|
||||
protocolP = \case
|
||||
NRSubId_ -> NRSubId <$> _smpP
|
||||
NRId_ -> NRId <$> _smpP <*> smpP
|
||||
NROk_ -> pure NROk
|
||||
NRErr_ -> NRErr <$> _smpP
|
||||
NRStat_ -> NRStat <$> _smpP
|
||||
NRPong_ -> pure NRPong
|
||||
|
||||
checkCredentials (_, _, subId, _) cmd = case cmd of
|
||||
-- ERR response does not always have subscription ID
|
||||
checkCredentials (_, _, entId, _) cmd = case cmd of
|
||||
-- ID response must not have queue ID
|
||||
NRId {} -> noEntity
|
||||
-- ERR response does not always have entity ID
|
||||
NRErr _ -> Right cmd
|
||||
-- other server responses must have subscription ID
|
||||
-- PONG response must not have queue ID
|
||||
NRPong -> noEntity
|
||||
-- other server responses must have entity ID
|
||||
_
|
||||
| B.null subId -> Left $ CMD NO_ENTITY
|
||||
| B.null entId -> Left $ CMD NO_ENTITY
|
||||
| otherwise -> Right cmd
|
||||
where
|
||||
noEntity
|
||||
| B.null entId = Right cmd
|
||||
| otherwise = Left $ CMD HAS_AUTH
|
||||
|
||||
data SMPQueueNtfUri = SMPQueueNtfUri
|
||||
{ smpServer :: SMPServer,
|
||||
data SMPQueueNtf = SMPQueueNtf
|
||||
{ smpServer :: ProtocolServer,
|
||||
notifierId :: NotifierId,
|
||||
notifierKey :: NtfPrivateSignKey
|
||||
}
|
||||
|
||||
instance Encoding SMPQueueNtfUri where
|
||||
smpEncode SMPQueueNtfUri {smpServer, notifierId, notifierKey} = smpEncode (smpServer, notifierId, notifierKey)
|
||||
instance Encoding SMPQueueNtf where
|
||||
smpEncode SMPQueueNtf {smpServer, notifierId, notifierKey} = smpEncode (smpServer, notifierId, notifierKey)
|
||||
smpP = do
|
||||
(smpServer, notifierId, notifierKey) <- smpP
|
||||
pure $ SMPQueueNtfUri smpServer notifierId notifierKey
|
||||
pure $ SMPQueueNtf smpServer notifierId notifierKey
|
||||
|
||||
newtype DeviceToken = DeviceToken ByteString
|
||||
data PushPlatform = PPApple
|
||||
|
||||
instance Encoding PushPlatform where
|
||||
smpEncode = \case
|
||||
PPApple -> "A"
|
||||
smpP =
|
||||
A.anyChar >>= \case
|
||||
'A' -> pure PPApple
|
||||
_ -> fail "bad PushPlatform"
|
||||
|
||||
data DeviceToken = DeviceToken PushPlatform ByteString
|
||||
|
||||
instance Encoding DeviceToken where
|
||||
smpEncode (DeviceToken t) = smpEncode t
|
||||
smpP = DeviceToken <$> smpP
|
||||
smpEncode (DeviceToken p t) = smpEncode (p, t)
|
||||
smpP = DeviceToken <$> smpP <*> smpP
|
||||
|
||||
type NtfSubsciptionId = ByteString
|
||||
type NtfEntityId = ByteString
|
||||
|
||||
data NtfStatus = NSPending | NSActive | NSEnd | NSSMPAuth
|
||||
type NtfSubscriptionId = NtfEntityId
|
||||
|
||||
instance Encoding NtfStatus where
|
||||
type NtfTokenId = NtfEntityId
|
||||
|
||||
data NtfSubStatus
|
||||
= -- | state after SNEW
|
||||
NSNew
|
||||
| -- | pending connection/subscription to SMP server
|
||||
NSPending
|
||||
| -- | connected and subscribed to SMP server
|
||||
NSActive
|
||||
| -- | NEND received (we currently do not support it)
|
||||
NSEnd
|
||||
| -- | SMP AUTH error
|
||||
NSSMPAuth
|
||||
deriving (Eq)
|
||||
|
||||
instance Encoding NtfSubStatus where
|
||||
smpEncode = \case
|
||||
NSPending -> "PENDING"
|
||||
NSNew -> "NEW"
|
||||
NSPending -> "PENDING" -- e.g. after SMP server disconnect/timeout while ntf server is retrying to connect
|
||||
NSActive -> "ACTIVE"
|
||||
NSEnd -> "END"
|
||||
NSSMPAuth -> "SMP_AUTH"
|
||||
smpP =
|
||||
A.takeTill (== ' ') >>= \case
|
||||
"NEW" -> pure NSNew
|
||||
"PENDING" -> pure NSPending
|
||||
"ACTIVE" -> pure NSActive
|
||||
"END" -> pure NSEnd
|
||||
"SMP_AUTH" -> pure NSSMPAuth
|
||||
_ -> fail "bad NtfError"
|
||||
|
||||
data NtfTknStatus
|
||||
= -- | state after registration (TNEW)
|
||||
NTNew
|
||||
| -- | if initial notification or verification failed (push provider error)
|
||||
NTInvalid
|
||||
| -- | if initial notification succeeded
|
||||
NTConfirmed
|
||||
| -- | after successful verification (TVFY)
|
||||
NTActive
|
||||
| -- | after it is no longer valid (push provider error)
|
||||
NTExpired
|
||||
deriving (Eq)
|
||||
|
||||
checkEntity :: forall t e e'. (NtfEntityI e, NtfEntityI e') => t e' -> Either String (t e)
|
||||
checkEntity c = case testEquality (sNtfEntity @e) (sNtfEntity @e') of
|
||||
Just Refl -> Right c
|
||||
Nothing -> Left "bad command party"
|
||||
|
||||
checkEntity' :: forall t p p'. (NtfEntityI p, NtfEntityI p') => t p' -> Maybe (t p)
|
||||
checkEntity' c = case testEquality (sNtfEntity @p) (sNtfEntity @p') of
|
||||
Just Refl -> Just c
|
||||
_ -> Nothing
|
||||
|
||||
@@ -1,9 +1,12 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
|
||||
module Simplex.Messaging.Notifications.Server where
|
||||
|
||||
@@ -12,13 +15,16 @@ import Control.Monad.IO.Unlift (MonadUnliftIO)
|
||||
import Control.Monad.Reader
|
||||
import Crypto.Random (MonadRandom)
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import Data.Functor (($>))
|
||||
import Network.Socket (ServiceName)
|
||||
import Simplex.Messaging.Client.Agent
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Notifications.Protocol
|
||||
import Simplex.Messaging.Notifications.Server.Env
|
||||
import Simplex.Messaging.Notifications.Server.Subscriptions
|
||||
import Simplex.Messaging.Notifications.Transport
|
||||
import Simplex.Messaging.Protocol (ErrorType (..), Transmission, encodeTransmission, tGet, tPut)
|
||||
import Simplex.Messaging.Protocol (ErrorType (..), SignedTransmission, Transmission, encodeTransmission, tGet, tPut)
|
||||
import qualified Simplex.Messaging.Protocol as SMP
|
||||
import Simplex.Messaging.Server
|
||||
import Simplex.Messaging.Transport (ATransport (..), THandle (..), TProxy, Transport)
|
||||
import Simplex.Messaging.Transport.Server (runTransportServer)
|
||||
@@ -37,7 +43,10 @@ runNtfServerBlocking started cfg@NtfServerConfig {transports} = do
|
||||
runReaderT ntfServer env
|
||||
where
|
||||
ntfServer :: (MonadUnliftIO m', MonadReader NtfEnv m') => m' ()
|
||||
ntfServer = raceAny_ (map runServer transports)
|
||||
ntfServer = do
|
||||
s <- asks subscriber
|
||||
ps <- asks pushServer
|
||||
raceAny_ (ntfSubscriber s : ntfPush ps : map runServer transports)
|
||||
|
||||
runServer :: (MonadUnliftIO m', MonadReader NtfEnv m') => (ServiceName, ATransport) -> m' ()
|
||||
runServer (tcpPort, ATransport t) = do
|
||||
@@ -51,11 +60,61 @@ runNtfServerBlocking started cfg@NtfServerConfig {transports} = do
|
||||
Right th -> runNtfClientTransport th
|
||||
Left _ -> pure ()
|
||||
|
||||
ntfSubscriber :: forall m. (MonadUnliftIO m, MonadReader NtfEnv m) => NtfSubscriber -> m ()
|
||||
ntfSubscriber NtfSubscriber {subQ, smpAgent = ca@SMPClientAgent {msgQ, agentQ}} = do
|
||||
raceAny_ [subscribe, receiveSMP, receiveAgent]
|
||||
where
|
||||
subscribe :: m ()
|
||||
subscribe = forever $ do
|
||||
atomically (readTBQueue subQ) >>= \case
|
||||
NtfSub NtfSubData {smpQueue} -> do
|
||||
let SMPQueueNtf {smpServer, notifierId, notifierKey} = smpQueue
|
||||
liftIO (runExceptT $ subscribeQueue ca smpServer ((SPNotifier, notifierId), notifierKey)) >>= \case
|
||||
Right _ -> pure () -- update subscription status
|
||||
Left e -> pure ()
|
||||
|
||||
receiveSMP :: m ()
|
||||
receiveSMP = forever $ do
|
||||
(srv, ntfId, msg) <- atomically $ readTBQueue msgQ
|
||||
case msg of
|
||||
SMP.NMSG -> do
|
||||
-- check when the last NMSG was received from this queue
|
||||
-- update timestamp
|
||||
-- check what was the last hidden notification was sent (and whether to this queue)
|
||||
-- decide whether it should be sent as hidden or visible
|
||||
-- construct and possibly encrypt notification
|
||||
-- send it
|
||||
pure ()
|
||||
_ -> pure ()
|
||||
pure ()
|
||||
|
||||
receiveAgent =
|
||||
forever $
|
||||
atomically (readTBQueue agentQ) >>= \case
|
||||
CAConnected _ -> pure ()
|
||||
CADisconnected srv subs -> do
|
||||
-- update subscription statuses
|
||||
pure ()
|
||||
CAReconnected _ -> pure ()
|
||||
CAResubscribed srv sub -> do
|
||||
-- update subscription status
|
||||
pure ()
|
||||
CASubError srv sub err -> do
|
||||
-- update subscription status
|
||||
pure ()
|
||||
|
||||
ntfPush :: (MonadUnliftIO m, MonadReader NtfEnv m) => NtfPushServer -> m ()
|
||||
ntfPush NtfPushServer {pushQ} = forever $ do
|
||||
atomically (readTBQueue pushQ) >>= \case
|
||||
(NtfTknData {}, Notification {}) -> pure ()
|
||||
|
||||
runNtfClientTransport :: (Transport c, MonadUnliftIO m, MonadReader NtfEnv m) => THandle c -> m ()
|
||||
runNtfClientTransport th@THandle {sessionId} = do
|
||||
q <- asks $ tbqSize . config
|
||||
c <- atomically $ newNtfServerClient q sessionId
|
||||
raceAny_ [send th c, client c, receive th c]
|
||||
qSize <- asks $ clientQSize . config
|
||||
c <- atomically $ newNtfServerClient qSize sessionId
|
||||
s <- asks subscriber
|
||||
ps <- asks pushServer
|
||||
raceAny_ [send th c, client c s ps, receive th c]
|
||||
`finally` clientDisconnected c
|
||||
|
||||
clientDisconnected :: MonadUnliftIO m => NtfServerClient -> m ()
|
||||
@@ -63,14 +122,13 @@ 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
|
||||
(sig, signed, (corrId, queueId, cmdOrError)) <- tGet th
|
||||
t@(sig, signed, (corrId, subId, cmdOrError)) <- tGet th
|
||||
case cmdOrError of
|
||||
Left e -> write sndQ (corrId, queueId, NRErr e)
|
||||
Right cmd -> do
|
||||
verified <- verifyTransmission sig signed queueId cmd
|
||||
if verified
|
||||
then write rcvQ (corrId, queueId, cmd)
|
||||
else write sndQ (corrId, queueId, NRErr AUTH)
|
||||
Left e -> write sndQ (corrId, subId, NRErr e)
|
||||
Right cmd ->
|
||||
verifyNtfTransmission t cmd >>= \case
|
||||
VRVerified req -> write rcvQ req
|
||||
VRFailed -> write sndQ (corrId, subId, NRErr AUTH)
|
||||
where
|
||||
write q t = atomically $ writeTBQueue q t
|
||||
|
||||
@@ -79,33 +137,121 @@ send h NtfServerClient {sndQ, sessionId} = forever $ do
|
||||
t <- atomically $ readTBQueue sndQ
|
||||
liftIO $ tPut h (Nothing, encodeTransmission sessionId t)
|
||||
|
||||
verifyTransmission ::
|
||||
forall m. (MonadUnliftIO m, MonadReader NtfEnv m) => Maybe C.ASignature -> ByteString -> NtfSubsciptionId -> NtfCommand -> m Bool
|
||||
verifyTransmission sig_ signed subId cmd = do
|
||||
case cmd of
|
||||
NCCreate _ _ k _ -> pure $ verifyCmdSignature sig_ signed k
|
||||
_ -> do
|
||||
st <- asks store
|
||||
verifySubCmd <$> atomically (getNtfSubscription st subId)
|
||||
where
|
||||
verifySubCmd = \case
|
||||
Right sub -> verifyCmdSignature sig_ signed $ subVerifyKey sub
|
||||
Left _ -> maybe False (dummyVerifyCmd signed) sig_ `seq` False
|
||||
data VerificationResult = VRVerified NtfRequest | VRFailed
|
||||
|
||||
client :: forall m. (MonadUnliftIO m, MonadReader NtfEnv m) => NtfServerClient -> m ()
|
||||
client NtfServerClient {rcvQ, sndQ} =
|
||||
verifyNtfTransmission ::
|
||||
forall m. (MonadUnliftIO m, MonadReader NtfEnv m) => SignedTransmission NtfCmd -> NtfCmd -> m VerificationResult
|
||||
verifyNtfTransmission (sig_, signed, (corrId, entId, _)) cmd = do
|
||||
case cmd of
|
||||
NtfCmd SToken (TNEW n@(NewNtfTkn _ k _)) ->
|
||||
-- TODO check that token is not already in store
|
||||
pure $
|
||||
if verifyCmdSignature sig_ signed k
|
||||
then 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
|
||||
_ -> 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
|
||||
|
||||
client :: forall m. (MonadUnliftIO m, MonadReader NtfEnv m) => NtfServerClient -> NtfSubscriber -> NtfPushServer -> m ()
|
||||
client NtfServerClient {rcvQ, sndQ} NtfSubscriber {subQ} NtfPushServer {pushQ} =
|
||||
forever $
|
||||
atomically (readTBQueue rcvQ)
|
||||
>>= processCommand
|
||||
>>= atomically . writeTBQueue sndQ
|
||||
where
|
||||
processCommand :: Transmission NtfCommand -> m (Transmission NtfResponse)
|
||||
processCommand (corrId, subId, cmd) = case cmd of
|
||||
NCCreate _token _smpQueue _verifyKey _dhKey -> do
|
||||
pure (corrId, subId, NROk)
|
||||
NCCheck -> do
|
||||
pure (corrId, subId, NROk)
|
||||
NCToken _token -> do
|
||||
pure (corrId, subId, NROk)
|
||||
NCDelete -> do
|
||||
pure (corrId, subId, NROk)
|
||||
processCommand :: NtfRequest -> m (Transmission NtfResponse)
|
||||
processCommand = \case
|
||||
NtfReqNew corrId (ANE SToken newTkn@(NewNtfTkn _ _ dhPubKey)) -> do
|
||||
st <- asks store
|
||||
(srvDhPubKey, srvDrivDhKey) <- liftIO C.generateKeyPair'
|
||||
let dhSecret = C.dh' dhPubKey srvDrivDhKey
|
||||
tknId <- getId
|
||||
atomically $ do
|
||||
tkn <- mkNtfTknData newTkn dhSecret
|
||||
addNtfToken st tknId tkn
|
||||
writeTBQueue pushQ (tkn, Notification)
|
||||
-- pure (corrId, sId, NRSubId pubDhKey)
|
||||
pure (corrId, "", NRId tknId srvDhPubKey)
|
||||
NtfReqCmd SToken tkn (corrId, tknId, cmd) ->
|
||||
(corrId,tknId,) <$> case cmd of
|
||||
TNEW newTkn -> pure NROk -- TODO when duplicate token sent
|
||||
TVFY code -> pure NROk
|
||||
TDEL -> pure NROk
|
||||
TCRN int -> pure NROk
|
||||
NtfReqNew corrId (ANE SSubscription newSub) -> pure (corrId, "", NROk)
|
||||
NtfReqCmd SSubscription sub (corrId, subId, cmd) ->
|
||||
(corrId,subId,) <$> case cmd of
|
||||
SNEW newSub -> pure NROk
|
||||
SCHK -> pure NROk
|
||||
SDEL -> pure NROk
|
||||
PING -> pure NRPong
|
||||
getId :: m NtfEntityId
|
||||
getId = do
|
||||
n <- asks $ subIdBytes . config
|
||||
gVar <- asks idsDrg
|
||||
atomically (randomBytes n gVar)
|
||||
|
||||
-- NReqCreate corrId tokenId smpQueue -> pure (corrId, "", NROk)
|
||||
-- do
|
||||
-- st <- asks store
|
||||
-- (pubDhKey, privDhKey) <- liftIO C.generateKeyPair'
|
||||
-- let dhSecret = C.dh' dhPubKey privDhKey
|
||||
-- sub <- atomically $ mkNtfSubsciption smpQueue token verifyKey dhSecret
|
||||
-- addSubRetry 3 st sub >>= \case
|
||||
-- Nothing -> pure (corrId, "", NRErr INTERNAL)
|
||||
-- Just sId -> do
|
||||
-- atomically $ writeTBQueue subQ sub
|
||||
-- pure (corrId, sId, NRSubId pubDhKey)
|
||||
-- where
|
||||
-- addSubRetry :: Int -> NtfSubscriptionsStore -> NtfSubsciption -> m (Maybe NtfSubsciptionId)
|
||||
-- addSubRetry 0 _ _ = pure Nothing
|
||||
-- addSubRetry n st sub = do
|
||||
-- sId <- getId
|
||||
-- -- create QueueRec record with these ids and keys
|
||||
-- atomically (addNtfSub st sId sub) >>= \case
|
||||
-- Nothing -> addSubRetry (n - 1) st sub
|
||||
-- _ -> pure $ Just sId
|
||||
-- getId :: m NtfSubsciptionId
|
||||
-- getId = do
|
||||
-- n <- asks $ subIdBytes . config
|
||||
-- gVar <- asks idsDrg
|
||||
-- atomically (randomBytes n gVar)
|
||||
-- NReqCommand sub@NtfSubsciption {tokenId, subStatus} (corrId, subId, cmd) ->
|
||||
-- (corrId,subId,) <$> case cmd of
|
||||
-- NCSubCreate tokenId smpQueue -> pure NROk
|
||||
-- do
|
||||
-- st <- asks store
|
||||
-- (pubDhKey, privDhKey) <- liftIO C.generateKeyPair'
|
||||
-- let dhSecret = C.dh' (dhPubKey newSub) privDhKey
|
||||
-- atomically (updateNtfSub st sub newSub dhSecret) >>= \case
|
||||
-- Nothing -> pure $ NRErr INTERNAL
|
||||
-- _ -> atomically $ do
|
||||
-- whenM ((== NSEnd) <$> readTVar status) $ writeTBQueue subQ sub
|
||||
-- pure $ NRSubId pubDhKey
|
||||
-- NCSubCheck -> NRStat <$> readTVarIO subStatus
|
||||
-- NCSubDelete -> do
|
||||
-- st <- asks store
|
||||
-- atomically (deleteNtfSub st subId) $> NROk
|
||||
|
||||
@@ -1,4 +1,7 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
|
||||
module Simplex.Messaging.Notifications.Server.Env where
|
||||
@@ -6,26 +9,27 @@ module Simplex.Messaging.Notifications.Server.Env where
|
||||
import Control.Monad.IO.Unlift
|
||||
import Crypto.Random
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.X509.Validation (Fingerprint (..))
|
||||
import Network.Socket
|
||||
import qualified Network.TLS as T
|
||||
import Numeric.Natural
|
||||
import Simplex.Messaging.Agent.RetryInterval
|
||||
import Simplex.Messaging.Client
|
||||
import Simplex.Messaging.Client.Agent
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Notifications.Protocol
|
||||
import Simplex.Messaging.Notifications.Server.Subscriptions
|
||||
import Simplex.Messaging.Protocol (Transmission)
|
||||
import Simplex.Messaging.Protocol (CorrId, Transmission)
|
||||
import Simplex.Messaging.Transport (ATransport)
|
||||
import Simplex.Messaging.Transport.Server (loadFingerprint, loadTLSServerParams)
|
||||
import UnliftIO.STM
|
||||
|
||||
data NtfServerConfig = NtfServerConfig
|
||||
{ transports :: [(ServiceName, ATransport)],
|
||||
subscriptionIdBytes :: Int,
|
||||
tbqSize :: Natural,
|
||||
smpCfg :: SMPClientConfig,
|
||||
subIdBytes :: Int,
|
||||
clientQSize :: Natural,
|
||||
subQSize :: Natural,
|
||||
pushQSize :: Natural,
|
||||
smpAgentCfg :: SMPClientAgentConfig,
|
||||
reconnectInterval :: RetryInterval,
|
||||
-- CA certificate private key is not needed for initialization
|
||||
caCertificateFile :: FilePath,
|
||||
@@ -33,26 +37,55 @@ data NtfServerConfig = NtfServerConfig
|
||||
certificateFile :: FilePath
|
||||
}
|
||||
|
||||
data Notification = Notification
|
||||
|
||||
data NtfEnv = NtfEnv
|
||||
{ config :: NtfServerConfig,
|
||||
serverIdentity :: C.KeyHash,
|
||||
store :: NtfSubscriptions,
|
||||
subscriber :: NtfSubscriber,
|
||||
pushServer :: NtfPushServer,
|
||||
store :: NtfStore,
|
||||
idsDrg :: TVar ChaChaDRG,
|
||||
serverIdentity :: C.KeyHash,
|
||||
tlsServerParams :: T.ServerParams,
|
||||
serverIdentity :: C.KeyHash
|
||||
}
|
||||
|
||||
newNtfServerEnv :: (MonadUnliftIO m, MonadRandom m) => NtfServerConfig -> m NtfEnv
|
||||
newNtfServerEnv config@NtfServerConfig {caCertificateFile, certificateFile, privateKeyFile} = do
|
||||
newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, caCertificateFile, certificateFile, privateKeyFile} = do
|
||||
idsDrg <- newTVarIO =<< drgNew
|
||||
store <- newTVarIO M.empty
|
||||
store <- atomically newNtfStore
|
||||
subscriber <- atomically $ newNtfSubscriber subQSize smpAgentCfg
|
||||
pushServer <- atomically $ newNtfPushServer pushQSize
|
||||
tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile
|
||||
Fingerprint fp <- liftIO $ loadFingerprint caCertificateFile
|
||||
let serverIdentity = C.KeyHash fp
|
||||
pure NtfEnv {config, store, idsDrg, tlsServerParams, serverIdentity}
|
||||
pure NtfEnv {config, subscriber, pushServer, store, idsDrg, tlsServerParams, serverIdentity = C.KeyHash fp}
|
||||
|
||||
data NtfSubscriber = NtfSubscriber
|
||||
{ subQ :: TBQueue (NtfEntityRec 'Subscription),
|
||||
smpAgent :: SMPClientAgent
|
||||
}
|
||||
|
||||
newNtfSubscriber :: Natural -> SMPClientAgentConfig -> STM NtfSubscriber
|
||||
newNtfSubscriber qSize smpAgentCfg = do
|
||||
smpAgent <- newSMPClientAgent smpAgentCfg
|
||||
subQ <- newTBQueue qSize
|
||||
pure NtfSubscriber {smpAgent, subQ}
|
||||
|
||||
newtype NtfPushServer = NtfPushServer
|
||||
{ pushQ :: TBQueue (NtfTknData, Notification)
|
||||
}
|
||||
|
||||
newNtfPushServer :: Natural -> STM NtfPushServer
|
||||
newNtfPushServer qSize = do
|
||||
pushQ <- newTBQueue qSize
|
||||
pure NtfPushServer {pushQ}
|
||||
|
||||
data NtfRequest
|
||||
= NtfReqNew CorrId ANewNtfEntity
|
||||
| forall e. NtfEntityI e => NtfReqCmd (SNtfEntity e) (NtfEntityRec e) (Transmission (NtfCommand e))
|
||||
|
||||
data NtfServerClient = NtfServerClient
|
||||
{ rcvQ :: TBQueue (Transmission NtfCommand),
|
||||
{ rcvQ :: TBQueue NtfRequest,
|
||||
sndQ :: TBQueue (Transmission NtfResponse),
|
||||
sessionId :: ByteString,
|
||||
connected :: TVar Bool
|
||||
|
||||
@@ -0,0 +1,11 @@
|
||||
module Simplex.Messaging.Notifications.Server.Push where
|
||||
|
||||
import Control.Concurrent.STM
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import Simplex.Messaging.Protocol (NotifierId, SMPServer)
|
||||
|
||||
data NtfPushPayload = NPVerification ByteString | NPNotification SMPServer NotifierId | NPPing
|
||||
|
||||
class PushProvider p where
|
||||
newPushProvider :: STM p
|
||||
requestBody :: p -> NtfPushPayload -> ByteString -- ?
|
||||
@@ -1,25 +1,109 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
|
||||
module Simplex.Messaging.Notifications.Server.Subscriptions where
|
||||
|
||||
import Control.Concurrent.STM
|
||||
import Control.Monad
|
||||
import Crypto.PubKey.Curve25519 (dhSecret)
|
||||
import Data.Map.Strict (Map)
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Set (Set)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Notifications.Protocol
|
||||
import Simplex.Messaging.Protocol (ErrorType (..), NotifierId, NtfPrivateSignKey, SMPServer)
|
||||
import Simplex.Messaging.Protocol (ErrorType (..), NotifierId, NtfPrivateSignKey, ProtocolServer)
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Util ((<$$>))
|
||||
|
||||
type NtfSubscriptionsData = Map NtfSubsciptionId NtfSubsciptionRec
|
||||
|
||||
type NtfSubscriptions = TVar NtfSubscriptionsData
|
||||
|
||||
data NtfSubsciptionRec = NtfSubsciptionRec
|
||||
{ smpServer :: SMPServer,
|
||||
notifierId :: NotifierId,
|
||||
notifierKey :: NtfPrivateSignKey,
|
||||
token :: DeviceToken,
|
||||
status :: TVar NtfStatus,
|
||||
subVerifyKey :: C.APublicVerifyKey,
|
||||
subDHSecret :: C.DhSecretX25519
|
||||
data NtfStore = NtfStore
|
||||
{ tokens :: TMap NtfTokenId NtfTknData,
|
||||
tokenIds :: TMap DeviceToken NtfTokenId
|
||||
}
|
||||
|
||||
getNtfSubscription :: NtfSubscriptions -> NtfSubsciptionId -> STM (Either ErrorType NtfSubsciptionRec)
|
||||
getNtfSubscription st subId = maybe (Left AUTH) Right . M.lookup subId <$> readTVar st
|
||||
newNtfStore :: STM NtfStore
|
||||
newNtfStore = do
|
||||
tokens <- TM.empty
|
||||
tokenIds <- TM.empty
|
||||
pure NtfStore {tokens, tokenIds}
|
||||
|
||||
data NtfTknData = NtfTknData
|
||||
{ token :: DeviceToken,
|
||||
tknStatus :: TVar NtfTknStatus,
|
||||
tknVerifyKey :: C.APublicVerifyKey,
|
||||
tknDhSecret :: C.DhSecretX25519
|
||||
}
|
||||
|
||||
mkNtfTknData :: NewNtfEntity 'Token -> C.DhSecretX25519 -> STM NtfTknData
|
||||
mkNtfTknData (NewNtfTkn token tknVerifyKey _) tknDhSecret = do
|
||||
tknStatus <- newTVar NTNew
|
||||
pure NtfTknData {token, tknStatus, tknVerifyKey, tknDhSecret}
|
||||
|
||||
data NtfSubscriptionsStore = NtfSubscriptionsStore
|
||||
|
||||
-- { subscriptions :: TMap NtfSubsciptionId NtfSubsciption,
|
||||
-- activeSubscriptions :: TMap (SMPServer, NotifierId) NtfSubsciptionId
|
||||
-- }
|
||||
-- do
|
||||
-- subscriptions <- newTVar M.empty
|
||||
-- activeSubscriptions <- newTVar M.empty
|
||||
-- pure NtfSubscriptionsStore {subscriptions, activeSubscriptions}
|
||||
|
||||
data NtfSubData = NtfSubData
|
||||
{ smpQueue :: SMPQueueNtf,
|
||||
tokenId :: NtfTokenId,
|
||||
subStatus :: TVar NtfSubStatus
|
||||
}
|
||||
|
||||
data NtfEntityRec (e :: NtfEntity) where
|
||||
NtfTkn :: NtfTknData -> NtfEntityRec 'Token
|
||||
NtfSub :: NtfSubData -> NtfEntityRec 'Subscription
|
||||
|
||||
data ANtfEntityRec = forall e. NtfEntityI e => NER (SNtfEntity e) (NtfEntityRec e)
|
||||
|
||||
getNtfToken :: NtfStore -> NtfTokenId -> STM (Maybe (NtfEntityRec 'Token))
|
||||
getNtfToken st tknId = NtfTkn <$$> TM.lookup tknId (tokens st)
|
||||
|
||||
addNtfToken :: NtfStore -> NtfTokenId -> NtfTknData -> STM ()
|
||||
addNtfToken st tknId tkn = pure ()
|
||||
|
||||
-- getNtfRec :: NtfStore -> SNtfEntity e -> NtfEntityId -> STM (Maybe (NtfEntityRec e))
|
||||
-- getNtfRec st ent entId = case ent of
|
||||
-- SToken -> NtfTkn <$$> TM.lookup entId (tokens st)
|
||||
-- SSubscription -> pure Nothing
|
||||
|
||||
-- getNtfVerifyKey :: NtfStore -> SNtfEntity e -> NtfEntityId -> STM (Maybe (NtfEntityRec e, C.APublicVerifyKey))
|
||||
-- getNtfVerifyKey st ent entId =
|
||||
-- getNtfRec st ent entId >>= \case
|
||||
-- Just r@(NtfTkn NtfTknData {tknVerifyKey}) -> pure $ Just (r, tknVerifyKey)
|
||||
-- Just r@(NtfSub NtfSubData {tokenId}) ->
|
||||
-- getNtfRec st SToken tokenId >>= \case
|
||||
-- Just (NtfTkn NtfTknData {tknVerifyKey}) -> pure $ Just (r, tknVerifyKey)
|
||||
-- _ -> pure Nothing
|
||||
-- _ -> pure Nothing
|
||||
|
||||
-- mkNtfSubsciption :: SMPQueueNtf -> NtfTokenId -> STM NtfSubsciption
|
||||
-- mkNtfSubsciption smpQueue tokenId = do
|
||||
-- subStatus <- newTVar NSNew
|
||||
-- pure NtfSubsciption {smpQueue, tokenId, subStatus}
|
||||
|
||||
-- getNtfSub :: NtfSubscriptionsStore -> NtfSubsciptionId -> STM (Maybe NtfSubsciption)
|
||||
-- getNtfSub st subId = pure Nothing -- maybe (pure $ Left AUTH) (fmap Right . readTVar) . M.lookup subId . subscriptions =<< readTVar st
|
||||
|
||||
-- getNtfSubViaSMPQueue :: NtfSubscriptionsStore -> SMPQueueNtf -> STM (Maybe NtfSubsciption)
|
||||
-- getNtfSubViaSMPQueue st smpQueue = pure Nothing
|
||||
|
||||
-- -- replace keeping status
|
||||
-- updateNtfSub :: NtfSubscriptionsStore -> NtfSubsciption -> SMPQueueNtf -> NtfTokenId -> C.DhSecretX25519 -> STM (Maybe ())
|
||||
-- updateNtfSub st sub smpQueue tokenId dhSecret = pure Nothing
|
||||
|
||||
-- addNtfSub :: NtfSubscriptionsStore -> NtfSubsciptionId -> NtfSubsciption -> STM (Maybe ())
|
||||
-- addNtfSub st subId sub = pure Nothing
|
||||
|
||||
-- deleteNtfSub :: NtfSubscriptionsStore -> NtfSubsciptionId -> STM ()
|
||||
-- deleteNtfSub st subId = pure ()
|
||||
|
||||
Reference in New Issue
Block a user