{-# 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)