message TTL and periodic expiration; setting to prevent creation of the new queues (#355)

* message TTL and periodic expiration; setting to prevent creation of the new queues

* fix expiration interval

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

@@ -9,6 +9,7 @@ import Control.Concurrent (ThreadId)
 import Control.Monad.IO.Unlift
 import Crypto.Random
 import Data.ByteString.Char8 (ByteString)
+import Data.Int (Int64)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
 import Data.X509.Validation (Fingerprint (..))
@@ -36,6 +37,12 @@ data ServerConfig = ServerConfig
     queueIdBytes :: Int,
     msgIdBytes :: Int,
     storeLog :: Maybe (StoreLog 'ReadMode),
+    -- | set to False to prohibit creating new queues
+    allowNewQueues :: Bool,
+    -- | time after which the messages can be removed from the queues, seconds
+    messageTTL :: Maybe Int64,
+    -- | interval to periodically remove expired messages (when no messages are sent to the queue), microseconds
+    expireMessagesInterval :: Maybe Int,
     -- CA certificate private key is not needed for initialization
     caCertificateFile :: FilePath,
     privateKeyFile :: FilePath,

src/Simplex/Messaging/Server/MsgStore.hs

@@ -2,6 +2,7 @@
 
 module Simplex.Messaging.Server.MsgStore where
 
+import Data.Int (Int64)
 import Data.Time.Clock.System (SystemTime)
 import Numeric.Natural
 import Simplex.Messaging.Protocol (MsgBody, MsgId, RecipientId)
@@ -22,3 +23,4 @@ class MonadMsgQueue q m where
   tryPeekMsg :: q -> m (Maybe Message) -- non blocking
   peekMsg :: q -> m Message -- blocking
   tryDelPeekMsg :: q -> m (Maybe Message) -- atomic delete (== read) last and peek next message, if available
+  deleteExpiredMsgs :: q -> Int64 -> m ()

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

@@ -3,9 +3,13 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns #-}
 
 module Simplex.Messaging.Server.MsgStore.STM where
 
+import Control.Monad (when)
+import Data.Int (Int64)
+import Data.Time.Clock.System (SystemTime (systemSeconds))
 import Numeric.Natural
 import Simplex.Messaging.Protocol (RecipientId)
 import Simplex.Messaging.Server.MsgStore
@@ -48,3 +52,11 @@ instance MonadMsgQueue MsgQueue STM where
   -- atomic delete (== read) last and peek next message if available
   tryDelPeekMsg :: MsgQueue -> STM (Maybe Message)
   tryDelPeekMsg (MsgQueue q) = tryReadTBQueue q >> tryPeekTBQueue q
+
+  deleteExpiredMsgs :: MsgQueue -> Int64 -> STM ()
+  deleteExpiredMsgs (MsgQueue q) old = loop
+    where
+      loop = tryPeekTBQueue q >>= mapM_ delOldMsg
+      delOldMsg Message {ts} =
+        when (systemSeconds ts < old) $
+          tryReadTBQueue q >> loop