simplexmq/src/Simplex/Messaging/Notifications/Server/StoreLog.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StrictData #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}

module Simplex.Messaging.Notifications.Server.StoreLog
  ( StoreLog,
    NtfStoreLogRecord (..),
    readWriteNtfSTMStore,
    logCreateToken,
    logTokenStatus,
    logUpdateToken,
    logTokenCron,
    logDeleteToken,
    logUpdateTokenTime,
    logCreateSubscription,
    logSubscriptionStatus,
    logDeleteSubscription,
    closeStoreLog,
  )
where

import Control.Applicative (optional, (<|>))
import Control.Concurrent.STM
import Control.Monad
import qualified Data.Attoparsec.ByteString.Char8 as A
import qualified Data.ByteString.Base64.URL as B64
import qualified Data.ByteString.Char8 as B
import Data.Functor (($>))
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe)
import Data.Word (Word16)
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Notifications.Protocol
import Simplex.Messaging.Notifications.Server.Store
import Simplex.Messaging.Notifications.Server.Store.Types
import Simplex.Messaging.Protocol (EntityId (..), SMPServer, ServiceId)
import Simplex.Messaging.Server.StoreLog
import Simplex.Messaging.SystemTime
import System.IO

data NtfStoreLogRecord
  = CreateToken NtfTknRec
  | TokenStatus NtfTokenId NtfTknStatus
  | UpdateToken NtfTokenId DeviceToken NtfRegCode
  | TokenCron NtfTokenId Word16
  | DeleteToken NtfTokenId
  | UpdateTokenTime NtfTokenId SystemDate
  | CreateSubscription NtfSubRec
  | SubscriptionStatus NtfSubscriptionId NtfSubStatus NtfAssociatedService
  | DeleteSubscription NtfSubscriptionId
  | SetNtfService SMPServer (Maybe ServiceId)
  deriving (Show)

instance StrEncoding NtfStoreLogRecord where
  strEncode = \case
    CreateToken tknRec -> strEncode (Str "TCREATE", tknRec)
    TokenStatus tknId tknStatus -> strEncode (Str "TSTATUS", tknId, tknStatus)
    UpdateToken tknId token regCode -> strEncode (Str "TUPDATE", tknId, token, regCode)
    TokenCron tknId cronInt -> strEncode (Str "TCRON", tknId, cronInt)
    DeleteToken tknId -> strEncode (Str "TDELETE", tknId)
    UpdateTokenTime tknId ts -> strEncode (Str "TTIME", tknId, ts)
    CreateSubscription subRec -> strEncode (Str "SCREATE", subRec)
    SubscriptionStatus subId subStatus serviceAssoc -> strEncode (Str "SSTATUS", subId, subStatus) <> serviceStr
      where
        serviceStr = if serviceAssoc then " service=" <> strEncode True else ""
    DeleteSubscription subId -> strEncode (Str "SDELETE", subId)
    SetNtfService srv serviceId -> strEncode (Str "SERVICE", srv) <> " service=" <> maybe "off" strEncode serviceId
  strP =
    A.choice
      [ "TCREATE " *> (CreateToken <$> strP),
        "TSTATUS " *> (TokenStatus <$> strP_ <*> strP),
        "TUPDATE " *> (UpdateToken <$> strP_ <*> strP_ <*> strP),
        "TCRON " *> (TokenCron <$> strP_ <*> strP),
        "TDELETE " *> (DeleteToken <$> strP),
        "TTIME " *> (UpdateTokenTime <$> strP_ <*> strP),
        "SCREATE " *> (CreateSubscription <$> strP),
        "SSTATUS " *> (SubscriptionStatus <$> strP_ <*> strP <*> (fromMaybe False <$> optional (" service=" *> strP))),
        "SDELETE " *> (DeleteSubscription <$> strP),
        "SERVICE " *> (SetNtfService <$> strP <* " service=" <*> ("off" $> Nothing <|> strP))
      ]

