{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}

module Simplex.Messaging.Server.QueueStore.STM where

import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Simplex.Messaging.Protocol
import Simplex.Messaging.Server.QueueStore
import UnliftIO.STM

data QueueStoreData = QueueStoreData
  { QueueStoreData -> Map RecipientId QueueRec
queues :: Map RecipientId QueueRec,
    QueueStoreData -> Map RecipientId RecipientId
senders :: Map SenderId RecipientId
  }

type QueueStore = TVar QueueStoreData

newQueueStore :: STM QueueStore
newQueueStore :: STM QueueStore
newQueueStore = QueueStoreData -> STM QueueStore
forall a. a -> STM (TVar a)
newTVar QueueStoreData :: Map RecipientId QueueRec
-> Map RecipientId RecipientId -> QueueStoreData
QueueStoreData {queues :: Map RecipientId QueueRec
queues = Map RecipientId QueueRec
forall k a. Map k a
M.empty, senders :: Map RecipientId RecipientId
senders = Map RecipientId RecipientId
forall k a. Map k a
M.empty}

instance MonadQueueStore QueueStore STM where
  addQueue :: QueueStore -> RecipientPublicKey -> (RecipientId, SenderId) -> STM (Either ErrorType ())
  addQueue :: QueueStore
-> SenderPublicKey
-> (RecipientId, RecipientId)
-> STM (Either ErrorType ())
addQueue QueueStore
store SenderPublicKey
rKey ids :: (RecipientId, RecipientId)
ids@(RecipientId
rId, RecipientId
sId) = do
    cs :: QueueStoreData
cs@QueueStoreData {Map RecipientId QueueRec
queues :: Map RecipientId QueueRec
queues :: QueueStoreData -> Map RecipientId QueueRec
queues, Map RecipientId RecipientId
senders :: Map RecipientId RecipientId
senders :: QueueStoreData -> Map RecipientId RecipientId
senders} <- QueueStore -> STM QueueStoreData
forall a. TVar a -> STM a
readTVar QueueStore
store
    if RecipientId -> Map RecipientId QueueRec -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member RecipientId
rId Map RecipientId QueueRec
queues Bool -> Bool -> Bool
|| RecipientId -> Map RecipientId RecipientId -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member RecipientId
sId Map RecipientId RecipientId
senders
      then Either ErrorType () -> STM (Either ErrorType ())
forall (m :: * -> *) a. Monad m => a -> m a
return (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_
      else do
        QueueStore -> QueueStoreData -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar QueueStore
store (QueueStoreData -> STM ()) -> QueueStoreData -> STM ()
forall a b. (a -> b) -> a -> b
$
          QueueStoreData
cs
            { queues :: Map RecipientId QueueRec
queues = RecipientId
-> QueueRec -> Map RecipientId QueueRec -> Map RecipientId QueueRec
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert RecipientId
rId (SenderPublicKey -> (RecipientId, RecipientId) -> QueueRec
mkQueueRec SenderPublicKey
rKey (RecipientId, RecipientId)
ids) Map RecipientId QueueRec
queues,
              senders :: Map RecipientId RecipientId
senders = RecipientId
-> RecipientId
-> Map RecipientId RecipientId
-> Map RecipientId RecipientId
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert RecipientId
sId RecipientId
rId Map RecipientId RecipientId
senders
            }
        Either ErrorType () -> STM (Either ErrorType ())
forall (m :: * -> *) a. Monad m => a -> m a
return (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 ()

  getQueue :: QueueStore -> SParty (p :: Party) -> QueueId -> STM (Either ErrorType QueueRec)
  getQueue :: QueueStore
-> SParty p -> RecipientId -> STM (Either ErrorType QueueRec)
getQueue QueueStore
store SParty p
SRecipient RecipientId
rId = do
    QueueStoreData
cs <- QueueStore -> STM QueueStoreData
forall a. TVar a -> STM a
readTVar QueueStore
store
    Either ErrorType QueueRec -> STM (Either ErrorType QueueRec)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ErrorType QueueRec -> STM (Either ErrorType QueueRec))
-> Either ErrorType QueueRec -> STM (Either ErrorType QueueRec)
forall a b. (a -> b) -> a -> b
$ QueueStoreData -> RecipientId -> Either ErrorType QueueRec
getRcpQueue QueueStoreData
cs RecipientId
rId
  getQueue QueueStore
store SParty p
SSender RecipientId
sId = do
    QueueStoreData
cs <- QueueStore -> STM QueueStoreData
forall a. TVar a -> STM a
readTVar QueueStore
store
    let rId :: Maybe RecipientId
rId = RecipientId -> Map RecipientId RecipientId -> Maybe RecipientId
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup RecipientId
sId (Map RecipientId RecipientId -> Maybe RecipientId)
-> Map RecipientId RecipientId -> Maybe RecipientId
forall a b. (a -> b) -> a -> b
$ QueueStoreData -> Map RecipientId RecipientId
senders QueueStoreData
cs
    Either ErrorType QueueRec -> STM (Either ErrorType QueueRec)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ErrorType QueueRec -> STM (Either ErrorType QueueRec))
