{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Simplex.Messaging.Server.QueueStore.STM
  ( STMQueueStore (..),
    STMService (..),
    setStoreLog,
    withLog',
    readQueueRecIO,
    setStatus,
  )
where

import qualified Control.Exception as E
import Control.Logger.Simple
import Control.Monad
import Data.Bitraversable (bimapM)
import Data.Functor (($>))
import Data.Int (Int64)
import Data.List (partition)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.Map.Strict as M
import Data.Set (Set)
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.X509.Validation as XV
import Simplex.Messaging.Protocol
import Simplex.Messaging.Server.QueueStore
import Simplex.Messaging.Server.QueueStore.Types
import Simplex.Messaging.Server.StoreLog
import Simplex.Messaging.SystemTime
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport (SMPServiceRole (..))
import Simplex.Messaging.Util (anyM, ifM, tshow, ($>>), ($>>=), (<$$))
import System.IO
import UnliftIO.STM

data STMQueueStore q = STMQueueStore
  { forall q. STMQueueStore q -> TMap RecipientId q
queues :: TMap RecipientId q,
    forall q. STMQueueStore q -> TMap RecipientId RecipientId
senders :: TMap SenderId RecipientId,
    forall q. STMQueueStore q -> TMap RecipientId RecipientId
notifiers :: TMap NotifierId RecipientId,
    forall q. STMQueueStore q -> TMap RecipientId STMService
services :: TMap ServiceId STMService,
    forall q. STMQueueStore q -> TMap CertFingerprint RecipientId
serviceCerts :: TMap CertFingerprint ServiceId,
    forall q. STMQueueStore q -> TMap RecipientId RecipientId
links :: TMap LinkId RecipientId,
    forall q. STMQueueStore q -> TVar (Maybe (StoreLog 'WriteMode))
storeLog :: TVar (Maybe (StoreLog 'WriteMode))
  }

data STMService = STMService
  { STMService -> ServiceRec
serviceRec :: ServiceRec,
    STMService -> TVar (Set RecipientId)
serviceRcvQueues :: TVar (Set RecipientId),
    STMService -> TVar (Set RecipientId)
serviceNtfQueues :: TVar (Set NotifierId)
  }

setStoreLog :: STMQueueStore q -> StoreLog 'WriteMode -> IO ()
setStoreLog :: forall q. STMQueueStore q -> StoreLog 'WriteMode -> IO ()
setStoreLog STMQueueStore q
st StoreLog 'WriteMode
sl = STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Maybe (StoreLog 'WriteMode))
-> Maybe (StoreLog 'WriteMode) -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (STMQueueStore q -> TVar (Maybe (StoreLog 'WriteMode))
forall q. STMQueueStore q -> TVar (Maybe (StoreLog 'WriteMode))
storeLog STMQueueStore q
st) (StoreLog 'WriteMode -> Maybe (StoreLog 'WriteMode)
forall a. a -> Maybe a
Just StoreLog 'WriteMode
sl)

instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where
  type QueueStoreCfg (STMQueueStore q) = ()

  newQueueStore :: () -> IO (STMQueueStore q)
  newQueueStore :: () -> IO (STMQueueStore q)
newQueueStore ()
_ = do
    TMap RecipientId q
queues <- IO (TMap RecipientId q)
forall k a. IO (TMap k a)
TM.emptyIO
    TMap RecipientId RecipientId
senders <- IO (TMap RecipientId RecipientId)
forall k a. IO (TMap k a)
TM.emptyIO
    TMap RecipientId RecipientId
notifiers <- IO (TMap RecipientId RecipientId)
forall k a. IO (TMap k a)
TM.emptyIO
    TMap RecipientId STMService
services <- IO (TMap RecipientId STMService)
forall k a. IO (TMap k a)
TM.emptyIO
    TMap CertFingerprint RecipientId
serviceCerts <- IO (TMap CertFingerprint RecipientId)
forall k a. IO (TMap k a)
TM.emptyIO
    TMap RecipientId RecipientId
links <- IO (TMap RecipientId RecipientId)
forall k a. IO (TMap k a)
TM.emptyIO
    TVar (Maybe (StoreLog 'WriteMode))
storeLog <- Maybe (StoreLog 'WriteMode)
-> IO (TVar (Maybe (StoreLog 'WriteMode)))
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Maybe (StoreLog 'WriteMode)
forall a. Maybe a
Nothing
    STMQueueStore q -> IO (STMQueueStore q)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure STMQueueStore {TMap RecipientId q
$sel:queues:STMQueueStore :: TMap RecipientId q
queues :: TMap RecipientId q
queues, TMap RecipientId RecipientId
$sel:senders:STMQueueStore :: TMap RecipientId RecipientId
senders :: TMap RecipientId RecipientId
senders, TMap RecipientId RecipientId
$sel:notifiers:STMQueueStore :: TMap RecipientId RecipientId
notifiers :: TMap RecipientId RecipientId
notifiers, TMap RecipientId RecipientId
$sel:links:STMQueueStore :: TMap RecipientId RecipientId
links :: TMap RecipientId RecipientId
links, TMap RecipientId STMService
$sel:services:STMQueueStore :: TMap RecipientId STMService
services :: TMap RecipientId STMService
services, TMap CertFingerprint RecipientId
$sel:serviceCerts:STMQueueStore :: TMap CertFingerprint RecipientId
serviceCerts :: TMap CertFingerprint RecipientId
serviceCerts, TVar (Maybe (StoreLog 'WriteMode))
$sel:storeLog:STMQueueStore :: TVar (Maybe (StoreLog 'WriteMode))
storeLog :: TVar (Maybe (StoreLog 'WriteMode))
storeLog}

  closeQueueStore :: STMQueueStore q -> IO ()
  closeQueueStore :: STMQueueStore q -> IO ()
closeQueueStore STMQueueStore {TMap RecipientId q
$sel:queues:STMQueueStore :: forall q. STMQueueStore q -> TMap RecipientId q
queues :: TMap RecipientId q
queues, TMap RecipientId RecipientId
$sel:senders:STMQueueStore :: forall q. STMQueueStore q -> TMap RecipientId RecipientId
senders :: TMap RecipientId RecipientId
senders, TMap RecipientId RecipientId
$sel:notifiers:STMQueueStore :: forall q. STMQueueStore q -> TMap RecipientId RecipientId
notifiers :: TMap RecipientId RecipientId
notifiers, TVar (Maybe (StoreLog 'WriteMode))
$sel:storeLog:STMQueueStore :: forall q. STMQueueStore q -> TVar (Maybe (StoreLog 'WriteMode))
storeLog :: TVar (Maybe (StoreLog 'WriteMode))
storeLog} = do
    TVar (Maybe (StoreLog 'WriteMode))
-> IO (Maybe (StoreLog 'WriteMode))
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Maybe (StoreLog 'WriteMode))
storeLog IO (Maybe (StoreLog 'WriteMode))
-> (Maybe (StoreLog 'WriteMode) -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (StoreLog 'WriteMode -> IO ())
-> Maybe (StoreLog 'WriteMode) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ StoreLog 'WriteMode -> IO ()
forall (a :: IOMode). StoreLog a -> IO ()
closeStoreLog
    STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMap RecipientId q -> STM ()
forall k a. TMap k a -> STM ()
TM.clear TMap RecipientId q
queues
    STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMap RecipientId RecipientId -> STM ()
forall k a. TMap k a -> STM ()
TM.clear TMap RecipientId RecipientId
senders
    STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMap RecipientId RecipientId -> STM ()
forall k a. TMap k a -> STM ()
TM.clear TMap RecipientId RecipientId
notifiers

  loadedQueues :: STMQueueStore q -> TMap RecipientId q
loadedQueues = STMQueueStore q -> TMap RecipientId q
forall q. STMQueueStore q -> TMap RecipientId q
queues
  {-# INLINE loadedQueues #-}
  compactQueues :: STMQueueStore q -> IO Int64
compactQueues STMQueueStore q
_ = Int64 -> IO Int64
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int64
0
  {-# INLINE compactQueues #-}

  getEntityCounts :: STMQueueStore q -> IO EntityCounts
  getEntityCounts :: STMQueueStore q -> IO EntityCounts
getEntityCounts STMQueueStore q
st = do
    Int
queueCount <- Map RecipientId q -> Int
forall k a. Map k a -> Int
M.size (Map RecipientId q -> Int) -> IO (Map RecipientId q) -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TMap RecipientId q -> IO (Map RecipientId q)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (STMQueueStore q -> TMap RecipientId q
forall q. STMQueueStore q -> TMap RecipientId q
queues STMQueueStore q
st)
    Int
notifierCount <- Map RecipientId RecipientId -> Int
forall k a. Map k a -> Int
M.size (Map RecipientId RecipientId -> Int)
-> IO (Map RecipientId RecipientId) -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TMap RecipientId RecipientId -> IO (Map RecipientId RecipientId)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (STMQueueStore q -> TMap RecipientId RecipientId
forall q. STMQueueStore q -> TMap RecipientId RecipientId
notifiers STMQueueStore q
st)
    Map RecipientId STMService
ss <- TMap RecipientId STMService -> IO (Map RecipientId STMService)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (STMQueueStore q -> TMap RecipientId STMService
forall q. STMQueueStore q -> TMap RecipientId STMService
services STMQueueStore q
st)
    Int
rcvServiceQueuesCount <- (STMService -> TVar (Set RecipientId))
-> Map RecipientId STMService -> IO Int
forall {t :: * -> *} {m :: * -> *} {t} {a}.
(Foldable t, MonadIO m) =>
(t -> TVar (Set a)) -> t t -> m Int
serviceQueuesCount STMService -> TVar (Set RecipientId)
serviceRcvQueues Map RecipientId STMService
ss
    Int
ntfServiceQueuesCount <- (STMService -> TVar (Set RecipientId))
-> Map RecipientId STMService -> IO Int
forall {t :: * -> *} {m :: * -> *} {t} {a}.
(Foldable t, MonadIO m) =>
(t -> TVar (Set a)) -> t t -> m Int
serviceQueuesCount STMService -> TVar (Set RecipientId)
serviceNtfQueues Map RecipientId STMService
ss
    EntityCounts -> IO EntityCounts
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      EntityCounts
        { Int
queueCount :: Int
queueCount :: Int
queueCount,
          Int
notifierCount :: Int
notifierCount :: Int
notifierCount,
          rcvServiceCount :: Int
rcvServiceCount = SMPServiceRole -> Map RecipientId STMService -> Int
forall {a} {k}. Num a => SMPServiceRole -> Map k STMService -> a
serviceCount SMPServiceRole
SRMessaging Map RecipientId STMService
ss,
          ntfServiceCount :: Int
ntfServiceCount = SMPServiceRole -> Map RecipientId STMService -> Int
forall {a} {k}. Num a => SMPServiceRole -> Map k STMService -> a
serviceCount SMPServiceRole
SRNotifier Map RecipientId STMService
ss,
          Int
rcvServiceQueuesCount :: Int
rcvServiceQueuesCount :: Int
rcvServiceQueuesCount,
          Int
ntfServiceQueuesCount :: Int
ntfServiceQueuesCount :: Int
ntfServiceQueuesCount
        }
    where
      serviceCount :: SMPServiceRole -> Map k STMService -> a
serviceCount SMPServiceRole
role = (a -> STMService -> a) -> a -> Map k STMService -> a
forall a b k. (a -> b -> a) -> a -> Map k b -> a
M.foldl' (\ !a
n STMService
s -> if ServiceRec -> SMPServiceRole
serviceRole (STMService -> ServiceRec
serviceRec STMService
s) SMPServiceRole -> SMPServiceRole -> Bool
forall a. Eq a => a -> a -> Bool
== SMPServiceRole
role then a
n a -> a -> a
forall a. Num a => a -> a -> a
+ a
1 else a
n) a
0
      serviceQueuesCount :: (t -> TVar (Set a)) -> t t -> m Int
serviceQueuesCount t -> TVar (Set a)
serviceSel = (Int -> t -> m Int) -> Int -> t t -> m Int
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\Int
n t
s -> (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+) (Int -> Int) -> (Set a -> Int) -> Set a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set a -> Int
forall a. Set a -> Int
S.size (Set a -> Int) -> m (Set a) -> m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Set a) -> m (Set a)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (t -> TVar (Set a)
serviceSel t
s)) Int
0

  addQueue_ :: STMQueueStore q -> (RecipientId -> QueueRec -> IO q) -> RecipientId -> QueueRec -> IO (Either ErrorType q)
  addQueue_ :: STMQueueStore q
-> (RecipientId -> QueueRec -> IO q)
-> RecipientId
-> QueueRec
-> IO (Either ErrorType q)
addQueue_ STMQueueStore q
st RecipientId -> QueueRec -> IO q
mkQ RecipientId
rId qr :: QueueRec
qr@QueueRec {$sel:senderId:QueueRec :: QueueRec -> RecipientId
senderId = RecipientId
sId, Maybe NtfCreds
notifier :: Maybe NtfCreds
$sel:notifier:QueueRec :: QueueRec -> Maybe NtfCreds
notifier, Maybe (RecipientId, QueueLinkData)
queueData :: Maybe (RecipientId, QueueLinkData)
$sel:queueData:QueueRec :: QueueRec -> Maybe (RecipientId, QueueLinkData)
queueData, Maybe RecipientId
rcvServiceId :: Maybe RecipientId
$sel:rcvServiceId:QueueRec :: QueueRec -> Maybe RecipientId
rcvServiceId} = do
    q
sq <- RecipientId -> QueueRec -> IO q
mkQ RecipientId
rId QueueRec
qr
    q -> IO (Either ErrorType ())
add q
sq IO (Either ErrorType ())
-> IO (Either ErrorType q) -> IO (Either ErrorType q)
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Monad f, Traversable f) =>
m (f a) -> m (f b) -> m (f b)
$>> Text
-> STMQueueStore q
-> (StoreLog 'WriteMode -> IO ())
-> IO (Either ErrorType ())
forall q.
Text
-> STMQueueStore q
-> (StoreLog 'WriteMode -> IO ())
-> IO (Either ErrorType ())
withLog Text
"addStoreQueue" STMQueueStore q
st (\StoreLog 'WriteMode
s -> StoreLog 'WriteMode -> RecipientId -> QueueRec -> IO ()
logCreateQueue StoreLog 'WriteMode
s RecipientId
rId QueueRec
qr) IO (Either ErrorType ())
-> Either ErrorType q -> IO (Either ErrorType q)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> q -> Either ErrorType q
forall a b. b -> Either a b
Right q
sq
    where
      STMQueueStore {TMap RecipientId q
$sel:queues:STMQueueStore :: forall q. STMQueueStore q -> TMap RecipientId q
queues :: TMap RecipientId q
queues, TMap RecipientId RecipientId
$sel:senders:STMQueueStore :: forall q. STMQueueStore q -> TMap RecipientId RecipientId
senders :: TMap RecipientId RecipientId
senders, TMap RecipientId RecipientId
$sel:notifiers:STMQueueStore :: forall q. STMQueueStore q -> TMap RecipientId RecipientId
notifiers :: TMap RecipientId RecipientId
notifiers, TMap RecipientId RecipientId
$sel:links:STMQueueStore :: forall q. STMQueueStore q -> TMap RecipientId RecipientId
links :: TMap RecipientId RecipientId
links} = STMQueueStore q
st
      add :: q -> IO (Either ErrorType ())
add q
q = STM (Either ErrorType ()) -> IO (Either ErrorType ())
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Either ErrorType ()) -> IO (Either ErrorType ()))
-> STM (Either ErrorType ()) -> IO (Either ErrorType ())
forall a b. (a -> b) -> a -> b
$ STM Bool
-> STM (Either ErrorType ())
-> STM (Either ErrorType ())
-> STM (Either ErrorType ())
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM STM Bool
hasId (Either ErrorType () -> STM (Either ErrorType ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrorType () -> STM (Either ErrorType ()))
-> Either ErrorType () -> STM (Either ErrorType ())
forall a b. (a -> b) -> a -> b
$ ErrorType -> Either ErrorType ()
forall a b. a -> Either a b
Left ErrorType
DUPLICATE_) (STM (Either ErrorType ()) -> STM (Either ErrorType ()))
-> STM (Either ErrorType ()) -> STM (Either ErrorType ())
forall a b. (a -> b) -> a -> b
$ () -> Either ErrorType ()
forall a b. b -> Either a b
Right () Either ErrorType () -> STM () -> STM (Either ErrorType ())
forall a b. a -> STM b -> STM a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ do
        RecipientId -> q -> TMap RecipientId q -> STM ()
forall k a. Ord k => k -> a -> TMap k a -> STM ()
TM.insert RecipientId
rId q
q TMap RecipientId q
queues
        RecipientId
-> RecipientId -> TMap RecipientId RecipientId -> STM ()
forall k a. Ord k => k -> a -> TMap k a -> STM ()
TM.insert RecipientId
sId RecipientId
rId TMap RecipientId RecipientId
senders
        Maybe NtfCreds -> (NtfCreds -> STM ()) -> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe NtfCreds
notifier ((NtfCreds -> STM ()) -> STM ()) -> (NtfCreds -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$ \NtfCreds {$sel:notifierId:NtfCreds :: NtfCreds -> RecipientId
notifierId = RecipientId
nId, Maybe RecipientId
ntfServiceId :: Maybe RecipientId
$sel:ntfServiceId:NtfCreds :: NtfCreds -> Maybe RecipientId
ntfServiceId} -> do
          RecipientId
-> RecipientId -> TMap RecipientId RecipientId -> STM ()
forall k a. Ord k => k -> a -> TMap k a -> STM ()
TM.insert RecipientId
nId RecipientId
rId TMap RecipientId RecipientId
notifiers
          (RecipientId -> STM ()) -> Maybe RecipientId -> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (STMQueueStore q
-> (STMService -> TVar (Set RecipientId))
-> RecipientId
-> RecipientId
-> STM ()
forall q.
STMQueueStore q
-> (STMService -> TVar (Set RecipientId))
-> RecipientId
-> RecipientId
-> STM ()
addServiceQueue STMQueueStore q
st STMService -> TVar (Set RecipientId)
serviceNtfQueues RecipientId
nId) Maybe RecipientId
ntfServiceId
        Maybe (RecipientId, QueueLinkData)
-> ((RecipientId, QueueLinkData) -> STM ()) -> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (RecipientId, QueueLinkData)
queueData (((RecipientId, QueueLinkData) -> STM ()) -> STM ())
-> ((RecipientId, QueueLinkData) -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$ \(RecipientId
lnkId, QueueLinkData
_) -> RecipientId
-> RecipientId -> TMap RecipientId RecipientId -> STM ()
forall k a. Ord k => k -> a -> TMap k a -> STM ()
TM.insert RecipientId
lnkId RecipientId
rId TMap RecipientId RecipientId
links
        (RecipientId -> STM ()) -> Maybe RecipientId -> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (STMQueueStore q
-> (STMService -> TVar (Set RecipientId))
-> RecipientId
-> RecipientId
-> STM ()
forall q.
STMQueueStore q
-> (STMService -> TVar (Set RecipientId))
-> RecipientId
-> RecipientId
-> STM ()
addServiceQueue STMQueueStore q
st STMService -> TVar (Set RecipientId)
serviceRcvQueues RecipientId
rId) Maybe RecipientId
rcvServiceId
      hasId :: STM Bool
hasId = [STM Bool] -> STM Bool
forall (m :: * -> *). Monad m => [m Bool] -> m Bool
anyM [RecipientId -> TMap RecipientId q -> STM Bool
forall k a. Ord k => k -> TMap k a -> STM Bool
TM.member RecipientId
rId TMap RecipientId q
queues, RecipientId -> TMap RecipientId RecipientId -> STM Bool
forall k a. Ord k => k -> TMap k a -> STM Bool
TM.member RecipientId
sId TMap RecipientId RecipientId
senders, STM Bool
hasNotifier, STM Bool
hasLink]
      hasNotifier :: STM Bool
hasNotifier = STM Bool -> (NtfCreds -> STM Bool) -> Maybe NtfCreds -> STM Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool -> STM Bool
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False) (\NtfCreds {RecipientId
$sel:notifierId:NtfCreds :: NtfCreds -> RecipientId
notifierId :: RecipientId
notifierId} -> RecipientId -> TMap RecipientId RecipientId -> STM Bool
forall k a. Ord k => k -> TMap k a -> STM Bool
TM.member RecipientId
notifierId TMap RecipientId RecipientId
notifiers) Maybe NtfCreds
notifier
      hasLink :: STM Bool
hasLink = STM Bool
-> ((RecipientId, QueueLinkData) -> STM Bool)
-> Maybe (RecipientId, QueueLinkData)
-> STM Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool -> STM Bool
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False) (\(RecipientId
lnkId, QueueLinkData
_) -> RecipientId -> TMap RecipientId RecipientId -> STM Bool
forall k a. Ord k => k -> TMap k a -> STM Bool
TM.member RecipientId
lnkId TMap RecipientId RecipientId
links) Maybe (RecipientId, QueueLinkData)
queueData

  getQueue_ :: QueueParty p => STMQueueStore q -> (Bool -> RecipientId -> QueueRec -> IO q) -> SParty p -> QueueId -> IO (Either ErrorType q)
  getQueue_ :: forall (p :: Party).
QueueParty p =>
STMQueueStore q
-> (Bool -> RecipientId -> QueueRec -> IO q)
-> SParty p
-> RecipientId
-> IO (Either ErrorType q)
getQueue_ STMQueueStore q
st Bool -> RecipientId -> QueueRec -> IO q
_ SParty p
party RecipientId
qId =
    Either ErrorType q
-> (q -> Either ErrorType q) -> Maybe q -> Either ErrorType q
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ErrorType -> Either ErrorType q
forall a b. a -> Either a b
Left ErrorType
AUTH) q -> Either ErrorType q
forall a b. b -> Either a b
Right (Maybe q -> Either ErrorType q)
-> IO (Maybe q) -> IO (Either ErrorType q)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case SParty p
party of
      SParty p
SRecipient -> RecipientId -> TMap RecipientId q -> IO (Maybe q)
forall k a. Ord k => k -> TMap k a -> IO (Maybe a)
TM.lookupIO RecipientId
qId TMap RecipientId q
queues
      SParty p
SSender -> RecipientId
-> TMap RecipientId RecipientId -> IO (Maybe RecipientId)
forall k a. Ord k => k -> TMap k a -> IO (Maybe a)
TM.lookupIO RecipientId
qId TMap RecipientId RecipientId
senders IO (Maybe RecipientId)
-> (RecipientId -> IO (Maybe q)) -> IO (Maybe q)
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Monad f, Traversable f) =>
m (f a) -> (a -> m (f b)) -> m (f b)
$>>= (RecipientId -> TMap RecipientId q -> IO (Maybe q)
forall k a. Ord k => k -> TMap k a -> IO (Maybe a)
`TM.lookupIO` TMap RecipientId q
queues)
      SParty p
SNotifier -> RecipientId
-> TMap RecipientId RecipientId -> IO (Maybe RecipientId)
forall k a. Ord k => k -> TMap k a -> IO (Maybe a)
TM.lookupIO RecipientId
qId TMap RecipientId RecipientId
notifiers IO (Maybe RecipientId)
-> (RecipientId -> IO (Maybe q)) -> IO (Maybe q)
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Monad f, Traversable f) =>
m (f a) -> (a -> m (f b)) -> m (f b)
$>>= (RecipientId -> TMap RecipientId q -> IO (Maybe q)
forall k a. Ord k => k -> TMap k a -> IO (Maybe a)
`TM.lookupIO` TMap RecipientId q
queues)
      SParty p
SSenderLink -> RecipientId
-> TMap RecipientId RecipientId -> IO (Maybe RecipientId)
forall k a. Ord k => k -> TMap k a -> IO (Maybe a)
TM.lookupIO RecipientId
qId TMap RecipientId RecipientId
links IO (Maybe RecipientId)
-> (RecipientId -> IO (Maybe q)) -> IO (Maybe q)
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Monad f, Traversable f) =>
m (f a) -> (a -> m (f b)) -> m (f b)
$>>= (RecipientId -> TMap RecipientId q -> IO (Maybe q)
forall k a. Ord k => k -> TMap k a -> IO (Maybe a)
`TM.lookupIO` TMap RecipientId q
queues)
    where
      STMQueueStore {TMap RecipientId q
$sel:queues:STMQueueStore :: forall q. STMQueueStore q -> TMap RecipientId q
queues :: TMap RecipientId q
queues, TMap RecipientId RecipientId
$sel:senders:STMQueueStore :: forall q. STMQueueStore q -> TMap RecipientId RecipientId
senders :: TMap RecipientId RecipientId
senders, TMap RecipientId RecipientId
$sel:notifiers:STMQueueStore :: forall q. STMQueueStore q -> TMap RecipientId RecipientId
notifiers :: TMap RecipientId RecipientId
notifiers, TMap RecipientId RecipientId
$sel:links:STMQueueStore :: forall q. STMQueueStore q -> TMap RecipientId RecipientId
links :: TMap RecipientId RecipientId
links} = STMQueueStore q
st

  getQueues_ :: BatchParty p => STMQueueStore q -> (Bool -> RecipientId -> QueueRec -> IO q) -> SParty p -> [QueueId] -> IO [Either ErrorType q]
  getQueues_ :: forall (p :: Party).
BatchParty p =>
STMQueueStore q
-> (Bool -> RecipientId -> QueueRec -> IO q)
-> SParty p
-> [RecipientId]
-> IO [Either ErrorType q]
getQueues_ STMQueueStore q
st Bool -> RecipientId -> QueueRec -> IO q
_ SParty p
party [RecipientId]
qIds = case SParty p
party of
    SParty p
SRecipient -> do
      Map RecipientId q
qs <- TMap RecipientId q -> IO (Map RecipientId q)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TMap RecipientId q
queues
      [Either ErrorType q] -> IO [Either ErrorType q]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Either ErrorType q] -> IO [Either ErrorType q])
-> [Either ErrorType q] -> IO [Either ErrorType q]
forall a b. (a -> b) -> a -> b
$ (RecipientId -> Either ErrorType q)
-> [RecipientId] -> [Either ErrorType q]
forall a b. (a -> b) -> [a] -> [b]
map (Map RecipientId q -> RecipientId -> Either ErrorType q
forall a. Map RecipientId a -> RecipientId -> Either ErrorType a
get Map RecipientId q
qs) [RecipientId]
qIds
    SParty p
SNotifier -> do
      Map RecipientId RecipientId
ns <- TMap RecipientId RecipientId -> IO (Map RecipientId RecipientId)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TMap RecipientId RecipientId
notifiers
      Map RecipientId q
qs <- TMap RecipientId q -> IO (Map RecipientId q)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TMap RecipientId q
queues
      [Either ErrorType q] -> IO [Either ErrorType q]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Either ErrorType q] -> IO [Either ErrorType q])
-> [Either ErrorType q] -> IO [Either ErrorType q]
forall a b. (a -> b) -> a -> b
$ (RecipientId -> Either ErrorType q)
-> [RecipientId] -> [Either ErrorType q]
forall a b. (a -> b) -> [a] -> [b]
map (Map RecipientId q -> RecipientId -> Either ErrorType q
forall a. Map RecipientId a -> RecipientId -> Either ErrorType a
get Map RecipientId q
qs (RecipientId -> Either ErrorType q)
-> (RecipientId -> Either ErrorType RecipientId)
-> RecipientId
-> Either ErrorType q
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Map RecipientId RecipientId
-> RecipientId -> Either ErrorType RecipientId
forall a. Map RecipientId a -> RecipientId -> Either ErrorType a
get Map RecipientId RecipientId
ns) [RecipientId]
qIds
    where
      STMQueueStore {TMap RecipientId q
$sel:queues:STMQueueStore :: forall q. STMQueueStore q -> TMap RecipientId q
queues :: TMap RecipientId q
queues, TMap RecipientId RecipientId
$sel:notifiers:STMQueueStore :: forall q. STMQueueStore q -> TMap RecipientId RecipientId
notifiers :: TMap RecipientId RecipientId
notifiers} = STMQueueStore q
st
      get :: M.Map QueueId a -> QueueId -> Either ErrorType a
      get :: forall a. Map RecipientId a -> RecipientId -> Either ErrorType a
get Map RecipientId a
m = Either ErrorType a
-> (a -> Either ErrorType a) -> Maybe a -> Either ErrorType a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ErrorType -> Either ErrorType a
forall a b. a -> Either a b
Left ErrorType
AUTH) a -> Either ErrorType a
forall a b. b -> Either a b
Right (Maybe a -> Either ErrorType a)
-> (RecipientId -> Maybe a) -> RecipientId -> Either ErrorType a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RecipientId -> Map RecipientId a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Map RecipientId a
m)

  getQueueLinkData :: STMQueueStore q -> q -> LinkId -> IO (Either ErrorType QueueLinkData)
  getQueueLinkData :: STMQueueStore q
-> q -> RecipientId -> IO (Either ErrorType QueueLinkData)
getQueueLinkData STMQueueStore q
_ q
q RecipientId
lnkId = STM (Either ErrorType QueueLinkData)
-> IO (Either ErrorType QueueLinkData)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Either ErrorType QueueLinkData)
 -> IO (Either ErrorType QueueLinkData))
-> STM (Either ErrorType QueueLinkData)
-> IO (Either ErrorType QueueLinkData)
forall a b. (a -> b) -> a -> b
$ TVar (Maybe QueueRec) -> STM (Either ErrorType QueueRec)
readQueueRec (q -> TVar (Maybe QueueRec)
forall q. StoreQueueClass q => q -> TVar (Maybe QueueRec)
queueRec q
q) STM (Either ErrorType QueueRec)
-> (QueueRec -> STM (Either ErrorType QueueLinkData))
-> STM (Either ErrorType QueueLinkData)
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Monad f, Traversable f) =>
m (f a) -> (a -> m (f b)) -> m (f b)
$>>= Either ErrorType QueueLinkData
-> STM (Either ErrorType QueueLinkData)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrorType QueueLinkData
 -> STM (Either ErrorType QueueLinkData))
-> (QueueRec -> Either ErrorType QueueLinkData)
-> QueueRec
-> STM (Either ErrorType QueueLinkData)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QueueRec -> Either ErrorType QueueLinkData
getData
    where
      getData :: QueueRec -> Either ErrorType QueueLinkData
getData QueueRec
qr = case QueueRec -> Maybe (RecipientId, QueueLinkData)
queueData QueueRec
qr of
        Just (RecipientId
lnkId', QueueLinkData
d) | RecipientId
lnkId' RecipientId -> RecipientId -> Bool
forall a. Eq a => a -> a -> Bool
== RecipientId
lnkId -> QueueLinkData -> Either ErrorType QueueLinkData
forall a b. b -> Either a b
Right QueueLinkData
d
        Maybe (RecipientId, QueueLinkData)
_ -> ErrorType -> Either ErrorType QueueLinkData
forall a b. a -> Either a b
Left ErrorType
AUTH

  addQueueLinkData :: STMQueueStore q -> q -> LinkId -> QueueLinkData -> IO (Either ErrorType ())
  addQueueLinkData :: STMQueueStore q
-> q -> RecipientId -> QueueLinkData -> IO (Either ErrorType ())
addQueueLinkData STMQueueStore q
st q
sq RecipientId
lnkId QueueLinkData
d =
    STM (Either ErrorType ()) -> IO (Either ErrorType ())
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TVar (Maybe QueueRec) -> STM (Either ErrorType QueueRec)
readQueueRec TVar (Maybe QueueRec)
qr STM (Either ErrorType QueueRec)
-> (QueueRec -> STM (Either ErrorType ()))
-> STM (Either ErrorType ())
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Monad f, Traversable f) =>
m (f a) -> (a -> m (f b)) -> m (f b)
$>>= QueueRec -> STM (Either ErrorType ())
add)
      IO (Either ErrorType ())
-> IO (Either ErrorType ()) -> IO (Either ErrorType ())
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Monad f, Traversable f) =>
m (f a) -> m (f b) -> m (f b)
$>> Text
-> STMQueueStore q
-> (StoreLog 'WriteMode -> IO ())
-> IO (Either ErrorType ())
forall q.
Text
-> STMQueueStore q
-> (StoreLog 'WriteMode -> IO ())
-> IO (Either ErrorType ())
withLog Text
"addQueueLinkData" STMQueueStore q
st (\StoreLog 'WriteMode
s -> StoreLog 'WriteMode
-> RecipientId -> RecipientId -> QueueLinkData -> IO ()
logCreateLink StoreLog 'WriteMode
s RecipientId
rId RecipientId
lnkId QueueLinkData
d)
    where
      rId :: RecipientId
rId = q -> RecipientId
forall q. StoreQueueClass q => q -> RecipientId
recipientId q
sq
      qr :: TVar (Maybe QueueRec)
qr = q -> TVar (Maybe QueueRec)
forall q. StoreQueueClass q => q -> TVar (Maybe QueueRec)
queueRec q
sq
      add :: QueueRec -> STM (Either ErrorType ())
add QueueRec
q = case QueueRec -> Maybe (RecipientId, QueueLinkData)
queueData QueueRec
q of
        Maybe (RecipientId, QueueLinkData)
Nothing -> STM (Either ErrorType ())
addLink
        Just (RecipientId
lnkId', QueueLinkData
d') | RecipientId
lnkId' RecipientId -> RecipientId -> Bool
forall a. Eq a => a -> a -> Bool
== RecipientId
lnkId Bool -> Bool -> Bool
&& QueueLinkData -> EncFixedDataBytes
forall a b. (a, b) -> a
fst QueueLinkData
d' EncFixedDataBytes -> EncFixedDataBytes -> Bool
forall a. Eq a => a -> a -> Bool
== QueueLinkData -> EncFixedDataBytes
forall a b. (a, b) -> a
fst QueueLinkData
d -> STM (Either ErrorType ())
addLink
        Maybe (RecipientId, QueueLinkData)
_ -> Either ErrorType () -> STM (Either ErrorType ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrorType () -> STM (Either ErrorType ()))
-> Either ErrorType () -> STM (Either ErrorType ())
forall a b. (a -> b) -> a -> b
$ ErrorType -> Either ErrorType ()
forall a b. a -> Either a b
Left ErrorType
AUTH
        where
          addLink :: STM (Either ErrorType ())
addLink = do
            let !q' :: QueueRec
q' = QueueRec
q {queueData = Just (lnkId, d)}
            TVar (Maybe QueueRec) -> Maybe QueueRec -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe QueueRec)
qr (Maybe QueueRec -> STM ()) -> Maybe QueueRec -> STM ()
forall a b. (a -> b) -> a -> b
$ QueueRec -> Maybe QueueRec
forall a. a -> Maybe a
Just QueueRec
q'
            RecipientId
-> RecipientId -> TMap RecipientId RecipientId -> STM ()
forall k a. Ord k => k -> a -> TMap k a -> STM ()
TM.insert RecipientId
lnkId RecipientId
rId (TMap RecipientId RecipientId -> STM ())
-> TMap RecipientId RecipientId -> STM ()
forall a b. (a -> b) -> a -> b
$ STMQueueStore q -> TMap RecipientId RecipientId
forall q. STMQueueStore q -> TMap RecipientId RecipientId
links STMQueueStore q
st
            Either ErrorType () -> STM (Either ErrorType ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrorType () -> STM (Either ErrorType ()))
-> Either ErrorType () -> STM (Either ErrorType ())
forall a b. (a -> b) -> a -> b
$ () -> Either ErrorType ()
forall a b. b -> Either a b
Right ()

  deleteQueueLinkData :: STMQueueStore q -> q -> IO (Either ErrorType ())
  deleteQueueLinkData :: STMQueueStore q -> q -> IO (Either ErrorType ())
deleteQueueLinkData STMQueueStore q
st q
sq =
    TVar (Maybe QueueRec)
-> (QueueRec -> STM (Maybe ())) -> IO (Either ErrorType (Maybe ()))
forall a.
TVar (Maybe QueueRec)
-> (QueueRec -> STM a) -> IO (Either ErrorType a)
withQueueRec TVar (Maybe QueueRec)
qr QueueRec -> STM (Maybe ())
delete
      IO (Either ErrorType (Maybe ()))
-> IO (Either ErrorType ()) -> IO (Either ErrorType ())
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Monad f, Traversable f) =>
m (f a) -> m (f b) -> m (f b)
$>> Text
-> STMQueueStore q
-> (StoreLog 'WriteMode -> IO ())
-> IO (Either ErrorType ())
forall q.
Text
-> STMQueueStore q
-> (StoreLog 'WriteMode -> IO ())
-> IO (Either ErrorType ())
withLog Text
"deleteQueueLinkData" STMQueueStore q
st (StoreLog 'WriteMode -> RecipientId -> IO ()
`logDeleteLink` q -> RecipientId
forall q. StoreQueueClass q => q -> RecipientId
recipientId q
sq)
    where
      qr :: TVar (Maybe QueueRec)
qr = q -> TVar (Maybe QueueRec)
forall q. StoreQueueClass q => q -> TVar (Maybe QueueRec)
queueRec q
sq
      delete :: QueueRec -> STM (Maybe ())
delete QueueRec
q = Maybe (RecipientId, QueueLinkData)
-> ((RecipientId, QueueLinkData) -> STM ()) -> STM (Maybe ())
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (QueueRec -> Maybe (RecipientId, QueueLinkData)
queueData QueueRec
q) (((RecipientId, QueueLinkData) -> STM ()) -> STM (Maybe ()))
-> ((RecipientId, QueueLinkData) -> STM ()) -> STM (Maybe ())
forall a b. (a -> b) -> a -> b
$ \(RecipientId
lnkId, QueueLinkData
_) -> do
        RecipientId -> TMap RecipientId RecipientId -> STM ()
forall k a. Ord k => k -> TMap k a -> STM ()
TM.delete RecipientId
lnkId (TMap RecipientId RecipientId -> STM ())
-> TMap RecipientId RecipientId -> STM ()
forall a b. (a -> b) -> a -> b
$ STMQueueStore q -> TMap RecipientId RecipientId
forall q. STMQueueStore q -> TMap RecipientId RecipientId
links STMQueueStore q
st
        TVar (Maybe QueueRec) -> Maybe QueueRec -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe QueueRec)
qr (Maybe QueueRec -> STM ()) -> Maybe QueueRec -> STM ()
forall a b. (a -> b) -> a -> b
$ QueueRec -> Maybe QueueRec
forall a. a -> Maybe a
Just QueueRec
q {queueData = Nothing}

  updateKeys :: STMQueueStore q -> q -> NonEmpty RcvPublicAuthKey -> IO (Either ErrorType ())
  updateKeys :: STMQueueStore q
-> q -> NonEmpty SndPublicAuthKey -> IO (Either ErrorType ())
updateKeys STMQueueStore q
st q
sq NonEmpty SndPublicAuthKey
rKeys =
    TVar (Maybe QueueRec)
-> (QueueRec -> STM ()) -> IO (Either ErrorType ())
forall a.
TVar (Maybe QueueRec)
-> (QueueRec -> STM a) -> IO (Either ErrorType a)
withQueueRec TVar (Maybe QueueRec)
qr QueueRec -> STM ()
update
      IO (Either ErrorType ())
-> IO (Either ErrorType ()) -> IO (Either ErrorType ())
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Monad f, Traversable f) =>
m (f a) -> m (f b) -> m (f b)
$>> Text
-> STMQueueStore q
-> (StoreLog 'WriteMode -> IO ())
-> IO (Either ErrorType ())
forall q.
Text
-> STMQueueStore q
-> (StoreLog 'WriteMode -> IO ())
-> IO (Either ErrorType ())
withLog Text
"updateKeys" STMQueueStore q
st (\StoreLog 'WriteMode
s -> StoreLog 'WriteMode
-> RecipientId -> NonEmpty SndPublicAuthKey -> IO ()
logUpdateKeys StoreLog 'WriteMode
s (q -> RecipientId
forall q. StoreQueueClass q => q -> RecipientId
recipientId q
sq) NonEmpty SndPublicAuthKey
rKeys)
    where
      qr :: TVar (Maybe QueueRec)
qr = q -> TVar (Maybe QueueRec)
forall q. StoreQueueClass q => q -> TVar (Maybe QueueRec)
queueRec q
sq
      update :: QueueRec -> STM ()
update QueueRec
q = TVar (Maybe QueueRec) -> Maybe QueueRec -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe QueueRec)
qr (Maybe QueueRec -> STM ()) -> Maybe QueueRec -> STM ()
forall a b. (a -> b) -> a -> b
$ QueueRec -> Maybe QueueRec
forall a. a -> Maybe a
Just QueueRec
q {recipientKeys = rKeys}

  secureQueue :: STMQueueStore q -> q -> SndPublicAuthKey -> IO (Either ErrorType ())
  secureQueue :: STMQueueStore q
-> q -> SndPublicAuthKey -> IO (Either ErrorType ())
secureQueue STMQueueStore q
st q
sq SndPublicAuthKey
sKey =
    STM (Either ErrorType ()) -> IO (Either ErrorType ())
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TVar (Maybe QueueRec) -> STM (Either ErrorType QueueRec)
readQueueRec TVar (Maybe QueueRec)
qr STM (Either ErrorType QueueRec)
-> (QueueRec -> STM (Either ErrorType ()))
-> STM (Either ErrorType ())
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Monad f, Traversable f) =>
m (f a) -> (a -> m (f b)) -> m (f b)
$>>= QueueRec -> STM (Either ErrorType ())
secure)
      IO (Either ErrorType ())
-> IO (Either ErrorType ()) -> IO (Either ErrorType ())
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Monad f, Traversable f) =>
m (f a) -> m (f b) -> m (f b)
$>> Text
-> STMQueueStore q
-> (StoreLog 'WriteMode -> IO ())
-> IO (Either ErrorType ())
forall q.
Text
-> STMQueueStore q
-> (StoreLog 'WriteMode -> IO ())
-> IO (Either ErrorType ())
withLog Text
"secureQueue" STMQueueStore q
st (\StoreLog 'WriteMode
s -> StoreLog 'WriteMode -> RecipientId -> SndPublicAuthKey -> IO ()
logSecureQueue StoreLog 'WriteMode
s (q -> RecipientId
forall q. StoreQueueClass q => q -> RecipientId
recipientId q
sq) SndPublicAuthKey
sKey)
    where
      qr :: TVar (Maybe QueueRec)
qr = q -> TVar (Maybe QueueRec)
forall q. StoreQueueClass q => q -> TVar (Maybe QueueRec)
queueRec q
sq
      secure :: QueueRec -> STM (Either ErrorType ())
secure QueueRec
q = case QueueRec -> Maybe SndPublicAuthKey
senderKey QueueRec
q of
        Just SndPublicAuthKey
k -> Either ErrorType () -> STM (Either ErrorType ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrorType () -> STM (Either ErrorType ()))
-> Either ErrorType () -> STM (Either ErrorType ())
forall a b. (a -> b) -> a -> b
$ if SndPublicAuthKey
sKey SndPublicAuthKey -> SndPublicAuthKey -> Bool
forall a. Eq a => a -> a -> Bool
== SndPublicAuthKey
k then () -> Either ErrorType ()
forall a b. b -> Either a b
Right () else ErrorType -> Either ErrorType ()
forall a b. a -> Either a b
Left ErrorType
AUTH
        Maybe SndPublicAuthKey
Nothing -> do
          TVar (Maybe QueueRec) -> Maybe QueueRec -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe QueueRec)
qr (Maybe QueueRec -> STM ()) -> Maybe QueueRec -> STM ()
forall a b. (a -> b) -> a -> b
$ QueueRec -> Maybe QueueRec
forall a. a -> Maybe a
Just QueueRec
q {senderKey = Just sKey}
          Either ErrorType () -> STM (Either ErrorType ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrorType () -> STM (Either ErrorType ()))
-> Either ErrorType () -> STM (Either ErrorType ())
forall a b. (a -> b) -> a -> b
$ () -> Either ErrorType ()
forall a b. b -> Either a b
Right ()

  addQueueNotifier :: STMQueueStore q -> q -> NtfCreds -> IO (Either ErrorType (Maybe NtfCreds))
  addQueueNotifier :: STMQueueStore q
-> q -> NtfCreds -> IO (Either ErrorType (Maybe NtfCreds))
addQueueNotifier STMQueueStore q
st q
sq ntfCreds :: NtfCreds
ntfCreds@NtfCreds {$sel:notifierId:NtfCreds :: NtfCreds -> RecipientId
notifierId = RecipientId
nId} =
    STM (Either ErrorType (Maybe NtfCreds))
-> IO (Either ErrorType (Maybe NtfCreds))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TVar (Maybe QueueRec) -> STM (Either ErrorType QueueRec)
readQueueRec TVar (Maybe QueueRec)
qr STM (Either ErrorType QueueRec)
-> (QueueRec -> STM (Either ErrorType (Maybe NtfCreds)))
-> STM (Either ErrorType (Maybe NtfCreds))
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Monad f, Traversable f) =>
m (f a) -> (a -> m (f b)) -> m (f b)
$>>= QueueRec -> STM (Either ErrorType (Maybe NtfCreds))
add)
      IO (Either ErrorType (Maybe NtfCreds))
-> (Maybe NtfCreds -> IO (Either ErrorType (Maybe NtfCreds)))
-> IO (Either ErrorType (Maybe NtfCreds))
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Monad f, Traversable f) =>
m (f a) -> (a -> m (f b)) -> m (f b)
$>>= \Maybe NtfCreds
nc_ -> Maybe NtfCreds
nc_ Maybe NtfCreds
-> IO (Either ErrorType ())
-> IO (Either ErrorType (Maybe NtfCreds))
forall (f :: * -> *) (g :: * -> *) b a.
(Functor f, Functor g) =>
b -> f (g a) -> f (g b)
<$$ Text
-> STMQueueStore q
-> (StoreLog 'WriteMode -> IO ())
-> IO (Either ErrorType ())
forall q.
Text
-> STMQueueStore q
-> (StoreLog 'WriteMode -> IO ())
-> IO (Either ErrorType ())
withLog Text
"addQueueNotifier" STMQueueStore q
st (\StoreLog 'WriteMode
s -> StoreLog 'WriteMode -> RecipientId -> NtfCreds -> IO ()
logAddNotifier StoreLog 'WriteMode
s RecipientId
rId NtfCreds
ntfCreds)
    where
      rId :: RecipientId
rId = q -> RecipientId
forall q. StoreQueueClass q => q -> RecipientId
recipientId q
sq
      qr :: TVar (Maybe QueueRec)
qr = q -> TVar (Maybe QueueRec)
forall q. StoreQueueClass q => q -> TVar (Maybe QueueRec)
queueRec q
sq
      STMQueueStore {TMap RecipientId RecipientId
$sel:notifiers:STMQueueStore :: forall q. STMQueueStore q -> TMap RecipientId RecipientId
notifiers :: TMap RecipientId RecipientId
notifiers} = STMQueueStore q
st
      add :: QueueRec -> STM (Either ErrorType (Maybe NtfCreds))
add QueueRec
q = STM Bool
-> STM (Either ErrorType (Maybe NtfCreds))
-> STM (Either ErrorType (Maybe NtfCreds))
-> STM (Either ErrorType (Maybe NtfCreds))
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (RecipientId -> TMap RecipientId RecipientId -> STM Bool
forall k a. Ord k => k -> TMap k a -> STM Bool
TM.member RecipientId
nId TMap RecipientId RecipientId
notifiers) (Either ErrorType (Maybe NtfCreds)
-> STM (Either ErrorType (Maybe NtfCreds))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrorType (Maybe NtfCreds)
 -> STM (Either ErrorType (Maybe NtfCreds)))
-> Either ErrorType (Maybe NtfCreds)
-> STM (Either ErrorType (Maybe NtfCreds))
forall a b. (a -> b) -> a -> b
$ ErrorType -> Either ErrorType (Maybe NtfCreds)
forall a b. a -> Either a b
Left ErrorType
DUPLICATE_) (STM (Either ErrorType (Maybe NtfCreds))
 -> STM (Either ErrorType (Maybe NtfCreds)))
-> STM (Either ErrorType (Maybe NtfCreds))
-> STM (Either ErrorType (Maybe NtfCreds))
forall a b. (a -> b) -> a -> b
$ do
        Maybe NtfCreds
nc_ <- Maybe NtfCreds
-> (NtfCreds -> STM NtfCreds) -> STM (Maybe NtfCreds)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (QueueRec -> Maybe NtfCreds
notifier QueueRec
q) ((NtfCreds -> STM NtfCreds) -> STM (Maybe NtfCreds))
-> (NtfCreds -> STM NtfCreds) -> STM (Maybe NtfCreds)
forall a b. (a -> b) -> a -> b
$ \NtfCreds
nc -> NtfCreds
nc NtfCreds -> STM () -> STM NtfCreds
forall a b. a -> STM b -> STM a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ STMQueueStore q -> NtfCreds -> STM ()
forall q. STMQueueStore q -> NtfCreds -> STM ()
removeNotifier STMQueueStore q
st NtfCreds
nc
        let !q' :: QueueRec
q' = QueueRec
q {notifier = Just ntfCreds}
        TVar (Maybe QueueRec) -> Maybe QueueRec -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe QueueRec)
qr (Maybe QueueRec -> STM ()) -> Maybe QueueRec -> STM ()
forall a b. (a -> b) -> a -> b
$ QueueRec -> Maybe QueueRec
forall a. a -> Maybe a
Just QueueRec
q'
        RecipientId
-> RecipientId -> TMap RecipientId RecipientId -> STM ()
forall k a. Ord k => k -> a -> TMap k a -> STM ()
TM.insert RecipientId
nId RecipientId
rId TMap RecipientId RecipientId
notifiers
        Either ErrorType (Maybe NtfCreds)
-> STM (Either ErrorType (Maybe NtfCreds))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrorType (Maybe NtfCreds)
 -> STM (Either ErrorType (Maybe NtfCreds)))
-> Either ErrorType (Maybe NtfCreds)
-> STM (Either ErrorType (Maybe NtfCreds))
forall a b. (a -> b) -> a -> b
$ Maybe NtfCreds -> Either ErrorType (Maybe NtfCreds)
forall a b. b -> Either a b
Right Maybe NtfCreds
nc_

  deleteQueueNotifier :: STMQueueStore q -> q -> IO (Either ErrorType (Maybe NtfCreds))
  deleteQueueNotifier :: STMQueueStore q -> q -> IO (Either ErrorType (Maybe NtfCreds))
deleteQueueNotifier STMQueueStore q
st q
sq =
    TVar (Maybe QueueRec)
-> (QueueRec -> STM (Maybe NtfCreds))
-> IO (Either ErrorType (Maybe NtfCreds))
forall a.
TVar (Maybe QueueRec)
-> (QueueRec -> STM a) -> IO (Either ErrorType a)
withQueueRec TVar (Maybe QueueRec)
qr QueueRec -> STM (Maybe NtfCreds)
delete
      IO (Either ErrorType (Maybe NtfCreds))
-> (Maybe NtfCreds -> IO (Either ErrorType (Maybe NtfCreds)))
-> IO (Either ErrorType (Maybe NtfCreds))
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Monad f, Traversable f) =>
m (f a) -> (a -> m (f b)) -> m (f b)
$>>= (Maybe NtfCreds
-> IO (Either ErrorType ())
-> IO (Either ErrorType (Maybe NtfCreds))
forall (f :: * -> *) (g :: * -> *) b a.
(Functor f, Functor g) =>
b -> f (g a) -> f (g b)
<$$ Text
-> STMQueueStore q
-> (StoreLog 'WriteMode -> IO ())
-> IO (Either ErrorType ())
forall q.
Text
-> STMQueueStore q
-> (StoreLog 'WriteMode -> IO ())
-> IO (Either ErrorType ())
withLog Text
"deleteQueueNotifier" STMQueueStore q
st (StoreLog 'WriteMode -> RecipientId -> IO ()
`logDeleteNotifier` q -> RecipientId
forall q. StoreQueueClass q => q -> RecipientId
recipientId q
sq))
    where
      qr :: TVar (Maybe QueueRec)
qr = q -> TVar (Maybe QueueRec)
forall q. StoreQueueClass q => q -> TVar (Maybe QueueRec)
queueRec q
sq
      delete :: QueueRec -> STM (Maybe NtfCreds)
delete QueueRec
q = Maybe NtfCreds
-> (NtfCreds -> STM NtfCreds) -> STM (Maybe NtfCreds)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (QueueRec -> Maybe NtfCreds
notifier QueueRec
q) ((NtfCreds -> STM NtfCreds) -> STM (Maybe NtfCreds))
-> (NtfCreds -> STM NtfCreds) -> STM (Maybe NtfCreds)
forall a b. (a -> b) -> a -> b
$ \NtfCreds
nc -> do
        STMQueueStore q -> NtfCreds -> STM ()
forall q. STMQueueStore q -> NtfCreds -> STM ()
removeNotifier STMQueueStore q
st NtfCreds
nc
        TVar (Maybe QueueRec) -> Maybe QueueRec -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe QueueRec)
qr (Maybe QueueRec -> STM ()) -> Maybe QueueRec -> STM ()
forall a b. (a -> b) -> a -> b
$ QueueRec -> Maybe QueueRec
forall a. a -> Maybe a
Just QueueRec
q {notifier = Nothing}
        NtfCreds -> STM NtfCreds
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NtfCreds
nc

  suspendQueue :: STMQueueStore q -> q -> IO (Either ErrorType ())
  suspendQueue :: STMQueueStore q -> q -> IO (Either ErrorType ())
suspendQueue STMQueueStore q
st q
sq =
    TVar (Maybe QueueRec)
-> ServerEntityStatus -> IO (Either ErrorType ())
setStatus (q -> TVar (Maybe QueueRec)
forall q. StoreQueueClass q => q -> TVar (Maybe QueueRec)
queueRec q
sq) ServerEntityStatus
EntityOff
      IO (Either ErrorType ())
-> IO (Either ErrorType ()) -> IO (Either ErrorType ())
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Monad f, Traversable f) =>
m (f a) -> m (f b) -> m (f b)
$>> Text
-> STMQueueStore q
-> (StoreLog 'WriteMode -> IO ())
-> IO (Either ErrorType ())
forall q.
Text
-> STMQueueStore q
-> (StoreLog 'WriteMode -> IO ())
-> IO (Either ErrorType ())
withLog Text
"suspendQueue" STMQueueStore q
st (StoreLog 'WriteMode -> RecipientId -> IO ()
`logSuspendQueue` q -> RecipientId
forall q. StoreQueueClass q => q -> RecipientId
recipientId q
sq)

  blockQueue :: STMQueueStore q -> q -> BlockingInfo -> IO (Either ErrorType ())
  blockQueue :: STMQueueStore q -> q -> BlockingInfo -> IO (Either ErrorType ())
blockQueue STMQueueStore q
st q
sq BlockingInfo
info =
    TVar (Maybe QueueRec)
-> ServerEntityStatus -> IO (Either ErrorType ())
setStatus (q -> TVar (Maybe QueueRec)
forall q. StoreQueueClass q => q -> TVar (Maybe QueueRec)
queueRec q
sq) (BlockingInfo -> ServerEntityStatus
EntityBlocked BlockingInfo
info)
      IO (Either ErrorType ())
-> IO (Either ErrorType ()) -> IO (Either ErrorType ())
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Monad f, Traversable f) =>
m (f a) -> m (f b) -> m (f b)
$>> Text
-> STMQueueStore q
-> (StoreLog 'WriteMode -> IO ())
-> IO (Either ErrorType ())
forall q.
Text
-> STMQueueStore q
-> (StoreLog 'WriteMode -> IO ())
-> IO (Either ErrorType ())
withLog Text
"blockQueue" STMQueueStore q
st (\StoreLog 'WriteMode
sl -> StoreLog 'WriteMode -> RecipientId -> BlockingInfo -> IO ()
logBlockQueue StoreLog 'WriteMode
sl (q -> RecipientId
forall q. StoreQueueClass q => q -> RecipientId
recipientId q
sq) BlockingInfo
info)

  unblockQueue :: STMQueueStore q -> q -> IO (Either ErrorType ())
  unblockQueue :: STMQueueStore q -> q -> IO (Either ErrorType ())
unblockQueue STMQueueStore q
st q
sq =
    TVar (Maybe QueueRec)
-> ServerEntityStatus -> IO (Either ErrorType ())
setStatus (q -> TVar (Maybe QueueRec)
forall q. StoreQueueClass q => q -> TVar (Maybe QueueRec)
queueRec q
sq) ServerEntityStatus
EntityActive
      IO (Either ErrorType ())
-> IO (Either ErrorType ()) -> IO (Either ErrorType ())
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Monad f, Traversable f) =>
m (f a) -> m (f b) -> m (f b)
$>> Text
-> STMQueueStore q
-> (StoreLog 'WriteMode -> IO ())
-> IO (Either ErrorType ())
forall q.
Text
-> STMQueueStore q
-> (StoreLog 'WriteMode -> IO ())
-> IO (Either ErrorType ())
withLog Text
"unblockQueue" STMQueueStore q
st (StoreLog 'WriteMode -> RecipientId -> IO ()
`logUnblockQueue` q -> RecipientId
forall q. StoreQueueClass q => q -> RecipientId
recipientId q
sq)

  updateQueueTime :: STMQueueStore q -> q -> SystemDate -> IO (Either ErrorType QueueRec)
  updateQueueTime :: STMQueueStore q
-> q -> SystemDate -> IO (Either ErrorType QueueRec)
updateQueueTime STMQueueStore q
st q
sq SystemDate
t = TVar (Maybe QueueRec)
-> (QueueRec -> STM (QueueRec, Bool))
-> IO (Either ErrorType (QueueRec, Bool))
forall a.
TVar (Maybe QueueRec)
-> (QueueRec -> STM a) -> IO (Either ErrorType a)
withQueueRec TVar (Maybe QueueRec)
qr QueueRec -> STM (QueueRec, Bool)
update IO (Either ErrorType (QueueRec, Bool))
-> ((QueueRec, Bool) -> IO (Either ErrorType QueueRec))
-> IO (Either ErrorType QueueRec)
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Monad f, Traversable f) =>
m (f a) -> (a -> m (f b)) -> m (f b)
$>>= (QueueRec, Bool) -> IO (Either ErrorType QueueRec)
log'
    where
      qr :: TVar (Maybe QueueRec)
qr = q -> TVar (Maybe QueueRec)
forall q. StoreQueueClass q => q -> TVar (Maybe QueueRec)
queueRec q
sq
      update :: QueueRec -> STM (QueueRec, Bool)
update q :: QueueRec
q@QueueRec {Maybe SystemDate
updatedAt :: Maybe SystemDate
$sel:updatedAt:QueueRec :: QueueRec -> Maybe SystemDate
updatedAt}
        | Maybe SystemDate
updatedAt Maybe SystemDate -> Maybe SystemDate -> Bool
forall a. Eq a => a -> a -> Bool
== SystemDate -> Maybe SystemDate
forall a. a -> Maybe a
Just SystemDate
t = (QueueRec, Bool) -> STM (QueueRec, Bool)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (QueueRec
q, Bool
False)
        | Bool
otherwise =
            let !q' :: QueueRec
q' = QueueRec
q {updatedAt = Just t}
             in TVar (Maybe QueueRec) -> Maybe QueueRec -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe QueueRec)
qr (QueueRec -> Maybe QueueRec
forall a. a -> Maybe a
Just QueueRec
q') STM () -> (QueueRec, Bool) -> STM (QueueRec, Bool)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (QueueRec
q', Bool
True)
      log' :: (QueueRec, Bool) -> IO (Either ErrorType QueueRec)
log' (QueueRec
q, Bool
changed)
        | Bool
changed = QueueRec
q QueueRec
-> IO (Either ErrorType ()) -> IO (Either ErrorType QueueRec)
forall (f :: * -> *) (g :: * -> *) b a.
(Functor f, Functor g) =>
b -> f (g a) -> f (g b)
<$$ Text
-> STMQueueStore q
-> (StoreLog 'WriteMode -> IO ())
-> IO (Either ErrorType ())
forall q.
Text
-> STMQueueStore q
-> (StoreLog 'WriteMode -> IO ())
-> IO (Either ErrorType ())
withLog Text
"updateQueueTime" STMQueueStore q
st (\StoreLog 'WriteMode
sl -> StoreLog 'WriteMode -> RecipientId -> SystemDate -> IO ()
logUpdateQueueTime StoreLog 'WriteMode
sl (q -> RecipientId
forall q. StoreQueueClass q => q -> RecipientId
recipientId q
sq) SystemDate
t)
        | Bool
otherwise = Either ErrorType QueueRec -> IO (Either ErrorType QueueRec)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrorType QueueRec -> IO (Either ErrorType QueueRec))
-> Either ErrorType QueueRec -> IO (Either ErrorType QueueRec)
forall a b. (a -> b) -> a -> b
$ QueueRec -> Either ErrorType QueueRec
forall a b. b -> Either a b
Right QueueRec
q

  deleteStoreQueue :: STMQueueStore q -> q -> IO (Either ErrorType QueueRec)
  deleteStoreQueue :: STMQueueStore q -> q -> IO (Either ErrorType QueueRec)
deleteStoreQueue STMQueueStore q
st q
sq =
    TVar (Maybe QueueRec)
-> (QueueRec -> STM QueueRec) -> IO (Either ErrorType QueueRec)
forall a.
TVar (Maybe QueueRec)
-> (QueueRec -> STM a) -> IO (Either ErrorType a)
withQueueRec TVar (Maybe QueueRec)
qr QueueRec -> STM QueueRec
delete
      IO (Either ErrorType QueueRec)
-> (QueueRec -> IO (Either ErrorType QueueRec))
-> IO (Either ErrorType QueueRec)
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Monad f, Traversable f) =>
m (f a) -> (a -> m (f b)) -> m (f b)
$>>= (QueueRec
-> IO (Either ErrorType ()) -> IO (Either ErrorType QueueRec)
forall (f :: * -> *) (g :: * -> *) b a.
(Functor f, Functor g) =>
b -> f (g a) -> f (g b)
<$$ Text
-> STMQueueStore q
-> (StoreLog 'WriteMode -> IO ())
-> IO (Either ErrorType ())
forall q.
Text
-> STMQueueStore q
-> (StoreLog 'WriteMode -> IO ())
-> IO (Either ErrorType ())
withLog Text
"deleteStoreQueue" STMQueueStore q
st (StoreLog 'WriteMode -> RecipientId -> IO ()
`logDeleteQueue` RecipientId
rId))
    where
      rId :: RecipientId
rId = q -> RecipientId
forall q. StoreQueueClass q => q -> RecipientId
recipientId q
sq
      qr :: TVar (Maybe QueueRec)
qr = q -> TVar (Maybe QueueRec)
forall q. StoreQueueClass q => q -> TVar (Maybe QueueRec)
queueRec q
sq
      delete :: QueueRec -> STM QueueRec
delete q :: QueueRec
q@QueueRec {RecipientId
$sel:senderId:QueueRec :: QueueRec -> RecipientId
senderId :: RecipientId
senderId, Maybe RecipientId
$sel:rcvServiceId:QueueRec :: QueueRec -> Maybe RecipientId
rcvServiceId :: Maybe RecipientId
rcvServiceId} = do
        TVar (Maybe QueueRec) -> Maybe QueueRec -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe QueueRec)
qr Maybe QueueRec
forall a. Maybe a
Nothing
        RecipientId -> TMap RecipientId RecipientId -> STM ()
forall k a. Ord k => k -> TMap k a -> STM ()
TM.delete RecipientId
senderId (TMap RecipientId RecipientId -> STM ())
-> TMap RecipientId RecipientId -> STM ()
forall a b. (a -> b) -> a -> b
$ STMQueueStore q -> TMap RecipientId RecipientId
forall q. STMQueueStore q -> TMap RecipientId RecipientId
senders STMQueueStore q
st
        (RecipientId -> STM ()) -> Maybe RecipientId -> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (STMQueueStore q
-> (STMService -> TVar (Set RecipientId))
-> RecipientId
-> RecipientId
-> STM ()
forall q.
STMQueueStore q
-> (STMService -> TVar (Set RecipientId))
-> RecipientId
-> RecipientId
-> STM ()
removeServiceQueue STMQueueStore q
st STMService -> TVar (Set RecipientId)
serviceRcvQueues RecipientId
rId) Maybe RecipientId
rcvServiceId
        (NtfCreds -> STM ()) -> Maybe NtfCreds -> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (STMQueueStore q -> NtfCreds -> STM ()
forall q. STMQueueStore q -> NtfCreds -> STM ()
removeNotifier STMQueueStore q
st) (Maybe NtfCreds -> STM ()) -> Maybe NtfCreds -> STM ()
forall a b. (a -> b) -> a -> b
$ QueueRec -> Maybe NtfCreds
notifier QueueRec
q
        QueueRec -> STM QueueRec
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure QueueRec
q

  getCreateService :: STMQueueStore q -> ServiceRec -> IO (Either ErrorType ServiceId)
  getCreateService :: STMQueueStore q -> ServiceRec -> IO (Either ErrorType RecipientId)
getCreateService STMQueueStore q
st sr :: ServiceRec
sr@ServiceRec {$sel:serviceId:ServiceRec :: ServiceRec -> RecipientId
serviceId = RecipientId
newSrvId, SMPServiceRole
$sel:serviceRole:ServiceRec :: ServiceRec -> SMPServiceRole
serviceRole :: SMPServiceRole
serviceRole, $sel:serviceCertHash:ServiceRec :: ServiceRec -> Fingerprint
serviceCertHash = XV.Fingerprint CertFingerprint
fp} =
    CertFingerprint
-> TMap CertFingerprint RecipientId -> IO (Maybe RecipientId)
forall k a. Ord k => k -> TMap k a -> IO (Maybe a)
TM.lookupIO CertFingerprint
fp TMap CertFingerprint RecipientId
serviceCerts
      IO (Maybe RecipientId)
-> (Maybe RecipientId -> IO (Either ErrorType (RecipientId, Bool)))
-> IO (Either ErrorType (RecipientId, Bool))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO (Either ErrorType (RecipientId, Bool))
-> (RecipientId -> IO (Either ErrorType (RecipientId, Bool)))
-> Maybe RecipientId
-> IO (Either ErrorType (RecipientId, Bool))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        (STM (Either ErrorType (RecipientId, Bool))
-> IO (Either ErrorType (RecipientId, Bool))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Either ErrorType (RecipientId, Bool))
 -> IO (Either ErrorType (RecipientId, Bool)))
-> STM (Either ErrorType (RecipientId, Bool))
-> IO (Either ErrorType (RecipientId, Bool))
forall a b. (a -> b) -> a -> b
$ CertFingerprint
-> TMap CertFingerprint RecipientId -> STM (Maybe RecipientId)
forall k a. Ord k => k -> TMap k a -> STM (Maybe a)
TM.lookup CertFingerprint
fp TMap CertFingerprint RecipientId
serviceCerts STM (Maybe RecipientId)
-> (Maybe RecipientId
    -> STM (Either ErrorType (RecipientId, Bool)))
-> STM (Either ErrorType (RecipientId, Bool))
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STM (Either ErrorType (RecipientId, Bool))
-> (RecipientId -> STM (Either ErrorType (RecipientId, Bool)))
-> Maybe RecipientId
-> STM (Either ErrorType (RecipientId, Bool))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe STM (Either ErrorType (RecipientId, Bool))
newService RecipientId -> STM (Either ErrorType (RecipientId, Bool))
checkService)
        (STM (Either ErrorType (RecipientId, Bool))
-> IO (Either ErrorType (RecipientId, Bool))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Either ErrorType (RecipientId, Bool))
 -> IO (Either ErrorType (RecipientId, Bool)))
-> (RecipientId -> STM (Either ErrorType (RecipientId, Bool)))
-> RecipientId
-> IO (Either ErrorType (RecipientId, Bool))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecipientId -> STM (Either ErrorType (RecipientId, Bool))
checkService)
      IO (Either ErrorType (RecipientId, Bool))
-> ((RecipientId, Bool) -> IO (Either ErrorType RecipientId))
-> IO (Either ErrorType RecipientId)
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Monad f, Traversable f) =>
m (f a) -> (a -> m (f b)) -> m (f b)
$>>= \(RecipientId
serviceId, Bool
new) ->
        if Bool
new
          then RecipientId
serviceId RecipientId
-> IO (Either ErrorType ()) -> IO (Either ErrorType RecipientId)
forall (f :: * -> *) (g :: * -> *) b a.
(Functor f, Functor g) =>
b -> f (g a) -> f (g b)
<$$ Text
-> STMQueueStore q
-> (StoreLog 'WriteMode -> IO ())
-> IO (Either ErrorType ())
forall q.
Text
-> STMQueueStore q
-> (StoreLog 'WriteMode -> IO ())
-> IO (Either ErrorType ())
withLog Text
"getCreateService" STMQueueStore q
st (StoreLog 'WriteMode -> ServiceRec -> IO ()
`logNewService` ServiceRec
sr)
          else Either ErrorType RecipientId -> IO (Either ErrorType RecipientId)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrorType RecipientId -> IO (Either ErrorType RecipientId))
-> Either ErrorType RecipientId
-> IO (Either ErrorType RecipientId)
forall a b. (a -> b) -> a -> b
$ RecipientId -> Either ErrorType RecipientId
forall a b. b -> Either a b
Right RecipientId
serviceId
    where
      STMQueueStore {TMap RecipientId STMService
$sel:services:STMQueueStore :: forall q. STMQueueStore q -> TMap RecipientId STMService
services :: TMap RecipientId STMService
services, TMap CertFingerprint RecipientId
$sel:serviceCerts:STMQueueStore :: forall q. STMQueueStore q -> TMap CertFingerprint RecipientId
serviceCerts :: TMap CertFingerprint RecipientId
serviceCerts} = STMQueueStore q
st
      checkService :: RecipientId -> STM (Either ErrorType (RecipientId, Bool))
checkService RecipientId
sId =
        RecipientId
-> TMap RecipientId STMService -> STM (Maybe STMService)
forall k a. Ord k => k -> TMap k a -> STM (Maybe a)
TM.lookup RecipientId
sId TMap RecipientId STMService
services STM (Maybe STMService)
-> (Maybe STMService -> STM (Either ErrorType (RecipientId, Bool)))
-> STM (Either ErrorType (RecipientId, Bool))
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Just STMService {$sel:serviceRec:STMService :: STMService -> ServiceRec
serviceRec = ServiceRec {RecipientId
$sel:serviceId:ServiceRec :: ServiceRec -> RecipientId
serviceId :: RecipientId
serviceId, $sel:serviceRole:ServiceRec :: ServiceRec -> SMPServiceRole
serviceRole = SMPServiceRole
role}}
            | SMPServiceRole
role SMPServiceRole -> SMPServiceRole -> Bool
forall a. Eq a => a -> a -> Bool
== SMPServiceRole
serviceRole -> Either ErrorType (RecipientId, Bool)
-> STM (Either ErrorType (RecipientId, Bool))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrorType (RecipientId, Bool)
 -> STM (Either ErrorType (RecipientId, Bool)))
-> Either ErrorType (RecipientId, Bool)
-> STM (Either ErrorType (RecipientId, Bool))
forall a b. (a -> b) -> a -> b
$ (RecipientId, Bool) -> Either ErrorType (RecipientId, Bool)
forall a b. b -> Either a b
Right (RecipientId
serviceId, Bool
False)
            | Bool
otherwise -> Either ErrorType (RecipientId, Bool)
-> STM (Either ErrorType (RecipientId, Bool))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrorType (RecipientId, Bool)
 -> STM (Either ErrorType (RecipientId, Bool)))
-> Either ErrorType (RecipientId, Bool)
-> STM (Either ErrorType (RecipientId, Bool))
forall a b. (a -> b) -> a -> b
$ ErrorType -> Either ErrorType (RecipientId, Bool)
forall a b. a -> Either a b
Left (ErrorType -> Either ErrorType (RecipientId, Bool))
-> ErrorType -> Either ErrorType (RecipientId, Bool)
forall a b. (a -> b) -> a -> b
$ ErrorType
SERVICE
          Maybe STMService
Nothing -> STM (Either ErrorType (RecipientId, Bool))
newService_
      newService :: STM (Either ErrorType (RecipientId, Bool))
newService = STM Bool
-> STM (Either ErrorType (RecipientId, Bool))
-> STM (Either ErrorType (RecipientId, Bool))
-> STM (Either ErrorType (RecipientId, Bool))
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (RecipientId -> TMap RecipientId STMService -> STM Bool
forall k a. Ord k => k -> TMap k a -> STM Bool
TM.member RecipientId
newSrvId TMap RecipientId STMService
services) (Either ErrorType (RecipientId, Bool)
-> STM (Either ErrorType (RecipientId, Bool))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrorType (RecipientId, Bool)
 -> STM (Either ErrorType (RecipientId, Bool)))
-> Either ErrorType (RecipientId, Bool)
-> STM (Either ErrorType (RecipientId, Bool))
forall a b. (a -> b) -> a -> b
$ ErrorType -> Either ErrorType (RecipientId, Bool)
forall a b. a -> Either a b
Left ErrorType
DUPLICATE_) STM (Either ErrorType (RecipientId, Bool))
newService_
      newService_ :: STM (Either ErrorType (RecipientId, Bool))
newService_ = do
        RecipientId
-> STM STMService -> TMap RecipientId STMService -> STM ()
forall k a. Ord k => k -> STM a -> TMap k a -> STM ()
TM.insertM RecipientId
newSrvId STM STMService
newSTMService TMap RecipientId STMService
services
        CertFingerprint
-> RecipientId -> TMap CertFingerprint RecipientId -> STM ()
forall k a. Ord k => k -> a -> TMap k a -> STM ()
TM.insert CertFingerprint
fp RecipientId
newSrvId TMap CertFingerprint RecipientId
serviceCerts
        Either ErrorType (RecipientId, Bool)
-> STM (Either ErrorType (RecipientId, Bool))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrorType (RecipientId, Bool)
 -> STM (Either ErrorType (RecipientId, Bool)))
-> Either ErrorType (RecipientId, Bool)
-> STM (Either ErrorType (RecipientId, Bool))
forall a b. (a -> b) -> a -> b
$ (RecipientId, Bool) -> Either ErrorType (RecipientId, Bool)
forall a b. b -> Either a b
Right (RecipientId
newSrvId, Bool
True)
      newSTMService :: STM STMService
newSTMService = do
        TVar (Set RecipientId)
serviceRcvQueues <- Set RecipientId -> STM (TVar (Set RecipientId))
forall a. a -> STM (TVar a)
newTVar Set RecipientId
forall a. Set a
S.empty
        TVar (Set RecipientId)
serviceNtfQueues <- Set RecipientId -> STM (TVar (Set RecipientId))
forall a. a -> STM (TVar a)
newTVar Set RecipientId
forall a. Set a
S.empty
        STMService -> STM STMService
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure STMService {$sel:serviceRec:STMService :: ServiceRec
serviceRec = ServiceRec
sr, TVar (Set RecipientId)
$sel:serviceRcvQueues:STMService :: TVar (Set RecipientId)
serviceRcvQueues :: TVar (Set RecipientId)
serviceRcvQueues, TVar (Set RecipientId)
$sel:serviceNtfQueues:STMService :: TVar (Set RecipientId)
serviceNtfQueues :: TVar (Set RecipientId)
serviceNtfQueues}

  setQueueService :: (PartyI p, ServiceParty p) => STMQueueStore q -> q -> SParty p -> Maybe ServiceId -> IO (Either ErrorType ())
  setQueueService :: forall (p :: Party).
(PartyI p, ServiceParty p) =>
STMQueueStore q
-> q -> SParty p -> Maybe RecipientId -> IO (Either ErrorType ())
setQueueService STMQueueStore q
st q
sq SParty p
party Maybe RecipientId
serviceId =
    STM (Either ErrorType ()) -> IO (Either ErrorType ())
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TVar (Maybe QueueRec) -> STM (Either ErrorType QueueRec)
readQueueRec TVar (Maybe QueueRec)
qr STM (Either ErrorType QueueRec)
-> (QueueRec -> STM (Either ErrorType ()))
-> STM (Either ErrorType ())
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Monad f, Traversable f) =>
m (f a) -> (a -> m (f b)) -> m (f b)
$>>= QueueRec -> STM (Either ErrorType ())
setService)
      IO (Either ErrorType ())
-> IO (Either ErrorType ()) -> IO (Either ErrorType ())
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Monad f, Traversable f) =>
m (f a) -> m (f b) -> m (f b)
$>> Text
-> STMQueueStore q
-> (StoreLog 'WriteMode -> IO ())
-> IO (Either ErrorType ())
forall q.
Text
-> STMQueueStore q
-> (StoreLog 'WriteMode -> IO ())
-> IO (Either ErrorType ())
withLog Text
"setQueueService" STMQueueStore q
st (\StoreLog 'WriteMode
sl -> StoreLog 'WriteMode
-> RecipientId -> SParty p -> Maybe RecipientId -> IO ()
forall (p :: Party).
(PartyI p, ServiceParty p) =>
StoreLog 'WriteMode
-> RecipientId -> SParty p -> Maybe RecipientId -> IO ()
logQueueService StoreLog 'WriteMode
sl RecipientId
rId SParty p
party Maybe RecipientId
serviceId)
    where
      qr :: TVar (Maybe QueueRec)
qr = q -> TVar (Maybe QueueRec)
forall q. StoreQueueClass q => q -> TVar (Maybe QueueRec)
queueRec q
sq
      rId :: RecipientId
rId = q -> RecipientId
forall q. StoreQueueClass q => q -> RecipientId
recipientId q
sq
      setService :: QueueRec -> STM (Either ErrorType ())
      setService :: QueueRec -> STM (Either ErrorType ())
setService q :: QueueRec
q@QueueRec {$sel:rcvServiceId:QueueRec :: QueueRec -> Maybe RecipientId
rcvServiceId = Maybe RecipientId
prevSrvId} = case SParty p
party of
        SParty p
SRecipientService
          | Maybe RecipientId
prevSrvId Maybe RecipientId -> Maybe RecipientId -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe RecipientId
serviceId -> Either ErrorType () -> STM (Either ErrorType ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrorType () -> STM (Either ErrorType ()))
-> Either ErrorType () -> STM (Either ErrorType ())
forall a b. (a -> b) -> a -> b
$ () -> Either ErrorType ()
forall a b. b -> Either a b
Right ()
          | Bool
otherwise -> do
              (STMService -> TVar (Set RecipientId))
-> RecipientId -> Maybe RecipientId -> STM ()
updateServiceQueues STMService -> TVar (Set RecipientId)
serviceRcvQueues RecipientId
rId Maybe RecipientId
prevSrvId
              let !q' :: Maybe QueueRec
q' = QueueRec -> Maybe QueueRec
forall a. a -> Maybe a
Just QueueRec
q {rcvServiceId = serviceId}
              TVar (Maybe QueueRec) -> Maybe QueueRec -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe QueueRec)
qr Maybe QueueRec
q' STM () -> Either ErrorType () -> STM (Either ErrorType ())
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> () -> Either ErrorType ()
forall a b. b -> Either a b
Right ()
        SParty p
SNotifierService -> case QueueRec -> Maybe NtfCreds
notifier QueueRec
q of
          Maybe NtfCreds
Nothing -> Either ErrorType () -> STM (Either ErrorType ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrorType () -> STM (Either ErrorType ()))
-> Either ErrorType () -> STM (Either ErrorType ())
forall a b. (a -> b) -> a -> b
$ ErrorType -> Either ErrorType ()
forall a b. a -> Either a b
Left ErrorType
AUTH
          Just nc :: NtfCreds
nc@NtfCreds {$sel:notifierId:NtfCreds :: NtfCreds -> RecipientId
notifierId = RecipientId
nId, $sel:ntfServiceId:NtfCreds :: NtfCreds -> Maybe RecipientId
ntfServiceId = Maybe RecipientId
prevNtfSrvId}
            | Maybe RecipientId
prevNtfSrvId Maybe RecipientId -> Maybe RecipientId -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe RecipientId
serviceId -> Either ErrorType () -> STM (Either ErrorType ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrorType () -> STM (Either ErrorType ()))
-> Either ErrorType () -> STM (Either ErrorType ())
forall a b. (a -> b) -> a -> b
$ () -> Either ErrorType ()
forall a b. b -> Either a b
Right ()
            | Bool
otherwise -> do
                let !q' :: Maybe QueueRec
q' = QueueRec -> Maybe QueueRec
forall a. a -> Maybe a
Just QueueRec
q {notifier = Just nc {ntfServiceId = serviceId}}
                (STMService -> TVar (Set RecipientId))
-> RecipientId -> Maybe RecipientId -> STM ()
updateServiceQueues STMService -> TVar (Set RecipientId)
serviceNtfQueues RecipientId
nId Maybe RecipientId
prevNtfSrvId
                TVar (Maybe QueueRec) -> Maybe QueueRec -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe QueueRec)
