smp server: option to expire messages when new message is sent (now off by default) (#1625)

* smp server: option to expire messages when new message is sent (now off by default)

* fix test

Author: epoberezkin

src/Simplex/Messaging/Protocol.hs

@@ -2022,7 +2022,7 @@ instance Encoding BrokerErrorType where
     RESPONSE e -> "RESPONSE " <> smpEncode e
     UNEXPECTED e -> "UNEXPECTED " <> smpEncode e
     TRANSPORT e -> "TRANSPORT " <> smpEncode e
-    NETWORK e -> "NETWORK" -- TODO once all upgrade: "NETWORK " <> smpEncode e
+    NETWORK _e -> "NETWORK" -- TODO once all upgrade: "NETWORK " <> smpEncode e
     TIMEOUT -> "TIMEOUT"
     HOST -> "HOST"
     NO_SERVICE -> "NO_SERVICE"
@@ -2042,7 +2042,7 @@ instance StrEncoding BrokerErrorType where
     RESPONSE e -> "RESPONSE " <> encodeUtf8 (T.pack e)
     UNEXPECTED e -> "UNEXPECTED " <> encodeUtf8 (T.pack e)
     TRANSPORT e -> "TRANSPORT " <> smpEncode e
-    NETWORK e -> "NETWORK" -- TODO once all upgrade: "NETWORK " <> strEncode e
+    NETWORK _e -> "NETWORK" -- TODO once all upgrade: "NETWORK " <> strEncode e
     TIMEOUT -> "TIMEOUT"
     HOST -> "HOST"
     NO_SERVICE -> "NO_SERVICE"

src/Simplex/Messaging/Server.hs

@@ -1848,10 +1848,10 @@ client
                     Right body -> do
                       when (isJust (queueData qr) && isSecuredMsgQueue qr) $ void $ liftIO $
                         deleteQueueLinkData (queueStore ms) q
-                      ServerConfig {messageExpiration, msgIdBytes} <- asks config
+                      ServerConfig {messageExpiration, expireMessagesOnSend, msgIdBytes} <- asks config
                       msgId <- randomId' msgIdBytes
                       msg_ <- liftIO $ runExceptT $ do
-                        expireMessages messageExpiration stats
+                        when expireMessagesOnSend $ mapM_ (expireMessages stats) messageExpiration
                         msg <- liftIO $ mkMessage msgId body
                         writeMsg ms q True msg
                       case msg_ of
@@ -1875,9 +1875,9 @@ client
               msgTs <- getSystemTime
               pure $! Message msgId msgTs msgFlags body
 
-            expireMessages :: Maybe ExpirationConfig -> ServerStats -> ExceptT ErrorType IO ()
-            expireMessages msgExp stats = do
-              deleted <- maybe (pure 0) (deleteExpiredMsgs ms q <=< liftIO . expireBeforeEpoch) msgExp
+            expireMessages :: ServerStats -> ExpirationConfig -> ExceptT ErrorType IO ()
+            expireMessages stats msgExp = do
+              deleted <- deleteExpiredMsgs ms q =<< liftIO (expireBeforeEpoch msgExp)
               liftIO $ when (deleted > 0) $ atomicModifyIORef'_ (msgExpired stats) (+ deleted)
 
             -- The condition for delivery of the message is:

src/Simplex/Messaging/Server/Env/STM.hs

@@ -153,6 +153,7 @@ data ServerConfig s = ServerConfig
     -- | time after which the messages can be removed from the queues and check interval, seconds
     messageExpiration :: Maybe ExpirationConfig,
     expireMessagesOnStart :: Bool,
+    expireMessagesOnSend :: Bool,
     -- | interval of inactivity after which journal queue is closed
     idleQueueInterval :: Int64,
     -- | notification expiration interval (seconds)

src/Simplex/Messaging/Server/Main.hs

@@ -428,6 +428,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
                     { ttl = 86400 * readIniDefault defMsgExpirationDays "STORE_LOG" "expire_messages_days" ini
                     },
               expireMessagesOnStart = fromMaybe True $ iniOnOff "STORE_LOG" "expire_messages_on_start" ini,
+              expireMessagesOnSend = fromMaybe True $ iniOnOff "STORE_LOG" "expire_messages_on_send" ini,
               idleQueueInterval = defaultIdleQueueInterval,
               notificationExpiration =
                 defaultNtfExpiration

src/Simplex/Messaging/Server/Main/Init.hs

@@ -87,7 +87,8 @@ iniFileContent cfgPath logPath opts host basicAuth controlPortPwds =
     <> ("restore_messages: " <> onOff enableStoreLog <> "\n\n")
     <> "# Messages and notifications expiration periods.\n"
     <> ("expire_messages_days: " <> tshow defMsgExpirationDays <> "\n")
-    <> "expire_messages_on_start: on\n"
+    <> "expire_messages_on_start: on\n\
+        \expire_messages_on_send: off\n"
     <> ("expire_ntfs_hours: " <> tshow defNtfExpirationHours <> "\n\n")
     <> "# Log daily server statistics to CSV file\n"
     <> ("log_stats: " <> onOff logStats <> "\n\n")

tests/SMPClient.hs

@@ -229,6 +229,7 @@ cfgMS msType = withStoreCfg (testServerStoreConfig msType) $ \serverStoreCfg ->
       dailyBlockQueueQuota = 20,
       messageExpiration = Just defaultMessageExpiration,
       expireMessagesOnStart = True,
+      expireMessagesOnSend = False,
       idleQueueInterval = defaultIdleQueueInterval,
       notificationExpiration = defaultNtfExpiration,
       inactiveClientExpiration = Just defaultInactiveClientExpiration,

tests/ServerTests.hs

@@ -1205,7 +1205,7 @@ testMsgExpireOnSend =
   it "should expire messages that are not received before messageTTL on SEND" $ \(ATransport (t :: TProxy c 'TServer), msType) -> do
     g <- C.newRandom
     (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
-    let cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 10000}}
+    let cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {expireMessagesOnSend = True, messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 10000}}
     withSmpServerConfigOn (ATransport t) cfg' testPort $ \_ ->
       testSMPClient @c $ \sh -> do
         (sId, rId, rKey, dhShared) <- testSMPClient @c $ \rh -> createAndSecureQueue rh sPub