mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-10-10 13:37:35 +00:00
81 lines
2.9 KiB
Haskell
81 lines
2.9 KiB
Haskell
{-# LANGUAGE BangPatterns #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Simplex.Messaging.Server.NtfStore
|
|
( NtfStore (..),
|
|
MsgNtf (..),
|
|
NtfLogRecord (..),
|
|
storeNtf,
|
|
deleteNtfs,
|
|
deleteExpiredNtfs,
|
|
deleteEmptyNtfs,
|
|
) where
|
|
|
|
import Control.Concurrent.STM
|
|
import Control.Monad (foldM)
|
|
import Data.Int (Int64)
|
|
import qualified Data.Map.Strict as M
|
|
import Data.Time.Clock.System (SystemTime (..))
|
|
import qualified Simplex.Messaging.Crypto as C
|
|
import Simplex.Messaging.Encoding.String
|
|
import Simplex.Messaging.Protocol (EncNMsgMeta, MsgId, NotifierId)
|
|
import Simplex.Messaging.TMap (TMap)
|
|
import qualified Simplex.Messaging.TMap as TM
|
|
import Simplex.Messaging.Util (whenM)
|
|
|
|
newtype NtfStore = NtfStore (TMap NotifierId (TVar [MsgNtf]))
|
|
|
|
data MsgNtf = MsgNtf
|
|
{ ntfMsgId :: MsgId,
|
|
ntfTs :: SystemTime,
|
|
ntfNonce :: C.CbNonce,
|
|
ntfEncMeta :: EncNMsgMeta
|
|
}
|
|
|
|
storeNtf :: NtfStore -> NotifierId -> MsgNtf -> IO ()
|
|
storeNtf (NtfStore ns) nId ntf =
|
|
-- TODO [ntfdb] coalesce messages here once the client is updated to process multiple messages
|
|
-- for single notification.
|
|
atomically $ TM.lookup nId ns >>= maybe (TM.insertM nId (newTVar [ntf]) ns) (`modifyTVar'` (ntf :))
|
|
|
|
deleteNtfs :: NtfStore -> NotifierId -> IO Int
|
|
deleteNtfs (NtfStore ns) nId = atomically (TM.lookupDelete nId ns) >>= maybe (pure 0) (fmap length . readTVarIO)
|
|
|
|
deleteExpiredNtfs :: NtfStore -> Int64 -> IO Int
|
|
deleteExpiredNtfs (NtfStore ns) old =
|
|
foldM (\expired -> fmap (expired +) . expireQueue) 0 . M.keys =<< readTVarIO ns
|
|
where
|
|
expireQueue nId = atomically $ TM.lookup nId ns >>= maybe (pure 0) (expire nId)
|
|
expire nId v = readTVar v >>= \case
|
|
[] -> TM.delete nId ns >> pure 0
|
|
-- check the last message first, it is the earliest
|
|
ntfs
|
|
| systemSeconds (ntfTs $ last ntfs) < old -> do
|
|
let !ntfs' = filter (\MsgNtf {ntfTs = ts} -> systemSeconds ts >= old) ntfs
|
|
if null ntfs'
|
|
then TM.delete nId ns >> pure (length ntfs)
|
|
else writeTVar v ntfs' >> pure (length ntfs - length ntfs')
|
|
| otherwise -> pure 0
|
|
|
|
deleteEmptyNtfs :: NtfStore -> [(NotifierId, TVar [MsgNtf])] -> IO ()
|
|
deleteEmptyNtfs (NtfStore ns) = mapM_ deleteEmpty
|
|
where
|
|
deleteEmpty (nId, v) =
|
|
whenM (null <$> readTVarIO v) $
|
|
atomically $
|
|
TM.lookup nId ns >>= mapM_ (\v' -> whenM (null <$> readTVar v') $ TM.delete nId ns)
|
|
|
|
data NtfLogRecord = NLRv1 NotifierId MsgNtf
|
|
|
|
instance StrEncoding MsgNtf where
|
|
strEncode MsgNtf {ntfMsgId, ntfTs, ntfNonce, ntfEncMeta} = strEncode (ntfMsgId, ntfTs, ntfNonce, ntfEncMeta)
|
|
strP = do
|
|
(ntfMsgId, ntfTs, ntfNonce, ntfEncMeta) <- strP
|
|
pure MsgNtf {ntfMsgId, ntfTs, ntfNonce, ntfEncMeta}
|
|
|
|
instance StrEncoding NtfLogRecord where
|
|
strEncode (NLRv1 nId ntf) = strEncode (Str "v1", nId, ntf)
|
|
strP = "v1 " *> (NLRv1 <$> strP_ <*> strP)
|