qr Maybe QueueRec
q' STM () -> Either ErrorType () -> STM (Either ErrorType ())
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> () -> Either ErrorType ()
forall a b. b -> Either a b
Right ()
      updateServiceQueues :: (STMService -> TVar (Set QueueId)) -> QueueId -> Maybe ServiceId -> STM ()
      updateServiceQueues :: (STMService -> TVar (Set RecipientId))
-> RecipientId -> Maybe RecipientId -> STM ()
updateServiceQueues STMService -> TVar (Set RecipientId)
serviceSel RecipientId
qId Maybe RecipientId
prevSrvId = do
        (RecipientId -> STM ()) -> Maybe RecipientId -> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (STMQueueStore q
-> (STMService -> TVar (Set RecipientId))
-> RecipientId
-> RecipientId
-> STM ()
forall q.
STMQueueStore q
-> (STMService -> TVar (Set RecipientId))
-> RecipientId
-> RecipientId
-> STM ()
removeServiceQueue STMQueueStore q
st STMService -> TVar (Set RecipientId)
serviceSel RecipientId
qId) Maybe RecipientId
prevSrvId
        (RecipientId -> STM ()) -> Maybe RecipientId -> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (STMQueueStore q
-> (STMService -> TVar (Set RecipientId))
-> RecipientId
-> RecipientId
-> STM ()
forall q.
STMQueueStore q
-> (STMService -> TVar (Set RecipientId))
-> RecipientId
-> RecipientId
-> STM ()
addServiceQueue STMQueueStore q
st STMService -> TVar (Set RecipientId)
serviceSel RecipientId
qId) Maybe RecipientId
serviceId

  getQueueNtfServices :: STMQueueStore q -> [(NotifierId, a)] -> IO (Either ErrorType ([(Maybe ServiceId, [(NotifierId, a)])], [(NotifierId, a)]))
  getQueueNtfServices :: forall a.
