{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}

module Simplex.Messaging.Server.MsgStore.STM where

import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Numeric.Natural
import Simplex.Messaging.Protocol (RecipientId)
import Simplex.Messaging.Server.MsgStore
import UnliftIO.STM

newtype MsgQueue = MsgQueue {MsgQueue -> TBQueue Message
msgQueue :: TBQueue Message}

newtype MsgStoreData = MsgStoreData {MsgStoreData -> Map RecipientId MsgQueue
messages :: Map RecipientId MsgQueue}

type STMMsgStore = TVar MsgStoreData

newMsgStore :: STM STMMsgStore
newMsgStore :: STM STMMsgStore
newMsgStore = MsgStoreData -> STM STMMsgStore
forall a. a -> STM (TVar a)
newTVar (MsgStoreData -> STM STMMsgStore)
-> MsgStoreData -> STM STMMsgStore
forall a b. (a -> b) -> a -> b
$ Map RecipientId MsgQueue -> MsgStoreData
MsgStoreData Map RecipientId MsgQueue
forall k a. Map k a
M.empty

instance MonadMsgStore STMMsgStore MsgQueue STM where
  getMsgQueue :: STMMsgStore -> RecipientId -> Natural -> STM MsgQueue
  getMsgQueue :: STMMsgStore -> RecipientId -> Natural -> STM MsgQueue
getMsgQueue STMMsgStore
store RecipientId
rId Natural
quota = do
    Map RecipientId MsgQueue
m <- MsgStoreData -> Map RecipientId MsgQueue
messages (MsgStoreData -> Map RecipientId MsgQueue)
-> STM MsgStoreData -> STM (Map RecipientId MsgQueue)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STMMsgStore -> STM MsgStoreData
forall a. TVar a -> STM a
readTVar STMMsgStore
store
    STM MsgQueue
-> (MsgQueue -> STM MsgQueue) -> Maybe MsgQueue -> STM MsgQueue
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Map RecipientId MsgQueue -> STM MsgQueue
newQ Map RecipientId MsgQueue
m) MsgQueue -> STM MsgQueue
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe MsgQueue -> STM MsgQueue) -> Maybe MsgQueue -> STM MsgQueue
forall a b. (a -> b) -> a -> b
$ RecipientId -> Map RecipientId MsgQueue -> Maybe MsgQueue
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup RecipientId
rId Map RecipientId MsgQueue
m
    where
      newQ :: Map RecipientId MsgQueue -> STM MsgQueue
newQ Map RecipientId MsgQueue
m' = do
        MsgQueue
q <- TBQueue Message -> MsgQueue
MsgQueue (TBQueue Message -> MsgQueue)
-> STM (TBQueue Message) -> STM MsgQueue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Natural -> STM (TBQueue Message)
forall a. Natural -> STM (TBQueue a)
newTBQueue Natural
quota
        STMMsgStore -> MsgStoreData -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar STMMsgStore
store (MsgStoreData -> STM ())
-> (Map RecipientId MsgQueue -> MsgStoreData)
-> Map RecipientId MsgQueue
-> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map RecipientId MsgQueue -> MsgStoreData
MsgStoreData (Map RecipientId MsgQueue -> STM ())
-> Map RecipientId MsgQueue -> STM ()
forall a b. (a -> b) -> a -> b
$ RecipientId
-> MsgQueue -> Map RecipientId MsgQueue -> Map RecipientId MsgQueue
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert RecipientId
rId MsgQueue
q Map RecipientId MsgQueue
m'
        MsgQueue -> STM MsgQueue
forall (m :: * -> *) a. Monad m => a -> m a
return MsgQueue
q

  delMsgQueue :: STMMsgStore -> RecipientId -> STM ()
  delMsgQueue :: STMMsgStore -> RecipientId -> STM ()
delMsgQueue STMMsgStore
store RecipientId
rId =
    STMMsgStore -> (MsgStoreData -> MsgStoreData) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar STMMsgStore
store ((MsgStoreData -> MsgStoreData) -> STM ())
-> (MsgStoreData -> MsgStoreData) -> STM ()
forall a b. (a -> b) -> a -> b
$ Map RecipientId MsgQueue -> MsgStoreData
MsgStoreData (Map RecipientId MsgQueue -> MsgStoreData)
-> (MsgStoreData -> Map RecipientId MsgQueue)
-> MsgStoreData
-> MsgStoreData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecipientId -> Map RecipientId MsgQueue -> Map RecipientId MsgQueue
forall k a. Ord k => k -> Map k a -> Map k a
M.delete RecipientId
rId (Map RecipientId MsgQueue -> Map RecipientId MsgQueue)
-> (MsgStoreData -> Map RecipientId MsgQueue)
-> MsgStoreData
-> Map RecipientId MsgQueue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MsgStoreData -> Map RecipientId MsgQueue
messages

instance MonadMsgQueue MsgQueue STM where
  isFull :: MsgQueue -> STM Bool
  isFull :: MsgQueue -> STM Bool
isFull = TBQueue Message -> STM Bool
forall a. TBQueue a -> STM Bool
isFullTBQueue (TBQueue Message -> STM Bool)
-> (MsgQueue -> TBQueue Message) -> MsgQueue -> STM Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MsgQueue -> TBQueue Message
msgQueue

  writeMsg :: MsgQueue -> Message -> STM ()
  writeMsg :: MsgQueue -> Message -> STM ()
writeMsg = TBQueue Message -> Message -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue (TBQueue Message -> Message -> STM ())
-> (MsgQueue -> TBQueue Message) -> MsgQueue -> Message -> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MsgQueue -> TBQueue Message
msgQueue

  tryPeekMsg :: MsgQueue -> STM (Maybe Message)
  tryPeekMsg :: MsgQueue -> STM (Maybe Message)
tryPeekMsg = TBQueue Message -> STM (Maybe Message)
forall a. TBQueue a -> STM (Maybe a)
tryPeekTBQueue (TBQueue Message -> STM (Maybe Message))
-> (MsgQueue -> TBQueue Message) -> MsgQueue -> STM (Maybe Message)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MsgQueue -> TBQueue Message
msgQueue

  peekMsg :: MsgQueue -> STM Message
  peekMsg :: MsgQueue -> STM Message
peekMsg = TBQueue Message -> STM Message
forall a. TBQueue a -> STM a
peekTBQueue (TBQueue Message -> STM Message)
-> (MsgQueue -> TBQueue Message) -> MsgQueue -> STM Message
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MsgQueue -> TBQueue Message
msgQueue

  -- atomic delete (== read) last and peek next message if available
  tryDelPeekMsg :: MsgQueue -> STM (Maybe Message)
  tryDelPeekMsg :: MsgQueue -> STM (Maybe Message)
tryDelPeekMsg (MsgQueue TBQueue Message
q) = TBQueue Message -> STM (Maybe Message)
forall a. TBQueue a -> STM (Maybe a)
tryReadTBQueue TBQueue Message
q STM (Maybe Message) -> STM (Maybe Message) -> STM (Maybe Message)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TBQueue Message -> STM (Maybe Message)
forall a. TBQueue a -> STM (Maybe a)
tryPeekTBQueue TBQueue Message
q