logNtfStoreRecord :: StoreLog 'WriteMode -> NtfStoreLogRecord -> IO ()
logNtfStoreRecord = writeStoreLogRecord
{-# INLINE logNtfStoreRecord #-}

logCreateToken :: StoreLog 'WriteMode -> NtfTknRec -> IO ()
logCreateToken s = logNtfStoreRecord s . CreateToken

logTokenStatus :: StoreLog 'WriteMode -> NtfTokenId -> NtfTknStatus -> IO ()
logTokenStatus s tknId tknStatus = logNtfStoreRecord s $ TokenStatus tknId tknStatus

logUpdateToken :: StoreLog 'WriteMode -> NtfTokenId -> DeviceToken -> NtfRegCode -> IO ()
logUpdateToken s tknId token regCode = logNtfStoreRecord s $ UpdateToken tknId token regCode

logTokenCron :: StoreLog 'WriteMode -> NtfTokenId -> Word16 -> IO ()
logTokenCron s tknId cronInt = logNtfStoreRecord s $ TokenCron tknId cronInt

logDeleteToken :: StoreLog 'WriteMode -> NtfTokenId -> IO ()
logDeleteToken s tknId = logNtfStoreRecord s $ DeleteToken tknId

logUpdateTokenTime :: StoreLog 'WriteMode -> NtfTokenId -> SystemDate -> IO ()
logUpdateTokenTime s tknId t = logNtfStoreRecord s $ UpdateTokenTime tknId t

logCreateSubscription :: StoreLog 'WriteMode -> NtfSubRec -> IO ()
logCreateSubscription s = logNtfStoreRecord s . CreateSubscription

logSubscriptionStatus :: StoreLog 'WriteMode -> (NtfSubscriptionId, NtfSubStatus, NtfAssociatedService) -> IO ()
logSubscriptionStatus s (subId, subStatus, serviceAssoc) = logNtfStoreRecord s $ SubscriptionStatus subId subStatus serviceAssoc

logDeleteSubscription :: StoreLog 'WriteMode -> NtfSubscriptionId -> IO ()
logDeleteSubscription s subId = logNtfStoreRecord s $ DeleteSubscription subId

logSetNtfService :: StoreLog 'WriteMode -> SMPServer -> Maybe ServiceId -> IO ()
logSetNtfService s srv serviceId = logNtfStoreRecord s $ SetNtfService srv serviceId

readWriteNtfSTMStore :: Bool -> FilePath -> NtfSTMStore -> IO (StoreLog 'WriteMode)
readWriteNtfSTMStore tty = readWriteStoreLog (readNtfStore tty) writeNtfStore

readNtfStore :: Bool -> FilePath -> NtfSTMStore -> IO ()
readNtfStore tty f st = readLogLines tty f $ \_ -> processLine
  where
    processLine s = either printError procNtfLogRecord (strDecode s)
      where
        printError e = B.putStrLn $ "Error parsing log: " <> B.pack e <> " - " <> B.take 100 s
        procNtfLogRecord = \case
          CreateToken r@NtfTknRec {ntfTknId} -> do
            tkn <- mkTknData r
            atomically $ stmAddNtfToken st ntfTknId tkn
          TokenStatus tknId status -> do
            tkn_ <- stmGetNtfTokenIO st tknId
            forM_ tkn_ $ \tkn@NtfTknData {tknStatus} -> do
              atomically $ writeTVar tknStatus status
              when (status == NTActive) $ void $ atomically $ stmRemoveInactiveTokenRegistrations st tkn
          UpdateToken tknId token' tknRegCode -> do
            stmGetNtfTokenIO st tknId
              >>= mapM_
                ( \tkn@NtfTknData {tknStatus} -> do
                    atomically $ stmRemoveTokenRegistration st tkn
                    atomically $ writeTVar tknStatus NTRegistered
                    atomically $ stmAddNtfToken st tknId tkn {token = token', tknRegCode}
                )
          TokenCron tknId cronInt ->
            stmGetNtfTokenIO st tknId
              >>= mapM_ (\NtfTknData {tknCronInterval} -> atomically $ writeTVar tknCronInterval cronInt)
          DeleteToken tknId ->
            atomically $ void $ stmDeleteNtfToken st tknId
          UpdateTokenTime tknId t ->
            stmGetNtfTokenIO st tknId
              >>= mapM_ (\NtfTknData {tknUpdatedAt} -> atomically $ writeTVar tknUpdatedAt $ Just t)
          CreateSubscription r@NtfSubRec {tokenId, ntfSubId} -> do
            sub <- mkSubData r
            atomically (stmAddNtfSubscription st ntfSubId sub) >>= \case
              Just () -> pure ()
              Nothing -> B.putStrLn $ "Warning: no token " <> enc tokenId <> ", subscription " <> enc ntfSubId
            where
              enc = B64.encode . unEntityId
          SubscriptionStatus subId status serviceAssoc -> do
            stmGetNtfSubscriptionIO st subId >>= mapM_ update
            where
              update NtfSubData {subStatus, ntfServiceAssoc} = atomically $ do
                writeTVar subStatus status
                writeTVar ntfServiceAssoc serviceAssoc
          DeleteSubscription subId ->
            atomically $ stmDeleteNtfSubscription st subId
          SetNtfService srv serviceId ->
            atomically $ stmSetNtfService st srv serviceId

writeNtfStore :: StoreLog 'WriteMode -> NtfSTMStore -> IO ()
writeNtfStore s NtfSTMStore {tokens, subscriptions, ntfServices} = do
  mapM_ (logCreateToken s <=< mkTknRec) =<< readTVarIO tokens
  mapM_ (logCreateSubscription s <=< mkSubRec) =<< readTVarIO subscriptions
  mapM_ (\(srv, serviceId) -> logSetNtfService s srv $ Just serviceId) . M.assocs =<< readTVarIO ntfServices