STMQueueStore q
-> [(RecipientId, a)]
-> IO
     (Either
        ErrorType
        ([(Maybe RecipientId, [(RecipientId, a)])], [(RecipientId, a)]))
getQueueNtfServices STMQueueStore q
st [(RecipientId, a)]
ntfs = do
    Map RecipientId STMService
ss <- TMap RecipientId STMService -> IO (Map RecipientId STMService)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (STMQueueStore q -> TMap RecipientId STMService
forall q. STMQueueStore q -> TMap RecipientId STMService
services STMQueueStore q
st)
    ([(Maybe RecipientId, [(RecipientId, a)])]
ssNtfs, [(RecipientId, a)]
noServiceNtfs) <- if Map RecipientId STMService -> Bool
forall k a. Map k a -> Bool
M.null Map RecipientId STMService
ss then ([(Maybe RecipientId, [(RecipientId, a)])], [(RecipientId, a)])
-> IO
     ([(Maybe RecipientId, [(RecipientId, a)])], [(RecipientId, a)])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [(RecipientId, a)]
ntfs) else (([(Maybe RecipientId, [(RecipientId, a)])], [(RecipientId, a)])
 -> (RecipientId, STMService)
 -> IO
      ([(Maybe RecipientId, [(RecipientId, a)])], [(RecipientId, a)]))