-> Either ErrorType QueueRec -> STM (Either ErrorType QueueRec)
forall a b. (a -> b) -> a -> b
$ Either ErrorType QueueRec
-> (RecipientId -> Either ErrorType QueueRec)
-> Maybe RecipientId
-> 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) (QueueStoreData -> RecipientId -> Either ErrorType QueueRec
getRcpQueue QueueStoreData
cs) Maybe RecipientId
rId
  getQueue QueueStore
_ SParty p
SBroker RecipientId
_ =
    Either ErrorType QueueRec -> STM (Either ErrorType QueueRec)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ErrorType QueueRec -> STM (Either ErrorType QueueRec))
-> Either ErrorType QueueRec -> STM (Either ErrorType QueueRec)
forall a b. (a -> b) -> a -> b
$ ErrorType -> Either ErrorType QueueRec
forall a b. a -> Either a b
Left ErrorType
INTERNAL

  secureQueue :: QueueStore
-> RecipientId -> SenderPublicKey -> STM (Either ErrorType ())
secureQueue QueueStore
store RecipientId
rId SenderPublicKey
sKey =
    QueueStore
-> RecipientId
-> (QueueStoreData
    -> QueueRec -> (Either ErrorType (), QueueStoreData))
-> STM (Either ErrorType ())
updateQueues QueueStore
store RecipientId
rId ((QueueStoreData
  -> QueueRec -> (Either ErrorType (), QueueStoreData))
 -> STM (Either ErrorType ()))
-> (QueueStoreData
    -> QueueRec -> (Either ErrorType (), QueueStoreData))
-> STM (Either ErrorType ())
forall a b. (a -> b) -> a -> b
$ \QueueStoreData
cs QueueRec
c ->
      case QueueRec -> Maybe SenderPublicKey
senderKey QueueRec
c of
        Just SenderPublicKey
_ -> (ErrorType -> Either ErrorType ()
forall a b. a -> Either a b
Left ErrorType
AUTH, QueueStoreData
cs)
        Maybe SenderPublicKey
_ -> (() -> Either ErrorType ()
forall a b. b -> Either a b
Right (), QueueStoreData
cs {queues :: Map RecipientId QueueRec
queues = RecipientId
-> QueueRec -> Map RecipientId QueueRec -> Map RecipientId QueueRec
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert RecipientId
rId QueueRec
c {senderKey :: Maybe SenderPublicKey
senderKey = SenderPublicKey -> Maybe SenderPublicKey
forall a. a -> Maybe a
Just SenderPublicKey
sKey} (QueueStoreData -> Map RecipientId QueueRec
queues QueueStoreData
cs)})

  suspendQueue :: QueueStore -> RecipientId -> STM (Either ErrorType ())
  suspendQueue :: QueueStore -> RecipientId -> STM (Either ErrorType ())
suspendQueue QueueStore
store RecipientId
rId =
    QueueStore
-> RecipientId
-> (QueueStoreData
    -> QueueRec -> (Either ErrorType (), QueueStoreData))
-> STM (Either ErrorType ())
updateQueues QueueStore
store RecipientId
rId ((QueueStoreData
  -> QueueRec -> (Either ErrorType (), QueueStoreData))
 -> STM (Either ErrorType ()))
-> (QueueStoreData
    -> QueueRec -> (Either ErrorType (), QueueStoreData))
-> STM (Either ErrorType ())
forall a b. (a -> b) -> a -> b
$ \QueueStoreData
cs QueueRec
c ->
      (() -> Either ErrorType ()
forall a b. b -> Either a b
Right (), QueueStoreData
cs {queues :: Map RecipientId QueueRec
queues = RecipientId
-> QueueRec -> Map RecipientId QueueRec -> Map RecipientId QueueRec
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert RecipientId
rId QueueRec
c {status :: QueueStatus
status = QueueStatus
QueueOff} (QueueStoreData -> Map RecipientId QueueRec
queues QueueStoreData
cs)})

  deleteQueue :: QueueStore -> RecipientId -> STM (Either ErrorType ())
  deleteQueue :: QueueStore -> RecipientId -> STM (Either ErrorType ())
