mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-07-31 13:51:01 +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
co-authored by
JRoberts
JRoberts
parent
4e1184d9eb
commit
d31958855f
@@ -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