-> ([(Maybe RecipientId, [(RecipientId, a)])], [(RecipientId, a)])
-> [(RecipientId, STMService)]
-> IO
     ([(Maybe RecipientId, [(RecipientId, a)])], [(RecipientId, a)])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ([(Maybe RecipientId, [(RecipientId, a)])], [(RecipientId, a)])
-> (RecipientId, STMService)
-> IO
     ([(Maybe RecipientId, [(RecipientId, a)])], [(RecipientId, a)])
forall {m :: * -> *} {a} {b}.
MonadIO m =>
([(Maybe a, [(RecipientId, b)])], [(RecipientId, b)])
-> (a, STMService)
-> m ([(Maybe a, [(RecipientId, b)])], [(RecipientId, b)])
addService ([], [(RecipientId, a)]
ntfs) (Map RecipientId STMService -> [(RecipientId, STMService)]
forall k a. Map k a -> [(k, a)]
M.assocs Map RecipientId STMService
ss)
    Map RecipientId RecipientId
ns <- TMap RecipientId RecipientId -> IO (Map RecipientId RecipientId)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (STMQueueStore q -> TMap RecipientId RecipientId
forall q. STMQueueStore q -> TMap RecipientId RecipientId
notifiers STMQueueStore q
st)
    let ([(RecipientId, a)]
ntfs', [(RecipientId, a)]
deleteNtfs) = ((RecipientId, a) -> Bool)
-> [(RecipientId, a)] -> ([(RecipientId, a)], [(RecipientId, a)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\(RecipientId
nId, a
_) -> RecipientId -> Map RecipientId RecipientId -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member RecipientId
nId Map RecipientId RecipientId
ns) [(RecipientId, a)]
noServiceNtfs
        ssNtfs' :: [(Maybe RecipientId, [(RecipientId, a)])]
ssNtfs' = (Maybe RecipientId
forall a. Maybe a
Nothing, [(RecipientId, a)]
ntfs') (Maybe RecipientId, [(RecipientId, a)])
-> [(Maybe RecipientId, [(RecipientId, a)])]
-> [(Maybe RecipientId, [(RecipientId, a)])]
forall a. a -> [a] -> [a]
: [(Maybe RecipientId, [(RecipientId, a)])]
ssNtfs
    Either
  ErrorType
  ([(Maybe RecipientId, [(RecipientId, a)])], [(RecipientId, a)])
-> IO
     (Either
        ErrorType
        ([(Maybe RecipientId, [(RecipientId, a)])], [(RecipientId, a)]))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
   ErrorType
   ([(Maybe RecipientId, [(RecipientId, a)])], [(RecipientId, a)])
 -> IO
      (Either
         ErrorType
         ([(Maybe RecipientId, [(RecipientId, a)])], [(RecipientId, a)])))
