diff --git a/CHANGELOG.md b/CHANGELOG.md index 15d93378e..21e752c68 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,36 @@ +# 6.0.4 + +SMP server: +- better performance/memory: fewer map updates on re-subscriptions (#1297), split and reduce STM transactions (#1294) +- send DELD when subscribed queue is deleted (#1312) +- add created/updated/used date to queues to manage expiration (#1306) + +XFTP server: truncate file creation time to 1 hour (#1310) + +Servers: +- bind control port only to 127.0.0.1 for better security in case of firewall misconfiguration (#1280) +- reduce memory used for period stats (#1298) + +Agent: process last notification from list (#1307) +- report receive file error with redirected file ID, when redirect is present (#1304) +- special error when deleted user record is not in database (#1303) +- fix race when sending a message to the deleted connection (#1296) +- support for multiple messages in a single notification + +Ntf server: +- only use SOCKS proxy for servers without public address (#1314) + +# 6.0.3 + +Agent: +- fix possible stuck queue rotation (#1290). + +SMP server: +- batch END responses when subscribed client switches to reduce server and client traffic. +- reduce STM transactions for better performance. +- add stats for END events and for SUB/DEL event batches. +- remove "expensive" stats to save memory. + # 6.0.2 SMP agent: diff --git a/apps/ntf-server/Main.hs b/apps/ntf-server/Main.hs index 31dbaec07..ac93580b9 100644 --- a/apps/ntf-server/Main.hs +++ b/apps/ntf-server/Main.hs @@ -15,7 +15,7 @@ logCfg = LogConfig {lc_file = Nothing, lc_stderr = True} main :: IO () main = do - setLogLevel LogDebug -- change to LogError in production + setLogLevel LogInfo cfgPath <- getEnvPath "NTF_SERVER_CFG_PATH" defaultCfgPath logPath <- getEnvPath "NTF_SERVER_LOG_PATH" defaultLogPath withGlobalLogging logCfg $ ntfServerCLI cfgPath logPath diff --git a/package.yaml b/package.yaml index 1b30d0f2c..da0ec8a9c 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: simplexmq -version: 6.0.2.0 +version: 6.0.4.0 synopsis: SimpleXMQ message broker description: | This package includes <./docs/Simplex-Messaging-Server.html server>, @@ -47,6 +47,7 @@ dependencies: - direct-sqlcipher == 2.3.* - directory == 1.3.* - filepath == 1.4.* + - hashable == 1.4.* - hourglass == 0.2.* - http-types == 0.12.* - http2 >= 4.2.2 && < 4.3 diff --git a/rfcs/2024-07-06-ios-notifications.md b/rfcs/2024-07-06-ios-notifications.md new file mode 100644 index 000000000..c60d7baf3 --- /dev/null +++ b/rfcs/2024-07-06-ios-notifications.md @@ -0,0 +1,18 @@ +# iOS notifications stability + +## Problem + +iOS notifications may fail to deliver for several reasons, but there are two important reasons that we could address: +- when notification server is not subscribed to SMP server(s), the notifications can be dropped - it can happen because either notification server restarts or becuase SMP server restarted and some messages are received before notification server resubscribed. We lose approximately 3% of notifications because of this reason. +- when user device is offline or has low power condition, Apple does not deliver notification, but puts them to storage. If while the notification is in storage a new one arrives it would overwrite the previous notification. If it was the message to the same message queue, the client will download messages anyway, up to a limit, but if the message was to another queue, it will not be delivered until the app is opened. Apple delivers about 88% of notifications that should be delivered (not accounting for uninstalled apps), the rest is replaced with the newer notifications. + +## Solution + +The first problem can be solved by preserving notifications for a limited time (say 1 hour) in case there is no subscription to notification from notification server. At the very least, they can be preserved in SMP server memory but can also be stored to a file on restart, similar to messages, and be delivered when notification server resubscribes. It is sufficient to store one notification per messaging queue. + +The second problem is both more damaging and more complex to solve. The solution could be to always deliver several last notifications to different queues in one packet (Apple allows up to ~4-5kb notification size, and we are sending packets of fixed size 512 bytes, so we could fit up to 8-10 of them in each notification). + +Every time a client receives such batch of notifications if can: +- check if that notification was already received in the previous batch. +- if it was received, it would be ignored, otherwise it would be processed. +- process them one by one, started from the most recent one while the time allows. diff --git a/rfcs/2023-12-29-pqdr.md b/rfcs/done/2023-12-29-pqdr.md similarity index 100% rename from rfcs/2023-12-29-pqdr.md rename to rfcs/done/2023-12-29-pqdr.md diff --git a/rfcs/2024-03-03-pqdr-version.md b/rfcs/done/2024-03-03-pqdr-version.md similarity index 100% rename from rfcs/2024-03-03-pqdr-version.md rename to rfcs/done/2024-03-03-pqdr-version.md diff --git a/rfcs/2024-06-14-fast-connection.md b/rfcs/done/2024-06-14-fast-connection.md similarity index 100% rename from rfcs/2024-06-14-fast-connection.md rename to rfcs/done/2024-06-14-fast-connection.md diff --git a/simplexmq.cabal b/simplexmq.cabal index 0e84119ac..86eda28b4 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -5,7 +5,7 @@ cabal-version: 1.12 -- see: https://github.com/sol/hpack name: simplexmq -version: 6.0.2.0 +version: 6.0.4.0 synopsis: SimpleXMQ message broker description: This package includes <./docs/Simplex-Messaging-Server.html server>, <./docs/Simplex-Messaging-Client.html client> and @@ -236,6 +236,7 @@ library , direct-sqlcipher ==2.3.* , directory ==1.3.* , filepath ==1.4.* + , hashable ==1.4.* , hourglass ==0.2.* , http-types ==0.12.* , http2 >=4.2.2 && <4.3 @@ -310,6 +311,7 @@ executable ntf-server , direct-sqlcipher ==2.3.* , directory ==1.3.* , filepath ==1.4.* + , hashable ==1.4.* , hourglass ==0.2.* , http-types ==0.12.* , http2 >=4.2.2 && <4.3 @@ -389,6 +391,7 @@ executable smp-server , directory ==1.3.* , file-embed , filepath ==1.4.* + , hashable ==1.4.* , hourglass ==0.2.* , http-types ==0.12.* , http2 >=4.2.2 && <4.3 @@ -467,6 +470,7 @@ executable xftp , direct-sqlcipher ==2.3.* , directory ==1.3.* , filepath ==1.4.* + , hashable ==1.4.* , hourglass ==0.2.* , http-types ==0.12.* , http2 >=4.2.2 && <4.3 @@ -542,6 +546,7 @@ executable xftp-server , direct-sqlcipher ==2.3.* , directory ==1.3.* , filepath ==1.4.* + , hashable ==1.4.* , hourglass ==0.2.* , http-types ==0.12.* , http2 >=4.2.2 && <4.3 @@ -653,6 +658,7 @@ test-suite simplexmq-test , directory ==1.3.* , filepath ==1.4.* , generic-random ==1.5.* + , hashable ==1.4.* , hourglass ==0.2.* , hspec ==2.11.* , hspec-core ==2.11.* diff --git a/src/Simplex/FileTransfer/Agent.hs b/src/Simplex/FileTransfer/Agent.hs index d6ee75ae9..aabe3ff28 100644 --- a/src/Simplex/FileTransfer/Agent.hs +++ b/src/Simplex/FileTransfer/Agent.hs @@ -45,7 +45,7 @@ import Data.List (foldl', partition, sortOn) import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) import qualified Data.Map.Strict as M -import Data.Maybe (mapMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Set as S import Data.Text (Text) import Data.Time.Clock (getCurrentTime) @@ -74,7 +74,7 @@ import qualified Simplex.Messaging.Crypto.File as CF import qualified Simplex.Messaging.Crypto.Lazy as LC import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String (strDecode, strEncode) -import Simplex.Messaging.Protocol (EntityId, ProtocolServer, ProtocolType (..), XFTPServer) +import Simplex.Messaging.Protocol (ProtocolServer, ProtocolType (..), XFTPServer) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Util (catchAll_, liftError, tshow, unlessM, whenM) import System.FilePath (takeFileName, ()) @@ -190,8 +190,9 @@ runXFTPRcvWorker c srv Worker {doWork} = do runXFTPOperation :: AgentConfig -> AM () runXFTPOperation AgentConfig {rcvFilesTTL, reconnectInterval = ri, xftpConsecutiveRetries} = withWork c doWork (\db -> getNextRcvChunkToDownload db srv rcvFilesTTL) $ \case - (RcvFileChunk {rcvFileId, rcvFileEntityId, fileTmpPath, replicas = []}, _) -> rcvWorkerInternalError c rcvFileId rcvFileEntityId (Just fileTmpPath) (INTERNAL "chunk has no replicas") - (fc@RcvFileChunk {userId, rcvFileId, rcvFileEntityId, digest, fileTmpPath, replicas = replica@RcvFileChunkReplica {rcvChunkReplicaId, server, delay} : _}, approvedRelays) -> do + (RcvFileChunk {rcvFileId, rcvFileEntityId, fileTmpPath, replicas = []}, _, redirectEntityId_) -> + rcvWorkerInternalError c rcvFileId rcvFileEntityId redirectEntityId_ (Just fileTmpPath) (INTERNAL "chunk has no replicas") + (fc@RcvFileChunk {userId, rcvFileId, rcvFileEntityId, digest, fileTmpPath, replicas = replica@RcvFileChunkReplica {rcvChunkReplicaId, server, delay} : _}, approvedRelays, redirectEntityId_) -> do let ri' = maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) delay withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop -> do liftIO $ waitWhileSuspended c @@ -202,7 +203,7 @@ runXFTPRcvWorker c srv Worker {doWork} = do where retryLoop loop e replicaDelay = do flip catchAgentError (\_ -> pure ()) $ do - when (serverHostError e) $ notify c rcvFileEntityId $ RFWARN e + when (serverHostError e) $ notify c (fromMaybe rcvFileEntityId redirectEntityId_) (RFWARN e) liftIO $ closeXFTPServerClient c userId server digest withStore' c $ \db -> updateRcvChunkReplicaDelay db rcvChunkReplicaId replicaDelay liftIO $ assertAgentForeground c @@ -211,7 +212,7 @@ runXFTPRcvWorker c srv Worker {doWork} = do atomically . incXFTPServerStat c userId srv $ case e of XFTP _ XFTP.AUTH -> downloadAuthErrs _ -> downloadErrs - rcvWorkerInternalError c rcvFileId rcvFileEntityId (Just fileTmpPath) e + rcvWorkerInternalError c rcvFileId rcvFileEntityId redirectEntityId_ (Just fileTmpPath) e downloadFileChunk :: RcvFileChunk -> RcvFileChunkReplica -> Bool -> AM () downloadFileChunk RcvFileChunk {userId, rcvFileId, rcvFileEntityId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath} replica approvedRelays = do unlessM ((approvedRelays ||) <$> ipAddressProtected') $ throwE $ FILE NOT_APPROVED @@ -262,11 +263,11 @@ retryOnError name loop done e = do then loop else done -rcvWorkerInternalError :: AgentClient -> DBRcvFileId -> RcvFileId -> Maybe FilePath -> AgentErrorType -> AM () -rcvWorkerInternalError c rcvFileId rcvFileEntityId tmpPath err = do +rcvWorkerInternalError :: AgentClient -> DBRcvFileId -> RcvFileId -> Maybe RcvFileId -> Maybe FilePath -> AgentErrorType -> AM () +rcvWorkerInternalError c rcvFileId rcvFileEntityId redirectEntityId_ tmpPath err = do lift $ forM_ tmpPath (removePath <=< toFSFilePath) withStore' c $ \db -> updateRcvFileError db rcvFileId (show err) - notify c rcvFileEntityId $ RFERR err + notify c (fromMaybe rcvFileEntityId redirectEntityId_) (RFERR err) runXFTPRcvLocalWorker :: AgentClient -> Worker -> AM () runXFTPRcvLocalWorker c Worker {doWork} = do @@ -279,8 +280,8 @@ runXFTPRcvLocalWorker c Worker {doWork} = do runXFTPOperation :: AgentConfig -> AM () runXFTPOperation AgentConfig {rcvFilesTTL} = withWork c doWork (`getNextRcvFileToDecrypt` rcvFilesTTL) $ - \f@RcvFile {rcvFileId, rcvFileEntityId, tmpPath} -> - decryptFile f `catchAgentError` rcvWorkerInternalError c rcvFileId rcvFileEntityId tmpPath + \f@RcvFile {rcvFileId, rcvFileEntityId, tmpPath, redirect} -> + decryptFile f `catchAgentError` rcvWorkerInternalError c rcvFileId rcvFileEntityId (redirectEntityId <$> redirect) tmpPath decryptFile :: RcvFile -> AM () decryptFile RcvFile {rcvFileId, rcvFileEntityId, size, digest, key, nonce, tmpPath, saveFile, status, chunks, redirect} = do let CryptoFile savePath cfArgs = saveFile @@ -346,7 +347,7 @@ xftpDeleteRcvFiles' c rcvFileEntityIds = do batchFiles :: (DB.Connection -> DBRcvFileId -> IO a) -> [RcvFile] -> AM' [Either AgentErrorType a] batchFiles f rcvFiles = withStoreBatch' c $ \db -> map (\RcvFile {rcvFileId} -> f db rcvFileId) rcvFiles -notify :: forall m e. (MonadIO m, AEntityI e) => AgentClient -> EntityId -> AEvent e -> m () +notify :: forall m e. (MonadIO m, AEntityI e) => AgentClient -> AEntityId -> AEvent e -> m () notify c entId cmd = atomically $ writeTBQueue (subQ c) ("", entId, AEvt (sAEntity @e) cmd) xftpSendFile' :: AgentClient -> UserId -> CryptoFile -> Int -> AM SndFileId diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs index 1404fd434..33e927265 100644 --- a/src/Simplex/FileTransfer/Client.hs +++ b/src/Simplex/FileTransfer/Client.hs @@ -50,6 +50,7 @@ import Simplex.Messaging.Protocol ProtocolServer (..), RecipientId, SenderId, + pattern NoEntity, ) import Simplex.Messaging.Transport (ALPN, HandshakeError (..), THandleAuth (..), THandleParams (..), TransportError (..), TransportPeer (..), supportedParameters) import Simplex.Messaging.Transport.Client (TransportClientConfig, TransportHost, alpn) @@ -222,7 +223,7 @@ createXFTPChunk :: Maybe BasicAuth -> ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId) createXFTPChunk c spKey file rcps auth_ = - sendXFTPCommand c spKey "" (FNEW file rcps auth_) Nothing >>= \case + sendXFTPCommand c spKey NoEntity (FNEW file rcps auth_) Nothing >>= \case (FRSndIds sId rIds, body) -> noFile body (sId, rIds) (r, _) -> throwE $ unexpectedResponse r @@ -278,7 +279,7 @@ pingXFTP :: XFTPClient -> ExceptT XFTPClientError IO () pingXFTP c@XFTPClient {thParams} = do t <- liftEither . first PCETransportError $ - xftpEncodeTransmission thParams ("", "", FileCmd SFRecipient PING) + xftpEncodeTransmission thParams ("", NoEntity, FileCmd SFRecipient PING) (r, _) <- sendXFTPTransmission c t Nothing case r of FRPong -> pure () diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs index 1eea6ef5a..079392a1b 100644 --- a/src/Simplex/FileTransfer/Client/Main.hs +++ b/src/Simplex/FileTransfer/Client/Main.hs @@ -44,7 +44,7 @@ import Data.List (foldl', sortOn) import Data.List.NonEmpty (NonEmpty (..), nonEmpty) import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) -import qualified Data.Map as M +import qualified Data.Map.Strict as M import Data.Maybe (fromMaybe, listToMaybe) import qualified Data.Text as T import Data.Word (Word32) diff --git a/src/Simplex/FileTransfer/Description.hs b/src/Simplex/FileTransfer/Description.hs index c702a177f..8cb98fd32 100644 --- a/src/Simplex/FileTransfer/Description.hs +++ b/src/Simplex/FileTransfer/Description.hs @@ -1,7 +1,9 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -53,7 +55,7 @@ import Data.List (foldl', sortOn) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) -import qualified Data.Map as M +import qualified Data.Map.Strict as M import Data.Maybe (fromMaybe) import Data.String import Data.Text (Text) @@ -139,12 +141,9 @@ data FileChunkReplica = FileChunkReplica } deriving (Eq, Show) -newtype ChunkReplicaId = ChunkReplicaId {unChunkReplicaId :: ByteString} +newtype ChunkReplicaId = ChunkReplicaId {unChunkReplicaId :: XFTPFileId} deriving (Eq, Show) - -instance StrEncoding ChunkReplicaId where - strEncode (ChunkReplicaId fid) = strEncode fid - strP = ChunkReplicaId <$> strP + deriving newtype (StrEncoding) instance FromJSON ChunkReplicaId where parseJSON = strParseJSON "ChunkReplicaId" @@ -153,10 +152,6 @@ instance ToJSON ChunkReplicaId where toJSON = strToJSON toEncoding = strToJEncoding -instance FromField ChunkReplicaId where fromField f = ChunkReplicaId <$> fromField f - -instance ToField ChunkReplicaId where toField (ChunkReplicaId s) = toField s - data YAMLFileDescription = YAMLFileDescription { party :: FileParty, size :: String, diff --git a/src/Simplex/FileTransfer/Protocol.hs b/src/Simplex/FileTransfer/Protocol.hs index c55b327f8..5899f9c3e 100644 --- a/src/Simplex/FileTransfer/Protocol.hs +++ b/src/Simplex/FileTransfer/Protocol.hs @@ -41,6 +41,7 @@ import Simplex.Messaging.Protocol ProtocolType (..), RcvPublicAuthKey, RcvPublicDhKey, + EntityId (..), RecipientId, SenderId, SentRawTransmission, @@ -170,7 +171,7 @@ data FileInfo = FileInfo } deriving (Show) -type XFTPFileId = ByteString +type XFTPFileId = EntityId instance FilePartyI p => ProtocolEncoding XFTPVersion XFTPErrorType (FileCommand p) where type Tag (FileCommand p) = FileCommandTag p @@ -191,7 +192,7 @@ instance FilePartyI p => ProtocolEncoding XFTPVersion XFTPErrorType (FileCommand fromProtocolError = fromProtocolError @XFTPVersion @XFTPErrorType @FileResponse {-# INLINE fromProtocolError #-} - checkCredentials (auth, _, fileId, _) cmd = case cmd of + checkCredentials (auth, _, EntityId fileId, _) cmd = case cmd of -- FNEW must not have signature and chunk ID FNEW {} | isNothing auth -> Left $ CMD NO_AUTH @@ -301,7 +302,7 @@ instance ProtocolEncoding XFTPVersion XFTPErrorType FileResponse where PEBlock -> BLOCK {-# INLINE fromProtocolError #-} - checkCredentials (_, _, entId, _) cmd = case cmd of + checkCredentials (_, _, EntityId entId, _) cmd = case cmd of FRSndIds {} -> noEntity -- ERR response does not always have entity ID FRErr _ -> Right cmd diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs index 819be9a81..434fcde4d 100644 --- a/src/Simplex/FileTransfer/Server.hs +++ b/src/Simplex/FileTransfer/Server.hs @@ -9,6 +9,7 @@ {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} @@ -32,11 +33,11 @@ import qualified Data.Map.Strict as M import Data.Maybe (fromMaybe, isJust) import qualified Data.Text as T import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime) -import Data.Time.Clock.System (SystemTime (..), getSystemTime) import Data.Time.Format.ISO8601 (iso8601Show) import Data.Word (Word32) import qualified Data.X509 as X import GHC.IO.Handle (hSetNewlineMode) +import GHC.IORef (atomicSwapIORef) import GHC.Stats (getRTSStats) import qualified Network.HTTP.Types as N import qualified Network.HTTP2.Server as H @@ -52,9 +53,10 @@ import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto.Lazy as LC import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Protocol (CorrId (..), RcvPublicAuthKey, RcvPublicDhKey, RecipientId, TransmissionAuth) +import Simplex.Messaging.Protocol (CorrId (..), EntityId (..), RcvPublicAuthKey, RcvPublicDhKey, RecipientId, TransmissionAuth, pattern NoEntity) import Simplex.Messaging.Server (dummyVerifyCmd, verifyCmdAuthorization) import Simplex.Messaging.Server.Expiration +import Simplex.Messaging.Server.QueueStore (RoundedSystemTime, getRoundedSystemTime) import Simplex.Messaging.Server.Stats import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM @@ -63,7 +65,7 @@ import Simplex.Messaging.Transport.Buffer (trimCR) import Simplex.Messaging.Transport.HTTP2 import Simplex.Messaging.Transport.HTTP2.File (fileBlockSize) import Simplex.Messaging.Transport.HTTP2.Server -import Simplex.Messaging.Transport.Server (runTCPServer, tlsServerCredentials) +import Simplex.Messaging.Transport.Server (runLocalTCPServer, tlsServerCredentials) import Simplex.Messaging.Util import Simplex.Messaging.Version import System.Exit (exitFailure) @@ -207,17 +209,17 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira withFile statsFilePath AppendMode $ \h -> liftIO $ do hSetBuffering h LineBuffering ts <- getCurrentTime - fromTime' <- atomically $ swapTVar fromTime ts - filesCreated' <- atomically $ swapTVar filesCreated 0 - fileRecipients' <- atomically $ swapTVar fileRecipients 0 - filesUploaded' <- atomically $ swapTVar filesUploaded 0 - filesExpired' <- atomically $ swapTVar filesExpired 0 - filesDeleted' <- atomically $ swapTVar filesDeleted 0 - files <- atomically $ periodStatCounts filesDownloaded ts - fileDownloads' <- atomically $ swapTVar fileDownloads 0 - fileDownloadAcks' <- atomically $ swapTVar fileDownloadAcks 0 - filesCount' <- readTVarIO filesCount - filesSize' <- readTVarIO filesSize + fromTime' <- atomicSwapIORef fromTime ts + filesCreated' <- atomicSwapIORef filesCreated 0 + fileRecipients' <- atomicSwapIORef fileRecipients 0 + filesUploaded' <- atomicSwapIORef filesUploaded 0 + filesExpired' <- atomicSwapIORef filesExpired 0 + filesDeleted' <- atomicSwapIORef filesDeleted 0 + files <- liftIO $ periodStatCounts filesDownloaded ts + fileDownloads' <- atomicSwapIORef fileDownloads 0 + fileDownloadAcks' <- atomicSwapIORef fileDownloadAcks 0 + filesCount' <- readIORef filesCount + filesSize' <- readIORef filesSize hPutStrLn h $ intercalate "," @@ -247,7 +249,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira u <- askUnliftIO liftIO $ do labelMyThread "control port server" - runTCPServer cpStarted port $ runCPClient u + runLocalTCPServer cpStarted port $ runCPClient u where runCPClient :: UnliftIO (ReaderT XFTPEnv IO) -> Socket -> IO () runCPClient u sock = do @@ -309,7 +311,7 @@ data ServerFile = ServerFile processRequest :: XFTPTransportRequest -> M () processRequest XFTPTransportRequest {thParams, reqBody = body@HTTP2Body {bodyHead}, sendResponse} - | B.length bodyHead /= xftpBlockSize = sendXFTPResponse ("", "", FRErr BLOCK) Nothing + | B.length bodyHead /= xftpBlockSize = sendXFTPResponse ("", NoEntity, FRErr BLOCK) Nothing | otherwise = do case xftpDecodeTransmission thParams bodyHead of Right (sig_, signed, (corrId, fId, cmdOrErr)) -> @@ -322,7 +324,7 @@ processRequest XFTPTransportRequest {thParams, reqBody = body@HTTP2Body {bodyHea Left e -> send (FRErr e) Nothing where send resp = sendXFTPResponse (corrId, fId, resp) - Left e -> sendXFTPResponse ("", "", FRErr e) Nothing + Left e -> sendXFTPResponse ("", NoEntity, FRErr e) Nothing where sendXFTPResponse (corrId, fId, resp) serverFile_ = do let t_ = xftpEncodeTransmission thParams (corrId, fId, resp) @@ -397,7 +399,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case r <- runExceptT $ do sizes <- asks $ allowedChunkSizes . config unless (size file `elem` sizes) $ throwE SIZE - ts <- liftIO getSystemTime + ts <- liftIO getFileTime -- TODO validate body empty sId <- ExceptT $ addFileRetry st file 3 ts rcps <- mapM (ExceptT . addRecipientRetry st 3 sId) rks @@ -405,12 +407,12 @@ processXFTPRequest HTTP2Body {bodyPart} = \case logAddFile sl sId file ts logAddRecipients sl sId rcps stats <- asks serverStats - atomically $ modifyTVar' (filesCreated stats) (+ 1) - atomically $ modifyTVar' (fileRecipients stats) (+ length rks) + lift $ incFileStat filesCreated + liftIO $ atomicModifyIORef'_ (fileRecipients stats) (+ length rks) let rIds = L.map (\(FileRecipient rId _) -> rId) rcps pure $ FRSndIds sId rIds pure $ either FRErr id r - addFileRetry :: FileStore -> FileInfo -> Int -> SystemTime -> M (Either XFTPErrorType XFTPFileId) + addFileRetry :: FileStore -> FileInfo -> Int -> RoundedSystemTime -> M (Either XFTPErrorType XFTPFileId) addFileRetry st file n ts = retryAdd n $ \sId -> runExceptT $ do ExceptT $ addFile st sId file ts @@ -435,7 +437,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case rcps <- mapM (ExceptT . addRecipientRetry st 3 sId) rks lift $ withFileLog $ \sl -> logAddRecipients sl sId rcps stats <- asks serverStats - atomically $ modifyTVar' (fileRecipients stats) (+ length rks) + liftIO $ atomicModifyIORef'_ (fileRecipients stats) (+ length rks) let rIds = L.map (\(FileRecipient rId _) -> rId) rcps pure $ FRRcvIds rIds pure $ either FRErr id r @@ -463,19 +465,19 @@ processXFTPRequest HTTP2Body {bodyPart} = \case \used -> let used' = used + fromIntegral size in if used' <= quota then (True, used') else (False, used) receive = do path <- asks $ filesPath . config - let fPath = path B.unpack (B64.encode senderId) + let fPath = path B.unpack (B64.encode $ unEntityId senderId) receiveChunk (XFTPRcvChunkSpec fPath size digest) >>= \case Right () -> do stats <- asks serverStats withFileLog $ \sl -> logPutFile sl senderId fPath atomically $ writeTVar filePath (Just fPath) - atomically $ modifyTVar' (filesUploaded stats) (+ 1) - atomically $ modifyTVar' (filesCount stats) (+ 1) - atomically $ modifyTVar' (filesSize stats) (+ fromIntegral size) + incFileStat filesUploaded + incFileStat filesCount + liftIO $ atomicModifyIORef'_ (filesSize stats) (+ fromIntegral size) pure FROk Left e -> do us <- asks $ usedStorage . store - atomically . modifyTVar' us $ subtract (fromIntegral size) + atomically $ modifyTVar' us $ subtract (fromIntegral size) liftIO $ whenM (doesFileExist fPath) (removeFile fPath) `catch` logFileError pure $ FRErr e receiveChunk spec = do @@ -494,8 +496,8 @@ processXFTPRequest HTTP2Body {bodyPart} = \case case LC.cbInit dhSecret cbNonce of Right sbState -> do stats <- asks serverStats - atomically $ modifyTVar' (fileDownloads stats) (+ 1) - atomically $ updatePeriodStats (filesDownloaded stats) senderId + incFileStat fileDownloads + liftIO $ updatePeriodStats (filesDownloaded stats) senderId pure (FRFile sDhKey cbNonce, Just ServerFile {filePath = path, fileSize = size, sbState}) _ -> pure (FRErr INTERNAL, Nothing) _ -> pure (FRErr NO_FILE, Nothing) @@ -511,8 +513,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case withFileLog (`logAckFile` rId) st <- asks store atomically $ deleteRecipient st rId fr - stats <- asks serverStats - atomically $ modifyTVar' (fileDownloadAcks stats) (+ 1) + incFileStat fileDownloadAcks pure FROk deleteServerFile_ :: FileRec -> M (Either XFTPErrorType ()) @@ -524,11 +525,14 @@ deleteServerFile_ FileRec {senderId, fileInfo, filePath} = do ExceptT $ first (\(_ :: SomeException) -> FILE_IO) <$> try (forM_ path $ \p -> whenM (doesFileExist p) (removeFile p >> deletedStats stats)) st <- asks store void $ atomically $ deleteFile st senderId - atomically $ modifyTVar' (filesDeleted stats) (+ 1) + lift $ incFileStat filesDeleted where deletedStats stats = do - atomically $ modifyTVar' (filesCount stats) (subtract 1) - atomically $ modifyTVar' (filesSize stats) (subtract $ fromIntegral $ size fileInfo) + liftIO $ atomicModifyIORef'_ (filesCount stats) (subtract 1) + liftIO $ atomicModifyIORef'_ (filesSize stats) (subtract $ fromIntegral $ size fileInfo) + +getFileTime :: IO RoundedSystemTime +getFileTime = getRoundedSystemTime fileTimePrecision expireServerFiles :: Maybe Int -> ExpirationConfig -> M () expireServerFiles itemDelay expCfg = do @@ -554,24 +558,21 @@ expireServerFiles itemDelay expCfg = do delete st sId = do withFileLog (`logDeleteFile` sId) void . atomically $ deleteFile st sId -- will not update usedStorage if sId isn't in store - FileServerStats {filesExpired} <- asks serverStats - atomically $ modifyTVar' filesExpired (+ 1) + incFileStat filesExpired randomId :: Int -> M ByteString randomId n = atomically . C.randomBytes n =<< asks random getFileId :: M XFTPFileId -getFileId = do - size <- asks (fileIdSize . config) - atomically . C.randomBytes size =<< asks random +getFileId = fmap EntityId . randomId =<< asks (fileIdSize . config) withFileLog :: (StoreLog 'WriteMode -> IO a) -> M () withFileLog action = liftIO . mapM_ action =<< asks storeLog -incFileStat :: (FileServerStats -> TVar Int) -> M () +incFileStat :: (FileServerStats -> IORef Int) -> M () incFileStat statSel = do stats <- asks serverStats - atomically $ modifyTVar (statSel stats) (+ 1) + liftIO $ atomicModifyIORef'_ (statSel stats) (+ 1) saveServerStats :: M () saveServerStats = @@ -594,7 +595,7 @@ restoreServerStats = asks (serverStatsBackupFile . config) >>= mapM_ restoreStat FileStore {files, usedStorage} <- asks store _filesCount <- M.size <$> readTVarIO files _filesSize <- readTVarIO usedStorage - atomically $ setFileServerStats s d {_filesCount, _filesSize} + liftIO $ setFileServerStats s d {_filesCount, _filesSize} renameFile f $ f <> ".bak" logInfo "server stats restored" when (statsFilesCount /= _filesCount) $ logWarn $ "Files count differs: stats: " <> tshow statsFilesCount <> ", store: " <> tshow _filesCount diff --git a/src/Simplex/FileTransfer/Server/Control.hs b/src/Simplex/FileTransfer/Server/Control.hs index a8786170e..75e54e55a 100644 --- a/src/Simplex/FileTransfer/Server/Control.hs +++ b/src/Simplex/FileTransfer/Server/Control.hs @@ -4,7 +4,7 @@ module Simplex.FileTransfer.Server.Control where import qualified Data.Attoparsec.ByteString.Char8 as A -import Data.ByteString (ByteString) +import Simplex.FileTransfer.Protocol (XFTPFileId) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol (BasicAuth) @@ -13,7 +13,7 @@ data CPClientRole = CPRNone | CPRUser | CPRAdmin data ControlProtocol = CPAuth BasicAuth | CPStatsRTS - | CPDelete ByteString + | CPDelete XFTPFileId | CPHelp | CPQuit | CPSkip diff --git a/src/Simplex/FileTransfer/Server/Stats.hs b/src/Simplex/FileTransfer/Server/Stats.hs index 1178dd5f6..a7951a65a 100644 --- a/src/Simplex/FileTransfer/Server/Stats.hs +++ b/src/Simplex/FileTransfer/Server/Stats.hs @@ -7,25 +7,24 @@ module Simplex.FileTransfer.Server.Stats where import Control.Applicative ((<|>)) import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.ByteString.Char8 as B +import Data.IORef import Data.Int (Int64) import Data.Time.Clock (UTCTime) import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Protocol (SenderId) import Simplex.Messaging.Server.Stats (PeriodStats, PeriodStatsData, getPeriodStatsData, newPeriodStats, setPeriodStats) -import UnliftIO.STM data FileServerStats = FileServerStats - { fromTime :: TVar UTCTime, - filesCreated :: TVar Int, - fileRecipients :: TVar Int, - filesUploaded :: TVar Int, - filesExpired :: TVar Int, - filesDeleted :: TVar Int, - filesDownloaded :: PeriodStats SenderId, - fileDownloads :: TVar Int, - fileDownloadAcks :: TVar Int, - filesCount :: TVar Int, - filesSize :: TVar Int64 + { fromTime :: IORef UTCTime, + filesCreated :: IORef Int, + fileRecipients :: IORef Int, + filesUploaded :: IORef Int, + filesExpired :: IORef Int, + filesDeleted :: IORef Int, + filesDownloaded :: PeriodStats, + fileDownloads :: IORef Int, + fileDownloadAcks :: IORef Int, + filesCount :: IORef Int, + filesSize :: IORef Int64 } data FileServerStatsData = FileServerStatsData @@ -35,7 +34,7 @@ data FileServerStatsData = FileServerStatsData _filesUploaded :: Int, _filesExpired :: Int, _filesDeleted :: Int, - _filesDownloaded :: PeriodStatsData SenderId, + _filesDownloaded :: PeriodStatsData, _fileDownloads :: Int, _fileDownloadAcks :: Int, _filesCount :: Int, @@ -45,47 +44,48 @@ data FileServerStatsData = FileServerStatsData newFileServerStats :: UTCTime -> IO FileServerStats newFileServerStats ts = do - fromTime <- newTVarIO ts - filesCreated <- newTVarIO 0 - fileRecipients <- newTVarIO 0 - filesUploaded <- newTVarIO 0 - filesExpired <- newTVarIO 0 - filesDeleted <- newTVarIO 0 + fromTime <- newIORef ts + filesCreated <- newIORef 0 + fileRecipients <- newIORef 0 + filesUploaded <- newIORef 0 + filesExpired <- newIORef 0 + filesDeleted <- newIORef 0 filesDownloaded <- newPeriodStats - fileDownloads <- newTVarIO 0 - fileDownloadAcks <- newTVarIO 0 - filesCount <- newTVarIO 0 - filesSize <- newTVarIO 0 + fileDownloads <- newIORef 0 + fileDownloadAcks <- newIORef 0 + filesCount <- newIORef 0 + filesSize <- newIORef 0 pure FileServerStats {fromTime, filesCreated, fileRecipients, filesUploaded, filesExpired, filesDeleted, filesDownloaded, fileDownloads, fileDownloadAcks, filesCount, filesSize} getFileServerStatsData :: FileServerStats -> IO FileServerStatsData getFileServerStatsData s = do - _fromTime <- readTVarIO $ fromTime (s :: FileServerStats) - _filesCreated <- readTVarIO $ filesCreated s - _fileRecipients <- readTVarIO $ fileRecipients s - _filesUploaded <- readTVarIO $ filesUploaded s - _filesExpired <- readTVarIO $ filesExpired s - _filesDeleted <- readTVarIO $ filesDeleted s + _fromTime <- readIORef $ fromTime (s :: FileServerStats) + _filesCreated <- readIORef $ filesCreated s + _fileRecipients <- readIORef $ fileRecipients s + _filesUploaded <- readIORef $ filesUploaded s + _filesExpired <- readIORef $ filesExpired s + _filesDeleted <- readIORef $ filesDeleted s _filesDownloaded <- getPeriodStatsData $ filesDownloaded s - _fileDownloads <- readTVarIO $ fileDownloads s - _fileDownloadAcks <- readTVarIO $ fileDownloadAcks s - _filesCount <- readTVarIO $ filesCount s - _filesSize <- readTVarIO $ filesSize s + _fileDownloads <- readIORef $ fileDownloads s + _fileDownloadAcks <- readIORef $ fileDownloadAcks s + _filesCount <- readIORef $ filesCount s + _filesSize <- readIORef $ filesSize s pure FileServerStatsData {_fromTime, _filesCreated, _fileRecipients, _filesUploaded, _filesExpired, _filesDeleted, _filesDownloaded, _fileDownloads, _fileDownloadAcks, _filesCount, _filesSize} -setFileServerStats :: FileServerStats -> FileServerStatsData -> STM () +-- this function is not thread safe, it is used on server start only +setFileServerStats :: FileServerStats -> FileServerStatsData -> IO () setFileServerStats s d = do - writeTVar (fromTime (s :: FileServerStats)) $! _fromTime (d :: FileServerStatsData) - writeTVar (filesCreated s) $! _filesCreated d - writeTVar (fileRecipients s) $! _fileRecipients d - writeTVar (filesUploaded s) $! _filesUploaded d - writeTVar (filesExpired s) $! _filesExpired d - writeTVar (filesDeleted s) $! _filesDeleted d + writeIORef (fromTime (s :: FileServerStats)) $! _fromTime (d :: FileServerStatsData) + writeIORef (filesCreated s) $! _filesCreated d + writeIORef (fileRecipients s) $! _fileRecipients d + writeIORef (filesUploaded s) $! _filesUploaded d + writeIORef (filesExpired s) $! _filesExpired d + writeIORef (filesDeleted s) $! _filesDeleted d setPeriodStats (filesDownloaded s) $! _filesDownloaded d - writeTVar (fileDownloads s) $! _fileDownloads d - writeTVar (fileDownloadAcks s) $! _fileDownloadAcks d - writeTVar (filesCount s) $! _filesCount d - writeTVar (filesSize s) $! _filesSize d + writeIORef (fileDownloads s) $! _fileDownloads d + writeIORef (fileDownloadAcks s) $! _fileDownloadAcks d + writeIORef (filesCount s) $! _filesCount d + writeIORef (filesSize s) $! _filesSize d instance StrEncoding FileServerStatsData where strEncode FileServerStatsData {_fromTime, _filesCreated, _fileRecipients, _filesUploaded, _filesExpired, _filesDeleted, _filesDownloaded, _fileDownloads, _fileDownloadAcks, _filesCount, _filesSize} = diff --git a/src/Simplex/FileTransfer/Server/Store.hs b/src/Simplex/FileTransfer/Server/Store.hs index b56b516aa..10c34819f 100644 --- a/src/Simplex/FileTransfer/Server/Store.hs +++ b/src/Simplex/FileTransfer/Server/Store.hs @@ -17,6 +17,7 @@ module Simplex.FileTransfer.Server.Store expiredFilePath, getFile, ackFile, + fileTimePrecision, ) where @@ -25,12 +26,12 @@ import qualified Data.Attoparsec.ByteString.Char8 as A import Data.Int (Int64) import Data.Set (Set) import qualified Data.Set as S -import Data.Time.Clock.System (SystemTime (..)) import Simplex.FileTransfer.Protocol (FileInfo (..), SFileParty (..), XFTPFileId) import Simplex.FileTransfer.Transport (XFTPErrorType (..)) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol (RcvPublicAuthKey, RecipientId, SenderId) +import Simplex.Messaging.Server.QueueStore (RoundedSystemTime (..)) import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Util (ifM, ($>>=)) @@ -46,9 +47,12 @@ data FileRec = FileRec fileInfo :: FileInfo, filePath :: TVar (Maybe FilePath), recipientIds :: TVar (Set RecipientId), - createdAt :: SystemTime + createdAt :: RoundedSystemTime } +fileTimePrecision :: Int64 +fileTimePrecision = 3600 -- truncate creation time to 1 hour + data FileRecipient = FileRecipient RecipientId RcvPublicAuthKey instance StrEncoding FileRecipient where @@ -62,14 +66,14 @@ newFileStore = do usedStorage <- newTVarIO 0 pure FileStore {files, recipients, usedStorage} -addFile :: FileStore -> SenderId -> FileInfo -> SystemTime -> STM (Either XFTPErrorType ()) +addFile :: FileStore -> SenderId -> FileInfo -> RoundedSystemTime -> STM (Either XFTPErrorType ()) addFile FileStore {files} sId fileInfo createdAt = ifM (TM.member sId files) (pure $ Left DUPLICATE_) $ do f <- newFileRec sId fileInfo createdAt TM.insert sId f files pure $ Right () -newFileRec :: SenderId -> FileInfo -> SystemTime -> STM FileRec +newFileRec :: SenderId -> FileInfo -> RoundedSystemTime -> STM FileRec newFileRec senderId fileInfo createdAt = do recipientIds <- newTVar S.empty filePath <- newTVar Nothing @@ -120,8 +124,8 @@ getFile st party fId = case party of expiredFilePath :: FileStore -> XFTPFileId -> Int64 -> STM (Maybe (Maybe FilePath)) expiredFilePath FileStore {files} sId old = TM.lookup sId files - $>>= \FileRec {filePath, createdAt} -> - if systemSeconds createdAt < old + $>>= \FileRec {filePath, createdAt = RoundedSystemTime createdAt} -> + if createdAt + fileTimePrecision < old then Just <$> readTVar filePath else pure Nothing diff --git a/src/Simplex/FileTransfer/Server/StoreLog.hs b/src/Simplex/FileTransfer/Server/StoreLog.hs index 8e8add3d6..9d3919c2c 100644 --- a/src/Simplex/FileTransfer/Server/StoreLog.hs +++ b/src/Simplex/FileTransfer/Server/StoreLog.hs @@ -28,18 +28,18 @@ import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) import qualified Data.Map.Strict as M -import Data.Time.Clock.System (SystemTime) import Simplex.FileTransfer.Protocol (FileInfo (..)) import Simplex.FileTransfer.Server.Store import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol (RcvPublicAuthKey, RecipientId, SenderId) +import Simplex.Messaging.Server.QueueStore (RoundedSystemTime) import Simplex.Messaging.Server.StoreLog import Simplex.Messaging.Util (bshow, whenM) import System.Directory (doesFileExist, renameFile) import System.IO data FileStoreLogRecord - = AddFile SenderId FileInfo SystemTime + = AddFile SenderId FileInfo RoundedSystemTime | PutFile SenderId FilePath | AddRecipients SenderId (NonEmpty FileRecipient) | DeleteFile SenderId @@ -64,7 +64,7 @@ instance StrEncoding FileStoreLogRecord where logFileStoreRecord :: StoreLog 'WriteMode -> FileStoreLogRecord -> IO () logFileStoreRecord = writeStoreLogRecord -logAddFile :: StoreLog 'WriteMode -> SenderId -> FileInfo -> SystemTime -> IO () +logAddFile :: StoreLog 'WriteMode -> SenderId -> FileInfo -> RoundedSystemTime -> IO () logAddFile s = logFileStoreRecord s .:. AddFile logPutFile :: StoreLog 'WriteMode -> SenderId -> FilePath -> IO () diff --git a/src/Simplex/FileTransfer/Types.hs b/src/Simplex/FileTransfer/Types.hs index 15dc672da..8569bdd12 100644 --- a/src/Simplex/FileTransfer/Types.hs +++ b/src/Simplex/FileTransfer/Types.hs @@ -25,9 +25,9 @@ import Simplex.Messaging.Parsers import Simplex.Messaging.Protocol (XFTPServer) import System.FilePath (()) -type RcvFileId = ByteString +type RcvFileId = ByteString -- Agent entity ID -type SndFileId = ByteString +type SndFileId = ByteString -- Agent entity ID authTagSize :: Int64 authTagSize = fromIntegral C.authTagSize diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 755734fde..e8aa309df 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -166,7 +166,7 @@ import Simplex.Messaging.Agent.Store import Simplex.Messaging.Agent.Store.SQLite import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations -import Simplex.Messaging.Client (ProtocolClient (..), SMPClientError, ServerTransmission (..), ServerTransmissionBatch, temporaryClientError, unexpectedResponse) +import Simplex.Messaging.Client (SMPClientError, ServerTransmission (..), ServerTransmissionBatch, temporaryClientError, unexpectedResponse) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.File (CryptoFile, CryptoFileArgs) import Simplex.Messaging.Crypto.Ratchet (PQEncryption, PQSupport (..), pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn) @@ -174,14 +174,14 @@ import qualified Simplex.Messaging.Crypto.Ratchet as CR import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfRegCode (NtfRegCode), NtfTknStatus (..), NtfTokenId) -import Simplex.Messaging.Notifications.Server.Push.APNS (PNMessageData (..)) +import Simplex.Messaging.Notifications.Server.Push.APNS (PNMessageData (..), pnMessagesP) import Simplex.Messaging.Notifications.Types import Simplex.Messaging.Parsers (parse) -import Simplex.Messaging.Protocol (BrokerMsg, Cmd (..), EntityId, ErrorType (AUTH), MsgBody, MsgFlags (..), NtfServer, ProtoServerWithAuth, ProtocolType (..), ProtocolTypeI (..), SMPMsgMeta, SParty (..), SProtocolType (..), SndPublicAuthKey, SubscriptionMode (..), UserProtocol, VersionSMPC, sndAuthKeySMPClientVersion) +import Simplex.Messaging.Protocol (BrokerMsg, Cmd (..), ErrorType (AUTH), MsgBody, MsgFlags (..), NtfServer, ProtoServerWithAuth, ProtocolType (..), ProtocolTypeI (..), SMPMsgMeta, SParty (..), SProtocolType (..), SndPublicAuthKey, SubscriptionMode (..), UserProtocol, VersionSMPC, sndAuthKeySMPClientVersion) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.ServiceScheme (ServiceScheme (..)) import qualified Simplex.Messaging.TMap as TM -import Simplex.Messaging.Transport (SMPVersion, THandleParams (sessionId)) +import Simplex.Messaging.Transport (SMPVersion) import Simplex.Messaging.Util import Simplex.Messaging.Version import Simplex.RemoteControl.Client @@ -334,7 +334,7 @@ createConnection :: AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe createConnection c userId enableNtfs = withAgentEnv c .:: newConn c userId "" enableNtfs {-# INLINE createConnection #-} --- | Changes the user id associated with a connection +-- | Changes the user id associated with a connection changeConnectionUser :: AgentClient -> UserId -> ConnId -> UserId -> AE () changeConnectionUser c oldUserId connId newUserId = withAgentEnv c $ changeConnectionUser' c oldUserId connId newUserId {-# INLINE changeConnectionUser #-} @@ -891,7 +891,7 @@ joinConnSrv c userId connId hasNewConn enableNtfs cReqUri@CRContactUri {} cInfo lift (compatibleContactUri cReqUri) >>= \case Just (qInfo, vrsn) -> do (connId', cReq) <- newConnSrv c userId connId hasNewConn enableNtfs SCMInvitation Nothing (CR.IKNoPQ pqSup) subMode srv - void $ sendInvitation c userId qInfo vrsn cReq cInfo + void $ sendInvitation c userId connId' qInfo vrsn cReq cInfo pure (connId', False) Nothing -> throwE $ AGENT A_VERSION @@ -1020,7 +1020,7 @@ subscribeConnections' c connIds = do SomeConn _ conn -> do let cmd = if enableNtfs $ toConnData conn then NSCCreate else NSCDelete ConnData {connId} = toConnData conn - atomically $ writeTBQueue (ntfSubQ ns) (connId, cmd) + atomically $ writeTBQueue (ntfSubQ ns) (connId, cmd) resumeDelivery :: Map ConnId SomeConn -> AM () resumeDelivery conns = do conns' <- M.restrictKeys conns . S.fromList <$> withStore' c getConnectionsForDelivery @@ -1065,7 +1065,8 @@ getNotificationMessage' c nonce encNtfInfo = do withStore' c getActiveNtfToken >>= \case Just NtfToken {ntfDhSecret = Just dhSecret} -> do ntfData <- agentCbDecrypt dhSecret nonce encNtfInfo - PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta} <- liftEither (parse strP (INTERNAL "error parsing PNMessageData") ntfData) + pnMsgs <- liftEither (parse pnMessagesP (INTERNAL "error parsing PNMessageData") ntfData) + let PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta} = L.last pnMsgs (ntfConnId, rcvNtfDhSecret) <- withStore c (`getNtfRcvQueue` smpQueue) ntfMsgMeta <- (eitherToMaybe . smpDecode <$> agentCbDecrypt rcvNtfDhSecret nmsgNonce encNMsgMeta) `catchAgentError` \_ -> pure Nothing msgMeta <- getConnectionMessage' c ntfConnId @@ -1103,8 +1104,8 @@ sendMessagesB_ c reqs connIds = withConnLocks c connIds "sendMessages" $ do where getConn_ :: DB.Connection -> TVar (Maybe (Either AgentErrorType SomeConn)) -> MsgReq -> IO (Either AgentErrorType (MsgReq, SomeConn)) getConn_ db prev req@(connId, _, _, _) = - (req,) <$$> - if B.null connId + (req,) + <$$> if B.null connId then fromMaybe (Left $ INTERNAL "sendMessagesB_: empty prev connId") <$> readTVarIO prev else do conn <- first storeError <$> getConn db connId @@ -1343,7 +1344,7 @@ enqueueMessageB c reqs = do storeSentMsg db cfg req@(cData@ConnData {connId}, sq :| _, pqEnc_, msgFlags, aMessage) = fmap (first storeError) $ runExceptT $ do let AgentConfig {smpAgentVRange, e2eEncryptVRange} = cfg internalTs <- liftIO getCurrentTime - (internalId, internalSndId, prevMsgHash) <- liftIO $ updateSndIds db connId + (internalId, internalSndId, prevMsgHash) <- ExceptT $ updateSndIds db connId let privHeader = APrivHeader (unSndId internalSndId) prevMsgHash agentMsg = AgentMessage privHeader aMessage agentMsgStr = smpEncode agentMsg @@ -2208,7 +2209,7 @@ cleanupManager c@AgentClient {subQ} = do deleteExpiredReplicasForDeletion = do rcvFilesTTL <- asks $ rcvFilesTTL . config withStore' c (`deleteDeletedSndChunkReplicasExpired` rcvFilesTTL) - notify :: forall e. AEntityI e => EntityId -> AEvent e -> AM () + notify :: forall e. AEntityI e => AEntityId -> AEvent e -> AM () notify entId cmd = atomically $ writeTBQueue subQ ("", entId, AEvt (sAEntity @e) cmd) data ACKd = ACKd | ACKPending @@ -2345,7 +2346,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId HELLO -> helloMsg srvMsgId msgMeta conn'' >> ackDel msgId -- note that there is no ACK sent for A_MSG, it is sent with agent's user ACK command A_MSG body -> do - logServer "<--" c srv rId $ "MSG :" <> logSecret srvMsgId + logServer "<--" c srv rId $ "MSG :" <> logSecret' srvMsgId notify $ MSG msgMeta msgFlags body pure ACKPending A_RCVD rcpts -> qDuplex conn'' "RCVD" $ messagesRcvd rcpts msgMeta @@ -2355,7 +2356,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId QUSE qs -> qDuplexAckDel conn'' "QUSE" $ qUseMsg srvMsgId qs -- no action needed for QTEST -- any message in the new queue will mark it active and trigger deletion of the old queue - QTEST _ -> logServer "<--" c srv rId ("MSG :" <> logSecret srvMsgId) >> ackDel msgId + QTEST _ -> logServer "<--" c srv rId ("MSG :" <> logSecret' srvMsgId) >> ackDel msgId EREADY _ -> qDuplexAckDel conn'' "EREADY" $ ereadyMsg rcPrev where qDuplexAckDel :: Connection c -> String -> (Connection 'CDuplex -> AM ()) -> AM ACKd @@ -2378,7 +2379,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId | otherwise -> liftEither (parse smpP (AGENT A_MESSAGE) agentMsgBody) >>= \case AgentMessage _ (A_MSG body) -> do - logServer "<--" c srv rId $ "MSG :" <> logSecret srvMsgId + logServer "<--" c srv rId $ "MSG :" <> logSecret' srvMsgId notify $ MSG msgMeta msgFlags body pure ACKPending _ -> ack @@ -2449,17 +2450,14 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId handleNotifyAck :: AM ACKd -> AM ACKd handleNotifyAck m = m `catchAgentError` \e -> notify (ERR e) >> ack SMP.END -> - atomically (TM.lookup tSess (smpClients c) $>>= (tryReadTMVar . sessionVar) >>= processEND) + atomically (ifM (activeClientSession c tSess sessId) (removeSubscription c connId $> True) (pure False)) >>= notifyEnd where - processEND = \case - Just (Right clnt) - | sessId == sessionId (thParams $ connectedClient clnt) -> - removeSubscription c connId $> True - _ -> pure False notifyEnd removed | removed = notify END >> logServer "<--" c srv rId "END" | otherwise = logServer "<--" c srv rId "END from disconnected client - ignored" + -- Possibly, we need to add some flag to connection that it was deleted + SMP.DELD -> atomically (removeSubscription c connId) >> notify DELD SMP.ERR e -> notify $ ERR $ SMP (B.unpack $ strEncode srv) e r -> unexpected r where @@ -2500,7 +2498,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId smpConfirmation :: SMP.MsgId -> Connection c -> Maybe C.APublicAuthKey -> C.PublicKeyX25519 -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> ByteString -> VersionSMPC -> VersionSMPA -> AM () smpConfirmation srvMsgId conn' senderKey e2ePubKey e2eEncryption encConnInfo smpClientVersion agentVersion = do - logServer "<--" c srv rId $ "MSG :" <> logSecret srvMsgId + logServer "<--" c srv rId $ "MSG :" <> logSecret' srvMsgId AgentConfig {smpClientVRange, smpAgentVRange, e2eEncryptVRange} <- asks config let ConnData {pqSupport} = toConnData conn' unless @@ -2569,7 +2567,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId helloMsg :: SMP.MsgId -> MsgMeta -> Connection c -> AM () helloMsg srvMsgId MsgMeta {pqEncryption} conn' = do - logServer "<--" c srv rId $ "MSG :" <> logSecret srvMsgId + logServer "<--" c srv rId $ "MSG :" <> logSecret' srvMsgId case status of Active -> prohibited "hello: active" _ -> @@ -2593,7 +2591,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId continueSending srvMsgId addr (DuplexConnection _ _ sqs) = case findQ addr sqs of Just sq -> do - logServer "<--" c srv rId $ "MSG :" <> logSecret srvMsgId + logServer "<--" c srv rId $ "MSG :" <> logSecret' srvMsgId atomically $ TM.lookup (qAddress sq) (smpDeliveryWorkers c) >>= mapM_ (\(_, retryLock) -> tryPutTMVar retryLock ()) @@ -2602,7 +2600,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId messagesRcvd :: NonEmpty AMessageReceipt -> MsgMeta -> Connection 'CDuplex -> AM ACKd messagesRcvd rcpts msgMeta@MsgMeta {broker = (srvMsgId, _)} _ = do - logServer "<--" c srv rId $ "MSG :" <> logSecret srvMsgId + logServer "<--" c srv rId $ "MSG :" <> logSecret' srvMsgId rs <- forM rcpts $ \rcpt -> clientReceipt rcpt `catchAgentError` \e -> notify (ERR e) $> Nothing case L.nonEmpty . catMaybes $ L.toList rs of Just rs' -> notify (RCVD msgMeta rs') $> ACKPending @@ -2642,7 +2640,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId sq2 <- withStore c $ \db -> do liftIO $ mapM_ (deleteConnSndQueue db connId) delSqs addConnSndQueue db connId (sq_ :: NewSndQueue) {primary = True, dbReplaceQueueId = Just dbQueueId} - logServer "<--" c srv rId $ "MSG :" <> logSecret srvMsgId <> " " <> logSecret (senderId queueAddress) + logServer "<--" c srv rId $ "MSG :" <> logSecret' srvMsgId <> " " <> logSecret (senderId queueAddress) let sqInfo' = (sqInfo :: SMPQueueInfo) {queueAddress = queueAddress {dhPublicKey}} void . enqueueMessages c cData' sqs SMP.noMsgFlags $ QKEY [(sqInfo', sndPublicKey)] sq1 <- withStore' c $ \db -> setSndSwitchStatus db sq $ Just SSSendingQKEY @@ -2663,7 +2661,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId Just rq'@RcvQueue {rcvId, e2ePrivKey = dhPrivKey, smpClientVersion = cVer, status = status'} | status' == New || status' == Confirmed -> do checkRQSwchStatus rq RSSendingQADD - logServer "<--" c srv rId $ "MSG :" <> logSecret srvMsgId <> " " <> logSecret senderId + logServer "<--" c srv rId $ "MSG :" <> logSecret' srvMsgId <> " " <> logSecret senderId let dhSecret = C.dh' dhPublicKey dhPrivKey withStore' c $ \db -> setRcvQueueConfirmedE2E db rq' dhSecret $ min cVer cVer' enqueueCommand c "" connId (Just smpServer) $ AInternalCommand $ ICQSecure rcvId senderKey @@ -2684,7 +2682,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId case find ((replaceQId ==) . dbQId) sqs of Just sq1 -> do checkSQSwchStatus sq1 SSSendingQKEY - logServer "<--" c srv rId $ "MSG :" <> logSecret srvMsgId <> " " <> logSecret (snd addr) + logServer "<--" c srv rId $ "MSG :" <> logSecret' srvMsgId <> " " <> logSecret (snd addr) withStore' c $ \db -> setSndQueueStatus db sq' Secured let sq'' = (sq' :: SndQueue) {status = Secured} -- sending QTEST to the new queue only, the old one will be removed if sent successfully @@ -2708,7 +2706,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId smpInvitation :: SMP.MsgId -> Connection c -> ConnectionRequestUri 'CMInvitation -> ConnInfo -> AM () smpInvitation srvMsgId conn' connReq@(CRInvitationUri crData _) cInfo = do - logServer "<--" c srv rId $ "MSG :" <> logSecret srvMsgId + logServer "<--" c srv rId $ "MSG :" <> logSecret' srvMsgId case conn' of ContactConnection {} -> do -- show connection request even if invitaion via contact address is not compatible. @@ -2853,7 +2851,7 @@ secureConfirmQueue c cData@ConnData {connId, connAgentVersion, pqSupport} sq srv currentE2EVersion <- asks $ maxVersion . e2eEncryptVRange . config withStore c $ \db -> runExceptT $ do let agentMsgBody = smpEncode aMessage - (_, internalSndId, _) <- liftIO $ updateSndIds db connId + (_, internalSndId, _) <- ExceptT $ updateSndIds db connId liftIO $ updateSndMsgHash db connId internalSndId (C.sha256Hash agentMsgBody) let pqEnc = CR.pqSupportToEnc pqSupport (encConnInfo, _) <- agentRatchetEncrypt db cData agentMsgBody e2eEncConnInfoLength (Just pqEnc) currentE2EVersion @@ -2886,7 +2884,7 @@ storeConfirmation c cData@ConnData {connId, pqSupport, connAgentVersion = v} sq currentE2EVersion <- asks $ maxVersion . e2eEncryptVRange . config withStore c $ \db -> runExceptT $ do internalTs <- liftIO getCurrentTime - (internalId, internalSndId, prevMsgHash) <- liftIO $ updateSndIds db connId + (internalId, internalSndId, prevMsgHash) <- ExceptT $ updateSndIds db connId let agentMsgStr = smpEncode agentMsg internalHash = C.sha256Hash agentMsgStr pqEnc = CR.pqSupportToEnc pqSupport @@ -2912,7 +2910,7 @@ enqueueRatchetKey c cData@ConnData {connId} sq e2eEncryption = do storeRatchetKey :: VersionSMPA -> AM InternalId storeRatchetKey agentVersion = withStore c $ \db -> runExceptT $ do internalTs <- liftIO getCurrentTime - (internalId, internalSndId, prevMsgHash) <- liftIO $ updateSndIds db connId + (internalId, internalSndId, prevMsgHash) <- ExceptT $ updateSndIds db connId let agentMsg = AgentRatchetInfo "" agentMsgStr = smpEncode agentMsg internalHash = C.sha256Hash agentMsgStr diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 8f339cab7..c2f1c8aa6 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -12,6 +12,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StrictData #-} @@ -82,6 +83,7 @@ module Simplex.Messaging.Agent.Client deleteQueues, logServer, logSecret, + logSecret', removeSubscription, hasActiveSubscription, hasPendingSubscription, @@ -228,7 +230,7 @@ import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, parse, sumT import Simplex.Messaging.Protocol ( AProtocolType (..), BrokerMsg, - EntityId, + EntityId (..), ErrorType, MsgFlags (..), MsgId, @@ -241,7 +243,6 @@ import Simplex.Messaging.Protocol ProtocolServer (..), ProtocolType (..), ProtocolTypeI (..), - QueueId, QueueIdsKeys (..), RcvMessage (..), RcvNtfPublicDhKey, @@ -255,6 +256,7 @@ import Simplex.Messaging.Protocol VersionSMPC, XFTPServer, XFTPServerWithAuth, + pattern NoEntity, sameSrvAddr', ) import qualified Simplex.Messaging.Protocol as SMP @@ -996,7 +998,7 @@ withClient_ c tSess@(_, srv, _) action = do where logServerError :: AgentErrorType -> AM a logServerError e = do - logServer "<--" c srv "" $ bshow e + logServer "<--" c srv NoEntity $ bshow e throwE e withProxySession :: AgentClient -> Maybe SMPServerWithAuth -> SMPTransportSession -> SMP.SenderId -> ByteString -> ((SMPConnectedClient, ProxiedRelay) -> AM a) -> AM a @@ -1013,32 +1015,32 @@ withProxySession c proxySrv_ destSess@(_, destSrv, _) entId cmdStr action = do proxySrv = showServer . protocolClientServer' . protocolClient logServerError :: SMPConnectedClient -> AgentErrorType -> AM a logServerError cl e = do - logServer ("<-- " <> proxySrv cl <> " <") c destSrv "" $ bshow e + logServer ("<-- " <> proxySrv cl <> " <") c destSrv NoEntity $ bshow e throwE e -withLogClient_ :: ProtocolServerClient v err msg => AgentClient -> TransportSession msg -> EntityId -> ByteString -> (Client msg -> AM a) -> AM a +withLogClient_ :: ProtocolServerClient v err msg => AgentClient -> TransportSession msg -> ByteString -> ByteString -> (Client msg -> AM a) -> AM a withLogClient_ c tSess@(_, srv, _) entId cmdStr action = do - logServer "-->" c srv entId cmdStr + logServer' "-->" c srv entId cmdStr res <- withClient_ c tSess action - logServer "<--" c srv entId "OK" + logServer' "<--" c srv entId "OK" return res withClient :: forall v err msg a. ProtocolServerClient v err msg => AgentClient -> TransportSession msg -> (Client msg -> ExceptT (ProtocolClientError err) IO a) -> AM a withClient c tSess action = withClient_ c tSess $ \client -> liftClient (clientProtocolError @v @err @msg) (clientServer $ protocolClient client) $ action client {-# INLINE withClient #-} -withLogClient :: forall v err msg a. ProtocolServerClient v err msg => AgentClient -> TransportSession msg -> EntityId -> ByteString -> (Client msg -> ExceptT (ProtocolClientError err) IO a) -> AM a +withLogClient :: forall v err msg a. ProtocolServerClient v err msg => AgentClient -> TransportSession msg -> ByteString -> ByteString -> (Client msg -> ExceptT (ProtocolClientError err) IO a) -> AM a withLogClient c tSess entId cmdStr action = withLogClient_ c tSess entId cmdStr $ \client -> liftClient (clientProtocolError @v @err @msg) (clientServer $ protocolClient client) $ action client {-# INLINE withLogClient #-} withSMPClient :: SMPQueueRec q => AgentClient -> q -> ByteString -> (SMPClient -> ExceptT SMPClientError IO a) -> AM a withSMPClient c q cmdStr action = do tSess <- mkSMPTransportSession c q - withLogClient c tSess (queueId q) cmdStr $ action . connectedClient + withLogClient c tSess (unEntityId $ queueId q) cmdStr $ action . connectedClient -sendOrProxySMPMessage :: AgentClient -> UserId -> SMPServer -> ByteString -> Maybe SMP.SndPrivateAuthKey -> SMP.SenderId -> MsgFlags -> SMP.MsgBody -> AM (Maybe SMPServer) -sendOrProxySMPMessage c userId destSrv cmdStr spKey_ senderId msgFlags msg = - sendOrProxySMPCommand c userId destSrv cmdStr senderId sendViaProxy sendDirectly +sendOrProxySMPMessage :: AgentClient -> UserId -> SMPServer -> ConnId -> ByteString -> Maybe SMP.SndPrivateAuthKey -> SMP.SenderId -> MsgFlags -> SMP.MsgBody -> AM (Maybe SMPServer) +sendOrProxySMPMessage c userId destSrv connId cmdStr spKey_ senderId msgFlags msg = + sendOrProxySMPCommand c userId destSrv connId cmdStr senderId sendViaProxy sendDirectly where sendViaProxy smp proxySess = do atomically $ incSMPServerStat c userId destSrv sentViaProxyAttempts @@ -1052,14 +1054,15 @@ sendOrProxySMPCommand :: AgentClient -> UserId -> SMPServer -> + ConnId -> ByteString -> SMP.SenderId -> (SMPClient -> ProxiedRelay -> ExceptT SMPClientError IO (Either ProxyClientError ())) -> (SMPClient -> ExceptT SMPClientError IO ()) -> AM (Maybe SMPServer) -sendOrProxySMPCommand c userId destSrv cmdStr senderId sendCmdViaProxy sendCmdDirectly = do - sess <- mkTransportSession c userId destSrv senderId - ifM shouldUseProxy (sendViaProxy Nothing sess) (sendDirectly sess $> Nothing) +sendOrProxySMPCommand c userId destSrv connId cmdStr senderId sendCmdViaProxy sendCmdDirectly = do + tSess <- mkTransportSession c userId destSrv connId + ifM shouldUseProxy (sendViaProxy Nothing tSess) (sendDirectly tSess $> Nothing) where shouldUseProxy = do cfg <- getNetworkConfig c @@ -1078,7 +1081,7 @@ sendOrProxySMPCommand c userId destSrv cmdStr senderId sendCmdViaProxy sendCmdDi SPFProhibit -> False unknownServer = liftIO $ maybe True (notElem destSrv . knownSrvs) <$> TM.lookupIO userId (smpServers c) sendViaProxy :: Maybe SMPServerWithAuth -> SMPTransportSession -> AM (Maybe SMPServer) - sendViaProxy proxySrv_ destSess@(_, _, qId) = do + sendViaProxy proxySrv_ destSess@(_, _, connId_) = do r <- tryAgentError . withProxySession c proxySrv_ destSess senderId ("PFWD " <> cmdStr) $ \(SMPConnectedClient smp _, proxySess@ProxiedRelay {prBasicAuth}) -> do r' <- liftClient SMP (clientServer smp) $ sendCmdViaProxy smp proxySess let proxySrv = protocolClientServer' smp @@ -1105,7 +1108,7 @@ sendOrProxySMPCommand c userId destSrv cmdStr senderId sendCmdViaProxy sendCmdDi -- checks that the current proxied relay session is the same one that was used to send the message and removes it deleteRelaySession = ( TM.lookup destSess (smpProxiedRelays c) - $>>= \(ProtoServerWithAuth srv _) -> tryReadSessVar (userId, srv, qId) (smpClients c) + $>>= \(ProtoServerWithAuth srv _) -> tryReadSessVar (userId, srv, connId_) (smpClients c) ) >>= \case Just (Right (SMPConnectedClient smp' prs)) @@ -1125,7 +1128,7 @@ sendOrProxySMPCommand c userId destSrv cmdStr senderId sendCmdViaProxy sendCmdDi | serverHostError e -> ifM directAllowed (sendDirectly destSess $> Nothing) (throwE e) | otherwise -> throwE e sendDirectly tSess = - withLogClient_ c tSess senderId ("SEND " <> cmdStr) $ \(SMPConnectedClient smp _) -> do + withLogClient_ c tSess (unEntityId senderId) ("SEND " <> cmdStr) $ \(SMPConnectedClient smp _) -> do r <- tryAgentError $ liftClient SMP (clientServer smp) $ sendCmdDirectly smp case r of Right () -> atomically $ incSMPServerStat c userId destSrv sentDirect @@ -1138,18 +1141,18 @@ ipAddressProtected NetworkConfig {socksProxy, hostMode} (ProtocolServer _ hosts isOnionHost = \case THOnionHost _ -> True; _ -> False withNtfClient :: AgentClient -> NtfServer -> EntityId -> ByteString -> (NtfClient -> ExceptT NtfClientError IO a) -> AM a -withNtfClient c srv = withLogClient c (0, srv, Nothing) +withNtfClient c srv (EntityId entId) = withLogClient c (0, srv, Nothing) entId withXFTPClient :: ProtocolServerClient v err msg => AgentClient -> - (UserId, ProtoServer msg, EntityId) -> + (UserId, ProtoServer msg, ByteString) -> ByteString -> (Client msg -> ExceptT (ProtocolClientError err) IO b) -> AM b -withXFTPClient c (userId, srv, entityId) cmdStr action = do - tSess <- mkTransportSession c userId srv entityId - withLogClient c tSess entityId cmdStr action +withXFTPClient c (userId, srv, sessEntId) cmdStr action = do + tSess <- mkTransportSession c userId srv sessEntId + withLogClient c tSess sessEntId cmdStr action liftClient :: (Show err, Encoding err) => (HostName -> err -> AgentErrorType) -> HostName -> ExceptT (ProtocolClientError err) IO a -> AM a liftClient protocolError_ = liftError . protocolClientError protocolError_ @@ -1291,12 +1294,12 @@ getXFTPWorkPath = do workDir <- readTVarIO =<< asks (xftpWorkDir . xftpAgent) maybe getTemporaryDirectory pure workDir -mkTransportSession :: MonadIO m => AgentClient -> UserId -> ProtoServer msg -> EntityId -> m (TransportSession msg) -mkTransportSession c userId srv entityId = mkTSession userId srv entityId <$> getSessionMode c +mkTransportSession :: MonadIO m => AgentClient -> UserId -> ProtoServer msg -> ByteString -> m (TransportSession msg) +mkTransportSession c userId srv sessEntId = mkTSession userId srv sessEntId <$> getSessionMode c {-# INLINE mkTransportSession #-} -mkTSession :: UserId -> ProtoServer msg -> EntityId -> TransportSessionMode -> TransportSession msg -mkTSession userId srv entityId mode = (userId, srv, if mode == TSMEntity then Just entityId else Nothing) +mkTSession :: UserId -> ProtoServer msg -> ByteString -> TransportSessionMode -> TransportSession msg +mkTSession userId srv sessEntId mode = (userId, srv, if mode == TSMEntity then Just sessEntId else Nothing) {-# INLINE mkTSession #-} mkSMPTransportSession :: (SMPQueueRec q, MonadIO m) => AgentClient -> q -> m SMPTransportSession @@ -1318,12 +1321,12 @@ newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange subMode sender rKeys@(_, rcvPrivateKey) <- atomically $ C.generateAuthKeyPair a g (dhKey, privDhKey) <- atomically $ C.generateKeyPair g (e2eDhKey, e2ePrivKey) <- atomically $ C.generateKeyPair g - logServer "-->" c srv "" "NEW" + logServer "-->" c srv NoEntity "NEW" tSess <- mkTransportSession c userId srv connId (sessId, QIK {rcvId, sndId, rcvPublicDhKey, sndSecure}) <- withClient c tSess $ \(SMPConnectedClient smp _) -> (sessionId $ thParams smp,) <$> createSMPQueue smp rKeys dhKey auth subMode senderCanSecure - liftIO . logServer "<--" c srv "" $ B.unwords ["IDS", logSecret rcvId, logSecret sndId] + liftIO . logServer "<--" c srv NoEntity $ B.unwords ["IDS", logSecret rcvId, logSecret sndId] let rq = RcvQueue { userId, @@ -1457,7 +1460,7 @@ sendTSessionBatches statCmd toRQ action c qs = tryAgentError' (getSMPServerClient c tSess) >>= \case Left e -> pure $ L.map ((,Left e) . toRQ) qs' Right (SMPConnectedClient smp _) -> liftIO $ do - logServer "-->" c srv (bshow (length qs') <> " queues") statCmd + logServer' "-->" c srv (bshow (length qs') <> " queues") statCmd L.map agentError <$> action smp qs' where agentError = second . first $ protocolClientError SMP $ clientServer smp @@ -1511,32 +1514,39 @@ getSubscriptions :: AgentClient -> IO (Set ConnId) getSubscriptions = readTVarIO . subscrConns {-# INLINE getSubscriptions #-} -logServer :: MonadIO m => ByteString -> AgentClient -> ProtocolServer s -> QueueId -> ByteString -> m () -logServer dir AgentClient {clientId} srv qId cmdStr = - logInfo . decodeUtf8 $ B.unwords ["A", "(" <> bshow clientId <> ")", dir, showServer srv, ":", logSecret qId, cmdStr] +logServer :: MonadIO m => ByteString -> AgentClient -> ProtocolServer s -> EntityId -> ByteString -> m () +logServer dir c srv = logServer' dir c srv . unEntityId {-# INLINE logServer #-} +logServer' :: MonadIO m => ByteString -> AgentClient -> ProtocolServer s -> ByteString -> ByteString -> m () +logServer' dir AgentClient {clientId} srv qStr cmdStr = + logInfo . decodeUtf8 $ B.unwords ["A", "(" <> bshow clientId <> ")", dir, showServer srv, ":", logSecret' qStr, cmdStr] + showServer :: ProtocolServer s -> ByteString showServer ProtocolServer {host, port} = strEncode host <> B.pack (if null port then "" else ':' : port) {-# INLINE showServer #-} -logSecret :: ByteString -> ByteString -logSecret bs = B64.encode $ B.take 3 bs +logSecret :: EntityId -> ByteString +logSecret = logSecret' . unEntityId {-# INLINE logSecret #-} +logSecret' :: ByteString -> ByteString +logSecret' = B64.encode . B.take 3 +{-# INLINE logSecret' #-} + sendConfirmation :: AgentClient -> SndQueue -> ByteString -> AM (Maybe SMPServer) -sendConfirmation c sq@SndQueue {userId, server, sndId, sndSecure, sndPublicKey, sndPrivateKey, e2ePubKey = e2ePubKey@Just {}} agentConfirmation = do +sendConfirmation c sq@SndQueue {userId, server, connId, sndId, sndSecure, sndPublicKey, sndPrivateKey, e2ePubKey = e2ePubKey@Just {}} agentConfirmation = do let (privHdr, spKey) = if sndSecure then (SMP.PHEmpty, Just sndPrivateKey) else (SMP.PHConfirmation sndPublicKey, Nothing) clientMsg = SMP.ClientMessage privHdr agentConfirmation msg <- agentCbEncrypt sq e2ePubKey $ smpEncode clientMsg - sendOrProxySMPMessage c userId server "" spKey sndId (MsgFlags {notification = True}) msg + sendOrProxySMPMessage c userId server connId "" spKey sndId (MsgFlags {notification = True}) msg sendConfirmation _ _ _ = throwE $ INTERNAL "sendConfirmation called without snd_queue public key(s) in the database" -sendInvitation :: AgentClient -> UserId -> Compatible SMPQueueInfo -> Compatible VersionSMPA -> ConnectionRequestUri 'CMInvitation -> ConnInfo -> AM (Maybe SMPServer) -sendInvitation c userId (Compatible (SMPQueueInfo v SMPQueueAddress {smpServer, senderId, dhPublicKey})) (Compatible agentVersion) connReq connInfo = do +sendInvitation :: AgentClient -> UserId -> ConnId -> Compatible SMPQueueInfo -> Compatible VersionSMPA -> ConnectionRequestUri 'CMInvitation -> ConnInfo -> AM (Maybe SMPServer) +sendInvitation c userId connId (Compatible (SMPQueueInfo v SMPQueueAddress {smpServer, senderId, dhPublicKey})) (Compatible agentVersion) connReq connInfo = do msg <- mkInvitation - sendOrProxySMPMessage c userId smpServer "" Nothing senderId (MsgFlags {notification = True}) msg + sendOrProxySMPMessage c userId smpServer connId "" Nothing senderId (MsgFlags {notification = True}) msg where mkInvitation :: AM ByteString -- this is only encrypted with per-queue E2E, not with double ratchet @@ -1572,8 +1582,8 @@ secureQueue c rq@RcvQueue {rcvId, rcvPrivateKey} senderKey = secureSMPQueue smp rcvPrivateKey rcvId senderKey secureSndQueue :: AgentClient -> SndQueue -> AM () -secureSndQueue c SndQueue {userId, server, sndId, sndPrivateKey, sndPublicKey} = - void $ sendOrProxySMPCommand c userId server "SKEY " sndId secureViaProxy secureDirectly +secureSndQueue c SndQueue {userId, connId, server, sndId, sndPrivateKey, sndPublicKey} = + void $ sendOrProxySMPCommand c userId server connId "SKEY " sndId secureViaProxy secureDirectly where -- TODO track statistics secureViaProxy smp proxySess = proxySecureSndSMPQueue smp proxySess sndPrivateKey sndId sndPublicKey @@ -1603,7 +1613,7 @@ disableQueuesNtfs = sendTSessionBatches "NDEL" id $ sendBatch disableSMPQueuesNt sendAck :: AgentClient -> RcvQueue -> MsgId -> AM () sendAck c rq@RcvQueue {rcvId, rcvPrivateKey} msgId = do - withSMPClient c rq ("ACK:" <> logSecret msgId) $ \smp -> + withSMPClient c rq ("ACK:" <> logSecret' msgId) $ \smp -> ackSMPMessage smp rcvPrivateKey rcvId msgId atomically $ releaseGetLock c rq @@ -1637,10 +1647,10 @@ deleteQueues c = sendTSessionBatches "DEL" id deleteQueues_ c pure rs sendAgentMessage :: AgentClient -> SndQueue -> MsgFlags -> ByteString -> AM (Maybe SMPServer) -sendAgentMessage c sq@SndQueue {userId, server, sndId, sndPrivateKey} msgFlags agentMsg = do +sendAgentMessage c sq@SndQueue {userId, server, connId, sndId, sndPrivateKey} msgFlags agentMsg = do let clientMsg = SMP.ClientMessage SMP.PHEmpty agentMsg msg <- agentCbEncrypt sq Nothing $ smpEncode clientMsg - sendOrProxySMPMessage c userId server "" (Just sndPrivateKey) sndId msgFlags msg + sendOrProxySMPMessage c userId server connId "" (Just sndPrivateKey) sndId msgFlags msg data ServerQueueInfo = ServerQueueInfo { server :: SMPServer, @@ -1659,7 +1669,7 @@ getQueueInfo c rq@RcvQueue {server, rcvId, rcvPrivateKey, sndId, status, clientN let ntfId = enc . (\ClientNtfCreds {notifierId} -> notifierId) <$> clientNtfCreds pure ServerQueueInfo {server, rcvId = enc rcvId, sndId = enc sndId, ntfId, status = serializeQueueStatus status, info} where - enc = decodeLatin1 . B64.encode + enc = decodeLatin1 . B64.encode . unEntityId agentNtfRegisterToken :: AgentClient -> NtfToken -> NtfPublicAuthKey -> C.PublicKeyX25519 -> AM (NtfTokenId, C.PublicKeyX25519) agentNtfRegisterToken c NtfToken {deviceToken, ntfServer, ntfPrivKey} ntfPubKey pubDhKey = @@ -1707,10 +1717,10 @@ agentXFTPNewChunk c SndFileChunk {userId, chunkSpec = XFTPChunkSpec {chunkSize}, rKeys <- xftpRcvKeys n (sndKey, replicaKey) <- atomically . C.generateAuthKeyPair C.SEd25519 =<< asks random let fileInfo = FileInfo {sndKey, size = chunkSize, digest = chunkDigest} - logServer "-->" c srv "" "FNEW" + logServer "-->" c srv NoEntity "FNEW" tSess <- mkTransportSession c userId srv chunkDigest (sndId, rIds) <- withClient c tSess $ \xftp -> X.createXFTPChunk xftp replicaKey fileInfo (L.map fst rKeys) auth - logServer "<--" c srv "" $ B.unwords ["SIDS", logSecret sndId] + logServer "<--" c srv NoEntity $ B.unwords ["SIDS", logSecret sndId] pure NewSndChunkReplica {server = srv, replicaId = ChunkReplicaId sndId, replicaKey, rcvIdsKeys = L.toList $ xftpRcvIdsKeys rIds rKeys} agentXFTPUploadChunk :: AgentClient -> UserId -> FileDigest -> SndFileChunkReplica -> XFTPChunkSpec -> AM () @@ -1734,7 +1744,7 @@ xftpRcvKeys n = do Just rKeys' -> pure rKeys' _ -> throwE $ INTERNAL "non-positive number of recipients" -xftpRcvIdsKeys :: NonEmpty ByteString -> NonEmpty C.AAuthKeyPair -> NonEmpty (ChunkReplicaId, C.APrivateAuthKey) +xftpRcvIdsKeys :: NonEmpty EntityId -> NonEmpty C.AAuthKeyPair -> NonEmpty (ChunkReplicaId, C.APrivateAuthKey) xftpRcvIdsKeys rIds rKeys = L.map ChunkReplicaId rIds `L.zip` L.map snd rKeys agentCbEncrypt :: SndQueue -> Maybe C.PublicKeyX25519 -> ByteString -> AM ByteString @@ -1920,6 +1930,7 @@ withStoreBatch' c actions = withStoreBatch c (fmap (fmap Right) . actions) storeError :: StoreError -> AgentErrorType storeError = \case SEConnNotFound -> CONN NOT_FOUND + SEUserNotFound -> NO_USER SERatchetNotFound -> CONN NOT_FOUND SEConnDuplicate -> CONN DUPLICATE SEBadConnType CRcv -> CONN SIMPLEX diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index ea1d51a7d..13e5011a2 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -51,6 +51,7 @@ module Simplex.Messaging.Agent.Protocol -- * SMP agent protocol types ConnInfo, SndQueueSecured, + AEntityId, ACommand (..), AEvent (..), AEvt (..), @@ -190,7 +191,6 @@ import Simplex.Messaging.Parsers import Simplex.Messaging.Protocol ( AProtocolType, BrokerErrorType (..), - EntityId, ErrorType, MsgBody, MsgFlags, @@ -287,10 +287,12 @@ e2eEncAgentMsgLength v = \case _ -> 15856 -- | SMP agent event -type ATransmission = (ACorrId, EntityId, AEvt) +type ATransmission = (ACorrId, AEntityId, AEvt) type UserId = Int64 +type AEntityId = ByteString + type ACorrId = ByteString data AEntity = AEConn | AERcvFile | AESndFile | AENone @@ -342,6 +344,7 @@ data AEvent (e :: AEntity) where INFO :: PQSupport -> ConnInfo -> AEvent AEConn CON :: PQEncryption -> AEvent AEConn -- notification that connection is established END :: AEvent AEConn + DELD :: AEvent AEConn CONNECT :: AProtocolType -> TransportHost -> AEvent AENone DISCONNECT :: AProtocolType -> TransportHost -> AEvent AENone DOWN :: SMPServer -> [ConnId] -> AEvent AENone @@ -411,6 +414,7 @@ data AEventTag (e :: AEntity) where INFO_ :: AEventTag AEConn CON_ :: AEventTag AEConn END_ :: AEventTag AEConn + DELD_ :: AEventTag AEConn CONNECT_ :: AEventTag AENone DISCONNECT_ :: AEventTag AENone DOWN_ :: AEventTag AENone @@ -464,6 +468,7 @@ aEventTag = \case INFO {} -> INFO_ CON _ -> CON_ END -> END_ + DELD -> DELD_ CONNECT {} -> CONNECT_ DISCONNECT {} -> DISCONNECT_ DOWN {} -> DOWN_ @@ -1336,6 +1341,8 @@ data AgentErrorType CMD {cmdErr :: CommandErrorType, errContext :: String} | -- | connection errors CONN {connErr :: ConnectionErrorType} + | -- | user not found in database + NO_USER | -- | SMP protocol errors forwarded to agent clients SMP {serverAddress :: String, smpErr :: ErrorType} | -- | NTF protocol errors forwarded to agent clients diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index 97b32eca8..d3eae9354 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -1,10 +1,12 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -15,6 +17,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeOperators #-} @@ -968,12 +971,12 @@ createRcvMsg db connId rq rcvMsgData@RcvMsgData {msgMeta = MsgMeta {sndMsgId}, i insertRcvMsgDetails_ db connId rq rcvMsgData updateRcvMsgHash db connId sndMsgId internalRcvId internalHash -updateSndIds :: DB.Connection -> ConnId -> IO (InternalId, InternalSndId, PrevSndMsgHash) -updateSndIds db connId = do - (lastInternalId, lastInternalSndId, prevSndHash) <- retrieveLastIdsAndHashSnd_ db connId +updateSndIds :: DB.Connection -> ConnId -> IO (Either StoreError (InternalId, InternalSndId, PrevSndMsgHash)) +updateSndIds db connId = runExceptT $ do + (lastInternalId, lastInternalSndId, prevSndHash) <- ExceptT $ retrieveLastIdsAndHashSnd_ db connId let internalId = InternalId $ unId lastInternalId + 1 internalSndId = InternalSndId $ unSndId lastInternalSndId + 1 - updateLastIdsSnd_ db connId internalId internalSndId + liftIO $ updateLastIdsSnd_ db connId internalId internalSndId pure (internalId, internalSndId, prevSndHash) createSndMsg :: DB.Connection -> ConnId -> SndMsgData -> IO () @@ -1814,6 +1817,14 @@ instance ToField (Version v) where toField (Version v) = toField v instance FromField (Version v) where fromField f = Version <$> fromField f +deriving newtype instance ToField EntityId + +deriving newtype instance FromField EntityId + +deriving newtype instance ToField ChunkReplicaId + +deriving newtype instance FromField ChunkReplicaId + listToEither :: e -> [a] -> Either e a listToEither _ (x : _) = Right x listToEither e _ = Left e @@ -2208,9 +2219,9 @@ updateRcvMsgHash db connId sndMsgId internalRcvId internalHash = -- * updateSndIds helpers -retrieveLastIdsAndHashSnd_ :: DB.Connection -> ConnId -> IO (InternalId, InternalSndId, PrevSndMsgHash) +retrieveLastIdsAndHashSnd_ :: DB.Connection -> ConnId -> IO (Either StoreError (InternalId, InternalSndId, PrevSndMsgHash)) retrieveLastIdsAndHashSnd_ dbConn connId = do - [(lastInternalId, lastInternalSndId, lastSndHash)] <- + firstRow id SEConnNotFound $ DB.queryNamed dbConn [sql| @@ -2219,7 +2230,6 @@ retrieveLastIdsAndHashSnd_ dbConn connId = do WHERE conn_id = :conn_id; |] [":conn_id" := connId] - return (lastInternalId, lastInternalSndId, lastSndHash) updateLastIdsSnd_ :: DB.Connection -> ConnId -> InternalId -> InternalSndId -> IO () updateLastIdsSnd_ dbConn connId newInternalId newInternalSndId = @@ -2515,7 +2525,7 @@ deleteRcvFile' :: DB.Connection -> DBRcvFileId -> IO () deleteRcvFile' db rcvFileId = DB.execute db "DELETE FROM rcv_files WHERE rcv_file_id = ?" (Only rcvFileId) -getNextRcvChunkToDownload :: DB.Connection -> XFTPServer -> NominalDiffTime -> IO (Either StoreError (Maybe (RcvFileChunk, Bool))) +getNextRcvChunkToDownload :: DB.Connection -> XFTPServer -> NominalDiffTime -> IO (Either StoreError (Maybe (RcvFileChunk, Bool, Maybe RcvFileId))) getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} ttl = do getWorkItem "rcv_file_download" getReplicaId getChunkData (markRcvFileFailed db . snd) where @@ -2539,7 +2549,7 @@ getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} ttl = d LIMIT 1 |] (host, port, keyHash, RFSReceiving, cutoffTs) - getChunkData :: (Int64, DBRcvFileId) -> IO (Either StoreError (RcvFileChunk, Bool)) + getChunkData :: (Int64, DBRcvFileId) -> IO (Either StoreError (RcvFileChunk, Bool, Maybe RcvFileId)) getChunkData (rcvFileChunkReplicaId, _fileId) = firstRow toChunk SEFileNotFound $ DB.query @@ -2548,7 +2558,7 @@ getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} ttl = d SELECT f.rcv_file_id, f.rcv_file_entity_id, f.user_id, c.rcv_file_chunk_id, c.chunk_no, c.chunk_size, c.digest, f.tmp_path, c.tmp_path, r.rcv_file_chunk_replica_id, r.replica_id, r.replica_key, r.received, r.delay, r.retries, - f.approved_relays + f.approved_relays, f.redirect_entity_id FROM rcv_file_chunk_replicas r JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id JOIN rcv_file_chunks c ON c.rcv_file_chunk_id = r.rcv_file_chunk_id @@ -2557,8 +2567,8 @@ getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} ttl = d |] (Only rcvFileChunkReplicaId) where - toChunk :: ((DBRcvFileId, RcvFileId, UserId, Int64, Int, FileSize Word32, FileDigest, FilePath, Maybe FilePath) :. (Int64, ChunkReplicaId, C.APrivateAuthKey, Bool, Maybe Int64, Int) :. Only Bool) -> (RcvFileChunk, Bool) - toChunk ((rcvFileId, rcvFileEntityId, userId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath, chunkTmpPath) :. (rcvChunkReplicaId, replicaId, replicaKey, received, delay, retries) :. (Only approvedRelays)) = + toChunk :: ((DBRcvFileId, RcvFileId, UserId, Int64, Int, FileSize Word32, FileDigest, FilePath, Maybe FilePath) :. (Int64, ChunkReplicaId, C.APrivateAuthKey, Bool, Maybe Int64, Int) :. (Bool, Maybe RcvFileId)) -> (RcvFileChunk, Bool, Maybe RcvFileId) + toChunk ((rcvFileId, rcvFileEntityId, userId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath, chunkTmpPath) :. (rcvChunkReplicaId, replicaId, replicaKey, received, delay, retries) :. (approvedRelays, redirectEntityId_)) = ( RcvFileChunk { rcvFileId, rcvFileEntityId, @@ -2571,7 +2581,8 @@ getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} ttl = d chunkTmpPath, replicas = [RcvFileChunkReplica {rcvChunkReplicaId, server, replicaId, replicaKey, received, delay, retries}] }, - approvedRelays + approvedRelays, + redirectEntityId_ ) getNextRcvFileToDecrypt :: DB.Connection -> NominalDiffTime -> IO (Either StoreError (Maybe RcvFile)) diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs index 131561f4d..8e17d9af6 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs @@ -29,7 +29,7 @@ import Control.Monad (forM_, when) import qualified Data.Aeson.TH as J import Data.List (intercalate, sortOn) import Data.List.NonEmpty (NonEmpty) -import qualified Data.Map as M +import qualified Data.Map.Strict as M import Data.Maybe (isNothing, mapMaybe) import Data.Text (Text) import Data.Text.Encoding (decodeLatin1) diff --git a/src/Simplex/Messaging/Agent/TRcvQueues.hs b/src/Simplex/Messaging/Agent/TRcvQueues.hs index 3b02f64ae..52d67be70 100644 --- a/src/Simplex/Messaging/Agent/TRcvQueues.hs +++ b/src/Simplex/Messaging/Agent/TRcvQueues.hs @@ -31,7 +31,7 @@ import Simplex.Messaging.Transport class Queue q where connId' :: q -> ConnId - qKey :: q -> (UserId, SMPServer, ConnId) + qKey :: q -> (UserId, SMPServer, RecipientId) -- the fields in this record have the same data with swapped keys for lookup efficiency, -- and all methods must maintain this invariant. @@ -63,7 +63,7 @@ addQueue rq (TRcvQueues qs cs) = do addQ = Just . maybe (k :| []) (k <|) k = qKey rq --- Save time by aggregating modifyTVar +-- Save time by aggregating modifyTVar' batchAddQueues :: (Foldable t, Queue q) => TRcvQueues q -> t q -> STM () batchAddQueues (TRcvQueues qs cs) rqs = do modifyTVar' qs $ \now -> foldl' (\rqs' rq -> M.insert (qKey rq) rq rqs') now rqs @@ -97,7 +97,7 @@ getDelSessQueues tSess sessId' (TRcvQueues qs cs) = do delQ acc@(removed, qs') (sessId, rq) | rq `isSession` tSess && sessId == sessId' = (rq : removed, M.delete (qKey rq) qs') | otherwise = acc - delConn :: ([ConnId], M.Map ConnId (NonEmpty (UserId, SMPServer, ConnId))) -> RcvQueue -> ([ConnId], M.Map ConnId (NonEmpty (UserId, SMPServer, ConnId))) + delConn :: ([ConnId], M.Map ConnId (NonEmpty (UserId, SMPServer, RecipientId))) -> RcvQueue -> ([ConnId], M.Map ConnId (NonEmpty (UserId, SMPServer, RecipientId))) delConn (removed, cs') rq = M.alterF f cId cs' where cId = connId rq @@ -113,7 +113,7 @@ isSession rq (uId, srv, connId_) = instance Queue RcvQueue where connId' = connId - qKey rq = (userId rq, server rq, connId rq) + qKey rq = (userId rq, server rq, rcvId rq) instance Queue (SessionId, RcvQueue) where connId' = connId . snd diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index b4567c62e..c0ce663ec 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -441,7 +441,8 @@ transportSession' = transportSession . client_ type UserId = Int64 -- | Transport session key - includes entity ID if `sessionMode = TSMEntity`. -type TransportSession msg = (UserId, ProtoServer msg, Maybe EntityId) +-- Please note that for SMP connection ID is used as entity ID, not queue ID. +type TransportSession msg = (UserId, ProtoServer msg, Maybe ByteString) -- | Connects to 'ProtocolServer' using passed client configuration -- and queue for messages and notifications. @@ -544,7 +545,7 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize if remaining > 1_000_000 -- delay pings only for significant time then loop remaining else do - whenM (readTVarIO sendPings) $ void . runExceptT $ sendProtocolCommand c Nothing "" (protocolPing @v @err @msg) + whenM (readTVarIO sendPings) $ void . runExceptT $ sendProtocolCommand c Nothing NoEntity (protocolPing @v @err @msg) -- sendProtocolCommand/getResponse updates counter for each command cnt <- readTVarIO timeoutErrorCount -- drop client when maxCnt of commands have timed out in sequence, but only after some time has passed after last received response @@ -670,7 +671,7 @@ createSMPQueue :: Bool -> ExceptT SMPClientError IO QueueIdsKeys createSMPQueue c (rKey, rpKey) dhKey auth subMode sndSecure = - sendSMPCommand c (Just rpKey) "" (NEW rKey dhKey auth subMode sndSecure) >>= \case + sendSMPCommand c (Just rpKey) NoEntity (NEW rKey dhKey auth subMode sndSecure) >>= \case IDS qik -> pure qik r -> throwE $ unexpectedResponse r @@ -829,7 +830,7 @@ deleteSMPQueues = okSMPCommands DEL connectSMPProxiedRelay :: SMPClient -> SMPServer -> Maybe BasicAuth -> ExceptT SMPClientError IO ProxiedRelay connectSMPProxiedRelay c@ProtocolClient {client_ = PClient {tcpConnectTimeout, tcpTimeout}} relayServ@ProtocolServer {keyHash = C.KeyHash kh} proxyAuth | thVersion (thParams c) >= sendingProxySMPVersion = - sendProtocolCommand_ c Nothing tOut Nothing "" (Cmd SProxiedClient (PRXY relayServ proxyAuth)) >>= \case + sendProtocolCommand_ c Nothing tOut Nothing NoEntity (Cmd SProxiedClient (PRXY relayServ proxyAuth)) >>= \case PKEY sId vr (chain, key) -> case supportedClientSMPRelayVRange `compatibleVersion` vr of Nothing -> throwE $ transportErr TEVersion @@ -931,7 +932,7 @@ proxySMPCommand c@ProtocolClient {thParams = proxyThParams, client_ = PClient {c et <- liftEitherWith PCECryptoError $ EncTransmission <$> C.cbEncrypt cmdSecret nonce b paddedProxiedTLength -- proxy interaction errors are wrapped let tOut = Just $ 2 * tcpTimeout - tryE (sendProtocolCommand_ c (Just nonce) tOut Nothing sessionId (Cmd SProxiedClient (PFWD v cmdPubKey et))) >>= \case + tryE (sendProtocolCommand_ c (Just nonce) tOut Nothing (EntityId sessionId) (Cmd SProxiedClient (PFWD v cmdPubKey et))) >>= \case Right r -> case r of PRES (EncResponse er) -> do -- server interaction errors are thrown directly @@ -967,7 +968,7 @@ forwardSMPTransmission c@ProtocolClient {thParams, client_ = PClient {clientCorr let fwdT = FwdTransmission {fwdCorrId, fwdVersion, fwdKey, fwdTransmission} eft = EncFwdTransmission $ C.cbEncryptNoPad sessSecret nonce (smpEncode fwdT) -- send - sendProtocolCommand_ c (Just nonce) Nothing Nothing "" (Cmd SSender (RFWD eft)) >>= \case + sendProtocolCommand_ c (Just nonce) Nothing Nothing NoEntity (Cmd SSender (RFWD eft)) >>= \case RRES (EncFwdResponse efr) -> do -- unwrap r' <- liftEitherWith PCECryptoError $ C.cbDecryptNoPad sessSecret (C.reverseNonce nonce) efr @@ -1015,7 +1016,7 @@ sendProtocolCommands c@ProtocolClient {thParams = THandleParams {batch, blockSiz | diff == 0 = pure $ L.fromList rs | diff > 0 = do putStrLn "send error: fewer responses than expected" - pure $ L.fromList $ rs <> replicate diff (Response "" $ Left $ PCETransportError TEBadBlock) + pure $ L.fromList $ rs <> replicate diff (Response NoEntity $ Left $ PCETransportError TEBadBlock) | otherwise = do putStrLn "send error: more responses than expected" pure $ L.fromList $ take (L.length cs) rs diff --git a/src/Simplex/Messaging/Encoding.hs b/src/Simplex/Messaging/Encoding.hs index 9f4c47583..15718e297 100644 --- a/src/Simplex/Messaging/Encoding.hs +++ b/src/Simplex/Messaging/Encoding.hs @@ -42,10 +42,12 @@ class Encoding a where -- | decoding of type (default implementation uses parser) smpDecode :: ByteString -> Either String a smpDecode = parseAll smpP + {-# INLINE smpDecode #-} -- | protocol parser of type (default implementation parses protocol ByteString encoding) smpP :: Parser a smpP = smpDecode <$?> smpP + {-# INLINE smpP #-} instance Encoding Char where smpEncode = B.singleton diff --git a/src/Simplex/Messaging/Encoding/String.hs b/src/Simplex/Messaging/Encoding/String.hs index 6b9fb5624..97e7d087b 100644 --- a/src/Simplex/Messaging/Encoding/String.hs +++ b/src/Simplex/Messaging/Encoding/String.hs @@ -28,6 +28,8 @@ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Char (isAlphaNum) import Data.Int (Int64) +import Data.IntSet (IntSet) +import qualified Data.IntSet as IS import qualified Data.List.NonEmpty as L import Data.Set (Set) import qualified Data.Set as S @@ -39,7 +41,7 @@ import Data.Time.Format.ISO8601 import Data.Word (Word16, Word32) import Simplex.Messaging.Encoding import Simplex.Messaging.Parsers (parseAll) -import Simplex.Messaging.Util ((<$?>)) +import Simplex.Messaging.Util (bshow, (<$?>)) class TextEncoding a where textEncode :: a -> Text @@ -53,14 +55,20 @@ class StrEncoding a where -- Please note - if you only specify strDecode, it will use base64urlP as default parser before decoding the string strDecode :: ByteString -> Either String a strDecode = parseAll strP + {-# INLINE strDecode #-} + strP :: Parser a strP = strDecode <$?> base64urlP + {-# INLINE strP #-} -- base64url encoding/decoding of ByteStrings - the parser only allows non-empty strings instance StrEncoding ByteString where strEncode = U.encode + {-# INLINE strEncode #-} strDecode = U.decode + {-# INLINE strDecode #-} strP = base64urlP + {-# INLINE strP #-} base64urlP :: Parser ByteString base64urlP = do @@ -119,15 +127,15 @@ instance StrEncoding Bool where {-# INLINE strP #-} instance StrEncoding Int where - strEncode = B.pack . show + strEncode = bshow {-# INLINE strEncode #-} - strP = A.decimal + strP = A.signed A.decimal {-# INLINE strP #-} instance StrEncoding Int64 where - strEncode = B.pack . show + strEncode = bshow {-# INLINE strEncode #-} - strP = A.decimal + strP = A.signed A.decimal {-# INLINE strP #-} instance StrEncoding SystemTime where @@ -154,6 +162,10 @@ instance (StrEncoding a, Ord a) => StrEncoding (Set a) where strEncode = strEncodeList . S.toList strP = S.fromList <$> listItem `A.sepBy'` A.char ',' +instance StrEncoding IntSet where + strEncode = strEncodeList . IS.toList + strP = IS.fromList <$> listItem `A.sepBy'` A.char ',' + listItem :: StrEncoding a => Parser a listItem = parseAll strP <$?> A.takeTill (\c -> c == ',' || c == ' ' || c == '\n') diff --git a/src/Simplex/Messaging/Notifications/Client.hs b/src/Simplex/Messaging/Notifications/Client.hs index 32d92faf3..72f0c15a8 100644 --- a/src/Simplex/Messaging/Notifications/Client.hs +++ b/src/Simplex/Messaging/Notifications/Client.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} module Simplex.Messaging.Notifications.Client where @@ -11,7 +12,7 @@ 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) +import Simplex.Messaging.Protocol (ErrorType, pattern NoEntity) type NtfClient = ProtocolClient NTFVersion ErrorType NtfResponse @@ -22,7 +23,7 @@ defaultNTFClientConfig = defaultClientConfig (Just supportedNTFHandshakes) suppo ntfRegisterToken :: NtfClient -> C.APrivateAuthKey -> NewNtfEntity 'Token -> ExceptT NtfClientError IO (NtfTokenId, C.PublicKeyX25519) ntfRegisterToken c pKey newTkn = - sendNtfCommand c (Just pKey) "" (TNEW newTkn) >>= \case + sendNtfCommand c (Just pKey) NoEntity (TNEW newTkn) >>= \case NRTknId tknId dhKey -> pure (tknId, dhKey) r -> throwE $ unexpectedResponse r @@ -46,7 +47,7 @@ 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) "" (SNEW newSub) >>= \case + sendNtfCommand c (Just pKey) NoEntity (SNEW newSub) >>= \case NRSubId subId -> pure subId r -> throwE $ unexpectedResponse r diff --git a/src/Simplex/Messaging/Notifications/Protocol.hs b/src/Simplex/Messaging/Notifications/Protocol.hs index 58a5e5193..556d4a930 100644 --- a/src/Simplex/Messaging/Notifications/Protocol.hs +++ b/src/Simplex/Messaging/Notifications/Protocol.hs @@ -208,7 +208,7 @@ instance NtfEntityI e => ProtocolEncoding NTFVersion ErrorType (NtfCommand e) wh fromProtocolError = fromProtocolError @NTFVersion @ErrorType @NtfResponse {-# INLINE fromProtocolError #-} - checkCredentials (auth, _, entityId, _) cmd = case cmd of + checkCredentials (auth, _, EntityId entityId, _) cmd = case cmd of -- TNEW and SNEW must have signature but NOT token/subscription IDs TNEW {} -> sigNoEntity SNEW {} -> sigNoEntity @@ -322,7 +322,7 @@ instance ProtocolEncoding NTFVersion ErrorType NtfResponse where PEBlock -> BLOCK {-# INLINE fromProtocolError #-} - checkCredentials (_, _, entId, _) cmd = case cmd of + checkCredentials (_, _, EntityId entId, _) cmd = case cmd of -- IDTKN response must not have queue ID NRTknId {} -> noEntity -- IDSUB response must not have queue ID @@ -426,7 +426,7 @@ instance FromJSON DeviceToken where t <- encodeUtf8 <$> o .: "token" pure $ DeviceToken pp t -type NtfEntityId = ByteString +type NtfEntityId = EntityId type NtfSubscriptionId = NtfEntityId @@ -443,6 +443,8 @@ data NtfSubStatus NSInactive | -- | END received NSEnd + | -- | DELD received (connection was deleted) + NSDeleted | -- | SMP AUTH error NSAuth | -- | SMP error other than AUTH @@ -456,6 +458,7 @@ ntfShouldSubscribe = \case NSActive -> True NSInactive -> True NSEnd -> False + NSDeleted -> False NSAuth -> False NSErr _ -> False @@ -466,6 +469,7 @@ instance Encoding NtfSubStatus where NSActive -> "ACTIVE" NSInactive -> "INACTIVE" NSEnd -> "END" + NSDeleted -> "DELETED" NSAuth -> "AUTH" NSErr err -> "ERR " <> err smpP = @@ -475,6 +479,7 @@ instance Encoding NtfSubStatus where "ACTIVE" -> pure NSActive "INACTIVE" -> pure NSInactive "END" -> pure NSEnd + "DELETED" -> pure NSDeleted "AUTH" -> pure NSAuth "ERR" -> NSErr <$> (A.space *> A.takeByteString) _ -> fail "bad NtfSubStatus" diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs index c75c844bb..2c964f9bf 100644 --- a/src/Simplex/Messaging/Notifications/Server.hs +++ b/src/Simplex/Messaging/Notifications/Server.hs @@ -7,6 +7,7 @@ {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} @@ -19,6 +20,7 @@ import Control.Monad.Reader import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Functor (($>)) +import Data.IORef import Data.Int (Int64) import Data.List (intercalate, sort) import Data.List.NonEmpty (NonEmpty (..)) @@ -30,6 +32,7 @@ import Data.Text.Encoding (decodeLatin1) import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime) import Data.Time.Clock.System (getSystemTime) import Data.Time.Format.ISO8601 (iso8601Show) +import GHC.IORef (atomicSwapIORef) import Network.Socket (ServiceName) import Simplex.Messaging.Client (ProtocolClientError (..), SMPClientError, ServerTransmission (..)) import Simplex.Messaging.Client.Agent @@ -42,7 +45,7 @@ import Simplex.Messaging.Notifications.Server.Stats import Simplex.Messaging.Notifications.Server.Store import Simplex.Messaging.Notifications.Server.StoreLog import Simplex.Messaging.Notifications.Transport -import Simplex.Messaging.Protocol (ErrorType (..), ProtocolServer (host), SMPServer, SignedTransmission, Transmission, encodeTransmission, tGet, tPut) +import Simplex.Messaging.Protocol (EntityId (..), ErrorType (..), ProtocolServer (host), SMPServer, SignedTransmission, Transmission, pattern NoEntity, encodeTransmission, tGet, tPut) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Server import Simplex.Messaging.Server.Stats @@ -118,16 +121,16 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do withFile statsFilePath AppendMode $ \h -> liftIO $ do hSetBuffering h LineBuffering ts <- getCurrentTime - fromTime' <- atomically $ swapTVar fromTime ts - tknCreated' <- atomically $ swapTVar tknCreated 0 - tknVerified' <- atomically $ swapTVar tknVerified 0 - tknDeleted' <- atomically $ swapTVar tknDeleted 0 - subCreated' <- atomically $ swapTVar subCreated 0 - subDeleted' <- atomically $ swapTVar subDeleted 0 - ntfReceived' <- atomically $ swapTVar ntfReceived 0 - ntfDelivered' <- atomically $ swapTVar ntfDelivered 0 - tkn <- atomically $ periodStatCounts activeTokens ts - sub <- atomically $ periodStatCounts activeSubs ts + fromTime' <- atomicSwapIORef fromTime ts + tknCreated' <- atomicSwapIORef tknCreated 0 + tknVerified' <- atomicSwapIORef tknVerified 0 + tknDeleted' <- atomicSwapIORef tknDeleted 0 + subCreated' <- atomicSwapIORef subCreated 0 + subDeleted' <- atomicSwapIORef subDeleted 0 + ntfReceived' <- atomicSwapIORef ntfReceived 0 + ntfDelivered' <- atomicSwapIORef ntfDelivered 0 + tkn <- liftIO $ periodStatCounts activeTokens ts + sub <- liftIO $ periodStatCounts activeSubs ts hPutStrLn h $ intercalate "," @@ -215,14 +218,15 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge st <- asks store NtfPushServer {pushQ} <- asks pushServer stats <- asks serverStats - atomically $ updatePeriodStats (activeSubs stats) ntfId + liftIO $ updatePeriodStats (activeSubs stats) ntfId atomically $ findNtfSubscriptionToken st smpQueue - >>= mapM_ (\tkn -> writeTBQueue pushQ (tkn, PNMessage PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta})) + >>= mapM_ (\tkn -> writeTBQueue pushQ (tkn, PNMessage (PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta} :| []))) incNtfStat ntfReceived Right SMP.END -> whenM (atomically $ activeClientSession' ca sessionId srv) $ updateSubStatus smpQueue NSEnd + Right SMP.DELD -> updateSubStatus smpQueue NSDeleted Right (SMP.ERR e) -> logError $ "SMP server error: " <> tshow e Right _ -> logError "SMP server unexpected response" Left e -> logError $ "SMP client error: " <> tshow e @@ -299,7 +303,7 @@ ntfPush s@NtfPushServer {pushQ} = forever $ do void $ deliverNotification pp tkn ntf PNMessage {} -> checkActiveTkn status $ do stats <- asks serverStats - atomically $ updatePeriodStats (activeTokens stats) ntfTknId + liftIO $ updatePeriodStats (activeTokens stats) ntfTknId void $ deliverNotification pp tkn ntf incNtfStat ntfDelivered where @@ -446,7 +450,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu atomically $ writeTBQueue pushQ (tkn, PNVerification regCode) withNtfLog (`logCreateToken` tkn) incNtfStatT token tknCreated - pure (corrId, "", NRTknId tknId srvDhPubKey) + pure (corrId, NoEntity, NRTknId tknId srvDhPubKey) NtfReqCmd SToken (NtfTkn tkn@NtfTknData {token, ntfTknId, tknStatus, tknRegCode, tknDhSecret, tknDhKeys = (srvDhPubKey, srvDhPrivKey), tknCronInterval}) (corrId, tknId, cmd) -> do status <- readTVarIO tknStatus (corrId,tknId,) <$> case cmd of @@ -537,7 +541,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu _ -> pure $ NRErr AUTH withNtfLog (`logCreateSubscription` sub) incNtfStat subCreated - pure (corrId, "", resp) + pure (corrId, NoEntity, resp) NtfReqCmd SSubscription (NtfSub NtfSubData {smpQueue = SMPQueueNtf {smpServer, notifierId}, notifierKey = registeredNKey, subStatus}) (corrId, subId, cmd) -> do status <- readTVarIO subStatus (corrId,subId,) <$> case cmd of @@ -562,7 +566,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu PING -> pure NRPong NtfReqPing corrId entId -> pure (corrId, entId, NRPong) getId :: M NtfEntityId - getId = randomBytes =<< asks (subIdBytes . config) + getId = fmap EntityId . randomBytes =<< asks (subIdBytes . config) getRegCode :: M NtfRegCode getRegCode = NtfRegCode <$> (randomBytes =<< asks (regCodeBytes . config)) randomBytes :: Int -> M ByteString @@ -575,14 +579,14 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu withNtfLog :: (StoreLog 'WriteMode -> IO a) -> M () withNtfLog action = liftIO . mapM_ action =<< asks storeLog -incNtfStatT :: DeviceToken -> (NtfServerStats -> TVar Int) -> M () +incNtfStatT :: DeviceToken -> (NtfServerStats -> IORef Int) -> M () incNtfStatT (DeviceToken PPApnsNull _) _ = pure () incNtfStatT _ statSel = incNtfStat statSel -incNtfStat :: (NtfServerStats -> TVar Int) -> M () +incNtfStat :: (NtfServerStats -> IORef Int) -> M () incNtfStat statSel = do stats <- asks serverStats - atomically $ modifyTVar' (statSel stats) (+ 1) + liftIO $ atomicModifyIORef'_ (statSel stats) (+ 1) saveServerStats :: M () saveServerStats = @@ -602,7 +606,7 @@ restoreServerStats = asks (serverStatsBackupFile . config) >>= mapM_ restoreStat liftIO (strDecode <$> B.readFile f) >>= \case Right d -> do s <- asks serverStats - atomically $ setNtfServerStats s d + liftIO $ setNtfServerStats s d renameFile f $ f <> ".bak" logInfo "server stats restored" Left e -> do diff --git a/src/Simplex/Messaging/Notifications/Server/Main.hs b/src/Simplex/Messaging/Notifications/Server/Main.hs index cd8561dd3..5002d2d45 100644 --- a/src/Simplex/Messaging/Notifications/Server/Main.hs +++ b/src/Simplex/Messaging/Notifications/Server/Main.hs @@ -16,7 +16,7 @@ import qualified Data.Text as T import qualified Data.Text.IO as T import Network.Socket (HostName) import Options.Applicative -import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientConfig (..), SocksMode (..), defaultNetworkConfig) +import Simplex.Messaging.Client (HostMode (..), NetworkConfig (..), ProtocolClientConfig (..), SocksMode (..), defaultNetworkConfig) import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Notifications.Server (runNtfServer) @@ -26,6 +26,7 @@ import Simplex.Messaging.Notifications.Transport (supportedNTFHandshakes, suppor import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern NtfServer) import Simplex.Messaging.Server.CLI import Simplex.Messaging.Server.Expiration +import Simplex.Messaging.Server.Main (textToHostMode) import Simplex.Messaging.Transport (simplexMQVersion) import Simplex.Messaging.Transport.Client (TransportHost (..)) import Simplex.Messaging.Transport.Server (TransportServerConfig (..), defaultTransportServerConfig) @@ -92,6 +93,10 @@ ntfServerCLI cfgPath logPath = <> "websockets: off\n\n\ \[SUBSCRIBER]\n\ \# Network configuration for notification server client.\n\ + \# `host_mode` can be 'public' (default) or 'onion'.\n\ + \# It defines prefferred hostname for destination servers with multiple hostnames.\n\ + \# host_mode: public\n\ + \# required_host_mode: off\n\n\ \# SOCKS proxy port for subscribing to SMP servers.\n\ \# You may need a separate instance of SOCKS proxy for incoming single-hop requests.\n\ \# socks_proxy: localhost:9050\n\n\ @@ -134,6 +139,8 @@ ntfServerCLI cfgPath logPath = defaultNetworkConfig { socksProxy = either error id <$!> strDecodeIni "SUBSCRIBER" "socks_proxy" ini, socksMode = maybe SMOnion (either error id) $! strDecodeIni "SUBSCRIBER" "socks_mode" ini, + hostMode = either (const HMPublic) textToHostMode $ lookupValue "SUBSCRIBER" "host_mode" ini, + requiredHostMode = fromMaybe False $ iniOnOff "SUBSCRIBER" "required_host_mode" ini, smpPingInterval = 60_000_000 -- 1 minutes } }, diff --git a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs index 2632ff4b4..00d3c6a81 100644 --- a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs +++ b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs @@ -28,12 +28,16 @@ import Data.Aeson (ToJSON, (.=)) import qualified Data.Aeson as J import qualified Data.Aeson.Encoding as JE import qualified Data.Aeson.TH as JQ +import qualified Data.Attoparsec.ByteString.Char8 as A import Data.Bifunctor (first) import qualified Data.ByteString.Base64.URL as U import Data.ByteString.Builder (lazyByteString) import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB import Data.Int (Int64) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) import Data.Maybe (isNothing) import Data.Text (Text) @@ -103,11 +107,20 @@ readECPrivateKey f = do data PushNotification = PNVerification NtfRegCode - | PNMessage PNMessageData + | PNMessage (NonEmpty PNMessageData) | -- | PNAlert Text PNCheckMessages deriving (Show) +-- List of PNMessageData uses semicolon-separated encoding instead of strEncode, +-- because strEncode of NonEmpty list uses comma for separator, +-- and encoding of PNMessageData's smpQueue has comma in list of hosts +encodePNMessages :: NonEmpty PNMessageData -> ByteString +encodePNMessages = B.intercalate ";" . map strEncode . L.toList + +pnMessagesP :: A.Parser (NonEmpty PNMessageData) +pnMessagesP = L.fromList <$> strP `A.sepBy1` A.char ';' + data PNMessageData = PNMessageData { smpQueue :: SMPQueueNtf, ntfTs :: SystemTime, @@ -285,7 +298,7 @@ apnsNotification NtfTknData {tknDhSecret} nonce paddedLen = \case encrypt code $ \code' -> apn APNSBackground {contentAvailable = 1} . Just $ J.object ["nonce" .= nonce, "verification" .= code'] PNMessage pnMessageData -> - encrypt (strEncode pnMessageData) $ \ntfData -> + encrypt (encodePNMessages pnMessageData) $ \ntfData -> apn apnMutableContent . Just $ J.object ["nonce" .= nonce, "message" .= ntfData] -- PNAlert text -> Right $ apn (apnAlert $ APNSAlertText text) Nothing PNCheckMessages -> Right $ apn APNSBackground {contentAvailable = 1} . Just $ J.object ["checkMessages" .= True] diff --git a/src/Simplex/Messaging/Notifications/Server/Stats.hs b/src/Simplex/Messaging/Notifications/Server/Stats.hs index b73e6098f..d05257664 100644 --- a/src/Simplex/Messaging/Notifications/Server/Stats.hs +++ b/src/Simplex/Messaging/Notifications/Server/Stats.hs @@ -7,24 +7,22 @@ module Simplex.Messaging.Notifications.Server.Stats where import Control.Applicative (optional) import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.ByteString.Char8 as B +import Data.IORef import Data.Time.Clock (UTCTime) import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Notifications.Protocol (NtfTokenId) -import Simplex.Messaging.Protocol (NotifierId) import Simplex.Messaging.Server.Stats -import UnliftIO.STM data NtfServerStats = NtfServerStats - { fromTime :: TVar UTCTime, - tknCreated :: TVar Int, - tknVerified :: TVar Int, - tknDeleted :: TVar Int, - subCreated :: TVar Int, - subDeleted :: TVar Int, - ntfReceived :: TVar Int, - ntfDelivered :: TVar Int, - activeTokens :: PeriodStats NtfTokenId, - activeSubs :: PeriodStats NotifierId + { fromTime :: IORef UTCTime, + tknCreated :: IORef Int, + tknVerified :: IORef Int, + tknDeleted :: IORef Int, + subCreated :: IORef Int, + subDeleted :: IORef Int, + ntfReceived :: IORef Int, + ntfDelivered :: IORef Int, + activeTokens :: PeriodStats, + activeSubs :: PeriodStats } data NtfServerStatsData = NtfServerStatsData @@ -36,48 +34,49 @@ data NtfServerStatsData = NtfServerStatsData _subDeleted :: Int, _ntfReceived :: Int, _ntfDelivered :: Int, - _activeTokens :: PeriodStatsData NtfTokenId, - _activeSubs :: PeriodStatsData NotifierId + _activeTokens :: PeriodStatsData, + _activeSubs :: PeriodStatsData } newNtfServerStats :: UTCTime -> IO NtfServerStats newNtfServerStats ts = do - fromTime <- newTVarIO ts - tknCreated <- newTVarIO 0 - tknVerified <- newTVarIO 0 - tknDeleted <- newTVarIO 0 - subCreated <- newTVarIO 0 - subDeleted <- newTVarIO 0 - ntfReceived <- newTVarIO 0 - ntfDelivered <- newTVarIO 0 + fromTime <- newIORef ts + tknCreated <- newIORef 0 + tknVerified <- newIORef 0 + tknDeleted <- newIORef 0 + subCreated <- newIORef 0 + subDeleted <- newIORef 0 + ntfReceived <- newIORef 0 + ntfDelivered <- newIORef 0 activeTokens <- newPeriodStats activeSubs <- newPeriodStats pure NtfServerStats {fromTime, tknCreated, tknVerified, tknDeleted, subCreated, subDeleted, ntfReceived, ntfDelivered, activeTokens, activeSubs} getNtfServerStatsData :: NtfServerStats -> IO NtfServerStatsData getNtfServerStatsData s@NtfServerStats {fromTime} = do - _fromTime <- readTVarIO fromTime - _tknCreated <- readTVarIO $ tknCreated s - _tknVerified <- readTVarIO $ tknVerified s - _tknDeleted <- readTVarIO $ tknDeleted s - _subCreated <- readTVarIO $ subCreated s - _subDeleted <- readTVarIO $ subDeleted s - _ntfReceived <- readTVarIO $ ntfReceived s - _ntfDelivered <- readTVarIO $ ntfDelivered s + _fromTime <- readIORef fromTime + _tknCreated <- readIORef $ tknCreated s + _tknVerified <- readIORef $ tknVerified s + _tknDeleted <- readIORef $ tknDeleted s + _subCreated <- readIORef $ subCreated s + _subDeleted <- readIORef $ subDeleted s + _ntfReceived <- readIORef $ ntfReceived s + _ntfDelivered <- readIORef $ ntfDelivered s _activeTokens <- getPeriodStatsData $ activeTokens s _activeSubs <- getPeriodStatsData $ activeSubs s pure NtfServerStatsData {_fromTime, _tknCreated, _tknVerified, _tknDeleted, _subCreated, _subDeleted, _ntfReceived, _ntfDelivered, _activeTokens, _activeSubs} -setNtfServerStats :: NtfServerStats -> NtfServerStatsData -> STM () +-- this function is not thread safe, it is used on server start only +setNtfServerStats :: NtfServerStats -> NtfServerStatsData -> IO () setNtfServerStats s@NtfServerStats {fromTime} d@NtfServerStatsData {_fromTime} = do - writeTVar fromTime $! _fromTime - writeTVar (tknCreated s) $! _tknCreated d - writeTVar (tknVerified s) $! _tknVerified d - writeTVar (tknDeleted s) $! _tknDeleted d - writeTVar (subCreated s) $! _subCreated d - writeTVar (subDeleted s) $! _subDeleted d - writeTVar (ntfReceived s) $! _ntfReceived d - writeTVar (ntfDelivered s) $! _ntfDelivered d + writeIORef fromTime $! _fromTime + writeIORef (tknCreated s) $! _tknCreated d + writeIORef (tknVerified s) $! _tknVerified d + writeIORef (tknDeleted s) $! _tknDeleted d + writeIORef (subCreated s) $! _subCreated d + writeIORef (subDeleted s) $! _subDeleted d + writeIORef (ntfReceived s) $! _ntfReceived d + writeIORef (ntfDelivered s) $! _ntfDelivered d setPeriodStats (activeTokens s) (_activeTokens d) setPeriodStats (activeSubs s) (_activeSubs d) diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index 63e3e4d98..cad84454f 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -2,11 +2,13 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLists #-} @@ -99,7 +101,8 @@ module Simplex.Messaging.Protocol BasicAuth (..), SrvLoc (..), CorrId (..), - EntityId, + EntityId (..), + pattern NoEntity, QueueId, RecipientId, SenderId, @@ -329,8 +332,8 @@ data RawTransmission = RawTransmission { authenticator :: ByteString, -- signature or encrypted transmission hash authorized :: ByteString, -- authorized transmission sessId :: SessionId, - corrId :: ByteString, - entityId :: ByteString, + corrId :: CorrId, + entityId :: EntityId, command :: ByteString } deriving (Show) @@ -357,7 +360,7 @@ instance IsString (Maybe TransmissionAuth) where fromString = parseString $ B64.decode >=> C.decodeSignature >=> pure . fmap TASignature -- | unparsed sent SMP transmission with signature, without session ID. -type SignedRawTransmission = (Maybe TransmissionAuth, SessionId, ByteString, ByteString) +type SignedRawTransmission = (Maybe TransmissionAuth, CorrId, EntityId, ByteString) -- | unparsed sent SMP transmission with signature. type SentRawTransmission = (Maybe TransmissionAuth, ByteString) @@ -374,7 +377,13 @@ type NotifierId = QueueId -- | SMP queue ID on the server. type QueueId = EntityId -type EntityId = ByteString +-- this type is used for server entities only +newtype EntityId = EntityId {unEntityId :: ByteString} + deriving (Eq, Ord, Show) + deriving newtype (Encoding, StrEncoding) + +pattern NoEntity :: EntityId +pattern NoEntity = EntityId "" -- | Parameterized type for SMP protocol commands from all clients. data Command (p :: Party) where @@ -475,6 +484,7 @@ data BrokerMsg where RRES :: EncFwdResponse -> BrokerMsg -- relay to proxy PRES :: EncResponse -> BrokerMsg -- proxy to client END :: BrokerMsg + DELD :: BrokerMsg INFO :: QueueInfo -> BrokerMsg OK :: BrokerMsg ERR :: ErrorType -> BrokerMsg @@ -696,6 +706,7 @@ data BrokerMsgTag | RRES_ | PRES_ | END_ + | DELD_ | INFO_ | OK_ | ERR_ @@ -769,6 +780,7 @@ instance Encoding BrokerMsgTag where RRES_ -> "RRES" PRES_ -> "PRES" END_ -> "END" + DELD_ -> "DELD" INFO_ -> "INFO" OK_ -> "OK" ERR_ -> "ERR" @@ -785,6 +797,7 @@ instance ProtocolMsgTag BrokerMsgTag where "RRES" -> Just RRES_ "PRES" -> Just PRES_ "END" -> Just END_ + "DELD" -> Just DELD_ "INFO" -> Just INFO_ "OK" -> Just OK_ "ERR" -> Just ERR_ @@ -1097,10 +1110,13 @@ serverStrP = do portP = show <$> (A.char ':' *> (A.decimal :: Parser Int)) -- | Transmission correlation ID. -newtype CorrId = CorrId {bs :: ByteString} deriving (Eq, Ord, Show) +newtype CorrId = CorrId {bs :: ByteString} + deriving (Eq, Ord, Show) + deriving newtype (Encoding) instance IsString CorrId where fromString = CorrId . fromString + {-# INLINE fromString #-} instance StrEncoding CorrId where strEncode (CorrId cId) = strEncode cId @@ -1323,7 +1339,7 @@ instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where fromProtocolError = fromProtocolError @SMPVersion @ErrorType @BrokerMsg {-# INLINE fromProtocolError #-} - checkCredentials (auth, _, entId, _) cmd = case cmd of + checkCredentials (auth, _, EntityId entId, _) cmd = case cmd of -- NEW must have signature but NOT queue ID NEW {} | isNothing auth -> Left $ CMD NO_AUTH @@ -1411,6 +1427,9 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where RRES (EncFwdResponse encBlock) -> e (RRES_, ' ', Tail encBlock) PRES (EncResponse encBlock) -> e (PRES_, ' ', Tail encBlock) END -> e END_ + DELD + | v >= deletedEventSMPVersion -> e DELD_ + | otherwise -> e END_ INFO info -> e (INFO_, ' ', info) OK -> e OK_ ERR err -> e (ERR_, ' ', err) @@ -1436,6 +1455,7 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where RRES_ -> RRES <$> (EncFwdResponse . unTail <$> _smpP) PRES_ -> PRES <$> (EncResponse . unTail <$> _smpP) END_ -> pure END + DELD_ -> pure DELD INFO_ -> INFO <$> _smpP OK_ -> pure OK ERR_ -> ERR <$> _smpP @@ -1448,7 +1468,7 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where PEBlock -> BLOCK {-# INLINE fromProtocolError #-} - checkCredentials (_, _, entId, _) cmd = case cmd of + checkCredentials (_, _, EntityId entId, _) cmd = case cmd of -- IDS response should not have queue ID IDS _ -> Right cmd -- ERR response does not always have queue ID @@ -1721,16 +1741,16 @@ tDecodeParseValidate THandleParams {sessionId, thVersion = v, implySessId} = \ca | implySessId || sessId == sessionId -> let decodedTransmission = (,corrId,entityId,command) <$> decodeTAuthBytes authenticator in either (const $ tError corrId) (tParseValidate authorized) decodedTransmission - | otherwise -> (Nothing, "", (CorrId corrId, "", Left $ fromProtocolError @v @err @cmd PESession)) + | otherwise -> (Nothing, "", (corrId, NoEntity, Left $ fromProtocolError @v @err @cmd PESession)) Left _ -> tError "" where - tError :: ByteString -> SignedTransmission err cmd - tError corrId = (Nothing, "", (CorrId corrId, "", Left $ fromProtocolError @v @err @cmd PEBlock)) + tError :: CorrId -> SignedTransmission err cmd + tError corrId = (Nothing, "", (corrId, NoEntity, Left $ fromProtocolError @v @err @cmd PEBlock)) tParseValidate :: ByteString -> SignedRawTransmission -> SignedTransmission err cmd tParseValidate signed t@(sig, corrId, entityId, command) = let cmd = parseProtocol @v @err @cmd v command >>= checkCredentials t - in (sig, signed, (CorrId corrId, entityId, cmd)) + in (sig, signed, (corrId, entityId, cmd)) $(J.deriveJSON defaultJSON ''MsgFlags) diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index a70995d5e..969c5399b 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -44,7 +44,6 @@ import Control.Monad.Except import Control.Monad.IO.Unlift import Control.Monad.Reader import Control.Monad.Trans.Except -import Crypto.Random import Control.Monad.STM (retry) import Data.Bifunctor (first) import Data.ByteString.Base64 (encode) @@ -54,21 +53,22 @@ import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB import Data.Either (fromRight, partitionEithers) import Data.Functor (($>)) +import Data.IORef import Data.Int (Int64) import qualified Data.IntMap.Strict as IM import qualified Data.IntSet as IS import Data.List (intercalate, mapAccumR) -import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty (NonEmpty (..), (<|)) import qualified Data.List.NonEmpty as L import qualified Data.Map.Strict as M import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing) -import qualified Data.Set as S import qualified Data.Text as T import Data.Text.Encoding (decodeLatin1) import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime) import Data.Time.Clock.System (SystemTime (..), getSystemTime) import Data.Time.Format.ISO8601 (iso8601Show) import Data.Type.Equality +import GHC.IORef (atomicSwapIORef) import GHC.Stats (getRTSStats) import GHC.TypeLits (KnownNat) import Network.Socket (ServiceName, Socket, socketToHandle) @@ -136,8 +136,11 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do expired <- restoreServerMessages restoreServerStats expired raceAny_ - ( serverThread s "server subscribedQ" subscribedQ subscribers subscriptions cancelSub - : serverThread s "server ntfSubscribedQ" ntfSubscribedQ Env.notifiers ntfSubscriptions (\_ -> pure ()) + ( serverThread s "server subscribedQ" True subscribedQ subscribers pendingENDs subscriptions cancelSub + : serverThread s "server deletedQ" False deletedQ subscribers pendingDELDs subscriptions cancelSub + : serverThread s "server ntfSubscribedQ" True ntfSubscribedQ Env.notifiers pendingNtfENDs ntfSubscriptions (\_ -> pure ()) + : serverThread s "server ntfDeletedQ" False ntfDeletedQ Env.notifiers pendingNtfDELDs ntfSubscriptions (\_ -> pure ()) + : sendPendingEvtsThread s : receiveFromProxyAgent pa : map runServer transports <> expireMessagesThread_ cfg <> serverStatsThread_ cfg <> controlPortThread_ cfg ) @@ -162,39 +165,81 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do forall s. Server -> String -> - (Server -> TQueue (QueueId, Client, Subscribed)) -> - (Server -> TMap QueueId Client) -> + Subscribed -> + (Server -> TQueue (QueueId, ClientId)) -> + (Server -> TMap QueueId (TVar Client)) -> + (Server -> TVar (IM.IntMap (NonEmpty RecipientId))) -> (Client -> TMap QueueId s) -> (s -> IO ()) -> M () - serverThread s label subQ subs clientSubs unsub = do + serverThread s label subscribed subQ subs pendingEvts clientSubs unsub = do labelMyThread label cls <- asks clients - forever $ - atomically (updateSubscribers cls) + liftIO . forever $ + (atomically (readTQueue $ subQ s) >>= atomically . updateSubscribers cls) $>>= endPreviousSubscriptions - >>= liftIO . mapM_ unsub + >>= mapM_ unsub where - updateSubscribers :: TVar (IM.IntMap (Maybe Client)) -> STM (Maybe (QueueId, Client)) - updateSubscribers cls = do - (qId, clnt, subscribed) <- readTQueue $ subQ s - current <- IM.member (clientId clnt) <$> readTVar cls - let updateSub - | not subscribed = TM.lookupDelete - | not current = TM.lookup -- do not insert client if it is already disconnected, but send END to any other client - | otherwise = (`TM.lookupInsert` clnt) -- insert subscribed and current client - clientToBeNotified c' - | sameClientId clnt c' = pure Nothing - | otherwise = do - yes <- readTVar $ connected c' - pure $ if yes then Just (qId, c') else Nothing - updateSub qId (subs s) $>>= clientToBeNotified - endPreviousSubscriptions :: (QueueId, Client) -> M (Maybe s) + updateSubscribers :: TVar (IM.IntMap (Maybe Client)) -> (QueueId, ClientId) -> STM (Maybe (QueueId, Client)) + updateSubscribers cls (qId, clntId) = + -- Client lookup by ID is in the same STM transaction. + -- In case client disconnects during the transaction, + -- it will be re-evaluated, and the client won't be stored as subscribed. + (readTVar cls >>= updateSub (subs s) . IM.lookup clntId) + $>>= clientToBeNotified + where + updateSub ss = \case + Just (Just clnt) + | subscribed -> + TM.lookup qId ss >>= -- insert subscribed and current client + maybe + (newTVar clnt >>= \cv -> TM.insert qId cv ss $> Nothing) + (\cv -> Just <$> swapTVar cv clnt) + | otherwise -> TM.lookupDelete qId ss >>= mapM readTVar + -- This case catches Just Nothing - it cannot happen here. + -- Nothing is there only before client thread is started. + _ -> TM.lookup qId ss >>= mapM readTVar -- do not insert client if it is already disconnected, but send END to any other client + clientToBeNotified c' + | clntId == clientId c' = pure Nothing + | otherwise = (\yes -> if yes then Just (qId, c') else Nothing) <$> readTVar (connected c') + endPreviousSubscriptions :: (QueueId, Client) -> IO (Maybe s) endPreviousSubscriptions (qId, c) = do - forkClient c (label <> ".endPreviousSubscriptions") $ - atomically $ writeTBQueue (sndQ c) [(CorrId "", qId, END)] + atomically $ modifyTVar' (pendingEvts s) $ IM.alter (Just . maybe [qId] (qId <|)) (clientId c) atomically $ TM.lookupDelete qId (clientSubs c) + sendPendingEvtsThread :: Server -> M () + sendPendingEvtsThread s = do + endInt <- asks $ pendingENDInterval . config + cls <- asks clients + forever $ do + threadDelay endInt + sendPending cls END $ pendingENDs s + sendPending cls DELD $ pendingDELDs s + sendPending cls END $ pendingNtfENDs s + sendPending cls DELD $ pendingNtfDELDs s + where + sendPending cls evt ref = do + ends <- atomically $ swapTVar ref IM.empty + unless (null ends) $ forM_ (IM.assocs ends) $ \(cId, qIds) -> + mapM_ (queueEvts qIds evt) . join . IM.lookup cId =<< readTVarIO cls + queueEvts qIds evt c@Client {connected, sndQ = q} = + whenM (readTVarIO connected) $ do + sent <- atomically $ ifM (isFullTBQueue q) (pure False) (writeTBQueue q ts $> True) + if sent + then updateEndStats + else -- if queue is full it can block + forkClient c ("sendPendingEvtsThread.queueEvts") $ + atomically (writeTBQueue q ts) >> updateEndStats + where + ts = L.map (CorrId "",,evt) qIds + updateEndStats = case evt of + END -> do + stats <- asks serverStats + let len = L.length qIds + liftIO $ atomicModifyIORef'_ (qSubEnd stats) (+ len) + liftIO $ atomicModifyIORef'_ (qSubEndB stats) (+ (len `div` 255 + 1)) -- up to 255 ENDs in the batch + _ -> pure () + receiveFromProxyAgent :: ProxyAgent -> M () receiveFromProxyAgent ProxyAgent {smpAgent = SMPClientAgent {agentQ}} = forever $ @@ -223,9 +268,9 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do old <- liftIO $ expireBeforeEpoch expCfg rIds <- M.keysSet <$> readTVarIO ms forM_ rIds $ \rId -> do - q <- atomically (getMsgQueue ms rId quota) - deleted <- atomically $ deleteExpiredMsgs q old - atomically $ modifyTVar' (msgExpired stats) (+ deleted) + q <- liftIO $ getMsgQueue ms rId quota + deleted <- liftIO $ deleteExpiredMsgs q old + liftIO $ atomicModifyIORef'_ (msgExpired stats) (+ deleted) serverStatsThread_ :: ServerConfig -> [M ()] serverStatsThread_ ServerConfig {logStatsInterval = Just interval, logStatsStartTime, serverStatsLogFile} = @@ -238,7 +283,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do initialDelay <- (startAt -) . fromIntegral . (`div` 1000000_000000) . diffTimeToPicoseconds . utctDayTime <$> liftIO getCurrentTime liftIO $ putStrLn $ "server stats log enabled: " <> statsFilePath liftIO $ threadDelay' $ 1000000 * (initialDelay + if initialDelay < 0 then 86400 else 0) - ss@ServerStats {fromTime, qCreated, qSecured, qDeletedAll, qDeletedNew, qDeletedSecured, qSub, qSubNoMsg, qSubAuth, qSubDuplicate, qSubProhibited, ntfCreated, ntfDeleted, ntfSub, ntfSubAuth, ntfSubDuplicate, msgSent, msgSentAuth, msgSentQuota, msgSentLarge, msgRecv, msgRecvGet, msgGet, msgGetNoMsg, msgGetAuth, msgGetDuplicate, msgGetProhibited, msgExpired, activeQueues, subscribedQueues, msgSentNtf, msgRecvNtf, activeQueuesNtf, qCount, msgCount, pRelays, pRelaysOwn, pMsgFwds, pMsgFwdsOwn, pMsgFwdsRecv} + ss@ServerStats {fromTime, qCreated, qSecured, qDeletedAll, qDeletedAllB, qDeletedNew, qDeletedSecured, qSub, qSubAllB, qSubAuth, qSubDuplicate, qSubProhibited, qSubEnd, qSubEndB, ntfCreated, ntfDeleted, ntfDeletedB, ntfSub, ntfSubB, ntfSubAuth, ntfSubDuplicate, msgSent, msgSentAuth, msgSentQuota, msgSentLarge, msgRecv, msgRecvGet, msgGet, msgGetNoMsg, msgGetAuth, msgGetDuplicate, msgGetProhibited, msgExpired, activeQueues, msgSentNtf, msgRecvNtf, activeQueuesNtf, qCount, msgCount, pRelays, pRelaysOwn, pMsgFwds, pMsgFwdsOwn, pMsgFwdsRecv} <- asks serverStats QueueStore {queues, notifiers} <- asks queueStore let interval = 1000000 * logInterval @@ -246,51 +291,55 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do withFile statsFilePath AppendMode $ \h -> liftIO $ do hSetBuffering h LineBuffering ts <- getCurrentTime - fromTime' <- atomically $ swapTVar fromTime ts - qCreated' <- atomically $ swapTVar qCreated 0 - qSecured' <- atomically $ swapTVar qSecured 0 - qDeletedAll' <- atomically $ swapTVar qDeletedAll 0 - qDeletedNew' <- atomically $ swapTVar qDeletedNew 0 - qDeletedSecured' <- atomically $ swapTVar qDeletedSecured 0 - qSub' <- atomically $ swapTVar qSub 0 - qSubNoMsg' <- atomically $ swapTVar qSubNoMsg 0 - qSubAuth' <- atomically $ swapTVar qSubAuth 0 - qSubDuplicate' <- atomically $ swapTVar qSubDuplicate 0 - qSubProhibited' <- atomically $ swapTVar qSubProhibited 0 - ntfCreated' <- atomically $ swapTVar ntfCreated 0 - ntfDeleted' <- atomically $ swapTVar ntfDeleted 0 - ntfSub' <- atomically $ swapTVar ntfSub 0 - ntfSubAuth' <- atomically $ swapTVar ntfSubAuth 0 - ntfSubDuplicate' <- atomically $ swapTVar ntfSubDuplicate 0 - msgSent' <- atomically $ swapTVar msgSent 0 - msgSentAuth' <- atomically $ swapTVar msgSentAuth 0 - msgSentQuota' <- atomically $ swapTVar msgSentQuota 0 - msgSentLarge' <- atomically $ swapTVar msgSentLarge 0 - msgRecv' <- atomically $ swapTVar msgRecv 0 - msgRecvGet' <- atomically $ swapTVar msgRecvGet 0 - msgGet' <- atomically $ swapTVar msgGet 0 - msgGetNoMsg' <- atomically $ swapTVar msgGetNoMsg 0 - msgGetAuth' <- atomically $ swapTVar msgGetAuth 0 - msgGetDuplicate' <- atomically $ swapTVar msgGetDuplicate 0 - msgGetProhibited' <- atomically $ swapTVar msgGetProhibited 0 - msgExpired' <- atomically $ swapTVar msgExpired 0 - ps <- atomically $ periodStatCounts activeQueues ts - psSub <- atomically $ periodStatCounts subscribedQueues ts - msgSentNtf' <- atomically $ swapTVar msgSentNtf 0 - msgRecvNtf' <- atomically $ swapTVar msgRecvNtf 0 - psNtf <- atomically $ periodStatCounts activeQueuesNtf ts - msgNtfs' <- atomically $ swapTVar (msgNtfs ss) 0 - msgNtfNoSub' <- atomically $ swapTVar (msgNtfNoSub ss) 0 - msgNtfLost' <- atomically $ swapTVar (msgNtfLost ss) 0 - pRelays' <- atomically $ getResetProxyStatsData pRelays - pRelaysOwn' <- atomically $ getResetProxyStatsData pRelaysOwn - pMsgFwds' <- atomically $ getResetProxyStatsData pMsgFwds - pMsgFwdsOwn' <- atomically $ getResetProxyStatsData pMsgFwdsOwn - pMsgFwdsRecv' <- atomically $ swapTVar pMsgFwdsRecv 0 - qCount' <- readTVarIO qCount + fromTime' <- atomicSwapIORef fromTime ts + qCreated' <- atomicSwapIORef qCreated 0 + qSecured' <- atomicSwapIORef qSecured 0 + qDeletedAll' <- atomicSwapIORef qDeletedAll 0 + qDeletedAllB' <- atomicSwapIORef qDeletedAllB 0 + qDeletedNew' <- atomicSwapIORef qDeletedNew 0 + qDeletedSecured' <- atomicSwapIORef qDeletedSecured 0 + qSub' <- atomicSwapIORef qSub 0 + qSubAllB' <- atomicSwapIORef qSubAllB 0 + qSubAuth' <- atomicSwapIORef qSubAuth 0 + qSubDuplicate' <- atomicSwapIORef qSubDuplicate 0 + qSubProhibited' <- atomicSwapIORef qSubProhibited 0 + qSubEnd' <- atomicSwapIORef qSubEnd 0 + qSubEndB' <- atomicSwapIORef qSubEndB 0 + ntfCreated' <- atomicSwapIORef ntfCreated 0 + ntfDeleted' <- atomicSwapIORef ntfDeleted 0 + ntfDeletedB' <- atomicSwapIORef ntfDeletedB 0 + ntfSub' <- atomicSwapIORef ntfSub 0 + ntfSubB' <- atomicSwapIORef ntfSubB 0 + ntfSubAuth' <- atomicSwapIORef ntfSubAuth 0 + ntfSubDuplicate' <- atomicSwapIORef ntfSubDuplicate 0 + msgSent' <- atomicSwapIORef msgSent 0 + msgSentAuth' <- atomicSwapIORef msgSentAuth 0 + msgSentQuota' <- atomicSwapIORef msgSentQuota 0 + msgSentLarge' <- atomicSwapIORef msgSentLarge 0 + msgRecv' <- atomicSwapIORef msgRecv 0 + msgRecvGet' <- atomicSwapIORef msgRecvGet 0 + msgGet' <- atomicSwapIORef msgGet 0 + msgGetNoMsg' <- atomicSwapIORef msgGetNoMsg 0 + msgGetAuth' <- atomicSwapIORef msgGetAuth 0 + msgGetDuplicate' <- atomicSwapIORef msgGetDuplicate 0 + msgGetProhibited' <- atomicSwapIORef msgGetProhibited 0 + msgExpired' <- atomicSwapIORef msgExpired 0 + ps <- liftIO $ periodStatCounts activeQueues ts + msgSentNtf' <- atomicSwapIORef msgSentNtf 0 + msgRecvNtf' <- atomicSwapIORef msgRecvNtf 0 + psNtf <- liftIO $ periodStatCounts activeQueuesNtf ts + msgNtfs' <- atomicSwapIORef (msgNtfs ss) 0 + msgNtfNoSub' <- atomicSwapIORef (msgNtfNoSub ss) 0 + msgNtfLost' <- atomicSwapIORef (msgNtfLost ss) 0 + pRelays' <- getResetProxyStatsData pRelays + pRelaysOwn' <- getResetProxyStatsData pRelaysOwn + pMsgFwds' <- getResetProxyStatsData pMsgFwds + pMsgFwdsOwn' <- getResetProxyStatsData pMsgFwdsOwn + pMsgFwdsRecv' <- atomicSwapIORef pMsgFwdsRecv 0 + qCount' <- readIORef qCount qCount'' <- M.size <$> readTVarIO queues ntfCount' <- M.size <$> readTVarIO notifiers - msgCount' <- readTVarIO msgCount + msgCount' <- readIORef msgCount hPutStrLn h $ intercalate "," @@ -329,23 +378,31 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do show msgNtfs', show msgNtfNoSub', show msgNtfLost', - show qSubNoMsg', + "0", -- qSubNoMsg' is removed for performance. + -- Use qSubAllB for the approximate number of all subscriptions. + -- Average observed batch size is 25-30 subscriptions. show msgRecvGet', show msgGet', show msgGetNoMsg', show msgGetAuth', show msgGetDuplicate', show msgGetProhibited', - dayCount psSub, - weekCount psSub, - monthCount psSub, + "0", -- dayCount psSub; psSub is removed to reduce memory usage + "0", -- weekCount psSub + "0", -- monthCount psSub show qCount'', show ntfCreated', show ntfDeleted', show ntfSub', show ntfSubAuth', show ntfSubDuplicate', - show ntfCount' + show ntfCount', + show qDeletedAllB', + show qSubAllB', + show qSubEnd', + show qSubEndB', + show ntfDeletedB', + show ntfSubB' ] ) liftIO $ threadDelay' interval @@ -374,7 +431,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do u <- askUnliftIO liftIO $ do labelMyThread "control port server" - runTCPServer cpStarted port $ runCPClient u srv + runLocalTCPServer cpStarted port $ runCPClient u srv where runCPClient :: UnliftIO (ReaderT Env IO) -> Server -> Socket -> IO () runCPClient u srv sock = do @@ -422,9 +479,9 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do hPutStrLn h . B.unpack $ B.intercalate "," [bshow cid, encode sessionId, connected', strEncode createdAt, rcvActiveAt', sndActiveAt', bshow age, subscriptions'] CPStats -> withUserRole $ do ss <- unliftIO u $ asks serverStats - let getStat :: (ServerStats -> TVar a) -> IO a - getStat var = readTVarIO (var ss) - putStat :: Show a => String -> (ServerStats -> TVar a) -> IO () + let getStat :: (ServerStats -> IORef a) -> IO a + getStat var = readIORef (var ss) + putStat :: Show a => String -> (ServerStats -> IORef a) -> IO () putStat label var = getStat var >>= \v -> hPutStrLn h $ label <> ": " <> show v putProxyStat :: String -> (ServerStats -> ProxyStats) -> IO () putProxyStat label var = do @@ -434,12 +491,16 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do putStat "qCreated" qCreated putStat "qSecured" qSecured putStat "qDeletedAll" qDeletedAll + putStat "qDeletedAllB" qDeletedAllB putStat "qDeletedNew" qDeletedNew putStat "qDeletedSecured" qDeletedSecured - getStat (day . activeQueues) >>= \v -> hPutStrLn h $ "daily active queues: " <> show (S.size v) - getStat (day . subscribedQueues) >>= \v -> hPutStrLn h $ "daily subscribed queues: " <> show (S.size v) + getStat (day . activeQueues) >>= \v -> hPutStrLn h $ "daily active queues: " <> show (IS.size v) + -- removed to reduce memory usage + -- getStat (day . subscribedQueues) >>= \v -> hPutStrLn h $ "daily subscribed queues: " <> show (S.size v) putStat "qSub" qSub - putStat "qSubNoMsg" qSubNoMsg + putStat "qSubAllB" qSubAllB + putStat "qSubEnd" qSubEnd + putStat "qSubEndB" qSubEndB subs <- (,,) <$> getStat qSubAuth <*> getStat qSubDuplicate <*> getStat qSubProhibited hPutStrLn h $ "other SUB events (auth, duplicate, prohibited): " <> show subs putStat "msgSent" msgSent @@ -521,27 +582,15 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do putActiveClientsInfo "SMP" subscribers putActiveClientsInfo "Ntf" notifiers where - putActiveClientsInfo :: String -> TMap QueueId Client -> IO () + putActiveClientsInfo :: String -> TMap QueueId (TVar Client) -> IO () putActiveClientsInfo protoName clients = do activeSubs <- readTVarIO clients hPutStrLn h $ protoName <> " subscriptions: " <> show (M.size activeSubs) - clCnt <- if r == CPRAdmin then putClientQueues activeSubs else pure $ countSubClients activeSubs + clCnt <- IS.size <$> countSubClients activeSubs hPutStrLn h $ protoName <> " subscribed clients: " <> show clCnt where - putClientQueues :: M.Map QueueId Client -> IO Int - putClientQueues subs = do - let cls = differentClients subs - clQs <- clientTBQueueLengths cls - hPutStrLn h $ protoName <> " subscribed clients queues (rcvQ, sndQ, msgQ): " <> show clQs - pure $ length cls - differentClients :: M.Map QueueId Client -> [Client] - differentClients = fst . M.foldl' addClient ([], IS.empty) - where - addClient acc@(cls, clSet) cl@Client {clientId} - | IS.member clientId clSet = acc - | otherwise = (cl : cls, IS.insert clientId clSet) - countSubClients :: M.Map QueueId Client -> Int - countSubClients = IS.size . M.foldr' (IS.insert . clientId) IS.empty + countSubClients :: M.Map QueueId (TVar Client) -> IO IS.IntSet + countSubClients = foldM (\ !s c -> (`IS.insert` s) . clientId <$> readTVarIO c) IS.empty countClientSubs :: (Client -> TMap QueueId a) -> Maybe (M.Map QueueId a -> IO (Int, Int, Int, Int)) -> IM.IntMap (Maybe Client) -> IO (Int, (Int, Int, Int, Int), Int, (Natural, Natural, Natural)) countClientSubs subSel countSubs_ = foldM addSubs (0, (0, 0, 0, 0), 0, (0, 0, 0)) where @@ -558,8 +607,6 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do clCnt' = if cnt == 0 then clCnt else clCnt + 1 qs' <- if cnt == 0 then pure qs else addQueueLengths qs cl pure (subCnt + cnt, cnts', clCnt', qs') - clientTBQueueLengths :: Foldable t => t Client -> IO (Natural, Natural, Natural) - clientTBQueueLengths = foldM addQueueLengths (0, 0, 0) clientTBQueueLengths' :: Foldable t => t (Maybe Client) -> IO (Natural, Natural, Natural) clientTBQueueLengths' = foldM (\acc -> maybe (pure acc) (addQueueLengths acc)) (0, 0, 0) addQueueLengths (!rl, !sl, !ml) cl = do @@ -584,10 +631,10 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do CPDelete queueId' -> withUserRole $ unliftIO u $ do st <- asks queueStore ms <- asks msgStore - queueId <- atomically (getQueue st SSender queueId') >>= \case + queueId <- liftIO (getQueue st SSender queueId') >>= \case Left _ -> pure queueId' -- fallback to using as recipientId directly Right QueueRec {recipientId} -> pure recipientId - r <- atomically $ + r <- liftIO $ deleteQueue st queueId $>>= \q -> Right . (q,) <$> delMsgQueueSize ms queueId case r of @@ -642,24 +689,27 @@ runClientTransport h@THandle {params = thParams@THandleParams {thVersion, sessio clientDisconnected :: Client -> M () clientDisconnected c@Client {clientId, subscriptions, ntfSubscriptions, connected, sessionId, endThreads} = do labelMyThread . B.unpack $ "client $" <> encode sessionId <> " disc" - (subs, ntfSubs) <- atomically $ do - writeTVar connected False - (,) <$> swapTVar subscriptions M.empty <*> swapTVar ntfSubscriptions M.empty + -- these can be in separate transactions, + -- because the client already disconnected and they won't change + atomically $ writeTVar connected False + subs <- atomically $ swapTVar subscriptions M.empty + ntfSubs <- atomically $ swapTVar ntfSubscriptions M.empty liftIO $ mapM_ cancelSub subs Server {subscribers, notifiers} <- asks server - updateSubscribers subs subscribers - updateSubscribers ntfSubs notifiers + liftIO $ updateSubscribers subs subscribers + liftIO $ updateSubscribers ntfSubs notifiers asks clients >>= atomically . (`modifyTVar'` IM.delete clientId) tIds <- atomically $ swapTVar endThreads IM.empty liftIO $ mapM_ (mapM_ killThread <=< deRefWeak) tIds where - updateSubscribers subs srvSubs = do - atomically $ modifyTVar' srvSubs $ \cs -> - M.foldrWithKey (\sub _ -> M.update deleteCurrentClient sub) cs subs - deleteCurrentClient :: Client -> Maybe Client - deleteCurrentClient c' - | sameClientId c c' = Nothing - | otherwise = Just c' + updateSubscribers :: M.Map QueueId a -> TMap QueueId (TVar Client) -> IO () + updateSubscribers subs srvSubs = + forM_ (M.keys subs) $ \qId -> + -- lookup of the subscribed client TVar can be in separate transaction, + -- as long as the client is read in the same transaction - + -- it prevents removing the next subscribed client. + TM.lookupIO qId srvSubs >>= + mapM_ (\c' -> atomically $ whenM (sameClientId c <$> readTVar c') $ TM.delete qId srvSubs) sameClientId :: Client -> Client -> Bool sameClientId Client {clientId} Client {clientId = cId'} = clientId == cId' @@ -680,9 +730,21 @@ receive h@THandle {params = THandleParams {thAuth}} Client {rcvQ, sndQ, rcvActiv atomically . (writeTVar rcvActiveAt $!) =<< liftIO getSystemTime stats <- asks serverStats (errs, cmds) <- partitionEithers <$> mapM (cmdAction stats) ts + updateBatchStats stats cmds write sndQ errs write rcvQ cmds where + updateBatchStats :: ServerStats -> [(Maybe QueueRec, Transmission Cmd)] -> M () + updateBatchStats stats = \case + (_, (_, _, (Cmd _ cmd))) : _ -> do + let sel_ = case cmd of + SUB -> Just qSubAllB + DEL -> Just qDeletedAllB + NSUB -> Just ntfSubB + NDEL -> Just ntfDeletedB + _ -> Nothing + mapM_ (\sel -> incStat $ sel stats) sel_ + [] -> pure () cmdAction :: ServerStats -> SignedTransmission ErrorType Cmd -> M (Either (Transmission BrokerMsg) (Maybe QueueRec, Transmission Cmd)) cmdAction stats (tAuth, authorized, (corrId, entId, cmdOrError)) = case cmdOrError of @@ -711,7 +773,7 @@ send th c@Client {sndQ, msgQ, sessionId} = do | L.length ts <= 2 = tSend th c ts | otherwise = do let (msgs_, ts') = mapAccumR splitMessages [] ts - -- If the request had batched subscriptions (L.length ts > 2) + -- If the request had batched subscriptions and L.length ts > 2 -- this will reply OK to all SUBs in the first batched transmission, -- to reduce client timeouts. tSend th c ts' @@ -725,7 +787,7 @@ send th c@Client {sndQ, msgQ, sessionId} = do -- replace MSG response with OK, accumulating MSG in a separate list. MSG {} -> ((CorrId "", entId, cmd) : msgs, (corrId, entId, OK)) _ -> (msgs, t) - + sendMsg :: Transport c => MVar (THandleSMP c 'TServer) -> Client -> IO () sendMsg th c@Client {msgQ, sessionId} = do labelMyThread . B.unpack $ "client $" <> encode sessionId <> " sendMsg" @@ -781,7 +843,7 @@ verifyTransmission auth_ tAuth authorized queueId cmd = get :: DirectParty p => SParty p -> M (Either ErrorType QueueRec) get party = do st <- asks queueStore - atomically $ getQueue st party queueId + liftIO $ getQueue st party queueId verifyCmdAuthorization :: Maybe (THandleAuth 'TServer, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> C.APublicAuthKey -> Bool verifyCmdAuthorization auth_ tAuth authorized key = maybe False (verify key) tAuth @@ -837,7 +899,7 @@ forkClient Client {endThreads, endThreadSeq} label action = do mkWeakThreadId t >>= atomically . modifyTVar' endThreads . IM.insert tId client :: THandleParams SMPVersion 'TServer -> Client -> Server -> M () -client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessionId, procThreads} Server {subscribedQ, ntfSubscribedQ, subscribers, notifiers} = do +client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, sndQ, sessionId, procThreads} Server {subscribedQ, deletedQ, ntfSubscribedQ, ntfDeletedQ, subscribers, notifiers} = do labelMyThread . B.unpack $ "client $" <> encode sessionId <> " commands" forever $ atomically (readTBQueue rcvQ) @@ -847,7 +909,7 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi reply :: MonadIO m => NonEmpty (Transmission BrokerMsg) -> m () reply = atomically . writeTBQueue sndQ processProxiedCmd :: Transmission (Command 'ProxiedClient) -> M (Maybe (Transmission BrokerMsg)) - processProxiedCmd (corrId, sessId, command) = (corrId,sessId,) <$$> case command of + processProxiedCmd (corrId, EntityId sessId, command) = (corrId,EntityId sessId,) <$$> case command of PRXY srv auth -> ifM allowProxy getRelay (pure $ Just $ ERR $ PROXY BASIC_AUTH) where allowProxy = do @@ -910,7 +972,7 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi forkProxiedCmd cmdAction = do bracket_ wait signal . forkClient clnt (B.unpack $ "client $" <> encode sessionId <> " proxy") $ do -- commands MUST be processed under a reasonable timeout or the client would halt - cmdAction >>= \t -> reply [(corrId, sessId, t)] + cmdAction >>= \t -> reply [(corrId, EntityId sessId, t)] pure Nothing where wait = do @@ -922,7 +984,7 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi signal = atomically $ modifyTVar' procThreads (\t -> t - 1) transportErr :: TransportError -> ErrorType transportErr = PROXY . BROKER . TRANSPORT - mkIncProxyStats :: MonadIO m => ProxyStats -> ProxyStats -> OwnServer -> (ProxyStats -> TVar Int) -> m () + mkIncProxyStats :: MonadIO m => ProxyStats -> ProxyStats -> OwnServer -> (ProxyStats -> IORef Int) -> m () mkIncProxyStats ps psOwn own sel = do incStat $ sel ps when own $ incStat $ sel psOwn @@ -930,14 +992,12 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi processCommand (qr_, (corrId, entId, cmd)) = case cmd of Cmd SProxiedClient command -> processProxiedCmd (corrId, entId, command) Cmd SSender command -> Just <$> case command of - SKEY sKey -> (corrId,entId,) <$> case qr_ of - Just QueueRec {sndSecure, recipientId} - | sndSecure -> secureQueue_ "SKEY" recipientId sKey - | otherwise -> pure $ ERR AUTH - Nothing -> pure $ ERR INTERNAL + SKEY sKey -> + withQueue $ \QueueRec {sndSecure, recipientId} -> + (corrId,entId,) <$> if sndSecure then secureQueue_ "SKEY" recipientId sKey else pure $ ERR AUTH SEND flags msgBody -> withQueue $ \qr -> sendMessage qr flags msgBody - PING -> pure (corrId, "", PONG) - RFWD encBlock -> (corrId, "",) <$> processForwardedCommand encBlock + PING -> pure (corrId, NoEntity, PONG) + RFWD encBlock -> (corrId, NoEntity,) <$> processForwardedCommand encBlock Cmd SNotifier NSUB -> Just <$> subscribeNotifications Cmd SRecipient command -> do st <- asks queueStore @@ -954,9 +1014,9 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi SUB -> withQueue (`subscribeQueue` entId) GET -> withQueue getMessage ACK msgId -> withQueue (`acknowledgeMsg` msgId) - KEY sKey -> (corrId,entId,) <$> case qr_ of - Just QueueRec {recipientId} -> secureQueue_ "KEY" recipientId sKey - Nothing -> pure $ ERR INTERNAL + KEY sKey -> + withQueue $ \QueueRec {recipientId} -> + (corrId,entId,) <$> secureQueue_ "KEY" recipientId sKey NKEY nKey dhKey -> addQueueNotifier_ st nKey dhKey NDEL -> deleteQueueNotifier_ st OFF -> suspendQueue_ st @@ -966,6 +1026,7 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi createQueue :: QueueStore -> RcvPublicAuthKey -> RcvPublicDhKey -> SubscriptionMode -> SenderCanSecure -> M (Transmission BrokerMsg) createQueue st recipientKey dhKey subMode sndSecure = time "NEW" $ do (rcvPublicDhKey, privDhKey) <- atomically . C.generateKeyPair =<< asks random + updatedAt <- Just <$> liftIO getSystemDate let rcvDhSecret = C.dh' dhKey privDhKey qik (rcvId, sndId) = QIK {rcvId, sndId, rcvPublicDhKey, sndSecure} qRec (recipientId, senderId) = @@ -977,7 +1038,8 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi senderKey = Nothing, notifier = Nothing, status = QueueActive, - sndSecure + sndSecure, + updatedAt } (corrId,entId,) <$> addQueueRetry 3 qik qRec where @@ -988,11 +1050,11 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi ids@(rId, _) <- getIds -- create QueueRec record with these ids and keys let qr = qRec ids - atomically (addQueue st qr) >>= \case + liftIO (addQueue st qr) >>= \case Left DUPLICATE_ -> addQueueRetry (n - 1) qik qRec Left e -> pure $ ERR e - Right _ -> do - withLog (`logCreateById` rId) + Right () -> do + withLog (`logCreateQueue` qr) stats <- asks serverStats incStat $ qCreated stats incStat $ qCount stats @@ -1001,12 +1063,6 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi SMSubscribe -> void $ subscribeQueue qr rId pure $ IDS (qik ids) - logCreateById :: StoreLog 'WriteMode -> RecipientId -> IO () - logCreateById s rId = - atomically (getQueue st SRecipient rId) >>= \case - Right q -> logCreateQueue s q - _ -> pure () - getIds :: M (RecipientId, SenderId) getIds = do n <- asks $ queueIdBytes . config @@ -1018,7 +1074,7 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi st <- asks queueStore stats <- asks serverStats incStat $ qSecured stats - atomically $ either ERR (const OK) <$> secureQueue st rId sKey + liftIO $ either ERR (const OK) <$> secureQueue st rId sKey addQueueNotifier_ :: QueueStore -> NtfPublicAuthKey -> RcvNtfPublicDhKey -> M (Transmission BrokerMsg) addQueueNotifier_ st notifierKey dhKey = time "NKEY" $ do @@ -1031,29 +1087,31 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi addNotifierRetry n rcvPublicDhKey rcvNtfDhSecret = do notifierId <- randomId =<< asks (queueIdBytes . config) let ntfCreds = NtfCreds {notifierId, notifierKey, rcvNtfDhSecret} - atomically (addQueueNotifier st entId ntfCreds) >>= \case + liftIO (addQueueNotifier st entId ntfCreds) >>= \case Left DUPLICATE_ -> addNotifierRetry (n - 1) rcvPublicDhKey rcvNtfDhSecret Left e -> pure $ ERR e - Right _ -> do + Right nId_ -> do withLog $ \s -> logAddNotifier s entId ntfCreds incStat . ntfCreated =<< asks serverStats + forM_ nId_ $ \nId -> atomically $ writeTQueue ntfDeletedQ (nId, clientId) pure $ NID notifierId rcvPublicDhKey deleteQueueNotifier_ :: QueueStore -> M (Transmission BrokerMsg) deleteQueueNotifier_ st = do withLog (`logDeleteNotifier` entId) - atomically (deleteQueueNotifier st entId) >>= \case - Right () -> do + liftIO (deleteQueueNotifier st entId) >>= \case + Right (Just nId) -> do -- Possibly, the same should be done if the queue is suspended, but currently we do not use it - atomically $ writeTQueue ntfSubscribedQ (entId, clnt, False) + atomically $ writeTQueue ntfDeletedQ (nId, clientId) incStat . ntfDeleted =<< asks serverStats pure ok + Right Nothing -> pure ok Left e -> pure $ err e suspendQueue_ :: QueueStore -> M (Transmission BrokerMsg) suspendQueue_ st = do withLog (`logSuspendQueue` entId) - okResp <$> atomically (suspendQueue st entId) + okResp <$> liftIO (suspendQueue st entId) subscribeQueue :: QueueRec -> RecipientId -> M (Transmission BrokerMsg) subscribeQueue qr rId = do @@ -1072,20 +1130,19 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi where newSub :: M Sub newSub = time "SUB newSub" . atomically $ do - writeTQueue subscribedQ (rId, clnt, True) + writeTQueue subscribedQ (rId, clientId) sub <- newSubscription NoSub TM.insert rId sub subscriptions pure sub deliver :: Bool -> Sub -> M (Transmission BrokerMsg) deliver inc sub = do q <- getStoreMsgQueue "SUB" rId - msg_ <- atomically $ tryPeekMsg q - when inc $ do - stats <- asks serverStats - incStat $ (if isJust msg_ then qSub else qSubNoMsg) stats - atomically $ updatePeriodStats (subscribedQueues stats) rId + msg_ <- liftIO $ tryPeekMsgIO q + when (inc && isJust msg_) $ + incStat . qSub =<< asks serverStats deliverMessage "SUB" qr rId sub msg_ + -- clients that use GET are not added to server subscribers getMessage :: QueueRec -> M (Transmission BrokerMsg) getMessage qr = time "GET" $ do atomically (TM.lookup entId subscriptions) >>= \case @@ -1112,6 +1169,7 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi q <- getStoreMsgQueue "GET" entId stats <- asks serverStats (statCnt, r) <- + -- TODO split STM, use tryPeekMsgIO atomically $ tryPeekMsg q >>= \case Just msg -> @@ -1123,7 +1181,17 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi pure r withQueue :: (QueueRec -> M (Transmission BrokerMsg)) -> M (Transmission BrokerMsg) - withQueue action = maybe (pure $ err AUTH) action qr_ + withQueue action = case qr_ of + Just qr -> updateQueueDate qr >> action qr + Nothing -> pure $ err INTERNAL + + updateQueueDate :: QueueRec -> M () + updateQueueDate QueueRec {updatedAt, recipientId = rId} = do + t <- liftIO getSystemDate + when (Just t /= updatedAt) $ do + withLog $ \s -> logUpdateQueueTime s rId t + st <- asks queueStore + liftIO $ updateQueueTime st rId t subscribeNotifications :: M (Transmission BrokerMsg) subscribeNotifications = do @@ -1137,7 +1205,7 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi pure ok where newSub = do - writeTQueue ntfSubscribedQ (entId, clnt, True) + writeTQueue ntfSubscribedQ (entId, clientId) TM.insert entId () ntfSubscriptions acknowledgeMsg :: QueueRec -> MsgId -> M (Transmission BrokerMsg) @@ -1150,11 +1218,11 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi q <- getStoreMsgQueue "ACK" entId case st of ProhibitSub -> do - deletedMsg_ <- atomically $ tryDelMsg q msgId + deletedMsg_ <- liftIO $ tryDelMsg q msgId mapM_ (updateStats True) deletedMsg_ pure ok _ -> do - (deletedMsg_, msg_) <- atomically $ tryDelPeekMsg q msgId + (deletedMsg_, msg_) <- liftIO $ tryDelPeekMsg q msgId mapM_ (updateStats False) deletedMsg_ deliverMessage "ACK" qr entId sub msg_ _ -> pure $ err NO_MSG @@ -1172,11 +1240,11 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi stats <- asks serverStats incStat $ msgRecv stats when isGet $ incStat $ msgRecvGet stats - atomically $ modifyTVar' (msgCount stats) (subtract 1) - atomically $ updatePeriodStats (activeQueues stats) entId + liftIO $ atomicModifyIORef'_ (msgCount stats) (subtract 1) + liftIO $ updatePeriodStats (activeQueues stats) entId when (notification msgFlags) $ do incStat $ msgRecvNtf stats - atomically $ updatePeriodStats (activeQueuesNtf stats) entId + liftIO $ updatePeriodStats (activeQueuesNtf stats) entId sendMessage :: QueueRec -> MsgFlags -> MsgBody -> M (Transmission BrokerMsg) sendMessage qr msgFlags msgBody @@ -1197,34 +1265,26 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi msg_ <- time "SEND" $ do q <- getStoreMsgQueue "SEND" $ recipientId qr expireMessages q - atomically . writeMsg q =<< mkMessage body + liftIO . writeMsg q =<< mkMessage body case msg_ of Nothing -> do incStat $ msgSentQuota stats pure $ err QUOTA Just (msg, wasEmpty) -> time "SEND ok" $ do - when wasEmpty $ tryDeliverMessage msg + when wasEmpty $ liftIO $ tryDeliverMessage msg when (notification msgFlags) $ do - forM_ (notifier qr) $ \ntf -> do - asks random >>= atomically . trySendNotification ntf msg >>= \case - Nothing -> do - incStat $ msgNtfNoSub stats - logWarn "No notification subscription" - Just False -> do - incStat $ msgNtfLost stats - logWarn "Dropped message notification" - Just True -> incStat $ msgNtfs stats + mapM_ (`trySendNotification` msg) (notifier qr) incStat $ msgSentNtf stats - atomically $ updatePeriodStats (activeQueuesNtf stats) (recipientId qr) + liftIO $ updatePeriodStats (activeQueuesNtf stats) (recipientId qr) incStat $ msgSent stats incStat $ msgCount stats - atomically $ updatePeriodStats (activeQueues stats) (recipientId qr) + liftIO $ updatePeriodStats (activeQueues stats) (recipientId qr) pure ok where THandleParams {thVersion} = thParams' mkMessage :: C.MaxLenBS MaxMessageLen -> M Message mkMessage body = do - msgId <- randomId =<< asks (msgIdBytes . config) + msgId <- randomId' =<< asks (msgIdBytes . config) msgTs <- liftIO getSystemTime pure $! Message msgId msgTs msgFlags body @@ -1232,10 +1292,10 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi expireMessages q = do msgExp <- asks $ messageExpiration . config old <- liftIO $ mapM expireBeforeEpoch msgExp - deleted <- atomically $ sum <$> mapM (deleteExpiredMsgs q) old + deleted <- liftIO $ sum <$> mapM (deleteExpiredMsgs q) old when (deleted > 0) $ do stats <- asks serverStats - atomically $ modifyTVar' (msgExpired stats) (+ deleted) + liftIO $ atomicModifyIORef'_ (msgExpired stats) (+ deleted) -- The condition for delivery of the message is: -- - the queue was empty when the message was sent, @@ -1245,12 +1305,21 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi -- If the queue is not full, then the thread is created where these checks are made: -- - it is the same subscribed client (in case it was reconnected it would receive message via SUB command) -- - nothing was delivered to this subscription (to avoid race conditions with the recipient). - tryDeliverMessage :: Message -> M () - tryDeliverMessage msg = atomically deliverToSub >>= mapM_ forkDeliver + tryDeliverMessage :: Message -> IO () + tryDeliverMessage msg = + -- the subscription is checked outside of STM to avoid transaction cost + -- in case no client is subscribed. + whenM (TM.memberIO rId subscribers) $ + atomically deliverToSub >>= mapM_ forkDeliver where rId = recipientId qr + -- remove tryPeekMsg deliverToSub = - TM.lookup rId subscribers + -- lookup has ot be in the same transaction, + -- so that if subscription ends, it re-evalutates + -- and delivery is cancelled - + -- the new client will receive message in response to SUB. + (TM.lookup rId subscribers >>= mapM readTVar) $>>= \rc@Client {subscriptions = subs, sndQ = q} -> TM.lookup rId subs $>>= \s@Sub {subThread, delivered} -> case subThread of ProhibitSub -> pure Nothing @@ -1270,38 +1339,55 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi void $ setDelivered s msg forkDeliver (rc@Client {sndQ = q}, s@Sub {delivered}, st) = do t <- mkWeakThreadId =<< forkIO deliverThread - atomically . modifyTVar' st $ \case + atomically $ modifyTVar' st $ \case -- this case is needed because deliverThread can exit before it SubPending -> SubThread t st' -> st' where deliverThread = do labelMyThread $ B.unpack ("client $" <> encode sessionId) <> " deliver/SEND" - time "deliver" . atomically $ - whenM (maybe False (sameClientId rc) <$> TM.lookup rId subscribers) $ do - tryTakeTMVar delivered >>= \case - Just _ -> pure () -- if a message was already delivered, should not deliver more - Nothing -> do - deliver q s - writeTVar st NoSub + -- lookup can be outside of STM transaction, + -- as long as the check that it is the same client is inside. + TM.lookupIO rId subscribers >>= mapM_ deliverIfSame + deliverIfSame rc' = time "deliver" . atomically $ + whenM (sameClientId rc <$> readTVar rc') $ + tryTakeTMVar delivered >>= \case + Just _ -> pure () -- if a message was already delivered, should not deliver more + Nothing -> do + -- a separate thread is needed because it blocks when client sndQ is full. + deliver q s + writeTVar st NoSub - trySendNotification :: NtfCreds -> Message -> TVar ChaChaDRG -> STM (Maybe Bool) - trySendNotification NtfCreds {notifierId, rcvNtfDhSecret} msg ntfNonceDrg = - mapM (writeNtf notifierId msg rcvNtfDhSecret ntfNonceDrg) =<< TM.lookup notifierId notifiers + trySendNotification :: NtfCreds -> Message -> M () + trySendNotification NtfCreds {notifierId, rcvNtfDhSecret} msg = do + stats <- asks serverStats + liftIO (TM.lookupIO notifierId notifiers) >>= \case + Nothing -> do + incStat $ msgNtfNoSub stats + logWarn "No notification subscription" + Just ntfClnt -> do + let updateStats True = incStat $ msgNtfs stats + updateStats _ = do + incStat $ msgNtfLost stats + logWarn "Dropped message notification" + writeNtf notifierId msg rcvNtfDhSecret ntfClnt >>= mapM_ updateStats - writeNtf :: NotifierId -> Message -> RcvNtfDhSecret -> TVar ChaChaDRG -> Client -> STM Bool - writeNtf nId msg rcvNtfDhSecret ntfNonceDrg Client {sndQ = q} = - ifM (isFullTBQueue q) (pure False) (sendNtf $> True) - where - sendNtf = case msg of - Message {msgId, msgTs} -> do - (nmsgNonce, encNMsgMeta) <- mkMessageNotification msgId msgTs rcvNtfDhSecret ntfNonceDrg - writeTBQueue q [(CorrId "", nId, NMSG nmsgNonce encNMsgMeta)] - _ -> pure () + writeNtf :: NotifierId -> Message -> RcvNtfDhSecret -> TVar Client -> M (Maybe Bool) + writeNtf nId msg rcvNtfDhSecret ntfClnt = case msg of + Message {msgId, msgTs} -> Just <$> do + (nmsgNonce, encNMsgMeta) <- mkMessageNotification msgId msgTs rcvNtfDhSecret + -- must be in one STM transaction to avoid the queue becoming full between the check and writing + atomically $ do + Client {sndQ = q} <- readTVar ntfClnt + ifM + (isFullTBQueue q) + (pure $ False) + (True <$ writeTBQueue q [(CorrId "", nId, NMSG nmsgNonce encNMsgMeta)]) + _ -> pure Nothing - mkMessageNotification :: ByteString -> SystemTime -> RcvNtfDhSecret -> TVar ChaChaDRG -> STM (C.CbNonce, EncNMsgMeta) - mkMessageNotification msgId msgTs rcvNtfDhSecret ntfNonceDrg = do - cbNonce <- C.randomCbNonce ntfNonceDrg + mkMessageNotification :: ByteString -> SystemTime -> RcvNtfDhSecret -> M (C.CbNonce, EncNMsgMeta) + mkMessageNotification msgId msgTs rcvNtfDhSecret = do + cbNonce <- atomically . C.randomCbNonce =<< asks random let msgMeta = NMsgMeta {msgId, msgTs} encNMsgMeta = C.cbEncrypt rcvNtfDhSecret cbNonce (smpEncode msgMeta) 128 pure . (cbNonce,) $ fromRight "" encNMsgMeta @@ -1371,7 +1457,7 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi where resp = (corrId, rId, OK) - time :: T.Text -> M a -> M a + time :: MonadIO m => T.Text -> m a -> m a time name = timed name entId encryptMsg :: QueueRec -> Message -> RcvMessage @@ -1391,41 +1477,41 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi getStoreMsgQueue name rId = time (name <> " getMsgQueue") $ do ms <- asks msgStore quota <- asks $ msgQueueQuota . config - atomically $ getMsgQueue ms rId quota + liftIO $ getMsgQueue ms rId quota delQueueAndMsgs :: QueueStore -> M (Transmission BrokerMsg) delQueueAndMsgs st = do withLog (`logDeleteQueue` entId) ms <- asks msgStore - atomically (deleteQueue st entId $>>= \q -> delMsgQueue ms entId $> Right q) >>= \case + liftIO (deleteQueue st entId $>>= \q -> delMsgQueue ms entId $> Right q) >>= \case Right q -> do -- Possibly, the same should be done if the queue is suspended, but currently we do not use it - atomically $ writeTQueue subscribedQ (entId, clnt, False) - atomically $ writeTQueue ntfSubscribedQ (entId, clnt, False) + atomically $ writeTQueue deletedQ (entId, clientId) + forM_ (notifierId <$> notifier q) $ \nId -> + atomically $ writeTQueue ntfDeletedQ (nId, clientId) updateDeletedStats q pure ok Left e -> pure $ err e getQueueInfo :: QueueRec -> M (Transmission BrokerMsg) getQueueInfo QueueRec {senderKey, notifier} = do - q@MsgQueue {size} <- getStoreMsgQueue "getQueueInfo" entId - info <- atomically $ do - qiSub <- TM.lookup entId subscriptions >>= mapM mkQSub - qiSize <- readTVar size - qiMsg <- toMsgInfo <$$> tryPeekMsg q - pure QueueInfo {qiSnd = isJust senderKey, qiNtf = isJust notifier, qiSub, qiSize, qiMsg} + q <- getStoreMsgQueue "getQueueInfo" entId + qiSub <- liftIO $ TM.lookupIO entId subscriptions >>= mapM mkQSub + qiSize <- liftIO $ getQueueSize q + qiMsg <- liftIO $ toMsgInfo <$$> tryPeekMsgIO q + let info = QueueInfo {qiSnd = isJust senderKey, qiNtf = isJust notifier, qiSub, qiSize, qiMsg} pure (corrId, entId, INFO info) where mkQSub Sub {subThread, delivered} = do qSubThread <- case subThread of ServerSub t -> do - st <- readTVar t + st <- readTVarIO t pure $ case st of NoSub -> QNoSub SubPending -> QSubPending SubThread _ -> QSubThread ProhibitSub -> pure QProhibitSub - qDelivered <- decodeLatin1 . encode <$$> tryReadTMVar delivered + qDelivered <- atomically $ decodeLatin1 . encode <$$> tryReadTMVar delivered pure QSub {qSubThread, qDelivered} ok :: Transmission BrokerMsg @@ -1445,8 +1531,8 @@ updateDeletedStats q = do incStat $ qDeletedAll stats incStat $ qCount stats -incStat :: MonadIO m => TVar Int -> m () -incStat v = atomically $ modifyTVar' v (+ 1) +incStat :: MonadIO m => IORef Int -> m () +incStat r = liftIO $ atomicModifyIORef'_ r (+ 1) {-# INLINE incStat #-} withLog :: (StoreLog 'WriteMode -> IO a) -> M () @@ -1454,8 +1540,8 @@ withLog action = do env <- ask liftIO . mapM_ action $ storeLog (env :: Env) -timed :: T.Text -> RecipientId -> M a -> M a -timed name qId a = do +timed :: MonadIO m => T.Text -> RecipientId -> m a -> m a +timed name (EntityId qId) a = do t <- liftIO getSystemTime r <- a t' <- liftIO getSystemTime @@ -1466,8 +1552,12 @@ timed name qId a = do diff t t' = (systemSeconds t' - systemSeconds t) * sec + fromIntegral (systemNanoseconds t' - systemNanoseconds t) sec = 1000_000000 -randomId :: Int -> M ByteString -randomId n = atomically . C.randomBytes n =<< asks random +randomId' :: Int -> M ByteString +randomId' n = atomically . C.randomBytes n =<< asks random + +randomId :: Int -> M EntityId +randomId = fmap EntityId . randomId' +{-# INLINE randomId #-} saveServerMessages :: Bool -> M () saveServerMessages keepMsgs = asks (storeMsgsFile . config) >>= mapM_ saveMessages @@ -1513,13 +1603,12 @@ restoreServerMessages = where s = LB.toStrict s' addToMsgQueue rId msg = do - (isExpired, logFull) <- atomically $ do - q <- getMsgQueue ms rId quota - case msg of - Message {msgTs} - | maybe True (systemSeconds msgTs >=) old_ -> (False,) . isNothing <$> writeMsg q msg - | otherwise -> pure (True, False) - MessageQuota {} -> writeMsg q msg $> (False, False) + q <- liftIO $ getMsgQueue ms rId quota + (isExpired, logFull) <- liftIO $ case msg of + Message {msgTs} + | maybe True (systemSeconds msgTs >=) old_ -> (False,) . isNothing <$> writeMsg q msg + | otherwise -> pure (True, False) + MessageQuota {} -> writeMsg q msg $> (False, False) when logFull . logError . decodeLatin1 $ "message queue " <> strEncode rId <> " is full, message not restored: " <> strEncode (messageId msg) pure $ if isExpired then expired + 1 else expired msgErr :: Show e => String -> e -> String @@ -1544,8 +1633,8 @@ restoreServerStats expiredWhileRestoring = asks (serverStatsBackupFile . config) Right d@ServerStatsData {_qCount = statsQCount} -> do s <- asks serverStats _qCount <- fmap M.size . readTVarIO . queues =<< asks queueStore - _msgCount <- foldM (\(!n) q -> (n +) <$> readTVarIO (size q)) 0 =<< readTVarIO =<< asks msgStore - atomically $ setServerStats s d {_qCount, _msgCount, _msgExpired = _msgExpired d + expiredWhileRestoring} + _msgCount <- liftIO . foldM (\(!n) q -> (n +) <$> getQueueSize q) 0 =<< readTVarIO =<< asks msgStore + liftIO $ setServerStats s d {_qCount, _msgCount, _msgExpired = _msgExpired d + expiredWhileRestoring} renameFile f $ f <> ".bak" logInfo "server stats restored" when (_qCount /= statsQCount) $ logWarn $ "Queue count differs: stats: " <> tshow statsQCount <> ", store: " <> tshow _qCount diff --git a/src/Simplex/Messaging/Server/Control.hs b/src/Simplex/Messaging/Server/Control.hs index b4c74e4ac..e1d1b5d12 100644 --- a/src/Simplex/Messaging/Server/Control.hs +++ b/src/Simplex/Messaging/Server/Control.hs @@ -4,9 +4,8 @@ module Simplex.Messaging.Server.Control where import qualified Data.Attoparsec.ByteString.Char8 as A -import Data.ByteString (ByteString) import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Protocol (BasicAuth) +import Simplex.Messaging.Protocol (BasicAuth, SenderId) data CPClientRole = CPRNone | CPRUser | CPRAdmin deriving (Eq) @@ -22,7 +21,7 @@ data ControlProtocol | CPSockets | CPSocketThreads | CPServerInfo - | CPDelete ByteString + | CPDelete SenderId | CPSave | CPHelp | CPQuit diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs index 9b1dd9405..8012f5154 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -76,6 +76,8 @@ data ServerConfig = ServerConfig serverStatsLogFile :: FilePath, -- | file to save and restore stats serverStatsBackupFile :: Maybe FilePath, + -- | interval between sending pending END events to unsubscribed clients, seconds + pendingENDInterval :: Int, -- | CA certificate private key is not needed for initialization caCertificateFile :: FilePath, privateKeyFile :: FilePath, @@ -134,10 +136,16 @@ data Env = Env type Subscribed = Bool data Server = Server - { subscribedQ :: TQueue (RecipientId, Client, Subscribed), - subscribers :: TMap RecipientId Client, - ntfSubscribedQ :: TQueue (NotifierId, Client, Subscribed), - notifiers :: TMap NotifierId Client, + { subscribedQ :: TQueue (RecipientId, ClientId), + deletedQ :: TQueue (RecipientId, ClientId), + subscribers :: TMap RecipientId (TVar Client), + ntfSubscribedQ :: TQueue (NotifierId, ClientId), + ntfDeletedQ :: TQueue (NotifierId, ClientId), + notifiers :: TMap NotifierId (TVar Client), + pendingENDs :: TVar (IntMap (NonEmpty RecipientId)), + pendingDELDs :: TVar (IntMap (NonEmpty RecipientId)), + pendingNtfENDs :: TVar (IntMap (NonEmpty NotifierId)), + pendingNtfDELDs :: TVar (IntMap (NonEmpty NotifierId)), savingLock :: Lock } @@ -177,11 +185,17 @@ data Sub = Sub newServer :: IO Server newServer = do subscribedQ <- newTQueueIO + deletedQ <- newTQueueIO subscribers <- TM.emptyIO ntfSubscribedQ <- newTQueueIO + ntfDeletedQ <- newTQueueIO notifiers <- TM.emptyIO + pendingENDs <- newTVarIO IM.empty + pendingDELDs <- newTVarIO IM.empty + pendingNtfENDs <- newTVarIO IM.empty + pendingNtfDELDs <- newTVarIO IM.empty savingLock <- atomically createLock - return Server {subscribedQ, subscribers, ntfSubscribedQ, notifiers, savingLock} + return Server {subscribedQ, deletedQ, subscribers, ntfSubscribedQ, ntfDeletedQ, notifiers, pendingENDs, pendingDELDs, pendingNtfENDs, pendingNtfDELDs, savingLock} newClient :: ClientId -> Natural -> VersionSMP -> ByteString -> SystemTime -> IO Client newClient clientId qSize thVersion sessionId createdAt = do diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index 784d0504a..8a1ea0a60 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -289,6 +289,7 @@ smpServerCLI_ generateSite serveStaticFiles cfgPath logPath = logStatsStartTime = 0, -- seconds from 00:00 UTC serverStatsLogFile = combine logPath "smp-server-stats.daily.log", serverStatsBackupFile = logStats $> combine logPath "smp-server-stats.log", + pendingENDInterval = 15000000, -- 15 seconds smpServerVRange = supportedServerSMPRelayVRange, transportConfig = defaultTransportServerConfig @@ -317,11 +318,6 @@ smpServerCLI_ generateSite serveStaticFiles cfgPath logPath = serverClientConcurrency = readIniDefault defaultProxyClientConcurrency "PROXY" "client_concurrency" ini, information = serverPublicInfo ini } - textToHostMode :: Text -> HostMode - textToHostMode = \case - "public" -> HMPublic - "onion" -> HMOnionViaSocks - s -> error . T.unpack $ "Invalid host_mode: " <> s textToOwnServers :: Text -> [ByteString] textToOwnServers = map encodeUtf8 . T.words @@ -345,6 +341,12 @@ smpServerCLI_ generateSite serveStaticFiles cfgPath logPath = where isOnion = \case THOnionHost _ -> True; _ -> False +textToHostMode :: Text -> HostMode +textToHostMode = \case + "public" -> HMPublic + "onion" -> HMOnionViaSocks + s -> error . T.unpack $ "Invalid host_mode: " <> s + data EmbeddedWebParams = EmbeddedWebParams { webStaticPath :: FilePath, webHttpPort :: Maybe Int, diff --git a/src/Simplex/Messaging/Server/MsgStore/STM.hs b/src/Simplex/Messaging/Server/MsgStore/STM.hs index e0a5c8b45..de994c17a 100644 --- a/src/Simplex/Messaging/Server/MsgStore/STM.hs +++ b/src/Simplex/Messaging/Server/MsgStore/STM.hs @@ -9,17 +9,18 @@ module Simplex.Messaging.Server.MsgStore.STM ( STMMsgStore, - MsgQueue (..), + MsgQueue (msgQueue), newMsgStore, getMsgQueue, delMsgQueue, delMsgQueueSize, writeMsg, tryPeekMsg, - peekMsg, + tryPeekMsgIO, tryDelMsg, tryDelPeekMsg, deleteExpiredMsgs, + getQueueSize, ) where @@ -44,9 +45,14 @@ type STMMsgStore = TMap RecipientId MsgQueue newMsgStore :: IO STMMsgStore newMsgStore = TM.emptyIO -getMsgQueue :: STMMsgStore -> RecipientId -> Int -> STM MsgQueue -getMsgQueue st rId quota = maybe newQ pure =<< TM.lookup rId st +-- The reason for double lookup is that majority of messaging queues exist, +-- because multiple messages are sent to the same queue, +-- so the first lookup without STM transaction will return the queue faster. +-- In case the queue does not exist, it needs to be looked-up again inside transaction. +getMsgQueue :: STMMsgStore -> RecipientId -> Int -> IO MsgQueue +getMsgQueue st rId quota = TM.lookupIO rId st >>= maybe (atomically maybeNewQ) pure where + maybeNewQ = TM.lookup rId st >>= maybe newQ pure newQ = do msgQueue <- newTQueue canWrite <- newTVar True @@ -55,14 +61,14 @@ getMsgQueue st rId quota = maybe newQ pure =<< TM.lookup rId st TM.insert rId q st pure q -delMsgQueue :: STMMsgStore -> RecipientId -> STM () -delMsgQueue st rId = TM.delete rId st +delMsgQueue :: STMMsgStore -> RecipientId -> IO () +delMsgQueue st rId = atomically $ TM.delete rId st -delMsgQueueSize :: STMMsgStore -> RecipientId -> STM Int -delMsgQueueSize st rId = TM.lookupDelete rId st >>= maybe (pure 0) (\MsgQueue {size} -> readTVar size) +delMsgQueueSize :: STMMsgStore -> RecipientId -> IO Int +delMsgQueueSize st rId = atomically (TM.lookupDelete rId st) >>= maybe (pure 0) (\MsgQueue {size} -> readTVarIO size) -writeMsg :: MsgQueue -> Message -> STM (Maybe (Message, Bool)) -writeMsg MsgQueue {msgQueue = q, quota, canWrite, size} !msg = do +writeMsg :: MsgQueue -> Message -> IO (Maybe (Message, Bool)) +writeMsg MsgQueue {msgQueue = q, quota, canWrite, size} !msg = atomically $ do canWrt <- readTVar canWrite empty <- isEmptyTQueue q if canWrt || empty @@ -77,43 +83,47 @@ writeMsg MsgQueue {msgQueue = q, quota, canWrite, size} !msg = do where msgQuota = MessageQuota {msgId = msgId msg, msgTs = msgTs msg} +tryPeekMsgIO :: MsgQueue -> IO (Maybe Message) +tryPeekMsgIO = atomically . tryPeekTQueue . msgQueue +{-# INLINE tryPeekMsgIO #-} + +-- TODO remove once deliverToSub is split tryPeekMsg :: MsgQueue -> STM (Maybe Message) tryPeekMsg = tryPeekTQueue . msgQueue {-# INLINE tryPeekMsg #-} -peekMsg :: MsgQueue -> STM Message -peekMsg = peekTQueue . msgQueue -{-# INLINE peekMsg #-} - -tryDelMsg :: MsgQueue -> MsgId -> STM (Maybe Message) -tryDelMsg mq msgId' = +tryDelMsg :: MsgQueue -> MsgId -> IO (Maybe Message) +tryDelMsg mq msgId' = atomically $ tryPeekMsg mq >>= \case msg_@(Just msg) - | msgId msg == msgId' || B.null msgId' -> tryDeleteMsg mq >> pure msg_ + | msgId msg == msgId' || B.null msgId' -> tryDeleteMsg_ mq >> pure msg_ | otherwise -> pure Nothing _ -> pure Nothing -- atomic delete (== read) last and peek next message if available -tryDelPeekMsg :: MsgQueue -> MsgId -> STM (Maybe Message, Maybe Message) -tryDelPeekMsg mq msgId' = +tryDelPeekMsg :: MsgQueue -> MsgId -> IO (Maybe Message, Maybe Message) +tryDelPeekMsg mq msgId' = atomically $ tryPeekMsg mq >>= \case msg_@(Just msg) - | msgId msg == msgId' || B.null msgId' -> (msg_,) <$> (tryDeleteMsg mq >> tryPeekMsg mq) + | msgId msg == msgId' || B.null msgId' -> (msg_,) <$> (tryDeleteMsg_ mq >> tryPeekMsg mq) | otherwise -> pure (Nothing, msg_) _ -> pure (Nothing, Nothing) -deleteExpiredMsgs :: MsgQueue -> Int64 -> STM Int -deleteExpiredMsgs mq old = loop 0 +deleteExpiredMsgs :: MsgQueue -> Int64 -> IO Int +deleteExpiredMsgs mq old = atomically $ loop 0 where loop dc = tryPeekMsg mq >>= \case Just Message {msgTs} | systemSeconds msgTs < old -> - tryDeleteMsg mq >> loop (dc + 1) + tryDeleteMsg_ mq >> loop (dc + 1) _ -> pure dc -tryDeleteMsg :: MsgQueue -> STM () -tryDeleteMsg MsgQueue {msgQueue = q, size} = +tryDeleteMsg_ :: MsgQueue -> STM () +tryDeleteMsg_ MsgQueue {msgQueue = q, size} = tryReadTQueue q >>= \case Just _ -> modifyTVar' size (subtract 1) _ -> pure () + +getQueueSize :: MsgQueue -> IO Int +getQueueSize MsgQueue {size} = readTVarIO size diff --git a/src/Simplex/Messaging/Server/QueueStore.hs b/src/Simplex/Messaging/Server/QueueStore.hs index 8d5bd8fff..3f7da8d29 100644 --- a/src/Simplex/Messaging/Server/QueueStore.hs +++ b/src/Simplex/Messaging/Server/QueueStore.hs @@ -1,10 +1,13 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} module Simplex.Messaging.Server.QueueStore where +import Data.Int (Int64) +import Data.Time.Clock.System (SystemTime (..), getSystemTime) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol @@ -16,7 +19,8 @@ data QueueRec = QueueRec senderKey :: !(Maybe SndPublicAuthKey), sndSecure :: !SenderCanSecure, notifier :: !(Maybe NtfCreds), - status :: !ServerQueueStatus + status :: !ServerQueueStatus, + updatedAt :: !(Maybe RoundedSystemTime) } deriving (Show) @@ -34,3 +38,16 @@ instance StrEncoding NtfCreds where pure NtfCreds {notifierId, notifierKey, rcvNtfDhSecret} data ServerQueueStatus = QueueActive | QueueOff deriving (Eq, Show) + +newtype RoundedSystemTime = RoundedSystemTime Int64 + deriving (Eq, Ord, Show) + +instance StrEncoding RoundedSystemTime where + strEncode (RoundedSystemTime t) = strEncode t + strP = RoundedSystemTime <$> strP + +getRoundedSystemTime :: Int64 -> IO RoundedSystemTime +getRoundedSystemTime prec = (\t -> RoundedSystemTime $ (systemSeconds t `div` prec) * prec) <$> getSystemTime + +getSystemDate :: IO RoundedSystemTime +getSystemDate = getRoundedSystemTime 86400 diff --git a/src/Simplex/Messaging/Server/QueueStore/STM.hs b/src/Simplex/Messaging/Server/QueueStore/STM.hs index 50907cf9a..5efff9cfd 100644 --- a/src/Simplex/Messaging/Server/QueueStore/STM.hs +++ b/src/Simplex/Messaging/Server/QueueStore/STM.hs @@ -19,6 +19,7 @@ module Simplex.Messaging.Server.QueueStore.STM addQueueNotifier, deleteQueueNotifier, suspendQueue, + updateQueueTime, deleteQueue, ) where @@ -45,8 +46,8 @@ newQueueStore = do notifiers <- TM.emptyIO pure QueueStore {queues, senders, notifiers} -addQueue :: QueueStore -> QueueRec -> STM (Either ErrorType ()) -addQueue QueueStore {queues, senders} q@QueueRec {recipientId = rId, senderId = sId} = do +addQueue :: QueueStore -> QueueRec -> IO (Either ErrorType ()) +addQueue QueueStore {queues, senders} q@QueueRec {recipientId = rId, senderId = sId} = atomically $ do ifM hasId (pure $ Left DUPLICATE_) $ do qVar <- newTVar q TM.insert rId qVar queues @@ -55,48 +56,55 @@ addQueue QueueStore {queues, senders} q@QueueRec {recipientId = rId, senderId = where hasId = (||) <$> TM.member rId queues <*> TM.member sId senders -getQueue :: DirectParty p => QueueStore -> SParty p -> QueueId -> STM (Either ErrorType QueueRec) +getQueue :: DirectParty p => QueueStore -> SParty p -> QueueId -> IO (Either ErrorType QueueRec) getQueue QueueStore {queues, senders, notifiers} party qId = - toResult <$> (mapM readTVar =<< getVar) + toResult <$> (mapM readTVarIO =<< getVar) where getVar = case party of - SRecipient -> TM.lookup qId queues - SSender -> TM.lookup qId senders $>>= (`TM.lookup` queues) - SNotifier -> TM.lookup qId notifiers $>>= (`TM.lookup` queues) + SRecipient -> TM.lookupIO qId queues + SSender -> TM.lookupIO qId senders $>>= (`TM.lookupIO` queues) + SNotifier -> TM.lookupIO qId notifiers $>>= (`TM.lookupIO` queues) -secureQueue :: QueueStore -> RecipientId -> SndPublicAuthKey -> STM (Either ErrorType QueueRec) -secureQueue QueueStore {queues} rId sKey = - withQueue rId queues $ \qVar -> +secureQueue :: QueueStore -> RecipientId -> SndPublicAuthKey -> IO (Either ErrorType QueueRec) +secureQueue QueueStore {queues} rId sKey = toResult <$> do + TM.lookupIO rId queues $>>= \qVar -> atomically $ readTVar qVar >>= \q -> case senderKey q of Just k -> pure $ if sKey == k then Just q else Nothing _ -> let !q' = q {senderKey = Just sKey} in writeTVar qVar q' $> Just q' -addQueueNotifier :: QueueStore -> RecipientId -> NtfCreds -> STM (Either ErrorType QueueRec) +addQueueNotifier :: QueueStore -> RecipientId -> NtfCreds -> IO (Either ErrorType (Maybe NotifierId)) addQueueNotifier QueueStore {queues, notifiers} rId ntfCreds@NtfCreds {notifierId = nId} = do - ifM (TM.member nId notifiers) (pure $ Left DUPLICATE_) $ - withQueue rId queues $ \qVar -> do + TM.lookupIO rId queues >>= \case + Just qVar -> atomically $ ifM (TM.member nId notifiers) (pure $ Left DUPLICATE_) $ do q <- readTVar qVar - forM_ (notifier q) $ (`TM.delete` notifiers) . notifierId - writeTVar qVar $! q {notifier = Just ntfCreds} + nId_ <- forM (notifier q) $ \NtfCreds {notifierId} -> TM.delete notifierId notifiers $> notifierId + let !q' = q {notifier = Just ntfCreds} + writeTVar qVar q' TM.insert nId rId notifiers - pure $ Just q + pure $ Right nId_ + Nothing -> pure $ Left AUTH -deleteQueueNotifier :: QueueStore -> RecipientId -> STM (Either ErrorType ()) +deleteQueueNotifier :: QueueStore -> RecipientId -> IO (Either ErrorType (Maybe NotifierId)) deleteQueueNotifier QueueStore {queues, notifiers} rId = withQueue rId queues $ \qVar -> do q <- readTVar qVar - forM_ (notifier q) $ \NtfCreds {notifierId} -> TM.delete notifierId notifiers - writeTVar qVar $! q {notifier = Nothing} - pure $ Just () + forM (notifier q) $ \NtfCreds {notifierId} -> do + TM.delete notifierId notifiers + writeTVar qVar $! q {notifier = Nothing} + pure notifierId -suspendQueue :: QueueStore -> RecipientId -> STM (Either ErrorType ()) +suspendQueue :: QueueStore -> RecipientId -> IO (Either ErrorType ()) suspendQueue QueueStore {queues} rId = - withQueue rId queues $ \qVar -> modifyTVar' qVar (\q -> q {status = QueueOff}) $> Just () + withQueue rId queues (`modifyTVar'` \q -> q {status = QueueOff}) -deleteQueue :: QueueStore -> RecipientId -> STM (Either ErrorType QueueRec) -deleteQueue QueueStore {queues, senders, notifiers} rId = do +updateQueueTime :: QueueStore -> RecipientId -> RoundedSystemTime -> IO () +updateQueueTime QueueStore {queues} rId t = + void $ withQueue rId queues (`modifyTVar'` \q -> q {updatedAt = Just t}) + +deleteQueue :: QueueStore -> RecipientId -> IO (Either ErrorType QueueRec) +deleteQueue QueueStore {queues, senders, notifiers} rId = atomically $ do TM.lookupDelete rId queues >>= \case Just qVar -> readTVar qVar >>= \q -> do @@ -108,5 +116,5 @@ deleteQueue QueueStore {queues, senders, notifiers} rId = do toResult :: Maybe a -> Either ErrorType a toResult = maybe (Left AUTH) Right -withQueue :: RecipientId -> TMap RecipientId (TVar QueueRec) -> (TVar QueueRec -> STM (Maybe a)) -> STM (Either ErrorType a) -withQueue rId queues f = toResult <$> TM.lookup rId queues $>>= f +withQueue :: RecipientId -> TMap RecipientId (TVar QueueRec) -> (TVar QueueRec -> STM a) -> IO (Either ErrorType a) +withQueue rId queues f = toResult <$> TM.lookupIO rId queues >>= atomically . mapM f diff --git a/src/Simplex/Messaging/Server/Stats.hs b/src/Simplex/Messaging/Server/Stats.hs index f5b430bb6..097ddb607 100644 --- a/src/Simplex/Messaging/Server/Stats.hs +++ b/src/Simplex/Messaging/Server/Stats.hs @@ -4,65 +4,78 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} module Simplex.Messaging.Server.Stats where import Control.Applicative (optional, (<|>)) import qualified Data.Attoparsec.ByteString.Char8 as A +import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B +import Data.Hashable (hash) +import Data.IORef +import Data.IntSet (IntSet) +import qualified Data.IntSet as IS import Data.Set (Set) import qualified Data.Set as S import Data.Time.Calendar.Month (pattern MonthDay) import Data.Time.Calendar.OrdinalDate (mondayStartWeek) import Data.Time.Clock (UTCTime (..)) +import GHC.IORef (atomicSwapIORef) import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Protocol (RecipientId) -import UnliftIO.STM +import Simplex.Messaging.Protocol (EntityId (..)) +import Simplex.Messaging.Util (atomicModifyIORef'_, unlessM) data ServerStats = ServerStats - { fromTime :: TVar UTCTime, - qCreated :: TVar Int, - qSecured :: TVar Int, - qDeletedAll :: TVar Int, - qDeletedNew :: TVar Int, - qDeletedSecured :: TVar Int, - qSub :: TVar Int, - qSubNoMsg :: TVar Int, - qSubAuth :: TVar Int, - qSubDuplicate :: TVar Int, - qSubProhibited :: TVar Int, - ntfCreated :: TVar Int, - ntfDeleted :: TVar Int, - ntfSub :: TVar Int, - ntfSubAuth :: TVar Int, - ntfSubDuplicate :: TVar Int, - msgSent :: TVar Int, - msgSentAuth :: TVar Int, - msgSentQuota :: TVar Int, - msgSentLarge :: TVar Int, - msgRecv :: TVar Int, - msgRecvGet :: TVar Int, - msgGet :: TVar Int, - msgGetNoMsg :: TVar Int, - msgGetAuth :: TVar Int, - msgGetDuplicate :: TVar Int, - msgGetProhibited :: TVar Int, - msgExpired :: TVar Int, - activeQueues :: PeriodStats RecipientId, - subscribedQueues :: PeriodStats RecipientId, - msgSentNtf :: TVar Int, -- sent messages with NTF flag - msgRecvNtf :: TVar Int, -- received messages with NTF flag - activeQueuesNtf :: PeriodStats RecipientId, - msgNtfs :: TVar Int, -- messages notications delivered to NTF server (<= msgSentNtf) - msgNtfNoSub :: TVar Int, -- no subscriber to notifications (e.g., NTF server not connected) - msgNtfLost :: TVar Int, -- notification is lost because NTF delivery queue is full + { fromTime :: IORef UTCTime, + qCreated :: IORef Int, + qSecured :: IORef Int, + qDeletedAll :: IORef Int, + qDeletedAllB :: IORef Int, + qDeletedNew :: IORef Int, + qDeletedSecured :: IORef Int, + qSub :: IORef Int, -- only includes subscriptions when there were pending messages + -- qSubNoMsg :: IORef Int, -- this stat creates too many STM transactions + qSubAllB :: IORef Int, -- count of all subscription batches (with and without pending messages) + qSubAuth :: IORef Int, + qSubDuplicate :: IORef Int, + qSubProhibited :: IORef Int, + qSubEnd :: IORef Int, + qSubEndB :: IORef Int, + ntfCreated :: IORef Int, + ntfDeleted :: IORef Int, + ntfDeletedB :: IORef Int, + ntfSub :: IORef Int, + ntfSubB :: IORef Int, + ntfSubAuth :: IORef Int, + ntfSubDuplicate :: IORef Int, + msgSent :: IORef Int, + msgSentAuth :: IORef Int, + msgSentQuota :: IORef Int, + msgSentLarge :: IORef Int, + msgRecv :: IORef Int, + msgRecvGet :: IORef Int, + msgGet :: IORef Int, + msgGetNoMsg :: IORef Int, + msgGetAuth :: IORef Int, + msgGetDuplicate :: IORef Int, + msgGetProhibited :: IORef Int, + msgExpired :: IORef Int, + activeQueues :: PeriodStats, + -- subscribedQueues :: PeriodStats, -- this stat uses too much memory + msgSentNtf :: IORef Int, -- sent messages with NTF flag + msgRecvNtf :: IORef Int, -- received messages with NTF flag + activeQueuesNtf :: PeriodStats, + msgNtfs :: IORef Int, -- messages notications delivered to NTF server (<= msgSentNtf) + msgNtfNoSub :: IORef Int, -- no subscriber to notifications (e.g., NTF server not connected) + msgNtfLost :: IORef Int, -- notification is lost because NTF delivery queue is full pRelays :: ProxyStats, pRelaysOwn :: ProxyStats, pMsgFwds :: ProxyStats, pMsgFwdsOwn :: ProxyStats, - pMsgFwdsRecv :: TVar Int, - qCount :: TVar Int, - msgCount :: TVar Int + pMsgFwdsRecv :: IORef Int, + qCount :: IORef Int, + msgCount :: IORef Int } data ServerStatsData = ServerStatsData @@ -70,16 +83,21 @@ data ServerStatsData = ServerStatsData _qCreated :: Int, _qSecured :: Int, _qDeletedAll :: Int, + _qDeletedAllB :: Int, _qDeletedNew :: Int, _qDeletedSecured :: Int, _qSub :: Int, - _qSubNoMsg :: Int, + _qSubAllB :: Int, _qSubAuth :: Int, _qSubDuplicate :: Int, _qSubProhibited :: Int, + _qSubEnd :: Int, + _qSubEndB :: Int, _ntfCreated :: Int, _ntfDeleted :: Int, + _ntfDeletedB :: Int, _ntfSub :: Int, + _ntfSubB :: Int, _ntfSubAuth :: Int, _ntfSubDuplicate :: Int, _msgSent :: Int, @@ -94,11 +112,10 @@ data ServerStatsData = ServerStatsData _msgGetDuplicate :: Int, _msgGetProhibited :: Int, _msgExpired :: Int, - _activeQueues :: PeriodStatsData RecipientId, - _subscribedQueues :: PeriodStatsData RecipientId, + _activeQueues :: PeriodStatsData, _msgSentNtf :: Int, _msgRecvNtf :: Int, - _activeQueuesNtf :: PeriodStatsData RecipientId, + _activeQueuesNtf :: PeriodStatsData, _msgNtfs :: Int, _msgNtfNoSub :: Int, _msgNtfLost :: Int, @@ -114,65 +131,74 @@ data ServerStatsData = ServerStatsData newServerStats :: UTCTime -> IO ServerStats newServerStats ts = do - fromTime <- newTVarIO ts - qCreated <- newTVarIO 0 - qSecured <- newTVarIO 0 - qDeletedAll <- newTVarIO 0 - qDeletedNew <- newTVarIO 0 - qDeletedSecured <- newTVarIO 0 - qSub <- newTVarIO 0 - qSubNoMsg <- newTVarIO 0 - qSubAuth <- newTVarIO 0 - qSubDuplicate <- newTVarIO 0 - qSubProhibited <- newTVarIO 0 - ntfCreated <- newTVarIO 0 - ntfDeleted <- newTVarIO 0 - ntfSub <- newTVarIO 0 - ntfSubAuth <- newTVarIO 0 - ntfSubDuplicate <- newTVarIO 0 - msgSent <- newTVarIO 0 - msgSentAuth <- newTVarIO 0 - msgSentQuota <- newTVarIO 0 - msgSentLarge <- newTVarIO 0 - msgRecv <- newTVarIO 0 - msgRecvGet <- newTVarIO 0 - msgGet <- newTVarIO 0 - msgGetNoMsg <- newTVarIO 0 - msgGetAuth <- newTVarIO 0 - msgGetDuplicate <- newTVarIO 0 - msgGetProhibited <- newTVarIO 0 - msgExpired <- newTVarIO 0 + fromTime <- newIORef ts + qCreated <- newIORef 0 + qSecured <- newIORef 0 + qDeletedAll <- newIORef 0 + qDeletedAllB <- newIORef 0 + qDeletedNew <- newIORef 0 + qDeletedSecured <- newIORef 0 + qSub <- newIORef 0 + qSubAllB <- newIORef 0 + qSubAuth <- newIORef 0 + qSubDuplicate <- newIORef 0 + qSubProhibited <- newIORef 0 + qSubEnd <- newIORef 0 + qSubEndB <- newIORef 0 + ntfCreated <- newIORef 0 + ntfDeleted <- newIORef 0 + ntfDeletedB <- newIORef 0 + ntfSub <- newIORef 0 + ntfSubB <- newIORef 0 + ntfSubAuth <- newIORef 0 + ntfSubDuplicate <- newIORef 0 + msgSent <- newIORef 0 + msgSentAuth <- newIORef 0 + msgSentQuota <- newIORef 0 + msgSentLarge <- newIORef 0 + msgRecv <- newIORef 0 + msgRecvGet <- newIORef 0 + msgGet <- newIORef 0 + msgGetNoMsg <- newIORef 0 + msgGetAuth <- newIORef 0 + msgGetDuplicate <- newIORef 0 + msgGetProhibited <- newIORef 0 + msgExpired <- newIORef 0 activeQueues <- newPeriodStats - subscribedQueues <- newPeriodStats - msgSentNtf <- newTVarIO 0 - msgRecvNtf <- newTVarIO 0 + msgSentNtf <- newIORef 0 + msgRecvNtf <- newIORef 0 activeQueuesNtf <- newPeriodStats - msgNtfs <- newTVarIO 0 - msgNtfNoSub <- newTVarIO 0 - msgNtfLost <- newTVarIO 0 + msgNtfs <- newIORef 0 + msgNtfNoSub <- newIORef 0 + msgNtfLost <- newIORef 0 pRelays <- newProxyStats pRelaysOwn <- newProxyStats pMsgFwds <- newProxyStats pMsgFwdsOwn <- newProxyStats - pMsgFwdsRecv <- newTVarIO 0 - qCount <- newTVarIO 0 - msgCount <- newTVarIO 0 + pMsgFwdsRecv <- newIORef 0 + qCount <- newIORef 0 + msgCount <- newIORef 0 pure ServerStats { fromTime, qCreated, qSecured, qDeletedAll, + qDeletedAllB, qDeletedNew, qDeletedSecured, qSub, - qSubNoMsg, + qSubAllB, qSubAuth, qSubDuplicate, qSubProhibited, + qSubEnd, + qSubEndB, ntfCreated, ntfDeleted, + ntfDeletedB, ntfSub, + ntfSubB, ntfSubAuth, ntfSubDuplicate, msgSent, @@ -188,7 +214,6 @@ newServerStats ts = do msgGetProhibited, msgExpired, activeQueues, - subscribedQueues, msgSentNtf, msgRecvNtf, activeQueuesNtf, @@ -206,65 +231,74 @@ newServerStats ts = do getServerStatsData :: ServerStats -> IO ServerStatsData getServerStatsData s = do - _fromTime <- readTVarIO $ fromTime s - _qCreated <- readTVarIO $ qCreated s - _qSecured <- readTVarIO $ qSecured s - _qDeletedAll <- readTVarIO $ qDeletedAll s - _qDeletedNew <- readTVarIO $ qDeletedNew s - _qDeletedSecured <- readTVarIO $ qDeletedSecured s - _qSub <- readTVarIO $ qSub s - _qSubNoMsg <- readTVarIO $ qSubNoMsg s - _qSubAuth <- readTVarIO $ qSubAuth s - _qSubDuplicate <- readTVarIO $ qSubDuplicate s - _qSubProhibited <- readTVarIO $ qSubProhibited s - _ntfCreated <- readTVarIO $ ntfCreated s - _ntfDeleted <- readTVarIO $ ntfDeleted s - _ntfSub <- readTVarIO $ ntfSub s - _ntfSubAuth <- readTVarIO $ ntfSubAuth s - _ntfSubDuplicate <- readTVarIO $ ntfSubDuplicate s - _msgSent <- readTVarIO $ msgSent s - _msgSentAuth <- readTVarIO $ msgSentAuth s - _msgSentQuota <- readTVarIO $ msgSentQuota s - _msgSentLarge <- readTVarIO $ msgSentLarge s - _msgRecv <- readTVarIO $ msgRecv s - _msgRecvGet <- readTVarIO $ msgRecvGet s - _msgGet <- readTVarIO $ msgGet s - _msgGetNoMsg <- readTVarIO $ msgGetNoMsg s - _msgGetAuth <- readTVarIO $ msgGetAuth s - _msgGetDuplicate <- readTVarIO $ msgGetDuplicate s - _msgGetProhibited <- readTVarIO $ msgGetProhibited s - _msgExpired <- readTVarIO $ msgExpired s + _fromTime <- readIORef $ fromTime s + _qCreated <- readIORef $ qCreated s + _qSecured <- readIORef $ qSecured s + _qDeletedAll <- readIORef $ qDeletedAll s + _qDeletedAllB <- readIORef $ qDeletedAllB s + _qDeletedNew <- readIORef $ qDeletedNew s + _qDeletedSecured <- readIORef $ qDeletedSecured s + _qSub <- readIORef $ qSub s + _qSubAllB <- readIORef $ qSubAllB s + _qSubAuth <- readIORef $ qSubAuth s + _qSubDuplicate <- readIORef $ qSubDuplicate s + _qSubProhibited <- readIORef $ qSubProhibited s + _qSubEnd <- readIORef $ qSubEnd s + _qSubEndB <- readIORef $ qSubEndB s + _ntfCreated <- readIORef $ ntfCreated s + _ntfDeleted <- readIORef $ ntfDeleted s + _ntfDeletedB <- readIORef $ ntfDeletedB s + _ntfSub <- readIORef $ ntfSub s + _ntfSubB <- readIORef $ ntfSubB s + _ntfSubAuth <- readIORef $ ntfSubAuth s + _ntfSubDuplicate <- readIORef $ ntfSubDuplicate s + _msgSent <- readIORef $ msgSent s + _msgSentAuth <- readIORef $ msgSentAuth s + _msgSentQuota <- readIORef $ msgSentQuota s + _msgSentLarge <- readIORef $ msgSentLarge s + _msgRecv <- readIORef $ msgRecv s + _msgRecvGet <- readIORef $ msgRecvGet s + _msgGet <- readIORef $ msgGet s + _msgGetNoMsg <- readIORef $ msgGetNoMsg s + _msgGetAuth <- readIORef $ msgGetAuth s + _msgGetDuplicate <- readIORef $ msgGetDuplicate s + _msgGetProhibited <- readIORef $ msgGetProhibited s + _msgExpired <- readIORef $ msgExpired s _activeQueues <- getPeriodStatsData $ activeQueues s - _subscribedQueues <- getPeriodStatsData $ subscribedQueues s - _msgSentNtf <- readTVarIO $ msgSentNtf s - _msgRecvNtf <- readTVarIO $ msgRecvNtf s + _msgSentNtf <- readIORef $ msgSentNtf s + _msgRecvNtf <- readIORef $ msgRecvNtf s _activeQueuesNtf <- getPeriodStatsData $ activeQueuesNtf s - _msgNtfs <- readTVarIO $ msgNtfs s - _msgNtfNoSub <- readTVarIO $ msgNtfNoSub s - _msgNtfLost <- readTVarIO $ msgNtfLost s + _msgNtfs <- readIORef $ msgNtfs s + _msgNtfNoSub <- readIORef $ msgNtfNoSub s + _msgNtfLost <- readIORef $ msgNtfLost s _pRelays <- getProxyStatsData $ pRelays s _pRelaysOwn <- getProxyStatsData $ pRelaysOwn s _pMsgFwds <- getProxyStatsData $ pMsgFwds s _pMsgFwdsOwn <- getProxyStatsData $ pMsgFwdsOwn s - _pMsgFwdsRecv <- readTVarIO $ pMsgFwdsRecv s - _qCount <- readTVarIO $ qCount s - _msgCount <- readTVarIO $ msgCount s + _pMsgFwdsRecv <- readIORef $ pMsgFwdsRecv s + _qCount <- readIORef $ qCount s + _msgCount <- readIORef $ msgCount s pure ServerStatsData { _fromTime, _qCreated, _qSecured, _qDeletedAll, + _qDeletedAllB, _qDeletedNew, _qDeletedSecured, _qSub, - _qSubNoMsg, + _qSubAllB, _qSubAuth, _qSubDuplicate, _qSubProhibited, + _qSubEnd, + _qSubEndB, _ntfCreated, _ntfDeleted, + _ntfDeletedB, _ntfSub, + _ntfSubB, _ntfSubAuth, _ntfSubDuplicate, _msgSent, @@ -280,7 +314,6 @@ getServerStatsData s = do _msgGetProhibited, _msgExpired, _activeQueues, - _subscribedQueues, _msgSentNtf, _msgRecvNtf, _activeQueuesNtf, @@ -296,51 +329,56 @@ getServerStatsData s = do _msgCount } -setServerStats :: ServerStats -> ServerStatsData -> STM () +-- this function is not thread safe, it is used on server start only +setServerStats :: ServerStats -> ServerStatsData -> IO () setServerStats s d = do - writeTVar (fromTime s) $! _fromTime d - writeTVar (qCreated s) $! _qCreated d - writeTVar (qSecured s) $! _qSecured d - writeTVar (qDeletedAll s) $! _qDeletedAll d - writeTVar (qDeletedNew s) $! _qDeletedNew d - writeTVar (qDeletedSecured s) $! _qDeletedSecured d - writeTVar (qSub s) $! _qSub d - writeTVar (qSubNoMsg s) $! _qSubNoMsg d - writeTVar (qSubAuth s) $! _qSubAuth d - writeTVar (qSubDuplicate s) $! _qSubDuplicate d - writeTVar (qSubProhibited s) $! _qSubProhibited d - writeTVar (ntfCreated s) $! _ntfCreated d - writeTVar (ntfDeleted s) $! _ntfDeleted d - writeTVar (ntfSub s) $! _ntfSub d - writeTVar (ntfSubAuth s) $! _ntfSubAuth d - writeTVar (ntfSubDuplicate s) $! _ntfSubDuplicate d - writeTVar (msgSent s) $! _msgSent d - writeTVar (msgSentAuth s) $! _msgSentAuth d - writeTVar (msgSentQuota s) $! _msgSentQuota d - writeTVar (msgSentLarge s) $! _msgSentLarge d - writeTVar (msgRecv s) $! _msgRecv d - writeTVar (msgRecvGet s) $! _msgRecvGet d - writeTVar (msgGet s) $! _msgGet d - writeTVar (msgGetNoMsg s) $! _msgGetNoMsg d - writeTVar (msgGetAuth s) $! _msgGetAuth d - writeTVar (msgGetDuplicate s) $! _msgGetDuplicate d - writeTVar (msgGetProhibited s) $! _msgGetProhibited d - writeTVar (msgExpired s) $! _msgExpired d + writeIORef (fromTime s) $! _fromTime d + writeIORef (qCreated s) $! _qCreated d + writeIORef (qSecured s) $! _qSecured d + writeIORef (qDeletedAll s) $! _qDeletedAll d + writeIORef (qDeletedAllB s) $! _qDeletedAllB d + writeIORef (qDeletedNew s) $! _qDeletedNew d + writeIORef (qDeletedSecured s) $! _qDeletedSecured d + writeIORef (qSub s) $! _qSub d + writeIORef (qSubAllB s) $! _qSubAllB d + writeIORef (qSubAuth s) $! _qSubAuth d + writeIORef (qSubDuplicate s) $! _qSubDuplicate d + writeIORef (qSubProhibited s) $! _qSubProhibited d + writeIORef (qSubEnd s) $! _qSubEnd d + writeIORef (qSubEndB s) $! _qSubEndB d + writeIORef (ntfCreated s) $! _ntfCreated d + writeIORef (ntfDeleted s) $! _ntfDeleted d + writeIORef (ntfDeletedB s) $! _ntfDeletedB d + writeIORef (ntfSub s) $! _ntfSub d + writeIORef (ntfSubB s) $! _ntfSubB d + writeIORef (ntfSubAuth s) $! _ntfSubAuth d + writeIORef (ntfSubDuplicate s) $! _ntfSubDuplicate d + writeIORef (msgSent s) $! _msgSent d + writeIORef (msgSentAuth s) $! _msgSentAuth d + writeIORef (msgSentQuota s) $! _msgSentQuota d + writeIORef (msgSentLarge s) $! _msgSentLarge d + writeIORef (msgRecv s) $! _msgRecv d + writeIORef (msgRecvGet s) $! _msgRecvGet d + writeIORef (msgGet s) $! _msgGet d + writeIORef (msgGetNoMsg s) $! _msgGetNoMsg d + writeIORef (msgGetAuth s) $! _msgGetAuth d + writeIORef (msgGetDuplicate s) $! _msgGetDuplicate d + writeIORef (msgGetProhibited s) $! _msgGetProhibited d + writeIORef (msgExpired s) $! _msgExpired d setPeriodStats (activeQueues s) (_activeQueues d) - setPeriodStats (subscribedQueues s) (_subscribedQueues d) - writeTVar (msgSentNtf s) $! _msgSentNtf d - writeTVar (msgRecvNtf s) $! _msgRecvNtf d + writeIORef (msgSentNtf s) $! _msgSentNtf d + writeIORef (msgRecvNtf s) $! _msgRecvNtf d setPeriodStats (activeQueuesNtf s) (_activeQueuesNtf d) - writeTVar (msgNtfs s) $! _msgNtfs d - writeTVar (msgNtfNoSub s) $! _msgNtfNoSub d - writeTVar (msgNtfLost s) $! _msgNtfLost d + writeIORef (msgNtfs s) $! _msgNtfs d + writeIORef (msgNtfNoSub s) $! _msgNtfNoSub d + writeIORef (msgNtfLost s) $! _msgNtfLost d setProxyStats (pRelays s) $! _pRelays d setProxyStats (pRelaysOwn s) $! _pRelaysOwn d setProxyStats (pMsgFwds s) $! _pMsgFwds d setProxyStats (pMsgFwdsOwn s) $! _pMsgFwdsOwn d - writeTVar (pMsgFwdsRecv s) $! _pMsgFwdsRecv d - writeTVar (qCount s) $! _qCount d - writeTVar (msgCount s) $! _msgCount d + writeIORef (pMsgFwdsRecv s) $! _pMsgFwdsRecv d + writeIORef (qCount s) $! _qCount d + writeIORef (msgCount s) $! _msgCount d instance StrEncoding ServerStatsData where strEncode d = @@ -351,15 +389,20 @@ instance StrEncoding ServerStatsData where "qDeletedAll=" <> strEncode (_qDeletedAll d), "qDeletedNew=" <> strEncode (_qDeletedNew d), "qDeletedSecured=" <> strEncode (_qDeletedSecured d), + "qDeletedAllB=" <> strEncode (_qDeletedAllB d), "qCount=" <> strEncode (_qCount d), "qSub=" <> strEncode (_qSub d), - "qSubNoMsg=" <> strEncode (_qSubNoMsg d), + "qSubAllB=" <> strEncode (_qSubAllB d), "qSubAuth=" <> strEncode (_qSubAuth d), "qSubDuplicate=" <> strEncode (_qSubDuplicate d), "qSubProhibited=" <> strEncode (_qSubProhibited d), + "qSubEnd=" <> strEncode (_qSubEnd d), + "qSubEndB=" <> strEncode (_qSubEndB d), "ntfCreated=" <> strEncode (_ntfCreated d), "ntfDeleted=" <> strEncode (_ntfDeleted d), + "ntfDeletedB=" <> strEncode (_ntfDeletedB d), "ntfSub=" <> strEncode (_ntfSub d), + "ntfSubB=" <> strEncode (_ntfSubB d), "ntfSubAuth=" <> strEncode (_ntfSubAuth d), "ntfSubDuplicate=" <> strEncode (_ntfSubDuplicate d), "msgSent=" <> strEncode (_msgSent d), @@ -381,8 +424,6 @@ instance StrEncoding ServerStatsData where "msgNtfLost=" <> strEncode (_msgNtfLost d), "activeQueues:", strEncode (_activeQueues d), - "subscribedQueues:", - strEncode (_subscribedQueues d), "activeQueuesNtf:", strEncode (_activeQueuesNtf d), "pRelays:", @@ -402,15 +443,21 @@ instance StrEncoding ServerStatsData where (_qDeletedAll, _qDeletedNew, _qDeletedSecured) <- (,0,0) <$> ("qDeleted=" *> strP <* A.endOfLine) <|> ((,,) <$> ("qDeletedAll=" *> strP <* A.endOfLine) <*> ("qDeletedNew=" *> strP <* A.endOfLine) <*> ("qDeletedSecured=" *> strP <* A.endOfLine)) + _qDeletedAllB <- opt "qDeletedAllB=" _qCount <- opt "qCount=" _qSub <- opt "qSub=" - _qSubNoMsg <- opt "qSubNoMsg=" + _qSubNoMsg <- skipInt "qSubNoMsg=" -- skipping it for backward compatibility + _qSubAllB <- opt "qSubAllB=" _qSubAuth <- opt "qSubAuth=" _qSubDuplicate <- opt "qSubDuplicate=" _qSubProhibited <- opt "qSubProhibited=" + _qSubEnd <- opt "qSubEnd=" + _qSubEndB <- opt "qSubEndB=" _ntfCreated <- opt "ntfCreated=" _ntfDeleted <- opt "ntfDeleted=" + _ntfDeletedB <- opt "ntfDeletedB=" _ntfSub <- opt "ntfSub=" + _ntfSubB <- opt "ntfSubB=" _ntfSubAuth <- opt "ntfSubAuth=" _ntfSubDuplicate <- opt "ntfSubDuplicate=" _msgSent <- "msgSent=" *> strP <* A.endOfLine @@ -440,7 +487,7 @@ instance StrEncoding ServerStatsData where pure PeriodStatsData {_day, _week, _month} _subscribedQueues <- optional ("subscribedQueues:" <* A.endOfLine) >>= \case - Just _ -> strP <* optional A.endOfLine + Just _ -> newPeriodStatsData <$ (strP @PeriodStatsData <* optional A.endOfLine) _ -> pure newPeriodStatsData _activeQueuesNtf <- optional ("activeQueuesNtf:" <* A.endOfLine) >>= \case @@ -457,16 +504,21 @@ instance StrEncoding ServerStatsData where _qCreated, _qSecured, _qDeletedAll, + _qDeletedAllB, _qDeletedNew, _qDeletedSecured, _qSub, - _qSubNoMsg, + _qSubAllB, _qSubAuth, _qSubDuplicate, _qSubProhibited, + _qSubEnd, + _qSubEndB, _ntfCreated, _ntfDeleted, + _ntfDeletedB, _ntfSub, + _ntfSubB, _ntfSubAuth, _ntfSubDuplicate, _msgSent, @@ -487,7 +539,6 @@ instance StrEncoding ServerStatsData where _msgNtfNoSub, _msgNtfLost, _activeQueues, - _subscribedQueues, _activeQueuesNtf, _pRelays, _pRelaysOwn, @@ -499,55 +550,59 @@ instance StrEncoding ServerStatsData where } where opt s = A.string s *> strP <* A.endOfLine <|> pure 0 + skipInt s = (0 :: Int) <$ optional (A.string s *> strP @Int *> A.endOfLine) proxyStatsP key = optional (A.string key >> A.endOfLine) >>= \case Just _ -> strP <* optional A.endOfLine _ -> pure newProxyStatsData -data PeriodStats a = PeriodStats - { day :: TVar (Set a), - week :: TVar (Set a), - month :: TVar (Set a) +data PeriodStats = PeriodStats + { day :: IORef IntSet, + week :: IORef IntSet, + month :: IORef IntSet } -newPeriodStats :: IO (PeriodStats a) +newPeriodStats :: IO PeriodStats newPeriodStats = do - day <- newTVarIO S.empty - week <- newTVarIO S.empty - month <- newTVarIO S.empty + day <- newIORef IS.empty + week <- newIORef IS.empty + month <- newIORef IS.empty pure PeriodStats {day, week, month} -data PeriodStatsData a = PeriodStatsData - { _day :: Set a, - _week :: Set a, - _month :: Set a +data PeriodStatsData = PeriodStatsData + { _day :: IntSet, + _week :: IntSet, + _month :: IntSet } deriving (Show) -newPeriodStatsData :: PeriodStatsData a -newPeriodStatsData = PeriodStatsData {_day = S.empty, _week = S.empty, _month = S.empty} +newPeriodStatsData :: PeriodStatsData +newPeriodStatsData = PeriodStatsData {_day = IS.empty, _week = IS.empty, _month = IS.empty} -getPeriodStatsData :: PeriodStats a -> IO (PeriodStatsData a) +getPeriodStatsData :: PeriodStats -> IO PeriodStatsData getPeriodStatsData s = do - _day <- readTVarIO $ day s - _week <- readTVarIO $ week s - _month <- readTVarIO $ month s + _day <- readIORef $ day s + _week <- readIORef $ week s + _month <- readIORef $ month s pure PeriodStatsData {_day, _week, _month} -setPeriodStats :: PeriodStats a -> PeriodStatsData a -> STM () +-- this function is not thread safe, it is used on server start only +setPeriodStats :: PeriodStats -> PeriodStatsData -> IO () setPeriodStats s d = do - writeTVar (day s) $! _day d - writeTVar (week s) $! _week d - writeTVar (month s) $! _month d + writeIORef (day s) $! _day d + writeIORef (week s) $! _week d + writeIORef (month s) $! _month d -instance (Ord a, StrEncoding a) => StrEncoding (PeriodStatsData a) where +instance StrEncoding PeriodStatsData where strEncode PeriodStatsData {_day, _week, _month} = - "day=" <> strEncode _day <> "\nweek=" <> strEncode _week <> "\nmonth=" <> strEncode _month + "dayHashes=" <> strEncode _day <> "\nweekHashes=" <> strEncode _week <> "\nmonthHashes=" <> strEncode _month strP = do - _day <- "day=" *> strP <* A.endOfLine - _week <- "week=" *> strP <* A.endOfLine - _month <- "month=" *> strP + _day <- ("day=" *> bsSetP <|> "dayHashes=" *> strP) <* A.endOfLine + _week <- ("week=" *> bsSetP <|> "weekHashes=" *> strP) <* A.endOfLine + _month <- "month=" *> bsSetP <|> "monthHashes=" *> strP pure PeriodStatsData {_day, _week, _month} + where + bsSetP = S.foldl' (\s -> (`IS.insert` s) . hash) IS.empty <$> strP @(Set ByteString) data PeriodStatCounts = PeriodStatCounts { dayCount :: String, @@ -555,7 +610,7 @@ data PeriodStatCounts = PeriodStatCounts monthCount :: String } -periodStatCounts :: forall a. PeriodStats a -> UTCTime -> STM PeriodStatCounts +periodStatCounts :: PeriodStats -> UTCTime -> IO PeriodStatCounts periodStatCounts ps ts = do let d = utctDay ts (_, wDay) = mondayStartWeek d @@ -565,33 +620,34 @@ periodStatCounts ps ts = do monthCount <- periodCount mDay $ month ps pure PeriodStatCounts {dayCount, weekCount, monthCount} where - periodCount :: Int -> TVar (Set a) -> STM String - periodCount 1 pVar = show . S.size <$> swapTVar pVar S.empty + periodCount :: Int -> IORef IntSet -> IO String + periodCount 1 ref = show . IS.size <$> atomicSwapIORef ref IS.empty periodCount _ _ = pure "" -updatePeriodStats :: Ord a => PeriodStats a -> a -> STM () -updatePeriodStats stats pId = do - updatePeriod day - updatePeriod week - updatePeriod month +updatePeriodStats :: PeriodStats -> EntityId -> IO () +updatePeriodStats ps (EntityId pId) = do + updatePeriod $ day ps + updatePeriod $ week ps + updatePeriod $ month ps where - updatePeriod pSel = modifyTVar' (pSel stats) (S.insert pId) + ph = hash pId + updatePeriod ref = unlessM (IS.member ph <$> readIORef ref) $ atomicModifyIORef'_ ref $ IS.insert ph data ProxyStats = ProxyStats - { pRequests :: TVar Int, - pSuccesses :: TVar Int, -- includes destination server error responses that will be forwarded to the client - pErrorsConnect :: TVar Int, - pErrorsCompat :: TVar Int, - pErrorsOther :: TVar Int + { pRequests :: IORef Int, + pSuccesses :: IORef Int, -- includes destination server error responses that will be forwarded to the client + pErrorsConnect :: IORef Int, + pErrorsCompat :: IORef Int, + pErrorsOther :: IORef Int } newProxyStats :: IO ProxyStats newProxyStats = do - pRequests <- newTVarIO 0 - pSuccesses <- newTVarIO 0 - pErrorsConnect <- newTVarIO 0 - pErrorsCompat <- newTVarIO 0 - pErrorsOther <- newTVarIO 0 + pRequests <- newIORef 0 + pSuccesses <- newIORef 0 + pErrorsConnect <- newIORef 0 + pErrorsCompat <- newIORef 0 + pErrorsOther <- newIORef 0 pure ProxyStats {pRequests, pSuccesses, pErrorsConnect, pErrorsCompat, pErrorsOther} data ProxyStatsData = ProxyStatsData @@ -608,29 +664,30 @@ newProxyStatsData = ProxyStatsData {_pRequests = 0, _pSuccesses = 0, _pErrorsCon getProxyStatsData :: ProxyStats -> IO ProxyStatsData getProxyStatsData s = do - _pRequests <- readTVarIO $ pRequests s - _pSuccesses <- readTVarIO $ pSuccesses s - _pErrorsConnect <- readTVarIO $ pErrorsConnect s - _pErrorsCompat <- readTVarIO $ pErrorsCompat s - _pErrorsOther <- readTVarIO $ pErrorsOther s + _pRequests <- readIORef $ pRequests s + _pSuccesses <- readIORef $ pSuccesses s + _pErrorsConnect <- readIORef $ pErrorsConnect s + _pErrorsCompat <- readIORef $ pErrorsCompat s + _pErrorsOther <- readIORef $ pErrorsOther s pure ProxyStatsData {_pRequests, _pSuccesses, _pErrorsConnect, _pErrorsCompat, _pErrorsOther} -getResetProxyStatsData :: ProxyStats -> STM ProxyStatsData +getResetProxyStatsData :: ProxyStats -> IO ProxyStatsData getResetProxyStatsData s = do - _pRequests <- swapTVar (pRequests s) 0 - _pSuccesses <- swapTVar (pSuccesses s) 0 - _pErrorsConnect <- swapTVar (pErrorsConnect s) 0 - _pErrorsCompat <- swapTVar (pErrorsCompat s) 0 - _pErrorsOther <- swapTVar (pErrorsOther s) 0 + _pRequests <- atomicSwapIORef (pRequests s) 0 + _pSuccesses <- atomicSwapIORef (pSuccesses s) 0 + _pErrorsConnect <- atomicSwapIORef (pErrorsConnect s) 0 + _pErrorsCompat <- atomicSwapIORef (pErrorsCompat s) 0 + _pErrorsOther <- atomicSwapIORef (pErrorsOther s) 0 pure ProxyStatsData {_pRequests, _pSuccesses, _pErrorsConnect, _pErrorsCompat, _pErrorsOther} -setProxyStats :: ProxyStats -> ProxyStatsData -> STM () +-- this function is not thread safe, it is used on server start only +setProxyStats :: ProxyStats -> ProxyStatsData -> IO () setProxyStats s d = do - writeTVar (pRequests s) $! _pRequests d - writeTVar (pSuccesses s) $! _pSuccesses d - writeTVar (pErrorsConnect s) $! _pErrorsConnect d - writeTVar (pErrorsCompat s) $! _pErrorsCompat d - writeTVar (pErrorsOther s) $! _pErrorsOther d + writeIORef (pRequests s) $! _pRequests d + writeIORef (pSuccesses s) $! _pSuccesses d + writeIORef (pErrorsConnect s) $! _pErrorsConnect d + writeIORef (pErrorsCompat s) $! _pErrorsCompat d + writeIORef (pErrorsOther s) $! _pErrorsOther d instance StrEncoding ProxyStatsData where strEncode ProxyStatsData {_pRequests, _pSuccesses, _pErrorsConnect, _pErrorsCompat, _pErrorsOther} = diff --git a/src/Simplex/Messaging/Server/StoreLog.hs b/src/Simplex/Messaging/Server/StoreLog.hs index 94a340d94..c47b06eb5 100644 --- a/src/Simplex/Messaging/Server/StoreLog.hs +++ b/src/Simplex/Messaging/Server/StoreLog.hs @@ -20,12 +20,14 @@ module Simplex.Messaging.Server.StoreLog logSuspendQueue, logDeleteQueue, logDeleteNotifier, + logUpdateQueueTime, readWriteStoreLog, ) where import Control.Applicative (optional, (<|>)) import Control.Monad (foldM, unless, when) +import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB import Data.Functor (($>)) @@ -33,7 +35,7 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol -import Simplex.Messaging.Server.QueueStore (NtfCreds (..), QueueRec (..), ServerQueueStatus (..)) +import Simplex.Messaging.Server.QueueStore import Simplex.Messaging.Transport.Buffer (trimCR) import Simplex.Messaging.Util (ifM) import System.Directory (doesFileExist, renameFile) @@ -52,9 +54,19 @@ data StoreLogRecord | SuspendQueue QueueId | DeleteQueue QueueId | DeleteNotifier QueueId + | UpdateTime QueueId RoundedSystemTime + +data SLRTag + = CreateQueue_ + | SecureQueue_ + | AddNotifier_ + | SuspendQueue_ + | DeleteQueue_ + | DeleteNotifier_ + | UpdateTime_ instance StrEncoding QueueRec where - strEncode QueueRec {recipientId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier} = + strEncode QueueRec {recipientId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, updatedAt} = B.unwords [ "rid=" <> strEncode recipientId, "rk=" <> strEncode recipientKey, @@ -64,8 +76,10 @@ instance StrEncoding QueueRec where ] <> if sndSecure then " sndSecure=" <> strEncode sndSecure else "" <> maybe "" notifierStr notifier + <> maybe "" updatedAtStr updatedAt where notifierStr ntfCreds = " notifier=" <> strEncode ntfCreds + updatedAtStr t = " updated_at=" <> strEncode t strP = do recipientId <- "rid=" *> strP_ @@ -75,24 +89,49 @@ instance StrEncoding QueueRec where senderKey <- "sk=" *> strP sndSecure <- (" sndSecure=" *> strP) <|> pure False notifier <- optional $ " notifier=" *> strP - pure QueueRec {recipientId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, status = QueueActive} + updatedAt <- optional $ " updated_at=" *> strP + pure QueueRec {recipientId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, status = QueueActive, updatedAt} + +instance StrEncoding SLRTag where + strEncode = \case + CreateQueue_ -> "CREATE" + SecureQueue_ -> "SECURE" + AddNotifier_ -> "NOTIFIER" + SuspendQueue_ -> "SUSPEND" + DeleteQueue_ -> "DELETE" + DeleteNotifier_ -> "NDELETE" + UpdateTime_ -> "TIME" + + strP = + A.takeTill (== ' ') >>= \case + "CREATE" -> pure CreateQueue_ + "SECURE" -> pure SecureQueue_ + "NOTIFIER" -> pure AddNotifier_ + "SUSPEND" -> pure SuspendQueue_ + "DELETE" -> pure DeleteQueue_ + "NDELETE" -> pure DeleteNotifier_ + "TIME" -> pure UpdateTime_ + s -> fail $ "invalid log record tag: " <> B.unpack s instance StrEncoding StoreLogRecord where strEncode = \case - CreateQueue q -> strEncode (Str "CREATE", q) - SecureQueue rId sKey -> strEncode (Str "SECURE", rId, sKey) - AddNotifier rId ntfCreds -> strEncode (Str "NOTIFIER", rId, ntfCreds) - SuspendQueue rId -> strEncode (Str "SUSPEND", rId) - DeleteQueue rId -> strEncode (Str "DELETE", rId) - DeleteNotifier rId -> strEncode (Str "NDELETE", rId) + CreateQueue q -> strEncode (CreateQueue_, q) + SecureQueue rId sKey -> strEncode (SecureQueue_, rId, sKey) + AddNotifier rId ntfCreds -> strEncode (AddNotifier_, rId, ntfCreds) + SuspendQueue rId -> strEncode (SuspendQueue_, rId) + DeleteQueue rId -> strEncode (DeleteQueue_, rId) + DeleteNotifier rId -> strEncode (DeleteNotifier_, rId) + UpdateTime rId t -> strEncode (UpdateTime_, rId, t) strP = - "CREATE " *> (CreateQueue <$> strP) - <|> "SECURE " *> (SecureQueue <$> strP_ <*> strP) - <|> "NOTIFIER " *> (AddNotifier <$> strP_ <*> strP) - <|> "SUSPEND " *> (SuspendQueue <$> strP) - <|> "DELETE " *> (DeleteQueue <$> strP) - <|> "NDELETE " *> (DeleteNotifier <$> strP) + strP_ >>= \case + CreateQueue_ -> CreateQueue <$> strP + SecureQueue_ -> SecureQueue <$> strP_ <*> strP + AddNotifier_ -> AddNotifier <$> strP_ <*> strP + SuspendQueue_ -> SuspendQueue <$> strP + DeleteQueue_ -> DeleteQueue <$> strP + DeleteNotifier_ -> DeleteNotifier <$> strP + UpdateTime_ -> UpdateTime <$> strP_ <*> strP openWriteStoreLog :: FilePath -> IO (StoreLog 'WriteMode) openWriteStoreLog f = do @@ -138,6 +177,9 @@ logDeleteQueue s = writeStoreLogRecord s . DeleteQueue logDeleteNotifier :: StoreLog 'WriteMode -> QueueId -> IO () logDeleteNotifier s = writeStoreLogRecord s . DeleteNotifier +logUpdateQueueTime :: StoreLog 'WriteMode -> QueueId -> RoundedSystemTime -> IO () +logUpdateQueueTime s qId t = writeStoreLogRecord s $ UpdateTime qId t + readWriteStoreLog :: FilePath -> IO (Map RecipientId QueueRec, StoreLog 'WriteMode) readWriteStoreLog f = do qs <- ifM (doesFileExist f) readQS (pure M.empty) @@ -169,5 +211,6 @@ readQueues f = foldM processLine M.empty . LB.lines =<< LB.readFile f SuspendQueue qId -> M.adjust (\q -> q {status = QueueOff}) qId m DeleteQueue qId -> M.delete qId m DeleteNotifier qId -> M.adjust (\q -> q {notifier = Nothing}) qId m + UpdateTime qId t -> M.adjust (\q -> q {updatedAt = Just t}) qId m printError :: String -> IO () printError e = B.putStrLn $ "Error parsing log: " <> B.pack e <> " - " <> s diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs index 3386f82f3..e681ec396 100644 --- a/src/Simplex/Messaging/Transport.hs +++ b/src/Simplex/Messaging/Transport.hs @@ -47,6 +47,7 @@ module Simplex.Messaging.Transport authCmdsSMPVersion, sendingProxySMPVersion, sndAuthKeySMPVersion, + deletedEventSMPVersion, simplexMQVersion, smpBlockSize, TransportConfig (..), @@ -116,7 +117,6 @@ import Simplex.Messaging.Version.Internal import System.IO.Error (isEOFError) import UnliftIO.Exception (Exception) import qualified UnliftIO.Exception as E -import UnliftIO.STM -- * Transport parameters @@ -131,6 +131,9 @@ smpBlockSize = 16384 -- 5 - basic auth for SMP servers (11/12/2022) -- 6 - allow creating queues without subscribing (9/10/2023) -- 7 - support authenticated encryption to verify senders' commands, imply but do NOT send session ID in signed part (4/30/2024) +-- 8 - SMP proxy for sender commands +-- 9 - faster handshake: SKEY command for sender to secure queue +-- 10 - DELD event to subscriber when queue is deleted via another connnection data SMPVersion @@ -161,14 +164,17 @@ sendingProxySMPVersion = VersionSMP 8 sndAuthKeySMPVersion :: VersionSMP sndAuthKeySMPVersion = VersionSMP 9 +deletedEventSMPVersion :: VersionSMP +deletedEventSMPVersion = VersionSMP 10 + currentClientSMPRelayVersion :: VersionSMP -currentClientSMPRelayVersion = VersionSMP 9 +currentClientSMPRelayVersion = VersionSMP 10 legacyServerSMPRelayVersion :: VersionSMP legacyServerSMPRelayVersion = VersionSMP 6 currentServerSMPRelayVersion :: VersionSMP -currentServerSMPRelayVersion = VersionSMP 9 +currentServerSMPRelayVersion = VersionSMP 10 -- Max SMP protocol version to be used in e2e encrypted -- connection between client and server, as defined by SMP proxy. diff --git a/src/Simplex/Messaging/Transport/HTTP2.hs b/src/Simplex/Messaging/Transport/HTTP2.hs index 3b741e6ce..10522c5bc 100644 --- a/src/Simplex/Messaging/Transport/HTTP2.hs +++ b/src/Simplex/Messaging/Transport/HTTP2.hs @@ -2,7 +2,6 @@ module Simplex.Messaging.Transport.HTTP2 where -import Control.Concurrent.STM import qualified Control.Exception as E import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B diff --git a/src/Simplex/Messaging/Transport/Server.hs b/src/Simplex/Messaging/Transport/Server.hs index 0b4da7833..28d4d354d 100644 --- a/src/Simplex/Messaging/Transport/Server.hs +++ b/src/Simplex/Messaging/Transport/Server.hs @@ -12,7 +12,7 @@ module Simplex.Messaging.Transport.Server newSocketState, runTransportServer, runTransportServerSocket, - runTCPServer, + runLocalTCPServer, runTCPServerSocket, startTCPServer, loadSupportedTLSServerParams, @@ -80,7 +80,7 @@ runTransportServer started port params cfg server = do runTransportServerState ss started port params cfg server runTransportServerState :: forall c . Transport c => SocketState -> TMVar Bool -> ServiceName -> T.ServerParams -> TransportServerConfig -> (c -> IO ()) -> IO () -runTransportServerState ss started port = runTransportServerSocketState ss started (startTCPServer started port) (transportName (TProxy :: TProxy c)) +runTransportServerState ss started port = runTransportServerSocketState ss started (startTCPServer started Nothing port) (transportName (TProxy :: TProxy c)) -- | Run a transport server with provided connection setup and handler. runTransportServerSocket :: Transport a => TMVar Bool -> IO Socket -> String -> T.ServerParams -> TransportServerConfig -> (a -> IO ()) -> IO () @@ -107,10 +107,10 @@ tlsServerCredentials serverParams = case T.sharedCredentials $ T.serverShared se _ -> error "server has more than one key" -- | Run TCP server without TLS -runTCPServer :: TMVar Bool -> ServiceName -> (Socket -> IO ()) -> IO () -runTCPServer started port server = do +runLocalTCPServer :: TMVar Bool -> ServiceName -> (Socket -> IO ()) -> IO () +runLocalTCPServer started port server = do ss <- newSocketState - runTCPServerSocket ss started (startTCPServer started port) server + runTCPServerSocket ss started (startTCPServer started (Just "127.0.0.1") port) server -- | Wrap socket provider in a TCP server bracket. runTCPServerSocket :: SocketState -> TMVar Bool -> IO Socket -> (Socket -> IO ()) -> IO () @@ -157,12 +157,12 @@ closeServer started clients sock = do close sock void . atomically $ tryPutTMVar started False -startTCPServer :: TMVar Bool -> ServiceName -> IO Socket -startTCPServer started port = withSocketsDo $ resolve >>= open >>= setStarted +startTCPServer :: TMVar Bool -> Maybe HostName -> ServiceName -> IO Socket +startTCPServer started host port = withSocketsDo $ resolve >>= open >>= setStarted where resolve = let hints = defaultHints {addrFlags = [AI_PASSIVE], addrSocketType = Stream} - in select <$> getAddrInfo (Just hints) Nothing (Just port) + in select <$> getAddrInfo (Just hints) host (Just port) select as = fromJust $ family AF_INET6 <|> family AF_INET where family f = find ((== f) . addrFamily) as diff --git a/src/Simplex/Messaging/Util.hs b/src/Simplex/Messaging/Util.hs index e46681ea7..fde54ab01 100644 --- a/src/Simplex/Messaging/Util.hs +++ b/src/Simplex/Messaging/Util.hs @@ -15,6 +15,7 @@ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB import Data.Int (Int64) +import Data.IORef import Data.List (groupBy, sortOn) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as L @@ -23,7 +24,7 @@ import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8With, encodeUtf8) import Data.Time (NominalDiffTime) import GHC.Conc (labelThread, myThreadId, threadDelay) -import UnliftIO +import UnliftIO hiding (atomicModifyIORef') import qualified UnliftIO.Exception as UE raceAny_ :: MonadUnliftIO m => [m a] -> m () @@ -167,13 +168,18 @@ threadDelay' = loop diffToMicroseconds :: NominalDiffTime -> Int64 diffToMicroseconds diff = truncate $ diff * 1000000 +{-# INLINE diffToMicroseconds #-} diffToMilliseconds :: NominalDiffTime -> Int64 diffToMilliseconds diff = truncate $ diff * 1000 +{-# INLINE diffToMilliseconds #-} labelMyThread :: MonadIO m => String -> m () labelMyThread label = liftIO $ myThreadId >>= (`labelThread` label) +atomicModifyIORef'_ :: IORef a -> (a -> a) -> IO () +atomicModifyIORef'_ r f = atomicModifyIORef' r (\v -> (f v, ())) + encodeJSON :: ToJSON a => a -> Text encodeJSON = safeDecodeUtf8 . LB.toStrict . J.encode diff --git a/src/Simplex/RemoteControl/Discovery.hs b/src/Simplex/RemoteControl/Discovery.hs index e70eb1c25..8ee76c651 100644 --- a/src/Simplex/RemoteControl/Discovery.hs +++ b/src/Simplex/RemoteControl/Discovery.hs @@ -71,7 +71,7 @@ preferAddress RCCtrlAddress {address, interface} addrs = startTLSServer :: Maybe Word16 -> TMVar (Maybe N.PortNumber) -> TLS.Credentials -> TLS.ServerHooks -> (Transport.TLS -> IO ()) -> IO (Async ()) startTLSServer port_ startedOnPort credentials hooks server = async . liftIO $ do started <- newEmptyTMVarIO - bracketOnError (startTCPServer started $ maybe "0" show port_) (\_e -> setPort Nothing) $ \socket -> + bracketOnError (startTCPServer started Nothing $ maybe "0" show port_) (\_e -> setPort Nothing) $ \socket -> ifM (atomically $ readTMVar started) (runServer started socket) diff --git a/tests/AgentTests/ConnectionRequestTests.hs b/tests/AgentTests/ConnectionRequestTests.hs index 5d0a2c00a..14f19efc3 100644 --- a/tests/AgentTests/ConnectionRequestTests.hs +++ b/tests/AgentTests/ConnectionRequestTests.hs @@ -20,7 +20,7 @@ import Simplex.Messaging.Agent.Protocol import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.Ratchet import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Protocol (ProtocolServer (..), currentSMPClientVersion, supportedSMPClientVRange, pattern VersionSMPC) +import Simplex.Messaging.Protocol (EntityId (..), ProtocolServer (..), currentSMPClientVersion, supportedSMPClientVRange, pattern VersionSMPC) import Simplex.Messaging.ServiceScheme (ServiceScheme (..)) import Simplex.Messaging.Version import Test.Hspec @@ -35,7 +35,7 @@ queueAddr :: SMPQueueAddress queueAddr = SMPQueueAddress { smpServer = srv, - senderId = "\223\142z\251", + senderId = EntityId "\223\142z\251", dhPublicKey = testDhKey, sndSecure = False } diff --git a/tests/AgentTests/NotificationTests.hs b/tests/AgentTests/NotificationTests.hs index c45c37124..a25564a0b 100644 --- a/tests/AgentTests/NotificationTests.hs +++ b/tests/AgentTests/NotificationTests.hs @@ -49,6 +49,7 @@ import Data.Bifunctor (bimap, first) import qualified Data.ByteString.Base64.URL as U import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B +import qualified Data.List.NonEmpty as L import Data.Text.Encoding (encodeUtf8) import Database.SQLite.Simple.QQ (sql) import NtfClient @@ -66,6 +67,7 @@ import Simplex.Messaging.Notifications.Protocol import Simplex.Messaging.Notifications.Server.Env (NtfServerConfig (..)) import Simplex.Messaging.Notifications.Server.Push.APNS import Simplex.Messaging.Notifications.Types (NtfTknAction (..), NtfToken (..)) +import Simplex.Messaging.Parsers (parseAll) import Simplex.Messaging.Protocol (ErrorType (AUTH), MsgFlags (MsgFlags), NtfServer, ProtocolServer (..), SMPMsgMeta (..), SubscriptionMode (..)) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Server.Env.STM (ServerConfig (..)) @@ -164,7 +166,7 @@ testNtfMatrix t runTest = do it "curr servers; curr clients" $ runNtfTestCfg t 1 cfg ntfServerCfg agentCfg agentCfg runTest it "curr servers; prev clients" $ runNtfTestCfg t 3 cfg ntfServerCfg agentCfgVPrevPQ agentCfgVPrevPQ runTest it "prev servers; prev clients" $ runNtfTestCfg t 3 cfgVPrev ntfServerCfgVPrev agentCfgVPrevPQ agentCfgVPrevPQ runTest - it "prev servers; curr clients" $ runNtfTestCfg t 3 cfgVPrev ntfServerCfgVPrev agentCfg agentCfg runTest + it "prev servers; curr clients" $ runNtfTestCfg t 1 cfgVPrev ntfServerCfgVPrev agentCfg agentCfg runTest -- servers can be upgraded in any order it "servers: curr SMP, prev NTF; prev clients" $ runNtfTestCfg t 3 cfg ntfServerCfgVPrev agentCfgVPrevPQ agentCfgVPrevPQ runTest it "servers: prev SMP, curr NTF; prev clients" $ runNtfTestCfg t 3 cfgVPrev ntfServerCfg agentCfgVPrevPQ agentCfgVPrevPQ runTest @@ -872,8 +874,8 @@ messageNotificationData :: HasCallStack => AgentClient -> TBQueue APNSMockReques messageNotificationData c apnsQ = do (nonce, message) <- messageNotification apnsQ NtfToken {ntfDhSecret = Just dhSecret} <- getNtfTokenData c - Right pnMsgData <- liftEither . first INTERNAL $ Right . strDecode =<< first show (C.cbDecrypt dhSecret nonce message) - pure pnMsgData + Right pnMsgs <- liftEither . first INTERNAL $ Right . parseAll pnMessagesP =<< first show (C.cbDecrypt dhSecret nonce message) + pure $ L.last pnMsgs noNotification :: TBQueue APNSMockRequest -> ExceptT AgentErrorType IO () noNotification apnsQ = do diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index f876603f5..22023cc96 100644 --- a/tests/AgentTests/SQLiteTests.hs +++ b/tests/AgentTests/SQLiteTests.hs @@ -50,7 +50,7 @@ import Simplex.Messaging.Crypto.File (CryptoFile (..)) import Simplex.Messaging.Crypto.Ratchet (InitialKeys (..), pattern PQSupportOn) import qualified Simplex.Messaging.Crypto.Ratchet as CR import Simplex.Messaging.Encoding.String (StrEncoding (..)) -import Simplex.Messaging.Protocol (SubscriptionMode (..), pattern VersionSMPC) +import Simplex.Messaging.Protocol (EntityId (..), SubscriptionMode (..), pattern VersionSMPC) import qualified Simplex.Messaging.Protocol as SMP import System.Random import Test.Hspec @@ -217,12 +217,12 @@ rcvQueue1 = { userId = 1, connId = "conn1", server = smpServer1, - rcvId = "1234", + rcvId = EntityId "1234", rcvPrivateKey = testPrivateAuthKey, rcvDhSecret = testDhSecret, e2ePrivKey = testPrivDhKey, e2eDhSecret = Nothing, - sndId = "2345", + sndId = EntityId "2345", sndSecure = True, status = New, dbQueueId = DBNewQueue, @@ -240,7 +240,7 @@ sndQueue1 = { userId = 1, connId = "conn1", server = smpServer1, - sndId = "3456", + sndId = EntityId "3456", sndSecure = True, sndPublicKey = testPublicAuthKey, sndPrivateKey = testPrivateAuthKey, @@ -332,7 +332,7 @@ testGetRcvConn :: SpecWith SQLiteStore testGetRcvConn = it "should get connection using rcv queue id and server" . withStoreTransaction $ \db -> do let smpServer = SMPServer "smp.simplex.im" "5223" testKeyHash - let recipientId = "1234" + let recipientId = EntityId "1234" g <- C.newRandom Right (_, rq) <- createRcvConn db g cData1 rcvQueue1 SCMInvitation getRcvConn db smpServer recipientId @@ -400,7 +400,7 @@ testUpgradeRcvConnToDuplex = { userId = 1, connId = "conn1", server = SMPServer "smp.simplex.im" "5223" testKeyHash, - sndId = "2345", + sndId = EntityId "2345", sndSecure = True, sndPublicKey = testPublicAuthKey, sndPrivateKey = testPrivateAuthKey, @@ -429,12 +429,12 @@ testUpgradeSndConnToDuplex = { userId = 1, connId = "conn1", server = SMPServer "smp.simplex.im" "5223" testKeyHash, - rcvId = "3456", + rcvId = EntityId "3456", rcvPrivateKey = testPrivateAuthKey, rcvDhSecret = testDhSecret, e2ePrivKey = testPrivDhKey, e2eDhSecret = Nothing, - sndId = "4567", + sndId = EntityId "4567", sndSecure = True, status = New, dbQueueId = DBNewQueue, @@ -556,7 +556,7 @@ mkSndMsgData internalId internalSndId internalHash = testCreateSndMsg_ :: DB.Connection -> PrevSndMsgHash -> ConnId -> SndQueue -> SndMsgData -> Expectation testCreateSndMsg_ db expectedPrevHash connId sq sndMsgData@SndMsgData {..} = do updateSndIds db connId - `shouldReturn` (internalId, internalSndId, expectedPrevHash) + `shouldReturn` Right (internalId, internalSndId, expectedPrevHash) createSndMsg db connId sndMsgData `shouldReturn` () createSndMsgDelivery db connId sq internalId @@ -715,7 +715,7 @@ rcvFileDescr1 = } where defaultChunkSize = FileSize $ mb 8 - replicaId = ChunkReplicaId "abc" + replicaId = ChunkReplicaId $ EntityId "abc" chunkDigest = FileDigest "ghi" testFileSbKey :: C.SbKey @@ -741,7 +741,7 @@ testGetNextRcvChunkToDownload st = do show e `shouldContain` "ConversionFailed" DB.query_ db "SELECT rcv_file_id FROM rcv_files WHERE failed = 1" `shouldReturn` [Only (1 :: Int)] - Right (Just (RcvFileChunk {rcvFileEntityId}, _)) <- getNextRcvChunkToDownload db xftpServer1 86400 + Right (Just (RcvFileChunk {rcvFileEntityId}, _, Nothing)) <- getNextRcvChunkToDownload db xftpServer1 86400 rcvFileEntityId `shouldBe` fId2 testGetNextRcvFileToDecrypt :: SQLiteStore -> Expectation @@ -785,9 +785,9 @@ newSndChunkReplica1 :: NewSndChunkReplica newSndChunkReplica1 = NewSndChunkReplica { server = xftpServer1, - replicaId = ChunkReplicaId "abc", + replicaId = ChunkReplicaId $ EntityId "abc", replicaKey = testFileReplicaKey, - rcvIdsKeys = [(ChunkReplicaId "abc", testFileReplicaKey)] + rcvIdsKeys = [(ChunkReplicaId $ EntityId "abc", testFileReplicaKey)] } testGetNextSndChunkToUpload :: SQLiteStore -> Expectation @@ -818,9 +818,9 @@ testGetNextDeletedSndChunkReplica st = do withTransaction st $ \db -> do Right Nothing <- getNextDeletedSndChunkReplica db xftpServer1 86400 - createDeletedSndChunkReplica db 1 (FileChunkReplica xftpServer1 (ChunkReplicaId "abc") testFileReplicaKey) (FileDigest "ghi") + createDeletedSndChunkReplica db 1 (FileChunkReplica xftpServer1 (ChunkReplicaId $ EntityId "abc") testFileReplicaKey) (FileDigest "ghi") DB.execute_ db "UPDATE deleted_snd_chunk_replicas SET delay = 'bad' WHERE deleted_snd_chunk_replica_id = 1" - createDeletedSndChunkReplica db 1 (FileChunkReplica xftpServer1 (ChunkReplicaId "abc") testFileReplicaKey) (FileDigest "ghi") + createDeletedSndChunkReplica db 1 (FileChunkReplica xftpServer1 (ChunkReplicaId $ EntityId "abc") testFileReplicaKey) (FileDigest "ghi") Left e <- getNextDeletedSndChunkReplica db xftpServer1 86400 show e `shouldContain` "ConversionFailed" diff --git a/tests/CoreTests/BatchingTests.hs b/tests/CoreTests/BatchingTests.hs index 5f6beb034..a12cbf1ea 100644 --- a/tests/CoreTests/BatchingTests.hs +++ b/tests/CoreTests/BatchingTests.hs @@ -2,6 +2,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} @@ -40,6 +41,7 @@ batchingTests = do it "should break on large message" testClientBatchWithLargeMessage describe "v7 (next)" $ do it "should batch with 136 subscriptions per batch" testClientBatchSubscriptionsV7 + it "should batch with N ENDs per batch" testClientBatchENDs it "should break on message that does not fit" testClientBatchWithMessageV7 it "should break on large message" testClientBatchWithLargeMessageV7 @@ -165,6 +167,20 @@ testClientBatchSubscriptionsV7 = do (length rs1, length rs2, length rs3) `shouldBe` (28, 136, 136) all lenOk [s1, s2, s3] `shouldBe` True +testClientBatchENDs :: IO () +testClientBatchENDs = do + client <- clientStubV7 + ends <- replicateM 300 randomENDCmd + let ends' = map (\t -> Right (Nothing, encodeTransmission (thParams client) t)) ends + batches1 = batchTransmissions False smpBlockSize $ L.fromList ends' + all lenOk1 batches1 `shouldBe` True + let batches = batchTransmissions True smpBlockSize $ L.fromList ends' + length batches `shouldBe` 2 + [TBTransmissions s1 n1 rs1, TBTransmissions s2 n2 rs2] <- pure batches + (n1, n2) `shouldBe` (45, 255) + (length rs1, length rs2) `shouldBe` (45, 255) + all lenOk [s1, s2] `shouldBe` True + testClientBatchWithMessage :: IO () testClientBatchWithMessage = do client <- testClientStub @@ -285,7 +301,7 @@ randomSUB_ a v sessId = do (rKey, rpKey) <- atomically $ C.generateAuthKeyPair a g thAuth_ <- testTHandleAuth v g rKey let thParams = testTHandleParams v sessId - TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (CorrId corrId, rId, Cmd SRecipient SUB) + TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (CorrId corrId, EntityId rId, Cmd SRecipient SUB) pure $ (,tToSend) <$> authTransmission thAuth_ (Just rpKey) nonce tForAuth randomSUBCmd :: ProtocolClient SMPVersion ErrorType BrokerMsg -> IO (PCTransmission ErrorType BrokerMsg) @@ -299,7 +315,13 @@ randomSUBCmd_ a c = do g <- C.newRandom rId <- atomically $ C.randomBytes 24 g (_, rpKey) <- atomically $ C.generateAuthKeyPair a g - mkTransmission c (Just rpKey, rId, Cmd SRecipient SUB) + mkTransmission c (Just rpKey, EntityId rId, Cmd SRecipient SUB) + +randomENDCmd :: IO (Transmission BrokerMsg) +randomENDCmd = do + g <- C.newRandom + rId <- atomically $ C.randomBytes 24 g + pure (CorrId "", EntityId rId, END) randomSEND :: ByteString -> Int -> IO (Either TransportError (Maybe TransmissionAuth, ByteString)) randomSEND = randomSEND_ C.SEd25519 subModeSMPVersion @@ -316,7 +338,7 @@ randomSEND_ a v sessId len = do thAuth_ <- testTHandleAuth v g sKey msg <- atomically $ C.randomBytes len g let thParams = testTHandleParams v sessId - TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (CorrId corrId, sId, Cmd SSender $ SEND noMsgFlags msg) + TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (CorrId corrId, EntityId sId, Cmd SSender $ SEND noMsgFlags msg) pure $ (,tToSend) <$> authTransmission thAuth_ (Just spKey) nonce tForAuth testTHandleParams :: VersionSMP -> ByteString -> THandleParams SMPVersion 'TClient @@ -355,7 +377,7 @@ randomSENDCmd_ a c len = do sId <- atomically $ C.randomBytes 24 g (_, rpKey) <- atomically $ C.generateAuthKeyPair a g msg <- atomically $ C.randomBytes len g - mkTransmission c (Just rpKey, sId, Cmd SSender $ SEND noMsgFlags msg) + mkTransmission c (Just rpKey, EntityId sId, Cmd SSender $ SEND noMsgFlags msg) lenOk :: ByteString -> Bool lenOk s = 0 < B.length s && B.length s <= smpBlockSize - 2 diff --git a/tests/CoreTests/TRcvQueuesTests.hs b/tests/CoreTests/TRcvQueuesTests.hs index 24d54fc8e..5b66bb844 100644 --- a/tests/CoreTests/TRcvQueuesTests.hs +++ b/tests/CoreTests/TRcvQueuesTests.hs @@ -3,18 +3,21 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-orphans #-} module CoreTests.TRcvQueuesTests where import AgentTests.EqInstances () +import qualified Data.ByteString.Char8 as B import qualified Data.List.NonEmpty as L import qualified Data.Map as M import qualified Data.Set as S +import Data.String (IsString (..)) import Simplex.Messaging.Agent.Protocol (ConnId, QueueStatus (..), UserId) import Simplex.Messaging.Agent.Store (DBQueueId (..), RcvQueue, StoredRcvQueue (..)) import qualified Simplex.Messaging.Agent.TRcvQueues as RQ import qualified Simplex.Messaging.Crypto as C -import Simplex.Messaging.Protocol (SMPServer, pattern VersionSMPC) +import Simplex.Messaging.Protocol (EntityId (..), RecipientId, SMPServer, pattern NoEntity, pattern VersionSMPC) import Test.Hspec import UnliftIO @@ -31,6 +34,8 @@ tRcvQueuesTests = do describe "queue transfer" $ do it "getDelSessQueues-batchAddQueues preserves total length" removeSubsTest +instance IsString EntityId where fromString = EntityId . B.pack + checkDataInvariant :: RQ.Queue q => RQ.TRcvQueues q -> IO Bool checkDataInvariant trq = atomically $ do conns <- readTVar $ RQ.getConnections trq @@ -44,11 +49,11 @@ checkDataInvariant trq = atomically $ do hasConnTest :: IO () hasConnTest = do trq <- RQ.empty - atomically $ RQ.addQueue (dummyRQ 0 "smp://1234-w==@alpha" "c1") trq + atomically $ RQ.addQueue (dummyRQ 0 "smp://1234-w==@alpha" "c1" "r1") trq checkDataInvariant trq `shouldReturn` True - atomically $ RQ.addQueue (dummyRQ 0 "smp://1234-w==@alpha" "c2") trq + atomically $ RQ.addQueue (dummyRQ 0 "smp://1234-w==@alpha" "c2" "r2") trq checkDataInvariant trq `shouldReturn` True - atomically $ RQ.addQueue (dummyRQ 0 "smp://1234-w==@beta" "c3") trq + atomically $ RQ.addQueue (dummyRQ 0 "smp://1234-w==@beta" "c3" "r3") trq checkDataInvariant trq `shouldReturn` True atomically (RQ.hasConn "c1" trq) `shouldReturn` True atomically (RQ.hasConn "c2" trq) `shouldReturn` True @@ -58,7 +63,7 @@ hasConnTest = do hasConnTestBatch :: IO () hasConnTestBatch = do trq <- RQ.empty - let qs = [dummyRQ 0 "smp://1234-w==@alpha" "c1", dummyRQ 0 "smp://1234-w==@alpha" "c2", dummyRQ 0 "smp://1234-w==@beta" "c3"] + let qs = [dummyRQ 0 "smp://1234-w==@alpha" "c1" "r1", dummyRQ 0 "smp://1234-w==@alpha" "c2" "r2", dummyRQ 0 "smp://1234-w==@beta" "c3" "r3"] atomically $ RQ.batchAddQueues trq qs checkDataInvariant trq `shouldReturn` True atomically (RQ.hasConn "c1" trq) `shouldReturn` True @@ -69,7 +74,7 @@ hasConnTestBatch = do batchIdempotentTest :: IO () batchIdempotentTest = do trq <- RQ.empty - let qs = [dummyRQ 0 "smp://1234-w==@alpha" "c1", dummyRQ 0 "smp://1234-w==@alpha" "c2", dummyRQ 0 "smp://1234-w==@beta" "c3"] + let qs = [dummyRQ 0 "smp://1234-w==@alpha" "c1" "r1", dummyRQ 0 "smp://1234-w==@alpha" "c2" "r2", dummyRQ 0 "smp://1234-w==@beta" "c3" "r3"] atomically $ RQ.batchAddQueues trq qs checkDataInvariant trq `shouldReturn` True qs' <- readTVarIO $ RQ.getRcvQueues trq @@ -83,9 +88,9 @@ deleteConnTest :: IO () deleteConnTest = do trq <- RQ.empty atomically $ do - RQ.addQueue (dummyRQ 0 "smp://1234-w==@alpha" "c1") trq - RQ.addQueue (dummyRQ 0 "smp://1234-w==@alpha" "c2") trq - RQ.addQueue (dummyRQ 0 "smp://1234-w==@beta" "c3") trq + RQ.addQueue (dummyRQ 0 "smp://1234-w==@alpha" "c1" "r1") trq + RQ.addQueue (dummyRQ 0 "smp://1234-w==@alpha" "c2" "r2") trq + RQ.addQueue (dummyRQ 0 "smp://1234-w==@beta" "c3" "r3") trq checkDataInvariant trq `shouldReturn` True atomically $ RQ.deleteConn "c1" trq checkDataInvariant trq `shouldReturn` True @@ -96,16 +101,16 @@ deleteConnTest = do getSessQueuesTest :: IO () getSessQueuesTest = do trq <- RQ.empty - atomically $ RQ.addQueue (dummyRQ 0 "smp://1234-w==@alpha" "c1") trq + atomically $ RQ.addQueue (dummyRQ 0 "smp://1234-w==@alpha" "c1" "r1") trq checkDataInvariant trq `shouldReturn` True - atomically $ RQ.addQueue (dummyRQ 0 "smp://1234-w==@alpha" "c2") trq + atomically $ RQ.addQueue (dummyRQ 0 "smp://1234-w==@alpha" "c2" "r2") trq checkDataInvariant trq `shouldReturn` True - atomically $ RQ.addQueue (dummyRQ 0 "smp://1234-w==@beta" "c3") trq + atomically $ RQ.addQueue (dummyRQ 0 "smp://1234-w==@beta" "c3" "r3") trq checkDataInvariant trq `shouldReturn` True - atomically $ RQ.addQueue (dummyRQ 1 "smp://1234-w==@beta" "c4") trq + atomically $ RQ.addQueue (dummyRQ 1 "smp://1234-w==@beta" "c4" "r4") trq checkDataInvariant trq `shouldReturn` True let tSess1 = (0, "smp://1234-w==@alpha", Just "c1") - RQ.getSessQueues tSess1 trq `shouldReturn` [dummyRQ 0 "smp://1234-w==@alpha" "c1"] + RQ.getSessQueues tSess1 trq `shouldReturn` [dummyRQ 0 "smp://1234-w==@alpha" "c1" "r1"] atomically (RQ.hasSessQueues tSess1 trq) `shouldReturn` True let tSess2 = (1, "smp://1234-w==@alpha", Just "c1") RQ.getSessQueues tSess2 trq `shouldReturn` [] @@ -114,17 +119,17 @@ getSessQueuesTest = do RQ.getSessQueues tSess3 trq `shouldReturn` [] atomically (RQ.hasSessQueues tSess3 trq) `shouldReturn` False let tSess4 = (0, "smp://1234-w==@alpha", Nothing) - RQ.getSessQueues tSess4 trq `shouldReturn` [dummyRQ 0 "smp://1234-w==@alpha" "c2", dummyRQ 0 "smp://1234-w==@alpha" "c1"] + RQ.getSessQueues tSess4 trq `shouldReturn` [dummyRQ 0 "smp://1234-w==@alpha" "c2" "r2", dummyRQ 0 "smp://1234-w==@alpha" "c1" "r1"] atomically (RQ.hasSessQueues tSess4 trq) `shouldReturn`True getDelSessQueuesTest :: IO () getDelSessQueuesTest = do trq <- RQ.empty let qs = - [ ("1", dummyRQ 0 "smp://1234-w==@alpha" "c1"), - ("1", dummyRQ 0 "smp://1234-w==@alpha" "c2"), - ("1", dummyRQ 0 "smp://1234-w==@beta" "c3"), - ("1", dummyRQ 1 "smp://1234-w==@beta" "c4") + [ ("1", dummyRQ 0 "smp://1234-w==@alpha" "c1" "r1"), + ("1", dummyRQ 0 "smp://1234-w==@alpha" "c2" "r2"), + ("1", dummyRQ 0 "smp://1234-w==@beta" "c3" "r3"), + ("1", dummyRQ 1 "smp://1234-w==@beta" "c4" "r4") ] atomically $ RQ.batchAddQueues trq qs checkDataInvariant trq `shouldReturn` True @@ -137,7 +142,7 @@ getDelSessQueuesTest = do -- connections intact atomically (RQ.hasConn "c1" trq) `shouldReturn` True atomically (RQ.hasConn "c2" trq) `shouldReturn` True - atomically (RQ.getDelSessQueues (0, "smp://1234-w==@alpha", Nothing) "1" trq) `shouldReturn` ([dummyRQ 0 "smp://1234-w==@alpha" "c2", dummyRQ 0 "smp://1234-w==@alpha" "c1"], ["c1", "c2"]) + atomically (RQ.getDelSessQueues (0, "smp://1234-w==@alpha", Nothing) "1" trq) `shouldReturn` ([dummyRQ 0 "smp://1234-w==@alpha" "c2" "r2", dummyRQ 0 "smp://1234-w==@alpha" "c1" "r1"], ["c1", "c2"]) checkDataInvariant trq `shouldReturn` True -- connections gone atomically (RQ.hasConn "c1" trq) `shouldReturn` False @@ -150,10 +155,10 @@ removeSubsTest :: IO () removeSubsTest = do aq <- RQ.empty let qs = - [ ("1", dummyRQ 0 "smp://1234-w==@alpha" "c1"), - ("1", dummyRQ 0 "smp://1234-w==@alpha" "c2"), - ("1", dummyRQ 0 "smp://1234-w==@beta" "c3"), - ("1", dummyRQ 1 "smp://1234-w==@beta" "c4") + [ ("1", dummyRQ 0 "smp://1234-w==@alpha" "c1" "r1"), + ("1", dummyRQ 0 "smp://1234-w==@alpha" "c2" "r2"), + ("1", dummyRQ 0 "smp://1234-w==@beta" "c3" "r3"), + ("1", dummyRQ 1 "smp://1234-w==@beta" "c4" "r4") ] atomically $ RQ.batchAddQueues aq qs @@ -180,18 +185,18 @@ totalSize a b = do csizeB <- M.size <$> readTVar (RQ.getConnections b) pure (qsizeA + qsizeB, csizeA + csizeB) -dummyRQ :: UserId -> SMPServer -> ConnId -> RcvQueue -dummyRQ userId server connId = +dummyRQ :: UserId -> SMPServer -> ConnId -> RecipientId -> RcvQueue +dummyRQ userId server connId rcvId = RcvQueue { userId, connId, server, - rcvId = "", + rcvId, rcvPrivateKey = C.APrivateAuthKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe", rcvDhSecret = "01234567890123456789012345678901", e2ePrivKey = "MC4CAQAwBQYDK2VuBCIEINCzbVFaCiYHoYncxNY8tSIfn0pXcIAhLBfFc0m+gOpk", e2eDhSecret = Nothing, - sndId = "", + sndId = NoEntity, sndSecure = True, status = New, dbQueueId = DBQueueId 0, diff --git a/tests/FileDescriptionTests.hs b/tests/FileDescriptionTests.hs index 65b818979..10c719888 100644 --- a/tests/FileDescriptionTests.hs +++ b/tests/FileDescriptionTests.hs @@ -13,6 +13,7 @@ import Simplex.FileTransfer.Description import Simplex.FileTransfer.Protocol import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String (StrEncoding (..)) +import Simplex.Messaging.Protocol (EntityId (..)) import Simplex.Messaging.ServiceScheme (ServiceScheme (..)) import System.Directory (removeFile) import Test.Hspec @@ -91,7 +92,7 @@ fileDesc = } where defaultChunkSize = FileSize $ mb 8 - replicaId = ChunkReplicaId "abc" + replicaId = ChunkReplicaId $ EntityId "abc" replicaKey = C.APrivateAuthKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe" chunkDigest = FileDigest "ghi" diff --git a/tests/NtfClient.hs b/tests/NtfClient.hs index 9bd124e55..c263bc016 100644 --- a/tests/NtfClient.hs +++ b/tests/NtfClient.hs @@ -158,7 +158,7 @@ ntfServerTest _ t = runNtfTest $ \h -> tPut' h t >> tGet' h [Right ()] <- tPut h [Right (sig, t')] pure () tGet' h = do - [(Nothing, _, (CorrId corrId, qId, Right cmd))] <- tGet h + [(Nothing, _, (CorrId corrId, EntityId qId, Right cmd))] <- tGet h pure (Nothing, corrId, qId, cmd) ntfTest :: Transport c => TProxy c -> (THandleNTF c 'TClient -> IO ()) -> Expectation diff --git a/tests/NtfServerTests.hs b/tests/NtfServerTests.hs index e5f096eef..e3349e9a3 100644 --- a/tests/NtfServerTests.hs +++ b/tests/NtfServerTests.hs @@ -17,6 +17,7 @@ import qualified Data.Aeson.Types as JT import Data.Bifunctor (first) import qualified Data.ByteString.Base64.URL as U import Data.ByteString.Char8 (ByteString) +import qualified Data.List.NonEmpty as L import Data.Text.Encoding (encodeUtf8) import NtfClient import SMPClient as SMP @@ -35,7 +36,6 @@ import ServerTests import qualified Simplex.Messaging.Agent.Protocol as AP import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding -import Simplex.Messaging.Encoding.String import Simplex.Messaging.Notifications.Protocol import Simplex.Messaging.Notifications.Server.Push.APNS import qualified Simplex.Messaging.Notifications.Server.Push.APNS as APNS @@ -72,13 +72,13 @@ pattern RespNtf corrId queueId command <- (_, _, (corrId, queueId, Right command deriving instance Eq NtfResponse -sendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandleNTF c 'TClient -> (Maybe TransmissionAuth, ByteString, ByteString, NtfCommand e) -> IO (SignedTransmission ErrorType NtfResponse) +sendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandleNTF c 'TClient -> (Maybe TransmissionAuth, ByteString, NtfEntityId, NtfCommand e) -> IO (SignedTransmission ErrorType NtfResponse) sendRecvNtf h@THandle {params} (sgn, corrId, qId, cmd) = do let TransmissionForAuth {tToSend} = encodeTransmissionForAuth params (CorrId corrId, qId, cmd) Right () <- tPut1 h (sgn, tToSend) tGet1 h -signSendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandleNTF c 'TClient -> C.APrivateAuthKey -> (ByteString, ByteString, NtfCommand e) -> IO (SignedTransmission ErrorType NtfResponse) +signSendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandleNTF c 'TClient -> C.APrivateAuthKey -> (ByteString, NtfEntityId, NtfCommand e) -> IO (SignedTransmission ErrorType NtfResponse) signSendRecvNtf h@THandle {params} (C.APrivateAuthKey a pk) (corrId, qId, cmd) = do let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth params (CorrId corrId, qId, cmd) Right () <- tPut1 h (authorize tForAuth, tToSend) @@ -110,7 +110,7 @@ testNotificationSubscription (ATransport t) = -- create queue (sId, rId, rKey, rcvDhSecret) <- createAndSecureQueue rh sPub -- register and verify token - RespNtf "1" "" (NRTknId tId ntfDh) <- signSendRecvNtf nh tknKey ("1", "", TNEW $ NewNtfTkn tkn tknPub dhPub) + RespNtf "1" NoEntity (NRTknId tId ntfDh) <- signSendRecvNtf nh tknKey ("1", NoEntity, TNEW $ NewNtfTkn tkn tknPub dhPub) APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse = send} <- atomically $ readTBQueue apnsQ send APNSRespOk @@ -126,7 +126,7 @@ testNotificationSubscription (ATransport t) = let srv = SMPServer SMP.testHost SMP.testPort SMP.testKeyHash q = SMPQueueNtf srv nId rcvNtfDhSecret = C.dh' rcvNtfSrvPubDhKey rcvNtfPrivDhKey - RespNtf "4" _ (NRSubId _subId) <- signSendRecvNtf nh tknKey ("4", "", SNEW $ NewNtfSub tId q nKey) + RespNtf "4" _ (NRSubId _subId) <- signSendRecvNtf nh tknKey ("4", NoEntity, SNEW $ NewNtfSub tId q nKey) -- send message threadDelay 50000 Resp "5" _ OK <- signSendRecv sh sKey ("5", sId, _SEND' "hello") @@ -136,8 +136,8 @@ testNotificationSubscription (ATransport t) = Right nonce' = C.cbNonce <$> ntfData' .-> "nonce" Right message = ntfData' .-> "message" Right ntfDataDecrypted = C.cbDecrypt dhSecret nonce' message - Right APNS.PNMessageData {smpQueue = SMPQueueNtf {smpServer, notifierId}, nmsgNonce, encNMsgMeta} = - parse strP (AP.INTERNAL "error parsing PNMessageData") ntfDataDecrypted + Right pnMsgs1 = parse pnMessagesP (AP.INTERNAL "error parsing PNMessageData") ntfDataDecrypted + APNS.PNMessageData {smpQueue = SMPQueueNtf {smpServer, notifierId}, nmsgNonce, encNMsgMeta} = L.last pnMsgs1 Right nMsgMeta = C.cbDecrypt rcvNtfDhSecret nmsgNonce encNMsgMeta Right NMsgMeta {msgId, msgTs} = parse smpP (AP.INTERNAL "error parsing NMsgMeta") nMsgMeta smpServer `shouldBe` srv @@ -169,8 +169,8 @@ testNotificationSubscription (ATransport t) = Right nonce3 = C.cbNonce <$> ntfData3 .-> "nonce" Right message3 = ntfData3 .-> "message" Right ntfDataDecrypted3 = C.cbDecrypt dhSecret nonce3 message3 - Right APNS.PNMessageData {smpQueue = SMPQueueNtf {smpServer = smpServer3, notifierId = notifierId3}} = - parse strP (AP.INTERNAL "error parsing PNMessageData") ntfDataDecrypted3 + Right pnMsgs2 = parse pnMessagesP (AP.INTERNAL "error parsing PNMessageData") ntfDataDecrypted3 + APNS.PNMessageData {smpQueue = SMPQueueNtf {smpServer = smpServer3, notifierId = notifierId3}} = L.last pnMsgs2 smpServer3 `shouldBe` srv notifierId3 `shouldBe` nId send3 APNSRespOk diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index 736016b3b..472f9b6b4 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -115,6 +115,7 @@ cfg = logStatsStartTime = 0, serverStatsLogFile = "tests/smp-server-stats.daily.log", serverStatsBackupFile = Nothing, + pendingENDInterval = 500000, caCertificateFile = "tests/fixtures/ca.crt", privateKeyFile = "tests/fixtures/server.key", certificateFile = "tests/fixtures/server.crt", @@ -218,7 +219,7 @@ smpServerTest _ t = runSmpTest $ \h -> tPut' h t >> tGet' h [Right ()] <- tPut h [Right (sig, t')] pure () tGet' h = do - [(Nothing, _, (CorrId corrId, qId, Right cmd))] <- tGet h + [(Nothing, _, (CorrId corrId, EntityId qId, Right cmd))] <- tGet h pure (Nothing, corrId, qId, cmd) smpTest :: (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandleSMP c 'TClient -> IO ()) -> Expectation diff --git a/tests/SMPProxyTests.hs b/tests/SMPProxyTests.hs index 8044d23f7..32aa992d3 100644 --- a/tests/SMPProxyTests.hs +++ b/tests/SMPProxyTests.hs @@ -34,7 +34,7 @@ import Simplex.Messaging.Client import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.Ratchet (pattern PQSupportOn) import qualified Simplex.Messaging.Crypto.Ratchet as CR -import Simplex.Messaging.Protocol (EncRcvMsgBody (..), MsgBody, RcvMessage (..), SubscriptionMode (..), maxMessageLength, noMsgFlags) +import Simplex.Messaging.Protocol (EncRcvMsgBody (..), MsgBody, RcvMessage (..), SubscriptionMode (..), pattern NoEntity, maxMessageLength, noMsgFlags) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Server.Env.STM (ServerConfig (..)) import Simplex.Messaging.Transport @@ -408,14 +408,14 @@ testNoProxy :: IO () testNoProxy = do withSmpServerConfigOn (transport @TLS) cfg testPort2 $ \_ -> do testSMPClient_ "127.0.0.1" testPort2 proxyVRangeV8 $ \(th :: THandleSMP TLS 'TClient) -> do - (_, _, (_corrId, _entityId, reply)) <- sendRecv th (Nothing, "0", "", SMP.PRXY testSMPServer Nothing) + (_, _, (_corrId, _entityId, reply)) <- sendRecv th (Nothing, "0", NoEntity, SMP.PRXY testSMPServer Nothing) reply `shouldBe` Right (SMP.ERR $ SMP.PROXY SMP.BASIC_AUTH) testProxyAuth :: IO () testProxyAuth = do withSmpServerConfigOn (transport @TLS) proxyCfgAuth testPort $ \_ -> do testSMPClient_ "127.0.0.1" testPort proxyVRangeV8 $ \(th :: THandleSMP TLS 'TClient) -> do - (_, _s, (_corrId, _entityId, reply)) <- sendRecv th (Nothing, "0", "", SMP.PRXY testSMPServer2 $ Just "wrong") + (_, _s, (_corrId, _entityId, reply)) <- sendRecv th (Nothing, "0", NoEntity, SMP.PRXY testSMPServer2 $ Just "wrong") reply `shouldBe` Right (SMP.ERR $ SMP.PROXY SMP.BASIC_AUTH) where proxyCfgAuth = proxyCfg {newQueueBasicAuth = Just "correct"} diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index 60aa1dd1c..0a1729ab8 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -25,7 +25,8 @@ import Data.Bifunctor (first) import Data.ByteString.Base64 import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B -import qualified Data.Set as S +import Data.Hashable (hash) +import qualified Data.IntSet as IS import Data.Type.Equality import GHC.Stack (withFrozenCallStack) import SMPClient @@ -78,13 +79,13 @@ pattern Ids rId sId srvDh <- IDS (QIK rId sId srvDh _sndSecure) pattern Msg :: MsgId -> MsgBody -> BrokerMsg pattern Msg msgId body <- MSG RcvMessage {msgId, msgBody = EncRcvMsgBody body} -sendRecv :: forall c p. (Transport c, PartyI p) => THandleSMP c 'TClient -> (Maybe TransmissionAuth, ByteString, ByteString, Command p) -> IO (SignedTransmission ErrorType BrokerMsg) +sendRecv :: forall c p. (Transport c, PartyI p) => THandleSMP c 'TClient -> (Maybe TransmissionAuth, ByteString, EntityId, Command p) -> IO (SignedTransmission ErrorType BrokerMsg) sendRecv h@THandle {params} (sgn, corrId, qId, cmd) = do let TransmissionForAuth {tToSend} = encodeTransmissionForAuth params (CorrId corrId, qId, cmd) Right () <- tPut1 h (sgn, tToSend) tGet1 h -signSendRecv :: forall c p. (Transport c, PartyI p) => THandleSMP c 'TClient -> C.APrivateAuthKey -> (ByteString, ByteString, Command p) -> IO (SignedTransmission ErrorType BrokerMsg) +signSendRecv :: forall c p. (Transport c, PartyI p) => THandleSMP c 'TClient -> C.APrivateAuthKey -> (ByteString, EntityId, Command p) -> IO (SignedTransmission ErrorType BrokerMsg) signSendRecv h@THandle {params} (C.APrivateAuthKey a pk) (corrId, qId, cmd) = do let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth params (CorrId corrId, qId, cmd) Right () <- tPut1 h (authorize tForAuth, tToSend) @@ -134,9 +135,9 @@ testCreateSecure (ATransport t) = g <- C.newRandom (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g - Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv r rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe False) + Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv r rKey ("abcd", NoEntity, NEW rPub dhPub Nothing SMSubscribe False) let dec = decryptMsgV3 $ C.dh' srvDh dhPriv - (rId1, "") #== "creates queue" + (rId1, NoEntity) #== "creates queue" Resp "bcda" sId1 ok1 <- sendRecv s ("", "bcda", sId, _SEND "hello") (ok1, OK) #== "accepts unsigned SEND" @@ -199,9 +200,9 @@ testCreateDelete (ATransport t) = g <- C.newRandom (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g - Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe False) + Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", NoEntity, NEW rPub dhPub Nothing SMSubscribe False) let dec = decryptMsgV3 $ C.dh' srvDh dhPriv - (rId1, "") #== "creates queue" + (rId1, NoEntity) #== "creates queue" (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g Resp "bcda" _ ok1 <- signSendRecv rh rKey ("bcda", rId, KEY sPub) @@ -271,7 +272,7 @@ stressTest (ATransport t) = (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (dhPub, _ :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g rIds <- forM ([1 .. 50] :: [Int]) . const $ do - Resp "" "" (Ids rId _ _) <- signSendRecv h1 rKey ("", "", NEW rPub dhPub Nothing SMSubscribe False) + Resp "" NoEntity (Ids rId _ _) <- signSendRecv h1 rKey ("", NoEntity, NEW rPub dhPub Nothing SMSubscribe False) pure rId let subscribeQueues h = forM_ rIds $ \rId -> do Resp "" rId' OK <- signSendRecv h rKey ("", rId, SUB) @@ -289,7 +290,7 @@ testAllowNewQueues t = g <- C.newRandom (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g (dhPub, _ :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g - Resp "abcd" "" (ERR AUTH) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe False) + Resp "abcd" NoEntity (ERR AUTH) <- signSendRecv h rKey ("abcd", NoEntity, NEW rPub dhPub Nothing SMSubscribe False) pure () testDuplex :: ATransport -> Spec @@ -299,7 +300,7 @@ testDuplex (ATransport t) = g <- C.newRandom (arPub, arKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g (aDhPub, aDhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g - Resp "abcd" _ (Ids aRcv aSnd aSrvDh) <- signSendRecv alice arKey ("abcd", "", NEW arPub aDhPub Nothing SMSubscribe False) + Resp "abcd" _ (Ids aRcv aSnd aSrvDh) <- signSendRecv alice arKey ("abcd", NoEntity, NEW arPub aDhPub Nothing SMSubscribe False) let aDec = decryptMsgV3 $ C.dh' aSrvDh aDhPriv -- aSnd ID is passed to Bob out-of-band @@ -315,15 +316,15 @@ testDuplex (ATransport t) = (brPub, brKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g (bDhPub, bDhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g - Resp "abcd" _ (Ids bRcv bSnd bSrvDh) <- signSendRecv bob brKey ("abcd", "", NEW brPub bDhPub Nothing SMSubscribe False) + Resp "abcd" _ (Ids bRcv bSnd bSrvDh) <- signSendRecv bob brKey ("abcd", NoEntity, NEW brPub bDhPub Nothing SMSubscribe False) let bDec = decryptMsgV3 $ C.dh' bSrvDh bDhPriv - Resp "bcda" _ OK <- signSendRecv bob bsKey ("bcda", aSnd, _SEND $ "reply_id " <> encode bSnd) + Resp "bcda" _ OK <- signSendRecv bob bsKey ("bcda", aSnd, _SEND $ "reply_id " <> encode (unEntityId bSnd)) -- "reply_id ..." is ad-hoc, not a part of SMP protocol Resp "" _ (Msg mId2 msg2) <- tGet1 alice Resp "cdab" _ OK <- signSendRecv alice arKey ("cdab", aRcv, ACK mId2) Right ["reply_id", bId] <- pure $ B.words <$> aDec mId2 msg2 - (bId, encode bSnd) #== "reply queue ID received from Bob" + (bId, encode (unEntityId bSnd)) #== "reply queue ID received from Bob" (asPub, asKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g Resp "dabc" _ OK <- sendRecv alice ("", "dabc", bSnd, _SEND $ "key " <> strEncode asPub) @@ -354,7 +355,7 @@ testSwitchSub (ATransport t) = g <- C.newRandom (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g - Resp "abcd" _ (Ids rId sId srvDh) <- signSendRecv rh1 rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe False) + Resp "abcd" _ (Ids rId sId srvDh) <- signSendRecv rh1 rKey ("abcd", NoEntity, NEW rPub dhPub Nothing SMSubscribe False) let dec = decryptMsgV3 $ C.dh' srvDh dhPriv Resp "bcda" _ ok1 <- sendRecv sh ("", "bcda", sId, _SEND "test1") (ok1, OK) #== "sent test message 1" @@ -384,6 +385,10 @@ testSwitchSub (ATransport t) = Resp "bcda" _ ok3 <- signSendRecv rh2 rKey ("bcda", rId, ACK mId3) (ok3, OK) #== "accepts ACK from the 2nd TCP connection" + Resp "cdab" _ OK <- signSendRecv rh1 rKey ("cdab", rId, DEL) + Resp "" rId' DELD <- tGet1 rh2 + (rId', rId) #== "connection deleted event delivered to subscribed client" + 1000 `timeout` tGet @SMPVersion @ErrorType @BrokerMsg rh1 >>= \case Nothing -> return () Just _ -> error "nothing else is delivered to the 1st TCP connection" @@ -491,12 +496,12 @@ testWithStoreLog at@(ATransport t) = (sPub1, sKey1) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (sPub2, sKey2) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (nPub, nKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g - recipientId1 <- newTVarIO "" + recipientId1 <- newTVarIO NoEntity recipientKey1 <- newTVarIO Nothing dhShared1 <- newTVarIO Nothing - senderId1 <- newTVarIO "" - senderId2 <- newTVarIO "" - notifierId <- newTVarIO "" + senderId1 <- newTVarIO NoEntity + senderId2 <- newTVarIO NoEntity + notifierId <- newTVarIO NoEntity withSmpServerStoreLogOn at testPort . runTest t $ \h -> runClient t $ \h1 -> do (sId1, rId1, rKey1, dhShared) <- createAndSecureQueue h sPub1 @@ -580,10 +585,10 @@ testRestoreMessages at@(ATransport t) = g <- C.newRandom (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g - recipientId <- newTVarIO "" + recipientId <- newTVarIO NoEntity recipientKey <- newTVarIO Nothing dhShared <- newTVarIO Nothing - senderId <- newTVarIO "" + senderId <- newTVarIO NoEntity withSmpServerStoreMsgLogOn at testPort . runTest t $ \h -> do runClient t $ \h1 -> do @@ -610,7 +615,7 @@ testRestoreMessages at@(ATransport t) = logSize testStoreLogFile `shouldReturn` 2 logSize testStoreMsgsFile `shouldReturn` 5 - logSize testServerStatsBackupFile `shouldReturn` 71 + logSize testServerStatsBackupFile `shouldReturn` 72 Right stats1 <- strDecode <$> B.readFile testServerStatsBackupFile checkStats stats1 [rId] 5 1 @@ -628,7 +633,7 @@ testRestoreMessages at@(ATransport t) = logSize testStoreLogFile `shouldReturn` 1 -- the last message is not removed because it was not ACK'd logSize testStoreMsgsFile `shouldReturn` 3 - logSize testServerStatsBackupFile `shouldReturn` 71 + logSize testServerStatsBackupFile `shouldReturn` 72 Right stats2 <- strDecode <$> B.readFile testServerStatsBackupFile checkStats stats2 [rId] 5 3 @@ -647,7 +652,7 @@ testRestoreMessages at@(ATransport t) = logSize testStoreLogFile `shouldReturn` 1 logSize testStoreMsgsFile `shouldReturn` 0 - logSize testServerStatsBackupFile `shouldReturn` 71 + logSize testServerStatsBackupFile `shouldReturn` 72 Right stats3 <- strDecode <$> B.readFile testServerStatsBackupFile checkStats stats3 [rId] 5 5 @@ -675,19 +680,19 @@ checkStats s qs sent received = do _msgSentNtf s `shouldBe` 0 _msgRecvNtf s `shouldBe` 0 let PeriodStatsData {_day, _week, _month} = _activeQueues s - S.toList _day `shouldBe` qs - S.toList _week `shouldBe` qs - S.toList _month `shouldBe` qs + IS.toList _day `shouldBe` map (hash . unEntityId) qs + IS.toList _week `shouldBe` map (hash . unEntityId) qs + IS.toList _month `shouldBe` map (hash . unEntityId) qs testRestoreExpireMessages :: ATransport -> Spec testRestoreExpireMessages at@(ATransport t) = it "should store messages on exit and restore on start" $ do g <- C.newRandom (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g - recipientId <- newTVarIO "" + recipientId <- newTVarIO NoEntity recipientKey <- newTVarIO Nothing dhShared <- newTVarIO Nothing - senderId <- newTVarIO "" + senderId <- newTVarIO NoEntity withSmpServerStoreMsgLogOn at testPort . runTest t $ \h -> do runClient t $ \h1 -> do @@ -742,7 +747,7 @@ createAndSecureQueue h sPub = do g <- C.newRandom (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g - Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe False) + Resp "abcd" NoEntity (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", NoEntity, NEW rPub dhPub Nothing SMSubscribe False) let dhShared = C.dh' srvDh dhPriv Resp "dabc" rId' OK <- signSendRecv h rKey ("dabc", rId, KEY sPub) (rId', rId) #== "same queue ID" @@ -771,13 +776,13 @@ testTiming (ATransport t) = (C.AuthAlg C.SX25519, C.AuthAlg C.SX25519, 200) -- correct key type ] timeRepeat n = fmap fst . timeItT . forM_ (replicate n ()) . const - similarTime t1 t2 = abs (t2 / t1 - 1) < 0.2 -- normally the difference between "no queue" and "wrong key" is less than 5% + similarTime t1 t2 = abs (t2 / t1 - 1) < 0.25 -- normally the difference between "no queue" and "wrong key" is less than 5% testSameTiming :: forall c. Transport c => THandleSMP c 'TClient -> THandleSMP c 'TClient -> (C.AuthAlg, C.AuthAlg, Int) -> Expectation testSameTiming rh sh (C.AuthAlg goodKeyAlg, C.AuthAlg badKeyAlg, n) = do g <- C.newRandom (rPub, rKey) <- atomically $ C.generateAuthKeyPair goodKeyAlg g (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g - Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe False) + Resp "abcd" NoEntity (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", NoEntity, NEW rPub dhPub Nothing SMSubscribe False) let dec = decryptMsgV3 $ C.dh' srvDh dhPriv Resp "cdab" _ OK <- signSendRecv rh rKey ("cdab", rId, SUB) @@ -793,12 +798,12 @@ testTiming (ATransport t) = runTimingTest sh badKey sId $ _SEND "hello" where - runTimingTest :: PartyI p => THandleSMP c 'TClient -> C.APrivateAuthKey -> ByteString -> Command p -> IO () + runTimingTest :: PartyI p => THandleSMP c 'TClient -> C.APrivateAuthKey -> EntityId -> Command p -> IO () runTimingTest h badKey qId cmd = do threadDelay 100000 _ <- timeRepeat n $ do -- "warm up" the server - Resp "dabc" _ (ERR AUTH) <- signSendRecv h badKey ("dabc", "1234", cmd) + Resp "dabc" _ (ERR AUTH) <- signSendRecv h badKey ("dabc", EntityId "1234", cmd) return () threadDelay 100000 timeWrongKey <- timeRepeat n $ do @@ -806,7 +811,7 @@ testTiming (ATransport t) = return () threadDelay 100000 timeNoQueue <- timeRepeat n $ do - Resp "dabc" _ (ERR AUTH) <- signSendRecv h badKey ("dabc", "1234", cmd) + Resp "dabc" _ (ERR AUTH) <- signSendRecv h badKey ("dabc", EntityId "1234", cmd) return () let ok = similarTime timeNoQueue timeWrongKey unless ok . putStrLn . unwords $ @@ -838,7 +843,8 @@ testMessageNotifications (ATransport t) = Resp "3a" _ OK <- signSendRecv rh rKey ("3a", rId, ACK mId1) Resp "" _ (NMSG _ _) <- tGet1 nh1 Resp "4" _ OK <- signSendRecv nh2 nKey ("4", nId, NSUB) - Resp "" _ END <- tGet1 nh1 + Resp "" nId2 END <- tGet1 nh1 + nId2 `shouldBe` nId Resp "5" _ OK <- signSendRecv sh sKey ("5", sId, _SEND' "hello again") Resp "" _ (Msg mId2 msg2) <- tGet1 rh Resp "5a" _ OK <- signSendRecv rh rKey ("5a", rId, ACK mId2) @@ -848,6 +854,8 @@ testMessageNotifications (ATransport t) = Nothing -> pure () Just _ -> error "nothing else should be delivered to the 1st notifier's TCP connection" Resp "6" _ OK <- signSendRecv rh rKey ("6", rId, NDEL) + Resp "" nId3 DELD <- tGet1 nh2 + nId3 `shouldBe` nId Resp "7" _ OK <- signSendRecv sh sKey ("7", sId, _SEND' "hello there") Resp "" _ (Msg mId3 msg3) <- tGet1 rh (dec mId3 msg3, Right "hello there") #== "delivered from queue again" diff --git a/tests/XFTPAgent.hs b/tests/XFTPAgent.hs index 8de86eff1..9803cb8b9 100644 --- a/tests/XFTPAgent.hs +++ b/tests/XFTPAgent.hs @@ -429,7 +429,7 @@ testXFTPAgentSendRestore = withGlobalLogging logCfgNoLogs $ do ("", sfId', SFPROG _ _) <- sfGet sndr' liftIO $ sfId' `shouldBe` sfId - threadDelay 100000 + threadDelay 200000 withXFTPServerStoreLogOn $ \_ -> do -- send file - should continue uploading with server up @@ -443,7 +443,7 @@ testXFTPAgentSendRestore = withGlobalLogging logCfgNoLogs $ do pure rfd1 -- prefix path should be removed after sending file - threadDelay 100000 + threadDelay 200000 doesDirectoryExist prefixPath `shouldReturn` False doesFileExist encPath `shouldReturn` False diff --git a/tests/XFTPServerTests.hs b/tests/XFTPServerTests.hs index 19713d8b1..9b74cf888 100644 --- a/tests/XFTPServerTests.hs +++ b/tests/XFTPServerTests.hs @@ -2,6 +2,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} module XFTPServerTests where @@ -20,13 +21,13 @@ import Data.List (isInfixOf) import ServerTests (logSize) import Simplex.FileTransfer.Client import Simplex.FileTransfer.Description (kb) -import Simplex.FileTransfer.Protocol (FileInfo (..)) +import Simplex.FileTransfer.Protocol (FileInfo (..), XFTPFileId) import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..)) import Simplex.FileTransfer.Transport (XFTPErrorType (..), XFTPRcvChunkSpec (..)) import Simplex.Messaging.Client (ProtocolClientError (..)) import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto.Lazy as LC -import Simplex.Messaging.Protocol (BasicAuth, SenderId) +import Simplex.Messaging.Protocol (BasicAuth, EntityId (..), pattern NoEntity) import Simplex.Messaging.Server.Expiration (ExpirationConfig (..)) import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive, removeFile) import System.FilePath (()) @@ -74,8 +75,8 @@ createTestChunk fp = do B.writeFile fp bytes pure bytes -readChunk :: SenderId -> IO ByteString -readChunk sId = B.readFile (xftpServerFiles B.unpack (B64.encode sId)) +readChunk :: XFTPFileId -> IO ByteString +readChunk sId = B.readFile (xftpServerFiles B.unpack (B64.encode $ unEntityId sId)) testFileChunkDelivery :: Expectation testFileChunkDelivery = xftpTest $ \c -> runRight_ $ runTestFileChunkDelivery c c @@ -267,9 +268,9 @@ testFileLog = do (rcvKey1, rpKey1) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (rcvKey2, rpKey2) <- atomically $ C.generateAuthKeyPair C.SEd25519 g digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath - sIdVar <- newTVarIO "" - rIdVar1 <- newTVarIO "" - rIdVar2 <- newTVarIO "" + sIdVar <- newTVarIO NoEntity + rIdVar1 <- newTVarIO NoEntity + rIdVar2 <- newTVarIO NoEntity threadDelay 100000