smp server: merge quota messages and set queue to "over quota" state after restoring, server tests with journal and memory store (#1380)

* smp: run server tests with journal and memory store

* merge quota messages, set queue to "over quota" state after restoring

* fix test

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

@@ -28,7 +28,7 @@ module Simplex.Messaging.Server.MsgStore.Journal
     readWriteQueueState,
     newMsgQueueState,
     newJournalId,
-    logQueueState,
+    appendState,
     queueLogFileName,
     logFileExt,
   )
@@ -255,11 +255,12 @@ instance MsgStoreClass JournalMsgStore where
               (Nothing <$ putStrLn ("Error: path " <> path' <> " is not a directory, skipping"))
 
   logQueueStates :: JournalMsgStore -> IO ()
-  logQueueStates st = withActiveMsgQueues st (\_ q _ -> logState q) ()
-    where
-      logState q =
-        readTVarIO (handles q)
-          >>= maybe (pure ()) (\hs -> readTVarIO (state q) >>= logQueueState (stateHandle hs))
+  logQueueStates ms = withActiveMsgQueues ms (\_ q _ -> logQueueState q) ()
+
+  logQueueState :: JournalMsgQueue -> IO ()
+  logQueueState q = 
+    readTVarIO (handles q)
+      >>= maybe (pure ()) (\hs -> readTVarIO (state q) >>= appendState (stateHandle hs))
 
   getMsgQueue :: JournalMsgStore -> RecipientId -> ExceptT ErrorType IO JournalMsgQueue
   getMsgQueue ms@JournalMsgStore {queueLocks, msgQueues, random} rId =
@@ -318,7 +319,7 @@ instance MsgStoreClass JournalMsgStore where
         else pure Nothing
     where
       JournalStoreConfig {quota, maxMsgCount} = config ms
-      msgQuota = MessageQuota {msgId = msgId msg, msgTs = msgTs msg}
+      !msgQuota = MessageQuota {msgId = msgId msg, msgTs = msgTs msg}
       writeToJournal st@MsgQueueState {writeState, readState = rs, size} canWrt' msg' = do
         let msgStr = strEncode msg' `B.snoc` '\n'
             msgLen = fromIntegral $ B.length msgStr
@@ -349,6 +350,10 @@ instance MsgStoreClass JournalMsgStore where
             atomically $ writeTVar handles $ Just $ hs {writeHandle = Just wh}
             pure (newJournalState journalId, wh)
 
+  -- can ONLY be used while restoring messages, not while server running
+  setOverQuota_ :: JournalMsgQueue -> IO ()
+  setOverQuota_ JournalMsgQueue {state} = atomically $ modifyTVar' state $ \st -> st {canWrite = False}
+
   getQueueSize :: JournalMsgQueue -> IO Int
   getQueueSize JournalMsgQueue {state} = size <$> readTVarIO state
 
@@ -363,13 +368,13 @@ instance MsgStoreClass JournalMsgStore where
             atomically $ writeTVar tipMsg $ Just (Just ml)
             pure $ Just msg
 
-  tryDeleteMsg_ :: JournalMsgQueue -> StoreIO ()
-  tryDeleteMsg_ q@JournalMsgQueue {tipMsg, handles} = StoreIO $
+  tryDeleteMsg_ :: JournalMsgQueue -> Bool -> StoreIO ()
+  tryDeleteMsg_ q@JournalMsgQueue {tipMsg, handles} logState = StoreIO $
     void $
       readTVarIO tipMsg -- if there is no cached tipMsg, do nothing
         $>>= (pure . fmap snd)
         $>>= \len -> readTVarIO handles
-        $>>= \hs -> updateReadPos q True len hs $> Just ()
+        $>>= \hs -> updateReadPos q logState len hs $> Just ()
 
   isolateQueue :: JournalMsgQueue -> String -> StoreIO a -> ExceptT ErrorType IO a
   isolateQueue q op (StoreIO a) = tryStore op $ withLock' (queueLock $ queue q) op $ a
@@ -416,11 +421,11 @@ chooseReadJournal q log' hs = do
 updateQueueState :: JournalMsgQueue -> Bool -> MsgQueueHandles -> MsgQueueState -> IO ()
 updateQueueState q log' hs st = do
   unless (validQueueState st) $ E.throwIO $ userError $ "updating to invalid state: " <> show st
-  when log' $ logQueueState (stateHandle hs) st
+  when log' $ appendState (stateHandle hs) st
   atomically $ writeTVar (state q) st
 
-logQueueState :: Handle -> MsgQueueState -> IO ()
-logQueueState h st = B.hPutStr h $ strEncode st `B.snoc` '\n'
+appendState :: Handle -> MsgQueueState -> IO ()
+appendState h st = B.hPutStr h $ strEncode st `B.snoc` '\n'
 
 updateReadPos :: JournalMsgQueue -> Bool -> Int64 -> MsgQueueHandles -> IO ()
 updateReadPos q log' len hs = do
@@ -555,7 +560,7 @@ readWriteQueueState JournalMsgStore {random, config} statePath =
       pure r
     writeQueueState st = do
       sh <- openFile statePath AppendMode
-      logQueueState sh st
+      appendState sh st
       pure (st, sh)
 
 validQueueState :: MsgQueueState -> Bool

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

@@ -62,6 +62,8 @@ instance MsgStoreClass STMMsgStore where
 
   logQueueStates _ = pure ()
 
+  logQueueState _ = pure ()
+
   -- 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.
@@ -104,10 +106,13 @@ instance MsgStoreClass STMMsgStore where
         modifyTVar' size (+ 1)
         if canWrt'
           then writeTQueue q msg $> Just (msg, empty)
-          else (writeTQueue q $! msgQuota) $> Nothing
+          else writeTQueue q msgQuota $> Nothing
       else pure Nothing
     where
-      msgQuota = MessageQuota {msgId = msgId msg, msgTs = msgTs msg}
+      !msgQuota = MessageQuota {msgId = msgId msg, msgTs = msgTs msg}
+
+  setOverQuota_ :: STMMsgQueue -> IO ()
+  setOverQuota_ q = atomically $ writeTVar (canWrite q) False
 
   getQueueSize :: STMMsgQueue -> IO Int
   getQueueSize STMMsgQueue {size} = readTVarIO size
@@ -116,8 +121,8 @@ instance MsgStoreClass STMMsgStore where
   tryPeekMsg_ = tryPeekTQueue . msgQueue
   {-# INLINE tryPeekMsg_ #-}
 
-  tryDeleteMsg_ :: STMMsgQueue -> STM ()
-  tryDeleteMsg_ STMMsgQueue {msgQueue = q, size} =
+  tryDeleteMsg_ :: STMMsgQueue -> Bool -> STM ()
+  tryDeleteMsg_ STMMsgQueue {msgQueue = q, size} _logState =
     tryReadTQueue q >>= \case
       Just _ -> modifyTVar' size (subtract 1)
       _ -> pure ()

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

@@ -26,14 +26,16 @@ class Monad (StoreMonad s) => MsgStoreClass s where
   activeMsgQueues :: s -> TMap RecipientId (MsgQueue s)
   withAllMsgQueues :: s -> (RecipientId -> MsgQueue s -> a -> IO a) -> a -> IO a
   logQueueStates :: s -> IO ()
+  logQueueState :: MsgQueue s -> IO ()
   getMsgQueue :: s -> RecipientId -> ExceptT ErrorType IO (MsgQueue s)
   delMsgQueue :: s -> RecipientId -> IO ()
   delMsgQueueSize :: s -> RecipientId -> IO Int
   getQueueMessages :: Bool -> MsgQueue s -> IO [Message]
   writeMsg :: s -> MsgQueue s -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool))
+  setOverQuota_ :: MsgQueue s -> IO () -- can ONLY be used while restoring messages, not while server running
   getQueueSize :: MsgQueue s -> IO Int
   tryPeekMsg_ :: MsgQueue s -> StoreMonad s (Maybe Message)
-  tryDeleteMsg_ :: MsgQueue s -> StoreMonad s ()
+  tryDeleteMsg_ :: MsgQueue s -> Bool -> StoreMonad s ()
   isolateQueue :: MsgQueue s -> String -> StoreMonad s a -> ExceptT ErrorType IO a
 
 data MSType = MSMemory | MSJournal
@@ -57,7 +59,7 @@ tryDelMsg mq msgId' =
     tryPeekMsg_ mq >>= \case
       msg_@(Just msg)
         | msgId msg == msgId' ->
-            tryDeleteMsg_ mq >> pure msg_
+            tryDeleteMsg_ mq True >> pure msg_
       _ -> pure Nothing
 
 -- atomic delete (== read) last and peek next message if available
@@ -66,16 +68,16 @@ tryDelPeekMsg mq msgId' =
   isolateQueue mq "tryDelPeekMsg" $
     tryPeekMsg_ mq >>= \case
       msg_@(Just msg)
-        | msgId msg == msgId' -> (msg_,) <$> (tryDeleteMsg_ mq >> tryPeekMsg_ mq)
+        | msgId msg == msgId' -> (msg_,) <$> (tryDeleteMsg_ mq True >> tryPeekMsg_ mq)
         | otherwise -> pure (Nothing, msg_)
       _ -> pure (Nothing, Nothing)
 
-deleteExpiredMsgs :: MsgStoreClass s => MsgQueue s -> Int64 -> ExceptT ErrorType IO Int
-deleteExpiredMsgs mq old = isolateQueue mq "deleteExpiredMsgs" $ loop 0
+deleteExpiredMsgs :: MsgStoreClass s => MsgQueue s -> Bool -> Int64 -> ExceptT ErrorType IO Int
+deleteExpiredMsgs mq logState old = isolateQueue mq "deleteExpiredMsgs" $ loop 0
   where
     loop dc =
       tryPeekMsg_ mq >>= \case
         Just Message {msgTs}
           | systemSeconds msgTs < old ->
-              tryDeleteMsg_ mq >> loop (dc + 1)
+              tryDeleteMsg_ mq logState >> loop (dc + 1)
         _ -> pure dc