-> Either
     ErrorType
     ([(Maybe RecipientId, [(RecipientId, a)])], [(RecipientId, a)])
-> IO
     (Either
        ErrorType
        ([(Maybe RecipientId, [(RecipientId, a)])], [(RecipientId, a)]))
forall a b. (a -> b) -> a -> b
$ ([(Maybe RecipientId, [(RecipientId, a)])], [(RecipientId, a)])
-> Either
     ErrorType
     ([(Maybe RecipientId, [(RecipientId, a)])], [(RecipientId, a)])
forall a b. b -> Either a b
Right ([(Maybe RecipientId, [(RecipientId, a)])]
ssNtfs', [(RecipientId, a)]
deleteNtfs)
    where
      addService :: ([(Maybe a, [(RecipientId, b)])], [(RecipientId, b)])
-> (a, STMService)
-> m ([(Maybe a, [(RecipientId, b)])], [(RecipientId, b)])
addService ([(Maybe a, [(RecipientId, b)])]
ssNtfs, [(RecipientId, b)]
ntfs') (a
serviceId, STMService
s) = do
        Set RecipientId
snIds <- TVar (Set RecipientId) -> m (Set RecipientId)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (TVar (Set RecipientId) -> m (Set RecipientId))
-> TVar (Set RecipientId) -> m (Set RecipientId)
forall a b. (a -> b) -> a -> b
$ STMService -> TVar (Set RecipientId)
serviceNtfQueues STMService
s
        let ([(RecipientId, b)]
sNtfs, [(RecipientId, b)]
restNtfs) = ((RecipientId, b) -> Bool)
-> [(RecipientId, b)] -> ([(RecipientId, b)], [(RecipientId, b)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\(RecipientId
nId, b
_) -> RecipientId -> Set RecipientId -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member RecipientId
nId Set RecipientId
snIds) [(RecipientId, b)]
ntfs'
        ([(Maybe a, [(RecipientId, b)])], [(RecipientId, b)])
-> m ([(Maybe a, [(RecipientId, b)])], [(RecipientId, b)])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a -> Maybe a
forall a. a -> Maybe a
Just a
serviceId, [(RecipientId, b)]
sNtfs) (Maybe a, [(RecipientId, b)])
-> [(Maybe a, [(RecipientId, b)])]
-> [(Maybe a, [(RecipientId, b)])]
forall a. a -> [a] -> [a]
: [(Maybe a, [(RecipientId, b)])]
ssNtfs, [(RecipientId, b)]
restNtfs)

  getServiceQueueCount :: (PartyI p, ServiceParty p) => STMQueueStore q -> SParty p -> ServiceId -> IO (Either ErrorType Int64)
  getServiceQueueCount :: forall (p :: Party).
