mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-04-27 08:35:15 +00:00
Evgeny
ce6777b68d
* put DRG state to IORef, split STM transaction of sending notification (#1288)
* put DRG state to IORef, split STM transaction of sending notification
* remove comment
* remove comment
* add comment
* revert version
* newtype for server entity IDs, fix TRcvQueues
* Revert "put DRG state to IORef, split STM transaction of sending notification (#1288)"
This reverts commit 517933d189.
* logServer
72 lines
3.3 KiB
Haskell
72 lines
3.3 KiB
Haskell
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE PatternSynonyms #-}
|
|
|
|
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
|
|
import Simplex.Messaging.Notifications.Transport (NTFVersion, supportedClientNTFVRange, supportedNTFHandshakes)
|
|
import Simplex.Messaging.Protocol (ErrorType, pattern NoEntity)
|
|
|
|
type NtfClient = ProtocolClient NTFVersion ErrorType NtfResponse
|
|
|
|
type NtfClientError = ProtocolClientError ErrorType
|
|
|
|
defaultNTFClientConfig :: ProtocolClientConfig NTFVersion
|
|
defaultNTFClientConfig = defaultClientConfig (Just supportedNTFHandshakes) supportedClientNTFVRange
|
|
|
|
ntfRegisterToken :: NtfClient -> C.APrivateAuthKey -> NewNtfEntity 'Token -> ExceptT NtfClientError IO (NtfTokenId, C.PublicKeyX25519)
|
|
ntfRegisterToken c pKey newTkn =
|
|
sendNtfCommand c (Just pKey) NoEntity (TNEW newTkn) >>= \case
|
|
NRTknId tknId dhKey -> pure (tknId, dhKey)
|
|
r -> throwE $ unexpectedResponse r
|
|
|
|
ntfVerifyToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> NtfRegCode -> ExceptT NtfClientError IO ()
|
|
ntfVerifyToken c pKey tknId code = okNtfCommand (TVFY code) c pKey tknId
|
|
|
|
ntfCheckToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> ExceptT NtfClientError IO NtfTknStatus
|
|
ntfCheckToken c pKey tknId =
|
|
sendNtfCommand c (Just pKey) tknId TCHK >>= \case
|
|
NRTkn stat -> pure stat
|
|
r -> throwE $ unexpectedResponse r
|
|
|
|
ntfReplaceToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> DeviceToken -> ExceptT NtfClientError IO ()
|
|
ntfReplaceToken c pKey tknId token = okNtfCommand (TRPL token) c pKey tknId
|
|
|
|
ntfDeleteToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> ExceptT NtfClientError IO ()
|
|
ntfDeleteToken = okNtfCommand TDEL
|
|
|
|
ntfEnableCron :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> Word16 -> ExceptT NtfClientError IO ()
|
|
ntfEnableCron c pKey tknId int = okNtfCommand (TCRN int) c pKey tknId
|
|
|
|
ntfCreateSubscription :: NtfClient -> C.APrivateAuthKey -> NewNtfEntity 'Subscription -> ExceptT NtfClientError IO NtfSubscriptionId
|
|
ntfCreateSubscription c pKey newSub =
|
|
sendNtfCommand c (Just pKey) NoEntity (SNEW newSub) >>= \case
|
|
NRSubId subId -> pure subId
|
|
r -> throwE $ unexpectedResponse r
|
|
|
|
ntfCheckSubscription :: NtfClient -> C.APrivateAuthKey -> NtfSubscriptionId -> ExceptT NtfClientError IO NtfSubStatus
|
|
ntfCheckSubscription c pKey subId =
|
|
sendNtfCommand c (Just pKey) subId SCHK >>= \case
|
|
NRSub stat -> pure stat
|
|
r -> throwE $ unexpectedResponse r
|
|
|
|
ntfDeleteSubscription :: NtfClient -> C.APrivateAuthKey -> NtfSubscriptionId -> ExceptT NtfClientError IO ()
|
|
ntfDeleteSubscription = okNtfCommand SDEL
|
|
|
|
-- | Send notification server command
|
|
sendNtfCommand :: NtfEntityI e => NtfClient -> Maybe C.APrivateAuthKey -> NtfEntityId -> NtfCommand e -> ExceptT NtfClientError IO NtfResponse
|
|
sendNtfCommand c pKey entId cmd = sendProtocolCommand c pKey entId (NtfCmd sNtfEntity cmd)
|
|
|
|
okNtfCommand :: NtfEntityI e => NtfCommand e -> NtfClient -> C.APrivateAuthKey -> NtfEntityId -> ExceptT NtfClientError IO ()
|
|
okNtfCommand cmd c pKey entId =
|
|
sendNtfCommand c (Just pKey) entId cmd >>= \case
|
|
NROk -> return ()
|
|
r -> throwE $ unexpectedResponse r
|