deleteQueue QueueStore
store RecipientId
rId =
    QueueStore
-> RecipientId
-> (QueueStoreData
    -> QueueRec -> (Either ErrorType (), QueueStoreData))
-> STM (Either ErrorType ())
updateQueues QueueStore
store RecipientId
rId ((QueueStoreData
  -> QueueRec -> (Either ErrorType (), QueueStoreData))
 -> STM (Either ErrorType ()))
-> (QueueStoreData
    -> QueueRec -> (Either ErrorType (), QueueStoreData))
-> STM (Either ErrorType ())
forall a b. (a -> b) -> a -> b
$ \QueueStoreData
cs QueueRec
c ->
      ( () -> Either ErrorType ()
forall a b. b -> Either a b
Right (),
        QueueStoreData
cs
          { queues :: Map RecipientId QueueRec
queues = RecipientId -> Map RecipientId QueueRec -> Map RecipientId QueueRec
forall k a. Ord k => k -> Map k a -> Map k a
M.delete RecipientId
rId (QueueStoreData -> Map RecipientId QueueRec
queues QueueStoreData
cs),
            senders :: Map RecipientId RecipientId
senders = RecipientId
-> Map RecipientId RecipientId -> Map RecipientId RecipientId
forall k a. Ord k => k -> Map k a -> Map k a
M.delete (QueueRec -> RecipientId
senderId QueueRec
c) (QueueStoreData -> Map RecipientId RecipientId
senders QueueStoreData
cs)
          }
      )

updateQueues ::
  QueueStore ->
  RecipientId ->
  (QueueStoreData -> QueueRec -> (Either ErrorType (), QueueStoreData)) ->
  STM (Either ErrorType ())
updateQueues :: QueueStore
-> RecipientId
-> (QueueStoreData
    -> QueueRec -> (Either ErrorType (), QueueStoreData))
-> STM (Either ErrorType ())
updateQueues QueueStore
store RecipientId
rId QueueStoreData -> QueueRec -> (Either ErrorType (), QueueStoreData)
update = do
  QueueStoreData
cs <- QueueStore -> STM QueueStoreData
forall a. TVar a -> STM a
readTVar QueueStore
store
  let conn :: Either ErrorType QueueRec
conn = QueueStoreData -> RecipientId -> Either ErrorType QueueRec
getRcpQueue QueueStoreData
cs RecipientId
rId
  (ErrorType -> STM (Either ErrorType ()))
-> (QueueRec -> STM (Either ErrorType ()))
-> Either ErrorType QueueRec
-> STM (Either ErrorType ())
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Either ErrorType () -> STM (Either ErrorType ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ErrorType () -> STM (Either ErrorType ()))
-> (ErrorType -> Either ErrorType ())
-> ErrorType
-> STM (Either ErrorType ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorType -> Either ErrorType ()
forall a b. a -> Either a b
Left) (QueueStoreData -> QueueRec -> STM (Either ErrorType ())
_update QueueStoreData
cs) Either ErrorType QueueRec
conn
  where
    _update :: QueueStoreData -> QueueRec -> STM (Either ErrorType ())
_update QueueStoreData
cs QueueRec
c = do
      let (Either ErrorType ()
res, QueueStoreData
cs') = QueueStoreData -> QueueRec -> (Either ErrorType (), QueueStoreData)
update QueueStoreData
cs QueueRec
c
      QueueStore -> QueueStoreData -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar QueueStore
store QueueStoreData
cs'
      Either ErrorType () -> STM (Either ErrorType ())
forall (m :: * -> *) a. Monad m => a -> m a
return Either ErrorType ()
res

getRcpQueue :: QueueStoreData -> RecipientId -> Either ErrorType QueueRec
getRcpQueue :: QueueStoreData -> RecipientId -> Either ErrorType QueueRec
getRcpQueue QueueStoreData
cs RecipientId
rId = 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)
-> (Map RecipientId QueueRec -> Maybe QueueRec)
-> Map RecipientId QueueRec
-> Either ErrorType QueueRec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecipientId -> Map RecipientId QueueRec -> Maybe QueueRec
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup RecipientId
rId (Map RecipientId QueueRec -> Either ErrorType QueueRec)
-> Map RecipientId QueueRec -> Either ErrorType QueueRec
forall a b. (a -> b) -> a -> b
$ QueueStoreData -> Map RecipientId QueueRec
queues QueueStoreData
cs