(PartyI p, ServiceParty p) =>
STMQueueStore q
-> SParty p -> RecipientId -> IO (Either ErrorType Int64)
getServiceQueueCount STMQueueStore q
st SParty p
party RecipientId
serviceId =
    RecipientId -> TMap RecipientId STMService -> IO (Maybe STMService)
forall k a. Ord k => k -> TMap k a -> IO (Maybe a)
TM.lookupIO RecipientId
serviceId (STMQueueStore q -> TMap RecipientId STMService
forall q. STMQueueStore q -> TMap RecipientId STMService
services STMQueueStore q
st) IO (Maybe STMService)
-> (Maybe STMService -> IO (Either ErrorType Int64))
-> IO (Either ErrorType Int64)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
      IO (Either ErrorType Int64)
-> (STMService -> IO (Either ErrorType Int64))
-> Maybe STMService
-> IO (Either ErrorType Int64)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Either ErrorType Int64 -> IO (Either ErrorType Int64)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrorType Int64 -> IO (Either ErrorType Int64))
-> Either ErrorType Int64 -> IO (Either ErrorType Int64)
forall a b. (a -> b) -> a -> b
$ ErrorType -> Either ErrorType Int64
forall a b. a -> Either a b
Left ErrorType
AUTH) ((Set RecipientId -> Either ErrorType Int64)
-> IO (Set RecipientId) -> IO (Either ErrorType Int64)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int64 -> Either ErrorType Int64
forall a b. b -> Either a b
Right (Int64 -> Either ErrorType Int64)
-> (Set RecipientId -> Int64)
-> Set RecipientId
-> Either ErrorType Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int64)
-> (Set RecipientId -> Int) -> Set RecipientId -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set RecipientId -> Int
forall a. Set a -> Int
S.size) (IO (Set RecipientId) -> IO (Either ErrorType Int64))
-> (STMService -> IO (Set RecipientId))
-> STMService
-> IO (Either ErrorType Int64)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar (Set RecipientId) -> IO (Set RecipientId)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (TVar (Set RecipientId) -> IO (Set RecipientId))
-> (STMService -> TVar (Set RecipientId))
-> STMService
-> IO (Set RecipientId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STMService -> TVar (Set RecipientId)
serviceSel)
    where
      serviceSel :: STMService -> TVar (Set QueueId)
      serviceSel :: STMService -> TVar (Set RecipientId)
