diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 9f5c24a9fd..2ae1bfdb56 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -726,7 +726,10 @@ restoreServerMessages = asks (storeMsgsFile . config) >>= mapM_ restoreMessages full <- atomically $ do q <- getMsgQueue ms rId quota isNothing <$> writeMsg q msg - when full . logError . decodeLatin1 $ "message queue " <> strEncode rId <> " is full, message not restored: " <> strEncode (msgId (msg :: Message)) + case msg of + Message {} -> + when full . logError . decodeLatin1 $ "message queue " <> strEncode rId <> " is full, message not restored: " <> strEncode (msgId (msg :: Message)) + MessageQuota {} -> pure () updateMsgV1toV3 QueueRec {rcvDhSecret} RcvMessage {msgId, msgTs, msgFlags, msgBody = EncRcvMsgBody body} = do let nonce = C.cbNonce msgId msgBody <- liftEither . first (msgErr "v1 message decryption") $ C.maxLenBS =<< C.cbDecrypt rcvDhSecret nonce body diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index cf32087755..66315336a2 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -52,7 +52,7 @@ serverTests t@(ATransport t') = do describe "Exceeding queue quota" $ testExceedQueueQuota t' describe "Store log" $ testWithStoreLog t describe "Restore messages" $ testRestoreMessages t - describe "Restore messages (v2)" $ testRestoreMessagesV2 t + describe "Restore messages (old / v2)" $ testRestoreMessagesV2 t describe "Timing of AUTH error" $ testTiming t describe "Message notifications" $ testMessageNotifications t describe "Message expiration" $ do @@ -628,10 +628,12 @@ testRestoreMessages at@(ATransport t) = Resp "2" _ OK <- signSendRecv h sKey ("2", sId, _SEND "hello 2") Resp "3" _ OK <- signSendRecv h sKey ("3", sId, _SEND "hello 3") Resp "4" _ OK <- signSendRecv h sKey ("4", sId, _SEND "hello 4") + Resp "5" _ OK <- signSendRecv h sKey ("5", sId, _SEND "hello 5") + Resp "6" _ (ERR QUOTA) <- signSendRecv h sKey ("6", sId, _SEND "hello 6") pure () logSize testStoreLogFile `shouldReturn` 2 - logSize testStoreMsgsFile `shouldReturn` 3 + logSize testStoreMsgsFile `shouldReturn` 5 withSmpServerStoreMsgLogOn at testPort . runTest t $ \h -> do rId <- readTVarIO recipientId @@ -647,15 +649,21 @@ testRestoreMessages at@(ATransport t) = logSize testStoreLogFile `shouldReturn` 1 -- the last message is not removed because it was not ACK'd - logSize testStoreMsgsFile `shouldReturn` 1 + logSize testStoreMsgsFile `shouldReturn` 3 withSmpServerStoreMsgLogOn at testPort . runTest t $ \h -> do rId <- readTVarIO recipientId Just rKey <- readTVarIO recipientKey Just dh <- readTVarIO dhShared + let dec = decryptMsgV3 dh Resp "4" _ (Msg mId4 msg4) <- signSendRecv h rKey ("4", rId, SUB) - Resp "5" _ OK <- signSendRecv h rKey ("5", rId, ACK mId4) - (decryptMsgV3 dh mId4 msg4, Right "hello 4") #== "restored message delivered" + (dec mId4 msg4, Right "hello 4") #== "restored message delivered" + Resp "5" _ (Msg mId5 msg5) <- signSendRecv h rKey ("5", rId, ACK mId4) + (dec mId5 msg5, Right "hello 5") #== "restored message delivered" + Resp "6" _ (Msg mId6 msg6) <- signSendRecv h rKey ("6", rId, ACK mId5) + (dec mId6 msg6, Left "ClientRcvMsgQuota") #== "restored message delivered" + Resp "7" _ OK <- signSendRecv h rKey ("7", rId, ACK mId6) + pure () logSize testStoreLogFile `shouldReturn` 1 logSize testStoreMsgsFile `shouldReturn` 0 diff --git a/tests/Test.hs b/tests/Test.hs index d074d9c866..c710a58df8 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -1,8 +1,8 @@ {-# LANGUAGE TypeApplications #-} import AgentTests (agentTests) --- import Control.Logger.Simple import CLITests +import Control.Logger.Simple import CoreTests.CryptoTests import CoreTests.EncodingTests import CoreTests.ProtocolErrorTests @@ -16,26 +16,26 @@ import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive) import System.Environment (setEnv) import Test.Hspec --- logCfg :: LogConfig --- logCfg = LogConfig {lc_file = Nothing, lc_stderr = True} +logCfg :: LogConfig +logCfg = LogConfig {lc_file = Nothing, lc_stderr = True} main :: IO () main = do - -- setLogLevel LogInfo -- LogError - -- withGlobalLogging logCfg $ do - createDirectoryIfMissing False "tests/tmp" - setEnv "APNS_KEY_ID" "H82WD9K9AQ" - setEnv "APNS_KEY_FILE" "./tests/fixtures/AuthKey_H82WD9K9AQ.p8" - hspec $ do - describe "Core tests" $ do - describe "Encoding tests" encodingTests - describe "Protocol error tests" protocolErrorTests - describe "Version range" versionRangeTests - describe "Encryption tests" cryptoTests - describe "Retry interval tests" retryIntervalTests - describe "SMP server via TLS" $ serverTests (transport @TLS) - describe "SMP server via WebSockets" $ serverTests (transport @WS) - describe "Notifications server" $ ntfServerTests (transport @TLS) - describe "SMP client agent" $ agentTests (transport @TLS) - describe "Server CLIs" cliTests - removeDirectoryRecursive "tests/tmp" + setLogLevel LogError -- LogInfo + withGlobalLogging logCfg $ do + createDirectoryIfMissing False "tests/tmp" + setEnv "APNS_KEY_ID" "H82WD9K9AQ" + setEnv "APNS_KEY_FILE" "./tests/fixtures/AuthKey_H82WD9K9AQ.p8" + hspec $ do + describe "Core tests" $ do + describe "Encoding tests" encodingTests + describe "Protocol error tests" protocolErrorTests + describe "Version range" versionRangeTests + describe "Encryption tests" cryptoTests + describe "Retry interval tests" retryIntervalTests + describe "SMP server via TLS" $ serverTests (transport @TLS) + describe "SMP server via WebSockets" $ serverTests (transport @WS) + describe "Notifications server" $ ntfServerTests (transport @TLS) + describe "SMP client agent" $ agentTests (transport @TLS) + describe "Server CLIs" cliTests + removeDirectoryRecursive "tests/tmp"