mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-10-23 02:12:35 +00:00
ntf-server store log (#435)
* ntf-server store log * ntf serevr: restore log when server is started, save compacted store log * log ntf server store changes * test, store log works * update ntf-server exe
This commit is contained in:
Evgeny Poberezkin authored and GitHub committed
1 parent
b0ac0744e2
commit
85d507d5d3
15 files changed
+394
-119
No files matched your search
@@ -22,12 +22,14 @@ import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Notifications.Protocol
|
||||
import Simplex.Messaging.Notifications.Server.Push.APNS
|
||||
import Simplex.Messaging.Notifications.Server.Store
|
||||
import Simplex.Messaging.Notifications.Server.StoreLog
|
||||
import Simplex.Messaging.Protocol (CorrId, SMPServer, Transmission)
|
||||
import Simplex.Messaging.Server.Expiration
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Transport (ATransport)
|
||||
import Simplex.Messaging.Transport.Server (loadFingerprint, loadTLSServerParams)
|
||||
import System.IO (IOMode (..))
|
||||
import UnliftIO.STM
|
||||
|
||||
data NtfServerConfig = NtfServerConfig
|
||||
@@ -40,6 +42,8 @@ data NtfServerConfig = NtfServerConfig
|
||||
smpAgentCfg :: SMPClientAgentConfig,
|
||||
apnsConfig :: APNSPushClientConfig,
|
||||
inactiveClientExpiration :: Maybe ExpirationConfig,
|
||||
storeLogFile :: Maybe FilePath,
|
||||
resubscribeDelay :: Int, -- microseconds
|
||||
-- CA certificate private key is not needed for initialization
|
||||
caCertificateFile :: FilePath,
|
||||
privateKeyFile :: FilePath,
|
||||
@@ -58,6 +62,7 @@ data NtfEnv = NtfEnv
|
||||
subscriber :: NtfSubscriber,
|
||||
pushServer :: NtfPushServer,
|
||||
store :: NtfStore,
|
||||
storeLog :: Maybe (StoreLog 'WriteMode),
|
||||
idsDrg :: TVar ChaChaDRG,
|
||||
serverIdentity :: C.KeyHash,
|
||||
tlsServerParams :: T.ServerParams,
|
||||
@@ -65,14 +70,15 @@ data NtfEnv = NtfEnv
|
||||
}
|
||||
|
||||
newNtfServerEnv :: (MonadUnliftIO m, MonadRandom m) => NtfServerConfig -> m NtfEnv
|
||||
newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsConfig, caCertificateFile, certificateFile, privateKeyFile} = do
|
||||
newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsConfig, storeLogFile, caCertificateFile, certificateFile, privateKeyFile} = do
|
||||
idsDrg <- newTVarIO =<< drgNew
|
||||
store <- atomically newNtfStore
|
||||
storeLog <- liftIO $ mapM (`readWriteNtfStore` store) storeLogFile
|
||||
subscriber <- atomically $ newNtfSubscriber subQSize smpAgentCfg
|
||||
pushServer <- atomically $ newNtfPushServer pushQSize apnsConfig
|
||||
tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile
|
||||
Fingerprint fp <- liftIO $ loadFingerprint caCertificateFile
|
||||
pure NtfEnv {config, subscriber, pushServer, store, idsDrg, tlsServerParams, serverIdentity = C.KeyHash fp}
|
||||
pure NtfEnv {config, subscriber, pushServer, store, storeLog, idsDrg, tlsServerParams, serverIdentity = C.KeyHash fp}
|
||||
|
||||
data NtfSubscriber = NtfSubscriber
|
||||
{ smpSubscribers :: TMap SMPServer SMPSubscriber,
|
||||
|
||||
@@ -10,6 +10,7 @@
|
||||
|
||||
module Simplex.Messaging.Notifications.Server.Push.APNS where
|
||||
|
||||
import Control.Exception (Exception)
|
||||
import Control.Logger.Simple
|
||||
import Control.Monad.Except
|
||||
import Crypto.Hash.Algorithms (SHA256 (..))
|
||||
@@ -320,7 +321,7 @@ data PushProviderError
|
||||
| PPTokenInvalid
|
||||
| PPRetryLater
|
||||
| PPPermanentError
|
||||
deriving (Show)
|
||||
deriving (Show, Exception)
|
||||
|
||||
type PushProviderClient = NtfTknData -> PushNotification -> ExceptT PushProviderError IO ()
|
||||
|
||||
|
||||
@@ -17,6 +17,7 @@ import qualified Data.Map.Strict as M
|
||||
import Data.Maybe (catMaybes)
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as S
|
||||
import Data.Word (Word16)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Notifications.Protocol
|
||||
import Simplex.Messaging.Protocol (NtfPrivateSignKey)
|
||||
@@ -49,26 +50,19 @@ data NtfTknData = NtfTknData
|
||||
tknVerifyKey :: C.APublicVerifyKey,
|
||||
tknDhKeys :: C.KeyPair 'C.X25519,
|
||||
tknDhSecret :: C.DhSecretX25519,
|
||||
tknRegCode :: NtfRegCode
|
||||
tknRegCode :: NtfRegCode,
|
||||
tknCronInterval :: TVar Word16
|
||||
}
|
||||
|
||||
mkNtfTknData :: NtfTokenId -> NewNtfEntity 'Token -> C.KeyPair 'C.X25519 -> C.DhSecretX25519 -> NtfRegCode -> STM NtfTknData
|
||||
mkNtfTknData ntfTknId (NewNtfTkn token tknVerifyKey _) tknDhKeys tknDhSecret tknRegCode = do
|
||||
tknStatus <- newTVar NTRegistered
|
||||
pure NtfTknData {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode}
|
||||
|
||||
-- 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}
|
||||
tknCronInterval <- newTVar 0
|
||||
pure NtfTknData {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval}
|
||||
|
||||
data NtfSubData = NtfSubData
|
||||
{ smpQueue :: SMPQueueNtf,
|
||||
{ ntfSubId :: NtfSubscriptionId,
|
||||
smpQueue :: SMPQueueNtf,
|
||||
notifierKey :: NtfPrivateSignKey,
|
||||
tokenId :: NtfTokenId,
|
||||
subStatus :: TVar NtfSubStatus
|
||||
@@ -175,10 +169,10 @@ getActiveNtfToken st tknId =
|
||||
tStatus <- readTVar tknStatus
|
||||
pure $ if tStatus == NTActive then Just tkn else Nothing
|
||||
|
||||
mkNtfSubData :: NewNtfEntity 'Subscription -> STM NtfSubData
|
||||
mkNtfSubData (NewNtfSub tokenId smpQueue notifierKey) = do
|
||||
mkNtfSubData :: NtfSubscriptionId -> NewNtfEntity 'Subscription -> STM NtfSubData
|
||||
mkNtfSubData ntfSubId (NewNtfSub tokenId smpQueue notifierKey) = do
|
||||
subStatus <- newTVar NSNew
|
||||
pure NtfSubData {smpQueue, tokenId, subStatus, notifierKey}
|
||||
pure NtfSubData {ntfSubId, smpQueue, tokenId, subStatus, notifierKey}
|
||||
|
||||
addNtfSubscription :: NtfStore -> NtfSubscriptionId -> NtfSubData -> STM (Maybe ())
|
||||
addNtfSubscription st subId sub@NtfSubData {smpQueue, tokenId} =
|
||||
|
||||
@@ -0,0 +1,227 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Simplex.Messaging.Notifications.Server.StoreLog
|
||||
( StoreLog,
|
||||
NtfStoreLogRecord (..),
|
||||
readWriteNtfStore,
|
||||
logCreateToken,
|
||||
logTokenStatus,
|
||||
logUpdateToken,
|
||||
logTokenCron,
|
||||
logDeleteToken,
|
||||
logCreateSubscription,
|
||||
logSubscriptionStatus,
|
||||
logDeleteSubscription,
|
||||
closeStoreLog,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Concurrent.STM
|
||||
import Control.Monad (void)
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Word (Word16)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Notifications.Protocol
|
||||
import Simplex.Messaging.Notifications.Server.Store
|
||||
import Simplex.Messaging.Protocol (NtfPrivateSignKey)
|
||||
import Simplex.Messaging.Server.StoreLog
|
||||
import Simplex.Messaging.Util (whenM)
|
||||
import System.Directory (doesFileExist, renameFile)
|
||||
import System.IO
|
||||
|
||||
data NtfStoreLogRecord
|
||||
= CreateToken NtfTknRec
|
||||
| TokenStatus NtfTokenId NtfTknStatus
|
||||
| UpdateToken NtfTokenId DeviceToken NtfRegCode
|
||||
| TokenCron NtfTokenId Word16
|
||||
| DeleteToken NtfTokenId
|
||||
| CreateSubscription NtfSubRec
|
||||
| SubscriptionStatus NtfSubscriptionId NtfSubStatus
|
||||
| DeleteSubscription NtfSubscriptionId
|
||||
|
||||
data NtfTknRec = NtfTknRec
|
||||
{ ntfTknId :: NtfTokenId,
|
||||
token :: DeviceToken,
|
||||
tknStatus :: NtfTknStatus,
|
||||
tknVerifyKey :: C.APublicVerifyKey,
|
||||
tknDhKeys :: C.KeyPair 'C.X25519,
|
||||
tknDhSecret :: C.DhSecretX25519,
|
||||
tknRegCode :: NtfRegCode,
|
||||
tknCronInterval :: Word16
|
||||
}
|
||||
|
||||
mkTknData :: NtfTknRec -> STM NtfTknData
|
||||
mkTknData NtfTknRec {ntfTknId, token, tknStatus = status, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval = cronInt} = do
|
||||
tknStatus <- newTVar status
|
||||
tknCronInterval <- newTVar cronInt
|
||||
pure NtfTknData {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval}
|
||||
|
||||
mkTknRec :: NtfTknData -> STM NtfTknRec
|
||||
mkTknRec NtfTknData {ntfTknId, token, tknStatus = status, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval = cronInt} = do
|
||||
tknStatus <- readTVar status
|
||||
tknCronInterval <- readTVar cronInt
|
||||
pure NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval}
|
||||
|
||||
data NtfSubRec = NtfSubRec
|
||||
{ ntfSubId :: NtfSubscriptionId,
|
||||
smpQueue :: SMPQueueNtf,
|
||||
notifierKey :: NtfPrivateSignKey,
|
||||
tokenId :: NtfTokenId,
|
||||
subStatus :: NtfSubStatus
|
||||
}
|
||||
|
||||
mkSubData :: NtfSubRec -> STM NtfSubData
|
||||
mkSubData NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus = status} = do
|
||||
subStatus <- newTVar status
|
||||
pure NtfSubData {ntfSubId, smpQueue, notifierKey, tokenId, subStatus}
|
||||
|
||||
mkSubRec :: NtfSubData -> STM NtfSubRec
|
||||
mkSubRec NtfSubData {ntfSubId, smpQueue, notifierKey, tokenId, subStatus = status} = do
|
||||
subStatus <- readTVar status
|
||||
pure NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus}
|
||||
|
||||
instance StrEncoding NtfStoreLogRecord where
|
||||
strEncode = \case
|
||||
CreateToken tknRec -> strEncode (Str "TCREATE", tknRec)
|
||||
TokenStatus tknId tknStatus -> strEncode (Str "TSTATUS", tknId, tknStatus)
|
||||
UpdateToken tknId token regCode -> strEncode (Str "TUPDATE", tknId, token, regCode)
|
||||
TokenCron tknId cronInt -> strEncode (Str "TCRON", tknId, cronInt)
|
||||
DeleteToken tknId -> strEncode (Str "TDELETE", tknId)
|
||||
CreateSubscription subRec -> strEncode (Str "SCREATE", subRec)
|
||||
SubscriptionStatus subId subStatus -> strEncode (Str "SSTATUS", subId, subStatus)
|
||||
DeleteSubscription subId -> strEncode (Str "SDELETE", subId)
|
||||
strP =
|
||||
A.choice
|
||||
[ "TCREATE " *> (CreateToken <$> strP),
|
||||
"TSTATUS " *> (TokenStatus <$> strP_ <*> strP),
|
||||
"TUPDATE " *> (UpdateToken <$> strP_ <*> strP_ <*> strP),
|
||||
"TCRON " *> (TokenCron <$> strP_ <*> strP),
|
||||
"TDELETE " *> (DeleteToken <$> strP),
|
||||
"SCREATE " *> (CreateSubscription <$> strP),
|
||||
"SSTATUS " *> (SubscriptionStatus <$> strP_ <*> strP),
|
||||
"SDELETE " *> (DeleteSubscription <$> strP)
|
||||
]
|
||||
|
||||
instance StrEncoding NtfTknRec where
|
||||
strEncode NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval} =
|
||||
B.unwords
|
||||
[ "tknId=" <> strEncode ntfTknId,
|
||||
"token=" <> strEncode token,
|
||||
"tokenStatus=" <> strEncode tknStatus,
|
||||
"verifyKey=" <> strEncode tknVerifyKey,
|
||||
"dhKeys=" <> strEncode tknDhKeys,
|
||||
"dhSecret=" <> strEncode tknDhSecret,
|
||||
"regCode=" <> strEncode tknRegCode,
|
||||
"cron=" <> strEncode tknCronInterval
|
||||
]
|
||||
strP = do
|
||||
ntfTknId <- "tknId=" *> strP_
|
||||
token <- "token=" *> strP_
|
||||
tknStatus <- "tokenStatus=" *> strP_
|
||||
tknVerifyKey <- "verifyKey=" *> strP_
|
||||
tknDhKeys <- "dhKeys=" *> strP_
|
||||
tknDhSecret <- "dhSecret=" *> strP_
|
||||
tknRegCode <- "regCode=" *> strP_
|
||||
tknCronInterval <- "cron=" *> strP
|
||||
pure NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhKeys, tknDhSecret, tknRegCode, tknCronInterval}
|
||||
|
||||
instance StrEncoding NtfSubRec where
|
||||
strEncode NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus} =
|
||||
B.unwords
|
||||
[ "subId=" <> strEncode ntfSubId,
|
||||
"smpQueue=" <> strEncode smpQueue,
|
||||
"notifierKey=" <> strEncode notifierKey,
|
||||
"tknId=" <> strEncode tokenId,
|
||||
"subStatus=" <> strEncode subStatus
|
||||
]
|
||||
strP = do
|
||||
ntfSubId <- "subId=" *> strP_
|
||||
smpQueue <- "smpQueue=" *> strP_
|
||||
notifierKey <- "notifierKey=" *> strP_
|
||||
tokenId <- "tknId=" *> strP_
|
||||
subStatus <- "subStatus=" *> strP
|
||||
pure NtfSubRec {ntfSubId, smpQueue, notifierKey, tokenId, subStatus}
|
||||
|
||||
logNtfStoreRecord :: StoreLog 'WriteMode -> NtfStoreLogRecord -> IO ()
|
||||
logNtfStoreRecord = writeStoreLogRecord
|
||||
|
||||
logCreateToken :: StoreLog 'WriteMode -> NtfTknData -> IO ()
|
||||
logCreateToken s tkn = logNtfStoreRecord s . CreateToken =<< atomically (mkTknRec tkn)
|
||||
|
||||
logTokenStatus :: StoreLog 'WriteMode -> NtfTokenId -> NtfTknStatus -> IO ()
|
||||
logTokenStatus s tknId tknStatus = logNtfStoreRecord s $ TokenStatus tknId tknStatus
|
||||
|
||||
logUpdateToken :: StoreLog 'WriteMode -> NtfTokenId -> DeviceToken -> NtfRegCode -> IO ()
|
||||
logUpdateToken s tknId token regCode = logNtfStoreRecord s $ UpdateToken tknId token regCode
|
||||
|
||||
logTokenCron :: StoreLog 'WriteMode -> NtfTokenId -> Word16 -> IO ()
|
||||
logTokenCron s tknId cronInt = logNtfStoreRecord s $ TokenCron tknId cronInt
|
||||
|
||||
logDeleteToken :: StoreLog 'WriteMode -> NtfTokenId -> IO ()
|
||||
logDeleteToken s tknId = logNtfStoreRecord s $ DeleteToken tknId
|
||||
|
||||
logCreateSubscription :: StoreLog 'WriteMode -> NtfSubData -> IO ()
|
||||
logCreateSubscription s sub = logNtfStoreRecord s . CreateSubscription =<< atomically (mkSubRec sub)
|
||||
|
||||
logSubscriptionStatus :: StoreLog 'WriteMode -> NtfSubscriptionId -> NtfSubStatus -> IO ()
|
||||
logSubscriptionStatus s subId subStatus = logNtfStoreRecord s $ SubscriptionStatus subId subStatus
|
||||
|
||||
logDeleteSubscription :: StoreLog 'WriteMode -> NtfSubscriptionId -> IO ()
|
||||
logDeleteSubscription s subId = logNtfStoreRecord s $ DeleteSubscription subId
|
||||
|
||||
readWriteNtfStore :: FilePath -> NtfStore -> IO (StoreLog 'WriteMode)
|
||||
readWriteNtfStore f st = do
|
||||
whenM (doesFileExist f) $ do
|
||||
readNtfStore f st
|
||||
renameFile f $ f <> ".bak"
|
||||
s <- openWriteStoreLog f
|
||||
writeNtfStore s st
|
||||
pure s
|
||||
|
||||
readNtfStore :: FilePath -> NtfStore -> IO ()
|
||||
readNtfStore f st = mapM_ addNtfLogRecord . B.lines =<< B.readFile f
|
||||
where
|
||||
addNtfLogRecord s = case strDecode s of
|
||||
Left e -> B.putStrLn $ "Log parsing error (" <> B.pack e <> "): " <> B.take 100 s
|
||||
Right lr -> atomically $ case lr of
|
||||
CreateToken r@NtfTknRec {ntfTknId} -> do
|
||||
tkn <- mkTknData r
|
||||
addNtfToken st ntfTknId tkn
|
||||
TokenStatus tknId status ->
|
||||
getNtfToken st tknId
|
||||
>>= mapM_ (\NtfTknData {tknStatus} -> writeTVar tknStatus status)
|
||||
UpdateToken tknId token' tknRegCode ->
|
||||
getNtfToken st tknId
|
||||
>>= mapM_
|
||||
( \tkn@NtfTknData {tknStatus} -> do
|
||||
removeTokenRegistration st tkn
|
||||
writeTVar tknStatus NTRegistered
|
||||
addNtfToken st tknId tkn {token = token', tknRegCode}
|
||||
)
|
||||
TokenCron tknId cronInt ->
|
||||
getNtfToken st tknId
|
||||
>>= mapM_ (\NtfTknData {tknCronInterval} -> writeTVar tknCronInterval cronInt)
|
||||
DeleteToken tknId ->
|
||||
void $ deleteNtfToken st tknId
|
||||
CreateSubscription r@NtfSubRec {ntfSubId} -> do
|
||||
sub <- mkSubData r
|
||||
void $ addNtfSubscription st ntfSubId sub
|
||||
SubscriptionStatus subId status ->
|
||||
getNtfSubscription st subId
|
||||
>>= mapM_ (\NtfSubData {subStatus} -> writeTVar subStatus status)
|
||||
DeleteSubscription subId ->
|
||||
deleteNtfSubscription st subId
|
||||
|
||||
writeNtfStore :: StoreLog 'WriteMode -> NtfStore -> IO ()
|
||||
writeNtfStore s NtfStore {tokens, subscriptions} = do
|
||||
atomically (readTVar tokens >>= mapM mkTknRec)
|
||||
>>= mapM_ (writeStoreLogRecord s . CreateToken)
|
||||
atomically (readTVar subscriptions >>= mapM mkSubRec)
|
||||
>>= mapM_ (writeStoreLogRecord s . CreateSubscription)
|
||||
Reference in new issue
Block a user