serviceSel = case SParty p
party of
        SParty p
SRecipientService -> STMService -> TVar (Set RecipientId)
serviceRcvQueues
        SParty p
SNotifierService -> STMService -> TVar (Set RecipientId)
serviceNtfQueues

withQueueRec :: TVar (Maybe QueueRec) -> (QueueRec -> STM a) -> IO (Either ErrorType a)
withQueueRec :: forall a.
TVar (Maybe QueueRec)
-> (QueueRec -> STM a) -> IO (Either ErrorType a)
withQueueRec TVar (Maybe QueueRec)
qr QueueRec -> STM a
a = STM (Either ErrorType a) -> IO (Either ErrorType a)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Either ErrorType a) -> IO (Either ErrorType a))
-> STM (Either ErrorType a) -> IO (Either ErrorType a)
forall a b. (a -> b) -> a -> b
$ TVar (Maybe QueueRec) -> STM (Either ErrorType QueueRec)
readQueueRec TVar (Maybe QueueRec)
qr STM (Either ErrorType QueueRec)
-> (Either ErrorType QueueRec -> STM (Either ErrorType a))
-> STM (Either ErrorType a)
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (QueueRec -> STM a)
-> Either ErrorType QueueRec -> STM (Either ErrorType a)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Either ErrorType a -> m (Either ErrorType b)
mapM QueueRec -> STM a
a

setStatus :: TVar (Maybe QueueRec) -> ServerEntityStatus -> IO (Either ErrorType ())
setStatus :: TVar (Maybe QueueRec)
-> ServerEntityStatus -> IO (Either ErrorType ())
setStatus TVar (Maybe QueueRec)
qr ServerEntityStatus
status =
  STM (Either ErrorType ()) -> IO (Either ErrorType ())
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Either ErrorType ()) -> IO (Either ErrorType ()))
-> STM (Either ErrorType ()) -> IO (Either ErrorType ())
forall a b. (a -> b) -> a -> b
$ TVar (Maybe QueueRec)
-> (Maybe QueueRec -> (Either ErrorType (), Maybe QueueRec))
-> STM (Either ErrorType ())
forall s a. TVar s -> (s -> (a, s)) -> STM a
stateTVar TVar (Maybe QueueRec)
qr ((Maybe QueueRec -> (Either ErrorType (), Maybe QueueRec))
 -> STM (Either ErrorType ()))
-> (Maybe QueueRec -> (Either ErrorType (), Maybe QueueRec))
-> STM (Either ErrorType ())
forall a b. (a -> b) -> a -> b
$ \case
    Just QueueRec
q -> (() -> Either ErrorType ()
forall a b. b -> Either a b
Right (), QueueRec -> Maybe QueueRec
forall a. a -> Maybe a
Just QueueRec
q {status})
    Maybe QueueRec
Nothing -> (ErrorType -> Either ErrorType ()
forall a b. a -> Either a b
Left ErrorType
AUTH, Maybe QueueRec
forall a. Maybe a
Nothing)

addServiceQueue :: STMQueueStore q -> (STMService -> TVar (Set QueueId)) -> QueueId -> ServiceId -> STM ()
addServiceQueue :: forall q.
STMQueueStore q
-> (STMService -> TVar (Set RecipientId))
-> RecipientId
-> RecipientId
-> STM ()
addServiceQueue STMQueueStore q
st STMService -> TVar (Set RecipientId)
serviceSel RecipientId
qId RecipientId
serviceId =
  RecipientId
-> TMap RecipientId STMService -> STM (Maybe STMService)
forall k a. Ord k => k -> TMap k a -> STM (Maybe a)
TM.lookup RecipientId
serviceId (STMQueueStore q -> TMap RecipientId STMService
forall q. STMQueueStore q -> TMap RecipientId STMService
services STMQueueStore q
st) STM (Maybe STMService) -> (Maybe STMService -> STM ()) -> STM ()
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (STMService -> STM ()) -> Maybe STMService -> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\STMService
s -> TVar (Set RecipientId)
-> (Set RecipientId -> Set RecipientId) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (STMService -> TVar (Set RecipientId)
serviceSel STMService
s) (RecipientId -> Set RecipientId -> Set RecipientId
forall a. Ord a => a -> Set a -> Set a
S.insert RecipientId
qId))
{-# INLINE addServiceQueue #-}

removeServiceQueue :: STMQueueStore q -> (STMService -> TVar (Set QueueId)) -> QueueId -> ServiceId -> STM ()
removeServiceQueue :: forall q.
STMQueueStore q
-> (STMService -> TVar (Set RecipientId))
-> RecipientId
-> RecipientId
-> STM ()
removeServiceQueue STMQueueStore q
st STMService -> TVar (Set RecipientId)
serviceSel RecipientId
qId RecipientId
serviceId =
  RecipientId
-> TMap RecipientId STMService -> STM (Maybe STMService)
forall k a. Ord k => k -> TMap k a -> STM (Maybe a)
TM.lookup RecipientId
serviceId (STMQueueStore q -> TMap RecipientId STMService
forall q. STMQueueStore q -> TMap RecipientId STMService
services STMQueueStore q
st) STM (Maybe STMService) -> (Maybe STMService -> STM ()) -> STM ()
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (STMService -> STM ()) -> Maybe STMService -> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\STMService
s -> TVar (Set RecipientId)
-> (Set RecipientId -> Set RecipientId) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (STMService -> TVar (Set RecipientId)
serviceSel STMService
s) (RecipientId -> Set RecipientId -> Set RecipientId
forall a. Ord a => a -> Set a -> Set a
S.delete RecipientId
qId))
{-# INLINE removeServiceQueue #-}

removeNotifier :: STMQueueStore q -> NtfCreds -> STM ()
removeNotifier :: forall q. STMQueueStore q -> NtfCreds -> STM ()
removeNotifier STMQueueStore q
st NtfCreds {$sel:notifierId:NtfCreds :: NtfCreds -> RecipientId
notifierId = RecipientId
nId, Maybe RecipientId
$sel:ntfServiceId:NtfCreds :: NtfCreds -> Maybe RecipientId
ntfServiceId :: Maybe RecipientId
ntfServiceId} = do
  RecipientId -> TMap RecipientId RecipientId -> STM ()
forall k a. Ord k => k -> TMap k a -> STM ()
TM.delete RecipientId
nId (TMap RecipientId RecipientId -> STM ())
-> TMap RecipientId RecipientId -> STM ()
forall a b. (a -> b) -> a -> b
$ STMQueueStore q -> TMap RecipientId RecipientId
forall q. STMQueueStore q -> TMap RecipientId RecipientId
notifiers STMQueueStore q
st
  (RecipientId -> STM ()) -> Maybe RecipientId -> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (STMQueueStore q
-> (STMService -> TVar (Set RecipientId))
-> RecipientId
-> RecipientId
-> STM ()
forall q.
STMQueueStore q
-> (STMService -> TVar (Set RecipientId))
-> RecipientId
-> RecipientId
-> STM ()
removeServiceQueue STMQueueStore q
st STMService -> TVar (Set RecipientId)
serviceNtfQueues RecipientId
nId) Maybe RecipientId
ntfServiceId

readQueueRec :: TVar (Maybe QueueRec) -> STM (Either ErrorType QueueRec)
readQueueRec :: TVar (Maybe QueueRec) -> STM (Either ErrorType QueueRec)
readQueueRec TVar (Maybe QueueRec)
qr = Either ErrorType QueueRec
-> (QueueRec -> Either ErrorType QueueRec)
-> Maybe QueueRec
-> Either ErrorType QueueRec
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ErrorType -> Either ErrorType QueueRec
forall a b. a -> Either a b
Left ErrorType
AUTH) QueueRec -> Either ErrorType QueueRec
forall a b. b -> Either a b
Right (Maybe QueueRec -> Either ErrorType QueueRec)
-> STM (Maybe QueueRec) -> STM (Either ErrorType QueueRec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Maybe QueueRec) -> STM (Maybe QueueRec)
forall a. TVar a -> STM a
readTVar TVar (Maybe QueueRec)
qr
{-# INLINE readQueueRec #-}

readQueueRecIO :: TVar (Maybe QueueRec) -> IO (Either ErrorType QueueRec)
readQueueRecIO :: TVar (Maybe QueueRec) -> IO (Either ErrorType QueueRec)
readQueueRecIO TVar (Maybe QueueRec)
qr = Either ErrorType QueueRec
-> (QueueRec -> Either ErrorType QueueRec)
-> Maybe QueueRec
-> Either ErrorType QueueRec
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ErrorType -> Either ErrorType QueueRec
forall a b. a -> Either a b
Left ErrorType
AUTH) QueueRec -> Either ErrorType QueueRec
forall a b. b -> Either a b
Right (Maybe QueueRec -> Either ErrorType QueueRec)
-> IO (Maybe QueueRec) -> IO (Either ErrorType QueueRec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Maybe QueueRec) -> IO (Maybe QueueRec)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Maybe QueueRec)
qr
{-# INLINE readQueueRecIO #-}

withLog' :: Text -> TVar (Maybe (StoreLog 'WriteMode)) -> (StoreLog 'WriteMode -> IO ()) -> IO (Either ErrorType ())
withLog' :: Text
-> TVar (Maybe (StoreLog 'WriteMode))
-> (StoreLog 'WriteMode -> IO ())
-> IO (Either ErrorType ())
withLog' Text
name TVar (Maybe (StoreLog 'WriteMode))
sl StoreLog 'WriteMode -> IO ()
action =
  TVar (Maybe (StoreLog 'WriteMode))
-> IO (Maybe (StoreLog 'WriteMode))
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Maybe (StoreLog 'WriteMode))
sl
    IO (Maybe (StoreLog 'WriteMode))
-> (Maybe (StoreLog 'WriteMode) -> IO (Either ErrorType ()))
-> IO (Either ErrorType ())
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO (Either ErrorType ())
-> (StoreLog 'WriteMode -> IO (Either ErrorType ()))
-> Maybe (StoreLog 'WriteMode)
-> IO (Either ErrorType ())
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Either ErrorType () -> IO (Either ErrorType ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrorType () -> IO (Either ErrorType ()))
-> Either ErrorType () -> IO (Either ErrorType ())
forall a b. (a -> b) -> a -> b
$ () -> Either ErrorType ()
forall a b. b -> Either a b
Right ()) (IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
E.try (IO () -> IO (Either SomeException ()))
-> (StoreLog 'WriteMode -> IO ())
-> StoreLog 'WriteMode
-> IO (Either SomeException ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ()
forall a. IO a -> IO a
E.uninterruptibleMask_ (IO () -> IO ())
-> (StoreLog 'WriteMode -> IO ()) -> StoreLog 'WriteMode -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StoreLog 'WriteMode -> IO ()
action (StoreLog 'WriteMode -> IO (Either SomeException ()))
-> (Either SomeException () -> IO (Either ErrorType ()))
-> StoreLog 'WriteMode
-> IO (Either ErrorType ())
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (SomeException -> IO ErrorType)
-> (() -> IO ())
-> Either SomeException ()
-> IO (Either ErrorType ())
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bimapM SomeException -> IO ErrorType
logErr () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure)
  where
    logErr :: E.SomeException -> IO ErrorType
    logErr :: SomeException -> IO ErrorType
logErr SomeException
e = Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logError (Text
"STORE: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err) IO () -> ErrorType -> IO ErrorType
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Text -> ErrorType
STORE Text
err
      where
        err :: Text
err = Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", withLog, " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeException -> Text
forall a. Show a => a -> Text
tshow SomeException
e

withLog :: Text -> STMQueueStore q -> (StoreLog 'WriteMode -> IO ()) -> IO (Either ErrorType ())
withLog :: forall q.
Text
-> STMQueueStore q
-> (StoreLog 'WriteMode -> IO ())
-> IO (Either ErrorType ())
withLog Text
name = Text
-> TVar (Maybe (StoreLog 'WriteMode))
-> (StoreLog 'WriteMode -> IO ())
-> IO (Either ErrorType ())
withLog' Text
name (TVar (Maybe (StoreLog 'WriteMode))
 -> (StoreLog 'WriteMode -> IO ()) -> IO (Either ErrorType ()))
-> (STMQueueStore q -> TVar (Maybe (StoreLog 'WriteMode)))
-> STMQueueStore q
-> (StoreLog 'WriteMode -> IO ())
-> IO (Either ErrorType ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STMQueueStore q -> TVar (Maybe (StoreLog 'WriteMode))
forall q. STMQueueStore q -> TVar (Maybe (StoreLog 'WriteMode))
storeLog
{-# INLINE withLog #-}