{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}

-- |
-- Module      : Simplex.Messaging.Server
-- Copyright   : (c) simplex.chat
-- License     : AGPL-3
--
-- Maintainer  : chat@simplex.chat
-- Stability   : experimental
-- Portability : non-portable
--
-- This module defines SMP protocol server with in-memory persistence
-- and optional append only log of SMP queue records.
--
-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md
module Simplex.Messaging.Server
  ( runSMPServer,
    runSMPServerBlocking,
    controlPortAuth,
    importMessages,
    exportMessages,
    printMessageStats,
    disconnectTransport,
    verifyCmdAuthorization,
    dummyVerifyCmd,
    randomId,
    AttachHTTP,
    MessageStats (..),
  )
where

import Control.Concurrent.STM (throwSTM)
import Control.Logger.Simple
import Control.Monad
import Control.Monad.Except
import Control.Monad.IO.Unlift
import Control.Monad.Reader
import Control.Monad.Trans.Except
import Control.Monad.STM (retry)
import Crypto.Random (ChaChaDRG)
import Data.Bifunctor (first, second)
import Data.ByteString.Base64 (encode)
import qualified Data.ByteString.Builder as BLD
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Constraint (Dict (..))
import Data.Dynamic (toDyn)
import Data.Either (fromRight, partitionEithers)
import Data.Foldable (foldrM)
import Data.Functor (($>))
import Data.IORef
import Data.Int (Int64)
import qualified Data.IntMap.Strict as IM
import qualified Data.IntSet as IS
import Data.List (foldl', intercalate)
import Data.List.NonEmpty (NonEmpty (..), (<|))
import qualified Data.List.NonEmpty as L
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe, isJust, isNothing)
import Data.Semigroup (Sum (..))
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeLatin1)
import qualified Data.Text.IO as T
import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
import Data.Time.Clock.System (SystemTime (..), getSystemTime)
import Data.Time.Format.ISO8601 (iso8601Show)
import Data.Type.Equality
import Data.Typeable (cast)
import qualified Data.X509 as X
import qualified Data.X509.Validation as XV
import GHC.Conc.Signal
import GHC.IORef (atomicSwapIORef)
import GHC.Stats (getRTSStats)
import GHC.TypeLits (KnownNat)
import Network.Socket (ServiceName, Socket, socketToHandle)
import qualified Network.TLS as TLS
import Numeric.Natural (Natural)
import Simplex.Messaging.Agent.Lock
import Simplex.Messaging.Client (ProtocolClient (thParams), ProtocolClientError (..), SMPClient, SMPClientError, forwardSMPTransmission, smpProxyError, temporaryClientError)
import Simplex.Messaging.Client.Agent (OwnServer, SMPClientAgent (..), SMPClientAgentEvent (..), closeSMPClientAgent, getSMPServerClient'', isOwnServer, lookupSMPServerClient, getConnectedSMPServerClient)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol
import Simplex.Messaging.Server.Control
import Simplex.Messaging.Server.Env.STM as Env
import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.Server.MsgStore
import Simplex.Messaging.Server.MsgStore.Journal (JournalMsgStore, JournalQueue (..), getJournalQueueMessages)
import Simplex.Messaging.Server.MsgStore.STM
import Simplex.Messaging.Server.MsgStore.Types
import Simplex.Messaging.Server.NtfStore
import Simplex.Messaging.Server.Prometheus
import Simplex.Messaging.Server.QueueStore
import Simplex.Messaging.Server.QueueStore.QueueInfo
import Simplex.Messaging.Server.QueueStore.Types
import Simplex.Messaging.Server.Stats
import Simplex.Messaging.Server.StoreLog (foldLogLines)
import Simplex.Messaging.SystemTime
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport
import Simplex.Messaging.Transport.Buffer (trimCR)
import Simplex.Messaging.Transport.Server
import Simplex.Messaging.Util
import Simplex.Messaging.Version
import System.Environment (lookupEnv)
import System.Exit (exitFailure, exitSuccess)
import System.IO (hPrint, hPutStrLn, hSetNewlineMode, universalNewlineMode)
import System.Mem.Weak (deRefWeak)
import UnliftIO (timeout)
import UnliftIO.Concurrent
import UnliftIO.Directory (doesFileExist, renameFile)
import UnliftIO.Exception
import UnliftIO.IO
import UnliftIO.STM

#if MIN_VERSION_base(4,18,0)
import Data.List (sort)
import GHC.Conc (listThreads, threadStatus)
import GHC.Conc.Sync (threadLabel)
#endif

#if defined(dbServerPostgres)
import Simplex.Messaging.Server.MsgStore.Postgres (exportDbMessages, getDbMessageStats)
#endif

-- | Runs an SMP server using passed configuration.
--
-- See a full server here: https://github.com/simplex-chat/simplexmq/blob/master/apps/smp-server/Main.hs
runSMPServer :: MsgStoreClass s => ServerConfig s -> Maybe AttachHTTP -> IO ()
runSMPServer :: forall s.
MsgStoreClass s =>
ServerConfig s -> Maybe AttachHTTP -> IO ()
runSMPServer ServerConfig s
cfg Maybe AttachHTTP
attachHTTP_ = do
  TMVar Bool
started <- IO (TMVar Bool)
forall (m :: * -> *) a. MonadIO m => m (TMVar a)
newEmptyTMVarIO
  TMVar Bool -> ServerConfig s -> Maybe AttachHTTP -> IO ()
forall s.
MsgStoreClass s =>
TMVar Bool -> ServerConfig s -> Maybe AttachHTTP -> IO ()
runSMPServerBlocking TMVar Bool
started ServerConfig s
cfg Maybe AttachHTTP
attachHTTP_

-- | Runs an SMP server using passed configuration with signalling.
--
-- This function uses passed TMVar to signal when the server is ready to accept TCP requests (True)
-- and when it is disconnected from the TCP socket once the server thread is killed (False).
runSMPServerBlocking :: MsgStoreClass s => TMVar Bool -> ServerConfig s -> Maybe AttachHTTP -> IO ()
runSMPServerBlocking :: forall s.
MsgStoreClass s =>
TMVar Bool -> ServerConfig s -> Maybe AttachHTTP -> IO ()
runSMPServerBlocking TMVar Bool
started ServerConfig s
cfg Maybe AttachHTTP
attachHTTP_ = ServerConfig s -> IO (Env s)
forall s. ServerConfig s -> IO (Env s)
newEnv ServerConfig s
cfg IO (Env s) -> (Env s -> 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
>>= ReaderT (Env s) IO () -> Env s -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (TMVar Bool
-> ServerConfig s -> Maybe AttachHTTP -> ReaderT (Env s) IO ()
forall s.
MsgStoreClass s =>
TMVar Bool -> ServerConfig s -> Maybe AttachHTTP -> M s ()
smpServer TMVar Bool
started ServerConfig s
cfg Maybe AttachHTTP
attachHTTP_)

type M s a = ReaderT (Env s) IO a
type AttachHTTP = Socket -> TLS.Context -> IO ()

-- actions used in serverThread to reduce STM transaction scope
data ClientSubAction
  = CSAEndSub QueueId -- end single direct queue subscription
  | CSAEndServiceSub -- end service subscription to one queue
  | CSADecreaseSubs Int64 -- reduce service subscriptions when cancelling. Fixed number is used to correctly handle race conditions when service resubscribes

type PrevClientSub s = (Client s, ClientSubAction, (EntityId, BrokerMsg))

smpServer :: forall s. MsgStoreClass s => TMVar Bool -> ServerConfig s -> Maybe AttachHTTP -> M s ()
smpServer :: forall s.
MsgStoreClass s =>
TMVar Bool -> ServerConfig s -> Maybe AttachHTTP -> M s ()
smpServer TMVar Bool
started cfg :: ServerConfig s
cfg@ServerConfig {[(String, ASrvTransport, Bool)]
transports :: [(String, ASrvTransport, Bool)]
$sel:transports:ServerConfig :: forall s. ServerConfig s -> [(String, ASrvTransport, Bool)]
transports, $sel:transportConfig:ServerConfig :: forall s. ServerConfig s -> TransportServerConfig
transportConfig = TransportServerConfig
tCfg, StartOptions
startOptions :: StartOptions
$sel:startOptions:ServerConfig :: forall s. ServerConfig s -> StartOptions
startOptions} Maybe AttachHTTP
attachHTTP_ = do
  Server s
s <- (Env s -> Server s) -> ReaderT (Env s) IO (Server s)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> Server s
forall s. Env s -> Server s
server
  ProxyAgent
pa <- (Env s -> ProxyAgent) -> ReaderT (Env s) IO ProxyAgent
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> ProxyAgent
forall s. Env s -> ProxyAgent
proxyAgent
  Maybe MessageStats
msgStats_ <- StartOptions -> M s (Maybe MessageStats)
forall s'. StartOptions -> M s' (Maybe MessageStats)
processServerMessages StartOptions
startOptions
  MessageStats
ntfStats <- M s MessageStats
forall s. M s MessageStats
restoreServerNtfs
  IO () -> M s ()
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
forall a b. (a -> b) -> a -> b
$ (MessageStats -> IO ()) -> Maybe MessageStats -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Text -> MessageStats -> IO ()
printMessageStats Text
"messages") Maybe MessageStats
msgStats_
  IO () -> M s ()
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
forall a b. (a -> b) -> a -> b
$ Text -> MessageStats -> IO ()
printMessageStats Text
"notifications" MessageStats
ntfStats
  Maybe MessageStats -> MessageStats -> M s ()
forall s.
MsgStoreClass s =>
Maybe MessageStats -> MessageStats -> M s ()
restoreServerStats Maybe MessageStats
msgStats_ MessageStats
ntfStats
  Bool -> M s () -> M s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (StartOptions -> Bool
maintenance StartOptions
startOptions) (M s () -> M s ()) -> M s () -> M s ()
forall a b. (a -> b) -> a -> b
$ do
    IO () -> M s ()
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"Server started in 'maintenance' mode, exiting"
    Server s -> M s ()
stopServer Server s
s
    IO () -> M s ()
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
forall a b. (a -> b) -> a -> b
$ IO ()
forall a. IO a
exitSuccess
  [M s ()] -> M s ()
forall (m :: * -> *) a. MonadUnliftIO m => [m a] -> m ()
raceAny_
    ( String
-> Server s
-> (Server s -> ServerSubscribers s)
-> (Client s -> TMap RecipientId Sub)
-> (Client s -> TVar Int64)
-> Maybe (Sub -> IO ())
-> M s ()
forall sub.
String
-> Server s
-> (Server s -> ServerSubscribers s)
-> (Client s -> TMap RecipientId sub)
-> (Client s -> TVar Int64)
-> Maybe (sub -> IO ())
-> M s ()
serverThread String
"server subscribers" Server s
s Server s -> ServerSubscribers s
forall s. Server s -> ServerSubscribers s
subscribers Client s -> TMap RecipientId Sub
forall s. Client s -> TMap RecipientId Sub
subscriptions Client s -> TVar Int64
forall s. Client s -> TVar Int64
serviceSubsCount ((Sub -> IO ()) -> Maybe (Sub -> IO ())
forall a. a -> Maybe a
Just Sub -> IO ()
cancelSub)
        M s () -> [M s ()] -> [M s ()]
forall a. a -> [a] -> [a]
: String
-> Server s
-> (Server s -> ServerSubscribers s)
-> (Client s -> TMap RecipientId ())
-> (Client s -> TVar Int64)
-> Maybe (() -> IO ())
-> M s ()
forall sub.
String
-> Server s
-> (Server s -> ServerSubscribers s)
-> (Client s -> TMap RecipientId sub)
-> (Client s -> TVar Int64)
-> Maybe (sub -> IO ())
-> M s ()
serverThread String
"server ntfSubscribers" Server s
s Server s -> ServerSubscribers s
forall s. Server s -> ServerSubscribers s
ntfSubscribers Client s -> TMap RecipientId ()
forall s. Client s -> TMap RecipientId ()
ntfSubscriptions Client s -> TVar Int64
forall s. Client s -> TVar Int64
ntfServiceSubsCount Maybe (() -> IO ())
forall a. Maybe a
Nothing
        M s () -> [M s ()] -> [M s ()]
forall a. a -> [a] -> [a]
: Server s -> M s ()
deliverNtfsThread Server s
s
        M s () -> [M s ()] -> [M s ()]
forall a. a -> [a] -> [a]
: Server s -> M s ()
sendPendingEvtsThread Server s
s
        M s () -> [M s ()] -> [M s ()]
forall a. a -> [a] -> [a]
: ProxyAgent -> M s ()
receiveFromProxyAgent ProxyAgent
pa
        M s () -> [M s ()] -> [M s ()]
forall a. a -> [a] -> [a]
: ServerConfig s -> M s ()
expireNtfsThread ServerConfig s
cfg
        M s () -> [M s ()] -> [M s ()]
forall a. a -> [a] -> [a]
: M s ()
sigIntHandlerThread
        M s () -> [M s ()] -> [M s ()]
forall a. a -> [a] -> [a]
: ((String, ASrvTransport, Bool) -> M s ())
-> [(String, ASrvTransport, Bool)] -> [M s ()]
forall a b. (a -> b) -> [a] -> [b]
map (String, ASrvTransport, Bool) -> M s ()
runServer [(String, ASrvTransport, Bool)]
transports
            [M s ()] -> [M s ()] -> [M s ()]
forall a. Semigroup a => a -> a -> a
<> ServerConfig s -> [M s ()]
expireMessagesThread_ ServerConfig s
cfg
            [M s ()] -> [M s ()] -> [M s ()]
forall a. Semigroup a => a -> a -> a
<> ServerConfig s -> [M s ()]
serverStatsThread_ ServerConfig s
cfg
            [M s ()] -> [M s ()] -> [M s ()]
forall a. Semigroup a => a -> a -> a
<> ServerConfig s -> [M s ()]
prometheusMetricsThread_ ServerConfig s
cfg
            [M s ()] -> [M s ()] -> [M s ()]
forall a. Semigroup a => a -> a -> a
<> ServerConfig s -> [M s ()]
controlPortThread_ ServerConfig s
cfg
    )
    M s () -> M s () -> M s ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`finally` Server s -> M s ()
stopServer Server s
s
  where
    runServer :: (ServiceName, ASrvTransport, AddHTTP) -> M s ()
    runServer :: (String, ASrvTransport, Bool) -> M s ()
runServer (String
tcpPort, ATransport TProxy c 'TServer
t, Bool
addHTTP) = do
      smpCreds :: Credential
smpCreds@(CertificateChain
srvCert, PrivKey
srvKey) <- (Env s -> Credential) -> ReaderT (Env s) IO Credential
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> Credential
forall s. Env s -> Credential
tlsServerCreds
      Maybe Credential
httpCreds_ <- (Env s -> Maybe Credential)
-> ReaderT (Env s) IO (Maybe Credential)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> Maybe Credential
forall s. Env s -> Maybe Credential
httpServerCreds
      SocketState
ss <- IO SocketState -> ReaderT (Env s) IO SocketState
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO SocketState
newSocketState
      (Env s -> TVar [(String, SocketState)])
-> ReaderT (Env s) IO (TVar [(String, SocketState)])
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> TVar [(String, SocketState)]
forall s. Env s -> TVar [(String, SocketState)]
sockets ReaderT (Env s) IO (TVar [(String, SocketState)])
-> (TVar [(String, SocketState)] -> M s ()) -> M s ()
forall a b.
ReaderT (Env s) IO a
-> (a -> ReaderT (Env s) IO b) -> ReaderT (Env s) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STM () -> M s ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> M s ())
-> (TVar [(String, SocketState)] -> STM ())
-> TVar [(String, SocketState)]
-> M s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TVar [(String, SocketState)]
-> ([(String, SocketState)] -> [(String, SocketState)]) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
`modifyTVar'` ((String
tcpPort, SocketState
ss) (String, SocketState)
-> [(String, SocketState)] -> [(String, SocketState)]
forall a. a -> [a] -> [a]
:))
      APrivateSignKey
srvSignKey <- (String -> ReaderT (Env s) IO APrivateSignKey)
-> (APrivateSignKey -> ReaderT (Env s) IO APrivateSignKey)
-> Either String APrivateSignKey
-> ReaderT (Env s) IO APrivateSignKey
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> ReaderT (Env s) IO APrivateSignKey
forall a. String -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail APrivateSignKey -> ReaderT (Env s) IO APrivateSignKey
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String APrivateSignKey
 -> ReaderT (Env s) IO APrivateSignKey)
-> Either String APrivateSignKey
-> ReaderT (Env s) IO APrivateSignKey
forall a b. (a -> b) -> a -> b
$ PrivKey -> Either String APrivateSignKey
forall k. CryptoPrivateKey k => PrivKey -> Either String k
C.x509ToPrivate' PrivKey
srvKey
      Env s
env <- ReaderT (Env s) IO (Env s)
forall r (m :: * -> *). MonadReader r m => m r
ask
      IO () -> M s ()
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
forall a b. (a -> b) -> a -> b
$ case (Maybe Credential
httpCreds_, Maybe AttachHTTP
attachHTTP_) of
        (Just Credential
httpCreds, Just AttachHTTP
attachHTTP) | Bool
addHTTP ->
          SocketState
-> TMVar Bool
-> String
-> Supported
-> TLSServerCredential
-> TransportServerConfig
-> (Socket -> (Bool, c 'TServer) -> IO ())
-> IO ()
forall (c :: TransportPeer -> *).
Transport c =>
SocketState
-> TMVar Bool
-> String
-> Supported
-> TLSServerCredential
-> TransportServerConfig
-> (Socket -> (Bool, c 'TServer) -> IO ())
-> IO ()
runTransportServerState_ SocketState
ss TMVar Bool
started String
tcpPort Supported
defaultSupportedParamsHTTPS TLSServerCredential
combinedCreds TransportServerConfig
tCfg ((Socket -> (Bool, c 'TServer) -> IO ()) -> IO ())
-> (Socket -> (Bool, c 'TServer) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Socket
s (Bool
sniUsed, c 'TServer
h) ->
            case c 'TServer -> Maybe (TLS 'TServer)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast c 'TServer
h of
              Just (TLS {Context
tlsContext :: Context
$sel:tlsContext:TLS :: forall (p :: TransportPeer). TLS p -> Context
tlsContext} :: TLS 'TServer) | Bool
sniUsed -> String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
labelMyThread String
"https client" IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> AttachHTTP
attachHTTP Socket
s Context
tlsContext
              Maybe (TLS 'TServer)
_ -> CertificateChain
-> APrivateSignKey -> TProxy c 'TServer -> c 'TServer -> M s ()
forall (c :: TransportPeer -> *).
Transport c =>
CertificateChain
-> APrivateSignKey -> TProxy c 'TServer -> c 'TServer -> M s ()
runClient CertificateChain
srvCert APrivateSignKey
srvSignKey TProxy c 'TServer
t c 'TServer
h M s () -> Env s -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` Env s
env
          where
            combinedCreds :: TLSServerCredential
combinedCreds = TLSServerCredential {$sel:credential:TLSServerCredential :: Credential
credential = Credential
smpCreds, $sel:sniCredential:TLSServerCredential :: Maybe Credential
sniCredential = Credential -> Maybe Credential
forall a. a -> Maybe a
Just Credential
httpCreds}
        (Maybe Credential, Maybe AttachHTTP)
_ ->
          SocketState
-> TMVar Bool
-> String
-> Supported
-> Credential
-> TransportServerConfig
-> (c 'TServer -> IO ())
-> IO ()
forall (c :: TransportPeer -> *).
Transport c =>
SocketState
-> TMVar Bool
-> String
-> Supported
-> Credential
-> TransportServerConfig
-> (c 'TServer -> IO ())
-> IO ()
runTransportServerState SocketState
ss TMVar Bool
started String
tcpPort Supported
defaultSupportedParams Credential
smpCreds TransportServerConfig
tCfg ((c 'TServer -> IO ()) -> IO ()) -> (c 'TServer -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \c 'TServer
h -> CertificateChain
-> APrivateSignKey -> TProxy c 'TServer -> c 'TServer -> M s ()
forall (c :: TransportPeer -> *).
Transport c =>
CertificateChain
-> APrivateSignKey -> TProxy c 'TServer -> c 'TServer -> M s ()
runClient CertificateChain
srvCert APrivateSignKey
srvSignKey TProxy c 'TServer
t c 'TServer
h M s () -> Env s -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` Env s
env

    sigIntHandlerThread :: M s ()
    sigIntHandlerThread :: M s ()
sigIntHandlerThread = do
      TMVar ()
flagINT <- ReaderT (Env s) IO (TMVar ())
forall (m :: * -> *) a. MonadIO m => m (TMVar a)
newEmptyTMVarIO
      let sigINT :: Signal
sigINT = Signal
2 -- CONST_SIGINT value
          sigIntAction :: ForeignPtr Word8 -> IO ()
sigIntAction = \ForeignPtr Word8
_ptr -> STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ STM Bool -> STM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (STM Bool -> STM ()) -> STM Bool -> STM ()
forall a b. (a -> b) -> a -> b
$ TMVar () -> () -> STM Bool
forall a. TMVar a -> a -> STM Bool
tryPutTMVar TMVar ()
flagINT ()
          sigIntHandler :: Maybe (ForeignPtr Word8 -> IO (), Dynamic)
sigIntHandler = (ForeignPtr Word8 -> IO (), Dynamic)
-> Maybe (ForeignPtr Word8 -> IO (), Dynamic)
forall a. a -> Maybe a
Just (ForeignPtr Word8 -> IO ()
sigIntAction, () -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn ())
      ReaderT (Env s) IO (Maybe (ForeignPtr Word8 -> IO (), Dynamic))
-> M s ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT (Env s) IO (Maybe (ForeignPtr Word8 -> IO (), Dynamic))
 -> M s ())
-> ReaderT (Env s) IO (Maybe (ForeignPtr Word8 -> IO (), Dynamic))
-> M s ()
forall a b. (a -> b) -> a -> b
$ IO (Maybe (ForeignPtr Word8 -> IO (), Dynamic))
-> ReaderT (Env s) IO (Maybe (ForeignPtr Word8 -> IO (), Dynamic))
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (ForeignPtr Word8 -> IO (), Dynamic))
 -> ReaderT (Env s) IO (Maybe (ForeignPtr Word8 -> IO (), Dynamic)))
-> IO (Maybe (ForeignPtr Word8 -> IO (), Dynamic))
-> ReaderT (Env s) IO (Maybe (ForeignPtr Word8 -> IO (), Dynamic))
forall a b. (a -> b) -> a -> b
$ Signal
-> Maybe (ForeignPtr Word8 -> IO (), Dynamic)
-> IO (Maybe (ForeignPtr Word8 -> IO (), Dynamic))
setHandler Signal
sigINT Maybe (ForeignPtr Word8 -> IO (), Dynamic)
sigIntHandler
      STM () -> M s ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> M s ()) -> STM () -> M s ()
forall a b. (a -> b) -> a -> b
$ TMVar () -> STM ()
forall a. TMVar a -> STM a
readTMVar TMVar ()
flagINT
      Text -> M s ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logNote Text
"Received SIGINT, stopping server..."

    stopServer :: Server s -> M s ()
    stopServer :: Server s -> M s ()
stopServer Server s
s = do
      (Env s -> TVar Bool) -> ReaderT (Env s) IO (TVar Bool)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> TVar Bool
forall s. Env s -> TVar Bool
serverActive ReaderT (Env s) IO (TVar Bool) -> (TVar Bool -> M s ()) -> M s ()
forall a b.
ReaderT (Env s) IO a
-> (a -> ReaderT (Env s) IO b) -> ReaderT (Env s) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STM () -> M s ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> M s ()) -> (TVar Bool -> STM ()) -> TVar Bool -> M s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
`writeTVar` Bool
False)
      Text -> M s ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logNote Text
"Saving server state..."
      Lock -> Text -> M s () -> M s ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
Lock -> Text -> m a -> m a
withLock' (Server s -> Lock
forall s. Server s -> Lock
savingLock Server s
s) Text
"final" (M s () -> M s ()) -> M s () -> M s ()
forall a b. (a -> b) -> a -> b
$ Bool -> M s ()
saveServer Bool
True M s () -> M s () -> M s ()
forall a b.
ReaderT (Env s) IO a
-> ReaderT (Env s) IO b -> ReaderT (Env s) IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> M s ()
closeServer
      Text -> M s ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logNote Text
"Server stopped"

    saveServer :: Bool -> M s ()
    saveServer :: Bool -> M s ()
saveServer Bool
drainMsgs = do
      MsgStore s
ms <- (Env s -> MsgStore s) -> ReaderT (Env s) IO (MsgStore s)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> MsgStore s
forall s. Env s -> MsgStore s
msgStore_
      IO () -> M s ()
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
forall a b. (a -> b) -> a -> b
$ Bool -> MsgStore s -> IO ()
forall s. Bool -> MsgStore s -> IO ()
saveServerMessages Bool
drainMsgs MsgStore s
ms IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> s -> IO ()
forall s. MsgStoreClass s => s -> IO ()
closeMsgStore (MsgStore s -> s
forall s. MsgStore s -> s
fromMsgStore MsgStore s
ms)
      M s ()
forall s. M s ()
saveServerNtfs
      M s ()
forall s. M s ()
saveServerStats

    closeServer :: M s ()
    closeServer :: M s ()
closeServer = (Env s -> SMPClientAgent 'Sender)
-> ReaderT (Env s) IO (SMPClientAgent 'Sender)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ProxyAgent -> SMPClientAgent 'Sender
smpAgent (ProxyAgent -> SMPClientAgent 'Sender)
-> (Env s -> ProxyAgent) -> Env s -> SMPClientAgent 'Sender
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env s -> ProxyAgent
forall s. Env s -> ProxyAgent
proxyAgent) ReaderT (Env s) IO (SMPClientAgent 'Sender)
-> (SMPClientAgent 'Sender -> M s ()) -> M s ()
forall a b.
ReaderT (Env s) IO a
-> (a -> ReaderT (Env s) IO b) -> ReaderT (Env s) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> M s ()
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ())
-> (SMPClientAgent 'Sender -> IO ())
-> SMPClientAgent 'Sender
-> M s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SMPClientAgent 'Sender -> IO ()
forall (p :: Party). SMPClientAgent p -> IO ()
closeSMPClientAgent

    serverThread ::
      forall sub. String ->
      Server s ->
      (Server s -> ServerSubscribers s) ->
      (Client s -> TMap QueueId sub) ->
      (Client s -> TVar Int64) ->
      Maybe (sub -> IO ()) ->
      M s ()
    serverThread :: forall sub.
String
-> Server s
-> (Server s -> ServerSubscribers s)
-> (Client s -> TMap RecipientId sub)
-> (Client s -> TVar Int64)
-> Maybe (sub -> IO ())
-> M s ()
serverThread String
label Server s
srv Server s -> ServerSubscribers s
srvSubscribers Client s -> TMap RecipientId sub
clientSubs Client s -> TVar Int64
clientServiceSubs Maybe (sub -> IO ())
unsub_ = do
      String -> M s ()
forall (m :: * -> *). MonadIO m => String -> m ()
labelMyThread String
label
      IO () -> M s ()
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> (IO () -> IO ()) -> IO () -> M s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> M s ()) -> IO () -> M s ()
forall a b. (a -> b) -> a -> b
$ do
        -- Reading clients outside of `updateSubscribers` transaction to avoid transaction re-evaluation on each new connected client.
        -- In case client disconnects during the transaction (its `connected` property is read),
        -- the transaction will still be re-evaluated, and the client won't be stored as subscribed.
        sub :: (ClientSub, Int)
sub@(ClientSub
_, Int
clntId) <- STM (ClientSub, Int) -> IO (ClientSub, Int)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (ClientSub, Int) -> IO (ClientSub, Int))
-> STM (ClientSub, Int) -> IO (ClientSub, Int)
forall a b. (a -> b) -> a -> b
$ TQueue (ClientSub, Int) -> STM (ClientSub, Int)
forall a. TQueue a -> STM a
readTQueue TQueue (ClientSub, Int)
subQ
        Maybe (Client s)
c_ <- Int -> Server s -> IO (Maybe (Client s))
forall s. Int -> Server s -> IO (Maybe (Client s))
getServerClient Int
clntId Server s
srv
        STM [PrevClientSub s] -> IO [PrevClientSub s]
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (Maybe (Client s) -> (ClientSub, Int) -> STM [PrevClientSub s]
updateSubscribers Maybe (Client s)
c_ (ClientSub, Int)
sub)
          IO [PrevClientSub s] -> ([PrevClientSub s] -> 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
>>= [PrevClientSub s] -> IO ()
endPreviousSubscriptions
      where
        ServerSubscribers {TQueue (ClientSub, Int)
subQ :: TQueue (ClientSub, Int)
$sel:subQ:ServerSubscribers :: forall s. ServerSubscribers s -> TQueue (ClientSub, Int)
subQ, SubscribedClients s
queueSubscribers :: SubscribedClients s
$sel:queueSubscribers:ServerSubscribers :: forall s. ServerSubscribers s -> SubscribedClients s
queueSubscribers, SubscribedClients s
serviceSubscribers :: SubscribedClients s
$sel:serviceSubscribers:ServerSubscribers :: forall s. ServerSubscribers s -> SubscribedClients s
serviceSubscribers, TVar Int64
totalServiceSubs :: TVar Int64
$sel:totalServiceSubs:ServerSubscribers :: forall s. ServerSubscribers s -> TVar Int64
totalServiceSubs, TVar IntSet
subClients :: TVar IntSet
$sel:subClients:ServerSubscribers :: forall s. ServerSubscribers s -> TVar IntSet
subClients, TVar (IntMap (NonEmpty (RecipientId, BrokerMsg)))
pendingEvents :: TVar (IntMap (NonEmpty (RecipientId, BrokerMsg)))
$sel:pendingEvents:ServerSubscribers :: forall s.
ServerSubscribers s
-> TVar (IntMap (NonEmpty (RecipientId, BrokerMsg)))
pendingEvents} = Server s -> ServerSubscribers s
srvSubscribers Server s
srv
        updateSubscribers :: Maybe (Client s) -> (ClientSub, ClientId) -> STM [PrevClientSub s]
        updateSubscribers :: Maybe (Client s) -> (ClientSub, Int) -> STM [PrevClientSub s]
updateSubscribers Maybe (Client s)
c_ (ClientSub
clntSub, Int
clntId) = case Maybe (Client s)
c_ of
          Just c :: Client s
c@Client {TVar Bool
connected :: TVar Bool
$sel:connected:Client :: forall s. Client s -> TVar Bool
connected} -> STM Bool
-> STM [PrevClientSub s]
-> STM [PrevClientSub s]
-> STM [PrevClientSub s]
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
connected) (Client s -> STM [PrevClientSub s]
updateSubConnected Client s
c) STM [PrevClientSub s]
updateSubDisconnected
          Maybe (Client s)
Nothing -> STM [PrevClientSub s]
updateSubDisconnected
          where
            updateSubConnected :: Client s -> STM [PrevClientSub s]
updateSubConnected Client s
c = case ClientSub
clntSub of
              CSClient RecipientId
qId Maybe RecipientId
prevServiceId Maybe RecipientId
serviceId_ -> do
                TVar IntSet -> (IntSet -> IntSet) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar IntSet
subClients ((IntSet -> IntSet) -> STM ()) -> (IntSet -> IntSet) -> STM ()
forall a b. (a -> b) -> a -> b
$ Int -> IntSet -> IntSet
IS.insert Int
clntId -- add ID to server's subscribed cients
                [PrevClientSub s]
as'' <- if Maybe RecipientId
prevServiceId Maybe RecipientId -> Maybe RecipientId -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe RecipientId
serviceId_ then [PrevClientSub s] -> STM [PrevClientSub s]
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [] else Maybe RecipientId
-> RecipientId -> BrokerMsg -> STM [PrevClientSub s]
endServiceSub Maybe RecipientId
prevServiceId RecipientId
qId BrokerMsg
END
                case Maybe RecipientId
serviceId_ of
                  Just RecipientId
serviceId -> do
                    TVar Int64 -> (Int64 -> Int64) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int64
totalServiceSubs (Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
1) -- server count for all services
                    [PrevClientSub s]
as <- RecipientId -> BrokerMsg -> STM [PrevClientSub s]
endQueueSub RecipientId
qId BrokerMsg
END
                    [PrevClientSub s]
as' <- RecipientId -> Maybe (Client s) -> STM [PrevClientSub s]
cancelServiceSubs RecipientId
serviceId (Maybe (Client s) -> STM [PrevClientSub s])
-> STM (Maybe (Client s)) -> STM [PrevClientSub s]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RecipientId
-> Client s -> SubscribedClients s -> STM (Maybe (Client s))
forall s.
RecipientId
-> Client s -> SubscribedClients s -> STM (Maybe (Client s))
upsertSubscribedClient RecipientId
serviceId Client s
c SubscribedClients s
serviceSubscribers
                    [PrevClientSub s] -> STM [PrevClientSub s]
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([PrevClientSub s] -> STM [PrevClientSub s])
-> [PrevClientSub s] -> STM [PrevClientSub s]
forall a b. (a -> b) -> a -> b
$ [PrevClientSub s]
as [PrevClientSub s] -> [PrevClientSub s] -> [PrevClientSub s]
forall a. [a] -> [a] -> [a]
++ [PrevClientSub s]
as' [PrevClientSub s] -> [PrevClientSub s] -> [PrevClientSub s]
forall a. [a] -> [a] -> [a]
++ [PrevClientSub s]
as''
                  Maybe RecipientId
Nothing -> do
                    [PrevClientSub s]
as <- RecipientId
-> BrokerMsg
-> ClientSubAction
-> Maybe (Client s)
-> STM [PrevClientSub s]
prevSub RecipientId
qId BrokerMsg
END (RecipientId -> ClientSubAction
CSAEndSub RecipientId
qId) (Maybe (Client s) -> STM [PrevClientSub s])
-> STM (Maybe (Client s)) -> STM [PrevClientSub s]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RecipientId
-> Client s -> SubscribedClients s -> STM (Maybe (Client s))
forall s.
RecipientId
-> Client s -> SubscribedClients s -> STM (Maybe (Client s))
upsertSubscribedClient RecipientId
qId Client s
c SubscribedClients s
queueSubscribers
                    [PrevClientSub s] -> STM [PrevClientSub s]
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([PrevClientSub s] -> STM [PrevClientSub s])
-> [PrevClientSub s] -> STM [PrevClientSub s]
forall a b. (a -> b) -> a -> b
$ [PrevClientSub s]
as [PrevClientSub s] -> [PrevClientSub s] -> [PrevClientSub s]
forall a. [a] -> [a] -> [a]
++ [PrevClientSub s]
as''
              CSDeleted RecipientId
qId Maybe RecipientId
serviceId -> do
                Client s -> STM ()
removeWhenNoSubs Client s
c
                [PrevClientSub s]
as <- RecipientId -> BrokerMsg -> STM [PrevClientSub s]
endQueueSub RecipientId
qId BrokerMsg
DELD
                [PrevClientSub s]
as' <- Maybe RecipientId
-> RecipientId -> BrokerMsg -> STM [PrevClientSub s]
endServiceSub Maybe RecipientId
serviceId RecipientId
qId BrokerMsg
DELD
                [PrevClientSub s] -> STM [PrevClientSub s]
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([PrevClientSub s] -> STM [PrevClientSub s])
-> [PrevClientSub s] -> STM [PrevClientSub s]
forall a b. (a -> b) -> a -> b
$ [PrevClientSub s]
as [PrevClientSub s] -> [PrevClientSub s] -> [PrevClientSub s]
forall a. [a] -> [a] -> [a]
++ [PrevClientSub s]
as'
              CSService RecipientId
serviceId Int64
count -> do
                TVar IntSet -> (IntSet -> IntSet) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar IntSet
subClients ((IntSet -> IntSet) -> STM ()) -> (IntSet -> IntSet) -> STM ()
forall a b. (a -> b) -> a -> b
$ Int -> IntSet -> IntSet
IS.insert Int
clntId -- add ID to server's subscribed cients
                TVar Int64 -> (Int64 -> Int64) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int64
totalServiceSubs (Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
count) -- server count for all services
                RecipientId -> Maybe (Client s) -> STM [PrevClientSub s]
cancelServiceSubs RecipientId
serviceId (Maybe (Client s) -> STM [PrevClientSub s])
-> STM (Maybe (Client s)) -> STM [PrevClientSub s]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RecipientId
-> Client s -> SubscribedClients s -> STM (Maybe (Client s))
forall s.
RecipientId
-> Client s -> SubscribedClients s -> STM (Maybe (Client s))
upsertSubscribedClient RecipientId
serviceId Client s
c SubscribedClients s
serviceSubscribers
            updateSubDisconnected :: STM [PrevClientSub s]
updateSubDisconnected = case ClientSub
clntSub of
                -- do not insert client if it is already disconnected, but send END/DELD to any other client subscribed to this queue or service
                CSClient RecipientId
qId Maybe RecipientId
prevServiceId Maybe RecipientId
serviceId -> do
                  [PrevClientSub s]
as <- RecipientId -> BrokerMsg -> STM [PrevClientSub s]
endQueueSub RecipientId
qId BrokerMsg
END
                  [PrevClientSub s]
as' <- Maybe RecipientId
-> RecipientId -> BrokerMsg -> STM [PrevClientSub s]
endServiceSub Maybe RecipientId
serviceId RecipientId
qId BrokerMsg
END
                  [PrevClientSub s]
as'' <- if Maybe RecipientId
prevServiceId Maybe RecipientId -> Maybe RecipientId -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe RecipientId
serviceId then [PrevClientSub s] -> STM [PrevClientSub s]
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [] else Maybe RecipientId
-> RecipientId -> BrokerMsg -> STM [PrevClientSub s]
endServiceSub Maybe RecipientId
prevServiceId RecipientId
qId BrokerMsg
END
                  [PrevClientSub s] -> STM [PrevClientSub s]
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([PrevClientSub s] -> STM [PrevClientSub s])
-> [PrevClientSub s] -> STM [PrevClientSub s]
forall a b. (a -> b) -> a -> b
$ [PrevClientSub s]
as [PrevClientSub s] -> [PrevClientSub s] -> [PrevClientSub s]
forall a. [a] -> [a] -> [a]
++ [PrevClientSub s]
as' [PrevClientSub s] -> [PrevClientSub s] -> [PrevClientSub s]
forall a. [a] -> [a] -> [a]
++ [PrevClientSub s]
as''
                CSDeleted RecipientId
qId Maybe RecipientId
serviceId -> do
                  [PrevClientSub s]
as <- RecipientId -> BrokerMsg -> STM [PrevClientSub s]
endQueueSub RecipientId
qId BrokerMsg
DELD
                  [PrevClientSub s]
as' <- Maybe RecipientId
-> RecipientId -> BrokerMsg -> STM [PrevClientSub s]
endServiceSub Maybe RecipientId
serviceId RecipientId
qId BrokerMsg
DELD
                  [PrevClientSub s] -> STM [PrevClientSub s]
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([PrevClientSub s] -> STM [PrevClientSub s])
-> [PrevClientSub s] -> STM [PrevClientSub s]
forall a b. (a -> b) -> a -> b
$ [PrevClientSub s]
as [PrevClientSub s] -> [PrevClientSub s] -> [PrevClientSub s]
forall a. [a] -> [a] -> [a]
++ [PrevClientSub s]
as'
                CSService RecipientId
serviceId Int64
_ -> RecipientId -> Maybe (Client s) -> STM [PrevClientSub s]
cancelServiceSubs RecipientId
serviceId (Maybe (Client s) -> STM [PrevClientSub s])
-> STM (Maybe (Client s)) -> STM [PrevClientSub s]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RecipientId -> SubscribedClients s -> STM (Maybe (Client s))
forall s.
RecipientId -> SubscribedClients s -> STM (Maybe (Client s))
lookupSubscribedClient RecipientId
serviceId SubscribedClients s
serviceSubscribers
            endQueueSub :: QueueId -> BrokerMsg -> STM [PrevClientSub s]
            endQueueSub :: RecipientId -> BrokerMsg -> STM [PrevClientSub s]
endQueueSub RecipientId
qId BrokerMsg
msg = RecipientId
-> BrokerMsg
-> ClientSubAction
-> Maybe (Client s)
-> STM [PrevClientSub s]
prevSub RecipientId
qId BrokerMsg
msg (RecipientId -> ClientSubAction
CSAEndSub RecipientId
qId) (Maybe (Client s) -> STM [PrevClientSub s])
-> STM (Maybe (Client s)) -> STM [PrevClientSub s]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RecipientId -> SubscribedClients s -> STM (Maybe (Client s))
forall s.
RecipientId -> SubscribedClients s -> STM (Maybe (Client s))
lookupDeleteSubscribedClient RecipientId
qId SubscribedClients s
queueSubscribers
            endServiceSub :: Maybe ServiceId -> QueueId -> BrokerMsg -> STM [PrevClientSub s]
            endServiceSub :: Maybe RecipientId
-> RecipientId -> BrokerMsg -> STM [PrevClientSub s]
endServiceSub Maybe RecipientId
Nothing RecipientId
_ BrokerMsg
_ = [PrevClientSub s] -> STM [PrevClientSub s]
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
            endServiceSub (Just RecipientId
serviceId) RecipientId
qId BrokerMsg
msg = RecipientId
-> BrokerMsg
-> ClientSubAction
-> Maybe (Client s)
-> STM [PrevClientSub s]
prevSub RecipientId
qId BrokerMsg
msg ClientSubAction
CSAEndServiceSub (Maybe (Client s) -> STM [PrevClientSub s])
-> STM (Maybe (Client s)) -> STM [PrevClientSub s]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RecipientId -> SubscribedClients s -> STM (Maybe (Client s))
forall s.
RecipientId -> SubscribedClients s -> STM (Maybe (Client s))
lookupSubscribedClient RecipientId
serviceId SubscribedClients s
serviceSubscribers
            prevSub :: QueueId -> BrokerMsg -> ClientSubAction -> Maybe (Client s) -> STM [PrevClientSub s]
            prevSub :: RecipientId
-> BrokerMsg
-> ClientSubAction
-> Maybe (Client s)
-> STM [PrevClientSub s]
prevSub RecipientId
qId BrokerMsg
msg ClientSubAction
action =
              (Client s -> STM [PrevClientSub s])
-> Maybe (Client s) -> STM [PrevClientSub s]
checkAnotherClient ((Client s -> STM [PrevClientSub s])
 -> Maybe (Client s) -> STM [PrevClientSub s])
-> (Client s -> STM [PrevClientSub s])
-> Maybe (Client s)
-> STM [PrevClientSub s]
forall a b. (a -> b) -> a -> b
$ \Client s
c -> [PrevClientSub s] -> STM [PrevClientSub s]
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(Client s
c, ClientSubAction
action, (RecipientId
qId, BrokerMsg
msg))]
            cancelServiceSubs :: ServiceId -> Maybe (Client s) -> STM [PrevClientSub s]
            cancelServiceSubs :: RecipientId -> Maybe (Client s) -> STM [PrevClientSub s]
cancelServiceSubs RecipientId
serviceId =
              (Client s -> STM [PrevClientSub s])
-> Maybe (Client s) -> STM [PrevClientSub s]
checkAnotherClient ((Client s -> STM [PrevClientSub s])
 -> Maybe (Client s) -> STM [PrevClientSub s])
-> (Client s -> STM [PrevClientSub s])
-> Maybe (Client s)
-> STM [PrevClientSub s]
forall a b. (a -> b) -> a -> b
$ \Client s
c -> do
                Int64
n <- TVar Int64 -> Int64 -> STM Int64
forall a. TVar a -> a -> STM a
swapTVar (Client s -> TVar Int64
clientServiceSubs Client s
c) Int64
0
                [PrevClientSub s] -> STM [PrevClientSub s]
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(Client s
c, Int64 -> ClientSubAction
CSADecreaseSubs Int64
n, (RecipientId
serviceId, Int64 -> BrokerMsg
ENDS Int64
n))]
            checkAnotherClient :: (Client s -> STM [PrevClientSub s]) -> Maybe (Client s) -> STM [PrevClientSub s]
            checkAnotherClient :: (Client s -> STM [PrevClientSub s])
-> Maybe (Client s) -> STM [PrevClientSub s]
checkAnotherClient Client s -> STM [PrevClientSub s]
mkSub = \case
              Just c :: Client s
c@Client {Int
clientId :: Int
$sel:clientId:Client :: forall s. Client s -> Int
clientId, TVar Bool
$sel:connected:Client :: forall s. Client s -> TVar Bool
connected :: TVar Bool
connected} | Int
clntId Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
clientId ->
                STM Bool
-> STM [PrevClientSub s]
-> STM [PrevClientSub s]
-> STM [PrevClientSub s]
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
connected) (Client s -> STM [PrevClientSub s]
mkSub Client s
c) ([PrevClientSub s] -> STM [PrevClientSub s]
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
              Maybe (Client s)
_ -> [PrevClientSub s] -> STM [PrevClientSub s]
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

        endPreviousSubscriptions :: [PrevClientSub s] -> IO ()
        endPreviousSubscriptions :: [PrevClientSub s] -> IO ()
endPreviousSubscriptions = (PrevClientSub s -> IO ()) -> [PrevClientSub s] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((PrevClientSub s -> IO ()) -> [PrevClientSub s] -> IO ())
-> (PrevClientSub s -> IO ()) -> [PrevClientSub s] -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Client s
c, ClientSubAction
subAction, (RecipientId, BrokerMsg)
evt) -> do
          STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (IntMap (NonEmpty (RecipientId, BrokerMsg)))
-> (IntMap (NonEmpty (RecipientId, BrokerMsg))
    -> IntMap (NonEmpty (RecipientId, BrokerMsg)))
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (IntMap (NonEmpty (RecipientId, BrokerMsg)))
pendingEvents ((IntMap (NonEmpty (RecipientId, BrokerMsg))
  -> IntMap (NonEmpty (RecipientId, BrokerMsg)))
 -> STM ())
-> (IntMap (NonEmpty (RecipientId, BrokerMsg))
    -> IntMap (NonEmpty (RecipientId, BrokerMsg)))
-> STM ()
forall a b. (a -> b) -> a -> b
$ (Maybe (NonEmpty (RecipientId, BrokerMsg))
 -> Maybe (NonEmpty (RecipientId, BrokerMsg)))
-> Int
-> IntMap (NonEmpty (RecipientId, BrokerMsg))
-> IntMap (NonEmpty (RecipientId, BrokerMsg))
forall a. (Maybe a -> Maybe a) -> Int -> IntMap a -> IntMap a
IM.alter (NonEmpty (RecipientId, BrokerMsg)
-> Maybe (NonEmpty (RecipientId, BrokerMsg))
forall a. a -> Maybe a
Just (NonEmpty (RecipientId, BrokerMsg)
 -> Maybe (NonEmpty (RecipientId, BrokerMsg)))
-> (Maybe (NonEmpty (RecipientId, BrokerMsg))
    -> NonEmpty (RecipientId, BrokerMsg))
-> Maybe (NonEmpty (RecipientId, BrokerMsg))
-> Maybe (NonEmpty (RecipientId, BrokerMsg))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (RecipientId, BrokerMsg)
-> (NonEmpty (RecipientId, BrokerMsg)
    -> NonEmpty (RecipientId, BrokerMsg))
-> Maybe (NonEmpty (RecipientId, BrokerMsg))
-> NonEmpty (RecipientId, BrokerMsg)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [(RecipientId, BrokerMsg)
Item (NonEmpty (RecipientId, BrokerMsg))
evt] ((RecipientId, BrokerMsg)
evt (RecipientId, BrokerMsg)
-> NonEmpty (RecipientId, BrokerMsg)
-> NonEmpty (RecipientId, BrokerMsg)
forall a. a -> NonEmpty a -> NonEmpty a
<|)) (Client s -> Int
forall s. Client s -> Int
clientId Client s
c)
          case ClientSubAction
subAction of
            CSAEndSub RecipientId
qId -> STM (Maybe sub) -> IO (Maybe sub)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (Client s -> RecipientId -> STM (Maybe sub)
endSub Client s
c RecipientId
qId) IO (Maybe sub) -> (Maybe sub -> 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
>>= Maybe (sub -> IO ()) -> Maybe sub -> IO ()
forall {f :: * -> *} {t}.
Applicative f =>
Maybe (t -> f ()) -> Maybe t -> f ()
a Maybe (sub -> IO ())
unsub_
              where
                a :: Maybe (t -> f ()) -> Maybe t -> f ()
a (Just t -> f ()
unsub) (Just t
s) = t -> f ()
unsub t
s
                a Maybe (t -> f ())
_ Maybe t
_ = () -> f ()
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            ClientSubAction
CSAEndServiceSub -> STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
              TVar Int64 -> (Int64 -> Int64) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (Client s -> TVar Int64
clientServiceSubs Client s
c) Int64 -> Int64
forall {a}. (Ord a, Num a) => a -> a
decrease
              TVar Int64 -> (Int64 -> Int64) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int64
totalServiceSubs Int64 -> Int64
forall {a}. (Ord a, Num a) => a -> a
decrease
              where
                decrease :: a -> a
decrease a
n = a -> a -> a
forall a. Ord a => a -> a -> a
max a
0 (a
n a -> a -> a
forall a. Num a => a -> a -> a
- a
1)
            -- TODO [certs rcv] for SMP subscriptions CSADecreaseSubs should also remove all delivery threads of the passed client
            CSADecreaseSubs Int64
n' -> STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar Int64 -> (Int64 -> Int64) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int64
totalServiceSubs ((Int64 -> Int64) -> STM ()) -> (Int64 -> Int64) -> STM ()
forall a b. (a -> b) -> a -> b
$ \Int64
n -> Int64 -> Int64 -> Int64
forall a. Ord a => a -> a -> a
max Int64
0 (Int64
n Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
n')
          where
            endSub :: Client s -> QueueId -> STM (Maybe sub)
            endSub :: Client s -> RecipientId -> STM (Maybe sub)
endSub Client s
c RecipientId
qId = RecipientId -> TMap RecipientId sub -> STM (Maybe sub)
forall k a. Ord k => k -> TMap k a -> STM (Maybe a)
TM.lookupDelete RecipientId
qId (Client s -> TMap RecipientId sub
clientSubs Client s
c) STM (Maybe sub)
-> (Maybe sub -> STM (Maybe sub)) -> STM (Maybe sub)
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Client s -> STM ()
removeWhenNoSubs Client s
c STM () -> Maybe sub -> STM (Maybe sub)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$>)
        -- remove client from server's subscribed cients
        removeWhenNoSubs :: Client s -> STM ()
removeWhenNoSubs Client s
c = do
          Bool
noClientSubs <- Map RecipientId sub -> Bool
forall a. Map RecipientId a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Map RecipientId sub -> Bool)
-> STM (Map RecipientId sub) -> STM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TMap RecipientId sub -> STM (Map RecipientId sub)
forall a. TVar a -> STM a
readTVar (Client s -> TMap RecipientId sub
clientSubs Client s
c)
          Bool
noServiceSubs <- (Int64
0 Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
==) (Int64 -> Bool) -> STM Int64 -> STM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar Int64 -> STM Int64
forall a. TVar a -> STM a
readTVar (Client s -> TVar Int64
clientServiceSubs Client s
c)
          Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
noClientSubs Bool -> Bool -> Bool
&& Bool
noServiceSubs) (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ TVar IntSet -> (IntSet -> IntSet) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar IntSet
subClients ((IntSet -> IntSet) -> STM ()) -> (IntSet -> IntSet) -> STM ()
forall a b. (a -> b) -> a -> b
$ Int -> IntSet -> IntSet
IS.delete (Client s -> Int
forall s. Client s -> Int
clientId Client s
c)

    deliverNtfsThread :: Server s -> M s ()
    deliverNtfsThread :: Server s -> M s ()
deliverNtfsThread srv :: Server s
srv@Server {$sel:ntfSubscribers:Server :: forall s. Server s -> ServerSubscribers s
ntfSubscribers = ServerSubscribers {TVar IntSet
$sel:subClients:ServerSubscribers :: forall s. ServerSubscribers s -> TVar IntSet
subClients :: TVar IntSet
subClients, SubscribedClients s
$sel:serviceSubscribers:ServerSubscribers :: forall s. ServerSubscribers s -> SubscribedClients s
serviceSubscribers :: SubscribedClients s
serviceSubscribers}} = do
      Int
ntfInt <- (Env s -> Int) -> ReaderT (Env s) IO Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Env s -> Int) -> ReaderT (Env s) IO Int)
-> (Env s -> Int) -> ReaderT (Env s) IO Int
forall a b. (a -> b) -> a -> b
$ ServerConfig s -> Int
forall s. ServerConfig s -> Int
ntfDeliveryInterval (ServerConfig s -> Int)
-> (Env s -> ServerConfig s) -> Env s -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env s -> ServerConfig s
forall s. Env s -> ServerConfig s
config
      s
ms <- (Env s -> s) -> ReaderT (Env s) IO s
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> s
forall s. Env s -> s
msgStore
      NtfStore
ns' <- (Env s -> NtfStore) -> ReaderT (Env s) IO NtfStore
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> NtfStore
forall s. Env s -> NtfStore
ntfStore
      ServerStats
stats <- (Env s -> ServerStats) -> ReaderT (Env s) IO ServerStats
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> ServerStats
forall s. Env s -> ServerStats
serverStats
      IO () -> M s ()
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Int -> IO ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay Int
ntfInt
        s -> NtfStore -> ServerStats -> IO ()
runDeliverNtfs s
ms NtfStore
ns' ServerStats
stats
      where
        runDeliverNtfs :: s -> NtfStore -> ServerStats -> IO ()
        runDeliverNtfs :: s -> NtfStore -> ServerStats -> IO ()
runDeliverNtfs s
ms (NtfStore TMap RecipientId (TVar [MsgNtf])
ns) ServerStats
stats = do
          [(RecipientId, TVar [MsgNtf])]
ntfs <- Map RecipientId (TVar [MsgNtf]) -> [(RecipientId, TVar [MsgNtf])]
forall k a. Map k a -> [(k, a)]
M.assocs (Map RecipientId (TVar [MsgNtf]) -> [(RecipientId, TVar [MsgNtf])])
-> IO (Map RecipientId (TVar [MsgNtf]))
-> IO [(RecipientId, TVar [MsgNtf])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TMap RecipientId (TVar [MsgNtf])
-> IO (Map RecipientId (TVar [MsgNtf]))
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TMap RecipientId (TVar [MsgNtf])
ns
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(RecipientId, TVar [MsgNtf])] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(RecipientId, TVar [MsgNtf])]
ntfs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            forall q s a.
QueueStoreClass q s =>
s
-> [(RecipientId, a)]
-> IO
     (Either
        ErrorType
        ([(Maybe RecipientId, [(RecipientId, a)])], [(RecipientId, a)]))
getQueueNtfServices @(StoreQueue s) (s -> QueueStore s
forall s. MsgStoreClass s => s -> QueueStore s
queueStore s
ms) [(RecipientId, TVar [MsgNtf])]
ntfs IO
  (Either
     ErrorType
     ([(Maybe RecipientId, [(RecipientId, TVar [MsgNtf])])],
      [(RecipientId, TVar [MsgNtf])]))
-> (Either
      ErrorType
      ([(Maybe RecipientId, [(RecipientId, TVar [MsgNtf])])],
       [(RecipientId, TVar [MsgNtf])])
    -> 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
>>= \case
              Left ErrorType
e -> Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logError (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"NOTIFICATIONS: getQueueNtfServices error " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ErrorType -> Text
forall a. Show a => a -> Text
tshow ErrorType
e
              Right ([(Maybe RecipientId, [(RecipientId, TVar [MsgNtf])])]
sNtfs, [(RecipientId, TVar [MsgNtf])]
deleted) -> do
                [(Maybe RecipientId, [(RecipientId, TVar [MsgNtf])])]
-> ((Maybe RecipientId, [(RecipientId, TVar [MsgNtf])]) -> IO ())
-> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Maybe RecipientId, [(RecipientId, TVar [MsgNtf])])]
sNtfs (((Maybe RecipientId, [(RecipientId, TVar [MsgNtf])]) -> IO ())
 -> IO ())
-> ((Maybe RecipientId, [(RecipientId, TVar [MsgNtf])]) -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(Maybe RecipientId
serviceId_, [(RecipientId, TVar [MsgNtf])]
ntfs') -> case Maybe RecipientId
serviceId_ of
                  Just RecipientId
sId -> RecipientId
-> SubscribedClients s -> IO (Maybe (TVar (Maybe (Client s))))
forall s.
RecipientId
-> SubscribedClients s -> IO (Maybe (TVar (Maybe (Client s))))
getSubscribedClient RecipientId
sId SubscribedClients s
serviceSubscribers IO (Maybe (TVar (Maybe (Client s))))
-> (Maybe (TVar (Maybe (Client s))) -> 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
>>= (TVar (Maybe (Client s)) -> IO ())
-> Maybe (TVar (Maybe (Client s))) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([(RecipientId, TVar [MsgNtf])] -> TVar (Maybe (Client s)) -> IO ()
deliverServiceNtfs [(RecipientId, TVar [MsgNtf])]
ntfs')
                  Maybe RecipientId
Nothing -> do -- legacy code that does almost the same as before for non-service subscribers
                    [Int]
cIds <- IntSet -> [Int]
IS.toList (IntSet -> [Int]) -> IO IntSet -> IO [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar IntSet -> IO IntSet
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar IntSet
subClients
                    [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int]
cIds ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
cId -> Int -> Server s -> IO (Maybe (Client s))
forall s. Int -> Server s -> IO (Maybe (Client s))
getServerClient Int
cId Server s
srv IO (Maybe (Client s)) -> (Maybe (Client s) -> 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
>>= (Client s -> IO ()) -> Maybe (Client s) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([(RecipientId, TVar [MsgNtf])] -> Client s -> IO ()
forall {s'}. [(RecipientId, TVar [MsgNtf])] -> Client s' -> IO ()
deliverQueueNtfs [(RecipientId, TVar [MsgNtf])]
ntfs')
                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 (TVar [MsgNtf])
-> (Map RecipientId (TVar [MsgNtf])
    -> Map RecipientId (TVar [MsgNtf]))
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TMap RecipientId (TVar [MsgNtf])
ns (Map RecipientId (TVar [MsgNtf])
-> Set RecipientId -> Map RecipientId (TVar [MsgNtf])
forall k a. Ord k => Map k a -> Set k -> Map k a
`M.withoutKeys` [RecipientId] -> Set RecipientId
forall a. Ord a => [a] -> Set a
S.fromList (((RecipientId, TVar [MsgNtf]) -> RecipientId)
-> [(RecipientId, TVar [MsgNtf])] -> [RecipientId]
forall a b. (a -> b) -> [a] -> [b]
map (RecipientId, TVar [MsgNtf]) -> RecipientId
forall a b. (a, b) -> a
fst [(RecipientId, TVar [MsgNtf])]
deleted))
          where
            deliverQueueNtfs :: [(RecipientId, TVar [MsgNtf])] -> Client s' -> IO ()
deliverQueueNtfs [(RecipientId, TVar [MsgNtf])]
ntfs' c :: Client s'
c@Client {TMap RecipientId ()
$sel:ntfSubscriptions:Client :: forall s. Client s -> TMap RecipientId ()
ntfSubscriptions :: TMap RecipientId ()
ntfSubscriptions} =
              IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ((forall a. TVar a -> IO a) -> Client s' -> IO Bool
forall (m :: * -> *) s'.
Monad m =>
(forall a. TVar a -> m a) -> Client s' -> m Bool
currentClient TVar a -> IO a
forall a. TVar a -> IO a
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO Client s'
c) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                Map RecipientId ()
subs <- TMap RecipientId () -> IO (Map RecipientId ())
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TMap RecipientId ()
ntfSubscriptions
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Map RecipientId () -> Bool
forall k a. Map k a -> Bool
M.null Map RecipientId ()
subs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                  let ntfs'' :: [(RecipientId, TVar [MsgNtf])]
ntfs'' = ((RecipientId, TVar [MsgNtf]) -> Bool)
-> [(RecipientId, TVar [MsgNtf])] -> [(RecipientId, TVar [MsgNtf])]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(RecipientId
nId, TVar [MsgNtf]
_) -> RecipientId -> Map RecipientId () -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member RecipientId
nId Map RecipientId ()
subs) [(RecipientId, TVar [MsgNtf])]
ntfs'
                  IO Int -> IO (Either SomeException Int)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (STM Int -> IO Int
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Int -> IO Int) -> STM Int -> IO Int
forall a b. (a -> b) -> a -> b
$ [(RecipientId, TVar [MsgNtf])] -> Client s' -> STM Int
forall s'. [(RecipientId, TVar [MsgNtf])] -> Client s' -> STM Int
flushSubscribedNtfs [(RecipientId, TVar [MsgNtf])]
ntfs'' Client s'
c) IO (Either SomeException Int)
-> (Either SomeException Int -> 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
>>= Client s' -> Either SomeException Int -> IO ()
forall s'. Client s' -> Either SomeException Int -> IO ()
updateNtfStats Client s'
c
            deliverServiceNtfs :: [(RecipientId, TVar [MsgNtf])] -> TVar (Maybe (Client s)) -> IO ()
deliverServiceNtfs [(RecipientId, TVar [MsgNtf])]
ntfs' TVar (Maybe (Client s))
cv = TVar (Maybe (Client s)) -> IO (Maybe (Client s))
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Maybe (Client s))
cv IO (Maybe (Client s)) -> (Maybe (Client s) -> 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
>>= (Client s -> IO ()) -> Maybe (Client s) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Client s -> IO ()
deliver
              where
                deliver :: Client s -> IO ()
deliver Client s
c = IO Int -> IO (Either SomeException Int)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (STM Int -> IO Int
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Int -> IO Int) -> STM Int -> IO Int
forall a b. (a -> b) -> a -> b
$ (Client s -> STM Int) -> STM Int
withSubscribed ((Client s -> STM Int) -> STM Int)
-> (Client s -> STM Int) -> STM Int
forall a b. (a -> b) -> a -> b
$ [(RecipientId, TVar [MsgNtf])] -> Client s -> STM Int
forall s'. [(RecipientId, TVar [MsgNtf])] -> Client s' -> STM Int
flushSubscribedNtfs [(RecipientId, TVar [MsgNtf])]
ntfs') IO (Either SomeException Int)
-> (Either SomeException Int -> 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
>>= Client s -> Either SomeException Int -> IO ()
forall s'. Client s' -> Either SomeException Int -> IO ()
updateNtfStats Client s
c
                withSubscribed :: (Client s -> STM Int) -> STM Int
                withSubscribed :: (Client s -> STM Int) -> STM Int
withSubscribed Client s -> STM Int
a = TVar (Maybe (Client s)) -> STM (Maybe (Client s))
forall a. TVar a -> STM a
readTVar TVar (Maybe (Client s))
cv STM (Maybe (Client s)) -> (Maybe (Client s) -> STM Int) -> STM Int
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STM Int -> (Client s -> STM Int) -> Maybe (Client s) -> STM Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IOError -> STM Int
forall e a. Exception e => e -> STM a
throwSTM (IOError -> STM Int) -> IOError -> STM Int
forall a b. (a -> b) -> a -> b
$ String -> IOError
userError String
"service unsubscribed") Client s -> STM Int
a
            flushSubscribedNtfs :: [(NotifierId, TVar [MsgNtf])] -> Client s' -> STM Int
            flushSubscribedNtfs :: forall s'. [(RecipientId, TVar [MsgNtf])] -> Client s' -> STM Int
flushSubscribedNtfs [(RecipientId, TVar [MsgNtf])]
ntfs c :: Client s'
c@Client {TBQueue
  (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
sndQ :: TBQueue
  (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
$sel:sndQ:Client :: forall s.
Client s
-> TBQueue
     (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
sndQ} = do
              [Transmission BrokerMsg]
ts_ <- ([Transmission BrokerMsg]
 -> (RecipientId, TVar [MsgNtf]) -> STM [Transmission BrokerMsg])
-> [Transmission BrokerMsg]
-> [(RecipientId, TVar [MsgNtf])]
-> STM [Transmission BrokerMsg]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM [Transmission BrokerMsg]
-> (RecipientId, TVar [MsgNtf]) -> STM [Transmission BrokerMsg]
addNtfs [] [(RecipientId, TVar [MsgNtf])]
ntfs
              Maybe (NonEmpty (Transmission BrokerMsg))
-> (NonEmpty (Transmission BrokerMsg) -> STM ()) -> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Transmission BrokerMsg]
-> Maybe (NonEmpty (Transmission BrokerMsg))
forall a. [a] -> Maybe (NonEmpty a)
L.nonEmpty [Transmission BrokerMsg]
ts_) ((NonEmpty (Transmission BrokerMsg) -> STM ()) -> STM ())
-> (NonEmpty (Transmission BrokerMsg) -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$ \NonEmpty (Transmission BrokerMsg)
ts -> do
                let cancelNtfs :: String -> STM ()
cancelNtfs String
s = IOError -> STM ()
forall e a. Exception e => e -> STM a
throwSTM (IOError -> STM ()) -> IOError -> STM ()
forall a b. (a -> b) -> a -> b
$ String -> IOError
userError (String -> IOError) -> String -> IOError
forall a b. (a -> b) -> a -> b
$ String
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([Transmission BrokerMsg] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Transmission BrokerMsg]
ts_) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" ntfs kept"
                STM Bool -> STM () -> STM ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM ((forall a. TVar a -> STM a) -> Client s' -> STM Bool
forall (m :: * -> *) s'.
Monad m =>
(forall a. TVar a -> m a) -> Client s' -> m Bool
currentClient TVar a -> STM a
forall a. TVar a -> STM a
readTVar Client s'
c) (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ String -> STM ()
cancelNtfs String
"not current client"
                STM Bool -> STM () -> STM ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (TBQueue
  (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
-> STM Bool
forall a. TBQueue a -> STM Bool
isFullTBQueue TBQueue
  (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
sndQ) (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ String -> STM ()
cancelNtfs String
"sending queue full"
                TBQueue
  (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
-> (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
-> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue
  (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
sndQ (NonEmpty (Transmission BrokerMsg)
ts, [])
              Int -> STM Int
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> STM Int) -> Int -> STM Int
forall a b. (a -> b) -> a -> b
$ [Transmission BrokerMsg] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Transmission BrokerMsg]
ts_
            currentClient :: Monad m => (forall a. TVar a -> m a) -> Client s' -> m Bool
            currentClient :: forall (m :: * -> *) s'.
Monad m =>
(forall a. TVar a -> m a) -> Client s' -> m Bool
currentClient forall a. TVar a -> m a
rd Client {Int
$sel:clientId:Client :: forall s. Client s -> Int
clientId :: Int
clientId, TVar Bool
$sel:connected:Client :: forall s. Client s -> TVar Bool
connected :: TVar Bool
connected} = Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool) -> m Bool -> m (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar Bool -> m Bool
forall a. TVar a -> m a
rd TVar Bool
connected m (Bool -> Bool) -> m Bool -> m Bool
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Int -> IntSet -> Bool
IS.member Int
clientId (IntSet -> Bool) -> m IntSet -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar IntSet -> m IntSet
forall a. TVar a -> m a
rd TVar IntSet
subClients)
            addNtfs :: [Transmission BrokerMsg] -> (NotifierId, TVar [MsgNtf]) -> STM [Transmission BrokerMsg]
            addNtfs :: [Transmission BrokerMsg]
-> (RecipientId, TVar [MsgNtf]) -> STM [Transmission BrokerMsg]
addNtfs [Transmission BrokerMsg]
acc (RecipientId
nId, TVar [MsgNtf]
v) =
              TVar [MsgNtf] -> STM [MsgNtf]
forall a. TVar a -> STM a
readTVar TVar [MsgNtf]
v STM [MsgNtf]
-> ([MsgNtf] -> STM [Transmission BrokerMsg])
-> STM [Transmission BrokerMsg]
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                [] -> [Transmission BrokerMsg] -> STM [Transmission BrokerMsg]
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Transmission BrokerMsg]
acc
                [MsgNtf]
ntfs -> do
                  TVar [MsgNtf] -> [MsgNtf] -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar [MsgNtf]
v []
                  [Transmission BrokerMsg] -> STM [Transmission BrokerMsg]
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Transmission BrokerMsg] -> STM [Transmission BrokerMsg])
-> [Transmission BrokerMsg] -> STM [Transmission BrokerMsg]
forall a b. (a -> b) -> a -> b
$ ([Transmission BrokerMsg] -> MsgNtf -> [Transmission BrokerMsg])
-> [Transmission BrokerMsg] -> [MsgNtf] -> [Transmission BrokerMsg]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\[Transmission BrokerMsg]
acc' MsgNtf
ntf -> RecipientId -> MsgNtf -> Transmission BrokerMsg
forall {b}. b -> MsgNtf -> (CorrId, b, BrokerMsg)
nmsg RecipientId
nId MsgNtf
ntf Transmission BrokerMsg
-> [Transmission BrokerMsg] -> [Transmission BrokerMsg]
forall a. a -> [a] -> [a]
: [Transmission BrokerMsg]
acc') [Transmission BrokerMsg]
acc [MsgNtf]
ntfs -- reverses, to order by time
            nmsg :: b -> MsgNtf -> (CorrId, b, BrokerMsg)
nmsg b
nId MsgNtf {CbNonce
ntfNonce :: CbNonce
ntfNonce :: MsgNtf -> CbNonce
ntfNonce, ByteString
ntfEncMeta :: ByteString
ntfEncMeta :: MsgNtf -> ByteString
ntfEncMeta} = (CorrId
NoCorrId, b
nId, CbNonce -> ByteString -> BrokerMsg
NMSG CbNonce
ntfNonce ByteString
ntfEncMeta)
            updateNtfStats :: Client s' -> Either SomeException Int -> IO ()
            updateNtfStats :: forall s'. Client s' -> Either SomeException Int -> IO ()
updateNtfStats Client {Int
$sel:clientId:Client :: forall s. Client s -> Int
clientId :: Int
clientId} = \case
              Right Int
0 -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              Right Int
len -> do
                IORef Int -> (Int -> Int) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef'_ (ServerStats -> IORef Int
ntfCount ServerStats
stats) (Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
len)
                IORef Int -> (Int -> Int) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef'_ (ServerStats -> IORef Int
msgNtfs ServerStats
stats) (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
len)
                IORef Int -> (Int -> Int) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef'_ (ServerStats -> IORef Int
msgNtfsB ServerStats
stats) (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
len Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
80 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) -- up to 80 NMSG in the batch
              Left SomeException
e -> Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logNote (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"NOTIFICATIONS: cancelled for client #" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
clientId Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", reason: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeException -> Text
forall a. Show a => a -> Text
tshow SomeException
e

    sendPendingEvtsThread :: Server s -> M s ()
    sendPendingEvtsThread :: Server s -> M s ()
sendPendingEvtsThread srv :: Server s
srv@Server {ServerSubscribers s
$sel:subscribers:Server :: forall s. Server s -> ServerSubscribers s
subscribers :: ServerSubscribers s
subscribers, ServerSubscribers s
$sel:ntfSubscribers:Server :: forall s. Server s -> ServerSubscribers s
ntfSubscribers :: ServerSubscribers s
ntfSubscribers} = do
      Int
endInt <- (Env s -> Int) -> ReaderT (Env s) IO Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Env s -> Int) -> ReaderT (Env s) IO Int)
-> (Env s -> Int) -> ReaderT (Env s) IO Int
forall a b. (a -> b) -> a -> b
$ ServerConfig s -> Int
forall s. ServerConfig s -> Int
pendingENDInterval (ServerConfig s -> Int)
-> (Env s -> ServerConfig s) -> Env s -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env s -> ServerConfig s
forall s. Env s -> ServerConfig s
config
      ServerStats
stats <- (Env s -> ServerStats) -> ReaderT (Env s) IO ServerStats
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> ServerStats
forall s. Env s -> ServerStats
serverStats
      IO () -> M s ()
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Int -> IO ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay Int
endInt
        ServerSubscribers s -> ServerStats -> IO ()
sendPending ServerSubscribers s
subscribers ServerStats
stats
        ServerSubscribers s -> ServerStats -> IO ()
sendPending ServerSubscribers s
ntfSubscribers ServerStats
stats
      where
        sendPending :: ServerSubscribers s -> ServerStats -> IO ()
sendPending ServerSubscribers {TVar (IntMap (NonEmpty (RecipientId, BrokerMsg)))
$sel:pendingEvents:ServerSubscribers :: forall s.
ServerSubscribers s
-> TVar (IntMap (NonEmpty (RecipientId, BrokerMsg)))
pendingEvents :: TVar (IntMap (NonEmpty (RecipientId, BrokerMsg)))
pendingEvents} ServerStats
stats = do
          IntMap (NonEmpty (RecipientId, BrokerMsg))
pending <- STM (IntMap (NonEmpty (RecipientId, BrokerMsg)))
-> IO (IntMap (NonEmpty (RecipientId, BrokerMsg)))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (IntMap (NonEmpty (RecipientId, BrokerMsg)))
 -> IO (IntMap (NonEmpty (RecipientId, BrokerMsg))))
-> STM (IntMap (NonEmpty (RecipientId, BrokerMsg)))
-> IO (IntMap (NonEmpty (RecipientId, BrokerMsg)))
forall a b. (a -> b) -> a -> b
$ TVar (IntMap (NonEmpty (RecipientId, BrokerMsg)))
-> IntMap (NonEmpty (RecipientId, BrokerMsg))
-> STM (IntMap (NonEmpty (RecipientId, BrokerMsg)))
forall a. TVar a -> a -> STM a
swapTVar TVar (IntMap (NonEmpty (RecipientId, BrokerMsg)))
pendingEvents IntMap (NonEmpty (RecipientId, BrokerMsg))
forall a. IntMap a
IM.empty
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (IntMap (NonEmpty (RecipientId, BrokerMsg)) -> Bool
forall a. IntMap a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null IntMap (NonEmpty (RecipientId, BrokerMsg))
pending) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [(Int, NonEmpty (RecipientId, BrokerMsg))]
-> ((Int, NonEmpty (RecipientId, BrokerMsg)) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (IntMap (NonEmpty (RecipientId, BrokerMsg))
-> [(Int, NonEmpty (RecipientId, BrokerMsg))]
forall a. IntMap a -> [(Int, a)]
IM.assocs IntMap (NonEmpty (RecipientId, BrokerMsg))
pending) (((Int, NonEmpty (RecipientId, BrokerMsg)) -> IO ()) -> IO ())
-> ((Int, NonEmpty (RecipientId, BrokerMsg)) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Int
cId, NonEmpty (RecipientId, BrokerMsg)
evts) ->
            Int -> Server s -> IO (Maybe (Client s))
forall s. Int -> Server s -> IO (Maybe (Client s))
getServerClient Int
cId Server s
srv IO (Maybe (Client s)) -> (Maybe (Client s) -> 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
>>= (Client s -> IO ()) -> Maybe (Client s) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (NonEmpty (RecipientId, BrokerMsg) -> Client s -> IO ()
enqueueEvts NonEmpty (RecipientId, BrokerMsg)
evts)
          where
            enqueueEvts :: NonEmpty (RecipientId, BrokerMsg) -> Client s -> IO ()
enqueueEvts NonEmpty (RecipientId, BrokerMsg)
evts c :: Client s
c@Client {TVar Bool
$sel:connected:Client :: forall s. Client s -> TVar Bool
connected :: TVar Bool
connected, TBQueue
  (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
$sel:sndQ:Client :: forall s.
Client s
-> TBQueue
     (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
sndQ :: TBQueue
  (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
sndQ} =
              IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (TVar Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar Bool
connected) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                Bool
sent <- STM Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ TBQueue
  (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
-> (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
-> STM Bool
forall a. TBQueue a -> a -> STM Bool
tryWriteTBQueue TBQueue
  (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
sndQ (NonEmpty (Transmission BrokerMsg)
ts, [])
                if Bool
sent
                  then IO ()
updateEndStats
                  else -- if queue is full it can block
                    Client s -> String -> IO () -> IO ()
forall (m :: * -> *) s.
MonadUnliftIO m =>
Client s -> String -> m () -> m ()
forkClient Client s
c String
"sendPendingEvtsThread.queueEvts" (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                      STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TBQueue
  (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
-> (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
-> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue
  (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
sndQ (NonEmpty (Transmission BrokerMsg)
ts, [])) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
updateEndStats
              where
                ts :: NonEmpty (Transmission BrokerMsg)
ts = ((RecipientId, BrokerMsg) -> Transmission BrokerMsg)
-> NonEmpty (RecipientId, BrokerMsg)
-> NonEmpty (Transmission BrokerMsg)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map (\(RecipientId
entId, BrokerMsg
evt) -> (CorrId
NoCorrId, RecipientId
entId, BrokerMsg
evt)) NonEmpty (RecipientId, BrokerMsg)
evts
                -- this accounts for both END and DELD events
                updateEndStats :: IO ()
updateEndStats = do
                  let len :: Int
len = NonEmpty (RecipientId, BrokerMsg) -> Int
forall a. NonEmpty a -> Int
L.length NonEmpty (RecipientId, BrokerMsg)
evts
                  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                    IORef Int -> (Int -> Int) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef'_ (ServerStats -> IORef Int
qSubEnd ServerStats
stats) (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
len)
                    IORef Int -> (Int -> Int) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef'_ (ServerStats -> IORef Int
qSubEndB ServerStats
stats) (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
len Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
255 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) -- up to 255 ENDs or DELDs in the batch

    receiveFromProxyAgent :: ProxyAgent -> M s ()
    receiveFromProxyAgent :: ProxyAgent -> M s ()
receiveFromProxyAgent ProxyAgent {$sel:smpAgent:ProxyAgent :: ProxyAgent -> SMPClientAgent 'Sender
smpAgent = SMPClientAgent {TBQueue SMPClientAgentEvent
agentQ :: TBQueue SMPClientAgentEvent
$sel:agentQ:SMPClientAgent :: forall (p :: Party).
SMPClientAgent p -> TBQueue SMPClientAgentEvent
agentQ}} =
      M s () -> M s ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (M s () -> M s ()) -> M s () -> M s ()
forall a b. (a -> b) -> a -> b
$
        STM SMPClientAgentEvent -> ReaderT (Env s) IO SMPClientAgentEvent
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TBQueue SMPClientAgentEvent -> STM SMPClientAgentEvent
forall a. TBQueue a -> STM a
readTBQueue TBQueue SMPClientAgentEvent
agentQ) ReaderT (Env s) IO SMPClientAgentEvent
-> (SMPClientAgentEvent -> M s ()) -> M s ()
forall a b.
ReaderT (Env s) IO a
-> (a -> ReaderT (Env s) IO b) -> ReaderT (Env s) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          CAConnected SMPServer
srv Maybe RecipientId
_service_ -> Text -> M s ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logInfo (Text -> M s ()) -> Text -> M s ()
forall a b. (a -> b) -> a -> b
$ Text
"SMP server connected " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SMPServer -> Text
forall {p :: ProtocolType}. ProtocolServer p -> Text
showServer' SMPServer
srv
          CADisconnected SMPServer
srv NonEmpty RecipientId
qIds -> Text -> M s ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logError (Text -> M s ()) -> Text -> M s ()
forall a b. (a -> b) -> a -> b
$ Text
"SMP server disconnected " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SMPServer -> Text
forall {p :: ProtocolType}. ProtocolServer p -> Text
showServer' SMPServer
srv Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" / subscriptions: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (NonEmpty RecipientId -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty RecipientId
qIds)
          -- the errors below should never happen - messaging proxy does not make any subscriptions
          CASubscribed SMPServer
srv Maybe RecipientId
serviceId NonEmpty RecipientId
qIds -> Text -> M s ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logError (Text -> M s ()) -> Text -> M s ()
forall a b. (a -> b) -> a -> b
$ Text
"SMP server subscribed queues " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
asService Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SMPServer -> Text
forall {p :: ProtocolType}. ProtocolServer p -> Text
showServer' SMPServer
srv Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" / subscriptions: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (NonEmpty RecipientId -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty RecipientId
qIds)
            where
              asService :: Text
asService = if Maybe RecipientId -> Bool
forall a. Maybe a -> Bool
isJust Maybe RecipientId
serviceId then Text
"as service " else Text
""
          CASubError SMPServer
srv NonEmpty (RecipientId, SMPClientError)
errs -> Text -> M s ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logError (Text -> M s ()) -> Text -> M s ()
forall a b. (a -> b) -> a -> b
$ Text
"SMP server subscription errors " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SMPServer -> Text
forall {p :: ProtocolType}. ProtocolServer p -> Text
showServer' SMPServer
srv Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" / errors: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (NonEmpty (RecipientId, SMPClientError) -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty (RecipientId, SMPClientError)
errs)
          CAServiceDisconnected {} -> Text -> M s ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logError Text
"CAServiceDisconnected"
          CAServiceSubscribed {} -> Text -> M s ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logError Text
"CAServiceSubscribed"
          CAServiceSubError {} -> Text -> M s ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logError Text
"CAServiceSubError"
          CAServiceUnavailable {} -> Text -> M s ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logError Text
"CAServiceUnavailable"
      where
        showServer' :: ProtocolServer p -> Text
showServer' = ByteString -> Text
decodeLatin1 (ByteString -> Text)
-> (ProtocolServer p -> ByteString) -> ProtocolServer p -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty TransportHost -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode (NonEmpty TransportHost -> ByteString)
-> (ProtocolServer p -> NonEmpty TransportHost)
-> ProtocolServer p
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProtocolServer p -> NonEmpty TransportHost
forall (p :: ProtocolType).
ProtocolServer p -> NonEmpty TransportHost
host

    expireMessagesThread_ :: ServerConfig s -> [M s ()]
    expireMessagesThread_ :: ServerConfig s -> [M s ()]
expireMessagesThread_ ServerConfig {$sel:messageExpiration:ServerConfig :: forall s. ServerConfig s -> Maybe ExpirationConfig
messageExpiration = Just ExpirationConfig
msgExp} = [ExpirationConfig -> M s ()
expireMessagesThread ExpirationConfig
msgExp]
    expireMessagesThread_ ServerConfig s
_ = []

    expireMessagesThread :: ExpirationConfig -> M s ()
    expireMessagesThread :: ExpirationConfig -> M s ()
expireMessagesThread ExpirationConfig {Int64
checkInterval :: Int64
checkInterval :: ExpirationConfig -> Int64
checkInterval, Int64
ttl :: Int64
ttl :: ExpirationConfig -> Int64
ttl} = do
      s
ms <- (Env s -> s) -> ReaderT (Env s) IO s
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> s
forall s. Env s -> s
msgStore
      let interval :: Int64
interval = Int64
checkInterval Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
1000000
      ServerStats
stats <- (Env s -> ServerStats) -> ReaderT (Env s) IO ServerStats
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> ServerStats
forall s. Env s -> ServerStats
serverStats
      String -> M s ()
forall (m :: * -> *). MonadIO m => String -> m ()
labelMyThread String
"expireMessagesThread"
      IO () -> M s ()
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ s -> ServerStats -> Int64 -> IO ()
expire s
ms ServerStats
stats Int64
interval
      where
        expire :: s -> ServerStats -> Int64 -> IO ()
        expire :: s -> ServerStats -> Int64 -> IO ()
expire s
ms ServerStats
stats Int64
interval = do
          Int64 -> IO ()
threadDelay' Int64
interval
          Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logNote Text
"Started expiring messages..."
          Int64
n <- forall q s. QueueStoreClass q s => s -> IO Int64
compactQueues @(StoreQueue s) (QueueStore s -> IO Int64) -> QueueStore s -> IO Int64
forall a b. (a -> b) -> a -> b
$ s -> QueueStore s
forall s. MsgStoreClass s => s -> QueueStore s
queueStore s
ms
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int64
n Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logNote (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Removed " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int64 -> Text
forall a. Show a => a -> Text
tshow Int64
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" old deleted queues from the database."
          Int64
now <- SystemTime -> Int64
systemSeconds (SystemTime -> Int64) -> IO SystemTime -> IO Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO SystemTime
getSystemTime
          IO MessageStats -> IO (Either SomeException MessageStats)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (Bool -> s -> Int64 -> Int64 -> IO MessageStats
forall s.
MsgStoreClass s =>
Bool -> s -> Int64 -> Int64 -> IO MessageStats
expireOldMessages Bool
False s
ms Int64
now Int64
ttl) IO (Either SomeException MessageStats)
-> (Either SomeException MessageStats -> 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
>>= \case
            Right msgStats :: MessageStats
msgStats@MessageStats {$sel:storedMsgsCount:MessageStats :: MessageStats -> Int
storedMsgsCount = Int
stored, $sel:expiredMsgsCount:MessageStats :: MessageStats -> Int
expiredMsgsCount = Int
expired} -> do
              IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
atomicWriteIORef (ServerStats -> IORef Int
msgCount ServerStats
stats) Int
stored
              IORef Int -> (Int -> Int) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef'_ (ServerStats -> IORef Int
msgExpired ServerStats
stats) (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
expired)
              Text -> MessageStats -> IO ()
printMessageStats Text
"STORE: messages" MessageStats
msgStats
            Left SomeException
e -> Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logError (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"STORE: expireOldMessages, error expiring messages, " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeException -> Text
forall a. Show a => a -> Text
tshow SomeException
e

    expireNtfsThread :: ServerConfig s -> M s ()
    expireNtfsThread :: ServerConfig s -> M s ()
expireNtfsThread ServerConfig {$sel:notificationExpiration:ServerConfig :: forall s. ServerConfig s -> ExpirationConfig
notificationExpiration = ExpirationConfig
expCfg} = do
      NtfStore
ns <- (Env s -> NtfStore) -> ReaderT (Env s) IO NtfStore
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> NtfStore
forall s. Env s -> NtfStore
ntfStore
      let interval :: Int64
interval = ExpirationConfig -> Int64
checkInterval ExpirationConfig
expCfg Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
1000000
      ServerStats
stats <- (Env s -> ServerStats) -> ReaderT (Env s) IO ServerStats
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> ServerStats
forall s. Env s -> ServerStats
serverStats
      String -> M s ()
forall (m :: * -> *). MonadIO m => String -> m ()
labelMyThread String
"expireNtfsThread"
      IO () -> M s ()
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Int64 -> IO ()
threadDelay' Int64
interval
        Int64
old <- ExpirationConfig -> IO Int64
expireBeforeEpoch ExpirationConfig
expCfg
        Int
expired <- NtfStore -> Int64 -> IO Int
deleteExpiredNtfs NtfStore
ns Int64
old
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
expired Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          IORef Int -> (Int -> Int) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef'_ (ServerStats -> IORef Int
msgNtfExpired ServerStats
stats) (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
expired)
          IORef Int -> (Int -> Int) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef'_ (ServerStats -> IORef Int
ntfCount ServerStats
stats) (Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
expired)

    serverStatsThread_ :: ServerConfig s -> [M s ()]
    serverStatsThread_ :: ServerConfig s -> [M s ()]
serverStatsThread_ ServerConfig {$sel:logStatsInterval:ServerConfig :: forall s. ServerConfig s -> Maybe Int64
logStatsInterval = Just Int64
interval, Int64
logStatsStartTime :: Int64
$sel:logStatsStartTime:ServerConfig :: forall s. ServerConfig s -> Int64
logStatsStartTime, String
serverStatsLogFile :: String
$sel:serverStatsLogFile:ServerConfig :: forall s. ServerConfig s -> String
serverStatsLogFile} =
      [Int64 -> Int64 -> String -> M s ()
logServerStats Int64
logStatsStartTime Int64
interval String
serverStatsLogFile]
    serverStatsThread_ ServerConfig s
_ = []

    logServerStats :: Int64 -> Int64 -> FilePath -> M s ()
    logServerStats :: Int64 -> Int64 -> String -> M s ()
logServerStats Int64
startAt Int64
logInterval String
statsFilePath = do
      String -> M s ()
forall (m :: * -> *). MonadIO m => String -> m ()
labelMyThread String
"logServerStats"
      Int64
initialDelay <- (Int64
startAt Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
-) (Int64 -> Int64) -> (UTCTime -> Int64) -> UTCTime -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int64) -> (UTCTime -> Integer) -> UTCTime -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
1000000_000000) (Integer -> Integer) -> (UTCTime -> Integer) -> UTCTime -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiffTime -> Integer
diffTimeToPicoseconds (DiffTime -> Integer)
-> (UTCTime -> DiffTime) -> UTCTime -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> DiffTime
utctDayTime (UTCTime -> Int64)
-> ReaderT (Env s) IO UTCTime -> ReaderT (Env s) IO Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime -> ReaderT (Env s) IO UTCTime
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
      IO () -> M s ()
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"server stats log enabled: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
statsFilePath
      IO () -> M s ()
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
forall a b. (a -> b) -> a -> b
$ Int64 -> IO ()
threadDelay' (Int64 -> IO ()) -> Int64 -> IO ()
forall a b. (a -> b) -> a -> b
$ Int64
1000000 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* (Int64
initialDelay Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ if Int64
initialDelay Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int64
0 then Int64
86400 else Int64
0)
      ss :: ServerStats
ss@ServerStats {IORef UTCTime
fromTime :: IORef UTCTime
fromTime :: ServerStats -> IORef UTCTime
fromTime, IORef Int
qCreated :: IORef Int
qCreated :: ServerStats -> IORef Int
qCreated, IORef Int
qSecured :: IORef Int
qSecured :: ServerStats -> IORef Int
qSecured, IORef Int
qDeletedAll :: IORef Int
qDeletedAll :: ServerStats -> IORef Int
qDeletedAll, IORef Int
qDeletedAllB :: IORef Int
qDeletedAllB :: ServerStats -> IORef Int
qDeletedAllB, IORef Int
qDeletedNew :: IORef Int
qDeletedNew :: ServerStats -> IORef Int
qDeletedNew, IORef Int
qDeletedSecured :: IORef Int
qDeletedSecured :: ServerStats -> IORef Int
qDeletedSecured, IORef Int
qSub :: IORef Int
qSub :: ServerStats -> IORef Int
qSub, IORef Int
qSubAllB :: IORef Int
qSubAllB :: ServerStats -> IORef Int
qSubAllB, IORef Int
qSubAuth :: IORef Int
qSubAuth :: ServerStats -> IORef Int
qSubAuth, IORef Int
qSubDuplicate :: IORef Int
qSubDuplicate :: ServerStats -> IORef Int
qSubDuplicate, IORef Int
qSubProhibited :: IORef Int
qSubProhibited :: ServerStats -> IORef Int
qSubProhibited, IORef Int
qSubEnd :: ServerStats -> IORef Int
qSubEnd :: IORef Int
qSubEnd, IORef Int
qSubEndB :: ServerStats -> IORef Int
qSubEndB :: IORef Int
qSubEndB, IORef Int
ntfCreated :: IORef Int
ntfCreated :: ServerStats -> IORef Int
ntfCreated, IORef Int
ntfDeleted :: IORef Int
ntfDeleted :: ServerStats -> IORef Int
ntfDeleted, IORef Int
ntfDeletedB :: IORef Int
ntfDeletedB :: ServerStats -> IORef Int
ntfDeletedB, IORef Int
ntfSub :: IORef Int
ntfSub :: ServerStats -> IORef Int
ntfSub, IORef Int
ntfSubB :: IORef Int
ntfSubB :: ServerStats -> IORef Int
ntfSubB, IORef Int
ntfSubAuth :: IORef Int
ntfSubAuth :: ServerStats -> IORef Int
ntfSubAuth, IORef Int
ntfSubDuplicate :: IORef Int
ntfSubDuplicate :: ServerStats -> IORef Int
ntfSubDuplicate, IORef Int
msgSent :: IORef Int
msgSent :: ServerStats -> IORef Int
msgSent, IORef Int
msgSentAuth :: IORef Int
msgSentAuth :: ServerStats -> IORef Int
msgSentAuth, IORef Int
msgSentQuota :: IORef Int
msgSentQuota :: ServerStats -> IORef Int
msgSentQuota, IORef Int
msgSentLarge :: IORef Int
msgSentLarge :: ServerStats -> IORef Int
msgSentLarge, IORef Int
msgRecv :: IORef Int
msgRecv :: ServerStats -> IORef Int
msgRecv, IORef Int
msgRecvGet :: IORef Int
msgRecvGet :: ServerStats -> IORef Int
msgRecvGet, IORef Int
msgGet :: IORef Int
msgGet :: ServerStats -> IORef Int
msgGet, IORef Int
msgGetNoMsg :: IORef Int
msgGetNoMsg :: ServerStats -> IORef Int
msgGetNoMsg, IORef Int
msgGetAuth :: IORef Int
msgGetAuth :: ServerStats -> IORef Int
msgGetAuth, IORef Int
msgGetDuplicate :: IORef Int
msgGetDuplicate :: ServerStats -> IORef Int
msgGetDuplicate, IORef Int
msgGetProhibited :: IORef Int
msgGetProhibited :: ServerStats -> IORef Int
msgGetProhibited, IORef Int
msgExpired :: ServerStats -> IORef Int
msgExpired :: IORef Int
msgExpired, PeriodStats
activeQueues :: PeriodStats
activeQueues :: ServerStats -> PeriodStats
activeQueues, IORef Int
msgSentNtf :: IORef Int
msgSentNtf :: ServerStats -> IORef Int
msgSentNtf, IORef Int
msgRecvNtf :: IORef Int
msgRecvNtf :: ServerStats -> IORef Int
msgRecvNtf, PeriodStats
activeQueuesNtf :: PeriodStats
activeQueuesNtf :: ServerStats -> PeriodStats
activeQueuesNtf, IORef Int
qCount :: IORef Int
qCount :: ServerStats -> IORef Int
qCount, IORef Int
msgCount :: ServerStats -> IORef Int
msgCount :: IORef Int
msgCount, IORef Int
ntfCount :: ServerStats -> IORef Int
ntfCount :: IORef Int
ntfCount, ProxyStats
pRelays :: ProxyStats
pRelays :: ServerStats -> ProxyStats
pRelays, ProxyStats
pRelaysOwn :: ProxyStats
pRelaysOwn :: ServerStats -> ProxyStats
pRelaysOwn, ProxyStats
pMsgFwds :: ProxyStats
pMsgFwds :: ServerStats -> ProxyStats
pMsgFwds, ProxyStats
pMsgFwdsOwn :: ProxyStats
pMsgFwdsOwn :: ServerStats -> ProxyStats
pMsgFwdsOwn, IORef Int
pMsgFwdsRecv :: IORef Int
pMsgFwdsRecv :: ServerStats -> IORef Int
pMsgFwdsRecv, ServiceStats
rcvServices :: ServiceStats
rcvServices :: ServerStats -> ServiceStats
rcvServices, ServiceStats
ntfServices :: ServiceStats
ntfServices :: ServerStats -> ServiceStats
ntfServices}
        <- (Env s -> ServerStats) -> ReaderT (Env s) IO ServerStats
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> ServerStats
forall s. Env s -> ServerStats
serverStats
      s
st <- (Env s -> s) -> ReaderT (Env s) IO s
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> s
forall s. Env s -> s
msgStore
      EntityCounts {Int
queueCount :: Int
queueCount :: EntityCounts -> Int
queueCount, Int
notifierCount :: Int
notifierCount :: EntityCounts -> Int
notifierCount, Int
rcvServiceCount :: Int
rcvServiceCount :: EntityCounts -> Int
rcvServiceCount, Int
ntfServiceCount :: Int
ntfServiceCount :: EntityCounts -> Int
ntfServiceCount, Int
rcvServiceQueuesCount :: Int
rcvServiceQueuesCount :: EntityCounts -> Int
rcvServiceQueuesCount, Int
ntfServiceQueuesCount :: Int
ntfServiceQueuesCount :: EntityCounts -> Int
ntfServiceQueuesCount} <-
        IO EntityCounts -> ReaderT (Env s) IO EntityCounts
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO EntityCounts -> ReaderT (Env s) IO EntityCounts)
-> IO EntityCounts -> ReaderT (Env s) IO EntityCounts
forall a b. (a -> b) -> a -> b
$ forall q s. QueueStoreClass q s => s -> IO EntityCounts
getEntityCounts @(StoreQueue s) (QueueStore s -> IO EntityCounts)
-> QueueStore s -> IO EntityCounts
forall a b. (a -> b) -> a -> b
$ s -> QueueStore s
forall s. MsgStoreClass s => s -> QueueStore s
queueStore s
st
      let interval :: Int64
interval = Int64
1000000 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
logInterval
      M s () -> M s ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (M s () -> M s ()) -> M s () -> M s ()
forall a b. (a -> b) -> a -> b
$ do
        String -> IOMode -> (Handle -> M s ()) -> M s ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> IOMode -> (Handle -> m a) -> m a
withFile String
statsFilePath IOMode
AppendMode ((Handle -> M s ()) -> M s ()) -> (Handle -> M s ()) -> M s ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> IO () -> M s ()
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
forall a b. (a -> b) -> a -> b
$ do
          Handle -> BufferMode -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> BufferMode -> m ()
hSetBuffering Handle
h BufferMode
LineBuffering
          UTCTime
ts <- IO UTCTime
getCurrentTime
          UTCTime
fromTime' <- IORef UTCTime -> UTCTime -> IO UTCTime
forall a. IORef a -> a -> IO a
atomicSwapIORef IORef UTCTime
fromTime UTCTime
ts
          Int
qCreated' <- IORef Int -> Int -> IO Int
forall a. IORef a -> a -> IO a
atomicSwapIORef IORef Int
qCreated Int
0
          Int
qSecured' <- IORef Int -> Int -> IO Int
forall a. IORef a -> a -> IO a
atomicSwapIORef IORef Int
qSecured Int
0
          Int
qDeletedAll' <- IORef Int -> Int -> IO Int
forall a. IORef a -> a -> IO a
atomicSwapIORef IORef Int
qDeletedAll Int
0
          Int
qDeletedAllB' <- IORef Int -> Int -> IO Int
forall a. IORef a -> a -> IO a
atomicSwapIORef IORef Int
qDeletedAllB Int
0
          Int
qDeletedNew' <- IORef Int -> Int -> IO Int
forall a. IORef a -> a -> IO a
atomicSwapIORef IORef Int
qDeletedNew Int
0
          Int
qDeletedSecured' <- IORef Int -> Int -> IO Int
forall a. IORef a -> a -> IO a
atomicSwapIORef IORef Int
qDeletedSecured Int
0
          Int
qSub' <- IORef Int -> Int -> IO Int
forall a. IORef a -> a -> IO a
atomicSwapIORef IORef Int
qSub Int
0
          Int
qSubAllB' <- IORef Int -> Int -> IO Int
forall a. IORef a -> a -> IO a
atomicSwapIORef IORef Int
qSubAllB Int
0
          Int
qSubAuth' <- IORef Int -> Int -> IO Int
forall a. IORef a -> a -> IO a
atomicSwapIORef IORef Int
qSubAuth Int
0
          Int
qSubDuplicate' <- IORef Int -> Int -> IO Int
forall a. IORef a -> a -> IO a
atomicSwapIORef IORef Int
qSubDuplicate Int
0
          Int
qSubProhibited' <- IORef Int -> Int -> IO Int
forall a. IORef a -> a -> IO a
atomicSwapIORef IORef Int
qSubProhibited Int
0
          Int
qSubEnd' <- IORef Int -> Int -> IO Int
forall a. IORef a -> a -> IO a
atomicSwapIORef IORef Int
qSubEnd Int
0
          Int
qSubEndB' <- IORef Int -> Int -> IO Int
forall a. IORef a -> a -> IO a
atomicSwapIORef IORef Int
qSubEndB Int
0
          Int
ntfCreated' <- IORef Int -> Int -> IO Int
forall a. IORef a -> a -> IO a
atomicSwapIORef IORef Int
ntfCreated Int
0
          Int
ntfDeleted' <- IORef Int -> Int -> IO Int
forall a. IORef a -> a -> IO a
atomicSwapIORef IORef Int
ntfDeleted Int
0
          Int
ntfDeletedB' <- IORef Int -> Int -> IO Int
forall a. IORef a -> a -> IO a
atomicSwapIORef IORef Int
ntfDeletedB Int
0
          Int
ntfSub' <- IORef Int -> Int -> IO Int
forall a. IORef a -> a -> IO a
atomicSwapIORef IORef Int
ntfSub Int
0
          Int
ntfSubB' <- IORef Int -> Int -> IO Int
forall a. IORef a -> a -> IO a
atomicSwapIORef IORef Int
ntfSubB Int
0
          Int
ntfSubAuth' <- IORef Int -> Int -> IO Int
forall a. IORef a -> a -> IO a
atomicSwapIORef IORef Int
ntfSubAuth Int
0
          Int
ntfSubDuplicate' <- IORef Int -> Int -> IO Int
forall a. IORef a -> a -> IO a
atomicSwapIORef IORef Int
ntfSubDuplicate Int
0
          Int
msgSent' <- IORef Int -> Int -> IO Int
forall a. IORef a -> a -> IO a
atomicSwapIORef IORef Int
msgSent Int
0
          Int
msgSentAuth' <- IORef Int -> Int -> IO Int
forall a. IORef a -> a -> IO a
atomicSwapIORef IORef Int
msgSentAuth Int
0
          Int
msgSentQuota' <- IORef Int -> Int -> IO Int
forall a. IORef a -> a -> IO a
atomicSwapIORef IORef Int
msgSentQuota Int
0
          Int
msgSentLarge' <- IORef Int -> Int -> IO Int
forall a. IORef a -> a -> IO a
atomicSwapIORef IORef Int
msgSentLarge Int
0
          Int
msgRecv' <- IORef Int -> Int -> IO Int
forall a. IORef a -> a -> IO a
atomicSwapIORef IORef Int
msgRecv Int
0
          Int
msgRecvGet' <- IORef Int -> Int -> IO Int
forall a. IORef a -> a -> IO a
atomicSwapIORef IORef Int
msgRecvGet Int
0
          Int
msgGet' <- IORef Int -> Int -> IO Int
forall a. IORef a -> a -> IO a
atomicSwapIORef IORef Int
msgGet Int
0
          Int
msgGetNoMsg' <- IORef Int -> Int -> IO Int
forall a. IORef a -> a -> IO a
atomicSwapIORef IORef Int
msgGetNoMsg Int
0
          Int
msgGetAuth' <- IORef Int -> Int -> IO Int
forall a. IORef a -> a -> IO a
atomicSwapIORef IORef Int
msgGetAuth Int
0
          Int
msgGetDuplicate' <- IORef Int -> Int -> IO Int
forall a. IORef a -> a -> IO a
atomicSwapIORef IORef Int
msgGetDuplicate Int
0
          Int
msgGetProhibited' <- IORef Int -> Int -> IO Int
forall a. IORef a -> a -> IO a
atomicSwapIORef IORef Int
msgGetProhibited Int
0
          Int
msgExpired' <- IORef Int -> Int -> IO Int
forall a. IORef a -> a -> IO a
atomicSwapIORef IORef Int
msgExpired Int
0
          PeriodStatCounts
ps <- IO PeriodStatCounts -> IO PeriodStatCounts
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO PeriodStatCounts -> IO PeriodStatCounts)
-> IO PeriodStatCounts -> IO PeriodStatCounts
forall a b. (a -> b) -> a -> b
$ PeriodStats -> UTCTime -> IO PeriodStatCounts
periodStatCounts PeriodStats
activeQueues UTCTime
ts
          Int
msgSentNtf' <- IORef Int -> Int -> IO Int
forall a. IORef a -> a -> IO a
atomicSwapIORef IORef Int
msgSentNtf Int
0
          Int
msgRecvNtf' <- IORef Int -> Int -> IO Int
forall a. IORef a -> a -> IO a
atomicSwapIORef IORef Int
msgRecvNtf Int
0
          PeriodStatCounts
psNtf <- IO PeriodStatCounts -> IO PeriodStatCounts
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO PeriodStatCounts -> IO PeriodStatCounts)
-> IO PeriodStatCounts -> IO PeriodStatCounts
forall a b. (a -> b) -> a -> b
$ PeriodStats -> UTCTime -> IO PeriodStatCounts
periodStatCounts PeriodStats
activeQueuesNtf UTCTime
ts
          Int
msgNtfs' <- IORef Int -> Int -> IO Int
forall a. IORef a -> a -> IO a
atomicSwapIORef (ServerStats -> IORef Int
msgNtfs ServerStats
ss) Int
0
          Int
msgNtfsB' <- IORef Int -> Int -> IO Int
forall a. IORef a -> a -> IO a
atomicSwapIORef (ServerStats -> IORef Int
msgNtfsB ServerStats
ss) Int
0
          Int
msgNtfNoSub' <- IORef Int -> Int -> IO Int
forall a. IORef a -> a -> IO a
atomicSwapIORef (ServerStats -> IORef Int
msgNtfNoSub ServerStats
ss) Int
0
          Int
msgNtfLost' <- IORef Int -> Int -> IO Int
forall a. IORef a -> a -> IO a
atomicSwapIORef (ServerStats -> IORef Int
msgNtfLost ServerStats
ss) Int
0
          Int
msgNtfExpired' <- IORef Int -> Int -> IO Int
forall a. IORef a -> a -> IO a
atomicSwapIORef (ServerStats -> IORef Int
msgNtfExpired ServerStats
ss) Int
0
          Int
_qBlocked <- IORef Int -> Int -> IO Int
forall a. IORef a -> a -> IO a
atomicSwapIORef (ServerStats -> IORef Int
qBlocked ServerStats
ss) Int
0 -- not logged, only reset
          ProxyStatsData
pRelays' <- ProxyStats -> IO ProxyStatsData
getResetProxyStatsData ProxyStats
pRelays
          ProxyStatsData
pRelaysOwn' <- ProxyStats -> IO ProxyStatsData
getResetProxyStatsData ProxyStats
pRelaysOwn
          ProxyStatsData
pMsgFwds' <- ProxyStats -> IO ProxyStatsData
getResetProxyStatsData ProxyStats
pMsgFwds
          ProxyStatsData
pMsgFwdsOwn' <- ProxyStats -> IO ProxyStatsData
getResetProxyStatsData ProxyStats
pMsgFwdsOwn
          Int
pMsgFwdsRecv' <- IORef Int -> Int -> IO Int
forall a. IORef a -> a -> IO a
atomicSwapIORef IORef Int
pMsgFwdsRecv Int
0
          ServiceStatsData
rcvServices' <- ServiceStats -> IO ServiceStatsData
getServiceStatsData ServiceStats
rcvServices
          ServiceStatsData
ntfServices' <- ServiceStats -> IO ServiceStatsData
getServiceStatsData ServiceStats
ntfServices
          Int
qCount' <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
qCount
          Int
msgCount' <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
msgCount
          Int
ntfCount' <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
ntfCount
          Handle -> Text -> IO ()
T.hPutStrLn Handle
h (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
            Text -> [Text] -> Text
T.intercalate
              Text
","
              ( [ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Day -> String
forall t. ISO8601 t => t -> String
iso8601Show (Day -> String) -> Day -> String
forall a b. (a -> b) -> a -> b
$ UTCTime -> Day
utctDay UTCTime
fromTime',
                  Int -> Text
forall a. Show a => a -> Text
tshow Int
qCreated',
                  Int -> Text
forall a. Show a => a -> Text
tshow Int
qSecured',
                  Int -> Text
forall a. Show a => a -> Text
tshow Int
qDeletedAll',
                  Int -> Text
forall a. Show a => a -> Text
tshow Int
msgSent',
                  Int -> Text
forall a. Show a => a -> Text
tshow Int
msgRecv',
                  PeriodStatCounts -> Text
dayCount PeriodStatCounts
ps,
                  PeriodStatCounts -> Text
weekCount PeriodStatCounts
ps,
                  PeriodStatCounts -> Text
monthCount PeriodStatCounts
ps,
                  Int -> Text
forall a. Show a => a -> Text
tshow Int
msgSentNtf',
                  Int -> Text
forall a. Show a => a -> Text
tshow Int
msgRecvNtf',
                  PeriodStatCounts -> Text
dayCount PeriodStatCounts
psNtf,
                  PeriodStatCounts -> Text
weekCount PeriodStatCounts
psNtf,
                  PeriodStatCounts -> Text
monthCount PeriodStatCounts
psNtf,
                  Int -> Text
forall a. Show a => a -> Text
tshow Int
qCount',
                  Int -> Text
forall a. Show a => a -> Text
tshow Int
msgCount',
                  Int -> Text
forall a. Show a => a -> Text
tshow Int
msgExpired',
                  Int -> Text
forall a. Show a => a -> Text
tshow Int
qDeletedNew',
                  Int -> Text
forall a. Show a => a -> Text
tshow Int
qDeletedSecured'
                ]
                  [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> ProxyStatsData -> [Text]
showProxyStats ProxyStatsData
pRelays'
                  [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> ProxyStatsData -> [Text]
showProxyStats ProxyStatsData
pRelaysOwn'
                  [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> ProxyStatsData -> [Text]
showProxyStats ProxyStatsData
pMsgFwds'
                  [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> ProxyStatsData -> [Text]
showProxyStats ProxyStatsData
pMsgFwdsOwn'
                  [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [ Int -> Text
forall a. Show a => a -> Text
tshow Int
pMsgFwdsRecv',
                       Int -> Text
forall a. Show a => a -> Text
tshow Int
qSub',
                       Int -> Text
forall a. Show a => a -> Text
tshow Int
qSubAuth',
                       Int -> Text
forall a. Show a => a -> Text
tshow Int
qSubDuplicate',
                       Int -> Text
forall a. Show a => a -> Text
tshow Int
qSubProhibited',
                       Int -> Text
forall a. Show a => a -> Text
tshow Int
msgSentAuth',
                       Int -> Text
forall a. Show a => a -> Text
tshow Int
msgSentQuota',
                       Int -> Text
forall a. Show a => a -> Text
tshow Int
msgSentLarge',
                       Int -> Text
forall a. Show a => a -> Text
tshow Int
msgNtfs',
                       Int -> Text
forall a. Show a => a -> Text
tshow Int
msgNtfNoSub',
                       Int -> Text
forall a. Show a => a -> Text
tshow Int
msgNtfLost',
                       Text
Item [Text]
"0", -- qSubNoMsg' is removed for performance.
                       -- Use qSubAllB for the approximate number of all subscriptions.
                       -- Average observed batch size is 25-30 subscriptions.
                       Int -> Text
forall a. Show a => a -> Text
tshow Int
msgRecvGet',
                       Int -> Text
forall a. Show a => a -> Text
tshow Int
msgGet',
                       Int -> Text
forall a. Show a => a -> Text
tshow Int
msgGetNoMsg',
                       Int -> Text
forall a. Show a => a -> Text
tshow Int
msgGetAuth',
                       Int -> Text
forall a. Show a => a -> Text
tshow Int
msgGetDuplicate',
                       Int -> Text
forall a. Show a => a -> Text
tshow Int
msgGetProhibited',
                       Text
Item [Text]
"0", -- dayCount psSub; psSub is removed to reduce memory usage
                       Text
Item [Text]
"0", -- weekCount psSub
                       Text
Item [Text]
"0", -- monthCount psSub
                       Int -> Text
forall a. Show a => a -> Text
tshow Int
queueCount,
                       Int -> Text
forall a. Show a => a -> Text
tshow Int
ntfCreated',
                       Int -> Text
forall a. Show a => a -> Text
tshow Int
ntfDeleted',
                       Int -> Text
forall a. Show a => a -> Text
tshow Int
ntfSub',
                       Int -> Text
forall a. Show a => a -> Text
tshow Int
ntfSubAuth',
                       Int -> Text
forall a. Show a => a -> Text
tshow Int
ntfSubDuplicate',
                       Int -> Text
forall a. Show a => a -> Text
tshow Int
notifierCount,
                       Int -> Text
forall a. Show a => a -> Text
tshow Int
qDeletedAllB',
                       Int -> Text
forall a. Show a => a -> Text
tshow Int
qSubAllB',
                       Int -> Text
forall a. Show a => a -> Text
tshow Int
qSubEnd',
                       Int -> Text
forall a. Show a => a -> Text
tshow Int
qSubEndB',
                       Int -> Text
forall a. Show a => a -> Text
tshow Int
ntfDeletedB',
                       Int -> Text
forall a. Show a => a -> Text
tshow Int
ntfSubB',
                       Int -> Text
forall a. Show a => a -> Text
tshow Int
msgNtfsB',
                       Int -> Text
forall a. Show a => a -> Text
tshow Int
msgNtfExpired',
                       Int -> Text
forall a. Show a => a -> Text
tshow Int
ntfCount',
                       Int -> Text
forall a. Show a => a -> Text
tshow Int
rcvServiceCount,
                       Int -> Text
forall a. Show a => a -> Text
tshow Int
ntfServiceCount,
                       Int -> Text
forall a. Show a => a -> Text
tshow Int
rcvServiceQueuesCount,
                       Int -> Text
forall a. Show a => a -> Text
tshow Int
ntfServiceQueuesCount
                     ]
                       [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> ServiceStatsData -> [Text]
showServiceStats ServiceStatsData
rcvServices'
                       [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> ServiceStatsData -> [Text]
showServiceStats ServiceStatsData
ntfServices'
              )
        IO () -> M s ()
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
forall a b. (a -> b) -> a -> b
$ Int64 -> IO ()
threadDelay' Int64
interval
      where
        showProxyStats :: ProxyStatsData -> [Text]
showProxyStats ProxyStatsData {Int
_pRequests :: Int
_pRequests :: ProxyStatsData -> Int
_pRequests, Int
_pSuccesses :: Int
_pSuccesses :: ProxyStatsData -> Int
_pSuccesses, Int
_pErrorsConnect :: Int
_pErrorsConnect :: ProxyStatsData -> Int
_pErrorsConnect, Int
_pErrorsCompat :: Int
_pErrorsCompat :: ProxyStatsData -> Int
_pErrorsCompat, Int
_pErrorsOther :: Int
_pErrorsOther :: ProxyStatsData -> Int
_pErrorsOther} =
          (Int -> Text) -> [Int] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Text
forall a. Show a => a -> Text
tshow [Int
Item [Int]
_pRequests, Int
Item [Int]
_pSuccesses, Int
Item [Int]
_pErrorsConnect, Int
Item [Int]
_pErrorsCompat, Int
Item [Int]
_pErrorsOther]
        showServiceStats :: ServiceStatsData -> [Text]
showServiceStats ServiceStatsData {Int
_srvAssocNew :: Int
_srvAssocNew :: ServiceStatsData -> Int
_srvAssocNew, Int
_srvAssocDuplicate :: Int
_srvAssocDuplicate :: ServiceStatsData -> Int
_srvAssocDuplicate, Int
_srvAssocUpdated :: Int
_srvAssocUpdated :: ServiceStatsData -> Int
_srvAssocUpdated, Int
_srvAssocRemoved :: Int
_srvAssocRemoved :: ServiceStatsData -> Int
_srvAssocRemoved, Int
_srvSubCount :: Int
_srvSubCount :: ServiceStatsData -> Int
_srvSubCount, Int
_srvSubDuplicate :: Int
_srvSubDuplicate :: ServiceStatsData -> Int
_srvSubDuplicate, Int
_srvSubQueues :: Int
_srvSubQueues :: ServiceStatsData -> Int
_srvSubQueues, Int
_srvSubEnd :: Int
_srvSubEnd :: ServiceStatsData -> Int
_srvSubEnd} =
          (Int -> Text) -> [Int] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Text
forall a. Show a => a -> Text
tshow [Int
Item [Int]
_srvAssocNew, Int
Item [Int]
_srvAssocDuplicate, Int
Item [Int]
_srvAssocUpdated, Int
Item [Int]
_srvAssocRemoved, Int
Item [Int]
_srvSubCount, Int
Item [Int]
_srvSubDuplicate, Int
Item [Int]
_srvSubQueues, Int
Item [Int]
_srvSubEnd]

    prometheusMetricsThread_ :: ServerConfig s -> [M s ()]
    prometheusMetricsThread_ :: ServerConfig s -> [M s ()]
prometheusMetricsThread_ ServerConfig {$sel:prometheusInterval:ServerConfig :: forall s. ServerConfig s -> Maybe Int
prometheusInterval = Just Int
interval, String
prometheusMetricsFile :: String
$sel:prometheusMetricsFile:ServerConfig :: forall s. ServerConfig s -> String
prometheusMetricsFile} =
      [Int -> String -> M s ()
savePrometheusMetrics Int
interval String
prometheusMetricsFile]
    prometheusMetricsThread_ ServerConfig s
_ = []

    savePrometheusMetrics :: Int -> FilePath -> M s ()
    savePrometheusMetrics :: Int -> String -> M s ()
savePrometheusMetrics Int
saveInterval String
metricsFile = do
      String -> M s ()
forall (m :: * -> *). MonadIO m => String -> m ()
labelMyThread String
"savePrometheusMetrics"
      IO () -> M s ()
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Prometheus metrics saved every " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
saveInterval String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" seconds to " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
metricsFile
      s
st <- (Env s -> s) -> ReaderT (Env s) IO s
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> s
forall s. Env s -> s
msgStore
      ServerStats
ss <- (Env s -> ServerStats) -> ReaderT (Env s) IO ServerStats
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> ServerStats
forall s. Env s -> ServerStats
serverStats
      Env s
env <- ReaderT (Env s) IO (Env s)
forall r (m :: * -> *). MonadReader r m => m r
ask
      Text
rtsOpts <- IO Text -> ReaderT (Env s) IO Text
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> ReaderT (Env s) IO Text)
-> IO Text -> ReaderT (Env s) IO Text
forall a b. (a -> b) -> a -> b
$ Text -> (String -> Text) -> Maybe String -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text
"set " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
rtsOptionsEnv) String -> Text
T.pack (Maybe String -> Text) -> IO (Maybe String) -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv (Text -> String
T.unpack Text
rtsOptionsEnv)
      let interval :: Int
interval = Int
1000000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
saveInterval
      IO () -> M s ()
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Int -> IO ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay Int
interval
        UTCTime
ts <- IO UTCTime
getCurrentTime
        ServerMetrics
sm <- s -> ServerStats -> Text -> IO ServerMetrics
getServerMetrics s
st ServerStats
ss Text
rtsOpts
        RealTimeMetrics
rtm <- Env s -> IO RealTimeMetrics
getRealTimeMetrics Env s
env
        String -> Text -> IO ()
T.writeFile String
metricsFile (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ ServerMetrics -> RealTimeMetrics -> UTCTime -> Text
prometheusMetrics ServerMetrics
sm RealTimeMetrics
rtm UTCTime
ts

    getServerMetrics :: s -> ServerStats -> Text -> IO ServerMetrics
    getServerMetrics :: s -> ServerStats -> Text -> IO ServerMetrics
getServerMetrics s
st ServerStats
ss Text
rtsOptions = do
      ServerStatsData
d <- ServerStats -> IO ServerStatsData
getServerStatsData ServerStats
ss
      let ps :: PeriodStatCounts
ps = PeriodStatsData -> PeriodStatCounts
periodStatDataCounts (PeriodStatsData -> PeriodStatCounts)
-> PeriodStatsData -> PeriodStatCounts
forall a b. (a -> b) -> a -> b
$ ServerStatsData -> PeriodStatsData
_activeQueues ServerStatsData
d
          psNtf :: PeriodStatCounts
psNtf = PeriodStatsData -> PeriodStatCounts
periodStatDataCounts (PeriodStatsData -> PeriodStatCounts)
-> PeriodStatsData -> PeriodStatCounts
forall a b. (a -> b) -> a -> b
$ ServerStatsData -> PeriodStatsData
_activeQueuesNtf ServerStatsData
d
      EntityCounts
entityCounts <- forall q s. QueueStoreClass q s => s -> IO EntityCounts
getEntityCounts @(StoreQueue s) (QueueStore s -> IO EntityCounts)
-> QueueStore s -> IO EntityCounts
forall a b. (a -> b) -> a -> b
$ s -> QueueStore s
forall s. MsgStoreClass s => s -> QueueStore s
queueStore s
st
      ServerMetrics -> IO ServerMetrics
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ServerMetrics {statsData :: ServerStatsData
statsData = ServerStatsData
d, activeQueueCounts :: PeriodStatCounts
activeQueueCounts = PeriodStatCounts
ps, activeNtfCounts :: PeriodStatCounts
activeNtfCounts = PeriodStatCounts
psNtf, EntityCounts
entityCounts :: EntityCounts
entityCounts :: EntityCounts
entityCounts, Text
rtsOptions :: Text
rtsOptions :: Text
rtsOptions}

    getRealTimeMetrics :: Env s -> IO RealTimeMetrics
    getRealTimeMetrics :: Env s -> IO RealTimeMetrics
getRealTimeMetrics Env {TVar [(String, SocketState)]
$sel:sockets:Env :: forall s. Env s -> TVar [(String, SocketState)]
sockets :: TVar [(String, SocketState)]
sockets, $sel:msgStore_:Env :: forall s. Env s -> MsgStore s
msgStore_ = MsgStore s
ms, $sel:server:Env :: forall s. Env s -> Server s
server = srv :: Server s
srv@Server {ServerSubscribers s
$sel:subscribers:Server :: forall s. Server s -> ServerSubscribers s
subscribers :: ServerSubscribers s
subscribers, ServerSubscribers s
$sel:ntfSubscribers:Server :: forall s. Server s -> ServerSubscribers s
ntfSubscribers :: ServerSubscribers s
ntfSubscribers}} = do
      [(String, SocketStats)]
socketStats <- ((String, SocketState) -> IO (String, SocketStats))
-> [(String, SocketState)] -> IO [(String, SocketStats)]
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) -> [a] -> m [b]
mapM ((SocketState -> IO SocketStats)
-> (String, SocketState) -> IO (String, SocketStats)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> (String, a) -> f (String, b)
traverse SocketState -> IO SocketStats
getSocketStats) ([(String, SocketState)] -> IO [(String, SocketStats)])
-> IO [(String, SocketState)] -> IO [(String, SocketStats)]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TVar [(String, SocketState)] -> IO [(String, SocketState)]
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar [(String, SocketState)]
sockets
#if MIN_VERSION_base(4,18,0)
      Int
threadsCount <- [ThreadId] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([ThreadId] -> Int) -> IO [ThreadId] -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [ThreadId]
listThreads
#else
      let threadsCount = 0
#endif
      Int
clientsCount <- IntMap (Client s) -> Int
forall a. IntMap a -> Int
IM.size (IntMap (Client s) -> Int) -> IO (IntMap (Client s)) -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Server s -> IO (IntMap (Client s))
forall s. Server s -> IO (IntMap (Client s))
getServerClients Server s
srv
      (RTSubscriberMetrics
deliveredSubs, TimeBuckets
deliveredTimes) <- SystemSeconds -> IO (RTSubscriberMetrics, TimeBuckets)
getDeliveredMetrics (SystemSeconds -> IO (RTSubscriberMetrics, TimeBuckets))
-> IO SystemSeconds -> IO (RTSubscriberMetrics, TimeBuckets)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO SystemSeconds
getSystemSeconds
      RTSubscriberMetrics
smpSubs <- ServerSubscribers s -> IO RTSubscriberMetrics
forall {s}. ServerSubscribers s -> IO RTSubscriberMetrics
getSubscribersMetrics ServerSubscribers s
subscribers
      RTSubscriberMetrics
ntfSubs <- ServerSubscribers s -> IO RTSubscriberMetrics
forall {s}. ServerSubscribers s -> IO RTSubscriberMetrics
getSubscribersMetrics ServerSubscribers s
ntfSubscribers
      LoadedQueueCounts
loadedCounts <- s -> IO LoadedQueueCounts
forall s. MsgStoreClass s => s -> IO LoadedQueueCounts
loadedQueueCounts (s -> IO LoadedQueueCounts) -> s -> IO LoadedQueueCounts
forall a b. (a -> b) -> a -> b
$ MsgStore s -> s
forall s. MsgStore s -> s
fromMsgStore MsgStore s
ms
      RealTimeMetrics -> IO RealTimeMetrics
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RealTimeMetrics {[(String, SocketStats)]
socketStats :: [(String, SocketStats)]
socketStats :: [(String, SocketStats)]
socketStats, Int
threadsCount :: Int
threadsCount :: Int
threadsCount, Int
clientsCount :: Int
clientsCount :: Int
clientsCount, RTSubscriberMetrics
deliveredSubs :: RTSubscriberMetrics
deliveredSubs :: RTSubscriberMetrics
deliveredSubs, TimeBuckets
deliveredTimes :: TimeBuckets
deliveredTimes :: TimeBuckets
deliveredTimes, RTSubscriberMetrics
smpSubs :: RTSubscriberMetrics
smpSubs :: RTSubscriberMetrics
smpSubs, RTSubscriberMetrics
ntfSubs :: RTSubscriberMetrics
ntfSubs :: RTSubscriberMetrics
ntfSubs, LoadedQueueCounts
loadedCounts :: LoadedQueueCounts
loadedCounts :: LoadedQueueCounts
loadedCounts}
      where
        getSubscribersMetrics :: ServerSubscribers s -> IO RTSubscriberMetrics
getSubscribersMetrics ServerSubscribers {SubscribedClients s
$sel:queueSubscribers:ServerSubscribers :: forall s. ServerSubscribers s -> SubscribedClients s
queueSubscribers :: SubscribedClients s
queueSubscribers, SubscribedClients s
$sel:serviceSubscribers:ServerSubscribers :: forall s. ServerSubscribers s -> SubscribedClients s
serviceSubscribers :: SubscribedClients s
serviceSubscribers, TVar IntSet
$sel:subClients:ServerSubscribers :: forall s. ServerSubscribers s -> TVar IntSet
subClients :: TVar IntSet
subClients} = do
          Int
subsCount <- Map RecipientId (TVar (Maybe (Client s))) -> Int
forall k a. Map k a -> Int
M.size (Map RecipientId (TVar (Maybe (Client s))) -> Int)
-> IO (Map RecipientId (TVar (Maybe (Client s)))) -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SubscribedClients s
-> IO (Map RecipientId (TVar (Maybe (Client s))))
forall s.
SubscribedClients s
-> IO (Map RecipientId (TVar (Maybe (Client s))))
getSubscribedClients SubscribedClients s
queueSubscribers
          Int
subClientsCount <- IntSet -> Int
IS.size (IntSet -> Int) -> IO IntSet -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar IntSet -> IO IntSet
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar IntSet
subClients
          Int
subServicesCount <- Map RecipientId (TVar (Maybe (Client s))) -> Int
forall k a. Map k a -> Int
M.size (Map RecipientId (TVar (Maybe (Client s))) -> Int)
-> IO (Map RecipientId (TVar (Maybe (Client s)))) -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SubscribedClients s
-> IO (Map RecipientId (TVar (Maybe (Client s))))
forall s.
SubscribedClients s
-> IO (Map RecipientId (TVar (Maybe (Client s))))
getSubscribedClients SubscribedClients s
serviceSubscribers
          RTSubscriberMetrics -> IO RTSubscriberMetrics
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RTSubscriberMetrics {Int
subsCount :: Int
subsCount :: Int
subsCount, Int
subClientsCount :: Int
subClientsCount :: Int
subClientsCount, Int
subServicesCount :: Int
subServicesCount :: Int
subServicesCount}
        getDeliveredMetrics :: SystemSeconds -> IO (RTSubscriberMetrics, TimeBuckets)
getDeliveredMetrics SystemSeconds
ts' = ((RTSubscriberMetrics, TimeBuckets)
 -> Client s -> IO (RTSubscriberMetrics, TimeBuckets))
-> (RTSubscriberMetrics, TimeBuckets)
-> IntMap (Client s)
-> IO (RTSubscriberMetrics, TimeBuckets)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (RTSubscriberMetrics, TimeBuckets)
-> Client s -> IO (RTSubscriberMetrics, TimeBuckets)
countClnt (Int -> Int -> Int -> RTSubscriberMetrics
RTSubscriberMetrics Int
0 Int
0 Int
0, TimeBuckets
emptyTimeBuckets) (IntMap (Client s) -> IO (RTSubscriberMetrics, TimeBuckets))
-> IO (IntMap (Client s)) -> IO (RTSubscriberMetrics, TimeBuckets)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Server s -> IO (IntMap (Client s))
forall s. Server s -> IO (IntMap (Client s))
getServerClients Server s
srv
          where
            countClnt :: (RTSubscriberMetrics, TimeBuckets)
-> Client s -> IO (RTSubscriberMetrics, TimeBuckets)
countClnt acc :: (RTSubscriberMetrics, TimeBuckets)
acc@(RTSubscriberMetrics
metrics, TimeBuckets
times) Client {TMap RecipientId Sub
$sel:subscriptions:Client :: forall s. Client s -> TMap RecipientId Sub
subscriptions :: TMap RecipientId Sub
subscriptions} = do
              (Int
cnt, TimeBuckets
times') <- ((Int, TimeBuckets) -> Sub -> IO (Int, TimeBuckets))
-> (Int, TimeBuckets)
-> Map RecipientId Sub
-> IO (Int, TimeBuckets)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Int, TimeBuckets) -> Sub -> IO (Int, TimeBuckets)
countSubs (Int
0, TimeBuckets
times) (Map RecipientId Sub -> IO (Int, TimeBuckets))
-> IO (Map RecipientId Sub) -> IO (Int, TimeBuckets)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TMap RecipientId Sub -> IO (Map RecipientId Sub)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TMap RecipientId Sub
subscriptions
              (RTSubscriberMetrics, TimeBuckets)
-> IO (RTSubscriberMetrics, TimeBuckets)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((RTSubscriberMetrics, TimeBuckets)
 -> IO (RTSubscriberMetrics, TimeBuckets))
-> (RTSubscriberMetrics, TimeBuckets)
-> IO (RTSubscriberMetrics, TimeBuckets)
forall a b. (a -> b) -> a -> b
$ if Int
cnt Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
                then (RTSubscriberMetrics
metrics {subsCount = subsCount metrics + cnt, subClientsCount = subClientsCount metrics + 1}, TimeBuckets
times')
                else (RTSubscriberMetrics, TimeBuckets)
acc
            countSubs :: (Int, TimeBuckets) -> Sub -> IO (Int, TimeBuckets)
countSubs acc :: (Int, TimeBuckets)
acc@(!Int
cnt, TimeBuckets
times) Sub {TVar (Maybe (ByteString, SystemSeconds))
delivered :: TVar (Maybe (ByteString, SystemSeconds))
$sel:delivered:Sub :: Sub -> TVar (Maybe (ByteString, SystemSeconds))
delivered} = do
              Maybe (ByteString, SystemSeconds)
delivered_ <- TVar (Maybe (ByteString, SystemSeconds))
-> IO (Maybe (ByteString, SystemSeconds))
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Maybe (ByteString, SystemSeconds))
delivered
              (Int, TimeBuckets) -> IO (Int, TimeBuckets)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Int, TimeBuckets) -> IO (Int, TimeBuckets))
-> (Int, TimeBuckets) -> IO (Int, TimeBuckets)
forall a b. (a -> b) -> a -> b
$ case Maybe (ByteString, SystemSeconds)
delivered_ of
                Maybe (ByteString, SystemSeconds)
Nothing -> (Int, TimeBuckets)
acc
                Just (ByteString
_, SystemSeconds
ts) -> (Int
cnt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, SystemSeconds -> SystemSeconds -> TimeBuckets -> TimeBuckets
updateTimeBuckets SystemSeconds
ts SystemSeconds
ts' TimeBuckets
times)

    runClient :: Transport c => X.CertificateChain -> C.APrivateSignKey -> TProxy c 'TServer -> c 'TServer -> M s ()
    runClient :: forall (c :: TransportPeer -> *).
Transport c =>
CertificateChain
-> APrivateSignKey -> TProxy c 'TServer -> c 'TServer -> M s ()
runClient CertificateChain
srvCert APrivateSignKey
srvSignKey TProxy c 'TServer
tp c 'TServer
h = do
      s
ms <- (Env s -> s) -> ReaderT (Env s) IO s
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> s
forall s. Env s -> s
msgStore
      TVar ChaChaDRG
g <- (Env s -> TVar ChaChaDRG) -> ReaderT (Env s) IO (TVar ChaChaDRG)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> TVar ChaChaDRG
forall s. Env s -> TVar ChaChaDRG
random
      Int
idSize <- (Env s -> Int) -> ReaderT (Env s) IO Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Env s -> Int) -> ReaderT (Env s) IO Int)
-> (Env s -> Int) -> ReaderT (Env s) IO Int
forall a b. (a -> b) -> a -> b
$ ServerConfig s -> Int
forall s. ServerConfig s -> Int
queueIdBytes (ServerConfig s -> Int)
-> (Env s -> ServerConfig s) -> Env s -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env s -> ServerConfig s
forall s. Env s -> ServerConfig s
config
      KeyHash
kh <- (Env s -> KeyHash) -> ReaderT (Env s) IO KeyHash
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> KeyHash
forall s. Env s -> KeyHash
serverIdentity
      (PublicKey 'X25519, PrivateKey 'X25519)
ks <- STM (PublicKey 'X25519, PrivateKey 'X25519)
-> ReaderT (Env s) IO (PublicKey 'X25519, PrivateKey 'X25519)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (PublicKey 'X25519, PrivateKey 'X25519)
 -> ReaderT (Env s) IO (PublicKey 'X25519, PrivateKey 'X25519))
-> (TVar ChaChaDRG -> STM (PublicKey 'X25519, PrivateKey 'X25519))
-> TVar ChaChaDRG
-> ReaderT (Env s) IO (PublicKey 'X25519, PrivateKey 'X25519)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar ChaChaDRG -> STM (KeyPair 'X25519)
TVar ChaChaDRG -> STM (PublicKey 'X25519, PrivateKey 'X25519)
forall (a :: Algorithm).
AlgorithmI a =>
TVar ChaChaDRG -> STM (KeyPair a)
C.generateKeyPair (TVar ChaChaDRG
 -> ReaderT (Env s) IO (PublicKey 'X25519, PrivateKey 'X25519))
-> ReaderT (Env s) IO (TVar ChaChaDRG)
-> ReaderT (Env s) IO (PublicKey 'X25519, PrivateKey 'X25519)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Env s -> TVar ChaChaDRG) -> ReaderT (Env s) IO (TVar ChaChaDRG)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> TVar ChaChaDRG
forall s. Env s -> TVar ChaChaDRG
random
      ServerConfig {VersionRangeSMP
smpServerVRange :: VersionRangeSMP
$sel:smpServerVRange:ServerConfig :: forall s. ServerConfig s -> VersionRangeSMP
smpServerVRange, Int
smpHandshakeTimeout :: Int
$sel:smpHandshakeTimeout:ServerConfig :: forall s. ServerConfig s -> Int
smpHandshakeTimeout} <- (Env s -> ServerConfig s) -> ReaderT (Env s) IO (ServerConfig s)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> ServerConfig s
forall s. Env s -> ServerConfig s
config
      String -> M s ()
forall (m :: * -> *). MonadIO m => String -> m ()
labelMyThread (String -> M s ()) -> String -> M s ()
forall a b. (a -> b) -> a -> b
$ String
"smp handshake for " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TProxy c 'TServer -> String
forall (p :: TransportPeer). TProxy c p -> String
forall (c :: TransportPeer -> *) (p :: TransportPeer).
Transport c =>
TProxy c p -> String
transportName TProxy c 'TServer
tp
      IO (Maybe (Either TransportError (THandleSMP c 'TServer)))
-> ReaderT
     (Env s) IO (Maybe (Either TransportError (THandleSMP c 'TServer)))
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Int
-> IO (Either TransportError (THandleSMP c 'TServer))
-> IO (Maybe (Either TransportError (THandleSMP c 'TServer)))
forall (m :: * -> *) a.
MonadUnliftIO m =>
Int -> m a -> m (Maybe a)
timeout Int
smpHandshakeTimeout (IO (Either TransportError (THandleSMP c 'TServer))
 -> IO (Maybe (Either TransportError (THandleSMP c 'TServer))))
-> (ExceptT TransportError IO (THandleSMP c 'TServer)
    -> IO (Either TransportError (THandleSMP c 'TServer)))
-> ExceptT TransportError IO (THandleSMP c 'TServer)
-> IO (Maybe (Either TransportError (THandleSMP c 'TServer)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT TransportError IO (THandleSMP c 'TServer)
-> IO (Either TransportError (THandleSMP c 'TServer))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT TransportError IO (THandleSMP c 'TServer)
 -> IO (Maybe (Either TransportError (THandleSMP c 'TServer))))
-> ExceptT TransportError IO (THandleSMP c 'TServer)
-> IO (Maybe (Either TransportError (THandleSMP c 'TServer)))
forall a b. (a -> b) -> a -> b
$ CertificateChain
-> APrivateSignKey
-> c 'TServer
-> KeyPair 'X25519
-> KeyHash
-> VersionRangeSMP
-> (SMPServiceRole
    -> CertificateChain
    -> Fingerprint
    -> ExceptT TransportError IO RecipientId)
-> ExceptT TransportError IO (THandleSMP c 'TServer)
forall (c :: TransportPeer -> *).
Transport c =>
CertificateChain
-> APrivateSignKey
-> c 'TServer
-> KeyPair 'X25519
-> KeyHash
-> VersionRangeSMP
-> (SMPServiceRole
    -> CertificateChain
    -> Fingerprint
    -> ExceptT TransportError IO RecipientId)
-> ExceptT TransportError IO (THandleSMP c 'TServer)
smpServerHandshake CertificateChain
srvCert APrivateSignKey
srvSignKey c 'TServer
h KeyPair 'X25519
(PublicKey 'X25519, PrivateKey 'X25519)
ks KeyHash
kh VersionRangeSMP
smpServerVRange ((SMPServiceRole
  -> CertificateChain
  -> Fingerprint
  -> ExceptT TransportError IO RecipientId)
 -> ExceptT TransportError IO (THandleSMP c 'TServer))
-> (SMPServiceRole
    -> CertificateChain
    -> Fingerprint
    -> ExceptT TransportError IO RecipientId)
-> ExceptT TransportError IO (THandleSMP c 'TServer)
forall a b. (a -> b) -> a -> b
$ s
-> TVar ChaChaDRG
-> Int
-> SMPServiceRole
-> CertificateChain
-> Fingerprint
-> ExceptT TransportError IO RecipientId
getClientService s
ms TVar ChaChaDRG
g Int
idSize) ReaderT
  (Env s) IO (Maybe (Either TransportError (THandleSMP c 'TServer)))
-> (Maybe (Either TransportError (THandleSMP c 'TServer))
    -> M s ())
-> M s ()
forall a b.
ReaderT (Env s) IO a
-> (a -> ReaderT (Env s) IO b) -> ReaderT (Env s) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just (Right THandleSMP c 'TServer
th) -> THandleSMP c 'TServer -> M s ()
forall (c :: TransportPeer -> *) s.
(Transport c, MsgStoreClass s) =>
THandleSMP c 'TServer -> M s ()
runClientTransport THandleSMP c 'TServer
th
        Maybe (Either TransportError (THandleSMP c 'TServer))
_ -> () -> M s ()
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    getClientService :: s -> TVar ChaChaDRG -> Int -> SMPServiceRole -> X.CertificateChain -> XV.Fingerprint -> ExceptT TransportError IO ServiceId
    getClientService :: s
-> TVar ChaChaDRG
-> Int
-> SMPServiceRole
-> CertificateChain
-> Fingerprint
-> ExceptT TransportError IO RecipientId
getClientService s
ms TVar ChaChaDRG
g Int
idSize SMPServiceRole
role CertificateChain
cert Fingerprint
fp = do
      RecipientId
newServiceId <- ByteString -> RecipientId
EntityId (ByteString -> RecipientId)
-> ExceptT TransportError IO ByteString
-> ExceptT TransportError IO RecipientId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM ByteString -> ExceptT TransportError IO ByteString
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (Int -> TVar ChaChaDRG -> STM ByteString
C.randomBytes Int
idSize TVar ChaChaDRG
g)
      SystemDate
ts <- IO SystemDate -> ExceptT TransportError IO SystemDate
forall a. IO a -> ExceptT TransportError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO SystemDate
getSystemDate
      let sr :: ServiceRec
sr = ServiceRec {$sel:serviceId:ServiceRec :: RecipientId
serviceId = RecipientId
newServiceId, $sel:serviceRole:ServiceRec :: SMPServiceRole
serviceRole = SMPServiceRole
role, $sel:serviceCert:ServiceRec :: CertificateChain
serviceCert = CertificateChain
cert, $sel:serviceCertHash:ServiceRec :: Fingerprint
serviceCertHash = Fingerprint
fp, $sel:serviceCreatedAt:ServiceRec :: SystemDate
serviceCreatedAt = SystemDate
ts}
      (ErrorType -> TransportError)
-> ExceptT ErrorType IO RecipientId
-> ExceptT TransportError IO RecipientId
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (TransportError -> ErrorType -> TransportError
forall a b. a -> b -> a
const (TransportError -> ErrorType -> TransportError)
-> TransportError -> ErrorType -> TransportError
forall a b. (a -> b) -> a -> b
$ HandshakeError -> TransportError
TEHandshake HandshakeError
BAD_SERVICE) (ExceptT ErrorType IO RecipientId
 -> ExceptT TransportError IO RecipientId)
-> ExceptT ErrorType IO RecipientId
-> ExceptT TransportError IO RecipientId
forall a b. (a -> b) -> a -> b
$ IO (Either ErrorType RecipientId)
-> ExceptT ErrorType IO RecipientId
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either ErrorType RecipientId)
 -> ExceptT ErrorType IO RecipientId)
-> IO (Either ErrorType RecipientId)
-> ExceptT ErrorType IO RecipientId
forall a b. (a -> b) -> a -> b
$
        forall q s.
QueueStoreClass q s =>
s -> ServiceRec -> IO (Either ErrorType RecipientId)
getCreateService @(StoreQueue s) (s -> QueueStore s
forall s. MsgStoreClass s => s -> QueueStore s
queueStore s
ms) ServiceRec
sr

    controlPortThread_ :: ServerConfig s -> [M s ()]
    controlPortThread_ :: ServerConfig s -> [M s ()]
controlPortThread_ ServerConfig {$sel:controlPort:ServerConfig :: forall s. ServerConfig s -> Maybe String
controlPort = Just String
port} = [String -> M s ()
runCPServer String
port]
    controlPortThread_ ServerConfig s
_ = []

    runCPServer :: ServiceName -> M s ()
    runCPServer :: String -> M s ()
runCPServer String
port = do
      Server s
srv <- (Env s -> Server s) -> ReaderT (Env s) IO (Server s)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> Server s
forall s. Env s -> Server s
server
      TMVar Bool
cpStarted <- ReaderT (Env s) IO (TMVar Bool)
forall (m :: * -> *) a. MonadIO m => m (TMVar a)
newEmptyTMVarIO
      UnliftIO (ReaderT (Env s) IO)
u <- ReaderT (Env s) IO (UnliftIO (ReaderT (Env s) IO))
forall (m :: * -> *). MonadUnliftIO m => m (UnliftIO m)
askUnliftIO
      IO () -> M s ()
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
forall a b. (a -> b) -> a -> b
$ do
        String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
labelMyThread String
"control port server"
        TMVar Bool -> String -> (Socket -> IO ()) -> IO ()
runLocalTCPServer TMVar Bool
cpStarted String
port ((Socket -> IO ()) -> IO ()) -> (Socket -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ UnliftIO (ReaderT (Env s) IO) -> Server s -> Socket -> IO ()
runCPClient UnliftIO (ReaderT (Env s) IO)
u Server s
srv
      where
        runCPClient :: UnliftIO (ReaderT (Env s) IO) -> Server s -> Socket -> IO ()
        runCPClient :: UnliftIO (ReaderT (Env s) IO) -> Server s -> Socket -> IO ()
runCPClient UnliftIO (ReaderT (Env s) IO)
u Server s
srv Socket
sock = do
          String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
labelMyThread String
"control port client"
          Handle
h <- Socket -> IOMode -> IO Handle
socketToHandle Socket
sock IOMode
ReadWriteMode
          Handle -> BufferMode -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> BufferMode -> m ()
hSetBuffering Handle
h BufferMode
LineBuffering
          Handle -> NewlineMode -> IO ()
hSetNewlineMode Handle
h NewlineMode
universalNewlineMode
          Handle -> String -> IO ()
hPutStrLn Handle
h String
"SMP server control port\n'help' for supported commands"
          TVar CPClientRole
role <- CPClientRole -> IO (TVar CPClientRole)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO CPClientRole
CPRNone
          Handle -> TVar CPClientRole -> IO ()
cpLoop Handle
h TVar CPClientRole
role
          where
            cpLoop :: Handle -> TVar CPClientRole -> IO ()
cpLoop Handle
h TVar CPClientRole
role = do
              ByteString
s <- ByteString -> ByteString
trimCR (ByteString -> ByteString) -> IO ByteString -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO ByteString
B.hGetLine Handle
h
              case ByteString -> Either String ControlProtocol
forall a. StrEncoding a => ByteString -> Either String a
strDecode ByteString
s of
                Right ControlProtocol
CPQuit -> Handle -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> m ()
hClose Handle
h
                Right ControlProtocol
cmd -> ByteString -> ControlProtocol -> IO ()
forall {f :: * -> *} {a}.
(MonadIO f, Show a) =>
a -> ControlProtocol -> f ()
logCmd ByteString
s ControlProtocol
cmd IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> TVar CPClientRole -> ControlProtocol -> IO ()
processCP Handle
h TVar CPClientRole
role ControlProtocol
cmd IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> TVar CPClientRole -> IO ()
cpLoop Handle
h TVar CPClientRole
role
                Left String
err -> Handle -> String -> IO ()
hPutStrLn Handle
h (String
"error: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
err) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> TVar CPClientRole -> IO ()
cpLoop Handle
h TVar CPClientRole
role
            logCmd :: a -> ControlProtocol -> f ()
logCmd a
s ControlProtocol
cmd = Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldLog (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$ Text -> f ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logWarn (Text -> f ()) -> Text -> f ()
forall a b. (a -> b) -> a -> b
$ Text
"ControlPort: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. Show a => a -> Text
tshow a
s
              where
                shouldLog :: Bool
shouldLog = case ControlProtocol
cmd of
                  CPAuth BasicAuth
_ -> Bool
False
                  ControlProtocol
CPHelp -> Bool
False
                  ControlProtocol
CPQuit -> Bool
False
                  ControlProtocol
CPSkip -> Bool
False
                  ControlProtocol
_ -> Bool
True
            processCP :: Handle -> TVar CPClientRole -> ControlProtocol -> IO ()
processCP Handle
h TVar CPClientRole
role = \case
              CPAuth BasicAuth
auth -> Handle
-> Maybe BasicAuth
-> Maybe BasicAuth
-> TVar CPClientRole
-> BasicAuth
-> IO ()
controlPortAuth Handle
h Maybe BasicAuth
user Maybe BasicAuth
admin TVar CPClientRole
role BasicAuth
auth
                where
                  ServerConfig {$sel:controlPortUserAuth:ServerConfig :: forall s. ServerConfig s -> Maybe BasicAuth
controlPortUserAuth = Maybe BasicAuth
user, $sel:controlPortAdminAuth:ServerConfig :: forall s. ServerConfig s -> Maybe BasicAuth
controlPortAdminAuth = Maybe BasicAuth
admin} = ServerConfig s
cfg
              ControlProtocol
CPSuspend -> IO () -> IO ()
withAdminRole (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
h String
"suspend not implemented"
              ControlProtocol
CPResume -> IO () -> IO ()
withAdminRole (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
h String
"resume not implemented"
              ControlProtocol
CPClients -> IO () -> IO ()
withAdminRole (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                IntMap (Client s)
cls <- Server s -> IO (IntMap (Client s))
forall s. Server s -> IO (IntMap (Client s))
getServerClients Server s
srv
                Handle -> String -> IO ()
hPutStrLn Handle
h String
"clientId,sessionId,connected,createdAt,rcvActiveAt,sndActiveAt,age,subscriptions"
                [(Int, Client s)] -> ((Int, Client s) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (IntMap (Client s) -> [(Int, Client s)]
forall a. IntMap a -> [(Int, a)]
IM.toList IntMap (Client s)
cls) (((Int, Client s) -> IO ()) -> IO ())
-> ((Int, Client s) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Int
cid, Client {$sel:clientTHParams:Client :: forall s. Client s -> THandleParams SMPVersion 'TServer
clientTHParams = THandleParams {ByteString
sessionId :: ByteString
$sel:sessionId:THandleParams :: forall v (p :: TransportPeer). THandleParams v p -> ByteString
sessionId}, TVar Bool
$sel:connected:Client :: forall s. Client s -> TVar Bool
connected :: TVar Bool
connected, SystemTime
createdAt :: SystemTime
$sel:createdAt:Client :: forall s. Client s -> SystemTime
createdAt, TVar SystemTime
rcvActiveAt :: TVar SystemTime
$sel:rcvActiveAt:Client :: forall s. Client s -> TVar SystemTime
rcvActiveAt, TVar SystemTime
sndActiveAt :: TVar SystemTime
$sel:sndActiveAt:Client :: forall s. Client s -> TVar SystemTime
sndActiveAt, TMap RecipientId Sub
$sel:subscriptions:Client :: forall s. Client s -> TMap RecipientId Sub
subscriptions :: TMap RecipientId Sub
subscriptions}) -> do
                  ByteString
connected' <- Bool -> ByteString
forall a. Show a => a -> ByteString
bshow (Bool -> ByteString) -> IO Bool -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar Bool
connected
                  ByteString
rcvActiveAt' <- SystemTime -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode (SystemTime -> ByteString) -> IO SystemTime -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar SystemTime -> IO SystemTime
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar SystemTime
rcvActiveAt
                  ByteString
sndActiveAt' <- SystemTime -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode (SystemTime -> ByteString) -> IO SystemTime -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar SystemTime -> IO SystemTime
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar SystemTime
sndActiveAt
                  SystemTime
now <- IO SystemTime -> IO SystemTime
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO SystemTime
getSystemTime
                  let age :: Int64
age = SystemTime -> Int64
systemSeconds SystemTime
now Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- SystemTime -> Int64
systemSeconds SystemTime
createdAt
                  ByteString
subscriptions' <- Int -> ByteString
forall a. Show a => a -> ByteString
bshow (Int -> ByteString)
-> (Map RecipientId Sub -> Int)
-> Map RecipientId Sub
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map RecipientId Sub -> Int
forall k a. Map k a -> Int
M.size (Map RecipientId Sub -> ByteString)
-> IO (Map RecipientId Sub) -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TMap RecipientId Sub -> IO (Map RecipientId Sub)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TMap RecipientId Sub
subscriptions
                  Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> (ByteString -> String) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
B.unpack (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString] -> ByteString
B.intercalate ByteString
"," [Int -> ByteString
forall a. Show a => a -> ByteString
bshow Int
cid, ByteString -> ByteString
encode ByteString
sessionId, ByteString
Item [ByteString]
connected', SystemTime -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode SystemTime
createdAt, ByteString
Item [ByteString]
rcvActiveAt', ByteString
Item [ByteString]
sndActiveAt', Int64 -> ByteString
forall a. Show a => a -> ByteString
bshow Int64
age, ByteString
Item [ByteString]
subscriptions']
              ControlProtocol
CPStats -> IO () -> IO ()
withUserRole (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                ServerStats
ss <- UnliftIO (ReaderT (Env s) IO)
-> forall a. ReaderT (Env s) IO a -> IO a
forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO (ReaderT (Env s) IO)
u (ReaderT (Env s) IO ServerStats -> IO ServerStats)
-> ReaderT (Env s) IO ServerStats -> IO ServerStats
forall a b. (a -> b) -> a -> b
$ (Env s -> ServerStats) -> ReaderT (Env s) IO ServerStats
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> ServerStats
forall s. Env s -> ServerStats
serverStats
                s
st <- UnliftIO (ReaderT (Env s) IO)
-> forall a. ReaderT (Env s) IO a -> IO a
forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO (ReaderT (Env s) IO)
u (ReaderT (Env s) IO s -> IO s) -> ReaderT (Env s) IO s -> IO s
forall a b. (a -> b) -> a -> b
$ (Env s -> s) -> ReaderT (Env s) IO s
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> s
forall s. Env s -> s
msgStore
                EntityCounts {Int
queueCount :: EntityCounts -> Int
queueCount :: Int
queueCount, Int
notifierCount :: EntityCounts -> Int
notifierCount :: Int
notifierCount, Int
rcvServiceCount :: EntityCounts -> Int
rcvServiceCount :: Int
rcvServiceCount, Int
ntfServiceCount :: EntityCounts -> Int
ntfServiceCount :: Int
ntfServiceCount, Int
rcvServiceQueuesCount :: EntityCounts -> Int
rcvServiceQueuesCount :: Int
rcvServiceQueuesCount, Int
ntfServiceQueuesCount :: EntityCounts -> Int
ntfServiceQueuesCount :: Int
ntfServiceQueuesCount} <-
                  forall q s. QueueStoreClass q s => s -> IO EntityCounts
getEntityCounts @(StoreQueue s) (QueueStore s -> IO EntityCounts)
-> QueueStore s -> IO EntityCounts
forall a b. (a -> b) -> a -> b
$ s -> QueueStore s
forall s. MsgStoreClass s => s -> QueueStore s
queueStore s
st
                let getStat :: (ServerStats -> IORef a) -> IO a
                    getStat :: forall a. (ServerStats -> IORef a) -> IO a
getStat ServerStats -> IORef a
var = IORef a -> IO a
forall a. IORef a -> IO a
readIORef (ServerStats -> IORef a
var ServerStats
ss)
                    putStat :: Show a => String -> (ServerStats -> IORef a) -> IO ()
                    putStat :: forall a. Show a => String -> (ServerStats -> IORef a) -> IO ()
putStat String
label ServerStats -> IORef a
var = (ServerStats -> IORef a) -> IO a
forall a. (ServerStats -> IORef a) -> IO a
getStat ServerStats -> IORef a
var IO a -> (a -> 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
>>= \a
v -> Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
label String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
v
                    putProxyStat :: String -> (ServerStats -> ProxyStats) -> IO ()
                    putProxyStat :: String -> (ServerStats -> ProxyStats) -> IO ()
putProxyStat String
label ServerStats -> ProxyStats
var = do
                      ProxyStatsData {Int
_pRequests :: ProxyStatsData -> Int
_pRequests :: Int
_pRequests, Int
_pSuccesses :: ProxyStatsData -> Int
_pSuccesses :: Int
_pSuccesses, Int
_pErrorsConnect :: ProxyStatsData -> Int
_pErrorsConnect :: Int
_pErrorsConnect, Int
_pErrorsCompat :: ProxyStatsData -> Int
_pErrorsCompat :: Int
_pErrorsCompat, Int
_pErrorsOther :: ProxyStatsData -> Int
_pErrorsOther :: Int
_pErrorsOther} <- ProxyStats -> IO ProxyStatsData
getProxyStatsData (ProxyStats -> IO ProxyStatsData)
-> ProxyStats -> IO ProxyStatsData
forall a b. (a -> b) -> a -> b
$ ServerStats -> ProxyStats
var ServerStats
ss
                      Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
label String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": requests=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
_pRequests String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", successes=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
_pSuccesses String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", errorsConnect=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
_pErrorsConnect String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", errorsCompat=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
_pErrorsCompat String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", errorsOther=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
_pErrorsOther
                String -> (ServerStats -> IORef UTCTime) -> IO ()
forall a. Show a => String -> (ServerStats -> IORef a) -> IO ()
putStat String
"fromTime" ServerStats -> IORef UTCTime
fromTime
                String -> (ServerStats -> IORef Int) -> IO ()
forall a. Show a => String -> (ServerStats -> IORef a) -> IO ()
putStat String
"qCreated" ServerStats -> IORef Int
qCreated
                String -> (ServerStats -> IORef Int) -> IO ()
forall a. Show a => String -> (ServerStats -> IORef a) -> IO ()
putStat String
"qSecured" ServerStats -> IORef Int
qSecured
                String -> (ServerStats -> IORef Int) -> IO ()
forall a. Show a => String -> (ServerStats -> IORef a) -> IO ()
putStat String
"qDeletedAll" ServerStats -> IORef Int
qDeletedAll
                String -> (ServerStats -> IORef Int) -> IO ()
forall a. Show a => String -> (ServerStats -> IORef a) -> IO ()
putStat String
"qDeletedAllB" ServerStats -> IORef Int
qDeletedAllB
                String -> (ServerStats -> IORef Int) -> IO ()
forall a. Show a => String -> (ServerStats -> IORef a) -> IO ()
putStat String
"qDeletedNew" ServerStats -> IORef Int
qDeletedNew
                String -> (ServerStats -> IORef Int) -> IO ()
forall a. Show a => String -> (ServerStats -> IORef a) -> IO ()
putStat String
"qDeletedSecured" ServerStats -> IORef Int
qDeletedSecured
                (ServerStats -> IORef IntSet) -> IO IntSet
forall a. (ServerStats -> IORef a) -> IO a
getStat (PeriodStats -> IORef IntSet
day (PeriodStats -> IORef IntSet)
-> (ServerStats -> PeriodStats) -> ServerStats -> IORef IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerStats -> PeriodStats
activeQueues) IO IntSet -> (IntSet -> 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
>>= \IntSet
v -> Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"daily active queues: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (IntSet -> Int
IS.size IntSet
v)
                -- removed to reduce memory usage
                -- getStat (day . subscribedQueues) >>= \v -> hPutStrLn h $ "daily subscribed queues: " <> show (S.size v)
                String -> (ServerStats -> IORef Int) -> IO ()
forall a. Show a => String -> (ServerStats -> IORef a) -> IO ()
putStat String
"qSub" ServerStats -> IORef Int
qSub
                String -> (ServerStats -> IORef Int) -> IO ()
forall a. Show a => String -> (ServerStats -> IORef a) -> IO ()
putStat String
"qSubAllB" ServerStats -> IORef Int
qSubAllB
                String -> (ServerStats -> IORef Int) -> IO ()
forall a. Show a => String -> (ServerStats -> IORef a) -> IO ()
putStat String
"qSubEnd" ServerStats -> IORef Int
qSubEnd
                String -> (ServerStats -> IORef Int) -> IO ()
forall a. Show a => String -> (ServerStats -> IORef a) -> IO ()
putStat String
"qSubEndB" ServerStats -> IORef Int
qSubEndB
                (Int, Int, Int)
subs <- (,,) (Int -> Int -> Int -> (Int, Int, Int))
-> IO Int -> IO (Int -> Int -> (Int, Int, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ServerStats -> IORef Int) -> IO Int
forall a. (ServerStats -> IORef a) -> IO a
getStat ServerStats -> IORef Int
qSubAuth IO (Int -> Int -> (Int, Int, Int))
-> IO Int -> IO (Int -> (Int, Int, Int))
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ServerStats -> IORef Int) -> IO Int
forall a. (ServerStats -> IORef a) -> IO a
getStat ServerStats -> IORef Int
qSubDuplicate IO (Int -> (Int, Int, Int)) -> IO Int -> IO (Int, Int, Int)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ServerStats -> IORef Int) -> IO Int
forall a. (ServerStats -> IORef a) -> IO a
getStat ServerStats -> IORef Int
qSubProhibited
                Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"other SUB events (auth, duplicate, prohibited): " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (Int, Int, Int) -> String
forall a. Show a => a -> String
show (Int, Int, Int)
subs
                String -> (ServerStats -> IORef Int) -> IO ()
forall a. Show a => String -> (ServerStats -> IORef a) -> IO ()
putStat String
"msgSent" ServerStats -> IORef Int
msgSent
                String -> (ServerStats -> IORef Int) -> IO ()
forall a. Show a => String -> (ServerStats -> IORef a) -> IO ()
putStat String
"msgRecv" ServerStats -> IORef Int
msgRecv
                String -> (ServerStats -> IORef Int) -> IO ()
forall a. Show a => String -> (ServerStats -> IORef a) -> IO ()
putStat String
"msgRecvGet" ServerStats -> IORef Int
msgRecvGet
                String -> (ServerStats -> IORef Int) -> IO ()
forall a. Show a => String -> (ServerStats -> IORef a) -> IO ()
putStat String
"msgGet" ServerStats -> IORef Int
msgGet
                String -> (ServerStats -> IORef Int) -> IO ()
forall a. Show a => String -> (ServerStats -> IORef a) -> IO ()
putStat String
"msgGetNoMsg" ServerStats -> IORef Int
msgGetNoMsg
                (Int, Int, Int)
gets <- (,,) (Int -> Int -> Int -> (Int, Int, Int))
-> IO Int -> IO (Int -> Int -> (Int, Int, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ServerStats -> IORef Int) -> IO Int
forall a. (ServerStats -> IORef a) -> IO a
getStat ServerStats -> IORef Int
msgGetAuth IO (Int -> Int -> (Int, Int, Int))
-> IO Int -> IO (Int -> (Int, Int, Int))
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ServerStats -> IORef Int) -> IO Int
forall a. (ServerStats -> IORef a) -> IO a
getStat ServerStats -> IORef Int
msgGetDuplicate IO (Int -> (Int, Int, Int)) -> IO Int -> IO (Int, Int, Int)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ServerStats -> IORef Int) -> IO Int
forall a. (ServerStats -> IORef a) -> IO a
getStat ServerStats -> IORef Int
msgGetProhibited
                Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"other GET events (auth, duplicate, prohibited): " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (Int, Int, Int) -> String
forall a. Show a => a -> String
show (Int, Int, Int)
gets
                String -> (ServerStats -> IORef Int) -> IO ()
forall a. Show a => String -> (ServerStats -> IORef a) -> IO ()
putStat String
"msgSentNtf" ServerStats -> IORef Int
msgSentNtf
                String -> (ServerStats -> IORef Int) -> IO ()
forall a. Show a => String -> (ServerStats -> IORef a) -> IO ()
putStat String
"msgRecvNtf" ServerStats -> IORef Int
msgRecvNtf
                String -> (ServerStats -> IORef Int) -> IO ()
forall a. Show a => String -> (ServerStats -> IORef a) -> IO ()
putStat String
"msgNtfs" ServerStats -> IORef Int
msgNtfs
                String -> (ServerStats -> IORef Int) -> IO ()
forall a. Show a => String -> (ServerStats -> IORef a) -> IO ()
putStat String
"msgNtfsB" ServerStats -> IORef Int
msgNtfsB
                String -> (ServerStats -> IORef Int) -> IO ()
forall a. Show a => String -> (ServerStats -> IORef a) -> IO ()
putStat String
"msgNtfExpired" ServerStats -> IORef Int
msgNtfExpired
                String -> (ServerStats -> IORef Int) -> IO ()
forall a. Show a => String -> (ServerStats -> IORef a) -> IO ()
putStat String
"qCount" ServerStats -> IORef Int
qCount
                Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"qCount 2: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
queueCount
                Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"notifiers: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
notifierCount
                String -> (ServerStats -> IORef Int) -> IO ()
forall a. Show a => String -> (ServerStats -> IORef a) -> IO ()
putStat String
"msgCount" ServerStats -> IORef Int
msgCount
                String -> (ServerStats -> IORef Int) -> IO ()
forall a. Show a => String -> (ServerStats -> IORef a) -> IO ()
putStat String
"ntfCount" ServerStats -> IORef Int
ntfCount
                TVar CPClientRole -> IO CPClientRole
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar CPClientRole
role IO CPClientRole -> (CPClientRole -> 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
>>= \case
                  CPClientRole
CPRAdmin -> do
                    NtfStore TMap RecipientId (TVar [MsgNtf])
ns <- UnliftIO (ReaderT (Env s) IO)
-> forall a. ReaderT (Env s) IO a -> IO a
forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO (ReaderT (Env s) IO)
u (ReaderT (Env s) IO NtfStore -> IO NtfStore)
-> ReaderT (Env s) IO NtfStore -> IO NtfStore
forall a b. (a -> b) -> a -> b
$ (Env s -> NtfStore) -> ReaderT (Env s) IO NtfStore
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> NtfStore
forall s. Env s -> NtfStore
ntfStore
                    Int
ntfCount2 <- IO Int -> IO Int
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> IO Int)
-> (Map RecipientId (TVar [MsgNtf]) -> IO Int)
-> Map RecipientId (TVar [MsgNtf])
-> IO Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> TVar [MsgNtf] -> IO Int)
-> Int -> Map RecipientId (TVar [MsgNtf]) -> IO Int
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\(!Int
n) TVar [MsgNtf]
q -> (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+) (Int -> Int) -> ([MsgNtf] -> Int) -> [MsgNtf] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [MsgNtf] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([MsgNtf] -> Int) -> IO [MsgNtf] -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar [MsgNtf] -> IO [MsgNtf]
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar [MsgNtf]
q) Int
0 (Map RecipientId (TVar [MsgNtf]) -> IO Int)
-> IO (Map RecipientId (TVar [MsgNtf])) -> IO Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TMap RecipientId (TVar [MsgNtf])
-> IO (Map RecipientId (TVar [MsgNtf]))
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TMap RecipientId (TVar [MsgNtf])
ns
                    Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"ntfCount 2: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
ntfCount2
                  CPClientRole
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                String -> (ServerStats -> ProxyStats) -> IO ()
putProxyStat String
"pRelays" ServerStats -> ProxyStats
pRelays
                String -> (ServerStats -> ProxyStats) -> IO ()
putProxyStat String
"pRelaysOwn" ServerStats -> ProxyStats
pRelaysOwn
                String -> (ServerStats -> ProxyStats) -> IO ()
putProxyStat String
"pMsgFwds" ServerStats -> ProxyStats
pMsgFwds
                String -> (ServerStats -> ProxyStats) -> IO ()
putProxyStat String
"pMsgFwdsOwn" ServerStats -> ProxyStats
pMsgFwdsOwn
                String -> (ServerStats -> IORef Int) -> IO ()
forall a. Show a => String -> (ServerStats -> IORef a) -> IO ()
putStat String
"pMsgFwdsRecv" ServerStats -> IORef Int
pMsgFwdsRecv
                Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"rcvServiceCount: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
rcvServiceCount
                Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"ntfServiceCount: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
ntfServiceCount
                Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"rcvServiceQueuesCount: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
rcvServiceQueuesCount
                Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"ntfServiceQueuesCount: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
ntfServiceQueuesCount
              ControlProtocol
CPStatsRTS -> IO RTSStats
getRTSStats IO RTSStats -> (RTSStats -> 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
>>= Handle -> RTSStats -> IO ()
forall a. Show a => Handle -> a -> IO ()
hPrint Handle
h
              ControlProtocol
CPThreads -> IO () -> IO ()
withAdminRole (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
#if MIN_VERSION_base(4,18,0)
                [ThreadId]
threads <- IO [ThreadId] -> IO [ThreadId]
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [ThreadId]
listThreads
                Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Threads: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([ThreadId] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ThreadId]
threads)
                [ThreadId] -> (ThreadId -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([ThreadId] -> [ThreadId]
forall a. Ord a => [a] -> [a]
sort [ThreadId]
threads) ((ThreadId -> IO ()) -> IO ()) -> (ThreadId -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ThreadId
tid -> do
                  Maybe String
label <- ThreadId -> IO (Maybe String)
threadLabel ThreadId
tid
                  ThreadStatus
status <- ThreadId -> IO ThreadStatus
threadStatus ThreadId
tid
                  Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ ThreadId -> String
forall a. Show a => a -> String
show ThreadId
tid String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" (" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ThreadStatus -> String
forall a. Show a => a -> String
show ThreadStatus
status String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
") " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" Maybe String
label
#else
                hPutStrLn h "Not available on GHC 8.10"
#endif
              ControlProtocol
CPSockets -> IO () -> IO ()
withUserRole (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ UnliftIO (ReaderT (Env s) IO)
-> forall a. ReaderT (Env s) IO a -> IO a
forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO (ReaderT (Env s) IO)
u ((Env s -> TVar [(String, SocketState)])
-> ReaderT (Env s) IO (TVar [(String, SocketState)])
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> TVar [(String, SocketState)]
forall s. Env s -> TVar [(String, SocketState)]
sockets) IO (TVar [(String, SocketState)])
-> (TVar [(String, SocketState)] -> IO [(String, SocketState)])
-> IO [(String, SocketState)]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TVar [(String, SocketState)] -> IO [(String, SocketState)]
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO IO [(String, SocketState)]
-> ([(String, SocketState)] -> 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
>>= ((String, SocketState) -> IO ())
-> [(String, SocketState)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String, SocketState) -> IO ()
putSockets
                where
                  putSockets :: (String, SocketState) -> IO ()
putSockets (String
tcpPort, SocketState
socketsState) = do
                    SocketStats
ss <- SocketState -> IO SocketStats
getSocketStats SocketState
socketsState
                    Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Sockets for port " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
tcpPort String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
":"
                    Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"accepted: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (SocketStats -> Int
socketsAccepted SocketStats
ss)
                    Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"closed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (SocketStats -> Int
socketsClosed SocketStats
ss)
                    Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"active: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (SocketStats -> Int
socketsActive SocketStats
ss)
                    Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"leaked: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (SocketStats -> Int
socketsLeaked SocketStats
ss)
              ControlProtocol
CPSocketThreads -> IO () -> IO ()
withAdminRole (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
#if MIN_VERSION_base(4,18,0)
                UnliftIO (ReaderT (Env s) IO)
-> forall a. ReaderT (Env s) IO a -> IO a
forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO (ReaderT (Env s) IO)
u ((Env s -> TVar [(String, SocketState)])
-> ReaderT (Env s) IO (TVar [(String, SocketState)])
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> TVar [(String, SocketState)]
forall s. Env s -> TVar [(String, SocketState)]
sockets) IO (TVar [(String, SocketState)])
-> (TVar [(String, SocketState)] -> IO [(String, SocketState)])
-> IO [(String, SocketState)]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TVar [(String, SocketState)] -> IO [(String, SocketState)]
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO IO [(String, SocketState)]
-> ([(String, SocketState)] -> 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
>>= ((String, SocketState) -> IO ())
-> [(String, SocketState)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String, SocketState) -> IO ()
putSocketThreads
                where
                  putSocketThreads :: (String, SocketState) -> IO ()
putSocketThreads (String
tcpPort, (TVar Int
_, TVar Int
_, TVar (IntMap (Weak ThreadId))
active')) = do
                    IntMap (Weak ThreadId)
active <- TVar (IntMap (Weak ThreadId)) -> IO (IntMap (Weak ThreadId))
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (IntMap (Weak ThreadId))
active'
                    [(Int, Weak ThreadId)] -> ((Int, Weak ThreadId) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (IntMap (Weak ThreadId) -> [(Int, Weak ThreadId)]
forall a. IntMap a -> [(Int, a)]
IM.toList IntMap (Weak ThreadId)
active) (((Int, Weak ThreadId) -> IO ()) -> IO ())
-> ((Int, Weak ThreadId) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Int
sid, Weak ThreadId
tid') ->
                      Weak ThreadId -> IO (Maybe ThreadId)
forall v. Weak v -> IO (Maybe v)
deRefWeak Weak ThreadId
tid' IO (Maybe ThreadId) -> (Maybe ThreadId -> 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
>>= \case
                        Maybe ThreadId
Nothing -> Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," [String
Item [String]
tcpPort, Int -> String
forall a. Show a => a -> String
show Int
sid, String
Item [String]
"", String
Item [String]
"gone", String
Item [String]
""]
                        Just ThreadId
tid -> do
                          Maybe String
label <- ThreadId -> IO (Maybe String)
threadLabel ThreadId
tid
                          ThreadStatus
status <- ThreadId -> IO ThreadStatus
threadStatus ThreadId
tid
                          Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," [String
Item [String]
tcpPort, Int -> String
forall a. Show a => a -> String
show Int
sid, ThreadId -> String
forall a. Show a => a -> String
show ThreadId
tid, ThreadStatus -> String
forall a. Show a => a -> String
show ThreadStatus
status, String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" Maybe String
label]
#else
                hPutStrLn h "Not available on GHC 8.10"
#endif
              ControlProtocol
CPServerInfo -> TVar CPClientRole -> IO CPClientRole
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar CPClientRole
role IO CPClientRole -> (CPClientRole -> 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
>>= \case
                CPClientRole
CPRNone -> do
                  Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logError Text
"Unauthorized control port command"
                  Handle -> String -> IO ()
hPutStrLn Handle
h String
"AUTH"
                CPClientRole
r -> do
#if MIN_VERSION_base(4,18,0)
                  [ThreadId]
threads <- IO [ThreadId] -> IO [ThreadId]
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [ThreadId]
listThreads
                  Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Threads: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([ThreadId] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ThreadId]
threads)
#else
                  hPutStrLn h "Threads: not available on GHC 8.10"
#endif
                  let Server {ServerSubscribers s
$sel:subscribers:Server :: forall s. Server s -> ServerSubscribers s
subscribers :: ServerSubscribers s
subscribers, ServerSubscribers s
$sel:ntfSubscribers:Server :: forall s. Server s -> ServerSubscribers s
ntfSubscribers :: ServerSubscribers s
ntfSubscribers} = Server s
srv
                  IntMap (Client s)
activeClients <- Server s -> IO (IntMap (Client s))
forall s. Server s -> IO (IntMap (Client s))
getServerClients Server s
srv
                  Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Clients: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (IntMap (Client s) -> Int
forall a. IntMap a -> Int
IM.size IntMap (Client s)
activeClients)
                  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CPClientRole
r CPClientRole -> CPClientRole -> Bool
forall a. Eq a => a -> a -> Bool
== CPClientRole
CPRAdmin) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                    (Natural, Natural, Natural)
clQs <- IntMap (Client s) -> IO (Natural, Natural, Natural)
forall (t :: * -> *).
Foldable t =>
t (Client s) -> IO (Natural, Natural, Natural)
clientTBQueueLengths' IntMap (Client s)
activeClients
                    Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Client queues (rcvQ, sndQ, msgQ): " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (Natural, Natural, Natural) -> String
forall a. Show a => a -> String
show (Natural, Natural, Natural)
clQs
                    (Int
smpSubCnt, (Int, Int, Int, Int)
smpSubCntByGroup, Int
smpClCnt, (Natural, Natural, Natural)
smpClQs) <- (Client s -> TMap RecipientId Sub)
-> Maybe (Map RecipientId Sub -> IO (Int, Int, Int, Int))
-> IntMap (Client s)
-> IO (Int, (Int, Int, Int, Int), Int, (Natural, Natural, Natural))
forall a.
(Client s -> TMap RecipientId a)
-> Maybe (Map RecipientId a -> IO (Int, Int, Int, Int))
-> IntMap (Client s)
-> IO (Int, (Int, Int, Int, Int), Int, (Natural, Natural, Natural))
countClientSubs Client s -> TMap RecipientId Sub
forall s. Client s -> TMap RecipientId Sub
subscriptions ((Map RecipientId Sub -> IO (Int, Int, Int, Int))
-> Maybe (Map RecipientId Sub -> IO (Int, Int, Int, Int))
forall a. a -> Maybe a
Just Map RecipientId Sub -> IO (Int, Int, Int, Int)
countSMPSubs) IntMap (Client s)
activeClients
                    Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"SMP subscriptions (via clients): " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
smpSubCnt
                    Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"SMP subscriptions (by group: NoSub, SubPending, SubThread, ProhibitSub): " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (Int, Int, Int, Int) -> String
forall a. Show a => a -> String
show (Int, Int, Int, Int)
smpSubCntByGroup
                    Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"SMP subscribed clients (via clients): " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
smpClCnt
                    Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"SMP subscribed clients queues (via clients, rcvQ, sndQ, msgQ): " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (Natural, Natural, Natural) -> String
forall a. Show a => a -> String
show (Natural, Natural, Natural)
smpClQs
                    (Int
ntfSubCnt, (Int, Int, Int, Int)
_, Int
ntfClCnt, (Natural, Natural, Natural)
ntfClQs) <- (Client s -> TMap RecipientId ())
-> Maybe (Map RecipientId () -> IO (Int, Int, Int, Int))
-> IntMap (Client s)
-> IO (Int, (Int, Int, Int, Int), Int, (Natural, Natural, Natural))
forall a.
(Client s -> TMap RecipientId a)
-> Maybe (Map RecipientId a -> IO (Int, Int, Int, Int))
-> IntMap (Client s)
-> IO (Int, (Int, Int, Int, Int), Int, (Natural, Natural, Natural))
countClientSubs Client s -> TMap RecipientId ()
forall s. Client s -> TMap RecipientId ()
ntfSubscriptions Maybe (Map RecipientId () -> IO (Int, Int, Int, Int))
forall a. Maybe a
Nothing IntMap (Client s)
activeClients
                    Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Ntf subscriptions (via clients): " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
ntfSubCnt
                    Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Ntf subscribed clients (via clients): " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
ntfClCnt
                    Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Ntf subscribed clients queues (via clients, rcvQ, sndQ, msgQ): " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (Natural, Natural, Natural) -> String
forall a. Show a => a -> String
show (Natural, Natural, Natural)
ntfClQs
                  String -> ServerSubscribers s -> Bool -> IO ()
putSubscribersInfo String
"SMP" ServerSubscribers s
subscribers Bool
False
                  String -> ServerSubscribers s -> Bool -> IO ()
putSubscribersInfo String
"Ntf" ServerSubscribers s
ntfSubscribers Bool
True
                  where
                    putSubscribersInfo :: String -> ServerSubscribers s -> Bool -> IO ()
                    putSubscribersInfo :: String -> ServerSubscribers s -> Bool -> IO ()
putSubscribersInfo String
protoName ServerSubscribers {SubscribedClients s
$sel:queueSubscribers:ServerSubscribers :: forall s. ServerSubscribers s -> SubscribedClients s
queueSubscribers :: SubscribedClients s
queueSubscribers, TVar IntSet
$sel:subClients:ServerSubscribers :: forall s. ServerSubscribers s -> TVar IntSet
subClients :: TVar IntSet
subClients} Bool
showIds = do
                      Map RecipientId (TVar (Maybe (Client s)))
activeSubs <- SubscribedClients s
-> IO (Map RecipientId (TVar (Maybe (Client s))))
forall s.
SubscribedClients s
-> IO (Map RecipientId (TVar (Maybe (Client s))))
getSubscribedClients SubscribedClients s
queueSubscribers
                      Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
protoName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" subscriptions: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (Map RecipientId (TVar (Maybe (Client s))) -> Int
forall k a. Map k a -> Int
M.size Map RecipientId (TVar (Maybe (Client s)))
activeSubs)
                      -- TODO [certs] service subscriptions
                      IntSet
clnts <- Map RecipientId (TVar (Maybe (Client s))) -> IO IntSet
countSubClients Map RecipientId (TVar (Maybe (Client s)))
activeSubs
                      Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
protoName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" subscribed clients: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (IntSet -> Int
IS.size IntSet
clnts) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (if Bool
showIds then String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [Int] -> String
forall a. Show a => a -> String
show (IntSet -> [Int]
IS.toList IntSet
clnts) else String
"")
                      IntSet
clnts' <- TVar IntSet -> IO IntSet
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar IntSet
subClients
                      Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
protoName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" subscribed clients count 2: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (IntSet -> Int
IS.size IntSet
clnts') String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (if Bool
showIds then String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> IntSet -> String
forall a. Show a => a -> String
show IntSet
clnts' else String
"")
                      where
                        countSubClients :: Map QueueId (TVar (Maybe (Client s))) -> IO IS.IntSet
                        countSubClients :: Map RecipientId (TVar (Maybe (Client s))) -> IO IntSet
countSubClients = (IntSet -> TVar (Maybe (Client s)) -> IO IntSet)
-> IntSet -> Map RecipientId (TVar (Maybe (Client s))) -> IO IntSet
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\ !IntSet
s TVar (Maybe (Client s))
c -> IntSet -> (Client s -> IntSet) -> Maybe (Client s) -> IntSet
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IntSet
s ((Int -> IntSet -> IntSet
`IS.insert` IntSet
s) (Int -> IntSet) -> (Client s -> Int) -> Client s -> IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Client s -> Int
forall s. Client s -> Int
clientId) (Maybe (Client s) -> IntSet) -> IO (Maybe (Client s)) -> IO IntSet
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Maybe (Client s)) -> IO (Maybe (Client s))
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Maybe (Client s))
c) IntSet
IS.empty
                    countClientSubs :: (Client s -> TMap QueueId a) -> Maybe (Map QueueId a -> IO (Int, Int, Int, Int)) -> IM.IntMap (Client s) -> IO (Int, (Int, Int, Int, Int), Int, (Natural, Natural, Natural))
                    countClientSubs :: forall a.
(Client s -> TMap RecipientId a)
-> Maybe (Map RecipientId a -> IO (Int, Int, Int, Int))
-> IntMap (Client s)
-> IO (Int, (Int, Int, Int, Int), Int, (Natural, Natural, Natural))
countClientSubs Client s -> TMap RecipientId a
subSel Maybe (Map RecipientId a -> IO (Int, Int, Int, Int))
countSubs_ = ((Int, (Int, Int, Int, Int), Int, (Natural, Natural, Natural))
 -> Client s
 -> IO
      (Int, (Int, Int, Int, Int), Int, (Natural, Natural, Natural)))
-> (Int, (Int, Int, Int, Int), Int, (Natural, Natural, Natural))
-> IntMap (Client s)
-> IO (Int, (Int, Int, Int, Int), Int, (Natural, Natural, Natural))
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Int, (Int, Int, Int, Int), Int, (Natural, Natural, Natural))
-> Client s
-> IO (Int, (Int, Int, Int, Int), Int, (Natural, Natural, Natural))
addSubs (Int
0, (Int
0, Int
0, Int
0, Int
0), Int
0, (Natural
0, Natural
0, Natural
0))
                      where
                        addSubs :: (Int, (Int, Int, Int, Int), Int, (Natural, Natural, Natural)) -> Client s -> IO (Int, (Int, Int, Int, Int), Int, (Natural, Natural, Natural))
                        addSubs :: (Int, (Int, Int, Int, Int), Int, (Natural, Natural, Natural))
-> Client s
-> IO (Int, (Int, Int, Int, Int), Int, (Natural, Natural, Natural))
addSubs (!Int
subCnt, cnts :: (Int, Int, Int, Int)
cnts@(!Int
c1, !Int
c2, !Int
c3, !Int
c4), !Int
clCnt, !(Natural, Natural, Natural)
qs) Client s
cl = do
                          Map RecipientId a
subs <- TMap RecipientId a -> IO (Map RecipientId a)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (TMap RecipientId a -> IO (Map RecipientId a))
-> TMap RecipientId a -> IO (Map RecipientId a)
forall a b. (a -> b) -> a -> b
$ Client s -> TMap RecipientId a
subSel Client s
cl
                          (Int, Int, Int, Int)
cnts' <- case Maybe (Map RecipientId a -> IO (Int, Int, Int, Int))
countSubs_ of
                            Maybe (Map RecipientId a -> IO (Int, Int, Int, Int))
Nothing -> (Int, Int, Int, Int) -> IO (Int, Int, Int, Int)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int, Int, Int, Int)
cnts
                            Just Map RecipientId a -> IO (Int, Int, Int, Int)
countSubs -> do
                              (Int
c1', Int
c2', Int
c3', Int
c4') <- Map RecipientId a -> IO (Int, Int, Int, Int)
countSubs Map RecipientId a
subs
                              (Int, Int, Int, Int) -> IO (Int, Int, Int, Int)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
c1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
c1', Int
c2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
c2', Int
c3 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
c3', Int
c4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
c4')
                          let cnt :: Int
cnt = Map RecipientId a -> Int
forall k a. Map k a -> Int
M.size Map RecipientId a
subs
                              clCnt' :: Int
clCnt' = if Int
cnt Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Int
clCnt else Int
clCnt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                          (Natural, Natural, Natural)
qs' <- if Int
cnt Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then (Natural, Natural, Natural) -> IO (Natural, Natural, Natural)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Natural, Natural, Natural)
qs else (Natural, Natural, Natural)
-> Client s -> IO (Natural, Natural, Natural)
forall {m :: * -> *} {s}.
MonadIO m =>
(Natural, Natural, Natural)
-> Client s -> m (Natural, Natural, Natural)
addQueueLengths (Natural, Natural, Natural)
qs Client s
cl
                          (Int, (Int, Int, Int, Int), Int, (Natural, Natural, Natural))
-> IO (Int, (Int, Int, Int, Int), Int, (Natural, Natural, Natural))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
subCnt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
cnt, (Int, Int, Int, Int)
cnts', Int
clCnt', (Natural, Natural, Natural)
qs')
                    clientTBQueueLengths' :: Foldable t => t (Client s) -> IO (Natural, Natural, Natural)
                    clientTBQueueLengths' :: forall (t :: * -> *).
Foldable t =>
t (Client s) -> IO (Natural, Natural, Natural)
clientTBQueueLengths' = ((Natural, Natural, Natural)
 -> Client s -> IO (Natural, Natural, Natural))
-> (Natural, Natural, Natural)
-> t (Client s)
-> IO (Natural, Natural, Natural)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Natural, Natural, Natural)
-> Client s -> IO (Natural, Natural, Natural)
forall {m :: * -> *} {s}.
MonadIO m =>
(Natural, Natural, Natural)
-> Client s -> m (Natural, Natural, Natural)
addQueueLengths (Natural
0, Natural
0, Natural
0)
                    addQueueLengths :: (Natural, Natural, Natural)
-> Client s -> m (Natural, Natural, Natural)
addQueueLengths (!Natural
rl, !Natural
sl, !Natural
ml) Client s
cl = do
                      (Natural
rl', Natural
sl', Natural
ml') <- Client s -> m (Natural, Natural, Natural)
forall {m :: * -> *} {s}.
MonadIO m =>
Client s -> m (Natural, Natural, Natural)
queueLengths Client s
cl
                      (Natural, Natural, Natural) -> m (Natural, Natural, Natural)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Natural
rl Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
rl', Natural
sl Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
sl', Natural
ml Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
ml')
                    queueLengths :: Client s -> m (Natural, Natural, Natural)
queueLengths Client {TBQueue (NonEmpty (VerifiedTransmission s))
rcvQ :: TBQueue (NonEmpty (VerifiedTransmission s))
$sel:rcvQ:Client :: forall s. Client s -> TBQueue (NonEmpty (VerifiedTransmission s))
rcvQ, TBQueue
  (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
$sel:sndQ:Client :: forall s.
Client s
-> TBQueue
     (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
sndQ :: TBQueue
  (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
sndQ, TBQueue (NonEmpty (Transmission BrokerMsg))
msgQ :: TBQueue (NonEmpty (Transmission BrokerMsg))
$sel:msgQ:Client :: forall s. Client s -> TBQueue (NonEmpty (Transmission BrokerMsg))
msgQ} = do
                      Natural
rl <- STM Natural -> m Natural
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Natural -> m Natural) -> STM Natural -> m Natural
forall a b. (a -> b) -> a -> b
$ TBQueue (NonEmpty (VerifiedTransmission s)) -> STM Natural
forall a. TBQueue a -> STM Natural
lengthTBQueue TBQueue (NonEmpty (VerifiedTransmission s))
rcvQ
                      Natural
sl <- STM Natural -> m Natural
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Natural -> m Natural) -> STM Natural -> m Natural
forall a b. (a -> b) -> a -> b
$ TBQueue
  (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
-> STM Natural
forall a. TBQueue a -> STM Natural
lengthTBQueue TBQueue
  (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
sndQ
                      Natural
ml <- STM Natural -> m Natural
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Natural -> m Natural) -> STM Natural -> m Natural
forall a b. (a -> b) -> a -> b
$ TBQueue (NonEmpty (Transmission BrokerMsg)) -> STM Natural
forall a. TBQueue a -> STM Natural
lengthTBQueue TBQueue (NonEmpty (Transmission BrokerMsg))
msgQ
                      (Natural, Natural, Natural) -> m (Natural, Natural, Natural)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Natural
rl, Natural
sl, Natural
ml)
                    countSMPSubs :: Map QueueId Sub -> IO (Int, Int, Int, Int)
                    countSMPSubs :: Map RecipientId Sub -> IO (Int, Int, Int, Int)
countSMPSubs = ((Int, Int, Int, Int) -> Sub -> IO (Int, Int, Int, Int))
-> (Int, Int, Int, Int)
-> Map RecipientId Sub
-> IO (Int, Int, Int, Int)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Int, Int, Int, Int) -> Sub -> IO (Int, Int, Int, Int)
forall {m :: * -> *} {a} {b} {c} {d}.
(MonadIO m, Num a, Num b, Num c, Num d) =>
(a, b, c, d) -> Sub -> m (a, b, c, d)
countSubs (Int
0, Int
0, Int
0, Int
0)
                      where
                        countSubs :: (a, b, c, d) -> Sub -> m (a, b, c, d)
countSubs (a
c1, b
c2, c
c3, d
c4) Sub {ServerSub
subThread :: ServerSub
$sel:subThread:Sub :: Sub -> ServerSub
subThread} = case ServerSub
subThread of
                          ServerSub TVar SubscriptionThread
t -> do
                            SubscriptionThread
st <- TVar SubscriptionThread -> m SubscriptionThread
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar SubscriptionThread
t
                            (a, b, c, d) -> m (a, b, c, d)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a, b, c, d) -> m (a, b, c, d)) -> (a, b, c, d) -> m (a, b, c, d)
forall a b. (a -> b) -> a -> b
$ case SubscriptionThread
st of
                              SubscriptionThread
NoSub -> (a
c1 a -> a -> a
forall a. Num a => a -> a -> a
+ a
1, b
c2, c
c3, d
c4)
                              SubscriptionThread
SubPending -> (a
c1, b
c2 b -> b -> b
forall a. Num a => a -> a -> a
+ b
1, c
c3, d
c4)
                              SubThread Weak ThreadId
_ -> (a
c1, b
c2, c
c3 c -> c -> c
forall a. Num a => a -> a -> a
+ c
1, d
c4)
                          ServerSub
ProhibitSub -> (a, b, c, d) -> m (a, b, c, d)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
c1, b
c2, c
c3, d
c4 d -> d -> d
forall a. Num a => a -> a -> a
+ d
1)
              CPDelete RecipientId
qId -> IO () -> IO ()
withAdminRole (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ UnliftIO (ReaderT (Env s) IO)
-> forall a. ReaderT (Env s) IO a -> IO a
forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO (ReaderT (Env s) IO)
u (M s () -> IO ()) -> M s () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                s
st <- (Env s -> s) -> ReaderT (Env s) IO s
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> s
forall s. Env s -> s
msgStore
                Either ErrorType (QueueRec, Int)
r <- IO (Either ErrorType (QueueRec, Int))
-> ReaderT (Env s) IO (Either ErrorType (QueueRec, Int))
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ErrorType (QueueRec, Int))
 -> ReaderT (Env s) IO (Either ErrorType (QueueRec, Int)))
-> IO (Either ErrorType (QueueRec, Int))
-> ReaderT (Env s) IO (Either ErrorType (QueueRec, Int))
forall a b. (a -> b) -> a -> b
$ ExceptT ErrorType IO (QueueRec, Int)
-> IO (Either ErrorType (QueueRec, Int))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ErrorType IO (QueueRec, Int)
 -> IO (Either ErrorType (QueueRec, Int)))
-> ExceptT ErrorType IO (QueueRec, Int)
-> IO (Either ErrorType (QueueRec, Int))
forall a b. (a -> b) -> a -> b
$ do
                  (StoreQueue s
q, QueueRec
_) <- IO (Either ErrorType (StoreQueue s, QueueRec))
-> ExceptT ErrorType IO (StoreQueue s, QueueRec)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either ErrorType (StoreQueue s, QueueRec))
 -> ExceptT ErrorType IO (StoreQueue s, QueueRec))
-> IO (Either ErrorType (StoreQueue s, QueueRec))
-> ExceptT ErrorType IO (StoreQueue s, QueueRec)
forall a b. (a -> b) -> a -> b
$ s -> RecipientId -> IO (Either ErrorType (StoreQueue s, QueueRec))
forall {s}.
MsgStoreClass s =>
s -> RecipientId -> IO (Either ErrorType (StoreQueue s, QueueRec))
getSenderQueue s
st RecipientId
qId
                  IO (Either ErrorType (QueueRec, Int))
-> ExceptT ErrorType IO (QueueRec, Int)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either ErrorType (QueueRec, Int))
 -> ExceptT ErrorType IO (QueueRec, Int))
-> IO (Either ErrorType (QueueRec, Int))
-> ExceptT ErrorType IO (QueueRec, Int)
forall a b. (a -> b) -> a -> b
$ s -> StoreQueue s -> IO (Either ErrorType (QueueRec, Int))
forall s.
MsgStoreClass s =>
s -> StoreQueue s -> IO (Either ErrorType (QueueRec, Int))
deleteQueueSize s
st StoreQueue s
q
                case Either ErrorType (QueueRec, Int)
r of
                  Left ErrorType
e -> IO () -> M s ()
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"error: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ErrorType -> String
forall a. Show a => a -> String
show ErrorType
e
                  Right (QueueRec
qr, Int
numDeleted) -> do
                    QueueRec -> M s ()
forall s. QueueRec -> M s ()
updateDeletedStats QueueRec
qr
                    IO () -> M s ()
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"ok, " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
numDeleted String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" messages deleted"
              CPStatus RecipientId
qId -> IO () -> IO ()
withUserRole (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ UnliftIO (ReaderT (Env s) IO)
-> forall a. ReaderT (Env s) IO a -> IO a
forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO (ReaderT (Env s) IO)
u (M s () -> IO ()) -> M s () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                s
st <- (Env s -> s) -> ReaderT (Env s) IO s
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> s
forall s. Env s -> s
msgStore
                Either ErrorType (StoreQueue s, QueueRec)
q <- IO (Either ErrorType (StoreQueue s, QueueRec))
-> ReaderT (Env s) IO (Either ErrorType (StoreQueue s, QueueRec))
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ErrorType (StoreQueue s, QueueRec))
 -> ReaderT (Env s) IO (Either ErrorType (StoreQueue s, QueueRec)))
-> IO (Either ErrorType (StoreQueue s, QueueRec))
-> ReaderT (Env s) IO (Either ErrorType (StoreQueue s, QueueRec))
forall a b. (a -> b) -> a -> b
$ s -> RecipientId -> IO (Either ErrorType (StoreQueue s, QueueRec))
forall {s}.
MsgStoreClass s =>
s -> RecipientId -> IO (Either ErrorType (StoreQueue s, QueueRec))
getSenderQueue s
st RecipientId
qId
                IO () -> M s ()
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ case Either ErrorType (StoreQueue s, QueueRec)
q of
                  Left ErrorType
e -> String
"error: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ErrorType -> String
forall a. Show a => a -> String
show ErrorType
e
                  Right (StoreQueue s
_, QueueRec {Maybe QueueMode
queueMode :: Maybe QueueMode
$sel:queueMode:QueueRec :: QueueRec -> Maybe QueueMode
queueMode, ServerEntityStatus
status :: ServerEntityStatus
$sel:status:QueueRec :: QueueRec -> ServerEntityStatus
status, Maybe SystemDate
updatedAt :: Maybe SystemDate
$sel:updatedAt:QueueRec :: QueueRec -> Maybe SystemDate
updatedAt}) ->
                    String
"status: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ServerEntityStatus -> String
forall a. Show a => a -> String
show ServerEntityStatus
status String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", updatedAt: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Maybe SystemDate -> String
forall a. Show a => a -> String
show Maybe SystemDate
updatedAt String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", queueMode: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Maybe QueueMode -> String
forall a. Show a => a -> String
show Maybe QueueMode
queueMode
              CPBlock RecipientId
qId BlockingInfo
info -> IO () -> IO ()
withUserRole (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ UnliftIO (ReaderT (Env s) IO)
-> forall a. ReaderT (Env s) IO a -> IO a
forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO (ReaderT (Env s) IO)
u (M s () -> IO ()) -> M s () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                s
st <- (Env s -> s) -> ReaderT (Env s) IO s
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> s
forall s. Env s -> s
msgStore
                ServerStats
stats <- (Env s -> ServerStats) -> ReaderT (Env s) IO ServerStats
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> ServerStats
forall s. Env s -> ServerStats
serverStats
                Int
blocked <- IO Int -> ReaderT (Env s) IO Int
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> ReaderT (Env s) IO Int)
-> IO Int -> ReaderT (Env s) IO Int
forall a b. (a -> b) -> a -> b
$ IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef (IORef Int -> IO Int) -> IORef Int -> IO Int
forall a b. (a -> b) -> a -> b
$ ServerStats -> IORef Int
qBlocked ServerStats
stats
                let quota :: Int
quota = ServerConfig s -> Int
forall s. ServerConfig s -> Int
dailyBlockQueueQuota ServerConfig s
cfg
                if Int
blocked Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
quota Bool -> Bool -> Bool
&& Int
quota Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0
                  then IO () -> M s ()
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"error: reached limit of " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
quota String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" queues blocked daily"
                  else do
                    Either ErrorType (ServerEntityStatus, ServerEntityStatus)
r <- IO (Either ErrorType (ServerEntityStatus, ServerEntityStatus))
-> ReaderT
     (Env s)
     IO
     (Either ErrorType (ServerEntityStatus, ServerEntityStatus))
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ErrorType (ServerEntityStatus, ServerEntityStatus))
 -> ReaderT
      (Env s)
      IO
      (Either ErrorType (ServerEntityStatus, ServerEntityStatus)))
-> IO (Either ErrorType (ServerEntityStatus, ServerEntityStatus))
-> ReaderT
     (Env s)
     IO
     (Either ErrorType (ServerEntityStatus, ServerEntityStatus))
forall a b. (a -> b) -> a -> b
$ ExceptT ErrorType IO (ServerEntityStatus, ServerEntityStatus)
-> IO (Either ErrorType (ServerEntityStatus, ServerEntityStatus))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ErrorType IO (ServerEntityStatus, ServerEntityStatus)
 -> IO (Either ErrorType (ServerEntityStatus, ServerEntityStatus)))
-> ExceptT ErrorType IO (ServerEntityStatus, ServerEntityStatus)
-> IO (Either ErrorType (ServerEntityStatus, ServerEntityStatus))
forall a b. (a -> b) -> a -> b
$ do
                      (StoreQueue s
q, QueueRec {ServerEntityStatus
$sel:status:QueueRec :: QueueRec -> ServerEntityStatus
status :: ServerEntityStatus
status}) <- IO (Either ErrorType (StoreQueue s, QueueRec))
-> ExceptT ErrorType IO (StoreQueue s, QueueRec)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either ErrorType (StoreQueue s, QueueRec))
 -> ExceptT ErrorType IO (StoreQueue s, QueueRec))
-> IO (Either ErrorType (StoreQueue s, QueueRec))
-> ExceptT ErrorType IO (StoreQueue s, QueueRec)
forall a b. (a -> b) -> a -> b
$ s -> RecipientId -> IO (Either ErrorType (StoreQueue s, QueueRec))
forall {s}.
MsgStoreClass s =>
s -> RecipientId -> IO (Either ErrorType (StoreQueue s, QueueRec))
getSenderQueue s
st RecipientId
qId
                      let rId :: RecipientId
rId = StoreQueue s -> RecipientId
forall q. StoreQueueClass q => q -> RecipientId
recipientId StoreQueue s
q
                      Bool -> ExceptT ErrorType IO () -> ExceptT ErrorType IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ServerEntityStatus
status ServerEntityStatus -> ServerEntityStatus -> Bool
forall a. Eq a => a -> a -> Bool
/= BlockingInfo -> ServerEntityStatus
EntityBlocked BlockingInfo
info) (ExceptT ErrorType IO () -> ExceptT ErrorType IO ())
-> ExceptT ErrorType IO () -> ExceptT ErrorType IO ()
forall a b. (a -> b) -> a -> b
$ do
                        IO (Either ErrorType ()) -> ExceptT ErrorType IO ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either ErrorType ()) -> ExceptT ErrorType IO ())
-> IO (Either ErrorType ()) -> ExceptT ErrorType IO ()
forall a b. (a -> b) -> a -> b
$ QueueStore s
-> StoreQueue s -> BlockingInfo -> IO (Either ErrorType ())
forall q s.
QueueStoreClass q s =>
s -> q -> BlockingInfo -> IO (Either ErrorType ())
blockQueue (s -> QueueStore s
forall s. MsgStoreClass s => s -> QueueStore s
queueStore s
st) StoreQueue s
q BlockingInfo
info
                        IO () -> ExceptT ErrorType IO ()
forall a. IO a -> ExceptT ErrorType IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT ErrorType IO ())
-> IO () -> ExceptT ErrorType IO ()
forall a b. (a -> b) -> a -> b
$
                          RecipientId
-> SubscribedClients s -> IO (Maybe (TVar (Maybe (Client s))))
forall s.
RecipientId
-> SubscribedClients s -> IO (Maybe (TVar (Maybe (Client s))))
getSubscribedClient RecipientId
rId (ServerSubscribers s -> SubscribedClients s
forall s. ServerSubscribers s -> SubscribedClients s
queueSubscribers (ServerSubscribers s -> SubscribedClients s)
-> ServerSubscribers s -> SubscribedClients s
forall a b. (a -> b) -> a -> b
$ Server s -> ServerSubscribers s
forall s. Server s -> ServerSubscribers s
subscribers Server s
srv)
                            IO (Maybe (TVar (Maybe (Client s))))
-> (TVar (Maybe (Client s)) -> IO (Maybe (Client s)))
-> IO (Maybe (Client s))
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Monad f, Traversable f) =>
m (f a) -> (a -> m (f b)) -> m (f b)
$>>= TVar (Maybe (Client s)) -> IO (Maybe (Client s))
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO
                            IO (Maybe (Client s)) -> (Maybe (Client s) -> 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
>>= (Client s -> IO ()) -> Maybe (Client s) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Client s
c -> STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TBQueue
  (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
-> (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
-> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue (Client s
-> TBQueue
     (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
forall s.
Client s
-> TBQueue
     (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
sndQ Client s
c) ([(CorrId
NoCorrId, RecipientId
rId, ErrorType -> BrokerMsg
ERR (ErrorType -> BrokerMsg) -> ErrorType -> BrokerMsg
forall a b. (a -> b) -> a -> b
$ BlockingInfo -> ErrorType
BLOCKED BlockingInfo
info)] , [])))
                      (ServerEntityStatus, ServerEntityStatus)
-> ExceptT ErrorType IO (ServerEntityStatus, ServerEntityStatus)
forall a. a -> ExceptT ErrorType IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ServerEntityStatus
status, BlockingInfo -> ServerEntityStatus
EntityBlocked BlockingInfo
info)
                    case Either ErrorType (ServerEntityStatus, ServerEntityStatus)
r of
                      Left ErrorType
e -> IO () -> M s ()
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"error: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ErrorType -> String
forall a. Show a => a -> String
show ErrorType
e
                      Right (ServerEntityStatus
EntityActive, ServerEntityStatus
status') -> do
                        IORef Int -> M s ()
forall (m :: * -> *). MonadIO m => IORef Int -> m ()
incStat (IORef Int -> M s ()) -> IORef Int -> M s ()
forall a b. (a -> b) -> a -> b
$ ServerStats -> IORef Int
qBlocked ServerStats
stats
                        IO () -> M s ()
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"ok, queue blocked: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ServerEntityStatus -> String
forall a. Show a => a -> String
show ServerEntityStatus
status'
                      Right (ServerEntityStatus
_, ServerEntityStatus
status') -> IO () -> M s ()
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"ok, already inactive: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ServerEntityStatus -> String
forall a. Show a => a -> String
show ServerEntityStatus
status'
              CPUnblock RecipientId
qId -> IO () -> IO ()
withUserRole (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ UnliftIO (ReaderT (Env s) IO)
-> forall a. ReaderT (Env s) IO a -> IO a
forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO (ReaderT (Env s) IO)
u (M s () -> IO ()) -> M s () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                s
st <- (Env s -> s) -> ReaderT (Env s) IO s
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> s
forall s. Env s -> s
msgStore
                Either ErrorType (Either Bool BlockingInfo)
r <- IO (Either ErrorType (Either Bool BlockingInfo))
-> ReaderT (Env s) IO (Either ErrorType (Either Bool BlockingInfo))
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ErrorType (Either Bool BlockingInfo))
 -> ReaderT
      (Env s) IO (Either ErrorType (Either Bool BlockingInfo)))
-> IO (Either ErrorType (Either Bool BlockingInfo))
-> ReaderT (Env s) IO (Either ErrorType (Either Bool BlockingInfo))
forall a b. (a -> b) -> a -> b
$ ExceptT ErrorType IO (Either Bool BlockingInfo)
-> IO (Either ErrorType (Either Bool BlockingInfo))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ErrorType IO (Either Bool BlockingInfo)
 -> IO (Either ErrorType (Either Bool BlockingInfo)))
-> ExceptT ErrorType IO (Either Bool BlockingInfo)
-> IO (Either ErrorType (Either Bool BlockingInfo))
forall a b. (a -> b) -> a -> b
$ do
                  (StoreQueue s
q, QueueRec {ServerEntityStatus
$sel:status:QueueRec :: QueueRec -> ServerEntityStatus
status :: ServerEntityStatus
status}) <- IO (Either ErrorType (StoreQueue s, QueueRec))
-> ExceptT ErrorType IO (StoreQueue s, QueueRec)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either ErrorType (StoreQueue s, QueueRec))
 -> ExceptT ErrorType IO (StoreQueue s, QueueRec))
-> IO (Either ErrorType (StoreQueue s, QueueRec))
-> ExceptT ErrorType IO (StoreQueue s, QueueRec)
forall a b. (a -> b) -> a -> b
$ s -> RecipientId -> IO (Either ErrorType (StoreQueue s, QueueRec))
forall {s}.
MsgStoreClass s =>
s -> RecipientId -> IO (Either ErrorType (StoreQueue s, QueueRec))
getSenderQueue s
st RecipientId
qId
                  case ServerEntityStatus
status of
                    EntityBlocked BlockingInfo
info -> BlockingInfo -> Either Bool BlockingInfo
forall a b. b -> Either a b
Right BlockingInfo
info Either Bool BlockingInfo
-> ExceptT ErrorType IO ()
-> ExceptT ErrorType IO (Either Bool BlockingInfo)
forall a b. a -> ExceptT ErrorType IO b -> ExceptT ErrorType IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ IO (Either ErrorType ()) -> ExceptT ErrorType IO ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (QueueStore s -> StoreQueue s -> IO (Either ErrorType ())
forall q s.
QueueStoreClass q s =>
s -> q -> IO (Either ErrorType ())
unblockQueue (s -> QueueStore s
forall s. MsgStoreClass s => s -> QueueStore s
queueStore s
st) StoreQueue s
q)
                    ServerEntityStatus
EntityActive -> Either Bool BlockingInfo
-> ExceptT ErrorType IO (Either Bool BlockingInfo)
forall a. a -> ExceptT ErrorType IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Bool BlockingInfo
 -> ExceptT ErrorType IO (Either Bool BlockingInfo))
-> Either Bool BlockingInfo
-> ExceptT ErrorType IO (Either Bool BlockingInfo)
forall a b. (a -> b) -> a -> b
$ Bool -> Either Bool BlockingInfo
forall a b. a -> Either a b
Left Bool
True
                    ServerEntityStatus
EntityOff -> Either Bool BlockingInfo
-> ExceptT ErrorType IO (Either Bool BlockingInfo)
forall a. a -> ExceptT ErrorType IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Bool BlockingInfo
 -> ExceptT ErrorType IO (Either Bool BlockingInfo))
-> Either Bool BlockingInfo
-> ExceptT ErrorType IO (Either Bool BlockingInfo)
forall a b. (a -> b) -> a -> b
$ Bool -> Either Bool BlockingInfo
forall a b. a -> Either a b
Left Bool
False
                IO () -> M s ()
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ case Either ErrorType (Either Bool BlockingInfo)
r of
                  Left ErrorType
e -> String
"error: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ErrorType -> String
forall a. Show a => a -> String
show ErrorType
e
                  Right (Right BlockingInfo
info) -> String
"ok, queue unblocked, reason to block was: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> BlockingInfo -> String
forall a. Show a => a -> String
show BlockingInfo
info
                  Right (Left Bool
unblocked) -> if Bool
unblocked then String
"ok, queue was active" else String
"error, queue is inactive"
              ControlProtocol
CPSave -> IO () -> IO ()
withAdminRole (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Lock -> Text -> IO () -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
Lock -> Text -> m a -> m a
withLock' (Server s -> Lock
forall s. Server s -> Lock
savingLock Server s
srv) Text
"control" (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                Handle -> String -> IO ()
hPutStrLn Handle
h String
"saving server state..."
                UnliftIO (ReaderT (Env s) IO)
-> forall a. ReaderT (Env s) IO a -> IO a
forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO (ReaderT (Env s) IO)
u (M s () -> IO ()) -> M s () -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> M s ()
saveServer Bool
False
                Handle -> String -> IO ()
hPutStrLn Handle
h String
"server state saved!"
              ControlProtocol
CPHelp -> Handle -> String -> IO ()
hPutStrLn Handle
h String
"commands: stats, stats-rts, clients, sockets, socket-threads, threads, server-info, delete, save, help, quit"
              ControlProtocol
CPQuit -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              ControlProtocol
CPSkip -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              where
                getSenderQueue :: s -> RecipientId -> IO (Either ErrorType (StoreQueue s, QueueRec))
getSenderQueue s
st RecipientId
qId =
                  s
-> SParty 'Sender
-> RecipientId
-> IO (Either ErrorType (StoreQueue s, QueueRec))
forall s (p :: Party).
(MsgStoreClass s, QueueParty p) =>
s
-> SParty p
-> RecipientId
-> IO (Either ErrorType (StoreQueue s, QueueRec))
getQueueRec s
st SParty 'Sender
SSender RecipientId
qId IO (Either ErrorType (StoreQueue s, QueueRec))
-> (Either ErrorType (StoreQueue s, QueueRec)
    -> IO (Either ErrorType (StoreQueue s, QueueRec)))
-> IO (Either ErrorType (StoreQueue s, QueueRec))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                    Right (StoreQueue s, QueueRec)
r -> Either ErrorType (StoreQueue s, QueueRec)
-> IO (Either ErrorType (StoreQueue s, QueueRec))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrorType (StoreQueue s, QueueRec)
 -> IO (Either ErrorType (StoreQueue s, QueueRec)))
-> Either ErrorType (StoreQueue s, QueueRec)
-> IO (Either ErrorType (StoreQueue s, QueueRec))
forall a b. (a -> b) -> a -> b
$ (StoreQueue s, QueueRec)
-> Either ErrorType (StoreQueue s, QueueRec)
forall a b. b -> Either a b
Right (StoreQueue s, QueueRec)
r
                    Left ErrorType
AUTH -> s
-> SParty 'LinkClient
-> RecipientId
-> IO (Either ErrorType (StoreQueue s, QueueRec))
forall s (p :: Party).
(MsgStoreClass s, QueueParty p) =>
s
-> SParty p
-> RecipientId
-> IO (Either ErrorType (StoreQueue s, QueueRec))
getQueueRec s
st SParty 'LinkClient
SSenderLink RecipientId
qId
                    Left ErrorType
e ->  Either ErrorType (StoreQueue s, QueueRec)
-> IO (Either ErrorType (StoreQueue s, QueueRec))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrorType (StoreQueue s, QueueRec)
 -> IO (Either ErrorType (StoreQueue s, QueueRec)))
-> Either ErrorType (StoreQueue s, QueueRec)
-> IO (Either ErrorType (StoreQueue s, QueueRec))
forall a b. (a -> b) -> a -> b
$ ErrorType -> Either ErrorType (StoreQueue s, QueueRec)
forall a b. a -> Either a b
Left ErrorType
e
                withUserRole :: IO () -> IO ()
withUserRole IO ()
action = TVar CPClientRole -> IO CPClientRole
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar CPClientRole
role IO CPClientRole -> (CPClientRole -> 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
>>= \case
                  CPClientRole
CPRAdmin -> IO ()
action
                  CPClientRole
CPRUser -> IO ()
action
                  CPClientRole
_ -> do
                    Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logError Text
"Unauthorized control port command"
                    Handle -> String -> IO ()
hPutStrLn Handle
h String
"AUTH"
                withAdminRole :: IO () -> IO ()
withAdminRole IO ()
action = TVar CPClientRole -> IO CPClientRole
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar CPClientRole
role IO CPClientRole -> (CPClientRole -> 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
>>= \case
                  CPClientRole
CPRAdmin -> IO ()
action
                  CPClientRole
_ -> do
                    Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logError Text
"Unauthorized control port command"
                    Handle -> String -> IO ()
hPutStrLn Handle
h String
"AUTH"

runClientTransport :: forall c s. (Transport c, MsgStoreClass s) => THandleSMP c 'TServer -> M s ()
runClientTransport :: forall (c :: TransportPeer -> *) s.
(Transport c, MsgStoreClass s) =>
THandleSMP c 'TServer -> M s ()
runClientTransport h :: THandleSMP c 'TServer
h@THandle {$sel:params:THandle :: forall v (c :: TransportPeer -> *) (p :: TransportPeer).
THandle v c p -> THandleParams v p
params = thParams :: THandleParams SMPVersion 'TServer
thParams@THandleParams {ByteString
$sel:sessionId:THandleParams :: forall v (p :: TransportPeer). THandleParams v p -> ByteString
sessionId :: ByteString
sessionId}} = do
  Natural
q <- (Env s -> Natural) -> ReaderT (Env s) IO Natural
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Env s -> Natural) -> ReaderT (Env s) IO Natural)
-> (Env s -> Natural) -> ReaderT (Env s) IO Natural
forall a b. (a -> b) -> a -> b
$ ServerConfig s -> Natural
forall s. ServerConfig s -> Natural
tbqSize (ServerConfig s -> Natural)
-> (Env s -> ServerConfig s) -> Env s -> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env s -> ServerConfig s
forall s. Env s -> ServerConfig s
config
  SystemTime
ts <- IO SystemTime -> ReaderT (Env s) IO SystemTime
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO SystemTime
getSystemTime
  TVar Int
nextClientId <- (Env s -> TVar Int) -> ReaderT (Env s) IO (TVar Int)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> TVar Int
forall s. Env s -> TVar Int
clientSeq
  Int
clientId <- STM Int -> ReaderT (Env s) IO Int
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Int -> ReaderT (Env s) IO Int)
-> STM Int -> ReaderT (Env s) IO Int
forall a b. (a -> b) -> a -> b
$ TVar Int -> (Int -> (Int, Int)) -> STM Int
forall s a. TVar s -> (s -> (a, s)) -> STM a
stateTVar TVar Int
nextClientId ((Int -> (Int, Int)) -> STM Int) -> (Int -> (Int, Int)) -> STM Int
forall a b. (a -> b) -> a -> b
$ \Int
next -> (Int
next, Int
next Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  Client s
c <- IO (Client s) -> ReaderT (Env s) IO (Client s)
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Client s) -> ReaderT (Env s) IO (Client s))
-> IO (Client s) -> ReaderT (Env s) IO (Client s)
forall a b. (a -> b) -> a -> b
$ Int
-> Natural
-> THandleParams SMPVersion 'TServer
-> SystemTime
-> IO (Client s)
forall s.
Int
-> Natural
-> THandleParams SMPVersion 'TServer
-> SystemTime
-> IO (Client s)
newClient Int
clientId Natural
q THandleParams SMPVersion 'TServer
thParams SystemTime
ts
  Client s -> M s ()
runClientThreads Client s
c M s () -> M s () -> M s ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`finally` Client s -> M s ()
forall s. Client s -> M s ()
clientDisconnected Client s
c
  where
    runClientThreads :: Client s -> M s ()
    runClientThreads :: Client s -> M s ()
runClientThreads Client s
c = do
      Server s
s <- (Env s -> Server s) -> ReaderT (Env s) IO (Server s)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> Server s
forall s. Env s -> Server s
server
      s
ms <- (Env s -> s) -> ReaderT (Env s) IO s
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> s
forall s. Env s -> s
msgStore
      ReaderT (Env s) IO Bool -> M s () -> M s ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (IO Bool -> ReaderT (Env s) IO Bool
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ReaderT (Env s) IO Bool)
-> IO Bool -> ReaderT (Env s) IO Bool
forall a b. (a -> b) -> a -> b
$ Client s -> Server s -> IO Bool
forall s. Client s -> Server s -> IO Bool
insertServerClient Client s
c Server s
s) (M s () -> M s ()) -> M s () -> M s ()
forall a b. (a -> b) -> a -> b
$ do
        Maybe ExpirationConfig
expCfg <- (Env s -> Maybe ExpirationConfig)
-> ReaderT (Env s) IO (Maybe ExpirationConfig)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Env s -> Maybe ExpirationConfig)
 -> ReaderT (Env s) IO (Maybe ExpirationConfig))
-> (Env s -> Maybe ExpirationConfig)
-> ReaderT (Env s) IO (Maybe ExpirationConfig)
forall a b. (a -> b) -> a -> b
$ ServerConfig s -> Maybe ExpirationConfig
forall s. ServerConfig s -> Maybe ExpirationConfig
inactiveClientExpiration (ServerConfig s -> Maybe ExpirationConfig)
-> (Env s -> ServerConfig s) -> Env s -> Maybe ExpirationConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env s -> ServerConfig s
forall s. Env s -> ServerConfig s
config
        MVar (THandleSMP c 'TServer)
th <- THandleSMP c 'TServer
-> ReaderT (Env s) IO (MVar (THandleSMP c 'TServer))
forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar THandleSMP c 'TServer
h -- put TH under a fair lock to interleave messages and command responses
        String -> M s ()
forall (m :: * -> *). MonadIO m => String -> m ()
labelMyThread (String -> M s ())
-> (ByteString -> String) -> ByteString -> M s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
B.unpack (ByteString -> M s ()) -> ByteString -> M s ()
forall a b. (a -> b) -> a -> b
$ ByteString
"client $" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
encode ByteString
sessionId
        [M s ()] -> M s ()
forall (m :: * -> *) a. MonadUnliftIO m => [m a] -> m ()
raceAny_ ([M s ()] -> M s ()) -> [M s ()] -> M s ()
forall a b. (a -> b) -> a -> b
$ [IO () -> M s ()
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
forall a b. (a -> b) -> a -> b
$ MVar (THandleSMP c 'TServer) -> Client s -> IO ()
forall (c :: TransportPeer -> *) s.
Transport c =>
MVar (THandleSMP c 'TServer) -> Client s -> IO ()
send MVar (THandleSMP c 'TServer)
th Client s
c, IO () -> M s ()
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
forall a b. (a -> b) -> a -> b
$ MVar (THandleSMP c 'TServer) -> Client s -> IO ()
forall (c :: TransportPeer -> *) s.
Transport c =>
MVar (THandleSMP c 'TServer) -> Client s -> IO ()
sendMsg MVar (THandleSMP c 'TServer)
th Client s
c, Server s -> s -> Client s -> M s ()
forall s. MsgStoreClass s => Server s -> s -> Client s -> M s ()
client Server s
s s
ms Client s
c, THandleSMP c 'TServer -> s -> Client s -> M s ()
forall (c :: TransportPeer -> *) s.
(Transport c, MsgStoreClass s) =>
THandleSMP c 'TServer -> s -> Client s -> M s ()
receive THandleSMP c 'TServer
h s
ms Client s
c] [M s ()] -> [M s ()] -> [M s ()]
forall a. Semigroup a => a -> a -> a
<> Client s -> Server s -> Maybe ExpirationConfig -> [M s ()]
disconnectThread_ Client s
c Server s
s Maybe ExpirationConfig
expCfg
    disconnectThread_ :: Client s -> Server s -> Maybe ExpirationConfig -> [M s ()]
    disconnectThread_ :: Client s -> Server s -> Maybe ExpirationConfig -> [M s ()]
disconnectThread_ Client s
c Server s
s (Just ExpirationConfig
expCfg) = [IO () -> M s ()
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
forall a b. (a -> b) -> a -> b
$ THandleSMP c 'TServer
-> TVar SystemTime
-> TVar SystemTime
-> ExpirationConfig
-> IO Bool
-> IO ()
forall (c :: TransportPeer -> *) v.
Transport c =>
THandle v c 'TServer
-> TVar SystemTime
-> TVar SystemTime
-> ExpirationConfig
-> IO Bool
-> IO ()
disconnectTransport THandleSMP c 'TServer
h (Client s -> TVar SystemTime
forall s. Client s -> TVar SystemTime
rcvActiveAt Client s
c) (Client s -> TVar SystemTime
forall s. Client s -> TVar SystemTime
sndActiveAt Client s
c) ExpirationConfig
expCfg (Client s -> Server s -> IO Bool
forall {f :: * -> *} {s} {s}.
MonadIO f =>
Client s -> Server s -> f Bool
noSubscriptions Client s
c Server s
s)]
    disconnectThread_ Client s
_ Server s
_ Maybe ExpirationConfig
_ = []
    noSubscriptions :: Client s -> Server s -> f Bool
noSubscriptions Client {Int
$sel:clientId:Client :: forall s. Client s -> Int
clientId :: Int
clientId} Server s
s =
      Bool -> Bool
not (Bool -> Bool) -> f Bool -> f Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [f Bool] -> f Bool
forall (m :: * -> *). Monad m => [m Bool] -> m Bool
anyM [ServerSubscribers s -> f Bool
hasSubs (Server s -> ServerSubscribers s
forall s. Server s -> ServerSubscribers s
subscribers Server s
s), ServerSubscribers s -> f Bool
hasSubs (Server s -> ServerSubscribers s
forall s. Server s -> ServerSubscribers s
ntfSubscribers Server s
s)]
      where
        hasSubs :: ServerSubscribers s -> f Bool
hasSubs ServerSubscribers {TVar IntSet
$sel:subClients:ServerSubscribers :: forall s. ServerSubscribers s -> TVar IntSet
subClients :: TVar IntSet
subClients} = Int -> IntSet -> Bool
IS.member Int
clientId (IntSet -> Bool) -> f IntSet -> f Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar IntSet -> f IntSet
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar IntSet
subClients

controlPortAuth :: Handle -> Maybe BasicAuth -> Maybe BasicAuth -> TVar CPClientRole -> BasicAuth -> IO ()
controlPortAuth :: Handle
-> Maybe BasicAuth
-> Maybe BasicAuth
-> TVar CPClientRole
-> BasicAuth
-> IO ()
controlPortAuth Handle
h Maybe BasicAuth
user Maybe BasicAuth
admin TVar CPClientRole
role BasicAuth
auth = do
  TVar CPClientRole -> IO CPClientRole
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar CPClientRole
role IO CPClientRole -> (CPClientRole -> 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
>>= \case
    CPClientRole
CPRNone -> do
      STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar CPClientRole -> CPClientRole -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar CPClientRole
role (CPClientRole -> STM ()) -> CPClientRole -> STM ()
forall a b. (a -> b) -> a -> b
$! CPClientRole
newRole
      Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ CPClientRole -> String
forall a. Show a => a -> String
currentRole CPClientRole
newRole
    CPClientRole
r -> Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ CPClientRole -> String
forall a. Show a => a -> String
currentRole CPClientRole
r String -> String -> String
forall a. Semigroup a => a -> a -> a
<> if CPClientRole
r CPClientRole -> CPClientRole -> Bool
forall a. Eq a => a -> a -> Bool
== CPClientRole
newRole then String
"" else String
", start new session to change."
  where
    currentRole :: a -> String
currentRole a
r = String
"Current role is " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
r
    newRole :: CPClientRole
newRole
      | BasicAuth -> Maybe BasicAuth
forall a. a -> Maybe a
Just BasicAuth
auth Maybe BasicAuth -> Maybe BasicAuth -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe BasicAuth
admin = CPClientRole
CPRAdmin
      | BasicAuth -> Maybe BasicAuth
forall a. a -> Maybe a
Just BasicAuth
auth Maybe BasicAuth -> Maybe BasicAuth -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe BasicAuth
user = CPClientRole
CPRUser
      | Bool
otherwise = CPClientRole
CPRNone

clientDisconnected :: forall s. Client s -> M s ()
clientDisconnected :: forall s. Client s -> M s ()
clientDisconnected c :: Client s
c@Client {Int
$sel:clientId:Client :: forall s. Client s -> Int
clientId :: Int
clientId, TMap RecipientId Sub
$sel:subscriptions:Client :: forall s. Client s -> TMap RecipientId Sub
subscriptions :: TMap RecipientId Sub
subscriptions, TMap RecipientId ()
$sel:ntfSubscriptions:Client :: forall s. Client s -> TMap RecipientId ()
ntfSubscriptions :: TMap RecipientId ()
ntfSubscriptions, TVar Int64
$sel:serviceSubsCount:Client :: forall s. Client s -> TVar Int64
serviceSubsCount :: TVar Int64
serviceSubsCount, TVar Int64
$sel:ntfServiceSubsCount:Client :: forall s. Client s -> TVar Int64
ntfServiceSubsCount :: TVar Int64
ntfServiceSubsCount, TVar Bool
$sel:connected:Client :: forall s. Client s -> TVar Bool
connected :: TVar Bool
connected, $sel:clientTHParams:Client :: forall s. Client s -> THandleParams SMPVersion 'TServer
clientTHParams = THandleParams {ByteString
$sel:sessionId:THandleParams :: forall v (p :: TransportPeer). THandleParams v p -> ByteString
sessionId :: ByteString
sessionId, Maybe (THandleAuth 'TServer)
thAuth :: Maybe (THandleAuth 'TServer)
$sel:thAuth:THandleParams :: forall v (p :: TransportPeer).
THandleParams v p -> Maybe (THandleAuth p)
thAuth}, TVar (IntMap (Weak ThreadId))
endThreads :: TVar (IntMap (Weak ThreadId))
$sel:endThreads:Client :: forall s. Client s -> TVar (IntMap (Weak ThreadId))
endThreads} = do
  String -> M s ()
forall (m :: * -> *). MonadIO m => String -> m ()
labelMyThread (String -> M s ())
-> (ByteString -> String) -> ByteString -> M s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
B.unpack (ByteString -> M s ()) -> ByteString -> M s ()
forall a b. (a -> b) -> a -> b
$ ByteString
"client $" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
encode ByteString
sessionId ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" disc"
  -- these can be in separate transactions,
  -- because the client already disconnected and they won't change
  STM () -> M s ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> M s ()) -> STM () -> M s ()
forall a b. (a -> b) -> a -> b
$ TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
connected Bool
False
  Map RecipientId Sub
subs <- STM (Map RecipientId Sub)
-> ReaderT (Env s) IO (Map RecipientId Sub)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Map RecipientId Sub)
 -> ReaderT (Env s) IO (Map RecipientId Sub))
-> STM (Map RecipientId Sub)
-> ReaderT (Env s) IO (Map RecipientId Sub)
forall a b. (a -> b) -> a -> b
$ TMap RecipientId Sub
-> Map RecipientId Sub -> STM (Map RecipientId Sub)
forall a. TVar a -> a -> STM a
swapTVar TMap RecipientId Sub
subscriptions Map RecipientId Sub
forall k a. Map k a
M.empty
  Map RecipientId ()
ntfSubs <- STM (Map RecipientId ()) -> ReaderT (Env s) IO (Map RecipientId ())
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Map RecipientId ())
 -> ReaderT (Env s) IO (Map RecipientId ()))
-> STM (Map RecipientId ())
-> ReaderT (Env s) IO (Map RecipientId ())
forall a b. (a -> b) -> a -> b
$ TMap RecipientId ()
-> Map RecipientId () -> STM (Map RecipientId ())
forall a. TVar a -> a -> STM a
swapTVar TMap RecipientId ()
ntfSubscriptions Map RecipientId ()
forall k a. Map k a
M.empty
  IO () -> M s ()
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
forall a b. (a -> b) -> a -> b
$ (Sub -> IO ()) -> Map RecipientId Sub -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Sub -> IO ()
cancelSub Map RecipientId Sub
subs
  ReaderT (Env s) IO Bool -> M s () -> M s ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ((Env s -> TVar Bool) -> ReaderT (Env s) IO (TVar Bool)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> TVar Bool
forall s. Env s -> TVar Bool
serverActive ReaderT (Env s) IO (TVar Bool)
-> (TVar Bool -> ReaderT (Env s) IO Bool)
-> ReaderT (Env s) IO Bool
forall a b.
ReaderT (Env s) IO a
-> (a -> ReaderT (Env s) IO b) -> ReaderT (Env s) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TVar Bool -> ReaderT (Env s) IO Bool
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO) (M s () -> M s ()) -> M s () -> M s ()
forall a b. (a -> b) -> a -> b
$ do
    srv :: Server s
srv@Server {ServerSubscribers s
$sel:subscribers:Server :: forall s. Server s -> ServerSubscribers s
subscribers :: ServerSubscribers s
subscribers, ServerSubscribers s
$sel:ntfSubscribers:Server :: forall s. Server s -> ServerSubscribers s
ntfSubscribers :: ServerSubscribers s
ntfSubscribers} <- (Env s -> Server s) -> ReaderT (Env s) IO (Server s)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> Server s
forall s. Env s -> Server s
server
    IO () -> M s ()
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
forall a b. (a -> b) -> a -> b
$ do
      Int -> Server s -> IO ()
forall s. Int -> Server s -> IO ()
deleteServerClient Int
clientId Server s
srv
      Map RecipientId Sub -> ServerSubscribers s -> IO ()
forall a. Map RecipientId a -> ServerSubscribers s -> IO ()
updateSubscribers Map RecipientId Sub
subs ServerSubscribers s
subscribers
      Map RecipientId () -> ServerSubscribers s -> IO ()
forall a. Map RecipientId a -> ServerSubscribers s -> IO ()
updateSubscribers Map RecipientId ()
ntfSubs ServerSubscribers s
ntfSubscribers
      case THandleAuth 'TServer -> Maybe THPeerClientService
peerClientService (THandleAuth 'TServer -> Maybe THPeerClientService)
-> Maybe (THandleAuth 'TServer) -> Maybe THPeerClientService
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (THandleAuth 'TServer)
thAuth of
        Just THClientService {RecipientId
serviceId :: RecipientId
$sel:serviceId:THClientService :: forall k. THClientService' k -> RecipientId
serviceId, SMPServiceRole
serviceRole :: SMPServiceRole
$sel:serviceRole:THClientService :: forall k. THClientService' k -> SMPServiceRole
serviceRole}
          | SMPServiceRole
serviceRole SMPServiceRole -> SMPServiceRole -> Bool
forall a. Eq a => a -> a -> Bool
== SMPServiceRole
SRMessaging -> RecipientId -> TVar Int64 -> ServerSubscribers s -> IO ()
updateServiceSubs RecipientId
serviceId TVar Int64
serviceSubsCount ServerSubscribers s
subscribers
          | SMPServiceRole
serviceRole SMPServiceRole -> SMPServiceRole -> Bool
forall a. Eq a => a -> a -> Bool
== SMPServiceRole
SRNotifier -> RecipientId -> TVar Int64 -> ServerSubscribers s -> IO ()
updateServiceSubs RecipientId
serviceId TVar Int64
ntfServiceSubsCount ServerSubscribers s
ntfSubscribers
        Maybe THPeerClientService
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  IntMap (Weak ThreadId)
tIds <- STM (IntMap (Weak ThreadId))
-> ReaderT (Env s) IO (IntMap (Weak ThreadId))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (IntMap (Weak ThreadId))
 -> ReaderT (Env s) IO (IntMap (Weak ThreadId)))
-> STM (IntMap (Weak ThreadId))
-> ReaderT (Env s) IO (IntMap (Weak ThreadId))
forall a b. (a -> b) -> a -> b
$ TVar (IntMap (Weak ThreadId))
-> IntMap (Weak ThreadId) -> STM (IntMap (Weak ThreadId))
forall a. TVar a -> a -> STM a
swapTVar TVar (IntMap (Weak ThreadId))
endThreads IntMap (Weak ThreadId)
forall a. IntMap a
IM.empty
  IO () -> M s ()
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
forall a b. (a -> b) -> a -> b
$ (Weak ThreadId -> IO ()) -> IntMap (Weak ThreadId) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((ThreadId -> IO ()) -> Maybe ThreadId -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ThreadId -> IO ()
forall (m :: * -> *). MonadIO m => ThreadId -> m ()
killThread (Maybe ThreadId -> IO ())
-> (Weak ThreadId -> IO (Maybe ThreadId)) -> Weak ThreadId -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Weak ThreadId -> IO (Maybe ThreadId)
forall v. Weak v -> IO (Maybe v)
deRefWeak) IntMap (Weak ThreadId)
tIds
  where
    updateSubscribers :: Map QueueId a -> ServerSubscribers s -> IO ()
    updateSubscribers :: forall a. Map RecipientId a -> ServerSubscribers s -> IO ()
updateSubscribers Map RecipientId a
subs ServerSubscribers {SubscribedClients s
$sel:queueSubscribers:ServerSubscribers :: forall s. ServerSubscribers s -> SubscribedClients s
queueSubscribers :: SubscribedClients s
queueSubscribers, TVar IntSet
$sel:subClients:ServerSubscribers :: forall s. ServerSubscribers s -> TVar IntSet
subClients :: TVar IntSet
subClients} = do
      (RecipientId -> IO ()) -> [RecipientId] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\RecipientId
qId -> RecipientId -> Client s -> SubscribedClients s -> IO ()
forall s. RecipientId -> Client s -> SubscribedClients s -> IO ()
deleteSubcribedClient RecipientId
qId Client s
c SubscribedClients s
queueSubscribers) (Map RecipientId a -> [RecipientId]
forall k a. Map k a -> [k]
M.keys Map RecipientId a
subs)
      STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar IntSet -> (IntSet -> IntSet) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar IntSet
subClients ((IntSet -> IntSet) -> STM ()) -> (IntSet -> IntSet) -> STM ()
forall a b. (a -> b) -> a -> b
$ Int -> IntSet -> IntSet
IS.delete Int
clientId
    updateServiceSubs :: ServiceId -> TVar Int64 -> ServerSubscribers s -> IO ()
    updateServiceSubs :: RecipientId -> TVar Int64 -> ServerSubscribers s -> IO ()
updateServiceSubs RecipientId
serviceId TVar Int64
subsCount ServerSubscribers {TVar Int64
$sel:totalServiceSubs:ServerSubscribers :: forall s. ServerSubscribers s -> TVar Int64
totalServiceSubs :: TVar Int64
totalServiceSubs, SubscribedClients s
$sel:serviceSubscribers:ServerSubscribers :: forall s. ServerSubscribers s -> SubscribedClients s
serviceSubscribers :: SubscribedClients s
serviceSubscribers} = do
      RecipientId -> Client s -> SubscribedClients s -> IO ()
forall s. RecipientId -> Client s -> SubscribedClients s -> IO ()
deleteSubcribedClient RecipientId
serviceId Client s
c SubscribedClients s
serviceSubscribers
      STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> (Int64 -> STM ()) -> Int64 -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar Int64 -> (Int64 -> Int64) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int64
totalServiceSubs ((Int64 -> Int64) -> STM ())
-> (Int64 -> Int64 -> Int64) -> Int64 -> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
subtract (Int64 -> IO ()) -> IO Int64 -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TVar Int64 -> IO Int64
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar Int64
subsCount

cancelSub :: Sub -> IO ()
cancelSub :: Sub -> IO ()
cancelSub Sub
s = case Sub -> ServerSub
subThread Sub
s of
  ServerSub TVar SubscriptionThread
st ->
    TVar SubscriptionThread -> IO SubscriptionThread
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar SubscriptionThread
st IO SubscriptionThread -> (SubscriptionThread -> 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
>>= \case
      SubThread Weak ThreadId
t -> IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Weak ThreadId -> IO (Maybe ThreadId)
forall v. Weak v -> IO (Maybe v)
deRefWeak Weak ThreadId
t IO (Maybe ThreadId) -> (Maybe ThreadId -> 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
>>= (ThreadId -> IO ()) -> Maybe ThreadId -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ThreadId -> IO ()
forall (m :: * -> *). MonadIO m => ThreadId -> m ()
killThread
      SubscriptionThread
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  ServerSub
ProhibitSub -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

type VerifiedTransmissionOrError s = Either (Transmission BrokerMsg) (VerifiedTransmission s)

receive :: forall c s. (Transport c, MsgStoreClass s) => THandleSMP c 'TServer -> s -> Client s -> M s ()
receive :: forall (c :: TransportPeer -> *) s.
(Transport c, MsgStoreClass s) =>
THandleSMP c 'TServer -> s -> Client s -> M s ()
receive h :: THandleSMP c 'TServer
h@THandle {$sel:params:THandle :: forall v (c :: TransportPeer -> *) (p :: TransportPeer).
THandle v c p -> THandleParams v p
params = THandleParams {Maybe (THandleAuth 'TServer)
$sel:thAuth:THandleParams :: forall v (p :: TransportPeer).
THandleParams v p -> Maybe (THandleAuth p)
thAuth :: Maybe (THandleAuth 'TServer)
thAuth, ByteString
$sel:sessionId:THandleParams :: forall v (p :: TransportPeer). THandleParams v p -> ByteString
sessionId :: ByteString
sessionId}} s
ms Client {TBQueue (NonEmpty (VerifiedTransmission s))
$sel:rcvQ:Client :: forall s. Client s -> TBQueue (NonEmpty (VerifiedTransmission s))
rcvQ :: TBQueue (NonEmpty (VerifiedTransmission s))
rcvQ, TBQueue
  (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
$sel:sndQ:Client :: forall s.
Client s
-> TBQueue
     (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
sndQ :: TBQueue
  (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
sndQ, TVar SystemTime
$sel:rcvActiveAt:Client :: forall s. Client s -> TVar SystemTime
rcvActiveAt :: TVar SystemTime
rcvActiveAt} = do
  String -> M s ()
forall (m :: * -> *). MonadIO m => String -> m ()
labelMyThread (String -> M s ())
-> (ByteString -> String) -> ByteString -> M s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
B.unpack (ByteString -> M s ()) -> ByteString -> M s ()
forall a b. (a -> b) -> a -> b
$ ByteString
"client $" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
encode ByteString
sessionId ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" receive"
  TVar Bool
sa <- (Env s -> TVar Bool) -> ReaderT (Env s) IO (TVar Bool)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> TVar Bool
forall s. Env s -> TVar Bool
serverActive
  ServerStats
stats <- (Env s -> ServerStats) -> ReaderT (Env s) IO ServerStats
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> ServerStats
forall s. Env s -> ServerStats
serverStats
  IO () -> M s ()
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    NonEmpty (SignedTransmissionOrError ErrorType Cmd)
ts <- THandleSMP c 'TServer
-> IO (NonEmpty (SignedTransmissionOrError ErrorType Cmd))
forall v err cmd (c :: TransportPeer -> *).
(ProtocolEncoding v err cmd, Transport c) =>
THandle v c 'TServer
-> IO (NonEmpty (SignedTransmissionOrError err cmd))
tGetServer THandleSMP c 'TServer
h
    IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (TVar Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar Bool
sa) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IOError -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (IOError -> IO ()) -> IOError -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IOError
userError String
"server stopped"
    STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> (SystemTime -> STM ()) -> SystemTime -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TVar SystemTime -> SystemTime -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar SystemTime
rcvActiveAt (SystemTime -> STM ()) -> SystemTime -> STM ()
forall a b. (a -> b) -> a -> b
$!) (SystemTime -> IO ()) -> IO SystemTime -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO SystemTime
getSystemTime
    let ([Transmission ErrorType]
es, [SignedTransmission Cmd]
ts') = [SignedTransmissionOrError ErrorType Cmd]
-> ([Transmission ErrorType], [SignedTransmission Cmd])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([SignedTransmissionOrError ErrorType Cmd]
 -> ([Transmission ErrorType], [SignedTransmission Cmd]))
-> [SignedTransmissionOrError ErrorType Cmd]
-> ([Transmission ErrorType], [SignedTransmission Cmd])
forall a b. (a -> b) -> a -> b
$ NonEmpty (SignedTransmissionOrError ErrorType Cmd)
-> [SignedTransmissionOrError ErrorType Cmd]
forall a. NonEmpty a -> [a]
L.toList NonEmpty (SignedTransmissionOrError ErrorType Cmd)
ts
        errs :: [Transmission BrokerMsg]
errs = (Transmission ErrorType -> Transmission BrokerMsg)
-> [Transmission ErrorType] -> [Transmission BrokerMsg]
forall a b. (a -> b) -> [a] -> [b]
map ((ErrorType -> BrokerMsg)
-> Transmission ErrorType -> Transmission BrokerMsg
forall b c a. (b -> c) -> (CorrId, a, b) -> (CorrId, a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ErrorType -> BrokerMsg
ERR) [Transmission ErrorType]
es
    [Transmission BrokerMsg]
errs' <- case [SignedTransmission Cmd]
ts' of
      (Maybe TAuthorizations
_, ByteString
_, (CorrId
_, RecipientId
_, Cmd SParty p
p Command p
cmd)) : [SignedTransmission Cmd]
rest -> do
        let service :: Maybe THPeerClientService
service = THandleAuth 'TServer -> Maybe THPeerClientService
peerClientService (THandleAuth 'TServer -> Maybe THPeerClientService)
-> Maybe (THandleAuth 'TServer) -> Maybe THPeerClientService
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (THandleAuth 'TServer)
thAuth
        ([Transmission BrokerMsg]
errs', [VerifiedTransmission s]
cmds) <- [Either (Transmission BrokerMsg) (VerifiedTransmission s)]
-> ([Transmission BrokerMsg], [VerifiedTransmission s])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either (Transmission BrokerMsg) (VerifiedTransmission s)]
 -> ([Transmission BrokerMsg], [VerifiedTransmission s]))
-> IO [Either (Transmission BrokerMsg) (VerifiedTransmission s)]
-> IO ([Transmission BrokerMsg], [VerifiedTransmission s])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case SParty p -> Maybe (Dict (PartyI p, BatchParty p))
forall (p :: Party).
SParty p -> Maybe (Dict (PartyI p, BatchParty p))
batchParty SParty p
p of
          Just Dict (PartyI p, BatchParty p)
Dict | Bool -> Bool
not ([SignedTransmission Cmd] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SignedTransmission Cmd]
rest) Bool -> Bool -> Bool
&& (SignedTransmission Cmd -> Bool)
-> [SignedTransmission Cmd] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (SParty p -> SignedTransmission Cmd -> Bool
forall (p :: Party). SParty p -> SignedTransmission Cmd -> Bool
sameParty SParty p
p) [SignedTransmission Cmd]
ts'-> do
            ServerStats -> Command p -> IO ()
forall (p :: Party). ServerStats -> Command p -> IO ()
updateBatchStats ServerStats
stats Command p
cmd -- even if nothing is verified
            let queueId :: (a, b, (a, b, c)) -> b
queueId (a
_, b
_, (a
_, b
qId, c
_)) = b
qId
            [Either ErrorType (StoreQueue s, QueueRec)]
qs <- s
-> SParty p
-> [RecipientId]
-> IO [Either ErrorType (StoreQueue s, QueueRec)]
forall s (p :: Party).
(MsgStoreClass s, BatchParty p) =>
s
-> SParty p
-> [RecipientId]
-> IO [Either ErrorType (StoreQueue s, QueueRec)]
getQueueRecs s
ms SParty p
p ([RecipientId] -> IO [Either ErrorType (StoreQueue s, QueueRec)])
-> [RecipientId] -> IO [Either ErrorType (StoreQueue s, QueueRec)]
forall a b. (a -> b) -> a -> b
$ (SignedTransmission Cmd -> RecipientId)
-> [SignedTransmission Cmd] -> [RecipientId]
forall a b. (a -> b) -> [a] -> [b]
map SignedTransmission Cmd -> RecipientId
forall {a} {b} {a} {b} {c}. (a, b, (a, b, c)) -> b
queueId [SignedTransmission Cmd]
ts'
            (SignedTransmission Cmd
 -> Either ErrorType (StoreQueue s, QueueRec)
 -> IO (Either (Transmission BrokerMsg) (VerifiedTransmission s)))
-> [SignedTransmission Cmd]
-> [Either ErrorType (StoreQueue s, QueueRec)]
-> IO [Either (Transmission BrokerMsg) (VerifiedTransmission s)]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (\SignedTransmission Cmd
t -> ServerStats
-> SignedTransmission Cmd
-> VerificationResult s
-> IO (Either (Transmission BrokerMsg) (VerifiedTransmission s))
verified ServerStats
stats SignedTransmission Cmd
t (VerificationResult s
 -> IO (Either (Transmission BrokerMsg) (VerifiedTransmission s)))
-> (Either ErrorType (StoreQueue s, QueueRec)
    -> VerificationResult s)
-> Either ErrorType (StoreQueue s, QueueRec)
-> IO (Either (Transmission BrokerMsg) (VerifiedTransmission s))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe THPeerClientService
-> Maybe (THandleAuth 'TServer)
-> SignedTransmission Cmd
-> Either ErrorType (StoreQueue s, QueueRec)
-> VerificationResult s
forall s.
Maybe THPeerClientService
-> Maybe (THandleAuth 'TServer)
-> SignedTransmission Cmd
-> Either ErrorType (StoreQueue s, QueueRec)
-> VerificationResult s
verifyLoadedQueue Maybe THPeerClientService
service Maybe (THandleAuth 'TServer)
thAuth SignedTransmission Cmd
t) [SignedTransmission Cmd]
ts' [Either ErrorType (StoreQueue s, QueueRec)]
qs
          Maybe (Dict (PartyI p, BatchParty p))
_ -> (SignedTransmission Cmd
 -> IO (Either (Transmission BrokerMsg) (VerifiedTransmission s)))
-> [SignedTransmission Cmd]
-> IO [Either (Transmission BrokerMsg) (VerifiedTransmission s)]
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) -> [a] -> m [b]
mapM (\SignedTransmission Cmd
t -> ServerStats
-> SignedTransmission Cmd
-> VerificationResult s
-> IO (Either (Transmission BrokerMsg) (VerifiedTransmission s))
verified ServerStats
stats SignedTransmission Cmd
t (VerificationResult s
 -> IO (Either (Transmission BrokerMsg) (VerifiedTransmission s)))
-> IO (VerificationResult s)
-> IO (Either (Transmission BrokerMsg) (VerifiedTransmission s))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< s
-> Maybe THPeerClientService
-> Maybe (THandleAuth 'TServer)
-> SignedTransmission Cmd
-> IO (VerificationResult s)
forall s.
MsgStoreClass s =>
s
-> Maybe THPeerClientService
-> Maybe (THandleAuth 'TServer)
-> SignedTransmission Cmd
-> IO (VerificationResult s)
verifyTransmission s
ms Maybe THPeerClientService
service Maybe (THandleAuth 'TServer)
thAuth SignedTransmission Cmd
t) [SignedTransmission Cmd]
ts'
        (NonEmpty (VerifiedTransmission s) -> IO ())
-> Maybe (NonEmpty (VerifiedTransmission s)) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ())
-> (NonEmpty (VerifiedTransmission s) -> STM ())
-> NonEmpty (VerifiedTransmission s)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TBQueue (NonEmpty (VerifiedTransmission s))
-> NonEmpty (VerifiedTransmission s) -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue (NonEmpty (VerifiedTransmission s))
rcvQ) (Maybe (NonEmpty (VerifiedTransmission s)) -> IO ())
-> Maybe (NonEmpty (VerifiedTransmission s)) -> IO ()
forall a b. (a -> b) -> a -> b
$ [VerifiedTransmission s]
-> Maybe (NonEmpty (VerifiedTransmission s))
forall a. [a] -> Maybe (NonEmpty a)
L.nonEmpty [VerifiedTransmission s]
cmds
        [Transmission BrokerMsg] -> IO [Transmission BrokerMsg]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Transmission BrokerMsg] -> IO [Transmission BrokerMsg])
-> [Transmission BrokerMsg] -> IO [Transmission BrokerMsg]
forall a b. (a -> b) -> a -> b
$ [Transmission BrokerMsg]
errs [Transmission BrokerMsg]
-> [Transmission BrokerMsg] -> [Transmission BrokerMsg]
forall a. [a] -> [a] -> [a]
++ [Transmission BrokerMsg]
errs'
      [] -> [Transmission BrokerMsg] -> IO [Transmission BrokerMsg]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Transmission BrokerMsg]
errs
    (NonEmpty (Transmission BrokerMsg) -> IO ())
-> Maybe (NonEmpty (Transmission BrokerMsg)) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ())
-> (NonEmpty (Transmission BrokerMsg) -> STM ())
-> NonEmpty (Transmission BrokerMsg)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TBQueue
  (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
-> (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
-> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue
  (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
sndQ ((NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
 -> STM ())
-> (NonEmpty (Transmission BrokerMsg)
    -> (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg]))
-> NonEmpty (Transmission BrokerMsg)
-> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,[])) (Maybe (NonEmpty (Transmission BrokerMsg)) -> IO ())
-> Maybe (NonEmpty (Transmission BrokerMsg)) -> IO ()
forall a b. (a -> b) -> a -> b
$ [Transmission BrokerMsg]
-> Maybe (NonEmpty (Transmission BrokerMsg))
forall a. [a] -> Maybe (NonEmpty a)
L.nonEmpty [Transmission BrokerMsg]
errs'
  where
    sameParty :: SParty p -> SignedTransmission Cmd -> Bool
    sameParty :: forall (p :: Party). SParty p -> SignedTransmission Cmd -> Bool
sameParty SParty p
p (Maybe TAuthorizations
_, ByteString
_, (CorrId
_, RecipientId
_, Cmd SParty p
p' Command p
_)) = Maybe (p :~: p) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (p :~: p) -> Bool) -> Maybe (p :~: p) -> Bool
forall a b. (a -> b) -> a -> b
$ SParty p -> SParty p -> Maybe (p :~: p)
forall {k} (f :: k -> *) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
forall (a :: Party) (b :: Party).
SParty a -> SParty b -> Maybe (a :~: b)
testEquality SParty p
p SParty p
p'
    updateBatchStats :: ServerStats -> Command p -> IO ()
    updateBatchStats :: forall (p :: Party). ServerStats -> Command p -> IO ()
updateBatchStats ServerStats
stats = \case
      Command p
SUB -> IORef Int -> IO ()
forall (m :: * -> *). MonadIO m => IORef Int -> m ()
incStat (IORef Int -> IO ()) -> IORef Int -> IO ()
forall a b. (a -> b) -> a -> b
$ ServerStats -> IORef Int
qSubAllB ServerStats
stats
      Command p
DEL -> IORef Int -> IO ()
forall (m :: * -> *). MonadIO m => IORef Int -> m ()
incStat (IORef Int -> IO ()) -> IORef Int -> IO ()
forall a b. (a -> b) -> a -> b
$ ServerStats -> IORef Int
qDeletedAllB ServerStats
stats
      Command p
NDEL -> IORef Int -> IO ()
forall (m :: * -> *). MonadIO m => IORef Int -> m ()
incStat (IORef Int -> IO ()) -> IORef Int -> IO ()
forall a b. (a -> b) -> a -> b
$ ServerStats -> IORef Int
ntfDeletedB ServerStats
stats
      Command p
NSUB -> IORef Int -> IO ()
forall (m :: * -> *). MonadIO m => IORef Int -> m ()
incStat (IORef Int -> IO ()) -> IORef Int -> IO ()
forall a b. (a -> b) -> a -> b
$ ServerStats -> IORef Int
ntfSubB ServerStats
stats
      Command p
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    verified :: ServerStats -> SignedTransmission Cmd -> VerificationResult s -> IO (VerifiedTransmissionOrError s)
    verified :: ServerStats
-> SignedTransmission Cmd
-> VerificationResult s
-> IO (Either (Transmission BrokerMsg) (VerifiedTransmission s))
verified ServerStats
stats (Maybe TAuthorizations
_, ByteString
_, t :: (CorrId, RecipientId, Cmd)
t@(CorrId
corrId, RecipientId
entId, Cmd SParty p
_ Command p
command)) = \case
      VRVerified Maybe (StoreQueue s, QueueRec)
q -> Either (Transmission BrokerMsg) (VerifiedTransmission s)
-> IO (Either (Transmission BrokerMsg) (VerifiedTransmission s))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Transmission BrokerMsg) (VerifiedTransmission s)
 -> IO (Either (Transmission BrokerMsg) (VerifiedTransmission s)))
-> Either (Transmission BrokerMsg) (VerifiedTransmission s)
-> IO (Either (Transmission BrokerMsg) (VerifiedTransmission s))
forall a b. (a -> b) -> a -> b
$ VerifiedTransmission s
-> Either (Transmission BrokerMsg) (VerifiedTransmission s)
forall a b. b -> Either a b
Right (Maybe (StoreQueue s, QueueRec)
q, (CorrId, RecipientId, Cmd)
t)
      VRFailed ErrorType
e -> Transmission BrokerMsg
-> Either (Transmission BrokerMsg) (VerifiedTransmission s)
forall a b. a -> Either a b
Left (CorrId
corrId, RecipientId
entId, ErrorType -> BrokerMsg
ERR ErrorType
e) Either (Transmission BrokerMsg) (VerifiedTransmission s)
-> IO ()
-> IO (Either (Transmission BrokerMsg) (VerifiedTransmission s))
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ErrorType
e ErrorType -> ErrorType -> Bool
forall a. Eq a => a -> a -> Bool
== ErrorType
AUTH) IO ()
incAuthStat
        where
          incAuthStat :: IO ()
incAuthStat = case Command p
command of
            SEND {} -> IORef Int -> IO ()
forall (m :: * -> *). MonadIO m => IORef Int -> m ()
incStat (IORef Int -> IO ()) -> IORef Int -> IO ()
forall a b. (a -> b) -> a -> b
$ ServerStats -> IORef Int
msgSentAuth ServerStats
stats
            Command p
SUB -> IORef Int -> IO ()
forall (m :: * -> *). MonadIO m => IORef Int -> m ()
incStat (IORef Int -> IO ()) -> IORef Int -> IO ()
forall a b. (a -> b) -> a -> b
$ ServerStats -> IORef Int
qSubAuth ServerStats
stats
            Command p
NSUB -> IORef Int -> IO ()
forall (m :: * -> *). MonadIO m => IORef Int -> m ()
incStat (IORef Int -> IO ()) -> IORef Int -> IO ()
forall a b. (a -> b) -> a -> b
$ ServerStats -> IORef Int
ntfSubAuth ServerStats
stats
            Command p
GET -> IORef Int -> IO ()
forall (m :: * -> *). MonadIO m => IORef Int -> m ()
incStat (IORef Int -> IO ()) -> IORef Int -> IO ()
forall a b. (a -> b) -> a -> b
$ ServerStats -> IORef Int
msgGetAuth ServerStats
stats
            Command p
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

send :: Transport c => MVar (THandleSMP c 'TServer) -> Client s -> IO ()
send :: forall (c :: TransportPeer -> *) s.
Transport c =>
MVar (THandleSMP c 'TServer) -> Client s -> IO ()
send MVar (THandleSMP c 'TServer)
th c :: Client s
c@Client {TBQueue
  (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
$sel:sndQ:Client :: forall s.
Client s
-> TBQueue
     (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
sndQ :: TBQueue
  (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
sndQ, TBQueue (NonEmpty (Transmission BrokerMsg))
$sel:msgQ:Client :: forall s. Client s -> TBQueue (NonEmpty (Transmission BrokerMsg))
msgQ :: TBQueue (NonEmpty (Transmission BrokerMsg))
msgQ, $sel:clientTHParams:Client :: forall s. Client s -> THandleParams SMPVersion 'TServer
clientTHParams = THandleParams {ByteString
$sel:sessionId:THandleParams :: forall v (p :: TransportPeer). THandleParams v p -> ByteString
sessionId :: ByteString
sessionId}} = do
  String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
labelMyThread (String -> IO ()) -> (ByteString -> String) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
B.unpack (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString
"client $" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
encode ByteString
sessionId ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" send"
  IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ STM (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
-> IO (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TBQueue
  (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
-> STM
     (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
forall a. TBQueue a -> STM a
readTBQueue TBQueue
  (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
sndQ) IO (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
-> ((NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
    -> 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
>>= (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
-> IO ()
sendTransmissions
  where
    -- If the request had batched subscriptions
    -- this will reply SOKs to all SUBs in the first batched transmission,
    -- to reduce client timeouts.
    -- After that all messages will be sent in separate transmissions,
    -- without any client response timeouts, and allowing them to interleave
    -- with other requests responses.
    sendTransmissions :: (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg]) -> IO ()
    sendTransmissions :: (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
-> IO ()
sendTransmissions (NonEmpty (Transmission BrokerMsg)
ts, []) = MVar (THandleSMP c 'TServer)
-> Client s -> NonEmpty (Transmission BrokerMsg) -> IO ()
forall (c :: TransportPeer -> *) s.
Transport c =>
MVar (THandleSMP c 'TServer)
-> Client s -> NonEmpty (Transmission BrokerMsg) -> IO ()
tSend MVar (THandleSMP c 'TServer)
th Client s
c NonEmpty (Transmission BrokerMsg)
ts
    sendTransmissions (NonEmpty (Transmission BrokerMsg)
ts, Transmission BrokerMsg
msg : [Transmission BrokerMsg]
msgs)
      | NonEmpty (Transmission BrokerMsg) -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty (Transmission BrokerMsg)
ts Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
4 = do -- up to 4 SOKs can be in one block with MSG (see testBatchSubResponses test)
          MVar (THandleSMP c 'TServer)
-> Client s -> NonEmpty (Transmission BrokerMsg) -> IO ()
forall (c :: TransportPeer -> *) s.
Transport c =>
MVar (THandleSMP c 'TServer)
-> Client s -> NonEmpty (Transmission BrokerMsg) -> IO ()
tSend MVar (THandleSMP c 'TServer)
th Client s
c (NonEmpty (Transmission BrokerMsg) -> IO ())
-> NonEmpty (Transmission BrokerMsg) -> IO ()
forall a b. (a -> b) -> a -> b
$ NonEmpty (Transmission BrokerMsg)
ts NonEmpty (Transmission BrokerMsg)
-> NonEmpty (Transmission BrokerMsg)
-> NonEmpty (Transmission BrokerMsg)
forall a. Semigroup a => a -> a -> a
<> [Transmission BrokerMsg
Item (NonEmpty (Transmission BrokerMsg))
msg]
          (NonEmpty (Transmission BrokerMsg) -> IO ())
-> Maybe (NonEmpty (Transmission BrokerMsg)) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ())
-> (NonEmpty (Transmission BrokerMsg) -> STM ())
-> NonEmpty (Transmission BrokerMsg)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TBQueue (NonEmpty (Transmission BrokerMsg))
-> NonEmpty (Transmission BrokerMsg) -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue (NonEmpty (Transmission BrokerMsg))
msgQ) (Maybe (NonEmpty (Transmission BrokerMsg)) -> IO ())
-> Maybe (NonEmpty (Transmission BrokerMsg)) -> IO ()
forall a b. (a -> b) -> a -> b
$ [Transmission BrokerMsg]
-> Maybe (NonEmpty (Transmission BrokerMsg))
forall a. [a] -> Maybe (NonEmpty a)
L.nonEmpty [Transmission BrokerMsg]
msgs
      | Bool
otherwise = do
          MVar (THandleSMP c 'TServer)
-> Client s -> NonEmpty (Transmission BrokerMsg) -> IO ()
forall (c :: TransportPeer -> *) s.
Transport c =>
MVar (THandleSMP c 'TServer)
-> Client s -> NonEmpty (Transmission BrokerMsg) -> IO ()
tSend MVar (THandleSMP c 'TServer)
th Client s
c NonEmpty (Transmission BrokerMsg)
ts
          STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TBQueue (NonEmpty (Transmission BrokerMsg))
-> NonEmpty (Transmission BrokerMsg) -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue (NonEmpty (Transmission BrokerMsg))
msgQ (Transmission BrokerMsg
msg Transmission BrokerMsg
-> [Transmission BrokerMsg] -> NonEmpty (Transmission BrokerMsg)
forall a. a -> [a] -> NonEmpty a
:| [Transmission BrokerMsg]
msgs)

sendMsg :: Transport c => MVar (THandleSMP c 'TServer) -> Client s -> IO ()
sendMsg :: forall (c :: TransportPeer -> *) s.
Transport c =>
MVar (THandleSMP c 'TServer) -> Client s -> IO ()
sendMsg MVar (THandleSMP c 'TServer)
th c :: Client s
c@Client {TBQueue (NonEmpty (Transmission BrokerMsg))
$sel:msgQ:Client :: forall s. Client s -> TBQueue (NonEmpty (Transmission BrokerMsg))
msgQ :: TBQueue (NonEmpty (Transmission BrokerMsg))
msgQ, $sel:clientTHParams:Client :: forall s. Client s -> THandleParams SMPVersion 'TServer
clientTHParams = THandleParams {ByteString
$sel:sessionId:THandleParams :: forall v (p :: TransportPeer). THandleParams v p -> ByteString
sessionId :: ByteString
sessionId}} = do
  String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
labelMyThread (String -> IO ()) -> (ByteString -> String) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
B.unpack (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString
"client $" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
encode ByteString
sessionId ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" sendMsg"
  IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ STM (NonEmpty (Transmission BrokerMsg))
-> IO (NonEmpty (Transmission BrokerMsg))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TBQueue (NonEmpty (Transmission BrokerMsg))
-> STM (NonEmpty (Transmission BrokerMsg))
forall a. TBQueue a -> STM a
readTBQueue TBQueue (NonEmpty (Transmission BrokerMsg))
msgQ) IO (NonEmpty (Transmission BrokerMsg))
-> (NonEmpty (Transmission BrokerMsg) -> 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
>>= (Transmission BrokerMsg -> IO ())
-> NonEmpty (Transmission BrokerMsg) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Transmission BrokerMsg
t -> MVar (THandleSMP c 'TServer)
-> Client s -> NonEmpty (Transmission BrokerMsg) -> IO ()
forall (c :: TransportPeer -> *) s.
Transport c =>
MVar (THandleSMP c 'TServer)
-> Client s -> NonEmpty (Transmission BrokerMsg) -> IO ()
tSend MVar (THandleSMP c 'TServer)
th Client s
c [Transmission BrokerMsg
Item (NonEmpty (Transmission BrokerMsg))
t])

tSend :: Transport c => MVar (THandleSMP c 'TServer) -> Client s -> NonEmpty (Transmission BrokerMsg) -> IO ()
tSend :: forall (c :: TransportPeer -> *) s.
Transport c =>
MVar (THandleSMP c 'TServer)
-> Client s -> NonEmpty (Transmission BrokerMsg) -> IO ()
tSend MVar (THandleSMP c 'TServer)
th Client {TVar SystemTime
$sel:sndActiveAt:Client :: forall s. Client s -> TVar SystemTime
sndActiveAt :: TVar SystemTime
sndActiveAt} NonEmpty (Transmission BrokerMsg)
ts = do
  MVar (THandleSMP c 'TServer)
-> (THandleSMP c 'TServer -> IO ()) -> IO ()
forall (m :: * -> *) a b.
MonadUnliftIO m =>
MVar a -> (a -> m b) -> m b
withMVar MVar (THandleSMP c 'TServer)
th ((THandleSMP c 'TServer -> IO ()) -> IO ())
-> (THandleSMP c 'TServer -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \h :: THandleSMP c 'TServer
h@THandle {THandleParams SMPVersion 'TServer
$sel:params:THandle :: forall v (c :: TransportPeer -> *) (p :: TransportPeer).
THandle v c p -> THandleParams v p
params :: THandleParams SMPVersion 'TServer
params} ->
    IO [Either TransportError ()] -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [Either TransportError ()] -> IO ())
-> (NonEmpty (Either TransportError SentRawTransmission)
    -> IO [Either TransportError ()])
-> NonEmpty (Either TransportError SentRawTransmission)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. THandleSMP c 'TServer
-> NonEmpty (Either TransportError SentRawTransmission)
-> IO [Either TransportError ()]
forall (c :: TransportPeer -> *) v (p :: TransportPeer).
Transport c =>
THandle v c p
-> NonEmpty (Either TransportError SentRawTransmission)
-> IO [Either TransportError ()]
tPut THandleSMP c 'TServer
h (NonEmpty (Either TransportError SentRawTransmission) -> IO ())
-> NonEmpty (Either TransportError SentRawTransmission) -> IO ()
forall a b. (a -> b) -> a -> b
$ (Transmission BrokerMsg
 -> Either TransportError SentRawTransmission)
-> NonEmpty (Transmission BrokerMsg)
-> NonEmpty (Either TransportError SentRawTransmission)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map (\Transmission BrokerMsg
t -> SentRawTransmission -> Either TransportError SentRawTransmission
forall a b. b -> Either a b
Right (Maybe TAuthorizations
forall a. Maybe a
Nothing, THandleParams SMPVersion 'TServer
-> Transmission BrokerMsg -> ByteString
forall v e c (p :: TransportPeer).
ProtocolEncoding v e c =>
THandleParams v p -> Transmission c -> ByteString
encodeTransmission THandleParams SMPVersion 'TServer
params Transmission BrokerMsg
t)) NonEmpty (Transmission BrokerMsg)
ts
  STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> (SystemTime -> STM ()) -> SystemTime -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TVar SystemTime -> SystemTime -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar SystemTime
sndActiveAt (SystemTime -> STM ()) -> SystemTime -> STM ()
forall a b. (a -> b) -> a -> b
$!) (SystemTime -> IO ()) -> IO SystemTime -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO SystemTime -> IO SystemTime
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO SystemTime
getSystemTime

disconnectTransport :: Transport c => THandle v c 'TServer -> TVar SystemTime -> TVar SystemTime -> ExpirationConfig -> IO Bool -> IO ()
disconnectTransport :: forall (c :: TransportPeer -> *) v.
Transport c =>
THandle v c 'TServer
-> TVar SystemTime
-> TVar SystemTime
-> ExpirationConfig
-> IO Bool
-> IO ()
disconnectTransport THandle {c 'TServer
connection :: c 'TServer
$sel:connection:THandle :: forall v (c :: TransportPeer -> *) (p :: TransportPeer).
THandle v c p -> c p
connection, $sel:params:THandle :: forall v (c :: TransportPeer -> *) (p :: TransportPeer).
THandle v c p -> THandleParams v p
params = THandleParams {ByteString
$sel:sessionId:THandleParams :: forall v (p :: TransportPeer). THandleParams v p -> ByteString
sessionId :: ByteString
sessionId}} TVar SystemTime
rcvActiveAt TVar SystemTime
sndActiveAt ExpirationConfig
expCfg IO Bool
noSubscriptions = do
  String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
labelMyThread (String -> IO ()) -> (ByteString -> String) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
B.unpack (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString
"client $" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
encode ByteString
sessionId ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" disconnectTransport"
  IO ()
loop
  where
    loop :: IO ()
loop = do
      Int64 -> IO ()
threadDelay' (Int64 -> IO ()) -> Int64 -> IO ()
forall a b. (a -> b) -> a -> b
$ ExpirationConfig -> Int64
checkInterval ExpirationConfig
expCfg Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
1000000
      IO Bool -> IO () -> IO () -> IO ()
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM IO Bool
noSubscriptions IO ()
checkExpired IO ()
loop
    checkExpired :: IO ()
checkExpired = do
      Int64
old <- ExpirationConfig -> IO Int64
expireBeforeEpoch ExpirationConfig
expCfg
      SystemTime
ts <- SystemTime -> SystemTime -> SystemTime
forall a. Ord a => a -> a -> a
max (SystemTime -> SystemTime -> SystemTime)
-> IO SystemTime -> IO (SystemTime -> SystemTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar SystemTime -> IO SystemTime
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar SystemTime
rcvActiveAt IO (SystemTime -> SystemTime) -> IO SystemTime -> IO SystemTime
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TVar SystemTime -> IO SystemTime
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar SystemTime
sndActiveAt
      if SystemTime -> Int64
systemSeconds SystemTime
ts Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int64
old then c 'TServer -> IO ()
forall (p :: TransportPeer). c p -> IO ()
forall (c :: TransportPeer -> *) (p :: TransportPeer).
Transport c =>
c p -> IO ()
closeConnection c 'TServer
connection else IO ()
loop

data VerificationResult s = VRVerified (Maybe (StoreQueue s, QueueRec)) | VRFailed ErrorType

-- This function verifies queue command authorization, with the objective to have constant time between the three AUTH error scenarios:
-- - the queue and party key exist, and the provided authorization has type matching queue key, but it is made with the different key.
-- - the queue and party key exist, but the provided authorization has incorrect type.
-- - the queue or party key do not exist.
-- In all cases, the time of the verification should depend only on the provided authorization type,
-- a dummy key is used to run verification in the last two cases, and failure is returned irrespective of the result.
verifyTransmission :: forall s. MsgStoreClass s => s -> Maybe THPeerClientService -> Maybe (THandleAuth 'TServer) -> SignedTransmission Cmd -> IO (VerificationResult s)
verifyTransmission :: forall s.
MsgStoreClass s =>
s
-> Maybe THPeerClientService
-> Maybe (THandleAuth 'TServer)
-> SignedTransmission Cmd
-> IO (VerificationResult s)
verifyTransmission s
ms Maybe THPeerClientService
service Maybe (THandleAuth 'TServer)
thAuth t :: SignedTransmission Cmd
t@(Maybe TAuthorizations
_, ByteString
_, (CorrId
_, RecipientId
queueId, Cmd SParty p
p Command p
_)) = case SParty p -> Maybe (Dict (PartyI p, QueueParty p))
forall (p :: Party).
SParty p -> Maybe (Dict (PartyI p, QueueParty p))
queueParty SParty p
p of
  Just Dict (PartyI p, QueueParty p)
Dict -> Maybe THPeerClientService
-> Maybe (THandleAuth 'TServer)
-> SignedTransmission Cmd
-> Either ErrorType (StoreQueue s, QueueRec)
-> VerificationResult s
forall s.
Maybe THPeerClientService
-> Maybe (THandleAuth 'TServer)
-> SignedTransmission Cmd
-> Either ErrorType (StoreQueue s, QueueRec)
-> VerificationResult s
verifyLoadedQueue Maybe THPeerClientService
service Maybe (THandleAuth 'TServer)
thAuth SignedTransmission Cmd
t (Either ErrorType (StoreQueue s, QueueRec) -> VerificationResult s)
-> IO (Either ErrorType (StoreQueue s, QueueRec))
-> IO (VerificationResult s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> s
-> SParty p
-> RecipientId
-> IO (Either ErrorType (StoreQueue s, QueueRec))
forall s (p :: Party).
(MsgStoreClass s, QueueParty p) =>
s
-> SParty p
-> RecipientId
-> IO (Either ErrorType (StoreQueue s, QueueRec))
getQueueRec s
ms SParty p
p RecipientId
queueId
  Maybe (Dict (PartyI p, QueueParty p))
Nothing -> VerificationResult s -> IO (VerificationResult s)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (VerificationResult s -> IO (VerificationResult s))
-> VerificationResult s -> IO (VerificationResult s)
forall a b. (a -> b) -> a -> b
$ Maybe THPeerClientService
-> Maybe (THandleAuth 'TServer)
-> SignedTransmission Cmd
-> Maybe (StoreQueue s, QueueRec)
-> VerificationResult s
forall s.
Maybe THPeerClientService
-> Maybe (THandleAuth 'TServer)
-> SignedTransmission Cmd
-> Maybe (StoreQueue s, QueueRec)
-> VerificationResult s
verifyQueueTransmission Maybe THPeerClientService
service Maybe (THandleAuth 'TServer)
thAuth SignedTransmission Cmd
t Maybe (StoreQueue s, QueueRec)
forall a. Maybe a
Nothing

verifyLoadedQueue :: Maybe THPeerClientService -> Maybe (THandleAuth 'TServer) -> SignedTransmission Cmd -> Either ErrorType (StoreQueue s, QueueRec) -> VerificationResult s
verifyLoadedQueue :: forall s.
Maybe THPeerClientService
-> Maybe (THandleAuth 'TServer)
-> SignedTransmission Cmd
-> Either ErrorType (StoreQueue s, QueueRec)
-> VerificationResult s
verifyLoadedQueue Maybe THPeerClientService
service Maybe (THandleAuth 'TServer)
thAuth t :: SignedTransmission Cmd
t@(Maybe TAuthorizations
tAuth, ByteString
authorized, (CorrId
corrId, RecipientId
_, Cmd
_)) = \case
  Right (StoreQueue s, QueueRec)
q -> Maybe THPeerClientService
-> Maybe (THandleAuth 'TServer)
-> SignedTransmission Cmd
-> Maybe (StoreQueue s, QueueRec)
-> VerificationResult s
forall s.
Maybe THPeerClientService
-> Maybe (THandleAuth 'TServer)
-> SignedTransmission Cmd
-> Maybe (StoreQueue s, QueueRec)
-> VerificationResult s
verifyQueueTransmission Maybe THPeerClientService
service Maybe (THandleAuth 'TServer)
thAuth SignedTransmission Cmd
t ((StoreQueue s, QueueRec) -> Maybe (StoreQueue s, QueueRec)
forall a. a -> Maybe a
Just (StoreQueue s, QueueRec)
q)
  Left ErrorType
AUTH -> Maybe (THandleAuth 'TServer)
-> Maybe TAuthorizations -> ByteString -> CorrId -> Bool
dummyVerifyCmd Maybe (THandleAuth 'TServer)
thAuth Maybe TAuthorizations
tAuth ByteString
authorized CorrId
corrId Bool -> VerificationResult s -> VerificationResult s
forall a b. a -> b -> b
`seq` ErrorType -> VerificationResult s
forall s. ErrorType -> VerificationResult s
VRFailed ErrorType
AUTH
  Left ErrorType
e -> ErrorType -> VerificationResult s
forall s. ErrorType -> VerificationResult s
VRFailed ErrorType
e

verifyQueueTransmission :: forall s. Maybe THPeerClientService -> Maybe (THandleAuth 'TServer) -> SignedTransmission Cmd -> Maybe (StoreQueue s, QueueRec) -> VerificationResult s
verifyQueueTransmission :: forall s.
Maybe THPeerClientService
-> Maybe (THandleAuth 'TServer)
-> SignedTransmission Cmd
-> Maybe (StoreQueue s, QueueRec)
-> VerificationResult s
verifyQueueTransmission Maybe THPeerClientService
service Maybe (THandleAuth 'TServer)
thAuth (Maybe TAuthorizations
tAuth, ByteString
authorized, (CorrId
corrId, RecipientId
entId, command :: Cmd
command@(Cmd SParty p
p Command p
cmd))) Maybe (StoreQueue s, QueueRec)
q_
  | Bool -> Bool
not Bool
checkRole = ErrorType -> VerificationResult s
forall s. ErrorType -> VerificationResult s
VRFailed (ErrorType -> VerificationResult s)
-> ErrorType -> VerificationResult s
forall a b. (a -> b) -> a -> b
$ CommandError -> ErrorType
CMD CommandError
PROHIBITED
  | Bool -> Bool
not Bool
verifyServiceSig = ErrorType -> VerificationResult s
forall s. ErrorType -> VerificationResult s
VRFailed ErrorType
SERVICE
  | Bool
otherwise = SParty p -> Command p -> VerificationResult s
forall (p :: Party). SParty p -> Command p -> VerificationResult s
vc SParty p
p Command p
cmd
  where
    vc :: SParty p -> Command p -> VerificationResult s -- this pattern match works with ghc8.10.7, flat case sees it as non-exhastive.
    vc :: forall (p :: Party). SParty p -> Command p -> VerificationResult s
vc SParty p
SCreator (NEW NewQueueReq {$sel:rcvAuthKey:NewQueueReq :: NewQueueReq -> RcvPublicAuthKey
rcvAuthKey = RcvPublicAuthKey
k}) = RcvPublicAuthKey -> VerificationResult s
verifiedWith RcvPublicAuthKey
k
    vc SParty p
SRecipient Command p
SUB = ((StoreQueue s, QueueRec) -> VerificationResult s)
-> VerificationResult s
verifyQueue (((StoreQueue s, QueueRec) -> VerificationResult s)
 -> VerificationResult s)
-> ((StoreQueue s, QueueRec) -> VerificationResult s)
-> VerificationResult s
forall a b. (a -> b) -> a -> b
$ \(StoreQueue s, QueueRec)
q -> NonEmpty RcvPublicAuthKey -> VerificationResult s
verifiedWithKeys (NonEmpty RcvPublicAuthKey -> VerificationResult s)
-> NonEmpty RcvPublicAuthKey -> VerificationResult s
forall a b. (a -> b) -> a -> b
$ QueueRec -> NonEmpty RcvPublicAuthKey
recipientKeys ((StoreQueue s, QueueRec) -> QueueRec
forall a b. (a, b) -> b
snd (StoreQueue s, QueueRec)
q)
    vc SParty p
SRecipient Command p
_ = ((StoreQueue s, QueueRec) -> VerificationResult s)
-> VerificationResult s
verifyQueue (((StoreQueue s, QueueRec) -> VerificationResult s)
 -> VerificationResult s)
-> ((StoreQueue s, QueueRec) -> VerificationResult s)
-> VerificationResult s
forall a b. (a -> b) -> a -> b
$ \(StoreQueue s, QueueRec)
q -> NonEmpty RcvPublicAuthKey -> VerificationResult s
verifiedWithKeys (NonEmpty RcvPublicAuthKey -> VerificationResult s)
-> NonEmpty RcvPublicAuthKey -> VerificationResult s
forall a b. (a -> b) -> a -> b
$ QueueRec -> NonEmpty RcvPublicAuthKey
recipientKeys ((StoreQueue s, QueueRec) -> QueueRec
forall a b. (a, b) -> b
snd (StoreQueue s, QueueRec)
q)
    vc SParty p
SRecipientService Command p
SUBS = VerificationResult s
verifyServiceCmd
    vc SParty p
SSender (SKEY RcvPublicAuthKey
k) = RcvPublicAuthKey -> VerificationResult s
verifySecure RcvPublicAuthKey
k
    -- SEND will be accepted without authorization before the queue is secured with KEY, SKEY or LSKEY command
    vc SParty p
SSender SEND {} = ((StoreQueue s, QueueRec) -> VerificationResult s)
-> VerificationResult s
verifyQueue (((StoreQueue s, QueueRec) -> VerificationResult s)
 -> VerificationResult s)
-> ((StoreQueue s, QueueRec) -> VerificationResult s)
-> VerificationResult s
forall a b. (a -> b) -> a -> b
$ \(StoreQueue s, QueueRec)
q -> if Bool
-> (RcvPublicAuthKey -> Bool) -> Maybe RcvPublicAuthKey -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe TAuthorizations -> Bool
forall a. Maybe a -> Bool
isNothing Maybe TAuthorizations
tAuth) RcvPublicAuthKey -> Bool
verify (QueueRec -> Maybe RcvPublicAuthKey
senderKey (QueueRec -> Maybe RcvPublicAuthKey)
-> QueueRec -> Maybe RcvPublicAuthKey
forall a b. (a -> b) -> a -> b
$ (StoreQueue s, QueueRec) -> QueueRec
forall a b. (a, b) -> b
snd (StoreQueue s, QueueRec)
q) then Maybe (StoreQueue s, QueueRec) -> VerificationResult s
forall s. Maybe (StoreQueue s, QueueRec) -> VerificationResult s
VRVerified Maybe (StoreQueue s, QueueRec)
q_ else ErrorType -> VerificationResult s
forall s. ErrorType -> VerificationResult s
VRFailed ErrorType
AUTH
    vc SParty p
SIdleClient Command p
PING = Maybe (StoreQueue s, QueueRec) -> VerificationResult s
forall s. Maybe (StoreQueue s, QueueRec) -> VerificationResult s
VRVerified Maybe (StoreQueue s, QueueRec)
forall a. Maybe a
Nothing
    vc SParty p
SSenderLink (LKEY RcvPublicAuthKey
k) = RcvPublicAuthKey -> VerificationResult s
verifySecure RcvPublicAuthKey
k
    vc SParty p
SSenderLink Command p
LGET = ((StoreQueue s, QueueRec) -> VerificationResult s)
-> VerificationResult s
verifyQueue (((StoreQueue s, QueueRec) -> VerificationResult s)
 -> VerificationResult s)
-> ((StoreQueue s, QueueRec) -> VerificationResult s)
-> VerificationResult s
forall a b. (a -> b) -> a -> b
$ \(StoreQueue s, QueueRec)
q -> if QueueRec -> Bool
isContactQueue ((StoreQueue s, QueueRec) -> QueueRec
forall a b. (a, b) -> b
snd (StoreQueue s, QueueRec)
q) then Maybe (StoreQueue s, QueueRec) -> VerificationResult s
forall s. Maybe (StoreQueue s, QueueRec) -> VerificationResult s
VRVerified Maybe (StoreQueue s, QueueRec)
q_ else ErrorType -> VerificationResult s
forall s. ErrorType -> VerificationResult s
VRFailed ErrorType
AUTH
    vc SParty p
SNotifier Command p
NSUB = ((StoreQueue s, QueueRec) -> VerificationResult s)
-> VerificationResult s
verifyQueue (((StoreQueue s, QueueRec) -> VerificationResult s)
 -> VerificationResult s)
-> ((StoreQueue s, QueueRec) -> VerificationResult s)
-> VerificationResult s
forall a b. (a -> b) -> a -> b
$ \(StoreQueue s, QueueRec)
q -> VerificationResult s
-> (NtfCreds -> VerificationResult s)
-> Maybe NtfCreds
-> VerificationResult s
forall b a. b -> (a -> b) -> Maybe a -> b
maybe VerificationResult s
dummyVerify (\NtfCreds
n -> RcvPublicAuthKey -> VerificationResult s
verifiedWith (RcvPublicAuthKey -> VerificationResult s)
-> RcvPublicAuthKey -> VerificationResult s
forall a b. (a -> b) -> a -> b
$ NtfCreds -> RcvPublicAuthKey
notifierKey NtfCreds
n) (QueueRec -> Maybe NtfCreds
notifier (QueueRec -> Maybe NtfCreds) -> QueueRec -> Maybe NtfCreds
forall a b. (a -> b) -> a -> b
$ (StoreQueue s, QueueRec) -> QueueRec
forall a b. (a, b) -> b
snd (StoreQueue s, QueueRec)
q)
    vc SParty p
SNotifierService Command p
NSUBS = VerificationResult s
verifyServiceCmd
    vc SParty p
SProxiedClient Command p
_ = Maybe (StoreQueue s, QueueRec) -> VerificationResult s
forall s. Maybe (StoreQueue s, QueueRec) -> VerificationResult s
VRVerified Maybe (StoreQueue s, QueueRec)
forall a. Maybe a
Nothing
    vc SParty p
SProxyService (RFWD EncFwdTransmission
_) = Maybe (StoreQueue s, QueueRec) -> VerificationResult s
forall s. Maybe (StoreQueue s, QueueRec) -> VerificationResult s
VRVerified Maybe (StoreQueue s, QueueRec)
forall a. Maybe a
Nothing
    checkRole :: Bool
checkRole = case (Maybe THPeerClientService
service, SParty p -> Maybe SMPServiceRole
forall (p :: Party). SParty p -> Maybe SMPServiceRole
partyClientRole SParty p
p) of
      (Just THClientService {SMPServiceRole
$sel:serviceRole:THClientService :: forall k. THClientService' k -> SMPServiceRole
serviceRole :: SMPServiceRole
serviceRole}, Just SMPServiceRole
role) -> SMPServiceRole
serviceRole SMPServiceRole -> SMPServiceRole -> Bool
forall a. Eq a => a -> a -> Bool
== SMPServiceRole
role
      (Maybe THPeerClientService, Maybe SMPServiceRole)
_ -> Bool
True
    verify :: RcvPublicAuthKey -> Bool
verify = Maybe (THandleAuth 'TServer)
-> Maybe TAuthorizations
-> ByteString
-> CorrId
-> RcvPublicAuthKey
-> Bool
verifyCmdAuthorization Maybe (THandleAuth 'TServer)
thAuth Maybe TAuthorizations
tAuth ByteString
authorized' CorrId
corrId
    verifyServiceCmd :: VerificationResult s
    verifyServiceCmd :: VerificationResult s
verifyServiceCmd = case (Maybe THPeerClientService
service, Maybe TAuthorizations
tAuth) of
      (Just THClientService {RecipientId
$sel:serviceId:THClientService :: forall k. THClientService' k -> RecipientId
serviceId :: RecipientId
serviceId, $sel:serviceKey:THClientService :: forall k. THClientService' k -> k
serviceKey = PublicKey 'Ed25519
k}, Just (TASignature (C.ASignature SAlgorithm a
C.SEd25519 Signature a
s), Maybe (Signature 'Ed25519)
Nothing))
        | RecipientId
entId RecipientId -> RecipientId -> Bool
forall a. Eq a => a -> a -> Bool
== RecipientId
serviceId Bool -> Bool -> Bool
&& PublicKey 'Ed25519 -> Signature 'Ed25519 -> ByteString -> Bool
forall (a :: Algorithm).
SignatureAlgorithm a =>
PublicKey a -> Signature a -> ByteString -> Bool
C.verify' PublicKey 'Ed25519
k Signature a
Signature 'Ed25519
s ByteString
authorized -> Maybe (StoreQueue s, QueueRec) -> VerificationResult s
forall s. Maybe (StoreQueue s, QueueRec) -> VerificationResult s
VRVerified Maybe (StoreQueue s, QueueRec)
forall a. Maybe a
Nothing
      (Maybe THPeerClientService, Maybe TAuthorizations)
_ -> ErrorType -> VerificationResult s
forall s. ErrorType -> VerificationResult s
VRFailed ErrorType
SERVICE
    -- this function verify service signature for commands that use it in service sessions
    verifyServiceSig :: Bool
verifyServiceSig
      | ProtoCommand BrokerMsg -> Bool
forall v err msg. Protocol v err msg => ProtoCommand msg -> Bool
useServiceAuth ProtoCommand BrokerMsg
Cmd
command = case (Maybe THPeerClientService
service, Maybe (Signature 'Ed25519)
serviceSig) of
          (Just THClientService {$sel:serviceKey:THClientService :: forall k. THClientService' k -> k
serviceKey = PublicKey 'Ed25519
k}, Just Signature 'Ed25519
s) -> PublicKey 'Ed25519 -> Signature 'Ed25519 -> ByteString -> Bool
forall (a :: Algorithm).
SignatureAlgorithm a =>
PublicKey a -> Signature a -> ByteString -> Bool
C.verify' PublicKey 'Ed25519
k Signature 'Ed25519
s ByteString
authorized
          (Maybe THPeerClientService
Nothing, Maybe (Signature 'Ed25519)
Nothing) -> Bool
True
          (Maybe THPeerClientService, Maybe (Signature 'Ed25519))
_ -> Bool
False
      | Bool
otherwise = Maybe (Signature 'Ed25519) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (Signature 'Ed25519)
serviceSig
    serviceSig :: Maybe (Signature 'Ed25519)
serviceSig = TAuthorizations -> Maybe (Signature 'Ed25519)
forall a b. (a, b) -> b
snd (TAuthorizations -> Maybe (Signature 'Ed25519))
-> Maybe TAuthorizations -> Maybe (Signature 'Ed25519)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe TAuthorizations
tAuth
    authorized' :: ByteString
authorized' = case (Maybe THPeerClientService
service, Maybe (Signature 'Ed25519)
serviceSig) of
      (Just THClientService {$sel:serviceCertHash:THClientService :: forall k. THClientService' k -> Fingerprint
serviceCertHash = XV.Fingerprint ByteString
fp}, Just Signature 'Ed25519
_) -> ByteString
fp ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
authorized
      (Maybe THPeerClientService, Maybe (Signature 'Ed25519))
_ -> ByteString
authorized
    dummyVerify :: VerificationResult s
    dummyVerify :: VerificationResult s
dummyVerify = Maybe (THandleAuth 'TServer)
-> Maybe TAuthorizations -> ByteString -> CorrId -> Bool
dummyVerifyCmd Maybe (THandleAuth 'TServer)
thAuth Maybe TAuthorizations
tAuth ByteString
authorized CorrId
corrId Bool -> VerificationResult s -> VerificationResult s
forall a b. a -> b -> b
`seq` ErrorType -> VerificationResult s
forall s. ErrorType -> VerificationResult s
VRFailed ErrorType
AUTH
    -- That a specific command requires queue signature verification is determined by `queueParty`,
    -- it should be coordinated with the case in this function (`verifyQueueTransmission`)
    verifyQueue :: ((StoreQueue s, QueueRec) -> VerificationResult s) -> VerificationResult s
    verifyQueue :: ((StoreQueue s, QueueRec) -> VerificationResult s)
-> VerificationResult s
verifyQueue (StoreQueue s, QueueRec) -> VerificationResult s
v = VerificationResult s
-> ((StoreQueue s, QueueRec) -> VerificationResult s)
-> Maybe (StoreQueue s, QueueRec)
-> VerificationResult s
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ErrorType -> VerificationResult s
forall s. ErrorType -> VerificationResult s
VRFailed ErrorType
INTERNAL) (StoreQueue s, QueueRec) -> VerificationResult s
v Maybe (StoreQueue s, QueueRec)
q_
    verifySecure :: SndPublicAuthKey -> VerificationResult s
    verifySecure :: RcvPublicAuthKey -> VerificationResult s
verifySecure RcvPublicAuthKey
k = ((StoreQueue s, QueueRec) -> VerificationResult s)
-> VerificationResult s
verifyQueue (((StoreQueue s, QueueRec) -> VerificationResult s)
 -> VerificationResult s)
-> ((StoreQueue s, QueueRec) -> VerificationResult s)
-> VerificationResult s
forall a b. (a -> b) -> a -> b
$ \(StoreQueue s, QueueRec)
q -> if RcvPublicAuthKey
k RcvPublicAuthKey -> QueueRec -> Bool
`allowedKey` (StoreQueue s, QueueRec) -> QueueRec
forall a b. (a, b) -> b
snd (StoreQueue s, QueueRec)
q then RcvPublicAuthKey -> VerificationResult s
verifiedWith RcvPublicAuthKey
k else VerificationResult s
dummyVerify
    verifiedWith :: C.APublicAuthKey -> VerificationResult s
    verifiedWith :: RcvPublicAuthKey -> VerificationResult s
verifiedWith RcvPublicAuthKey
k = if RcvPublicAuthKey -> Bool
verify RcvPublicAuthKey
k then Maybe (StoreQueue s, QueueRec) -> VerificationResult s
forall s. Maybe (StoreQueue s, QueueRec) -> VerificationResult s
VRVerified Maybe (StoreQueue s, QueueRec)
q_ else ErrorType -> VerificationResult s
forall s. ErrorType -> VerificationResult s
VRFailed ErrorType
AUTH
    verifiedWithKeys :: NonEmpty C.APublicAuthKey -> VerificationResult s
    verifiedWithKeys :: NonEmpty RcvPublicAuthKey -> VerificationResult s
verifiedWithKeys NonEmpty RcvPublicAuthKey
ks = if (RcvPublicAuthKey -> Bool) -> NonEmpty RcvPublicAuthKey -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any RcvPublicAuthKey -> Bool
verify NonEmpty RcvPublicAuthKey
ks then Maybe (StoreQueue s, QueueRec) -> VerificationResult s
forall s. Maybe (StoreQueue s, QueueRec) -> VerificationResult s
VRVerified Maybe (StoreQueue s, QueueRec)
q_ else ErrorType -> VerificationResult s
forall s. ErrorType -> VerificationResult s
VRFailed ErrorType
AUTH
    allowedKey :: RcvPublicAuthKey -> QueueRec -> Bool
allowedKey RcvPublicAuthKey
k = \case
      QueueRec {$sel:queueMode:QueueRec :: QueueRec -> Maybe QueueMode
queueMode = Just QueueMode
QMMessaging, Maybe RcvPublicAuthKey
$sel:senderKey:QueueRec :: QueueRec -> Maybe RcvPublicAuthKey
senderKey :: Maybe RcvPublicAuthKey
senderKey} -> Bool
-> (RcvPublicAuthKey -> Bool) -> Maybe RcvPublicAuthKey -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (RcvPublicAuthKey
k RcvPublicAuthKey -> RcvPublicAuthKey -> Bool
forall a. Eq a => a -> a -> Bool
==) Maybe RcvPublicAuthKey
senderKey
      QueueRec
_ -> Bool
False

isContactQueue :: QueueRec -> Bool
isContactQueue :: QueueRec -> Bool
isContactQueue QueueRec {Maybe QueueMode
$sel:queueMode:QueueRec :: QueueRec -> Maybe QueueMode
queueMode :: Maybe QueueMode
queueMode, Maybe RcvPublicAuthKey
$sel:senderKey:QueueRec :: QueueRec -> Maybe RcvPublicAuthKey
senderKey :: Maybe RcvPublicAuthKey
senderKey} = case Maybe QueueMode
queueMode of
  Just QueueMode
QMMessaging -> Bool
False
  Just QueueMode
QMContact -> Bool
True
  Maybe QueueMode
Nothing -> Maybe RcvPublicAuthKey -> Bool
forall a. Maybe a -> Bool
isNothing Maybe RcvPublicAuthKey
senderKey -- for backward compatibility with pre-SKEY contact addresses

isSecuredMsgQueue :: QueueRec -> Bool
isSecuredMsgQueue :: QueueRec -> Bool
isSecuredMsgQueue QueueRec {Maybe QueueMode
$sel:queueMode:QueueRec :: QueueRec -> Maybe QueueMode
queueMode :: Maybe QueueMode
queueMode, Maybe RcvPublicAuthKey
$sel:senderKey:QueueRec :: QueueRec -> Maybe RcvPublicAuthKey
senderKey :: Maybe RcvPublicAuthKey
senderKey} = case Maybe QueueMode
queueMode of
  Just QueueMode
QMContact -> Bool
False
  Maybe QueueMode
_ -> Maybe RcvPublicAuthKey -> Bool
forall a. Maybe a -> Bool
isJust Maybe RcvPublicAuthKey
senderKey

-- Random correlation ID is used as a nonce in case crypto_box authenticator is used to authorize transmission
verifyCmdAuthorization :: Maybe (THandleAuth 'TServer) -> Maybe TAuthorizations -> ByteString -> CorrId -> C.APublicAuthKey -> Bool
verifyCmdAuthorization :: Maybe (THandleAuth 'TServer)
-> Maybe TAuthorizations
-> ByteString
-> CorrId
-> RcvPublicAuthKey
-> Bool
verifyCmdAuthorization Maybe (THandleAuth 'TServer)
thAuth Maybe TAuthorizations
tAuth ByteString
authorized CorrId
corrId RcvPublicAuthKey
key = Bool -> (TAuthorizations -> Bool) -> Maybe TAuthorizations -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (RcvPublicAuthKey -> TAuthorizations -> Bool
verify RcvPublicAuthKey
key) Maybe TAuthorizations
tAuth
  where
    verify :: C.APublicAuthKey -> TAuthorizations -> Bool
    verify :: RcvPublicAuthKey -> TAuthorizations -> Bool
verify (C.APublicAuthKey SAlgorithm a
a PublicKey a
k) = \case
      (TASignature (C.ASignature SAlgorithm a
a' Signature a
s), Maybe (Signature 'Ed25519)
_) -> case SAlgorithm a -> SAlgorithm a -> Maybe (a :~: a)
forall {k} (f :: k -> *) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
forall (a :: Algorithm) (b :: Algorithm).
SAlgorithm a -> SAlgorithm b -> Maybe (a :~: b)
testEquality SAlgorithm a
a SAlgorithm a
a' of
        Just a :~: a
Refl -> PublicKey a -> Signature a -> ByteString -> Bool
forall (a :: Algorithm).
SignatureAlgorithm a =>
PublicKey a -> Signature a -> ByteString -> Bool
C.verify' PublicKey a
k Signature a
Signature a
s ByteString
authorized
        Maybe (a :~: a)
_ -> PublicKey a -> Signature a -> ByteString -> Bool
forall (a :: Algorithm).
SignatureAlgorithm a =>
PublicKey a -> Signature a -> ByteString -> Bool
C.verify' (SAlgorithm a -> PublicKey a
forall (a :: Algorithm).
SignatureAlgorithm a =>
SAlgorithm a -> PublicKey a
dummySignKey SAlgorithm a
a') Signature a
s ByteString
authorized Bool -> Bool -> Bool
forall a b. a -> b -> b
`seq` Bool
False
      (TAAuthenticator CbAuthenticator
s, Maybe (Signature 'Ed25519)
_) -> case SAlgorithm a
a of
        SAlgorithm a
C.SX25519 -> Maybe (THandleAuth 'TServer)
-> PublicKey 'X25519
-> CbAuthenticator
-> ByteString
-> CorrId
-> Bool
verifyCmdAuth Maybe (THandleAuth 'TServer)
thAuth PublicKey a
PublicKey 'X25519
k CbAuthenticator
s ByteString
authorized CorrId
corrId
        SAlgorithm a
_ -> Maybe (THandleAuth 'TServer)
-> PublicKey 'X25519
-> CbAuthenticator
-> ByteString
-> CorrId
-> Bool
verifyCmdAuth Maybe (THandleAuth 'TServer)
thAuth PublicKey 'X25519
dummyKeyX25519 CbAuthenticator
s ByteString
authorized CorrId
corrId Bool -> Bool -> Bool
forall a b. a -> b -> b
`seq` Bool
False

verifyCmdAuth :: Maybe (THandleAuth 'TServer) -> C.PublicKeyX25519 -> C.CbAuthenticator -> ByteString -> CorrId -> Bool
verifyCmdAuth :: Maybe (THandleAuth 'TServer)
-> PublicKey 'X25519
-> CbAuthenticator
-> ByteString
-> CorrId
-> Bool
verifyCmdAuth Maybe (THandleAuth 'TServer)
thAuth PublicKey 'X25519
k CbAuthenticator
authenticator ByteString
authorized (CorrId ByteString
corrId) = case Maybe (THandleAuth 'TServer)
thAuth of
  Just THAuthServer {$sel:serverPrivKey:THAuthClient :: THandleAuth 'TServer -> PrivateKey 'X25519
serverPrivKey = PrivateKey 'X25519
pk} -> PublicKey 'X25519
-> PrivateKey 'X25519
-> CbNonce
-> CbAuthenticator
-> ByteString
-> Bool
C.cbVerify PublicKey 'X25519
k PrivateKey 'X25519
pk (ByteString -> CbNonce
C.cbNonce ByteString
corrId) CbAuthenticator
authenticator ByteString
authorized
  Maybe (THandleAuth 'TServer)
Nothing -> Bool
False

dummyVerifyCmd :: Maybe (THandleAuth 'TServer) -> Maybe TAuthorizations -> ByteString -> CorrId -> Bool
dummyVerifyCmd :: Maybe (THandleAuth 'TServer)
-> Maybe TAuthorizations -> ByteString -> CorrId -> Bool
dummyVerifyCmd Maybe (THandleAuth 'TServer)
thAuth Maybe TAuthorizations
tAuth ByteString
authorized CorrId
corrId = Bool -> (TAuthorizations -> Bool) -> Maybe TAuthorizations -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False TAuthorizations -> Bool
verify Maybe TAuthorizations
tAuth
  where
    verify :: TAuthorizations -> Bool
verify = \case
      (TASignature (C.ASignature SAlgorithm a
a Signature a
s), Maybe (Signature 'Ed25519)
_) -> PublicKey a -> Signature a -> ByteString -> Bool
forall (a :: Algorithm).
SignatureAlgorithm a =>
PublicKey a -> Signature a -> ByteString -> Bool
C.verify' (SAlgorithm a -> PublicKey a
forall (a :: Algorithm).
SignatureAlgorithm a =>
SAlgorithm a -> PublicKey a
dummySignKey SAlgorithm a
a) Signature a
s ByteString
authorized
      (TAAuthenticator CbAuthenticator
s, Maybe (Signature 'Ed25519)
_) -> Maybe (THandleAuth 'TServer)
-> PublicKey 'X25519
-> CbAuthenticator
-> ByteString
-> CorrId
-> Bool
verifyCmdAuth Maybe (THandleAuth 'TServer)
thAuth PublicKey 'X25519
dummyKeyX25519 CbAuthenticator
s ByteString
authorized CorrId
corrId

-- These dummy keys are used with `dummyVerify` function to mitigate timing attacks
-- by having the same time of the response whether a queue exists or nor, for all valid key/signature sizes
dummySignKey :: C.SignatureAlgorithm a => C.SAlgorithm a -> C.PublicKey a
dummySignKey :: forall (a :: Algorithm).
SignatureAlgorithm a =>
SAlgorithm a -> PublicKey a
dummySignKey = \case
  SAlgorithm a
C.SEd25519 -> PublicKey a
PublicKey 'Ed25519
dummyKeyEd25519
  SAlgorithm a
C.SEd448 -> PublicKey a
PublicKey 'Ed448
dummyKeyEd448

dummyKeyEd25519 :: C.PublicKey 'C.Ed25519
dummyKeyEd25519 :: PublicKey 'Ed25519
dummyKeyEd25519 = PublicKey 'Ed25519
"MCowBQYDK2VwAyEA139Oqs4QgpqbAmB0o7rZf6T19ryl7E65k4AYe0kE3Qs="

dummyKeyEd448 :: C.PublicKey 'C.Ed448
dummyKeyEd448 :: PublicKey 'Ed448
dummyKeyEd448 = PublicKey 'Ed448
"MEMwBQYDK2VxAzoA6ibQc9XpkSLtwrf7PLvp81qW/etiumckVFImCMRdftcG/XopbOSaq9qyLhrgJWKOLyNrQPNVvpMA"

dummyKeyX25519 :: C.PublicKey 'C.X25519
dummyKeyX25519 :: PublicKey 'X25519
dummyKeyX25519 = PublicKey 'X25519
"MCowBQYDK2VuAyEA4JGSMYht18H4mas/jHeBwfcM7jLwNYJNOAhi2/g4RXg="

forkClient :: MonadUnliftIO m => Client s -> String -> m () -> m ()
forkClient :: forall (m :: * -> *) s.
MonadUnliftIO m =>
Client s -> String -> m () -> m ()
forkClient Client {TVar (IntMap (Weak ThreadId))
$sel:endThreads:Client :: forall s. Client s -> TVar (IntMap (Weak ThreadId))
endThreads :: TVar (IntMap (Weak ThreadId))
endThreads, TVar Int
endThreadSeq :: TVar Int
$sel:endThreadSeq:Client :: forall s. Client s -> TVar Int
endThreadSeq} String
label m ()
action = do
  Int
tId <- STM Int -> m Int
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Int -> m Int) -> STM Int -> m Int
forall a b. (a -> b) -> a -> b
$ TVar Int -> (Int -> (Int, Int)) -> STM Int
forall s a. TVar s -> (s -> (a, s)) -> STM a
stateTVar TVar Int
endThreadSeq ((Int -> (Int, Int)) -> STM Int) -> (Int -> (Int, Int)) -> STM Int
forall a b. (a -> b) -> a -> b
$ \Int
next -> (Int
next, Int
next Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  ThreadId
t <- m () -> m ThreadId
forall (m :: * -> *). MonadUnliftIO m => m () -> m ThreadId
forkIO (m () -> m ThreadId) -> m () -> m ThreadId
forall a b. (a -> b) -> a -> b
$ do
    String -> m ()
forall (m :: * -> *). MonadIO m => String -> m ()
labelMyThread String
label
    m ()
action m () -> m () -> m ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`finally` STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TVar (IntMap (Weak ThreadId))
-> (IntMap (Weak ThreadId) -> IntMap (Weak ThreadId)) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (IntMap (Weak ThreadId))
endThreads ((IntMap (Weak ThreadId) -> IntMap (Weak ThreadId)) -> STM ())
-> (IntMap (Weak ThreadId) -> IntMap (Weak ThreadId)) -> STM ()
forall a b. (a -> b) -> a -> b
$ Int -> IntMap (Weak ThreadId) -> IntMap (Weak ThreadId)
forall a. Int -> IntMap a -> IntMap a
IM.delete Int
tId)
  ThreadId -> m (Weak ThreadId)
forall (m :: * -> *). MonadIO m => ThreadId -> m (Weak ThreadId)
mkWeakThreadId ThreadId
t m (Weak ThreadId) -> (Weak ThreadId -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ())
-> (Weak ThreadId -> STM ()) -> Weak ThreadId -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar (IntMap (Weak ThreadId))
-> (IntMap (Weak ThreadId) -> IntMap (Weak ThreadId)) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (IntMap (Weak ThreadId))
endThreads ((IntMap (Weak ThreadId) -> IntMap (Weak ThreadId)) -> STM ())
-> (Weak ThreadId
    -> IntMap (Weak ThreadId) -> IntMap (Weak ThreadId))
-> Weak ThreadId
-> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int
-> Weak ThreadId
-> IntMap (Weak ThreadId)
-> IntMap (Weak ThreadId)
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
tId

client :: forall s. MsgStoreClass s => Server s -> s -> Client s -> M s ()
client :: forall s. MsgStoreClass s => Server s -> s -> Client s -> M s ()
client
  -- TODO [certs rcv] rcv subscriptions
  Server {ServerSubscribers s
$sel:subscribers:Server :: forall s. Server s -> ServerSubscribers s
subscribers :: ServerSubscribers s
subscribers, ServerSubscribers s
$sel:ntfSubscribers:Server :: forall s. Server s -> ServerSubscribers s
ntfSubscribers :: ServerSubscribers s
ntfSubscribers}
  s
ms
  clnt :: Client s
clnt@Client {Int
$sel:clientId:Client :: forall s. Client s -> Int
clientId :: Int
clientId, TMap RecipientId ()
$sel:ntfSubscriptions:Client :: forall s. Client s -> TMap RecipientId ()
ntfSubscriptions :: TMap RecipientId ()
ntfSubscriptions, TVar Bool
ntfServiceSubscribed :: TVar Bool
$sel:ntfServiceSubscribed:Client :: forall s. Client s -> TVar Bool
ntfServiceSubscribed, $sel:serviceSubsCount:Client :: forall s. Client s -> TVar Int64
serviceSubsCount = TVar Int64
_todo', TVar Int64
$sel:ntfServiceSubsCount:Client :: forall s. Client s -> TVar Int64
ntfServiceSubsCount :: TVar Int64
ntfServiceSubsCount, TBQueue (NonEmpty (VerifiedTransmission s))
$sel:rcvQ:Client :: forall s. Client s -> TBQueue (NonEmpty (VerifiedTransmission s))
rcvQ :: TBQueue (NonEmpty (VerifiedTransmission s))
rcvQ, TBQueue
  (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
$sel:sndQ:Client :: forall s.
Client s
-> TBQueue
     (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
sndQ :: TBQueue
  (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
sndQ, $sel:clientTHParams:Client :: forall s. Client s -> THandleParams SMPVersion 'TServer
clientTHParams = thParams' :: THandleParams SMPVersion 'TServer
thParams'@THandleParams {ByteString
$sel:sessionId:THandleParams :: forall v (p :: TransportPeer). THandleParams v p -> ByteString
sessionId :: ByteString
sessionId}, TVar Int
procThreads :: TVar Int
$sel:procThreads:Client :: forall s. Client s -> TVar Int
procThreads} = do
    String -> M s ()
forall (m :: * -> *). MonadIO m => String -> m ()
labelMyThread (String -> M s ())
-> (ByteString -> String) -> ByteString -> M s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
B.unpack (ByteString -> M s ()) -> ByteString -> M s ()
forall a b. (a -> b) -> a -> b
$ ByteString
"client $" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
encode ByteString
sessionId ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" commands"
    let THandleParams {Version SMPVersion
thVersion :: Version SMPVersion
$sel:thVersion:THandleParams :: forall v (p :: TransportPeer). THandleParams v p -> Version v
thVersion} = THandleParams SMPVersion 'TServer
thParams'
        clntServiceId :: Maybe RecipientId
clntServiceId = (\THClientService {RecipientId
$sel:serviceId:THClientService :: forall k. THClientService' k -> RecipientId
serviceId :: RecipientId
serviceId} -> RecipientId
serviceId) (THPeerClientService -> RecipientId)
-> Maybe THPeerClientService -> Maybe RecipientId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (THandleAuth 'TServer -> Maybe THPeerClientService
peerClientService (THandleAuth 'TServer -> Maybe THPeerClientService)
-> Maybe (THandleAuth 'TServer) -> Maybe THPeerClientService
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< THandleParams SMPVersion 'TServer -> Maybe (THandleAuth 'TServer)
forall v (p :: TransportPeer).
THandleParams v p -> Maybe (THandleAuth p)
thAuth THandleParams SMPVersion 'TServer
thParams')
        process :: VerifiedTransmission s
-> ([Transmission BrokerMsg], [Transmission BrokerMsg])
-> ReaderT
     (Env s) IO ([Transmission BrokerMsg], [Transmission BrokerMsg])
process VerifiedTransmission s
t acc :: ([Transmission BrokerMsg], [Transmission BrokerMsg])
acc@([Transmission BrokerMsg]
rs, [Transmission BrokerMsg]
msgs) =
          (([Transmission BrokerMsg], [Transmission BrokerMsg])
-> ((Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
    -> ([Transmission BrokerMsg], [Transmission BrokerMsg]))
-> Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
-> ([Transmission BrokerMsg], [Transmission BrokerMsg])
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Transmission BrokerMsg], [Transmission BrokerMsg])
acc (\(!Transmission BrokerMsg
r, !Maybe (Transmission BrokerMsg)
msg_) -> (Transmission BrokerMsg
r Transmission BrokerMsg
-> [Transmission BrokerMsg] -> [Transmission BrokerMsg]
forall a. a -> [a] -> [a]
: [Transmission BrokerMsg]
rs, [Transmission BrokerMsg]
-> (Transmission BrokerMsg -> [Transmission BrokerMsg])
-> Maybe (Transmission BrokerMsg)
-> [Transmission BrokerMsg]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Transmission BrokerMsg]
msgs (Transmission BrokerMsg
-> [Transmission BrokerMsg] -> [Transmission BrokerMsg]
forall a. a -> [a] -> [a]
: [Transmission BrokerMsg]
msgs) Maybe (Transmission BrokerMsg)
msg_)))
            (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
 -> ([Transmission BrokerMsg], [Transmission BrokerMsg]))
-> ReaderT
     (Env s)
     IO
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
-> ReaderT
     (Env s) IO ([Transmission BrokerMsg], [Transmission BrokerMsg])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe RecipientId
-> Version SMPVersion
-> VerifiedTransmission s
-> ReaderT
     (Env s)
     IO
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
processCommand Maybe RecipientId
clntServiceId Version SMPVersion
thVersion VerifiedTransmission s
t
    M s () -> M s ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (M s () -> M s ()) -> M s () -> M s ()
forall a b. (a -> b) -> a -> b
$
      STM (NonEmpty (VerifiedTransmission s))
-> ReaderT (Env s) IO (NonEmpty (VerifiedTransmission s))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TBQueue (NonEmpty (VerifiedTransmission s))
-> STM (NonEmpty (VerifiedTransmission s))
forall a. TBQueue a -> STM a
readTBQueue TBQueue (NonEmpty (VerifiedTransmission s))
rcvQ)
        ReaderT (Env s) IO (NonEmpty (VerifiedTransmission s))
-> (NonEmpty (VerifiedTransmission s)
    -> ReaderT
         (Env s) IO ([Transmission BrokerMsg], [Transmission BrokerMsg]))
-> ReaderT
     (Env s) IO ([Transmission BrokerMsg], [Transmission BrokerMsg])
forall a b.
ReaderT (Env s) IO a
-> (a -> ReaderT (Env s) IO b) -> ReaderT (Env s) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (VerifiedTransmission s
 -> ([Transmission BrokerMsg], [Transmission BrokerMsg])
 -> ReaderT
      (Env s) IO ([Transmission BrokerMsg], [Transmission BrokerMsg]))
-> ([Transmission BrokerMsg], [Transmission BrokerMsg])
-> NonEmpty (VerifiedTransmission s)
-> ReaderT
     (Env s) IO ([Transmission BrokerMsg], [Transmission BrokerMsg])
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM VerifiedTransmission s
-> ([Transmission BrokerMsg], [Transmission BrokerMsg])
-> ReaderT
     (Env s) IO ([Transmission BrokerMsg], [Transmission BrokerMsg])
process ([], [])
        ReaderT
  (Env s) IO ([Transmission BrokerMsg], [Transmission BrokerMsg])
-> (([Transmission BrokerMsg], [Transmission BrokerMsg]) -> M s ())
-> M s ()
forall a b.
ReaderT (Env s) IO a
-> (a -> ReaderT (Env s) IO b) -> ReaderT (Env s) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \([Transmission BrokerMsg]
rs_, [Transmission BrokerMsg]
msgs) -> (NonEmpty (Transmission BrokerMsg) -> M s ())
-> Maybe (NonEmpty (Transmission BrokerMsg)) -> M s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (STM () -> M s ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> M s ())
-> (NonEmpty (Transmission BrokerMsg) -> STM ())
-> NonEmpty (Transmission BrokerMsg)
-> M s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TBQueue
  (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
-> (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
-> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue
  (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
sndQ ((NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
 -> STM ())
-> (NonEmpty (Transmission BrokerMsg)
    -> (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg]))
-> NonEmpty (Transmission BrokerMsg)
-> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,[Transmission BrokerMsg]
msgs)) ([Transmission BrokerMsg]
-> Maybe (NonEmpty (Transmission BrokerMsg))
forall a. [a] -> Maybe (NonEmpty a)
L.nonEmpty [Transmission BrokerMsg]
rs_)
  where
    processProxiedCmd :: Transmission (Command 'ProxiedClient) -> M s (Maybe ResponseAndMessage)
    processProxiedCmd :: Transmission (Command 'ProxiedClient)
-> ReaderT
     (Env s)
     IO
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
processProxiedCmd (CorrId
corrId, EntityId ByteString
sessId, Command 'ProxiedClient
command) = (\BrokerMsg
t -> ((CorrId
corrId, ByteString -> RecipientId
EntityId ByteString
sessId, BrokerMsg
t), Maybe (Transmission BrokerMsg)
forall a. Maybe a
Nothing)) (BrokerMsg
 -> (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
-> ReaderT (Env s) IO (Maybe BrokerMsg)
-> ReaderT
     (Env s)
     IO
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
forall (f :: * -> *) (g :: * -> *) a b.
(Functor f, Functor g) =>
(a -> b) -> f (g a) -> f (g b)
<$$> case Command 'ProxiedClient
command of
      PRXY SMPServer
srv Maybe BasicAuth
auth -> ReaderT (Env s) IO Bool
-> ReaderT (Env s) IO (Maybe BrokerMsg)
-> ReaderT (Env s) IO (Maybe BrokerMsg)
-> ReaderT (Env s) IO (Maybe BrokerMsg)
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM ReaderT (Env s) IO Bool
allowProxy ReaderT (Env s) IO (Maybe BrokerMsg)
getRelay (Maybe BrokerMsg -> ReaderT (Env s) IO (Maybe BrokerMsg)
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe BrokerMsg -> ReaderT (Env s) IO (Maybe BrokerMsg))
-> Maybe BrokerMsg -> ReaderT (Env s) IO (Maybe BrokerMsg)
forall a b. (a -> b) -> a -> b
$ BrokerMsg -> Maybe BrokerMsg
forall a. a -> Maybe a
Just (BrokerMsg -> Maybe BrokerMsg) -> BrokerMsg -> Maybe BrokerMsg
forall a b. (a -> b) -> a -> b
$ ErrorType -> BrokerMsg
ERR (ErrorType -> BrokerMsg) -> ErrorType -> BrokerMsg
forall a b. (a -> b) -> a -> b
$ ProxyError -> ErrorType
PROXY ProxyError
BASIC_AUTH)
        where
          allowProxy :: ReaderT (Env s) IO Bool
allowProxy = do
            ServerConfig {Bool
allowSMPProxy :: Bool
$sel:allowSMPProxy:ServerConfig :: forall s. ServerConfig s -> Bool
allowSMPProxy, Maybe BasicAuth
newQueueBasicAuth :: Maybe BasicAuth
$sel:newQueueBasicAuth:ServerConfig :: forall s. ServerConfig s -> Maybe BasicAuth
newQueueBasicAuth} <- (Env s -> ServerConfig s) -> ReaderT (Env s) IO (ServerConfig s)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> ServerConfig s
forall s. Env s -> ServerConfig s
config
            Bool -> ReaderT (Env s) IO Bool
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> ReaderT (Env s) IO Bool)
-> Bool -> ReaderT (Env s) IO Bool
forall a b. (a -> b) -> a -> b
$ Bool
allowSMPProxy Bool -> Bool -> Bool
&& Bool -> (BasicAuth -> Bool) -> Maybe BasicAuth -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True ((Maybe BasicAuth -> Maybe BasicAuth -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe BasicAuth
auth) (Maybe BasicAuth -> Bool)
-> (BasicAuth -> Maybe BasicAuth) -> BasicAuth -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BasicAuth -> Maybe BasicAuth
forall a. a -> Maybe a
Just) Maybe BasicAuth
newQueueBasicAuth
          getRelay :: ReaderT (Env s) IO (Maybe BrokerMsg)
getRelay = do
            ProxyAgent {$sel:smpAgent:ProxyAgent :: ProxyAgent -> SMPClientAgent 'Sender
smpAgent = SMPClientAgent 'Sender
a} <- (Env s -> ProxyAgent) -> ReaderT (Env s) IO ProxyAgent
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> ProxyAgent
forall s. Env s -> ProxyAgent
proxyAgent
            IO (Maybe (Either SMPClientError (Bool, SMPClient)))
-> ReaderT
     (Env s) IO (Maybe (Either SMPClientError (Bool, SMPClient)))
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (SMPClientAgent 'Sender
-> SMPServer
-> IO (Maybe (Either SMPClientError (Bool, SMPClient)))
forall (p :: Party).
SMPClientAgent p
-> SMPServer
-> IO (Maybe (Either SMPClientError (Bool, SMPClient)))
getConnectedSMPServerClient SMPClientAgent 'Sender
a SMPServer
srv) ReaderT
  (Env s) IO (Maybe (Either SMPClientError (Bool, SMPClient)))
-> (Maybe (Either SMPClientError (Bool, SMPClient))
    -> ReaderT (Env s) IO (Maybe BrokerMsg))
-> ReaderT (Env s) IO (Maybe BrokerMsg)
forall a b.
ReaderT (Env s) IO a
-> (a -> ReaderT (Env s) IO b) -> ReaderT (Env s) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Just Either SMPClientError (Bool, SMPClient)
r -> BrokerMsg -> Maybe BrokerMsg
forall a. a -> Maybe a
Just (BrokerMsg -> Maybe BrokerMsg)
-> ReaderT (Env s) IO BrokerMsg
-> ReaderT (Env s) IO (Maybe BrokerMsg)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SMPClientAgent 'Sender
-> Either SMPClientError (Bool, SMPClient)
-> ReaderT (Env s) IO BrokerMsg
proxyServerResponse SMPClientAgent 'Sender
a Either SMPClientError (Bool, SMPClient)
r
              Maybe (Either SMPClientError (Bool, SMPClient))
Nothing ->
                ReaderT (Env s) IO BrokerMsg
-> ReaderT (Env s) IO (Maybe BrokerMsg)
forkProxiedCmd (ReaderT (Env s) IO BrokerMsg
 -> ReaderT (Env s) IO (Maybe BrokerMsg))
-> ReaderT (Env s) IO BrokerMsg
-> ReaderT (Env s) IO (Maybe BrokerMsg)
forall a b. (a -> b) -> a -> b
$
                  IO (Either SMPClientError (Bool, SMPClient))
-> ReaderT (Env s) IO (Either SMPClientError (Bool, SMPClient))
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ExceptT SMPClientError IO (Bool, SMPClient)
-> IO (Either SMPClientError (Bool, SMPClient))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (SMPClientAgent 'Sender
-> SMPServer -> ExceptT SMPClientError IO (Bool, SMPClient)
forall (p :: Party).
SMPClientAgent p
-> SMPServer -> ExceptT SMPClientError IO (Bool, SMPClient)
getSMPServerClient'' SMPClientAgent 'Sender
a SMPServer
srv) IO (Either SMPClientError (Bool, SMPClient))
-> (IOError -> IO (Either SMPClientError (Bool, SMPClient)))
-> IO (Either SMPClientError (Bool, SMPClient))
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (Either SMPClientError (Bool, SMPClient)
-> IO (Either SMPClientError (Bool, SMPClient))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SMPClientError (Bool, SMPClient)
 -> IO (Either SMPClientError (Bool, SMPClient)))
-> (IOError -> Either SMPClientError (Bool, SMPClient))
-> IOError
-> IO (Either SMPClientError (Bool, SMPClient))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SMPClientError -> Either SMPClientError (Bool, SMPClient)
forall a b. a -> Either a b
Left (SMPClientError -> Either SMPClientError (Bool, SMPClient))
-> (IOError -> SMPClientError)
-> IOError
-> Either SMPClientError (Bool, SMPClient)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> SMPClientError
forall err. IOError -> ProtocolClientError err
PCEIOError))
                    ReaderT (Env s) IO (Either SMPClientError (Bool, SMPClient))
-> (Either SMPClientError (Bool, SMPClient)
    -> ReaderT (Env s) IO BrokerMsg)
-> ReaderT (Env s) IO BrokerMsg
forall a b.
ReaderT (Env s) IO a
-> (a -> ReaderT (Env s) IO b) -> ReaderT (Env s) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SMPClientAgent 'Sender
-> Either SMPClientError (Bool, SMPClient)
-> ReaderT (Env s) IO BrokerMsg
proxyServerResponse SMPClientAgent 'Sender
a
          proxyServerResponse :: SMPClientAgent 'Sender -> Either SMPClientError (OwnServer, SMPClient) -> M s BrokerMsg
          proxyServerResponse :: SMPClientAgent 'Sender
-> Either SMPClientError (Bool, SMPClient)
-> ReaderT (Env s) IO BrokerMsg
proxyServerResponse SMPClientAgent 'Sender
a Either SMPClientError (Bool, SMPClient)
smp_ = do
            ServerStats {ProxyStats
pRelays :: ServerStats -> ProxyStats
pRelays :: ProxyStats
pRelays, ProxyStats
pRelaysOwn :: ServerStats -> ProxyStats
pRelaysOwn :: ProxyStats
pRelaysOwn} <- (Env s -> ServerStats) -> ReaderT (Env s) IO ServerStats
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> ServerStats
forall s. Env s -> ServerStats
serverStats
            let inc :: Bool -> (ProxyStats -> IORef Int) -> M s ()
inc = ProxyStats
-> ProxyStats -> Bool -> (ProxyStats -> IORef Int) -> M s ()
forall (m :: * -> *).
MonadIO m =>
ProxyStats
-> ProxyStats -> Bool -> (ProxyStats -> IORef Int) -> m ()
mkIncProxyStats ProxyStats
pRelays ProxyStats
pRelaysOwn
            case Either SMPClientError (Bool, SMPClient)
smp_ of
              Right (Bool
own, SMPClient
smp) -> do
                Bool -> (ProxyStats -> IORef Int) -> M s ()
inc Bool
own ProxyStats -> IORef Int
pRequests
                case SMPClient -> BrokerMsg
forall {err} {msg}. ProtocolClient SMPVersion err msg -> BrokerMsg
proxyResp SMPClient
smp of
                  r :: BrokerMsg
r@PKEY {} -> BrokerMsg
r BrokerMsg -> M s () -> ReaderT (Env s) IO BrokerMsg
forall a b. a -> ReaderT (Env s) IO b -> ReaderT (Env s) IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> (ProxyStats -> IORef Int) -> M s ()
inc Bool
own ProxyStats -> IORef Int
pSuccesses
                  BrokerMsg
r -> BrokerMsg
r BrokerMsg -> M s () -> ReaderT (Env s) IO BrokerMsg
forall a b. a -> ReaderT (Env s) IO b -> ReaderT (Env s) IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> (ProxyStats -> IORef Int) -> M s ()
inc Bool
own ProxyStats -> IORef Int
pErrorsCompat
              Left SMPClientError
e -> do
                let own :: Bool
own = SMPClientAgent 'Sender -> SMPServer -> Bool
forall (p :: Party). SMPClientAgent p -> SMPServer -> Bool
isOwnServer SMPClientAgent 'Sender
a SMPServer
srv
                Bool -> (ProxyStats -> IORef Int) -> M s ()
inc Bool
own ProxyStats -> IORef Int
pRequests
                Bool -> (ProxyStats -> IORef Int) -> M s ()
inc Bool
own ((ProxyStats -> IORef Int) -> M s ())
-> (ProxyStats -> IORef Int) -> M s ()
forall a b. (a -> b) -> a -> b
$ if SMPClientError -> Bool
forall err. ProtocolClientError err -> Bool
temporaryClientError SMPClientError
e then ProxyStats -> IORef Int
pErrorsConnect else ProxyStats -> IORef Int
pErrorsOther
                Text -> M s ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logWarn (Text -> M s ()) -> Text -> M s ()
forall a b. (a -> b) -> a -> b
$ Text
"Error connecting: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
decodeLatin1 (NonEmpty TransportHost -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode (NonEmpty TransportHost -> ByteString)
-> NonEmpty TransportHost -> ByteString
forall a b. (a -> b) -> a -> b
$ SMPServer -> NonEmpty TransportHost
forall (p :: ProtocolType).
ProtocolServer p -> NonEmpty TransportHost
host SMPServer
srv) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SMPClientError -> Text
forall a. Show a => a -> Text
tshow SMPClientError
e
                BrokerMsg -> ReaderT (Env s) IO BrokerMsg
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BrokerMsg -> ReaderT (Env s) IO BrokerMsg)
-> (ErrorType -> BrokerMsg)
-> ErrorType
-> ReaderT (Env s) IO BrokerMsg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorType -> BrokerMsg
ERR (ErrorType -> ReaderT (Env s) IO BrokerMsg)
-> ErrorType -> ReaderT (Env s) IO BrokerMsg
forall a b. (a -> b) -> a -> b
$ SMPClientError -> ErrorType
smpProxyError SMPClientError
e
            where
              proxyResp :: ProtocolClient SMPVersion err msg -> BrokerMsg
proxyResp ProtocolClient SMPVersion err msg
smp =
                let THandleParams {$sel:sessionId:THandleParams :: forall v (p :: TransportPeer). THandleParams v p -> ByteString
sessionId = ByteString
srvSessId, Version SMPVersion
$sel:thVersion:THandleParams :: forall v (p :: TransportPeer). THandleParams v p -> Version v
thVersion :: Version SMPVersion
thVersion, VersionRangeSMP
thServerVRange :: VersionRangeSMP
$sel:thServerVRange:THandleParams :: forall v (p :: TransportPeer). THandleParams v p -> VersionRange v
thServerVRange, Maybe (THandleAuth 'TClient)
$sel:thAuth:THandleParams :: forall v (p :: TransportPeer).
THandleParams v p -> Maybe (THandleAuth p)
thAuth :: Maybe (THandleAuth 'TClient)
thAuth} = ProtocolClient SMPVersion err msg
-> THandleParams SMPVersion 'TClient
forall v err msg.
ProtocolClient v err msg -> THandleParams v 'TClient
thParams ProtocolClient SMPVersion err msg
smp
                  in case VersionRangeSMP
-> VersionRangeSMP -> Maybe (Compatible VersionRangeSMP)
forall v a.
VersionRangeI v a =>
a -> VersionRange v -> Maybe (Compatible a)
compatibleVRange VersionRangeSMP
thServerVRange VersionRangeSMP
proxiedSMPRelayVRange of
                      -- Cap the destination relay version range to prevent client version fingerprinting.
                      -- See comment for proxiedSMPRelayVersion.
                      Just (Compatible VersionRangeSMP
vr) | Version SMPVersion
thVersion Version SMPVersion -> Version SMPVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= Version SMPVersion
sendingProxySMPVersion -> case Maybe (THandleAuth 'TClient)
thAuth of
                        Just THAuthClient {CertChainPubKey
peerServerCertKey :: CertChainPubKey
$sel:peerServerCertKey:THAuthClient :: THandleAuth 'TClient -> CertChainPubKey
peerServerCertKey} -> ByteString -> VersionRangeSMP -> CertChainPubKey -> BrokerMsg
PKEY ByteString
srvSessId VersionRangeSMP
vr CertChainPubKey
peerServerCertKey
                        Maybe (THandleAuth 'TClient)
Nothing -> ErrorType -> BrokerMsg
ERR (ErrorType -> BrokerMsg) -> ErrorType -> BrokerMsg
forall a b. (a -> b) -> a -> b
$ TransportError -> ErrorType
transportErr TransportError
TENoServerAuth
                      Maybe (Compatible VersionRangeSMP)
_ -> ErrorType -> BrokerMsg
ERR (ErrorType -> BrokerMsg) -> ErrorType -> BrokerMsg
forall a b. (a -> b) -> a -> b
$ TransportError -> ErrorType
transportErr TransportError
TEVersion
      PFWD Version SMPVersion
fwdV PublicKey 'X25519
pubKey EncTransmission
encBlock -> do
        ProxyAgent {$sel:smpAgent:ProxyAgent :: ProxyAgent -> SMPClientAgent 'Sender
smpAgent = SMPClientAgent 'Sender
a} <- (Env s -> ProxyAgent) -> ReaderT (Env s) IO ProxyAgent
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> ProxyAgent
forall s. Env s -> ProxyAgent
proxyAgent
        ServerStats {ProxyStats
pMsgFwds :: ServerStats -> ProxyStats
pMsgFwds :: ProxyStats
pMsgFwds, ProxyStats
pMsgFwdsOwn :: ServerStats -> ProxyStats
pMsgFwdsOwn :: ProxyStats
pMsgFwdsOwn} <- (Env s -> ServerStats) -> ReaderT (Env s) IO ServerStats
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> ServerStats
forall s. Env s -> ServerStats
serverStats
        let inc :: Bool -> (ProxyStats -> IORef Int) -> M s ()
inc = ProxyStats
-> ProxyStats -> Bool -> (ProxyStats -> IORef Int) -> M s ()
forall (m :: * -> *).
MonadIO m =>
ProxyStats
-> ProxyStats -> Bool -> (ProxyStats -> IORef Int) -> m ()
mkIncProxyStats ProxyStats
pMsgFwds ProxyStats
pMsgFwdsOwn
        IO (Maybe (Bool, SMPClient))
-> ReaderT (Env s) IO (Maybe (Bool, SMPClient))
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (SMPClientAgent 'Sender
-> ByteString -> IO (Maybe (Bool, SMPClient))
forall (p :: Party).
SMPClientAgent p -> ByteString -> IO (Maybe (Bool, SMPClient))
lookupSMPServerClient SMPClientAgent 'Sender
a ByteString
sessId) ReaderT (Env s) IO (Maybe (Bool, SMPClient))
-> (Maybe (Bool, SMPClient)
    -> ReaderT (Env s) IO (Maybe BrokerMsg))
-> ReaderT (Env s) IO (Maybe BrokerMsg)
forall a b.
ReaderT (Env s) IO a
-> (a -> ReaderT (Env s) IO b) -> ReaderT (Env s) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Just (Bool
own, SMPClient
smp) -> do
            Bool -> (ProxyStats -> IORef Int) -> M s ()
inc Bool
own ProxyStats -> IORef Int
pRequests
            if Version SMPVersion
v Version SMPVersion -> Version SMPVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= Version SMPVersion
sendingProxySMPVersion
              then ReaderT (Env s) IO BrokerMsg
-> ReaderT (Env s) IO (Maybe BrokerMsg)
forkProxiedCmd (ReaderT (Env s) IO BrokerMsg
 -> ReaderT (Env s) IO (Maybe BrokerMsg))
-> ReaderT (Env s) IO BrokerMsg
-> ReaderT (Env s) IO (Maybe BrokerMsg)
forall a b. (a -> b) -> a -> b
$ do
                IO (Either SMPClientError EncResponse)
-> ReaderT (Env s) IO (Either SMPClientError EncResponse)
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ExceptT SMPClientError IO EncResponse
-> IO (Either SMPClientError EncResponse)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (SMPClient
-> CorrId
-> Version SMPVersion
-> PublicKey 'X25519
-> EncTransmission
-> ExceptT SMPClientError IO EncResponse
forwardSMPTransmission SMPClient
smp CorrId
corrId Version SMPVersion
fwdV PublicKey 'X25519
pubKey EncTransmission
encBlock) IO (Either SMPClientError EncResponse)
-> (IOError -> IO (Either SMPClientError EncResponse))
-> IO (Either SMPClientError EncResponse)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (Either SMPClientError EncResponse
-> IO (Either SMPClientError EncResponse)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SMPClientError EncResponse
 -> IO (Either SMPClientError EncResponse))
-> (IOError -> Either SMPClientError EncResponse)
-> IOError
-> IO (Either SMPClientError EncResponse)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SMPClientError -> Either SMPClientError EncResponse
forall a b. a -> Either a b
Left (SMPClientError -> Either SMPClientError EncResponse)
-> (IOError -> SMPClientError)
-> IOError
-> Either SMPClientError EncResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> SMPClientError
forall err. IOError -> ProtocolClientError err
PCEIOError))  ReaderT (Env s) IO (Either SMPClientError EncResponse)
-> (Either SMPClientError EncResponse
    -> ReaderT (Env s) IO BrokerMsg)
-> ReaderT (Env s) IO BrokerMsg
forall a b.
ReaderT (Env s) IO a
-> (a -> ReaderT (Env s) IO b) -> ReaderT (Env s) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                  Right EncResponse
r -> EncResponse -> BrokerMsg
PRES EncResponse
r BrokerMsg -> M s () -> ReaderT (Env s) IO BrokerMsg
forall a b. a -> ReaderT (Env s) IO b -> ReaderT (Env s) IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> (ProxyStats -> IORef Int) -> M s ()
inc Bool
own ProxyStats -> IORef Int
pSuccesses
                  Left SMPClientError
e -> ErrorType -> BrokerMsg
ERR (SMPClientError -> ErrorType
smpProxyError SMPClientError
e) BrokerMsg -> M s () -> ReaderT (Env s) IO BrokerMsg
forall a b. a -> ReaderT (Env s) IO b -> ReaderT (Env s) IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ case SMPClientError
e of
                    PCEProtocolError {} -> Bool -> (ProxyStats -> IORef Int) -> M s ()
inc Bool
own ProxyStats -> IORef Int
pSuccesses
                    SMPClientError
_ -> Bool -> (ProxyStats -> IORef Int) -> M s ()
inc Bool
own ProxyStats -> IORef Int
pErrorsOther
              else BrokerMsg -> Maybe BrokerMsg
forall a. a -> Maybe a
Just (ErrorType -> BrokerMsg
ERR (ErrorType -> BrokerMsg) -> ErrorType -> BrokerMsg
forall a b. (a -> b) -> a -> b
$ TransportError -> ErrorType
transportErr TransportError
TEVersion) Maybe BrokerMsg -> M s () -> ReaderT (Env s) IO (Maybe BrokerMsg)
forall a b. a -> ReaderT (Env s) IO b -> ReaderT (Env s) IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> (ProxyStats -> IORef Int) -> M s ()
inc Bool
own ProxyStats -> IORef Int
pErrorsCompat
            where
              THandleParams {$sel:thVersion:THandleParams :: forall v (p :: TransportPeer). THandleParams v p -> Version v
thVersion = Version SMPVersion
v} = SMPClient -> THandleParams SMPVersion 'TClient
forall v err msg.
ProtocolClient v err msg -> THandleParams v 'TClient
thParams SMPClient
smp
          Maybe (Bool, SMPClient)
Nothing -> Bool -> (ProxyStats -> IORef Int) -> M s ()
inc Bool
False ProxyStats -> IORef Int
pRequests M s ()
-> ReaderT (Env s) IO (Maybe BrokerMsg)
-> ReaderT (Env s) IO (Maybe BrokerMsg)
forall a b.
ReaderT (Env s) IO a
-> ReaderT (Env s) IO b -> ReaderT (Env s) IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> (ProxyStats -> IORef Int) -> M s ()
inc Bool
False ProxyStats -> IORef Int
pErrorsConnect M s () -> Maybe BrokerMsg -> ReaderT (Env s) IO (Maybe BrokerMsg)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> BrokerMsg -> Maybe BrokerMsg
forall a. a -> Maybe a
Just (ErrorType -> BrokerMsg
ERR (ErrorType -> BrokerMsg) -> ErrorType -> BrokerMsg
forall a b. (a -> b) -> a -> b
$ ProxyError -> ErrorType
PROXY ProxyError
NO_SESSION)
      where
        forkProxiedCmd :: M s BrokerMsg -> M s (Maybe BrokerMsg)
        forkProxiedCmd :: ReaderT (Env s) IO BrokerMsg
-> ReaderT (Env s) IO (Maybe BrokerMsg)
forkProxiedCmd ReaderT (Env s) IO BrokerMsg
cmdAction = do
          M s () -> M s () -> M s () -> M s ()
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> m b -> m c -> m c
bracket_ M s ()
wait M s ()
signal (M s () -> M s ()) -> (M s () -> M s ()) -> M s () -> M s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Client s -> String -> M s () -> M s ()
forall (m :: * -> *) s.
MonadUnliftIO m =>
Client s -> String -> m () -> m ()
forkClient Client s
clnt (ByteString -> String
B.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ ByteString
"client $" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
encode ByteString
sessionId ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" proxy") (M s () -> M s ()) -> M s () -> M s ()
forall a b. (a -> b) -> a -> b
$ do
            -- commands MUST be processed under a reasonable timeout or the client would halt
            ReaderT (Env s) IO BrokerMsg
cmdAction ReaderT (Env s) IO BrokerMsg -> (BrokerMsg -> M s ()) -> M s ()
forall a b.
ReaderT (Env s) IO a
-> (a -> ReaderT (Env s) IO b) -> ReaderT (Env s) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \BrokerMsg
t -> STM () -> M s ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> M s ()) -> STM () -> M s ()
forall a b. (a -> b) -> a -> b
$ TBQueue
  (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
-> (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
-> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue
  (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
sndQ ([(CorrId
corrId, ByteString -> RecipientId
EntityId ByteString
sessId, BrokerMsg
t)], [])
          Maybe BrokerMsg -> ReaderT (Env s) IO (Maybe BrokerMsg)
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe BrokerMsg
forall a. Maybe a
Nothing
          where
            wait :: M s ()
wait = do
              ServerConfig {Int
serverClientConcurrency :: Int
$sel:serverClientConcurrency:ServerConfig :: forall s. ServerConfig s -> Int
serverClientConcurrency} <- (Env s -> ServerConfig s) -> ReaderT (Env s) IO (ServerConfig s)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> ServerConfig s
forall s. Env s -> ServerConfig s
config
              STM () -> M s ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> M s ()) -> STM () -> M s ()
forall a b. (a -> b) -> a -> b
$ do
                Int
used <- TVar Int -> STM Int
forall a. TVar a -> STM a
readTVar TVar Int
procThreads
                Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
used Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
serverClientConcurrency) STM ()
forall a. STM a
retry
                TVar Int -> Int -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Int
procThreads (Int -> STM ()) -> Int -> STM ()
forall a b. (a -> b) -> a -> b
$! Int
used Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
            signal :: M s ()
signal = STM () -> M s ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> M s ()) -> STM () -> M s ()
forall a b. (a -> b) -> a -> b
$ TVar Int -> (Int -> Int) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int
procThreads (\Int
t -> Int
t Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
    transportErr :: TransportError -> ErrorType
    transportErr :: TransportError -> ErrorType
transportErr = ProxyError -> ErrorType
PROXY (ProxyError -> ErrorType)
-> (TransportError -> ProxyError) -> TransportError -> ErrorType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BrokerErrorType -> ProxyError
BROKER (BrokerErrorType -> ProxyError)
-> (TransportError -> BrokerErrorType)
-> TransportError
-> ProxyError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TransportError -> BrokerErrorType
TRANSPORT
    mkIncProxyStats :: MonadIO m => ProxyStats -> ProxyStats -> OwnServer -> (ProxyStats -> IORef Int) -> m ()
    mkIncProxyStats :: forall (m :: * -> *).
MonadIO m =>
ProxyStats
-> ProxyStats -> Bool -> (ProxyStats -> IORef Int) -> m ()
mkIncProxyStats ProxyStats
ps ProxyStats
psOwn Bool
own ProxyStats -> IORef Int
sel = do
      IORef Int -> m ()
forall (m :: * -> *). MonadIO m => IORef Int -> m ()
incStat (IORef Int -> m ()) -> IORef Int -> m ()
forall a b. (a -> b) -> a -> b
$ ProxyStats -> IORef Int
sel ProxyStats
ps
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
own (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef Int -> m ()
forall (m :: * -> *). MonadIO m => IORef Int -> m ()
incStat (IORef Int -> m ()) -> IORef Int -> m ()
forall a b. (a -> b) -> a -> b
$ ProxyStats -> IORef Int
sel ProxyStats
psOwn
    processCommand :: Maybe ServiceId -> VersionSMP -> VerifiedTransmission s -> M s (Maybe ResponseAndMessage)
    processCommand :: Maybe RecipientId
-> Version SMPVersion
-> VerifiedTransmission s
-> ReaderT
     (Env s)
     IO
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
processCommand Maybe RecipientId
clntServiceId Version SMPVersion
clntVersion (Maybe (StoreQueue s, QueueRec)
q_, (CorrId
corrId, RecipientId
entId, Cmd
cmd)) = case Cmd
cmd of
      Cmd SParty p
SProxiedClient Command p
command -> Transmission (Command 'ProxiedClient)
-> ReaderT
     (Env s)
     IO
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
processProxiedCmd (CorrId
corrId, RecipientId
entId, Command p
Command 'ProxiedClient
command)
      Cmd SParty p
SSender Command p
command -> case Command p
command of
        SKEY RcvPublicAuthKey
k -> (StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg))
-> ReaderT
     (Env s)
     IO
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
withQueue ((StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg))
 -> ReaderT
      (Env s)
      IO
      (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))))
-> (StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg))
-> ReaderT
     (Env s)
     IO
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
forall a b. (a -> b) -> a -> b
$ \StoreQueue s
q QueueRec
qr -> QueueMode
-> QueueRec
-> M s (Either ErrorType BrokerMsg)
-> M s (Transmission BrokerMsg)
checkMode QueueMode
QMMessaging QueueRec
qr (M s (Either ErrorType BrokerMsg) -> M s (Transmission BrokerMsg))
-> M s (Either ErrorType BrokerMsg) -> M s (Transmission BrokerMsg)
forall a b. (a -> b) -> a -> b
$ StoreQueue s
-> RcvPublicAuthKey -> M s (Either ErrorType BrokerMsg)
secureQueue_ StoreQueue s
q RcvPublicAuthKey
k
        SEND MsgFlags
flags ByteString
msgBody -> Transmission BrokerMsg
-> Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
response (Transmission BrokerMsg
 -> Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
-> M s (Transmission BrokerMsg)
-> ReaderT
     (Env s)
     IO
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool
-> (ErrorType -> Transmission BrokerMsg)
-> (StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg))
-> M s (Transmission BrokerMsg)
forall r.
Bool
-> (ErrorType -> r) -> (StoreQueue s -> QueueRec -> M s r) -> M s r
withQueue_ Bool
False ErrorType -> Transmission BrokerMsg
err (MsgFlags
-> ByteString
-> StoreQueue s
-> QueueRec
-> M s (Transmission BrokerMsg)
sendMessage MsgFlags
flags ByteString
msgBody)
      Cmd SParty p
SIdleClient Command p
PING -> Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
-> ReaderT
     (Env s)
     IO
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
 -> ReaderT
      (Env s)
      IO
      (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))))
-> Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
-> ReaderT
     (Env s)
     IO
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
forall a b. (a -> b) -> a -> b
$ Transmission BrokerMsg
-> Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
response (CorrId
corrId, RecipientId
NoEntity, BrokerMsg
PONG)
      Cmd SParty p
SProxyService (RFWD EncFwdTransmission
encBlock) -> Transmission BrokerMsg
-> Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
response (Transmission BrokerMsg
 -> Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
-> (BrokerMsg -> Transmission BrokerMsg)
-> BrokerMsg
-> Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CorrId
corrId,RecipientId
NoEntity,) (BrokerMsg
 -> Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
-> ReaderT (Env s) IO BrokerMsg
-> ReaderT
     (Env s)
     IO
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EncFwdTransmission -> ReaderT (Env s) IO BrokerMsg
processForwardedCommand EncFwdTransmission
encBlock
      Cmd SParty p
SSenderLink Command p
command -> case Command p
command of
        LKEY RcvPublicAuthKey
k -> (StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg))
-> ReaderT
     (Env s)
     IO
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
withQueue ((StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg))
 -> ReaderT
      (Env s)
      IO
      (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))))
-> (StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg))
-> ReaderT
     (Env s)
     IO
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
forall a b. (a -> b) -> a -> b
$ \StoreQueue s
q QueueRec
qr -> QueueMode
-> QueueRec
-> M s (Either ErrorType BrokerMsg)
-> M s (Transmission BrokerMsg)
checkMode QueueMode
QMMessaging QueueRec
qr (M s (Either ErrorType BrokerMsg) -> M s (Transmission BrokerMsg))
-> M s (Either ErrorType BrokerMsg) -> M s (Transmission BrokerMsg)
forall a b. (a -> b) -> a -> b
$ StoreQueue s
-> RcvPublicAuthKey -> M s (Either ErrorType BrokerMsg)
secureQueue_ StoreQueue s
q RcvPublicAuthKey
k M s (Either ErrorType BrokerMsg)
-> M s (Either ErrorType BrokerMsg)
-> M s (Either ErrorType BrokerMsg)
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Monad f, Traversable f) =>
m (f a) -> m (f b) -> m (f b)
$>> StoreQueue s -> QueueRec -> M s (Either ErrorType BrokerMsg)
getQueueLink_ StoreQueue s
q QueueRec
qr
        Command p
LGET -> (StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg))
-> ReaderT
     (Env s)
     IO
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
withQueue ((StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg))
 -> ReaderT
      (Env s)
      IO
      (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))))
-> (StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg))
-> ReaderT
     (Env s)
     IO
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
forall a b. (a -> b) -> a -> b
$ \StoreQueue s
q QueueRec
qr -> QueueRec
-> M s (Either ErrorType BrokerMsg) -> M s (Transmission BrokerMsg)
checkContact QueueRec
qr (M s (Either ErrorType BrokerMsg) -> M s (Transmission BrokerMsg))
-> M s (Either ErrorType BrokerMsg) -> M s (Transmission BrokerMsg)
forall a b. (a -> b) -> a -> b
$ StoreQueue s -> QueueRec -> M s (Either ErrorType BrokerMsg)
getQueueLink_ StoreQueue s
q QueueRec
qr
      Cmd SParty p
SNotifier Command p
NSUB -> Transmission BrokerMsg
-> Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
response (Transmission BrokerMsg
 -> Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
-> (BrokerMsg -> Transmission BrokerMsg)
-> BrokerMsg
-> Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CorrId
corrId,RecipientId
entId,) (BrokerMsg
 -> Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
-> ReaderT (Env s) IO BrokerMsg
-> ReaderT
     (Env s)
     IO
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Maybe (StoreQueue s, QueueRec)
q_ of
        Just (StoreQueue s
q, QueueRec {$sel:notifier:QueueRec :: QueueRec -> Maybe NtfCreds
notifier = Just NtfCreds
ntfCreds}) -> StoreQueue s -> NtfCreds -> ReaderT (Env s) IO BrokerMsg
subscribeNotifications StoreQueue s
q NtfCreds
ntfCreds
        Maybe (StoreQueue s, QueueRec)
_ -> BrokerMsg -> ReaderT (Env s) IO BrokerMsg
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BrokerMsg -> ReaderT (Env s) IO BrokerMsg)
-> BrokerMsg -> ReaderT (Env s) IO BrokerMsg
forall a b. (a -> b) -> a -> b
$ ErrorType -> BrokerMsg
ERR ErrorType
INTERNAL
      Cmd SParty p
SNotifierService Command p
NSUBS -> Transmission BrokerMsg
-> Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
response (Transmission BrokerMsg
 -> Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
-> (BrokerMsg -> Transmission BrokerMsg)
-> BrokerMsg
-> Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CorrId
corrId,RecipientId
entId,) (BrokerMsg
 -> Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
-> ReaderT (Env s) IO BrokerMsg
-> ReaderT
     (Env s)
     IO
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Maybe RecipientId
clntServiceId of
        Just RecipientId
serviceId -> RecipientId -> ReaderT (Env s) IO BrokerMsg
subscribeServiceNotifications RecipientId
serviceId
        Maybe RecipientId
Nothing -> BrokerMsg -> ReaderT (Env s) IO BrokerMsg
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BrokerMsg -> ReaderT (Env s) IO BrokerMsg)
-> BrokerMsg -> ReaderT (Env s) IO BrokerMsg
forall a b. (a -> b) -> a -> b
$ ErrorType -> BrokerMsg
ERR ErrorType
INTERNAL
      Cmd SParty p
SCreator (NEW nqr :: NewQueueReq
nqr@NewQueueReq {Maybe BasicAuth
auth_ :: Maybe BasicAuth
$sel:auth_:NewQueueReq :: NewQueueReq -> Maybe BasicAuth
auth_}) ->
        Transmission BrokerMsg
-> Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
response (Transmission BrokerMsg
 -> Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
-> M s (Transmission BrokerMsg)
-> ReaderT
     (Env s)
     IO
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT (Env s) IO Bool
-> M s (Transmission BrokerMsg)
-> M s (Transmission BrokerMsg)
-> M s (Transmission BrokerMsg)
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM ReaderT (Env s) IO Bool
allowNew (NewQueueReq -> M s (Transmission BrokerMsg)
createQueue NewQueueReq
nqr) (Transmission BrokerMsg -> M s (Transmission BrokerMsg)
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CorrId
corrId, RecipientId
entId, ErrorType -> BrokerMsg
ERR ErrorType
AUTH))
          where
            allowNew :: ReaderT (Env s) IO Bool
allowNew = do
              ServerConfig {Bool
allowNewQueues :: Bool
$sel:allowNewQueues:ServerConfig :: forall s. ServerConfig s -> Bool
allowNewQueues, Maybe BasicAuth
$sel:newQueueBasicAuth:ServerConfig :: forall s. ServerConfig s -> Maybe BasicAuth
newQueueBasicAuth :: Maybe BasicAuth
newQueueBasicAuth} <- (Env s -> ServerConfig s) -> ReaderT (Env s) IO (ServerConfig s)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> ServerConfig s
forall s. Env s -> ServerConfig s
config
              Bool -> ReaderT (Env s) IO Bool
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> ReaderT (Env s) IO Bool)
-> Bool -> ReaderT (Env s) IO Bool
forall a b. (a -> b) -> a -> b
$ Bool
allowNewQueues Bool -> Bool -> Bool
&& Bool -> (BasicAuth -> Bool) -> Maybe BasicAuth -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True ((Maybe BasicAuth -> Maybe BasicAuth -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe BasicAuth
auth_) (Maybe BasicAuth -> Bool)
-> (BasicAuth -> Maybe BasicAuth) -> BasicAuth -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BasicAuth -> Maybe BasicAuth
forall a. a -> Maybe a
Just) Maybe BasicAuth
newQueueBasicAuth
      Cmd SParty p
SRecipient Command p
command ->
        case Command p
command of
          Command p
SUB -> (StoreQueue s
 -> QueueRec
 -> M s (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
-> ReaderT
     (Env s)
     IO
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
withQueue' StoreQueue s
-> QueueRec
-> M s (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
subscribeQueueAndDeliver
          Command p
GET -> (StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg))
-> ReaderT
     (Env s)
     IO
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
withQueue StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg)
getMessage
          ACK ByteString
msgId -> (StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg))
-> ReaderT
     (Env s)
     IO
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
withQueue ((StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg))
 -> ReaderT
      (Env s)
      IO
      (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))))
-> (StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg))
-> ReaderT
     (Env s)
     IO
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
forall a b. (a -> b) -> a -> b
$ ByteString
-> StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg)
acknowledgeMsg ByteString
msgId
          KEY RcvPublicAuthKey
sKey -> (StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg))
-> ReaderT
     (Env s)
     IO
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
withQueue ((StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg))
 -> ReaderT
      (Env s)
      IO
      (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))))
-> (StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg))
-> ReaderT
     (Env s)
     IO
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
forall a b. (a -> b) -> a -> b
$ \StoreQueue s
q QueueRec
_ -> (ErrorType -> Transmission BrokerMsg)
-> (BrokerMsg -> Transmission BrokerMsg)
-> Either ErrorType BrokerMsg
-> Transmission BrokerMsg
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ErrorType -> Transmission BrokerMsg
err (CorrId
corrId,RecipientId
entId,) (Either ErrorType BrokerMsg -> Transmission BrokerMsg)
-> M s (Either ErrorType BrokerMsg) -> M s (Transmission BrokerMsg)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StoreQueue s
-> RcvPublicAuthKey -> M s (Either ErrorType BrokerMsg)
secureQueue_ StoreQueue s
q RcvPublicAuthKey
sKey
          RKEY NonEmpty RcvPublicAuthKey
rKeys -> (StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg))
-> ReaderT
     (Env s)
     IO
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
withQueue ((StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg))
 -> ReaderT
      (Env s)
      IO
      (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))))
-> (StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg))
-> ReaderT
     (Env s)
     IO
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
forall a b. (a -> b) -> a -> b
$ \StoreQueue s
q QueueRec
qr -> QueueMode
-> QueueRec
-> M s (Either ErrorType BrokerMsg)
-> M s (Transmission BrokerMsg)
checkMode QueueMode
QMContact QueueRec
qr (M s (Either ErrorType BrokerMsg) -> M s (Transmission BrokerMsg))
-> M s (Either ErrorType BrokerMsg) -> M s (Transmission BrokerMsg)
forall a b. (a -> b) -> a -> b
$ BrokerMsg
OK BrokerMsg
-> ReaderT (Env s) IO (Either ErrorType ())
-> M s (Either ErrorType BrokerMsg)
forall (f :: * -> *) (g :: * -> *) b a.
(Functor f, Functor g) =>
b -> f (g a) -> f (g b)
<$$ IO (Either ErrorType ())
-> ReaderT (Env s) IO (Either ErrorType ())
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (QueueStore s
-> StoreQueue s
-> NonEmpty RcvPublicAuthKey
-> IO (Either ErrorType ())
forall q s.
QueueStoreClass q s =>
s -> q -> NonEmpty RcvPublicAuthKey -> IO (Either ErrorType ())
updateKeys (s -> QueueStore s
forall s. MsgStoreClass s => s -> QueueStore s
queueStore s
ms) StoreQueue s
q NonEmpty RcvPublicAuthKey
rKeys)
          LSET RecipientId
lnkId QueueLinkData
d ->
            (StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg))
-> ReaderT
     (Env s)
     IO
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
withQueue ((StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg))
 -> ReaderT
      (Env s)
      IO
      (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))))
-> (StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg))
-> ReaderT
     (Env s)
     IO
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
forall a b. (a -> b) -> a -> b
$ \StoreQueue s
q QueueRec
qr -> case QueueRec -> Maybe (RecipientId, QueueLinkData)
queueData QueueRec
qr of
              Maybe (RecipientId, QueueLinkData)
_ | QueueRec -> Bool
isSecuredMsgQueue QueueRec
qr -> Transmission BrokerMsg -> M s (Transmission BrokerMsg)
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Transmission BrokerMsg -> M s (Transmission BrokerMsg))
-> Transmission BrokerMsg -> M s (Transmission BrokerMsg)
forall a b. (a -> b) -> a -> b
$ ErrorType -> Transmission BrokerMsg
err ErrorType
AUTH
              Just (RecipientId
lnkId', QueueLinkData
_) | RecipientId
lnkId' RecipientId -> RecipientId -> Bool
forall a. Eq a => a -> a -> Bool
/= RecipientId
lnkId -> Transmission BrokerMsg -> M s (Transmission BrokerMsg)
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Transmission BrokerMsg -> M s (Transmission BrokerMsg))
-> Transmission BrokerMsg -> M s (Transmission BrokerMsg)
forall a b. (a -> b) -> a -> b
$ ErrorType -> Transmission BrokerMsg
err ErrorType
AUTH -- can't change link ID
              Maybe (RecipientId, QueueLinkData)
_ -> IO (Transmission BrokerMsg) -> M s (Transmission BrokerMsg)
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Transmission BrokerMsg) -> M s (Transmission BrokerMsg))
-> IO (Transmission BrokerMsg) -> M s (Transmission BrokerMsg)
forall a b. (a -> b) -> a -> b
$ (ErrorType -> Transmission BrokerMsg)
-> (() -> Transmission BrokerMsg)
-> Either ErrorType ()
-> Transmission BrokerMsg
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ErrorType -> Transmission BrokerMsg
err (Transmission BrokerMsg -> () -> Transmission BrokerMsg
forall a b. a -> b -> a
const Transmission BrokerMsg
ok) (Either ErrorType () -> Transmission BrokerMsg)
-> IO (Either ErrorType ()) -> IO (Transmission BrokerMsg)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QueueStore s
-> StoreQueue s
-> RecipientId
-> QueueLinkData
-> IO (Either ErrorType ())
forall q s.
QueueStoreClass q s =>
s -> q -> RecipientId -> QueueLinkData -> IO (Either ErrorType ())
addQueueLinkData (s -> QueueStore s
forall s. MsgStoreClass s => s -> QueueStore s
queueStore s
ms) StoreQueue s
q RecipientId
lnkId QueueLinkData
d
          Command p
LDEL ->
            (StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg))
-> ReaderT
     (Env s)
     IO
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
withQueue ((StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg))
 -> ReaderT
      (Env s)
      IO
      (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))))
-> (StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg))
-> ReaderT
     (Env s)
     IO
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
forall a b. (a -> b) -> a -> b
$ \StoreQueue s
q QueueRec
qr -> case QueueRec -> Maybe (RecipientId, QueueLinkData)
queueData QueueRec
qr of
              Just (RecipientId, QueueLinkData)
_ -> IO (Transmission BrokerMsg) -> M s (Transmission BrokerMsg)
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Transmission BrokerMsg) -> M s (Transmission BrokerMsg))
-> IO (Transmission BrokerMsg) -> M s (Transmission BrokerMsg)
forall a b. (a -> b) -> a -> b
$ (ErrorType -> Transmission BrokerMsg)
-> (() -> Transmission BrokerMsg)
-> Either ErrorType ()
-> Transmission BrokerMsg
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ErrorType -> Transmission BrokerMsg
err (Transmission BrokerMsg -> () -> Transmission BrokerMsg
forall a b. a -> b -> a
const Transmission BrokerMsg
ok) (Either ErrorType () -> Transmission BrokerMsg)
-> IO (Either ErrorType ()) -> IO (Transmission BrokerMsg)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QueueStore s -> StoreQueue s -> IO (Either ErrorType ())
forall q s.
QueueStoreClass q s =>
s -> q -> IO (Either ErrorType ())
deleteQueueLinkData (s -> QueueStore s
forall s. MsgStoreClass s => s -> QueueStore s
queueStore s
ms) StoreQueue s
q
              Maybe (RecipientId, QueueLinkData)
Nothing -> Transmission BrokerMsg -> M s (Transmission BrokerMsg)
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Transmission BrokerMsg
ok
          NKEY RcvPublicAuthKey
nKey PublicKey 'X25519
dhKey -> (StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg))
-> ReaderT
     (Env s)
     IO
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
withQueue ((StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg))
 -> ReaderT
      (Env s)
      IO
      (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))))
-> (StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg))
-> ReaderT
     (Env s)
     IO
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
forall a b. (a -> b) -> a -> b
$ \StoreQueue s
q QueueRec
_ -> StoreQueue s
-> RcvPublicAuthKey
-> PublicKey 'X25519
-> M s (Transmission BrokerMsg)
addQueueNotifier_ StoreQueue s
q RcvPublicAuthKey
nKey PublicKey 'X25519
dhKey
          Command p
NDEL -> (StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg))
-> ReaderT
     (Env s)
     IO
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
withQueue ((StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg))
 -> ReaderT
      (Env s)
      IO
      (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))))
-> (StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg))
-> ReaderT
     (Env s)
     IO
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
forall a b. (a -> b) -> a -> b
$ \StoreQueue s
q QueueRec
_ -> StoreQueue s -> M s (Transmission BrokerMsg)
deleteQueueNotifier_ StoreQueue s
q
          Command p
OFF -> Transmission BrokerMsg
-> Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
response (Transmission BrokerMsg
 -> Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
-> M s (Transmission BrokerMsg)
-> ReaderT
     (Env s)
     IO
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> M s (Transmission BrokerMsg)
-> ((StoreQueue s, QueueRec) -> M s (Transmission BrokerMsg))
-> Maybe (StoreQueue s, QueueRec)
-> M s (Transmission BrokerMsg)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Transmission BrokerMsg -> M s (Transmission BrokerMsg)
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Transmission BrokerMsg -> M s (Transmission BrokerMsg))
-> Transmission BrokerMsg -> M s (Transmission BrokerMsg)
forall a b. (a -> b) -> a -> b
$ ErrorType -> Transmission BrokerMsg
err ErrorType
INTERNAL) (StoreQueue s, QueueRec) -> M s (Transmission BrokerMsg)
suspendQueue_ Maybe (StoreQueue s, QueueRec)
q_
          Command p
DEL -> Transmission BrokerMsg
-> Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
response (Transmission BrokerMsg
 -> Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
-> M s (Transmission BrokerMsg)
-> ReaderT
     (Env s)
     IO
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> M s (Transmission BrokerMsg)
-> ((StoreQueue s, QueueRec) -> M s (Transmission BrokerMsg))
-> Maybe (StoreQueue s, QueueRec)
-> M s (Transmission BrokerMsg)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Transmission BrokerMsg -> M s (Transmission BrokerMsg)
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Transmission BrokerMsg -> M s (Transmission BrokerMsg))
-> Transmission BrokerMsg -> M s (Transmission BrokerMsg)
forall a b. (a -> b) -> a -> b
$ ErrorType -> Transmission BrokerMsg
err ErrorType
INTERNAL) (StoreQueue s, QueueRec) -> M s (Transmission BrokerMsg)
delQueueAndMsgs Maybe (StoreQueue s, QueueRec)
q_
          Command p
QUE -> (StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg))
-> ReaderT
     (Env s)
     IO
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
withQueue ((StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg))
 -> ReaderT
      (Env s)
      IO
      (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))))
-> (StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg))
-> ReaderT
     (Env s)
     IO
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
forall a b. (a -> b) -> a -> b
$ \StoreQueue s
q QueueRec
qr -> (CorrId
corrId,RecipientId
entId,) (BrokerMsg -> Transmission BrokerMsg)
-> ReaderT (Env s) IO BrokerMsg -> M s (Transmission BrokerMsg)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StoreQueue s -> QueueRec -> ReaderT (Env s) IO BrokerMsg
getQueueInfo StoreQueue s
q QueueRec
qr
      Cmd SParty p
SRecipientService Command p
SUBS -> Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
-> ReaderT
     (Env s)
     IO
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
 -> ReaderT
      (Env s)
      IO
      (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))))
-> Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
-> ReaderT
     (Env s)
     IO
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
forall a b. (a -> b) -> a -> b
$ Transmission BrokerMsg
-> Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
response (Transmission BrokerMsg
 -> Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
-> Transmission BrokerMsg
-> Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
forall a b. (a -> b) -> a -> b
$ ErrorType -> Transmission BrokerMsg
err (CommandError -> ErrorType
CMD CommandError
PROHIBITED) -- "TODO [certs rcv]"
      where
        createQueue :: NewQueueReq -> M s (Transmission BrokerMsg)
        createQueue :: NewQueueReq -> M s (Transmission BrokerMsg)
createQueue NewQueueReq {RcvPublicAuthKey
$sel:rcvAuthKey:NewQueueReq :: NewQueueReq -> RcvPublicAuthKey
rcvAuthKey :: RcvPublicAuthKey
rcvAuthKey, PublicKey 'X25519
rcvDhKey :: PublicKey 'X25519
$sel:rcvDhKey:NewQueueReq :: NewQueueReq -> PublicKey 'X25519
rcvDhKey, SubscriptionMode
subMode :: SubscriptionMode
$sel:subMode:NewQueueReq :: NewQueueReq -> SubscriptionMode
subMode, Maybe QueueReqData
queueReqData :: Maybe QueueReqData
$sel:queueReqData:NewQueueReq :: NewQueueReq -> Maybe QueueReqData
queueReqData, Maybe NewNtfCreds
ntfCreds :: Maybe NewNtfCreds
$sel:ntfCreds:NewQueueReq :: NewQueueReq -> Maybe NewNtfCreds
ntfCreds}
          | Maybe RecipientId -> Bool
forall a. Maybe a -> Bool
isJust Maybe RecipientId
clntServiceId Bool -> Bool -> Bool
&& SubscriptionMode
subMode SubscriptionMode -> SubscriptionMode -> Bool
forall a. Eq a => a -> a -> Bool
== SubscriptionMode
SMOnlyCreate = Transmission BrokerMsg -> M s (Transmission BrokerMsg)
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CorrId
corrId, RecipientId
entId, ErrorType -> BrokerMsg
ERR (ErrorType -> BrokerMsg) -> ErrorType -> BrokerMsg
forall a b. (a -> b) -> a -> b
$ CommandError -> ErrorType
CMD CommandError
PROHIBITED)
          | Bool
otherwise = do
              TVar ChaChaDRG
g <- (Env s -> TVar ChaChaDRG) -> ReaderT (Env s) IO (TVar ChaChaDRG)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> TVar ChaChaDRG
forall s. Env s -> TVar ChaChaDRG
random
              Int
idSize <- (Env s -> Int) -> ReaderT (Env s) IO Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Env s -> Int) -> ReaderT (Env s) IO Int)
-> (Env s -> Int) -> ReaderT (Env s) IO Int
forall a b. (a -> b) -> a -> b
$ ServerConfig s -> Int
forall s. ServerConfig s -> Int
queueIdBytes (ServerConfig s -> Int)
-> (Env s -> ServerConfig s) -> Env s -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env s -> ServerConfig s
forall s. Env s -> ServerConfig s
config
              Maybe SystemDate
updatedAt <- SystemDate -> Maybe SystemDate
forall a. a -> Maybe a
Just (SystemDate -> Maybe SystemDate)
-> ReaderT (Env s) IO SystemDate
-> ReaderT (Env s) IO (Maybe SystemDate)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO SystemDate -> ReaderT (Env s) IO SystemDate
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO SystemDate
getSystemDate
              (PublicKey 'X25519
rcvPublicDhKey, PrivateKey 'X25519
privDhKey) <- STM (PublicKey 'X25519, PrivateKey 'X25519)
-> ReaderT (Env s) IO (PublicKey 'X25519, PrivateKey 'X25519)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (PublicKey 'X25519, PrivateKey 'X25519)
 -> ReaderT (Env s) IO (PublicKey 'X25519, PrivateKey 'X25519))
-> STM (PublicKey 'X25519, PrivateKey 'X25519)
-> ReaderT (Env s) IO (PublicKey 'X25519, PrivateKey 'X25519)
forall a b. (a -> b) -> a -> b
$ TVar ChaChaDRG -> STM (KeyPair 'X25519)
forall (a :: Algorithm).
AlgorithmI a =>
TVar ChaChaDRG -> STM (KeyPair a)
C.generateKeyPair TVar ChaChaDRG
g
              Maybe (RcvPublicAuthKey, DhSecret 'X25519, PublicKey 'X25519)
ntfKeys_ <- Maybe NewNtfCreds
-> (NewNtfCreds
    -> ReaderT
         (Env s) IO (RcvPublicAuthKey, DhSecret 'X25519, PublicKey 'X25519))
-> ReaderT
     (Env s)
     IO
     (Maybe (RcvPublicAuthKey, DhSecret 'X25519, PublicKey 'X25519))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe NewNtfCreds
ntfCreds ((NewNtfCreds
  -> ReaderT
       (Env s) IO (RcvPublicAuthKey, DhSecret 'X25519, PublicKey 'X25519))
 -> ReaderT
      (Env s)
      IO
      (Maybe (RcvPublicAuthKey, DhSecret 'X25519, PublicKey 'X25519)))
-> (NewNtfCreds
    -> ReaderT
         (Env s) IO (RcvPublicAuthKey, DhSecret 'X25519, PublicKey 'X25519))
-> ReaderT
     (Env s)
     IO
     (Maybe (RcvPublicAuthKey, DhSecret 'X25519, PublicKey 'X25519))
forall a b. (a -> b) -> a -> b
$ \(NewNtfCreds RcvPublicAuthKey
notifierKey PublicKey 'X25519
dhKey) -> do
                (PublicKey 'X25519
ntfPubDhKey, PrivateKey 'X25519
ntfPrivDhKey) <- STM (PublicKey 'X25519, PrivateKey 'X25519)
-> ReaderT (Env s) IO (PublicKey 'X25519, PrivateKey 'X25519)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (PublicKey 'X25519, PrivateKey 'X25519)
 -> ReaderT (Env s) IO (PublicKey 'X25519, PrivateKey 'X25519))
-> STM (PublicKey 'X25519, PrivateKey 'X25519)
-> ReaderT (Env s) IO (PublicKey 'X25519, PrivateKey 'X25519)
forall a b. (a -> b) -> a -> b
$ TVar ChaChaDRG -> STM (KeyPair 'X25519)
forall (a :: Algorithm).
AlgorithmI a =>
TVar ChaChaDRG -> STM (KeyPair a)
C.generateKeyPair TVar ChaChaDRG
g
                (RcvPublicAuthKey, DhSecret 'X25519, PublicKey 'X25519)
-> ReaderT
     (Env s) IO (RcvPublicAuthKey, DhSecret 'X25519, PublicKey 'X25519)
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RcvPublicAuthKey
notifierKey, PublicKey 'X25519 -> PrivateKey 'X25519 -> DhSecret 'X25519
forall (a :: Algorithm).
DhAlgorithm a =>
PublicKey a -> PrivateKey a -> DhSecret a
C.dh' PublicKey 'X25519
dhKey PrivateKey 'X25519
ntfPrivDhKey, PublicKey 'X25519
ntfPubDhKey)
              let randId :: ReaderT (Env s) IO RecipientId
randId = ByteString -> RecipientId
EntityId (ByteString -> RecipientId)
-> ReaderT (Env s) IO ByteString -> ReaderT (Env s) IO RecipientId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM ByteString -> ReaderT (Env s) IO ByteString
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (Int -> TVar ChaChaDRG -> STM ByteString
C.randomBytes Int
idSize TVar ChaChaDRG
g)
                  -- the remaining 24 bytes are reserved, possibly for notifier ID in the new notifications protocol
                  sndId' :: ByteString
sndId' = Int -> ByteString -> ByteString
B.take Int
24 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
C.sha3_384 (CorrId -> ByteString
bs CorrId
corrId)
                  tryCreate :: Int -> ReaderT (Env s) IO BrokerMsg
tryCreate Int
0 = BrokerMsg -> ReaderT (Env s) IO BrokerMsg
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BrokerMsg -> ReaderT (Env s) IO BrokerMsg)
-> BrokerMsg -> ReaderT (Env s) IO BrokerMsg
forall a b. (a -> b) -> a -> b
$ ErrorType -> BrokerMsg
ERR ErrorType
INTERNAL
                  tryCreate Int
n = do
                    (RecipientId
sndId, Bool
clntIds, Maybe (RecipientId, QueueLinkData)
queueData) <- case Maybe QueueReqData
queueReqData of
                      Just (QRMessaging (Just (RecipientId
sId, QueueLinkData
d))) -> (\RecipientId
linkId -> (RecipientId
sId, Bool
True, (RecipientId, QueueLinkData) -> Maybe (RecipientId, QueueLinkData)
forall a. a -> Maybe a
Just (RecipientId
linkId, QueueLinkData
d))) (RecipientId
 -> (RecipientId, Bool, Maybe (RecipientId, QueueLinkData)))
-> ReaderT (Env s) IO RecipientId
-> ReaderT
     (Env s) IO (RecipientId, Bool, Maybe (RecipientId, QueueLinkData))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT (Env s) IO RecipientId
randId
                      Just (QRContact (Just (RecipientId
linkId, (RecipientId
sId, QueueLinkData
d)))) -> (RecipientId, Bool, Maybe (RecipientId, QueueLinkData))
-> ReaderT
     (Env s) IO (RecipientId, Bool, Maybe (RecipientId, QueueLinkData))
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RecipientId
sId, Bool
True, (RecipientId, QueueLinkData) -> Maybe (RecipientId, QueueLinkData)
forall a. a -> Maybe a
Just (RecipientId
linkId, QueueLinkData
d))
                      Maybe QueueReqData
_ -> (,Bool
False,Maybe (RecipientId, QueueLinkData)
forall a. Maybe a
Nothing) (RecipientId
 -> (RecipientId, Bool, Maybe (RecipientId, QueueLinkData)))
-> ReaderT (Env s) IO RecipientId
-> ReaderT
     (Env s) IO (RecipientId, Bool, Maybe (RecipientId, QueueLinkData))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT (Env s) IO RecipientId
randId
                    -- The condition that client-provided sender ID must match hash of correlation ID
                    -- prevents "ID oracle" attack, when creating queue with supplied ID can be used to check
                    -- if queue with this ID still exists.
                    if Bool
clntIds Bool -> Bool -> Bool
&& RecipientId -> ByteString
unEntityId RecipientId
sndId ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
sndId'
                      then BrokerMsg -> ReaderT (Env s) IO BrokerMsg
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BrokerMsg -> ReaderT (Env s) IO BrokerMsg)
-> BrokerMsg -> ReaderT (Env s) IO BrokerMsg
forall a b. (a -> b) -> a -> b
$ ErrorType -> BrokerMsg
ERR (ErrorType -> BrokerMsg) -> ErrorType -> BrokerMsg
forall a b. (a -> b) -> a -> b
$ CommandError -> ErrorType
CMD CommandError
PROHIBITED
                      else do
                        RecipientId
rcvId <- ReaderT (Env s) IO RecipientId
randId
                        Maybe (NtfCreds, ServerNtfCreds)
ntf <- Maybe (RcvPublicAuthKey, DhSecret 'X25519, PublicKey 'X25519)
-> ((RcvPublicAuthKey, DhSecret 'X25519, PublicKey 'X25519)
    -> ReaderT (Env s) IO (NtfCreds, ServerNtfCreds))
-> ReaderT (Env s) IO (Maybe (NtfCreds, ServerNtfCreds))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe (RcvPublicAuthKey, DhSecret 'X25519, PublicKey 'X25519)
ntfKeys_ (((RcvPublicAuthKey, DhSecret 'X25519, PublicKey 'X25519)
  -> ReaderT (Env s) IO (NtfCreds, ServerNtfCreds))
 -> ReaderT (Env s) IO (Maybe (NtfCreds, ServerNtfCreds)))
-> ((RcvPublicAuthKey, DhSecret 'X25519, PublicKey 'X25519)
    -> ReaderT (Env s) IO (NtfCreds, ServerNtfCreds))
-> ReaderT (Env s) IO (Maybe (NtfCreds, ServerNtfCreds))
forall a b. (a -> b) -> a -> b
$ \(RcvPublicAuthKey
notifierKey, DhSecret 'X25519
rcvNtfDhSecret, PublicKey 'X25519
rcvPubDhKey) -> do
                          RecipientId
notifierId <- ReaderT (Env s) IO RecipientId
randId
                          let ntfCreds' :: NtfCreds
ntfCreds' = NtfCreds {RecipientId
notifierId :: RecipientId
$sel:notifierId:NtfCreds :: RecipientId
notifierId, RcvPublicAuthKey
$sel:notifierKey:NtfCreds :: RcvPublicAuthKey
notifierKey :: RcvPublicAuthKey
notifierKey, DhSecret 'X25519
rcvNtfDhSecret :: DhSecret 'X25519
$sel:rcvNtfDhSecret:NtfCreds :: DhSecret 'X25519
rcvNtfDhSecret, $sel:ntfServiceId:NtfCreds :: Maybe RecipientId
ntfServiceId = Maybe RecipientId
forall a. Maybe a
Nothing}
                          (NtfCreds, ServerNtfCreds)
-> ReaderT (Env s) IO (NtfCreds, ServerNtfCreds)
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NtfCreds
ntfCreds', RecipientId -> PublicKey 'X25519 -> ServerNtfCreds
ServerNtfCreds RecipientId
notifierId PublicKey 'X25519
rcvPubDhKey)
                        let queueMode :: Maybe QueueMode
queueMode = QueueReqData -> QueueMode
queueReqMode (QueueReqData -> QueueMode)
-> Maybe QueueReqData -> Maybe QueueMode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe QueueReqData
queueReqData
                            qr :: QueueRec
qr =
                              QueueRec
                                { $sel:senderId:QueueRec :: RecipientId
senderId = RecipientId
sndId,
                                  $sel:recipientKeys:QueueRec :: NonEmpty RcvPublicAuthKey
recipientKeys = [Item (NonEmpty RcvPublicAuthKey)
RcvPublicAuthKey
rcvAuthKey],
                                  $sel:rcvDhSecret:QueueRec :: DhSecret 'X25519
rcvDhSecret = PublicKey 'X25519 -> PrivateKey 'X25519 -> DhSecret 'X25519
forall (a :: Algorithm).
DhAlgorithm a =>
PublicKey a -> PrivateKey a -> DhSecret a
C.dh' PublicKey 'X25519
rcvDhKey PrivateKey 'X25519
privDhKey,
                                  $sel:senderKey:QueueRec :: Maybe RcvPublicAuthKey
senderKey = Maybe RcvPublicAuthKey
forall a. Maybe a
Nothing,
                                  Maybe QueueMode
$sel:queueMode:QueueRec :: Maybe QueueMode
queueMode :: Maybe QueueMode
queueMode,
                                  Maybe (RecipientId, QueueLinkData)
$sel:queueData:QueueRec :: Maybe (RecipientId, QueueLinkData)
queueData :: Maybe (RecipientId, QueueLinkData)
queueData,
                                  $sel:notifier:QueueRec :: Maybe NtfCreds
notifier = (NtfCreds, ServerNtfCreds) -> NtfCreds
forall a b. (a, b) -> a
fst ((NtfCreds, ServerNtfCreds) -> NtfCreds)
-> Maybe (NtfCreds, ServerNtfCreds) -> Maybe NtfCreds
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (NtfCreds, ServerNtfCreds)
ntf,
                                  $sel:status:QueueRec :: ServerEntityStatus
status = ServerEntityStatus
EntityActive,
                                  Maybe SystemDate
$sel:updatedAt:QueueRec :: Maybe SystemDate
updatedAt :: Maybe SystemDate
updatedAt,
                                  $sel:rcvServiceId:QueueRec :: Maybe RecipientId
rcvServiceId = Maybe RecipientId
clntServiceId
                                }
                        IO (Either ErrorType (StoreQueue s))
-> ReaderT (Env s) IO (Either ErrorType (StoreQueue s))
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (s
-> RecipientId -> QueueRec -> IO (Either ErrorType (StoreQueue s))
forall s.
MsgStoreClass s =>
s
-> RecipientId -> QueueRec -> IO (Either ErrorType (StoreQueue s))
addQueue s
ms RecipientId
rcvId QueueRec
qr) ReaderT (Env s) IO (Either ErrorType (StoreQueue s))
-> (Either ErrorType (StoreQueue s)
    -> ReaderT (Env s) IO BrokerMsg)
-> ReaderT (Env s) IO BrokerMsg
forall a b.
ReaderT (Env s) IO a
-> (a -> ReaderT (Env s) IO b) -> ReaderT (Env s) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                          Left ErrorType
DUPLICATE_ -- TODO [short links] possibly, we somehow need to understand which IDs caused collision to retry if it's not client-supplied?
                            | Bool
clntIds -> BrokerMsg -> ReaderT (Env s) IO BrokerMsg
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BrokerMsg -> ReaderT (Env s) IO BrokerMsg)
-> BrokerMsg -> ReaderT (Env s) IO BrokerMsg
forall a b. (a -> b) -> a -> b
$ ErrorType -> BrokerMsg
ERR ErrorType
AUTH -- no retry on collision if sender ID is client-supplied
                            | Bool
otherwise -> Int -> ReaderT (Env s) IO BrokerMsg
tryCreate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
                          Left ErrorType
e -> BrokerMsg -> ReaderT (Env s) IO BrokerMsg
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BrokerMsg -> ReaderT (Env s) IO BrokerMsg)
-> BrokerMsg -> ReaderT (Env s) IO BrokerMsg
forall a b. (a -> b) -> a -> b
$ ErrorType -> BrokerMsg
ERR ErrorType
e
                          Right StoreQueue s
_q -> do
                            ServerStats
stats <- (Env s -> ServerStats) -> ReaderT (Env s) IO ServerStats
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> ServerStats
forall s. Env s -> ServerStats
serverStats
                            IORef Int -> M s ()
forall (m :: * -> *). MonadIO m => IORef Int -> m ()
incStat (IORef Int -> M s ()) -> IORef Int -> M s ()
forall a b. (a -> b) -> a -> b
$ ServerStats -> IORef Int
qCreated ServerStats
stats
                            IORef Int -> M s ()
forall (m :: * -> *). MonadIO m => IORef Int -> m ()
incStat (IORef Int -> M s ()) -> IORef Int -> M s ()
forall a b. (a -> b) -> a -> b
$ ServerStats -> IORef Int
qCount ServerStats
stats
                            Bool -> M s () -> M s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe (NtfCreds, ServerNtfCreds) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (NtfCreds, ServerNtfCreds)
ntf) (M s () -> M s ()) -> M s () -> M s ()
forall a b. (a -> b) -> a -> b
$ IORef Int -> M s ()
forall (m :: * -> *). MonadIO m => IORef Int -> m ()
incStat (IORef Int -> M s ()) -> IORef Int -> M s ()
forall a b. (a -> b) -> a -> b
$ ServerStats -> IORef Int
ntfNewCreated ServerStats
stats
                            case SubscriptionMode
subMode of
                              SubscriptionMode
SMOnlyCreate -> () -> M s ()
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                              SubscriptionMode
SMSubscribe -> RecipientId -> QueueRec -> M s ()
subscribeNewQueue RecipientId
rcvId QueueRec
qr -- no need to check if message is available, it's a new queue
                            BrokerMsg -> ReaderT (Env s) IO BrokerMsg
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BrokerMsg -> ReaderT (Env s) IO BrokerMsg)
-> BrokerMsg -> ReaderT (Env s) IO BrokerMsg
forall a b. (a -> b) -> a -> b
$ QueueIdsKeys -> BrokerMsg
IDS QIK {RecipientId
rcvId :: RecipientId
$sel:rcvId:QIK :: RecipientId
rcvId, RecipientId
sndId :: RecipientId
$sel:sndId:QIK :: RecipientId
sndId, PublicKey 'X25519
rcvPublicDhKey :: PublicKey 'X25519
$sel:rcvPublicDhKey:QIK :: PublicKey 'X25519
rcvPublicDhKey, Maybe QueueMode
queueMode :: Maybe QueueMode
$sel:queueMode:QIK :: Maybe QueueMode
queueMode, $sel:linkId:QIK :: Maybe RecipientId
linkId = (RecipientId, QueueLinkData) -> RecipientId
forall a b. (a, b) -> a
fst ((RecipientId, QueueLinkData) -> RecipientId)
-> Maybe (RecipientId, QueueLinkData) -> Maybe RecipientId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (RecipientId, QueueLinkData)
queueData, $sel:serviceId:QIK :: Maybe RecipientId
serviceId = Maybe RecipientId
clntServiceId, $sel:serverNtfCreds:QIK :: Maybe ServerNtfCreds
serverNtfCreds = (NtfCreds, ServerNtfCreds) -> ServerNtfCreds
forall a b. (a, b) -> b
snd ((NtfCreds, ServerNtfCreds) -> ServerNtfCreds)
-> Maybe (NtfCreds, ServerNtfCreds) -> Maybe ServerNtfCreds
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (NtfCreds, ServerNtfCreds)
ntf}
              (CorrId
corrId,RecipientId
entId,) (BrokerMsg -> Transmission BrokerMsg)
-> ReaderT (Env s) IO BrokerMsg -> M s (Transmission BrokerMsg)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> ReaderT (Env s) IO BrokerMsg
tryCreate (Int
3 :: Int)

        -- this check allows to support contact queues created prior to SKEY,
        -- using `queueMode == Just QMContact` would prevent it, as they have queueMode `Nothing`.
        checkContact :: QueueRec -> M s (Either ErrorType BrokerMsg) -> M s (Transmission BrokerMsg)
        checkContact :: QueueRec
-> M s (Either ErrorType BrokerMsg) -> M s (Transmission BrokerMsg)
checkContact QueueRec
qr M s (Either ErrorType BrokerMsg)
a =
          (ErrorType -> Transmission BrokerMsg)
-> (BrokerMsg -> Transmission BrokerMsg)
-> Either ErrorType BrokerMsg
-> Transmission BrokerMsg
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ErrorType -> Transmission BrokerMsg
err (CorrId
corrId,RecipientId
entId,)
            (Either ErrorType BrokerMsg -> Transmission BrokerMsg)
-> M s (Either ErrorType BrokerMsg) -> M s (Transmission BrokerMsg)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> if QueueRec -> Bool
isContactQueue QueueRec
qr then M s (Either ErrorType BrokerMsg)
a else Either ErrorType BrokerMsg -> M s (Either ErrorType BrokerMsg)
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrorType BrokerMsg -> M s (Either ErrorType BrokerMsg))
-> Either ErrorType BrokerMsg -> M s (Either ErrorType BrokerMsg)
forall a b. (a -> b) -> a -> b
$ ErrorType -> Either ErrorType BrokerMsg
forall a b. a -> Either a b
Left ErrorType
AUTH

        checkMode :: QueueMode -> QueueRec -> M s (Either ErrorType BrokerMsg) -> M s (Transmission BrokerMsg)
        checkMode :: QueueMode
-> QueueRec
-> M s (Either ErrorType BrokerMsg)
-> M s (Transmission BrokerMsg)
checkMode QueueMode
qm QueueRec {Maybe QueueMode
$sel:queueMode:QueueRec :: QueueRec -> Maybe QueueMode
queueMode :: Maybe QueueMode
queueMode} M s (Either ErrorType BrokerMsg)
a =
          (ErrorType -> Transmission BrokerMsg)
-> (BrokerMsg -> Transmission BrokerMsg)
-> Either ErrorType BrokerMsg
-> Transmission BrokerMsg
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ErrorType -> Transmission BrokerMsg
err (CorrId
corrId,RecipientId
entId,)
            (Either ErrorType BrokerMsg -> Transmission BrokerMsg)
-> M s (Either ErrorType BrokerMsg) -> M s (Transmission BrokerMsg)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> if Maybe QueueMode
queueMode Maybe QueueMode -> Maybe QueueMode -> Bool
forall a. Eq a => a -> a -> Bool
== QueueMode -> Maybe QueueMode
forall a. a -> Maybe a
Just QueueMode
qm then M s (Either ErrorType BrokerMsg)
a else Either ErrorType BrokerMsg -> M s (Either ErrorType BrokerMsg)
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrorType BrokerMsg -> M s (Either ErrorType BrokerMsg))
-> Either ErrorType BrokerMsg -> M s (Either ErrorType BrokerMsg)
forall a b. (a -> b) -> a -> b
$ ErrorType -> Either ErrorType BrokerMsg
forall a b. a -> Either a b
Left ErrorType
AUTH

        secureQueue_ :: StoreQueue s -> SndPublicAuthKey -> M s (Either ErrorType BrokerMsg)
        secureQueue_ :: StoreQueue s
-> RcvPublicAuthKey -> M s (Either ErrorType BrokerMsg)
secureQueue_ StoreQueue s
q RcvPublicAuthKey
sKey = do
          IO (Either ErrorType ())
-> ReaderT (Env s) IO (Either ErrorType ())
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (QueueStore s
-> StoreQueue s -> RcvPublicAuthKey -> IO (Either ErrorType ())
forall q s.
QueueStoreClass q s =>
s -> q -> RcvPublicAuthKey -> IO (Either ErrorType ())
secureQueue (s -> QueueStore s
forall s. MsgStoreClass s => s -> QueueStore s
queueStore s
ms) StoreQueue s
q RcvPublicAuthKey
sKey)
            ReaderT (Env s) IO (Either ErrorType ())
-> M s (Either ErrorType BrokerMsg)
-> M s (Either ErrorType BrokerMsg)
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Monad f, Traversable f) =>
m (f a) -> m (f b) -> m (f b)
$>> ((Env s -> ServerStats) -> ReaderT (Env s) IO ServerStats
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> ServerStats
forall s. Env s -> ServerStats
serverStats ReaderT (Env s) IO ServerStats -> (ServerStats -> M s ()) -> M s ()
forall a b.
ReaderT (Env s) IO a
-> (a -> ReaderT (Env s) IO b) -> ReaderT (Env s) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IORef Int -> M s ()
forall (m :: * -> *). MonadIO m => IORef Int -> m ()
incStat (IORef Int -> M s ())
-> (ServerStats -> IORef Int) -> ServerStats -> M s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerStats -> IORef Int
qSecured) M s ()
-> Either ErrorType BrokerMsg -> M s (Either ErrorType BrokerMsg)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> BrokerMsg -> Either ErrorType BrokerMsg
forall a b. b -> Either a b
Right BrokerMsg
OK

        getQueueLink_ :: StoreQueue s -> QueueRec -> M s (Either ErrorType BrokerMsg)
        getQueueLink_ :: StoreQueue s -> QueueRec -> M s (Either ErrorType BrokerMsg)
getQueueLink_ StoreQueue s
q QueueRec
qr = IO (Either ErrorType BrokerMsg) -> M s (Either ErrorType BrokerMsg)
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ErrorType BrokerMsg)
 -> M s (Either ErrorType BrokerMsg))
-> IO (Either ErrorType BrokerMsg)
-> M s (Either ErrorType BrokerMsg)
forall a b. (a -> b) -> a -> b
$ RecipientId -> QueueLinkData -> BrokerMsg
LNK (QueueRec -> RecipientId
senderId QueueRec
qr) (QueueLinkData -> BrokerMsg)
-> IO (Either ErrorType QueueLinkData)
-> IO (Either ErrorType BrokerMsg)
forall (f :: * -> *) (g :: * -> *) a b.
(Functor f, Functor g) =>
(a -> b) -> f (g a) -> f (g b)
<$$> QueueStore s
-> StoreQueue s
-> RecipientId
-> IO (Either ErrorType QueueLinkData)
forall q s.
QueueStoreClass q s =>
s -> q -> RecipientId -> IO (Either ErrorType QueueLinkData)
getQueueLinkData (s -> QueueStore s
forall s. MsgStoreClass s => s -> QueueStore s
queueStore s
ms) StoreQueue s
q RecipientId
entId

        addQueueNotifier_ :: StoreQueue s -> NtfPublicAuthKey -> RcvNtfPublicDhKey -> M s (Transmission BrokerMsg)
        addQueueNotifier_ :: StoreQueue s
-> RcvPublicAuthKey
-> PublicKey 'X25519
-> M s (Transmission BrokerMsg)
addQueueNotifier_ StoreQueue s
q RcvPublicAuthKey
notifierKey PublicKey 'X25519
dhKey = do
          (PublicKey 'X25519
rcvPublicDhKey, PrivateKey 'X25519
privDhKey) <- STM (PublicKey 'X25519, PrivateKey 'X25519)
-> ReaderT (Env s) IO (PublicKey 'X25519, PrivateKey 'X25519)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (PublicKey 'X25519, PrivateKey 'X25519)
 -> ReaderT (Env s) IO (PublicKey 'X25519, PrivateKey 'X25519))
-> (TVar ChaChaDRG -> STM (PublicKey 'X25519, PrivateKey 'X25519))
-> TVar ChaChaDRG
-> ReaderT (Env s) IO (PublicKey 'X25519, PrivateKey 'X25519)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar ChaChaDRG -> STM (KeyPair 'X25519)
TVar ChaChaDRG -> STM (PublicKey 'X25519, PrivateKey 'X25519)
forall (a :: Algorithm).
AlgorithmI a =>
TVar ChaChaDRG -> STM (KeyPair a)
C.generateKeyPair (TVar ChaChaDRG
 -> ReaderT (Env s) IO (PublicKey 'X25519, PrivateKey 'X25519))
-> ReaderT (Env s) IO (TVar ChaChaDRG)
-> ReaderT (Env s) IO (PublicKey 'X25519, PrivateKey 'X25519)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Env s -> TVar ChaChaDRG) -> ReaderT (Env s) IO (TVar ChaChaDRG)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> TVar ChaChaDRG
forall s. Env s -> TVar ChaChaDRG
random
          let rcvNtfDhSecret :: DhSecret 'X25519
rcvNtfDhSecret = PublicKey 'X25519 -> PrivateKey 'X25519 -> DhSecret 'X25519
forall (a :: Algorithm).
DhAlgorithm a =>
PublicKey a -> PrivateKey a -> DhSecret a
C.dh' PublicKey 'X25519
dhKey PrivateKey 'X25519
privDhKey
          (CorrId
corrId,RecipientId
entId,) (BrokerMsg -> Transmission BrokerMsg)
-> ReaderT (Env s) IO BrokerMsg -> M s (Transmission BrokerMsg)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> PublicKey 'X25519
-> DhSecret 'X25519
-> ReaderT (Env s) IO BrokerMsg
addNotifierRetry Int
3 PublicKey 'X25519
rcvPublicDhKey DhSecret 'X25519
rcvNtfDhSecret
          where
            addNotifierRetry :: Int -> RcvNtfPublicDhKey -> RcvNtfDhSecret -> M s BrokerMsg
            addNotifierRetry :: Int
-> PublicKey 'X25519
-> DhSecret 'X25519
-> ReaderT (Env s) IO BrokerMsg
addNotifierRetry Int
0 PublicKey 'X25519
_ DhSecret 'X25519
_ = BrokerMsg -> ReaderT (Env s) IO BrokerMsg
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BrokerMsg -> ReaderT (Env s) IO BrokerMsg)
-> BrokerMsg -> ReaderT (Env s) IO BrokerMsg
forall a b. (a -> b) -> a -> b
$ ErrorType -> BrokerMsg
ERR ErrorType
INTERNAL
            addNotifierRetry Int
n PublicKey 'X25519
rcvPublicDhKey DhSecret 'X25519
rcvNtfDhSecret = do
              RecipientId
notifierId <- Int -> ReaderT (Env s) IO RecipientId
forall s. Int -> M s RecipientId
randomId (Int -> ReaderT (Env s) IO RecipientId)
-> ReaderT (Env s) IO Int -> ReaderT (Env s) IO RecipientId
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Env s -> Int) -> ReaderT (Env s) IO Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerConfig s -> Int
forall s. ServerConfig s -> Int
queueIdBytes (ServerConfig s -> Int)
-> (Env s -> ServerConfig s) -> Env s -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env s -> ServerConfig s
forall s. Env s -> ServerConfig s
config)
              let ntfCreds :: NtfCreds
ntfCreds = NtfCreds {RecipientId
$sel:notifierId:NtfCreds :: RecipientId
notifierId :: RecipientId
notifierId, RcvPublicAuthKey
$sel:notifierKey:NtfCreds :: RcvPublicAuthKey
notifierKey :: RcvPublicAuthKey
notifierKey, DhSecret 'X25519
$sel:rcvNtfDhSecret:NtfCreds :: DhSecret 'X25519
rcvNtfDhSecret :: DhSecret 'X25519
rcvNtfDhSecret, $sel:ntfServiceId:NtfCreds :: Maybe RecipientId
ntfServiceId = Maybe RecipientId
forall a. Maybe a
Nothing}
              IO (Either ErrorType (Maybe NtfCreds))
-> ReaderT (Env s) IO (Either ErrorType (Maybe NtfCreds))
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (QueueStore s
-> StoreQueue s
-> NtfCreds
-> IO (Either ErrorType (Maybe NtfCreds))
forall q s.
QueueStoreClass q s =>
s -> q -> NtfCreds -> IO (Either ErrorType (Maybe NtfCreds))
addQueueNotifier (s -> QueueStore s
forall s. MsgStoreClass s => s -> QueueStore s
queueStore s
ms) StoreQueue s
q NtfCreds
ntfCreds) ReaderT (Env s) IO (Either ErrorType (Maybe NtfCreds))
-> (Either ErrorType (Maybe NtfCreds)
    -> ReaderT (Env s) IO BrokerMsg)
-> ReaderT (Env s) IO BrokerMsg
forall a b.
ReaderT (Env s) IO a
-> (a -> ReaderT (Env s) IO b) -> ReaderT (Env s) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Left ErrorType
DUPLICATE_ -> Int
-> PublicKey 'X25519
-> DhSecret 'X25519
-> ReaderT (Env s) IO BrokerMsg
addNotifierRetry (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) PublicKey 'X25519
rcvPublicDhKey DhSecret 'X25519
rcvNtfDhSecret
                Left ErrorType
e -> BrokerMsg -> ReaderT (Env s) IO BrokerMsg
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BrokerMsg -> ReaderT (Env s) IO BrokerMsg)
-> BrokerMsg -> ReaderT (Env s) IO BrokerMsg
forall a b. (a -> b) -> a -> b
$ ErrorType -> BrokerMsg
ERR ErrorType
e
                Right Maybe NtfCreds
nc_ -> do
                  IORef Int -> M s ()
forall (m :: * -> *). MonadIO m => IORef Int -> m ()
incStat (IORef Int -> M s ())
-> (ServerStats -> IORef Int) -> ServerStats -> M s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerStats -> IORef Int
ntfCreated (ServerStats -> M s ()) -> ReaderT (Env s) IO ServerStats -> M s ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Env s -> ServerStats) -> ReaderT (Env s) IO ServerStats
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> ServerStats
forall s. Env s -> ServerStats
serverStats
                  Maybe NtfCreds -> (NtfCreds -> M s ()) -> M s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe NtfCreds
nc_ ((NtfCreds -> M s ()) -> M s ()) -> (NtfCreds -> M s ()) -> M s ()
forall a b. (a -> b) -> a -> b
$ \NtfCreds {$sel:notifierId:NtfCreds :: NtfCreds -> RecipientId
notifierId = RecipientId
nId, Maybe RecipientId
$sel:ntfServiceId:NtfCreds :: NtfCreds -> Maybe RecipientId
ntfServiceId :: Maybe RecipientId
ntfServiceId} ->
                    STM () -> M s ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> M s ()) -> STM () -> M s ()
forall a b. (a -> b) -> a -> b
$ TQueue (ClientSub, Int) -> (ClientSub, Int) -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue (ServerSubscribers s -> TQueue (ClientSub, Int)
forall s. ServerSubscribers s -> TQueue (ClientSub, Int)
subQ ServerSubscribers s
ntfSubscribers) (RecipientId -> Maybe RecipientId -> ClientSub
CSDeleted RecipientId
nId Maybe RecipientId
ntfServiceId, Int
clientId)
                  BrokerMsg -> ReaderT (Env s) IO BrokerMsg
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BrokerMsg -> ReaderT (Env s) IO BrokerMsg)
-> BrokerMsg -> ReaderT (Env s) IO BrokerMsg
forall a b. (a -> b) -> a -> b
$ RecipientId -> PublicKey 'X25519 -> BrokerMsg
NID RecipientId
notifierId PublicKey 'X25519
rcvPublicDhKey

        deleteQueueNotifier_ :: StoreQueue s -> M s (Transmission BrokerMsg)
        deleteQueueNotifier_ :: StoreQueue s -> M s (Transmission BrokerMsg)
deleteQueueNotifier_ StoreQueue s
q =
          IO (Either ErrorType (Maybe NtfCreds))
-> ReaderT (Env s) IO (Either ErrorType (Maybe NtfCreds))
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (QueueStore s
-> StoreQueue s -> IO (Either ErrorType (Maybe NtfCreds))
forall q s.
QueueStoreClass q s =>
s -> q -> IO (Either ErrorType (Maybe NtfCreds))
deleteQueueNotifier (s -> QueueStore s
forall s. MsgStoreClass s => s -> QueueStore s
queueStore s
ms) StoreQueue s
q) ReaderT (Env s) IO (Either ErrorType (Maybe NtfCreds))
-> (Either ErrorType (Maybe NtfCreds)
    -> M s (Transmission BrokerMsg))
-> M s (Transmission BrokerMsg)
forall a b.
ReaderT (Env s) IO a
-> (a -> ReaderT (Env s) IO b) -> ReaderT (Env s) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Right (Just NtfCreds {$sel:notifierId:NtfCreds :: NtfCreds -> RecipientId
notifierId = RecipientId
nId, Maybe RecipientId
$sel:ntfServiceId:NtfCreds :: NtfCreds -> Maybe RecipientId
ntfServiceId :: Maybe RecipientId
ntfServiceId}) -> do
              -- Possibly, the same should be done if the queue is suspended, but currently we do not use it
              ServerStats
stats <- (Env s -> ServerStats) -> ReaderT (Env s) IO ServerStats
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> ServerStats
forall s. Env s -> ServerStats
serverStats
              Int
deleted <- (Env s -> NtfStore) -> ReaderT (Env s) IO NtfStore
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> NtfStore
forall s. Env s -> NtfStore
ntfStore ReaderT (Env s) IO NtfStore
-> (NtfStore -> ReaderT (Env s) IO Int) -> ReaderT (Env s) IO Int
forall a b.
ReaderT (Env s) IO a
-> (a -> ReaderT (Env s) IO b) -> ReaderT (Env s) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO Int -> ReaderT (Env s) IO Int
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> ReaderT (Env s) IO Int)
-> (NtfStore -> IO Int) -> NtfStore -> ReaderT (Env s) IO Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NtfStore -> RecipientId -> IO Int
`deleteNtfs` RecipientId
nId)
              Bool -> M s () -> M s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
deleted Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (M s () -> M s ()) -> M s () -> M s ()
forall a b. (a -> b) -> a -> b
$ IO () -> M s ()
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
forall a b. (a -> b) -> a -> b
$ IORef Int -> (Int -> Int) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef'_ (ServerStats -> IORef Int
ntfCount ServerStats
stats) (Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
deleted)
              STM () -> M s ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> M s ()) -> STM () -> M s ()
forall a b. (a -> b) -> a -> b
$ TQueue (ClientSub, Int) -> (ClientSub, Int) -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue (ServerSubscribers s -> TQueue (ClientSub, Int)
forall s. ServerSubscribers s -> TQueue (ClientSub, Int)
subQ ServerSubscribers s
ntfSubscribers) (RecipientId -> Maybe RecipientId -> ClientSub
CSDeleted RecipientId
nId Maybe RecipientId
ntfServiceId, Int
clientId)
              IORef Int -> M s ()
forall (m :: * -> *). MonadIO m => IORef Int -> m ()
incStat (IORef Int -> M s ()) -> IORef Int -> M s ()
forall a b. (a -> b) -> a -> b
$ ServerStats -> IORef Int
ntfDeleted ServerStats
stats
              Transmission BrokerMsg -> M s (Transmission BrokerMsg)
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Transmission BrokerMsg
ok
            Right Maybe NtfCreds
Nothing -> Transmission BrokerMsg -> M s (Transmission BrokerMsg)
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Transmission BrokerMsg
ok
            Left ErrorType
e -> Transmission BrokerMsg -> M s (Transmission BrokerMsg)
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Transmission BrokerMsg -> M s (Transmission BrokerMsg))
-> Transmission BrokerMsg -> M s (Transmission BrokerMsg)
forall a b. (a -> b) -> a -> b
$ ErrorType -> Transmission BrokerMsg
err ErrorType
e

        suspendQueue_ :: (StoreQueue s, QueueRec) -> M s (Transmission BrokerMsg)
        suspendQueue_ :: (StoreQueue s, QueueRec) -> M s (Transmission BrokerMsg)
suspendQueue_ (StoreQueue s
q, QueueRec
_) = IO (Transmission BrokerMsg) -> M s (Transmission BrokerMsg)
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Transmission BrokerMsg) -> M s (Transmission BrokerMsg))
-> IO (Transmission BrokerMsg) -> M s (Transmission BrokerMsg)
forall a b. (a -> b) -> a -> b
$ (ErrorType -> Transmission BrokerMsg)
-> (() -> Transmission BrokerMsg)
-> Either ErrorType ()
-> Transmission BrokerMsg
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ErrorType -> Transmission BrokerMsg
err (Transmission BrokerMsg -> () -> Transmission BrokerMsg
forall a b. a -> b -> a
const Transmission BrokerMsg
ok) (Either ErrorType () -> Transmission BrokerMsg)
-> IO (Either ErrorType ()) -> IO (Transmission BrokerMsg)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QueueStore s -> StoreQueue s -> IO (Either ErrorType ())
forall q s.
QueueStoreClass q s =>
s -> q -> IO (Either ErrorType ())
suspendQueue (s -> QueueStore s
forall s. MsgStoreClass s => s -> QueueStore s
queueStore s
ms) StoreQueue s
q

        -- TODO [certs rcv] if serviceId is passed, associate with the service and respond with SOK
        subscribeQueueAndDeliver :: StoreQueue s -> QueueRec -> M s ResponseAndMessage
        subscribeQueueAndDeliver :: StoreQueue s
-> QueueRec
-> M s (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
subscribeQueueAndDeliver StoreQueue s
q QueueRec
qr =
          IO (Maybe Sub) -> ReaderT (Env s) IO (Maybe Sub)
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (RecipientId -> TMap RecipientId Sub -> IO (Maybe Sub)
forall k a. Ord k => k -> TMap k a -> IO (Maybe a)
TM.lookupIO RecipientId
entId (TMap RecipientId Sub -> IO (Maybe Sub))
-> TMap RecipientId Sub -> IO (Maybe Sub)
forall a b. (a -> b) -> a -> b
$ Client s -> TMap RecipientId Sub
forall s. Client s -> TMap RecipientId Sub
subscriptions Client s
clnt) ReaderT (Env s) IO (Maybe Sub)
-> (Maybe Sub
    -> M s (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
-> M s (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
forall a b.
ReaderT (Env s) IO a
-> (a -> ReaderT (Env s) IO b) -> ReaderT (Env s) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe Sub
Nothing -> QueueRec -> M s Sub
subscribeRcvQueue QueueRec
qr M s Sub
-> (Sub
    -> M s (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
-> M s (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
forall a b.
ReaderT (Env s) IO a
-> (a -> ReaderT (Env s) IO b) -> ReaderT (Env s) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool
-> Sub
-> M s (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
deliver Bool
False
            Just s :: Sub
s@Sub {ServerSub
$sel:subThread:Sub :: Sub -> ServerSub
subThread :: ServerSub
subThread} -> do
              ServerStats
stats <- (Env s -> ServerStats) -> ReaderT (Env s) IO ServerStats
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> ServerStats
forall s. Env s -> ServerStats
serverStats
              case ServerSub
subThread of
                ServerSub
ProhibitSub -> do
                  -- cannot use SUB in the same connection where GET was used
                  IORef Int -> M s ()
forall (m :: * -> *). MonadIO m => IORef Int -> m ()
incStat (IORef Int -> M s ()) -> IORef Int -> M s ()
forall a b. (a -> b) -> a -> b
$ ServerStats -> IORef Int
qSubProhibited ServerStats
stats
                  (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
-> M s (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ErrorType -> Transmission BrokerMsg
err (CommandError -> ErrorType
CMD CommandError
PROHIBITED), Maybe (Transmission BrokerMsg)
forall a. Maybe a
Nothing)
                ServerSub
_ -> do
                  IORef Int -> M s ()
forall (m :: * -> *). MonadIO m => IORef Int -> m ()
incStat (IORef Int -> M s ()) -> IORef Int -> M s ()
forall a b. (a -> b) -> a -> b
$ ServerStats -> IORef Int
qSubDuplicate ServerStats
stats
                  STM () -> M s ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TVar (Maybe (ByteString, SystemSeconds))
-> Maybe (ByteString, SystemSeconds) -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (Sub -> TVar (Maybe (ByteString, SystemSeconds))
delivered Sub
s) Maybe (ByteString, SystemSeconds)
forall a. Maybe a
Nothing) M s ()
-> M s (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
-> M s (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
forall a b.
ReaderT (Env s) IO a
-> ReaderT (Env s) IO b -> ReaderT (Env s) IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool
-> Sub
-> M s (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
deliver Bool
True Sub
s
          where
            deliver :: Bool -> Sub -> M s ResponseAndMessage
            deliver :: Bool
-> Sub
-> M s (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
deliver Bool
hasSub Sub
sub = do
              ServerStats
stats <- (Env s -> ServerStats) -> ReaderT (Env s) IO ServerStats
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> ServerStats
forall s. Env s -> ServerStats
serverStats
              (Either
   ErrorType (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
 -> (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
-> ReaderT
     (Env s)
     IO
     (Either
        ErrorType (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
-> M s (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
forall a b.
(a -> b) -> ReaderT (Env s) IO a -> ReaderT (Env s) IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ErrorType
 -> (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
-> ((Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
    -> (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
-> Either
     ErrorType (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
-> (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((,Maybe (Transmission BrokerMsg)
forall a. Maybe a
Nothing) (Transmission BrokerMsg
 -> (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
-> (ErrorType -> Transmission BrokerMsg)
-> ErrorType
-> (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorType -> Transmission BrokerMsg
err) (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
-> (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
forall a. a -> a
id) (ReaderT
   (Env s)
   IO
   (Either
      ErrorType (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
 -> M s (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
-> ReaderT
     (Env s)
     IO
     (Either
        ErrorType (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
-> M s (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
forall a b. (a -> b) -> a -> b
$ IO
  (Either
     ErrorType (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
-> ReaderT
     (Env s)
     IO
     (Either
        ErrorType (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   (Either
      ErrorType (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
 -> ReaderT
      (Env s)
      IO
      (Either
         ErrorType
         (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))))
-> IO
     (Either
        ErrorType (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
-> ReaderT
     (Env s)
     IO
     (Either
        ErrorType (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
forall a b. (a -> b) -> a -> b
$ ExceptT
  ErrorType
  IO
  (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
-> IO
     (Either
        ErrorType (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT
   ErrorType
   IO
   (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
 -> IO
      (Either
         ErrorType
         (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))))
-> ExceptT
     ErrorType
     IO
     (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
-> IO
     (Either
        ErrorType (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
forall a b. (a -> b) -> a -> b
$ do
                Maybe Message
msg_ <- s -> StoreQueue s -> ExceptT ErrorType IO (Maybe Message)
forall s.
MsgStoreClass s =>
s -> StoreQueue s -> ExceptT ErrorType IO (Maybe Message)
tryPeekMsg s
ms StoreQueue s
q
                Maybe (Transmission BrokerMsg)
msg' <- Maybe Message
-> (Message -> ExceptT ErrorType IO (Transmission BrokerMsg))
-> ExceptT ErrorType IO (Maybe (Transmission BrokerMsg))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe Message
msg_ ((Message -> ExceptT ErrorType IO (Transmission BrokerMsg))
 -> ExceptT ErrorType IO (Maybe (Transmission BrokerMsg)))
-> (Message -> ExceptT ErrorType IO (Transmission BrokerMsg))
-> ExceptT ErrorType IO (Maybe (Transmission BrokerMsg))
forall a b. (a -> b) -> a -> b
$ \Message
msg -> IO (Transmission BrokerMsg)
-> ExceptT ErrorType IO (Transmission BrokerMsg)
forall a. IO a -> ExceptT ErrorType IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Transmission BrokerMsg)
 -> ExceptT ErrorType IO (Transmission BrokerMsg))
-> IO (Transmission BrokerMsg)
-> ExceptT ErrorType IO (Transmission BrokerMsg)
forall a b. (a -> b) -> a -> b
$ do
                  SystemSeconds
ts <- IO SystemSeconds
getSystemSeconds
                  STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Sub -> Message -> SystemSeconds -> STM ()
setDelivered Sub
sub Message
msg SystemSeconds
ts
                  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
hasSub (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef Int -> IO ()
forall (m :: * -> *). MonadIO m => IORef Int -> m ()
incStat (IORef Int -> IO ()) -> IORef Int -> IO ()
forall a b. (a -> b) -> a -> b
$ ServerStats -> IORef Int
qSub ServerStats
stats
                  Transmission BrokerMsg -> IO (Transmission BrokerMsg)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CorrId
NoCorrId, RecipientId
entId, RcvMessage -> BrokerMsg
MSG (QueueRec -> Message -> RcvMessage
encryptMsg QueueRec
qr Message
msg))
                (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
-> ExceptT
     ErrorType
     IO
     (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
forall a. a -> ExceptT ErrorType IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((CorrId
corrId, RecipientId
entId, Maybe RecipientId -> BrokerMsg
SOK Maybe RecipientId
clntServiceId), Maybe (Transmission BrokerMsg)
msg')

        -- TODO [certs rcv] combine with subscribing ntf queues
        subscribeRcvQueue :: QueueRec -> M s Sub
        subscribeRcvQueue :: QueueRec -> M s Sub
subscribeRcvQueue QueueRec {Maybe RecipientId
$sel:rcvServiceId:QueueRec :: QueueRec -> Maybe RecipientId
rcvServiceId :: Maybe RecipientId
rcvServiceId} = STM Sub -> M s Sub
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Sub -> M s Sub) -> STM Sub -> M s Sub
forall a b. (a -> b) -> a -> b
$ do
          TQueue (ClientSub, Int) -> (ClientSub, Int) -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue (ServerSubscribers s -> TQueue (ClientSub, Int)
forall s. ServerSubscribers s -> TQueue (ClientSub, Int)
subQ ServerSubscribers s
subscribers) (RecipientId -> Maybe RecipientId -> Maybe RecipientId -> ClientSub
CSClient RecipientId
entId Maybe RecipientId
rcvServiceId Maybe RecipientId
forall a. Maybe a
Nothing, Int
clientId)
          Sub
sub <- SubscriptionThread -> STM Sub
newSubscription SubscriptionThread
NoSub
          RecipientId -> Sub -> TMap RecipientId Sub -> STM ()
forall k a. Ord k => k -> a -> TMap k a -> STM ()
TM.insert RecipientId
entId Sub
sub (TMap RecipientId Sub -> STM ()) -> TMap RecipientId Sub -> STM ()
forall a b. (a -> b) -> a -> b
$ Client s -> TMap RecipientId Sub
forall s. Client s -> TMap RecipientId Sub
subscriptions Client s
clnt
          Sub -> STM Sub
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Sub
sub

        subscribeNewQueue :: RecipientId -> QueueRec -> M s ()
        subscribeNewQueue :: RecipientId -> QueueRec -> M s ()
subscribeNewQueue RecipientId
rId QueueRec {Maybe RecipientId
$sel:rcvServiceId:QueueRec :: QueueRec -> Maybe RecipientId
rcvServiceId :: Maybe RecipientId
rcvServiceId} = do
          case Maybe RecipientId
rcvServiceId of
            Just RecipientId
_ -> STM () -> M s ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> M s ()) -> STM () -> M s ()
forall a b. (a -> b) -> a -> b
$ TVar Int64 -> (Int64 -> Int64) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (Client s -> TVar Int64
forall s. Client s -> TVar Int64
serviceSubsCount Client s
clnt) (Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
1)
            Maybe RecipientId
Nothing -> do
              Sub
sub <- STM Sub -> M s Sub
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Sub -> M s Sub) -> STM Sub -> M s Sub
forall a b. (a -> b) -> a -> b
$ SubscriptionThread -> STM Sub
newSubscription SubscriptionThread
NoSub
              STM () -> M s ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> M s ()) -> STM () -> M s ()
forall a b. (a -> b) -> a -> b
$ RecipientId -> Sub -> TMap RecipientId Sub -> STM ()
forall k a. Ord k => k -> a -> TMap k a -> STM ()
TM.insert RecipientId
rId Sub
sub (TMap RecipientId Sub -> STM ()) -> TMap RecipientId Sub -> STM ()
forall a b. (a -> b) -> a -> b
$ Client s -> TMap RecipientId Sub
forall s. Client s -> TMap RecipientId Sub
subscriptions Client s
clnt
          STM () -> M s ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> M s ()) -> STM () -> M s ()
forall a b. (a -> b) -> a -> b
$ TQueue (ClientSub, Int) -> (ClientSub, Int) -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue (ServerSubscribers s -> TQueue (ClientSub, Int)
forall s. ServerSubscribers s -> TQueue (ClientSub, Int)
subQ ServerSubscribers s
subscribers) (RecipientId -> Maybe RecipientId -> Maybe RecipientId -> ClientSub
CSClient RecipientId
rId Maybe RecipientId
rcvServiceId Maybe RecipientId
rcvServiceId, Int
clientId)

        -- clients that use GET are not added to server subscribers
        getMessage :: StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg)
        getMessage :: StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg)
getMessage StoreQueue s
q QueueRec
qr = do
          STM (Maybe Sub) -> ReaderT (Env s) IO (Maybe Sub)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (RecipientId -> TMap RecipientId Sub -> STM (Maybe Sub)
forall k a. Ord k => k -> TMap k a -> STM (Maybe a)
TM.lookup RecipientId
entId (TMap RecipientId Sub -> STM (Maybe Sub))
-> TMap RecipientId Sub -> STM (Maybe Sub)
forall a b. (a -> b) -> a -> b
$ Client s -> TMap RecipientId Sub
forall s. Client s -> TMap RecipientId Sub
subscriptions Client s
clnt) ReaderT (Env s) IO (Maybe Sub)
-> (Maybe Sub -> M s (Transmission BrokerMsg))
-> M s (Transmission BrokerMsg)
forall a b.
ReaderT (Env s) IO a
-> (a -> ReaderT (Env s) IO b) -> ReaderT (Env s) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe Sub
Nothing ->
              STM Sub -> M s Sub
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically STM Sub
newSub M s Sub
-> (Sub -> M s (Transmission BrokerMsg))
-> M s (Transmission BrokerMsg)
forall a b.
ReaderT (Env s) IO a
-> (a -> ReaderT (Env s) IO b) -> ReaderT (Env s) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Sub
-> Maybe (ByteString, SystemSeconds)
-> M s (Transmission BrokerMsg)
`getMessage_` Maybe (ByteString, SystemSeconds)
forall a. Maybe a
Nothing)
            Just s :: Sub
s@Sub {ServerSub
$sel:subThread:Sub :: Sub -> ServerSub
subThread :: ServerSub
subThread} ->
              case ServerSub
subThread of
                ServerSub
ProhibitSub ->
                  STM (Maybe (ByteString, SystemSeconds))
-> ReaderT (Env s) IO (Maybe (ByteString, SystemSeconds))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TVar (Maybe (ByteString, SystemSeconds))
-> Maybe (ByteString, SystemSeconds)
-> STM (Maybe (ByteString, SystemSeconds))
forall a. TVar a -> a -> STM a
swapTVar (Sub -> TVar (Maybe (ByteString, SystemSeconds))
delivered Sub
s) Maybe (ByteString, SystemSeconds)
forall a. Maybe a
Nothing)
                    ReaderT (Env s) IO (Maybe (ByteString, SystemSeconds))
-> (Maybe (ByteString, SystemSeconds)
    -> M s (Transmission BrokerMsg))
-> M s (Transmission BrokerMsg)
forall a b.
ReaderT (Env s) IO a
-> (a -> ReaderT (Env s) IO b) -> ReaderT (Env s) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Sub
-> Maybe (ByteString, SystemSeconds)
-> M s (Transmission BrokerMsg)
getMessage_ Sub
s
                -- cannot use GET in the same connection where there is an active subscription
                ServerSub
_ -> do
                  ServerStats
stats <- (Env s -> ServerStats) -> ReaderT (Env s) IO ServerStats
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> ServerStats
forall s. Env s -> ServerStats
serverStats
                  IORef Int -> M s ()
forall (m :: * -> *). MonadIO m => IORef Int -> m ()
incStat (IORef Int -> M s ()) -> IORef Int -> M s ()
forall a b. (a -> b) -> a -> b
$ ServerStats -> IORef Int
msgGetProhibited ServerStats
stats
                  Transmission BrokerMsg -> M s (Transmission BrokerMsg)
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Transmission BrokerMsg -> M s (Transmission BrokerMsg))
-> Transmission BrokerMsg -> M s (Transmission BrokerMsg)
forall a b. (a -> b) -> a -> b
$ ErrorType -> Transmission BrokerMsg
err (ErrorType -> Transmission BrokerMsg)
-> ErrorType -> Transmission BrokerMsg
forall a b. (a -> b) -> a -> b
$ CommandError -> ErrorType
CMD CommandError
PROHIBITED
          where
            newSub :: STM Sub
            newSub :: STM Sub
newSub = do
              Sub
s <- STM Sub
newProhibitedSub
              RecipientId -> Sub -> TMap RecipientId Sub -> STM ()
forall k a. Ord k => k -> a -> TMap k a -> STM ()
TM.insert RecipientId
entId Sub
s (TMap RecipientId Sub -> STM ()) -> TMap RecipientId Sub -> STM ()
forall a b. (a -> b) -> a -> b
$ Client s -> TMap RecipientId Sub
forall s. Client s -> TMap RecipientId Sub
subscriptions Client s
clnt
              -- Here we don't account for this client as subscribed in the server
              -- and don't notify other subscribed clients.
              -- This is tracked as "subscription" in the client to prevent these
              -- clients from being able to subscribe.
              Sub -> STM Sub
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Sub
s
            getMessage_ :: Sub -> Maybe (MsgId, SystemSeconds) -> M s (Transmission BrokerMsg)
            getMessage_ :: Sub
-> Maybe (ByteString, SystemSeconds)
-> M s (Transmission BrokerMsg)
getMessage_ Sub
s Maybe (ByteString, SystemSeconds)
delivered_ = do
              ServerStats
stats <- (Env s -> ServerStats) -> ReaderT (Env s) IO ServerStats
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> ServerStats
forall s. Env s -> ServerStats
serverStats
              (Either ErrorType (Transmission BrokerMsg)
 -> Transmission BrokerMsg)
-> ReaderT (Env s) IO (Either ErrorType (Transmission BrokerMsg))
-> M s (Transmission BrokerMsg)
forall a b.
(a -> b) -> ReaderT (Env s) IO a -> ReaderT (Env s) IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ErrorType -> Transmission BrokerMsg)
-> (Transmission BrokerMsg -> Transmission BrokerMsg)
-> Either ErrorType (Transmission BrokerMsg)
-> Transmission BrokerMsg
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ErrorType -> Transmission BrokerMsg
err Transmission BrokerMsg -> Transmission BrokerMsg
forall a. a -> a
id) (ReaderT (Env s) IO (Either ErrorType (Transmission BrokerMsg))
 -> M s (Transmission BrokerMsg))
-> ReaderT (Env s) IO (Either ErrorType (Transmission BrokerMsg))
-> M s (Transmission BrokerMsg)
forall a b. (a -> b) -> a -> b
$ IO (Either ErrorType (Transmission BrokerMsg))
-> ReaderT (Env s) IO (Either ErrorType (Transmission BrokerMsg))
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ErrorType (Transmission BrokerMsg))
 -> ReaderT (Env s) IO (Either ErrorType (Transmission BrokerMsg)))
-> IO (Either ErrorType (Transmission BrokerMsg))
-> ReaderT (Env s) IO (Either ErrorType (Transmission BrokerMsg))
forall a b. (a -> b) -> a -> b
$ ExceptT ErrorType IO (Transmission BrokerMsg)
-> IO (Either ErrorType (Transmission BrokerMsg))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ErrorType IO (Transmission BrokerMsg)
 -> IO (Either ErrorType (Transmission BrokerMsg)))
-> ExceptT ErrorType IO (Transmission BrokerMsg)
-> IO (Either ErrorType (Transmission BrokerMsg))
forall a b. (a -> b) -> a -> b
$
                s -> StoreQueue s -> ExceptT ErrorType IO (Maybe Message)
forall s.
MsgStoreClass s =>
s -> StoreQueue s -> ExceptT ErrorType IO (Maybe Message)
tryPeekMsg s
ms StoreQueue s
q ExceptT ErrorType IO (Maybe Message)
-> (Maybe Message -> ExceptT ErrorType IO (Transmission BrokerMsg))
-> ExceptT ErrorType IO (Transmission BrokerMsg)
forall a b.
ExceptT ErrorType IO a
-> (a -> ExceptT ErrorType IO b) -> ExceptT ErrorType IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                  Just Message
msg -> do
                    let encMsg :: RcvMessage
encMsg = QueueRec -> Message -> RcvMessage
encryptMsg QueueRec
qr Message
msg
                    IORef Int -> ExceptT ErrorType IO ()
forall (m :: * -> *). MonadIO m => IORef Int -> m ()
incStat (IORef Int -> ExceptT ErrorType IO ())
-> IORef Int -> ExceptT ErrorType IO ()
forall a b. (a -> b) -> a -> b
$ (if Maybe (ByteString, SystemSeconds) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (ByteString, SystemSeconds)
delivered_ then ServerStats -> IORef Int
msgGetDuplicate else ServerStats -> IORef Int
msgGet) ServerStats
stats
                    SystemSeconds
ts <- IO SystemSeconds -> ExceptT ErrorType IO SystemSeconds
forall a. IO a -> ExceptT ErrorType IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO SystemSeconds
getSystemSeconds
                    STM (Transmission BrokerMsg)
-> ExceptT ErrorType IO (Transmission BrokerMsg)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Transmission BrokerMsg)
 -> ExceptT ErrorType IO (Transmission BrokerMsg))
-> STM (Transmission BrokerMsg)
-> ExceptT ErrorType IO (Transmission BrokerMsg)
forall a b. (a -> b) -> a -> b
$ Sub -> Message -> SystemSeconds -> STM ()
setDelivered Sub
s Message
msg SystemSeconds
ts STM () -> Transmission BrokerMsg -> STM (Transmission BrokerMsg)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (CorrId
corrId, RecipientId
entId, RcvMessage -> BrokerMsg
MSG RcvMessage
encMsg)
                  Maybe Message
Nothing -> IORef Int -> ExceptT ErrorType IO ()
forall (m :: * -> *). MonadIO m => IORef Int -> m ()
incStat (ServerStats -> IORef Int
msgGetNoMsg ServerStats
stats) ExceptT ErrorType IO ()
-> Transmission BrokerMsg
-> ExceptT ErrorType IO (Transmission BrokerMsg)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Transmission BrokerMsg
ok

        withQueue :: (StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg)) -> M s (Maybe ResponseAndMessage)
        withQueue :: (StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg))
-> ReaderT
     (Env s)
     IO
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
withQueue = (Transmission BrokerMsg
 -> Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
-> M s (Transmission BrokerMsg)
-> ReaderT
     (Env s)
     IO
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
forall a b.
(a -> b) -> ReaderT (Env s) IO a -> ReaderT (Env s) IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Transmission BrokerMsg
-> Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
response (M s (Transmission BrokerMsg)
 -> ReaderT
      (Env s)
      IO
      (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))))
-> ((StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg))
    -> M s (Transmission BrokerMsg))
-> (StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg))
-> ReaderT
     (Env s)
     IO
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool
-> (ErrorType -> Transmission BrokerMsg)
-> (StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg))
-> M s (Transmission BrokerMsg)
forall r.
Bool
-> (ErrorType -> r) -> (StoreQueue s -> QueueRec -> M s r) -> M s r
withQueue_ Bool
True ErrorType -> Transmission BrokerMsg
err
        {-# INLINE withQueue #-}

        withQueue' :: (StoreQueue s -> QueueRec -> M s ResponseAndMessage) -> M s (Maybe ResponseAndMessage)
        withQueue' :: (StoreQueue s
 -> QueueRec
 -> M s (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
-> ReaderT
     (Env s)
     IO
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
withQueue' = ((Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
 -> Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
-> M s (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
-> ReaderT
     (Env s)
     IO
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
forall a b.
(a -> b) -> ReaderT (Env s) IO a -> ReaderT (Env s) IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
-> Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
forall a. a -> Maybe a
Just (M s (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
 -> ReaderT
      (Env s)
      IO
      (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))))
-> ((StoreQueue s
     -> QueueRec
     -> M s (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
    -> M s (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
-> (StoreQueue s
    -> QueueRec
    -> M s (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
-> ReaderT
     (Env s)
     IO
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool
-> (ErrorType
    -> (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
-> (StoreQueue s
    -> QueueRec
    -> M s (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
-> M s (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
forall r.
Bool
-> (ErrorType -> r) -> (StoreQueue s -> QueueRec -> M s r) -> M s r
withQueue_ Bool
True ((,Maybe (Transmission BrokerMsg)
forall a. Maybe a
Nothing) (Transmission BrokerMsg
 -> (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
-> (ErrorType -> Transmission BrokerMsg)
-> ErrorType
-> (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorType -> Transmission BrokerMsg
err)
        {-# INLINE withQueue' #-}

        -- SEND passes queueNotBlocked False here to update time, but it fails anyway on blocked queues (see code for SEND).
        withQueue_ :: Bool -> (ErrorType -> r) -> (StoreQueue s -> QueueRec -> M s r) -> M s r
        withQueue_ :: forall r.
Bool
-> (ErrorType -> r) -> (StoreQueue s -> QueueRec -> M s r) -> M s r
withQueue_ Bool
queueNotBlocked ErrorType -> r
err' StoreQueue s -> QueueRec -> M s r
action = case Maybe (StoreQueue s, QueueRec)
q_ of
          Maybe (StoreQueue s, QueueRec)
Nothing -> r -> M s r
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (r -> M s r) -> r -> M s r
forall a b. (a -> b) -> a -> b
$ ErrorType -> r
err' ErrorType
INTERNAL
          Just (StoreQueue s
q, qr :: QueueRec
qr@QueueRec {ServerEntityStatus
$sel:status:QueueRec :: QueueRec -> ServerEntityStatus
status :: ServerEntityStatus
status, Maybe SystemDate
$sel:updatedAt:QueueRec :: QueueRec -> Maybe SystemDate
updatedAt :: Maybe SystemDate
updatedAt}) -> case ServerEntityStatus
status of
            EntityBlocked BlockingInfo
info | Bool
queueNotBlocked -> r -> M s r
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (r -> M s r) -> r -> M s r
forall a b. (a -> b) -> a -> b
$ ErrorType -> r
err' (ErrorType -> r) -> ErrorType -> r
forall a b. (a -> b) -> a -> b
$ BlockingInfo -> ErrorType
BLOCKED BlockingInfo
info
            ServerEntityStatus
_ -> do
              SystemDate
t <- IO SystemDate -> ReaderT (Env s) IO SystemDate
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO SystemDate
getSystemDate
              if 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
                then StoreQueue s -> QueueRec -> M s r
action StoreQueue s
q QueueRec
qr
                else IO (Either ErrorType QueueRec)
-> ReaderT (Env s) IO (Either ErrorType QueueRec)
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (QueueStore s
-> StoreQueue s -> SystemDate -> IO (Either ErrorType QueueRec)
forall q s.
QueueStoreClass q s =>
s -> q -> SystemDate -> IO (Either ErrorType QueueRec)
updateQueueTime (s -> QueueStore s
forall s. MsgStoreClass s => s -> QueueStore s
queueStore s
ms) StoreQueue s
q SystemDate
t) ReaderT (Env s) IO (Either ErrorType QueueRec)
-> (Either ErrorType QueueRec -> M s r) -> M s r
forall a b.
ReaderT (Env s) IO a
-> (a -> ReaderT (Env s) IO b) -> ReaderT (Env s) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ErrorType -> M s r)
-> (QueueRec -> M s r) -> Either ErrorType QueueRec -> M s r
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (r -> M s r
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (r -> M s r) -> (ErrorType -> r) -> ErrorType -> M s r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorType -> r
err') (StoreQueue s -> QueueRec -> M s r
action StoreQueue s
q)

        subscribeNotifications :: StoreQueue s -> NtfCreds -> M s BrokerMsg
        subscribeNotifications :: StoreQueue s -> NtfCreds -> ReaderT (Env s) IO BrokerMsg
subscribeNotifications StoreQueue s
q NtfCreds {Maybe RecipientId
$sel:ntfServiceId:NtfCreds :: NtfCreds -> Maybe RecipientId
ntfServiceId :: Maybe RecipientId
ntfServiceId} = do
          ServerStats
stats <- (Env s -> ServerStats) -> ReaderT (Env s) IO ServerStats
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> ServerStats
forall s. Env s -> ServerStats
serverStats
          let incNtfSrvStat :: (ServiceStats -> IORef Int) -> M s ()
incNtfSrvStat ServiceStats -> IORef Int
sel = IORef Int -> M s ()
forall (m :: * -> *). MonadIO m => IORef Int -> m ()
incStat (IORef Int -> M s ()) -> IORef Int -> M s ()
forall a b. (a -> b) -> a -> b
$ ServiceStats -> IORef Int
sel (ServiceStats -> IORef Int) -> ServiceStats -> IORef Int
forall a b. (a -> b) -> a -> b
$ ServerStats -> ServiceStats
ntfServices ServerStats
stats
          case Maybe RecipientId
clntServiceId of
            Just RecipientId
serviceId
              | Maybe RecipientId
ntfServiceId Maybe RecipientId -> Maybe RecipientId -> Bool
forall a. Eq a => a -> a -> Bool
== RecipientId -> Maybe RecipientId
forall a. a -> Maybe a
Just RecipientId
serviceId -> do
                  -- duplicate queue-service association - can only happen in case of response error/timeout
                  Bool
hasSub <- STM Bool -> ReaderT (Env s) IO Bool
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Bool -> ReaderT (Env s) IO Bool)
-> STM Bool -> ReaderT (Env s) IO Bool
forall a b. (a -> b) -> a -> b
$ STM Bool -> STM Bool -> STM Bool -> STM Bool
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM STM Bool
hasServiceSub (Bool -> STM Bool
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True) (Bool
False Bool -> STM () -> STM Bool
forall a b. a -> STM b -> STM a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ STM ()
newServiceQueueSub)
                  Bool -> M s () -> M s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
hasSub (M s () -> M s ()) -> M s () -> M s ()
forall a b. (a -> b) -> a -> b
$ do
                    (ServiceStats -> IORef Int) -> M s ()
incNtfSrvStat ServiceStats -> IORef Int
srvSubCount
                    (ServiceStats -> IORef Int) -> M s ()
incNtfSrvStat ServiceStats -> IORef Int
srvSubQueues
                  (ServiceStats -> IORef Int) -> M s ()
incNtfSrvStat ServiceStats -> IORef Int
srvAssocDuplicate
                  BrokerMsg -> ReaderT (Env s) IO BrokerMsg
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BrokerMsg -> ReaderT (Env s) IO BrokerMsg)
-> BrokerMsg -> ReaderT (Env s) IO BrokerMsg
forall a b. (a -> b) -> a -> b
$ Maybe RecipientId -> BrokerMsg
SOK (Maybe RecipientId -> BrokerMsg) -> Maybe RecipientId -> BrokerMsg
forall a b. (a -> b) -> a -> b
$ RecipientId -> Maybe RecipientId
forall a. a -> Maybe a
Just RecipientId
serviceId
              | Bool
otherwise ->
                  -- new or updated queue-service association
                  IO (Either ErrorType ())
-> ReaderT (Env s) IO (Either ErrorType ())
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (QueueStore s
-> StoreQueue s
-> SParty 'NotifierService
-> Maybe RecipientId
-> IO (Either ErrorType ())
forall q s (p :: Party).
(QueueStoreClass q s, PartyI p, ServiceParty p) =>
s -> q -> SParty p -> Maybe RecipientId -> IO (Either ErrorType ())
forall (p :: Party).
(PartyI p, ServiceParty p) =>
QueueStore s
-> StoreQueue s
-> SParty p
-> Maybe RecipientId
-> IO (Either ErrorType ())
setQueueService (s -> QueueStore s
forall s. MsgStoreClass s => s -> QueueStore s
queueStore s
ms) StoreQueue s
q SParty 'NotifierService
SNotifierService (RecipientId -> Maybe RecipientId
forall a. a -> Maybe a
Just RecipientId
serviceId)) ReaderT (Env s) IO (Either ErrorType ())
-> (Either ErrorType () -> ReaderT (Env s) IO BrokerMsg)
-> ReaderT (Env s) IO BrokerMsg
forall a b.
ReaderT (Env s) IO a
-> (a -> ReaderT (Env s) IO b) -> ReaderT (Env s) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                    Left ErrorType
e -> BrokerMsg -> ReaderT (Env s) IO BrokerMsg
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BrokerMsg -> ReaderT (Env s) IO BrokerMsg)
-> BrokerMsg -> ReaderT (Env s) IO BrokerMsg
forall a b. (a -> b) -> a -> b
$ ErrorType -> BrokerMsg
ERR ErrorType
e
                    Right () -> do
                      Bool
hasSub <- STM Bool -> ReaderT (Env s) IO Bool
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Bool -> ReaderT (Env s) IO Bool)
-> STM Bool -> ReaderT (Env s) IO Bool
forall a b. (a -> b) -> a -> b
$ (Bool -> STM () -> STM Bool
forall a b. a -> STM b -> STM a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ STM ()
newServiceQueueSub) (Bool -> STM Bool) -> STM Bool -> STM Bool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< STM Bool
hasServiceSub
                      Bool -> M s () -> M s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
hasSub (M s () -> M s ()) -> M s () -> M s ()
forall a b. (a -> b) -> a -> b
$ (ServiceStats -> IORef Int) -> M s ()
incNtfSrvStat ServiceStats -> IORef Int
srvSubCount
                      (ServiceStats -> IORef Int) -> M s ()
incNtfSrvStat ServiceStats -> IORef Int
srvSubQueues
                      (ServiceStats -> IORef Int) -> M s ()
incNtfSrvStat ((ServiceStats -> IORef Int) -> M s ())
-> (ServiceStats -> IORef Int) -> M s ()
forall a b. (a -> b) -> a -> b
$ (ServiceStats -> IORef Int)
-> (RecipientId -> ServiceStats -> IORef Int)
-> Maybe RecipientId
-> ServiceStats
-> IORef Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ServiceStats -> IORef Int
srvAssocNew ((ServiceStats -> IORef Int)
-> RecipientId -> ServiceStats -> IORef Int
forall a b. a -> b -> a
const ServiceStats -> IORef Int
srvAssocUpdated) Maybe RecipientId
ntfServiceId
                      BrokerMsg -> ReaderT (Env s) IO BrokerMsg
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BrokerMsg -> ReaderT (Env s) IO BrokerMsg)
-> BrokerMsg -> ReaderT (Env s) IO BrokerMsg
forall a b. (a -> b) -> a -> b
$ Maybe RecipientId -> BrokerMsg
SOK (Maybe RecipientId -> BrokerMsg) -> Maybe RecipientId -> BrokerMsg
forall a b. (a -> b) -> a -> b
$ RecipientId -> Maybe RecipientId
forall a. a -> Maybe a
Just RecipientId
serviceId
              where
                hasServiceSub :: STM Bool
hasServiceSub = (Int64
0 Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
/=) (Int64 -> Bool) -> STM Int64 -> STM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar Int64 -> STM Int64
forall a. TVar a -> STM a
readTVar TVar Int64
ntfServiceSubsCount
                -- This function is used when queue is associated with the service.
                newServiceQueueSub :: STM ()
newServiceQueueSub = do
                  TQueue (ClientSub, Int) -> (ClientSub, Int) -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue (ServerSubscribers s -> TQueue (ClientSub, Int)
forall s. ServerSubscribers s -> TQueue (ClientSub, Int)
subQ ServerSubscribers s
ntfSubscribers) (RecipientId -> Maybe RecipientId -> Maybe RecipientId -> ClientSub
CSClient RecipientId
entId Maybe RecipientId
ntfServiceId (RecipientId -> Maybe RecipientId
forall a. a -> Maybe a
Just RecipientId
serviceId), Int
clientId)
                  TVar Int64 -> (Int64 -> Int64) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int64
ntfServiceSubsCount (Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
1) -- service count
                  TVar Int64 -> (Int64 -> Int64) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (ServerSubscribers s -> TVar Int64
forall s. ServerSubscribers s -> TVar Int64
totalServiceSubs ServerSubscribers s
ntfSubscribers) (Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
1) -- server count for all services
            Maybe RecipientId
Nothing -> case Maybe RecipientId
ntfServiceId of
              Just RecipientId
_ ->
                IO (Either ErrorType ())
-> ReaderT (Env s) IO (Either ErrorType ())
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (QueueStore s
-> StoreQueue s
-> SParty 'NotifierService
-> Maybe RecipientId
-> IO (Either ErrorType ())
forall q s (p :: Party).
(QueueStoreClass q s, PartyI p, ServiceParty p) =>
s -> q -> SParty p -> Maybe RecipientId -> IO (Either ErrorType ())
forall (p :: Party).
(PartyI p, ServiceParty p) =>
QueueStore s
-> StoreQueue s
-> SParty p
-> Maybe RecipientId
-> IO (Either ErrorType ())
setQueueService (s -> QueueStore s
forall s. MsgStoreClass s => s -> QueueStore s
queueStore s
ms) StoreQueue s
q SParty 'NotifierService
SNotifierService Maybe RecipientId
forall a. Maybe a
Nothing) ReaderT (Env s) IO (Either ErrorType ())
-> (Either ErrorType () -> ReaderT (Env s) IO BrokerMsg)
-> ReaderT (Env s) IO BrokerMsg
forall a b.
ReaderT (Env s) IO a
-> (a -> ReaderT (Env s) IO b) -> ReaderT (Env s) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                  Left ErrorType
e -> BrokerMsg -> ReaderT (Env s) IO BrokerMsg
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BrokerMsg -> ReaderT (Env s) IO BrokerMsg)
-> BrokerMsg -> ReaderT (Env s) IO BrokerMsg
forall a b. (a -> b) -> a -> b
$ ErrorType -> BrokerMsg
ERR ErrorType
e
                  Right () -> do
                    -- hasSubscription should never be True in this branch, because queue was associated with service.
                    -- So unless storage and session states diverge, this check is redundant.
                    Bool
hasSub <- STM Bool -> ReaderT (Env s) IO Bool
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Bool -> ReaderT (Env s) IO Bool)
-> STM Bool -> ReaderT (Env s) IO Bool
forall a b. (a -> b) -> a -> b
$ STM Bool
hasSubscription STM Bool -> (Bool -> STM Bool) -> STM Bool
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> STM Bool
newSub
                    (ServiceStats -> IORef Int) -> M s ()
incNtfSrvStat ServiceStats -> IORef Int
srvAssocRemoved
                    Bool -> ReaderT (Env s) IO BrokerMsg
sok Bool
hasSub
              Maybe RecipientId
Nothing -> do
                Bool
hasSub <- STM Bool -> ReaderT (Env s) IO Bool
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Bool -> ReaderT (Env s) IO Bool)
-> STM Bool -> ReaderT (Env s) IO Bool
forall a b. (a -> b) -> a -> b
$ STM Bool -> STM Bool -> STM Bool -> STM Bool
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM STM Bool
hasSubscription (Bool -> STM Bool
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True) (Bool -> STM Bool
newSub Bool
False)
                Bool -> ReaderT (Env s) IO BrokerMsg
sok Bool
hasSub
              where
                hasSubscription :: STM Bool
hasSubscription = RecipientId -> TMap RecipientId () -> STM Bool
forall k a. Ord k => k -> TMap k a -> STM Bool
TM.member RecipientId
entId TMap RecipientId ()
ntfSubscriptions
                newSub :: Bool -> STM Bool
newSub Bool
hasSub = do
                  TQueue (ClientSub, Int) -> (ClientSub, Int) -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue (ServerSubscribers s -> TQueue (ClientSub, Int)
forall s. ServerSubscribers s -> TQueue (ClientSub, Int)
subQ ServerSubscribers s
ntfSubscribers) (RecipientId -> Maybe RecipientId -> Maybe RecipientId -> ClientSub
CSClient RecipientId
entId Maybe RecipientId
ntfServiceId Maybe RecipientId
forall a. Maybe a
Nothing, Int
clientId)
                  Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
hasSub) (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ RecipientId -> () -> TMap RecipientId () -> STM ()
forall k a. Ord k => k -> a -> TMap k a -> STM ()
TM.insert RecipientId
entId () TMap RecipientId ()
ntfSubscriptions
                  Bool -> STM Bool
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
hasSub
                sok :: Bool -> ReaderT (Env s) IO BrokerMsg
sok Bool
hasSub = do
                  IORef Int -> M s ()
forall (m :: * -> *). MonadIO m => IORef Int -> m ()
incStat (IORef Int -> M s ()) -> IORef Int -> M s ()
forall a b. (a -> b) -> a -> b
$ if Bool
hasSub then ServerStats -> IORef Int
ntfSubDuplicate ServerStats
stats else ServerStats -> IORef Int
ntfSub ServerStats
stats
                  BrokerMsg -> ReaderT (Env s) IO BrokerMsg
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BrokerMsg -> ReaderT (Env s) IO BrokerMsg)
-> BrokerMsg -> ReaderT (Env s) IO BrokerMsg
forall a b. (a -> b) -> a -> b
$ Maybe RecipientId -> BrokerMsg
SOK Maybe RecipientId
forall a. Maybe a
Nothing

        subscribeServiceNotifications :: ServiceId -> M s BrokerMsg
        subscribeServiceNotifications :: RecipientId -> ReaderT (Env s) IO BrokerMsg
subscribeServiceNotifications RecipientId
serviceId = do
          Bool
subscribed <- TVar Bool -> ReaderT (Env s) IO Bool
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar Bool
ntfServiceSubscribed
          if Bool
subscribed
            then Int64 -> BrokerMsg
SOKS (Int64 -> BrokerMsg)
-> ReaderT (Env s) IO Int64 -> ReaderT (Env s) IO BrokerMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar Int64 -> ReaderT (Env s) IO Int64
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar Int64
ntfServiceSubsCount
            else
              IO (Either ErrorType Int64)
-> ReaderT (Env s) IO (Either ErrorType Int64)
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall q s (p :: Party).
(QueueStoreClass q s, PartyI p, ServiceParty p) =>
s -> SParty p -> RecipientId -> IO (Either ErrorType Int64)
getServiceQueueCount @(StoreQueue s) (s -> QueueStore s
forall s. MsgStoreClass s => s -> QueueStore s
queueStore s
ms) SParty 'NotifierService
SNotifierService RecipientId
serviceId) ReaderT (Env s) IO (Either ErrorType Int64)
-> (Either ErrorType Int64 -> ReaderT (Env s) IO BrokerMsg)
-> ReaderT (Env s) IO BrokerMsg
forall a b.
ReaderT (Env s) IO a
-> (a -> ReaderT (Env s) IO b) -> ReaderT (Env s) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Left ErrorType
e -> BrokerMsg -> ReaderT (Env s) IO BrokerMsg
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BrokerMsg -> ReaderT (Env s) IO BrokerMsg)
-> BrokerMsg -> ReaderT (Env s) IO BrokerMsg
forall a b. (a -> b) -> a -> b
$ ErrorType -> BrokerMsg
ERR ErrorType
e
                Right !Int64
count' -> do
                  Int64
incCount <- STM Int64 -> ReaderT (Env s) IO Int64
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Int64 -> ReaderT (Env s) IO Int64)
-> STM Int64 -> ReaderT (Env s) IO Int64
forall a b. (a -> b) -> a -> b
$ do
                    TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
ntfServiceSubscribed Bool
True
                    Int64
count <- TVar Int64 -> Int64 -> STM Int64
forall a. TVar a -> a -> STM a
swapTVar TVar Int64
ntfServiceSubsCount Int64
count'
                    Int64 -> STM Int64
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int64 -> STM Int64) -> Int64 -> STM Int64
forall a b. (a -> b) -> a -> b
$ Int64
count' Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
count
                  STM () -> M s ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> M s ()) -> STM () -> M s ()
forall a b. (a -> b) -> a -> b
$ TQueue (ClientSub, Int) -> (ClientSub, Int) -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue (ServerSubscribers s -> TQueue (ClientSub, Int)
forall s. ServerSubscribers s -> TQueue (ClientSub, Int)
subQ ServerSubscribers s
ntfSubscribers) (RecipientId -> Int64 -> ClientSub
CSService RecipientId
serviceId Int64
incCount, Int
clientId)
                  BrokerMsg -> ReaderT (Env s) IO BrokerMsg
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BrokerMsg -> ReaderT (Env s) IO BrokerMsg)
-> BrokerMsg -> ReaderT (Env s) IO BrokerMsg
forall a b. (a -> b) -> a -> b
$ Int64 -> BrokerMsg
SOKS Int64
count'

        acknowledgeMsg :: MsgId -> StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg)
        acknowledgeMsg :: ByteString
-> StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg)
acknowledgeMsg ByteString
msgId StoreQueue s
q QueueRec
qr =
          IO (Maybe Sub) -> ReaderT (Env s) IO (Maybe Sub)
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (RecipientId -> TMap RecipientId Sub -> IO (Maybe Sub)
forall k a. Ord k => k -> TMap k a -> IO (Maybe a)
TM.lookupIO RecipientId
entId (TMap RecipientId Sub -> IO (Maybe Sub))
-> TMap RecipientId Sub -> IO (Maybe Sub)
forall a b. (a -> b) -> a -> b
$ Client s -> TMap RecipientId Sub
forall s. Client s -> TMap RecipientId Sub
subscriptions Client s
clnt) ReaderT (Env s) IO (Maybe Sub)
-> (Maybe Sub -> M s (Transmission BrokerMsg))
-> M s (Transmission BrokerMsg)
forall a b.
ReaderT (Env s) IO a
-> (a -> ReaderT (Env s) IO b) -> ReaderT (Env s) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe Sub
Nothing -> Transmission BrokerMsg -> M s (Transmission BrokerMsg)
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Transmission BrokerMsg -> M s (Transmission BrokerMsg))
-> Transmission BrokerMsg -> M s (Transmission BrokerMsg)
forall a b. (a -> b) -> a -> b
$ ErrorType -> Transmission BrokerMsg
err ErrorType
NO_MSG
            Just Sub
sub ->
              STM (Maybe (ServerSub, SystemSeconds))
-> ReaderT (Env s) IO (Maybe (ServerSub, SystemSeconds))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (Sub -> STM (Maybe (ServerSub, SystemSeconds))
getDelivered Sub
sub) ReaderT (Env s) IO (Maybe (ServerSub, SystemSeconds))
-> (Maybe (ServerSub, SystemSeconds)
    -> M s (Transmission BrokerMsg))
-> M s (Transmission BrokerMsg)
forall a b.
ReaderT (Env s) IO a
-> (a -> ReaderT (Env s) IO b) -> ReaderT (Env s) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Just (ServerSub
st, SystemSeconds
ts) -> do
                  ServerStats
stats <- (Env s -> ServerStats) -> ReaderT (Env s) IO ServerStats
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> ServerStats
forall s. Env s -> ServerStats
serverStats
                  (Either ErrorType (Transmission BrokerMsg)
 -> Transmission BrokerMsg)
-> ReaderT (Env s) IO (Either ErrorType (Transmission BrokerMsg))
-> M s (Transmission BrokerMsg)
forall a b.
(a -> b) -> ReaderT (Env s) IO a -> ReaderT (Env s) IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ErrorType -> Transmission BrokerMsg)
-> (Transmission BrokerMsg -> Transmission BrokerMsg)
-> Either ErrorType (Transmission BrokerMsg)
-> Transmission BrokerMsg
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ErrorType -> Transmission BrokerMsg
err Transmission BrokerMsg -> Transmission BrokerMsg
forall a. a -> a
id) (ReaderT (Env s) IO (Either ErrorType (Transmission BrokerMsg))
 -> M s (Transmission BrokerMsg))
-> ReaderT (Env s) IO (Either ErrorType (Transmission BrokerMsg))
-> M s (Transmission BrokerMsg)
forall a b. (a -> b) -> a -> b
$ IO (Either ErrorType (Transmission BrokerMsg))
-> ReaderT (Env s) IO (Either ErrorType (Transmission BrokerMsg))
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ErrorType (Transmission BrokerMsg))
 -> ReaderT (Env s) IO (Either ErrorType (Transmission BrokerMsg)))
-> IO (Either ErrorType (Transmission BrokerMsg))
-> ReaderT (Env s) IO (Either ErrorType (Transmission BrokerMsg))
forall a b. (a -> b) -> a -> b
$ ExceptT ErrorType IO (Transmission BrokerMsg)
-> IO (Either ErrorType (Transmission BrokerMsg))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ErrorType IO (Transmission BrokerMsg)
 -> IO (Either ErrorType (Transmission BrokerMsg)))
-> ExceptT ErrorType IO (Transmission BrokerMsg)
-> IO (Either ErrorType (Transmission BrokerMsg))
forall a b. (a -> b) -> a -> b
$ do
                    case ServerSub
st of
                      ServerSub
ProhibitSub -> do
                        Maybe Message
deletedMsg_ <- s
-> StoreQueue s
-> ByteString
-> ExceptT ErrorType IO (Maybe Message)
forall s.
MsgStoreClass s =>
s
-> StoreQueue s
-> ByteString
-> ExceptT ErrorType IO (Maybe Message)
tryDelMsg s
ms StoreQueue s
q ByteString
msgId
                        IO () -> ExceptT ErrorType IO ()
forall a. IO a -> ExceptT ErrorType IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT ErrorType IO ())
-> IO () -> ExceptT ErrorType IO ()
forall a b. (a -> b) -> a -> b
$ (Message -> IO ()) -> Maybe Message -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ServerStats -> Bool -> SystemSeconds -> Message -> IO ()
updateStats ServerStats
stats Bool
True SystemSeconds
ts) Maybe Message
deletedMsg_
                        Transmission BrokerMsg
-> ExceptT ErrorType IO (Transmission BrokerMsg)
forall a. a -> ExceptT ErrorType IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Transmission BrokerMsg
ok
                      ServerSub
_ -> do
                        (Maybe Message
deletedMsg_, Maybe Message
msg_) <- s
-> StoreQueue s
-> ByteString
-> ExceptT ErrorType IO (Maybe Message, Maybe Message)
forall s.
MsgStoreClass s =>
s
-> StoreQueue s
-> ByteString
-> ExceptT ErrorType IO (Maybe Message, Maybe Message)
tryDelPeekMsg s
ms StoreQueue s
q ByteString
msgId
                        IO (Transmission BrokerMsg)
-> ExceptT ErrorType IO (Transmission BrokerMsg)
forall a. IO a -> ExceptT ErrorType IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Transmission BrokerMsg)
 -> ExceptT ErrorType IO (Transmission BrokerMsg))
-> IO (Transmission BrokerMsg)
-> ExceptT ErrorType IO (Transmission BrokerMsg)
forall a b. (a -> b) -> a -> b
$ do
                          (Message -> IO ()) -> Maybe Message -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ServerStats -> Bool -> SystemSeconds -> Message -> IO ()
updateStats ServerStats
stats Bool
False SystemSeconds
ts) Maybe Message
deletedMsg_
                          Maybe Message -> (Message -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Message
msg_ ((Message -> IO ()) -> IO ()) -> (Message -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Message
msg -> do
                            SystemSeconds
ts' <- IO SystemSeconds
getSystemSeconds
                            STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Sub -> Message -> SystemSeconds -> STM ()
setDelivered Sub
sub Message
msg SystemSeconds
ts'
                          Transmission BrokerMsg -> IO (Transmission BrokerMsg)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CorrId
corrId, RecipientId
entId, BrokerMsg -> (Message -> BrokerMsg) -> Maybe Message -> BrokerMsg
forall b a. b -> (a -> b) -> Maybe a -> b
maybe BrokerMsg
OK (RcvMessage -> BrokerMsg
MSG (RcvMessage -> BrokerMsg)
-> (Message -> RcvMessage) -> Message -> BrokerMsg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QueueRec -> Message -> RcvMessage
encryptMsg QueueRec
qr) Maybe Message
msg_)
                Maybe (ServerSub, SystemSeconds)
_ -> Transmission BrokerMsg -> M s (Transmission BrokerMsg)
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Transmission BrokerMsg -> M s (Transmission BrokerMsg))
-> Transmission BrokerMsg -> M s (Transmission BrokerMsg)
forall a b. (a -> b) -> a -> b
$ ErrorType -> Transmission BrokerMsg
err ErrorType
NO_MSG
          where
            getDelivered :: Sub -> STM (Maybe (ServerSub, SystemSeconds))
            getDelivered :: Sub -> STM (Maybe (ServerSub, SystemSeconds))
getDelivered Sub {TVar (Maybe (ByteString, SystemSeconds))
$sel:delivered:Sub :: Sub -> TVar (Maybe (ByteString, SystemSeconds))
delivered :: TVar (Maybe (ByteString, SystemSeconds))
delivered, ServerSub
$sel:subThread:Sub :: Sub -> ServerSub
subThread :: ServerSub
subThread} = do
              TVar (Maybe (ByteString, SystemSeconds))
-> STM (Maybe (ByteString, SystemSeconds))
forall a. TVar a -> STM a
readTVar TVar (Maybe (ByteString, SystemSeconds))
delivered STM (Maybe (ByteString, SystemSeconds))
-> ((ByteString, SystemSeconds)
    -> STM (Maybe (ServerSub, SystemSeconds)))
-> STM (Maybe (ServerSub, SystemSeconds))
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Monad f, Traversable f) =>
m (f a) -> (a -> m (f b)) -> m (f b)
$>>= \(ByteString
msgId', SystemSeconds
ts) ->
                if ByteString
msgId ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
msgId' Bool -> Bool -> Bool
|| ByteString -> Bool
B.null ByteString
msgId
                  then TVar (Maybe (ByteString, SystemSeconds))
-> Maybe (ByteString, SystemSeconds) -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe (ByteString, SystemSeconds))
delivered Maybe (ByteString, SystemSeconds)
forall a. Maybe a
Nothing STM ()
-> Maybe (ServerSub, SystemSeconds)
-> STM (Maybe (ServerSub, SystemSeconds))
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (ServerSub, SystemSeconds) -> Maybe (ServerSub, SystemSeconds)
forall a. a -> Maybe a
Just (ServerSub
subThread, SystemSeconds
ts)
                  else Maybe (ServerSub, SystemSeconds)
-> STM (Maybe (ServerSub, SystemSeconds))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ServerSub, SystemSeconds)
forall a. Maybe a
Nothing
            updateStats :: ServerStats -> Bool -> SystemSeconds -> Message -> IO ()
            updateStats :: ServerStats -> Bool -> SystemSeconds -> Message -> IO ()
updateStats ServerStats
stats Bool
isGet SystemSeconds
deliveryTime = \case
              MessageQuota {} -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              Message {MsgFlags
msgFlags :: MsgFlags
$sel:msgFlags:Message :: Message -> MsgFlags
msgFlags} -> do
                IORef Int -> IO ()
forall (m :: * -> *). MonadIO m => IORef Int -> m ()
incStat (IORef Int -> IO ()) -> IORef Int -> IO ()
forall a b. (a -> b) -> a -> b
$ ServerStats -> IORef Int
msgRecv ServerStats
stats
                if Bool
isGet
                  then IORef Int -> IO ()
forall (m :: * -> *). MonadIO m => IORef Int -> m ()
incStat (IORef Int -> IO ()) -> IORef Int -> IO ()
forall a b. (a -> b) -> a -> b
$ ServerStats -> IORef Int
msgRecvGet ServerStats
stats
                  else () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- TODO skip notification delivery for delivered message
                  -- skipping delivery fails tests, it should be counted in msgNtfSkipped
                  -- forM_ (notifierId <$> notifier qr) $ \nId -> do
                  --   ns <- asks ntfStore
                  --   atomically $ TM.lookup nId ns >>=
                  --     mapM_ (\MsgNtf {ntfMsgId} -> when (msgId == msgId') $ TM.delete nId ns)
                IORef Int -> (Int -> Int) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef'_ (ServerStats -> IORef Int
msgCount ServerStats
stats) (Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
1)
                PeriodStats -> RecipientId -> IO ()
updatePeriodStats (ServerStats -> PeriodStats
activeQueues ServerStats
stats) RecipientId
entId
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MsgFlags -> Bool
notification MsgFlags
msgFlags) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                  IORef Int -> IO ()
forall (m :: * -> *). MonadIO m => IORef Int -> m ()
incStat (IORef Int -> IO ()) -> IORef Int -> IO ()
forall a b. (a -> b) -> a -> b
$ ServerStats -> IORef Int
msgRecvNtf ServerStats
stats
                  PeriodStats -> RecipientId -> IO ()
updatePeriodStats (ServerStats -> PeriodStats
activeQueuesNtf ServerStats
stats) RecipientId
entId
                SystemSeconds
currTime <- IO SystemSeconds
getSystemSeconds
                IORef TimeBuckets -> (TimeBuckets -> TimeBuckets) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef'_ (ServerStats -> IORef TimeBuckets
msgRecvAckTimes ServerStats
stats) ((TimeBuckets -> TimeBuckets) -> IO ())
-> (TimeBuckets -> TimeBuckets) -> IO ()
forall a b. (a -> b) -> a -> b
$ SystemSeconds -> SystemSeconds -> TimeBuckets -> TimeBuckets
updateTimeBuckets SystemSeconds
deliveryTime SystemSeconds
currTime

        sendMessage :: MsgFlags -> MsgBody -> StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg)
        sendMessage :: MsgFlags
-> ByteString
-> StoreQueue s
-> QueueRec
-> M s (Transmission BrokerMsg)
sendMessage MsgFlags
msgFlags ByteString
msgBody StoreQueue s
q QueueRec
qr
          | ByteString -> Int
B.length ByteString
msgBody Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Version SMPVersion -> Int
maxMessageLength Version SMPVersion
clntVersion = do
              ServerStats
stats <- (Env s -> ServerStats) -> ReaderT (Env s) IO ServerStats
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> ServerStats
forall s. Env s -> ServerStats
serverStats
              IORef Int -> M s ()
forall (m :: * -> *). MonadIO m => IORef Int -> m ()
incStat (IORef Int -> M s ()) -> IORef Int -> M s ()
forall a b. (a -> b) -> a -> b
$ ServerStats -> IORef Int
msgSentLarge ServerStats
stats
              Transmission BrokerMsg -> M s (Transmission BrokerMsg)
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Transmission BrokerMsg -> M s (Transmission BrokerMsg))
-> Transmission BrokerMsg -> M s (Transmission BrokerMsg)
forall a b. (a -> b) -> a -> b
$ ErrorType -> Transmission BrokerMsg
err ErrorType
LARGE_MSG
          | Bool
otherwise = do
              ServerStats
stats <- (Env s -> ServerStats) -> ReaderT (Env s) IO ServerStats
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> ServerStats
forall s. Env s -> ServerStats
serverStats
              case QueueRec -> ServerEntityStatus
status QueueRec
qr of
                ServerEntityStatus
EntityOff -> do
                  IORef Int -> M s ()
forall (m :: * -> *). MonadIO m => IORef Int -> m ()
incStat (IORef Int -> M s ()) -> IORef Int -> M s ()
forall a b. (a -> b) -> a -> b
$ ServerStats -> IORef Int
msgSentAuth ServerStats
stats
                  Transmission BrokerMsg -> M s (Transmission BrokerMsg)
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Transmission BrokerMsg -> M s (Transmission BrokerMsg))
-> Transmission BrokerMsg -> M s (Transmission BrokerMsg)
forall a b. (a -> b) -> a -> b
$ ErrorType -> Transmission BrokerMsg
err ErrorType
AUTH
                EntityBlocked BlockingInfo
info -> do
                  IORef Int -> M s ()
forall (m :: * -> *). MonadIO m => IORef Int -> m ()
incStat (IORef Int -> M s ()) -> IORef Int -> M s ()
forall a b. (a -> b) -> a -> b
$ ServerStats -> IORef Int
msgSentBlock ServerStats
stats
                  Transmission BrokerMsg -> M s (Transmission BrokerMsg)
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Transmission BrokerMsg -> M s (Transmission BrokerMsg))
-> Transmission BrokerMsg -> M s (Transmission BrokerMsg)
forall a b. (a -> b) -> a -> b
$ ErrorType -> Transmission BrokerMsg
err (ErrorType -> Transmission BrokerMsg)
-> ErrorType -> Transmission BrokerMsg
forall a b. (a -> b) -> a -> b
$ BlockingInfo -> ErrorType
BLOCKED BlockingInfo
info
                ServerEntityStatus
EntityActive ->
                  case ByteString -> Either CryptoError (MaxLenBS MaxMessageLen)
forall (i :: Natural).
KnownNat i =>
ByteString -> Either CryptoError (MaxLenBS i)
C.maxLenBS ByteString
msgBody of
                    Left CryptoError
_ -> Transmission BrokerMsg -> M s (Transmission BrokerMsg)
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Transmission BrokerMsg -> M s (Transmission BrokerMsg))
-> Transmission BrokerMsg -> M s (Transmission BrokerMsg)
forall a b. (a -> b) -> a -> b
$ ErrorType -> Transmission BrokerMsg
err ErrorType
LARGE_MSG
                    Right MaxLenBS MaxMessageLen
body -> do
                      Bool -> M s () -> M s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe (RecipientId, QueueLinkData) -> Bool
forall a. Maybe a -> Bool
isJust (QueueRec -> Maybe (RecipientId, QueueLinkData)
queueData QueueRec
qr) Bool -> Bool -> Bool
&& QueueRec -> Bool
isSecuredMsgQueue QueueRec
qr) (M s () -> M s ()) -> M s () -> M s ()
forall a b. (a -> b) -> a -> b
$ ReaderT (Env s) IO (Either ErrorType ()) -> M s ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT (Env s) IO (Either ErrorType ()) -> M s ())
-> ReaderT (Env s) IO (Either ErrorType ()) -> M s ()
forall a b. (a -> b) -> a -> b
$ IO (Either ErrorType ())
-> ReaderT (Env s) IO (Either ErrorType ())
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ErrorType ())
 -> ReaderT (Env s) IO (Either ErrorType ()))
-> IO (Either ErrorType ())
-> ReaderT (Env s) IO (Either ErrorType ())
forall a b. (a -> b) -> a -> b
$
                        QueueStore s -> StoreQueue s -> IO (Either ErrorType ())
forall q s.
QueueStoreClass q s =>
s -> q -> IO (Either ErrorType ())
deleteQueueLinkData (s -> QueueStore s
forall s. MsgStoreClass s => s -> QueueStore s
queueStore s
ms) StoreQueue s
q
                      ServerConfig {Maybe ExpirationConfig
$sel:messageExpiration:ServerConfig :: forall s. ServerConfig s -> Maybe ExpirationConfig
messageExpiration :: Maybe ExpirationConfig
messageExpiration, Bool
expireMessagesOnSend :: Bool
$sel:expireMessagesOnSend:ServerConfig :: forall s. ServerConfig s -> Bool
expireMessagesOnSend, Int
msgIdBytes :: Int
$sel:msgIdBytes:ServerConfig :: forall s. ServerConfig s -> Int
msgIdBytes} <- (Env s -> ServerConfig s) -> ReaderT (Env s) IO (ServerConfig s)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> ServerConfig s
forall s. Env s -> ServerConfig s
config
                      ByteString
msgId <- Int -> ReaderT (Env s) IO ByteString
forall s. Int -> M s ByteString
randomId' Int
msgIdBytes
                      Either ErrorType (Maybe (Message, Bool))
msg_ <- IO (Either ErrorType (Maybe (Message, Bool)))
-> ReaderT (Env s) IO (Either ErrorType (Maybe (Message, Bool)))
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ErrorType (Maybe (Message, Bool)))
 -> ReaderT (Env s) IO (Either ErrorType (Maybe (Message, Bool))))
-> IO (Either ErrorType (Maybe (Message, Bool)))
-> ReaderT (Env s) IO (Either ErrorType (Maybe (Message, Bool)))
forall a b. (a -> b) -> a -> b
$ ExceptT ErrorType IO (Maybe (Message, Bool))
-> IO (Either ErrorType (Maybe (Message, Bool)))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ErrorType IO (Maybe (Message, Bool))
 -> IO (Either ErrorType (Maybe (Message, Bool))))
-> ExceptT ErrorType IO (Maybe (Message, Bool))
-> IO (Either ErrorType (Maybe (Message, Bool)))
forall a b. (a -> b) -> a -> b
$ do
                        Bool -> ExceptT ErrorType IO () -> ExceptT ErrorType IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
expireMessagesOnSend (ExceptT ErrorType IO () -> ExceptT ErrorType IO ())
-> ExceptT ErrorType IO () -> ExceptT ErrorType IO ()
forall a b. (a -> b) -> a -> b
$ (ExpirationConfig -> ExceptT ErrorType IO ())
-> Maybe ExpirationConfig -> ExceptT ErrorType IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ServerStats -> ExpirationConfig -> ExceptT ErrorType IO ()
expireMessages ServerStats
stats) Maybe ExpirationConfig
messageExpiration
                        Message
msg <- IO Message -> ExceptT ErrorType IO Message
forall a. IO a -> ExceptT ErrorType IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Message -> ExceptT ErrorType IO Message)
-> IO Message -> ExceptT ErrorType IO Message
forall a b. (a -> b) -> a -> b
$ ByteString -> MaxLenBS MaxMessageLen -> IO Message
mkMessage ByteString
msgId MaxLenBS MaxMessageLen
body
                        s
-> StoreQueue s
-> Bool
-> Message
-> ExceptT ErrorType IO (Maybe (Message, Bool))
forall s.
MsgStoreClass s =>
s
-> StoreQueue s
-> Bool
-> Message
-> ExceptT ErrorType IO (Maybe (Message, Bool))
writeMsg s
ms StoreQueue s
q Bool
True Message
msg
                      case Either ErrorType (Maybe (Message, Bool))
msg_ of
                        Left ErrorType
e -> Transmission BrokerMsg -> M s (Transmission BrokerMsg)
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Transmission BrokerMsg -> M s (Transmission BrokerMsg))
-> Transmission BrokerMsg -> M s (Transmission BrokerMsg)
forall a b. (a -> b) -> a -> b
$ ErrorType -> Transmission BrokerMsg
err ErrorType
e
                        Right Maybe (Message, Bool)
Nothing -> do
                          IORef Int -> M s ()
forall (m :: * -> *). MonadIO m => IORef Int -> m ()
incStat (IORef Int -> M s ()) -> IORef Int -> M s ()
forall a b. (a -> b) -> a -> b
$ ServerStats -> IORef Int
msgSentQuota ServerStats
stats
                          Transmission BrokerMsg -> M s (Transmission BrokerMsg)
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Transmission BrokerMsg -> M s (Transmission BrokerMsg))
-> Transmission BrokerMsg -> M s (Transmission BrokerMsg)
forall a b. (a -> b) -> a -> b
$ ErrorType -> Transmission BrokerMsg
err ErrorType
QUOTA
                        Right (Just (Message
msg, Bool
wasEmpty)) -> do
                          Bool -> M s () -> M s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
wasEmpty (M s () -> M s ()) -> M s () -> M s ()
forall a b. (a -> b) -> a -> b
$ IO () -> M s ()
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
forall a b. (a -> b) -> a -> b
$ Message -> IO ()
tryDeliverMessage Message
msg
                          Bool -> M s () -> M s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MsgFlags -> Bool
notification MsgFlags
msgFlags) (M s () -> M s ()) -> M s () -> M s ()
forall a b. (a -> b) -> a -> b
$ do
                            (NtfCreds -> M s ()) -> Maybe NtfCreds -> M s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (NtfCreds -> Message -> M s ()
`enqueueNotification` Message
msg) (QueueRec -> Maybe NtfCreds
notifier QueueRec
qr)
                            IORef Int -> M s ()
forall (m :: * -> *). MonadIO m => IORef Int -> m ()
incStat (IORef Int -> M s ()) -> IORef Int -> M s ()
forall a b. (a -> b) -> a -> b
$ ServerStats -> IORef Int
msgSentNtf ServerStats
stats
                            IO () -> M s ()
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
forall a b. (a -> b) -> a -> b
$ PeriodStats -> RecipientId -> IO ()
updatePeriodStats (ServerStats -> PeriodStats
activeQueuesNtf ServerStats
stats) (StoreQueue s -> RecipientId
forall q. StoreQueueClass q => q -> RecipientId
recipientId StoreQueue s
q)
                          IORef Int -> M s ()
forall (m :: * -> *). MonadIO m => IORef Int -> m ()
incStat (IORef Int -> M s ()) -> IORef Int -> M s ()
forall a b. (a -> b) -> a -> b
$ ServerStats -> IORef Int
msgSent ServerStats
stats
                          IORef Int -> M s ()
forall (m :: * -> *). MonadIO m => IORef Int -> m ()
incStat (IORef Int -> M s ()) -> IORef Int -> M s ()
forall a b. (a -> b) -> a -> b
$ ServerStats -> IORef Int
msgCount ServerStats
stats
                          IO () -> M s ()
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
forall a b. (a -> b) -> a -> b
$ PeriodStats -> RecipientId -> IO ()
updatePeriodStats (ServerStats -> PeriodStats
activeQueues ServerStats
stats) (StoreQueue s -> RecipientId
forall q. StoreQueueClass q => q -> RecipientId
recipientId StoreQueue s
q)
                          Transmission BrokerMsg -> M s (Transmission BrokerMsg)
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Transmission BrokerMsg
ok
          where
            mkMessage :: MsgId -> C.MaxLenBS MaxMessageLen -> IO Message
            mkMessage :: ByteString -> MaxLenBS MaxMessageLen -> IO Message
mkMessage ByteString
msgId MaxLenBS MaxMessageLen
body = do
              SystemTime
msgTs <- IO SystemTime
getSystemTime
              Message -> IO Message
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Message -> IO Message) -> Message -> IO Message
forall a b. (a -> b) -> a -> b
$! ByteString
-> SystemTime -> MsgFlags -> MaxLenBS MaxMessageLen -> Message
Message ByteString
msgId SystemTime
msgTs MsgFlags
msgFlags MaxLenBS MaxMessageLen
body

            expireMessages :: ServerStats -> ExpirationConfig -> ExceptT ErrorType IO ()
            expireMessages :: ServerStats -> ExpirationConfig -> ExceptT ErrorType IO ()
expireMessages ServerStats
stats ExpirationConfig
msgExp = do
              Int
deleted <- s -> StoreQueue s -> Int64 -> ExceptT ErrorType IO Int
forall s.
MsgStoreClass s =>
s -> StoreQueue s -> Int64 -> ExceptT ErrorType IO Int
deleteExpiredMsgs s
ms StoreQueue s
q (Int64 -> ExceptT ErrorType IO Int)
-> ExceptT ErrorType IO Int64 -> ExceptT ErrorType IO Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO Int64 -> ExceptT ErrorType IO Int64
forall a. IO a -> ExceptT ErrorType IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ExpirationConfig -> IO Int64
expireBeforeEpoch ExpirationConfig
msgExp)
              IO () -> ExceptT ErrorType IO ()
forall a. IO a -> ExceptT ErrorType IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT ErrorType IO ())
-> IO () -> ExceptT ErrorType IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
deleted Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef Int -> (Int -> Int) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef'_ (ServerStats -> IORef Int
msgExpired ServerStats
stats) (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
deleted)

            -- The condition for delivery of the message is:
            -- - the queue was empty when the message was sent,
            -- - there is subscribed recipient,
            -- - no message was "delivered" that was not acknowledged.
            -- If the send queue of the subscribed client is not full the message is put there in the same transaction.
            -- If the queue is not full, then the thread is created where these checks are made:
            -- - it is the same subscribed client (in case it was reconnected it would receive message via SUB command)
            -- - nothing was delivered to this subscription (to avoid race conditions with the recipient).
            tryDeliverMessage :: Message -> IO ()
            tryDeliverMessage :: Message -> IO ()
tryDeliverMessage Message
msg =
              -- the subscribed client var is read outside of STM to avoid transaction cost
              -- in case no client is subscribed.
              RecipientId
-> SubscribedClients s -> IO (Maybe (TVar (Maybe (Client s))))
forall s.
RecipientId
-> SubscribedClients s -> IO (Maybe (TVar (Maybe (Client s))))
getSubscribedClient RecipientId
rId (ServerSubscribers s -> SubscribedClients s
forall s. ServerSubscribers s -> SubscribedClients s
queueSubscribers ServerSubscribers s
subscribers)
                IO (Maybe (TVar (Maybe (Client s))))
-> (TVar (Maybe (Client s))
    -> IO (Maybe (Client s, Sub, TVar SubscriptionThread)))
-> IO (Maybe (Client s, Sub, TVar SubscriptionThread))
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Monad f, Traversable f) =>
m (f a) -> (a -> m (f b)) -> m (f b)
$>>= TVar (Maybe (Client s))
-> IO (Maybe (Client s, Sub, TVar SubscriptionThread))
deliverToSub
                IO (Maybe (Client s, Sub, TVar SubscriptionThread))
-> (Maybe (Client s, Sub, TVar SubscriptionThread) -> 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
>>= ((Client s, Sub, TVar SubscriptionThread) -> IO ())
-> Maybe (Client s, Sub, TVar SubscriptionThread) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Client s, Sub, TVar SubscriptionThread) -> IO ()
forkDeliver
              where
                rId :: RecipientId
rId = StoreQueue s -> RecipientId
forall q. StoreQueueClass q => q -> RecipientId
recipientId StoreQueue s
q
                deliverToSub :: TVar (Maybe (Client s))
-> IO (Maybe (Client s, Sub, TVar SubscriptionThread))
deliverToSub TVar (Maybe (Client s))
rcv = do
                  SystemSeconds
ts <- IO SystemSeconds
getSystemSeconds
                  STM (Maybe (Client s, Sub, TVar SubscriptionThread))
-> IO (Maybe (Client s, Sub, TVar SubscriptionThread))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Maybe (Client s, Sub, TVar SubscriptionThread))
 -> IO (Maybe (Client s, Sub, TVar SubscriptionThread)))
-> STM (Maybe (Client s, Sub, TVar SubscriptionThread))
-> IO (Maybe (Client s, Sub, TVar SubscriptionThread))
forall a b. (a -> b) -> a -> b
$
                    -- reading client TVar in the same transaction,
                    -- so that if subscription ends, it re-evalutates
                    -- and delivery is cancelled -
                    -- the new client will receive message in response to SUB.
                    TVar (Maybe (Client s)) -> STM (Maybe (Client s))
forall a. TVar a -> STM a
readTVar TVar (Maybe (Client s))
rcv
                      STM (Maybe (Client s))
-> (Client s
    -> STM (Maybe (Client s, Sub, TVar SubscriptionThread)))
-> STM (Maybe (Client s, Sub, TVar SubscriptionThread))
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Monad f, Traversable f) =>
m (f a) -> (a -> m (f b)) -> m (f b)
$>>= \rc :: Client s
rc@Client {$sel:subscriptions:Client :: forall s. Client s -> TMap RecipientId Sub
subscriptions = TMap RecipientId Sub
subs, $sel:sndQ:Client :: forall s.
Client s
-> TBQueue
     (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
sndQ = TBQueue
  (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
sndQ'} -> RecipientId -> TMap RecipientId Sub -> STM (Maybe Sub)
forall k a. Ord k => k -> TMap k a -> STM (Maybe a)
TM.lookup RecipientId
rId TMap RecipientId Sub
subs
                      STM (Maybe Sub)
-> (Sub -> STM (Maybe (Client s, Sub, TVar SubscriptionThread)))
-> STM (Maybe (Client s, Sub, TVar SubscriptionThread))
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Monad f, Traversable f) =>
m (f a) -> (a -> m (f b)) -> m (f b)
$>>= \s :: Sub
s@Sub {ServerSub
$sel:subThread:Sub :: Sub -> ServerSub
subThread :: ServerSub
subThread, TVar (Maybe (ByteString, SystemSeconds))
$sel:delivered:Sub :: Sub -> TVar (Maybe (ByteString, SystemSeconds))
delivered :: TVar (Maybe (ByteString, SystemSeconds))
delivered} -> case ServerSub
subThread of
                        ServerSub
ProhibitSub -> Maybe (Client s, Sub, TVar SubscriptionThread)
-> STM (Maybe (Client s, Sub, TVar SubscriptionThread))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Client s, Sub, TVar SubscriptionThread)
forall a. Maybe a
Nothing
                        ServerSub TVar SubscriptionThread
st -> TVar SubscriptionThread -> STM SubscriptionThread
forall a. TVar a -> STM a
readTVar TVar SubscriptionThread
st STM SubscriptionThread
-> (SubscriptionThread
    -> STM (Maybe (Client s, Sub, TVar SubscriptionThread)))
-> STM (Maybe (Client s, Sub, TVar SubscriptionThread))
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                          SubscriptionThread
NoSub ->
                            TVar (Maybe (ByteString, SystemSeconds))
-> STM (Maybe (ByteString, SystemSeconds))
forall a. TVar a -> STM a
readTVar TVar (Maybe (ByteString, SystemSeconds))
delivered STM (Maybe (ByteString, SystemSeconds))
-> (Maybe (ByteString, SystemSeconds)
    -> STM (Maybe (Client s, Sub, TVar SubscriptionThread)))
-> STM (Maybe (Client s, Sub, TVar SubscriptionThread))
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 (ByteString, SystemSeconds)
_ -> Maybe (Client s, Sub, TVar SubscriptionThread)
-> STM (Maybe (Client s, Sub, TVar SubscriptionThread))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Client s, Sub, TVar SubscriptionThread)
forall a. Maybe a
Nothing -- if a message was already delivered, should not deliver more
                              Maybe (ByteString, SystemSeconds)
Nothing ->
                                STM Bool
-> STM (Maybe (Client s, Sub, TVar SubscriptionThread))
-> STM (Maybe (Client s, Sub, TVar SubscriptionThread))
-> STM (Maybe (Client s, Sub, TVar SubscriptionThread))
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM
                                  (TBQueue
  (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
-> STM Bool
forall a. TBQueue a -> STM Bool
isFullTBQueue TBQueue
  (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
sndQ')
                                  (TVar SubscriptionThread -> SubscriptionThread -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar SubscriptionThread
st SubscriptionThread
SubPending STM ()
-> Maybe (Client s, Sub, TVar SubscriptionThread)
-> STM (Maybe (Client s, Sub, TVar SubscriptionThread))
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (Client s, Sub, TVar SubscriptionThread)
-> Maybe (Client s, Sub, TVar SubscriptionThread)
forall a. a -> Maybe a
Just (Client s
rc, Sub
s, TVar SubscriptionThread
st))
                                  (TBQueue
  (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
-> Sub -> SystemSeconds -> STM ()
deliver TBQueue
  (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
sndQ' Sub
s SystemSeconds
ts STM ()
-> Maybe (Client s, Sub, TVar SubscriptionThread)
-> STM (Maybe (Client s, Sub, TVar SubscriptionThread))
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe (Client s, Sub, TVar SubscriptionThread)
forall a. Maybe a
Nothing)
                          SubscriptionThread
_ -> Maybe (Client s, Sub, TVar SubscriptionThread)
-> STM (Maybe (Client s, Sub, TVar SubscriptionThread))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Client s, Sub, TVar SubscriptionThread)
forall a. Maybe a
Nothing
                deliver :: TBQueue
  (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
-> Sub -> SystemSeconds -> STM ()
deliver TBQueue
  (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
sndQ' Sub
s SystemSeconds
ts = do
                  let encMsg :: RcvMessage
encMsg = QueueRec -> Message -> RcvMessage
encryptMsg QueueRec
qr Message
msg
                  TBQueue
  (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
-> (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
-> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue
  (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
sndQ' ([(CorrId
NoCorrId, RecipientId
rId, RcvMessage -> BrokerMsg
MSG RcvMessage
encMsg)], [])
                  Sub -> Message -> SystemSeconds -> STM ()
setDelivered Sub
s Message
msg SystemSeconds
ts
                forkDeliver :: (Client s, Sub, TVar SubscriptionThread) -> IO ()
forkDeliver (rc :: Client s
rc@Client {$sel:sndQ:Client :: forall s.
Client s
-> TBQueue
     (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
sndQ = TBQueue
  (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
sndQ'}, s :: Sub
s@Sub {TVar (Maybe (ByteString, SystemSeconds))
$sel:delivered:Sub :: Sub -> TVar (Maybe (ByteString, SystemSeconds))
delivered :: TVar (Maybe (ByteString, SystemSeconds))
delivered}, TVar SubscriptionThread
st) = do
                  Weak ThreadId
t <- ThreadId -> IO (Weak ThreadId)
forall (m :: * -> *). MonadIO m => ThreadId -> m (Weak ThreadId)
mkWeakThreadId (ThreadId -> IO (Weak ThreadId))
-> IO ThreadId -> IO (Weak ThreadId)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO () -> IO ThreadId
forall (m :: * -> *). MonadUnliftIO m => m () -> m ThreadId
forkIO IO ()
deliverThread
                  STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar SubscriptionThread
-> (SubscriptionThread -> SubscriptionThread) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar SubscriptionThread
st ((SubscriptionThread -> SubscriptionThread) -> STM ())
-> (SubscriptionThread -> SubscriptionThread) -> STM ()
forall a b. (a -> b) -> a -> b
$ \case
                    -- this case is needed because deliverThread can exit before it
                    SubscriptionThread
SubPending -> Weak ThreadId -> SubscriptionThread
SubThread Weak ThreadId
t
                    SubscriptionThread
st' -> SubscriptionThread
st'
                  where
                    deliverThread :: IO ()
deliverThread = do
                      String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
labelMyThread (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> String
B.unpack (ByteString
"client $" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
encode ByteString
sessionId) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" deliver/SEND"
                      -- lookup can be outside of STM transaction,
                      -- as long as the check that it is the same client is inside.
                      RecipientId
-> SubscribedClients s -> IO (Maybe (TVar (Maybe (Client s))))
forall s.
RecipientId
-> SubscribedClients s -> IO (Maybe (TVar (Maybe (Client s))))
getSubscribedClient RecipientId
rId (ServerSubscribers s -> SubscribedClients s
forall s. ServerSubscribers s -> SubscribedClients s
queueSubscribers ServerSubscribers s
subscribers) IO (Maybe (TVar (Maybe (Client s))))
-> (Maybe (TVar (Maybe (Client s))) -> 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
>>= (TVar (Maybe (Client s)) -> IO ())
-> Maybe (TVar (Maybe (Client s))) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ TVar (Maybe (Client s)) -> IO ()
deliverIfSame
                    deliverIfSame :: TVar (Maybe (Client s)) -> IO ()
deliverIfSame TVar (Maybe (Client s))
rcv = do
                      SystemSeconds
ts <- IO SystemSeconds
getSystemSeconds
                      STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ STM Bool -> STM () -> STM ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (Client s -> TVar (Maybe (Client s)) -> STM Bool
forall s. Client s -> TVar (Maybe (Client s)) -> STM Bool
sameClient Client s
rc TVar (Maybe (Client s))
rcv) (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$
                        TVar (Maybe (ByteString, SystemSeconds))
-> STM (Maybe (ByteString, SystemSeconds))
forall a. TVar a -> STM a
readTVar TVar (Maybe (ByteString, SystemSeconds))
delivered STM (Maybe (ByteString, SystemSeconds))
-> (Maybe (ByteString, SystemSeconds) -> 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
>>= \case
                          Just (ByteString, SystemSeconds)
_ -> () -> STM ()
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- if a message was already delivered, should not deliver more
                          Maybe (ByteString, SystemSeconds)
Nothing -> do
                            -- a separate thread is needed because it blocks when client sndQ is full.
                            TBQueue
  (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
-> Sub -> SystemSeconds -> STM ()
deliver TBQueue
  (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg])
sndQ' Sub
s SystemSeconds
ts
                            TVar SubscriptionThread -> SubscriptionThread -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar SubscriptionThread
st SubscriptionThread
NoSub

            enqueueNotification :: NtfCreds -> Message -> M s ()
            enqueueNotification :: NtfCreds -> Message -> M s ()
enqueueNotification NtfCreds
_ MessageQuota {} = () -> M s ()
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            enqueueNotification NtfCreds {$sel:notifierId:NtfCreds :: NtfCreds -> RecipientId
notifierId = RecipientId
nId, DhSecret 'X25519
$sel:rcvNtfDhSecret:NtfCreds :: NtfCreds -> DhSecret 'X25519
rcvNtfDhSecret :: DhSecret 'X25519
rcvNtfDhSecret} Message {ByteString
msgId :: ByteString
$sel:msgId:Message :: Message -> ByteString
msgId, SystemTime
msgTs :: SystemTime
$sel:msgTs:Message :: Message -> SystemTime
msgTs} = do
              NtfStore
ns <- (Env s -> NtfStore) -> ReaderT (Env s) IO NtfStore
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> NtfStore
forall s. Env s -> NtfStore
ntfStore
              MsgNtf
ntf <- ByteString -> SystemTime -> DhSecret 'X25519 -> M s MsgNtf
mkMessageNotification ByteString
msgId SystemTime
msgTs DhSecret 'X25519
rcvNtfDhSecret
              IO () -> M s ()
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
forall a b. (a -> b) -> a -> b
$ NtfStore -> RecipientId -> MsgNtf -> IO ()
storeNtf NtfStore
ns RecipientId
nId MsgNtf
ntf
              IORef Int -> M s ()
forall (m :: * -> *). MonadIO m => IORef Int -> m ()
incStat (IORef Int -> M s ())
-> (ServerStats -> IORef Int) -> ServerStats -> M s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerStats -> IORef Int
ntfCount (ServerStats -> M s ()) -> ReaderT (Env s) IO ServerStats -> M s ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Env s -> ServerStats) -> ReaderT (Env s) IO ServerStats
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> ServerStats
forall s. Env s -> ServerStats
serverStats

            mkMessageNotification :: ByteString -> SystemTime -> RcvNtfDhSecret -> M s MsgNtf
            mkMessageNotification :: ByteString -> SystemTime -> DhSecret 'X25519 -> M s MsgNtf
mkMessageNotification ByteString
msgId SystemTime
msgTs DhSecret 'X25519
rcvNtfDhSecret = do
              CbNonce
ntfNonce <- STM CbNonce -> ReaderT (Env s) IO CbNonce
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM CbNonce -> ReaderT (Env s) IO CbNonce)
-> (TVar ChaChaDRG -> STM CbNonce)
-> TVar ChaChaDRG
-> ReaderT (Env s) IO CbNonce
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar ChaChaDRG -> STM CbNonce
C.randomCbNonce (TVar ChaChaDRG -> ReaderT (Env s) IO CbNonce)
-> ReaderT (Env s) IO (TVar ChaChaDRG)
-> ReaderT (Env s) IO CbNonce
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Env s -> TVar ChaChaDRG) -> ReaderT (Env s) IO (TVar ChaChaDRG)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> TVar ChaChaDRG
forall s. Env s -> TVar ChaChaDRG
random
              let msgMeta :: NMsgMeta
msgMeta = NMsgMeta {ByteString
msgId :: ByteString
$sel:msgId:NMsgMeta :: ByteString
msgId, SystemTime
msgTs :: SystemTime
$sel:msgTs:NMsgMeta :: SystemTime
msgTs}
                  encNMsgMeta :: Either CryptoError ByteString
encNMsgMeta = DhSecret 'X25519
-> CbNonce -> ByteString -> Int -> Either CryptoError ByteString
C.cbEncrypt DhSecret 'X25519
rcvNtfDhSecret CbNonce
ntfNonce (NMsgMeta -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode NMsgMeta
msgMeta) Int
128
              MsgNtf -> M s MsgNtf
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MsgNtf -> M s MsgNtf) -> MsgNtf -> M s MsgNtf
forall a b. (a -> b) -> a -> b
$ MsgNtf {ntfMsgId :: ByteString
ntfMsgId = ByteString
msgId, ntfTs :: SystemTime
ntfTs = SystemTime
msgTs, CbNonce
ntfNonce :: CbNonce
ntfNonce :: CbNonce
ntfNonce, ntfEncMeta :: ByteString
ntfEncMeta = ByteString -> Either CryptoError ByteString -> ByteString
forall b a. b -> Either a b -> b
fromRight ByteString
"" Either CryptoError ByteString
encNMsgMeta}

        processForwardedCommand :: EncFwdTransmission -> M s BrokerMsg
        processForwardedCommand :: EncFwdTransmission -> ReaderT (Env s) IO BrokerMsg
processForwardedCommand (EncFwdTransmission ByteString
s) = (Either ErrorType EncFwdResponse -> BrokerMsg)
-> ReaderT (Env s) IO (Either ErrorType EncFwdResponse)
-> ReaderT (Env s) IO BrokerMsg
forall a b.
(a -> b) -> ReaderT (Env s) IO a -> ReaderT (Env s) IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ErrorType -> BrokerMsg)
-> (EncFwdResponse -> BrokerMsg)
-> Either ErrorType EncFwdResponse
-> BrokerMsg
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ErrorType -> BrokerMsg
ERR EncFwdResponse -> BrokerMsg
RRES) (ReaderT (Env s) IO (Either ErrorType EncFwdResponse)
 -> ReaderT (Env s) IO BrokerMsg)
-> (ExceptT ErrorType (ReaderT (Env s) IO) EncFwdResponse
    -> ReaderT (Env s) IO (Either ErrorType EncFwdResponse))
-> ExceptT ErrorType (ReaderT (Env s) IO) EncFwdResponse
-> ReaderT (Env s) IO BrokerMsg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT ErrorType (ReaderT (Env s) IO) EncFwdResponse
-> ReaderT (Env s) IO (Either ErrorType EncFwdResponse)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ErrorType (ReaderT (Env s) IO) EncFwdResponse
 -> ReaderT (Env s) IO BrokerMsg)
-> ExceptT ErrorType (ReaderT (Env s) IO) EncFwdResponse
-> ReaderT (Env s) IO BrokerMsg
forall a b. (a -> b) -> a -> b
$ do
          THAuthServer {PrivateKey 'X25519
$sel:serverPrivKey:THAuthClient :: THandleAuth 'TServer -> PrivateKey 'X25519
serverPrivKey :: PrivateKey 'X25519
serverPrivKey, Maybe (DhSecret 'X25519)
sessSecret' :: Maybe (DhSecret 'X25519)
$sel:sessSecret':THAuthClient :: THandleAuth 'TServer -> Maybe (DhSecret 'X25519)
sessSecret'} <- ExceptT ErrorType (ReaderT (Env s) IO) (THandleAuth 'TServer)
-> (THandleAuth 'TServer
    -> ExceptT ErrorType (ReaderT (Env s) IO) (THandleAuth 'TServer))
-> Maybe (THandleAuth 'TServer)
-> ExceptT ErrorType (ReaderT (Env s) IO) (THandleAuth 'TServer)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ErrorType
-> ExceptT ErrorType (ReaderT (Env s) IO) (THandleAuth 'TServer)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (ErrorType
 -> ExceptT ErrorType (ReaderT (Env s) IO) (THandleAuth 'TServer))
-> ErrorType
-> ExceptT ErrorType (ReaderT (Env s) IO) (THandleAuth 'TServer)
forall a b. (a -> b) -> a -> b
$ TransportError -> ErrorType
transportErr TransportError
TENoServerAuth) THandleAuth 'TServer
-> ExceptT ErrorType (ReaderT (Env s) IO) (THandleAuth 'TServer)
forall a. a -> ExceptT ErrorType (ReaderT (Env s) IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (THandleParams SMPVersion 'TServer -> Maybe (THandleAuth 'TServer)
forall v (p :: TransportPeer).
THandleParams v p -> Maybe (THandleAuth p)
thAuth THandleParams SMPVersion 'TServer
thParams')
          DhSecret 'X25519
sessSecret <- ExceptT ErrorType (ReaderT (Env s) IO) (DhSecret 'X25519)
-> (DhSecret 'X25519
    -> ExceptT ErrorType (ReaderT (Env s) IO) (DhSecret 'X25519))
-> Maybe (DhSecret 'X25519)
-> ExceptT ErrorType (ReaderT (Env s) IO) (DhSecret 'X25519)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ErrorType
-> ExceptT ErrorType (ReaderT (Env s) IO) (DhSecret 'X25519)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (ErrorType
 -> ExceptT ErrorType (ReaderT (Env s) IO) (DhSecret 'X25519))
-> ErrorType
-> ExceptT ErrorType (ReaderT (Env s) IO) (DhSecret 'X25519)
forall a b. (a -> b) -> a -> b
$ TransportError -> ErrorType
transportErr TransportError
TENoServerAuth) DhSecret 'X25519
-> ExceptT ErrorType (ReaderT (Env s) IO) (DhSecret 'X25519)
forall a. a -> ExceptT ErrorType (ReaderT (Env s) IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (DhSecret 'X25519)
sessSecret'
          let proxyNonce :: CbNonce
proxyNonce = ByteString -> CbNonce
C.cbNonce (ByteString -> CbNonce) -> ByteString -> CbNonce
forall a b. (a -> b) -> a -> b
$ CorrId -> ByteString
bs CorrId
corrId
          ByteString
s' <- (CryptoError -> ErrorType)
-> Either CryptoError ByteString
-> ExceptT ErrorType (ReaderT (Env s) IO) ByteString
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> Either e a -> ExceptT e' m a
liftEitherWith (ErrorType -> CryptoError -> ErrorType
forall a b. a -> b -> a
const ErrorType
CRYPTO) (Either CryptoError ByteString
 -> ExceptT ErrorType (ReaderT (Env s) IO) ByteString)
-> Either CryptoError ByteString
-> ExceptT ErrorType (ReaderT (Env s) IO) ByteString
forall a b. (a -> b) -> a -> b
$ DhSecret 'X25519
-> CbNonce -> ByteString -> Either CryptoError ByteString
C.cbDecryptNoPad DhSecret 'X25519
sessSecret CbNonce
proxyNonce ByteString
s
          FwdTransmission {CorrId
fwdCorrId :: CorrId
$sel:fwdCorrId:FwdTransmission :: FwdTransmission -> CorrId
fwdCorrId, Version SMPVersion
fwdVersion :: Version SMPVersion
$sel:fwdVersion:FwdTransmission :: FwdTransmission -> Version SMPVersion
fwdVersion, PublicKey 'X25519
fwdKey :: PublicKey 'X25519
$sel:fwdKey:FwdTransmission :: FwdTransmission -> PublicKey 'X25519
fwdKey, $sel:fwdTransmission:FwdTransmission :: FwdTransmission -> EncTransmission
fwdTransmission = EncTransmission ByteString
et} <- (String -> ErrorType)
-> Either String FwdTransmission
-> ExceptT ErrorType (ReaderT (Env s) IO) FwdTransmission
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> Either e a -> ExceptT e' m a
liftEitherWith (ErrorType -> String -> ErrorType
forall a b. a -> b -> a
const (ErrorType -> String -> ErrorType)
-> ErrorType -> String -> ErrorType
forall a b. (a -> b) -> a -> b
$ CommandError -> ErrorType
CMD CommandError
SYNTAX) (Either String FwdTransmission
 -> ExceptT ErrorType (ReaderT (Env s) IO) FwdTransmission)
-> Either String FwdTransmission
-> ExceptT ErrorType (ReaderT (Env s) IO) FwdTransmission
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String FwdTransmission
forall a. Encoding a => ByteString -> Either String a
smpDecode ByteString
s'
          let clientSecret :: DhSecret 'X25519
clientSecret = PublicKey 'X25519 -> PrivateKey 'X25519 -> DhSecret 'X25519
forall (a :: Algorithm).
DhAlgorithm a =>
PublicKey a -> PrivateKey a -> DhSecret a
C.dh' PublicKey 'X25519
fwdKey PrivateKey 'X25519
serverPrivKey
              clientNonce :: CbNonce
clientNonce = ByteString -> CbNonce
C.cbNonce (ByteString -> CbNonce) -> ByteString -> CbNonce
forall a b. (a -> b) -> a -> b
$ CorrId -> ByteString
bs CorrId
fwdCorrId
          ByteString
b <- (CryptoError -> ErrorType)
-> Either CryptoError ByteString
-> ExceptT ErrorType (ReaderT (Env s) IO) ByteString
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> Either e a -> ExceptT e' m a
liftEitherWith (ErrorType -> CryptoError -> ErrorType
forall a b. a -> b -> a
const ErrorType
CRYPTO) (Either CryptoError ByteString
 -> ExceptT ErrorType (ReaderT (Env s) IO) ByteString)
-> Either CryptoError ByteString
-> ExceptT ErrorType (ReaderT (Env s) IO) ByteString
forall a b. (a -> b) -> a -> b
$ DhSecret 'X25519
-> CbNonce -> ByteString -> Either CryptoError ByteString
C.cbDecrypt DhSecret 'X25519
clientSecret CbNonce
clientNonce ByteString
et
          let clntTHParams :: THandleParams SMPVersion 'TServer
clntTHParams = Version SMPVersion
-> THandleParams SMPVersion 'TServer
-> THandleParams SMPVersion 'TServer
forall (p :: TransportPeer).
Version SMPVersion
-> THandleParams SMPVersion p -> THandleParams SMPVersion p
smpTHParamsSetVersion Version SMPVersion
fwdVersion THandleParams SMPVersion 'TServer
thParams'
          -- only allowing single forwarded transactions
          SignedTransmissionOrError ErrorType Cmd
t' <- case THandleParams SMPVersion 'TServer
-> ByteString -> NonEmpty (Either TransportError RawTransmission)
forall v (p :: TransportPeer).
THandleParams v p
-> ByteString -> NonEmpty (Either TransportError RawTransmission)
tParse THandleParams SMPVersion 'TServer
clntTHParams ByteString
b of
            Either TransportError RawTransmission
t :| [] -> SignedTransmissionOrError ErrorType Cmd
-> ExceptT
     ErrorType
     (ReaderT (Env s) IO)
     (SignedTransmissionOrError ErrorType Cmd)
forall a. a -> ExceptT ErrorType (ReaderT (Env s) IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SignedTransmissionOrError ErrorType Cmd
 -> ExceptT
      ErrorType
      (ReaderT (Env s) IO)
      (SignedTransmissionOrError ErrorType Cmd))
-> SignedTransmissionOrError ErrorType Cmd
-> ExceptT
     ErrorType
     (ReaderT (Env s) IO)
     (SignedTransmissionOrError ErrorType Cmd)
forall a b. (a -> b) -> a -> b
$ THandleParams SMPVersion 'TServer
-> Either TransportError RawTransmission
-> SignedTransmissionOrError ErrorType Cmd
forall v err cmd.
ProtocolEncoding v err cmd =>
THandleParams v 'TServer
-> Either TransportError RawTransmission
-> SignedTransmissionOrError err cmd
tDecodeServer THandleParams SMPVersion 'TServer
clntTHParams Either TransportError RawTransmission
t
            NonEmpty (Either TransportError RawTransmission)
_ -> ErrorType
-> ExceptT
     ErrorType
     (ReaderT (Env s) IO)
     (SignedTransmissionOrError ErrorType Cmd)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE ErrorType
BLOCK
          let clntThAuth :: Maybe (THandleAuth 'TServer)
clntThAuth = THandleAuth 'TServer -> Maybe (THandleAuth 'TServer)
forall a. a -> Maybe a
Just (THandleAuth 'TServer -> Maybe (THandleAuth 'TServer))
-> THandleAuth 'TServer -> Maybe (THandleAuth 'TServer)
forall a b. (a -> b) -> a -> b
$ THAuthServer {PrivateKey 'X25519
$sel:serverPrivKey:THAuthClient :: PrivateKey 'X25519
serverPrivKey :: PrivateKey 'X25519
serverPrivKey, $sel:peerClientService:THAuthClient :: Maybe THPeerClientService
peerClientService = Maybe THPeerClientService
forall a. Maybe a
Nothing, $sel:sessSecret':THAuthClient :: Maybe (DhSecret 'X25519)
sessSecret' = DhSecret 'X25519 -> Maybe (DhSecret 'X25519)
forall a. a -> Maybe a
Just DhSecret 'X25519
clientSecret}
          -- process forwarded command
          Transmission BrokerMsg
r <-
            ReaderT
  (Env s)
  IO
  (Either (Transmission BrokerMsg) (VerifiedTransmission s))
-> ExceptT
     ErrorType
     (ReaderT (Env s) IO)
     (Either (Transmission BrokerMsg) (VerifiedTransmission s))
forall (m :: * -> *) a. Monad m => m a -> ExceptT ErrorType m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Maybe (THandleAuth 'TServer)
-> SignedTransmissionOrError ErrorType Cmd
-> ReaderT
     (Env s)
     IO
     (Either (Transmission BrokerMsg) (VerifiedTransmission s))
rejectOrVerify Maybe (THandleAuth 'TServer)
clntThAuth SignedTransmissionOrError ErrorType Cmd
t') ExceptT
  ErrorType
  (ReaderT (Env s) IO)
  (Either (Transmission BrokerMsg) (VerifiedTransmission s))
-> (Either (Transmission BrokerMsg) (VerifiedTransmission s)
    -> ExceptT ErrorType (ReaderT (Env s) IO) (Transmission BrokerMsg))
-> ExceptT ErrorType (ReaderT (Env s) IO) (Transmission BrokerMsg)
forall a b.
ExceptT ErrorType (ReaderT (Env s) IO) a
-> (a -> ExceptT ErrorType (ReaderT (Env s) IO) b)
-> ExceptT ErrorType (ReaderT (Env s) IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Left Transmission BrokerMsg
r -> Transmission BrokerMsg
-> ExceptT ErrorType (ReaderT (Env s) IO) (Transmission BrokerMsg)
forall a. a -> ExceptT ErrorType (ReaderT (Env s) IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Transmission BrokerMsg
r
              -- rejectOrVerify filters allowed commands, no need to repeat it here.
              -- INTERNAL is used because processCommand never returns Nothing for sender commands (could be extracted for better types).
              -- `fst` removes empty message that is only returned for `SUB` command
              Right t'' :: VerifiedTransmission s
t''@(Maybe (StoreQueue s, QueueRec)
_, (CorrId
corrId', RecipientId
entId', Cmd
_)) -> Transmission BrokerMsg
-> ((Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
    -> Transmission BrokerMsg)
-> Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
-> Transmission BrokerMsg
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (CorrId
corrId', RecipientId
entId', ErrorType -> BrokerMsg
ERR ErrorType
INTERNAL) (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
-> Transmission BrokerMsg
forall a b. (a, b) -> a
fst (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
 -> Transmission BrokerMsg)
-> ExceptT
     ErrorType
     (ReaderT (Env s) IO)
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
-> ExceptT ErrorType (ReaderT (Env s) IO) (Transmission BrokerMsg)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT
  (Env s)
  IO
  (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
-> ExceptT
     ErrorType
     (ReaderT (Env s) IO)
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
forall (m :: * -> *) a. Monad m => m a -> ExceptT ErrorType m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Maybe RecipientId
-> Version SMPVersion
-> VerifiedTransmission s
-> ReaderT
     (Env s)
     IO
     (Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
processCommand Maybe RecipientId
forall a. Maybe a
Nothing Version SMPVersion
fwdVersion VerifiedTransmission s
t'')
          -- encode response
          ByteString
r' <- case THandleParams SMPVersion 'TServer
-> NonEmpty (Either TransportError SentRawTransmission)
-> [TransportBatch ()]
forall v (p :: TransportPeer).
THandleParams v p
-> NonEmpty (Either TransportError SentRawTransmission)
-> [TransportBatch ()]
batchTransmissions THandleParams SMPVersion 'TServer
clntTHParams [SentRawTransmission -> Either TransportError SentRawTransmission
forall a b. b -> Either a b
Right (Maybe TAuthorizations
forall a. Maybe a
Nothing, THandleParams SMPVersion 'TServer
-> Transmission BrokerMsg -> ByteString
forall v e c (p :: TransportPeer).
ProtocolEncoding v e c =>
THandleParams v p -> Transmission c -> ByteString
encodeTransmission THandleParams SMPVersion 'TServer
clntTHParams Transmission BrokerMsg
r)] of
            [] -> ErrorType -> ExceptT ErrorType (ReaderT (Env s) IO) ByteString
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE ErrorType
INTERNAL -- at least 1 item is guaranteed from NonEmpty/Right
            TBError TransportError
_ ()
_ : [TransportBatch ()]
_ -> ErrorType -> ExceptT ErrorType (ReaderT (Env s) IO) ByteString
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE ErrorType
BLOCK
            TBTransmission ByteString
b' ()
_ : [TransportBatch ()]
_ -> ByteString -> ExceptT ErrorType (ReaderT (Env s) IO) ByteString
forall a. a -> ExceptT ErrorType (ReaderT (Env s) IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
b'
            TBTransmissions ByteString
b' Int
_ [()]
_ : [TransportBatch ()]
_ -> ByteString -> ExceptT ErrorType (ReaderT (Env s) IO) ByteString
forall a. a -> ExceptT ErrorType (ReaderT (Env s) IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
b'
          -- encrypt to client
          EncResponse
r2 <- (CryptoError -> ErrorType)
-> Either CryptoError EncResponse
-> ExceptT ErrorType (ReaderT (Env s) IO) EncResponse
forall (m :: * -> *) e e' a.
MonadIO m =>
(e -> e') -> Either e a -> ExceptT e' m a
liftEitherWith (ErrorType -> CryptoError -> ErrorType
forall a b. a -> b -> a
const ErrorType
BLOCK) (Either CryptoError EncResponse
 -> ExceptT ErrorType (ReaderT (Env s) IO) EncResponse)
-> Either CryptoError EncResponse
-> ExceptT ErrorType (ReaderT (Env s) IO) EncResponse
forall a b. (a -> b) -> a -> b
$ ByteString -> EncResponse
EncResponse (ByteString -> EncResponse)
-> Either CryptoError ByteString -> Either CryptoError EncResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DhSecret 'X25519
-> CbNonce -> ByteString -> Int -> Either CryptoError ByteString
C.cbEncrypt DhSecret 'X25519
clientSecret (CbNonce -> CbNonce
C.reverseNonce CbNonce
clientNonce) ByteString
r' Int
paddedProxiedTLength
          -- encrypt to proxy
          let fr :: FwdResponse
fr = FwdResponse {CorrId
fwdCorrId :: CorrId
$sel:fwdCorrId:FwdResponse :: CorrId
fwdCorrId, $sel:fwdResponse:FwdResponse :: EncResponse
fwdResponse = EncResponse
r2}
              r3 :: EncFwdResponse
r3 = ByteString -> EncFwdResponse
EncFwdResponse (ByteString -> EncFwdResponse) -> ByteString -> EncFwdResponse
forall a b. (a -> b) -> a -> b
$ DhSecret 'X25519 -> CbNonce -> ByteString -> ByteString
C.cbEncryptNoPad DhSecret 'X25519
sessSecret (CbNonce -> CbNonce
C.reverseNonce CbNonce
proxyNonce) (FwdResponse -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode FwdResponse
fr)
          ServerStats
stats <- (Env s -> ServerStats)
-> ExceptT ErrorType (ReaderT (Env s) IO) ServerStats
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> ServerStats
forall s. Env s -> ServerStats
serverStats
          IORef Int -> ExceptT ErrorType (ReaderT (Env s) IO) ()
forall (m :: * -> *). MonadIO m => IORef Int -> m ()
incStat (IORef Int -> ExceptT ErrorType (ReaderT (Env s) IO) ())
-> IORef Int -> ExceptT ErrorType (ReaderT (Env s) IO) ()
forall a b. (a -> b) -> a -> b
$ ServerStats -> IORef Int
pMsgFwdsRecv ServerStats
stats
          EncFwdResponse
-> ExceptT ErrorType (ReaderT (Env s) IO) EncFwdResponse
forall a. a -> ExceptT ErrorType (ReaderT (Env s) IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure EncFwdResponse
r3
          where
            rejectOrVerify :: Maybe (THandleAuth 'TServer) -> SignedTransmissionOrError ErrorType Cmd -> M s (VerifiedTransmissionOrError s)
            rejectOrVerify :: Maybe (THandleAuth 'TServer)
-> SignedTransmissionOrError ErrorType Cmd
-> ReaderT
     (Env s)
     IO
     (Either (Transmission BrokerMsg) (VerifiedTransmission s))
rejectOrVerify Maybe (THandleAuth 'TServer)
clntThAuth = \case
              Left (CorrId
corrId', RecipientId
entId', ErrorType
e) -> Either (Transmission BrokerMsg) (VerifiedTransmission s)
-> ReaderT
     (Env s)
     IO
     (Either (Transmission BrokerMsg) (VerifiedTransmission s))
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Transmission BrokerMsg) (VerifiedTransmission s)
 -> ReaderT
      (Env s)
      IO
      (Either (Transmission BrokerMsg) (VerifiedTransmission s)))
-> Either (Transmission BrokerMsg) (VerifiedTransmission s)
-> ReaderT
     (Env s)
     IO
     (Either (Transmission BrokerMsg) (VerifiedTransmission s))
forall a b. (a -> b) -> a -> b
$ Transmission BrokerMsg
-> Either (Transmission BrokerMsg) (VerifiedTransmission s)
forall a b. a -> Either a b
Left (CorrId
corrId', RecipientId
entId', ErrorType -> BrokerMsg
ERR ErrorType
e)
              Right t' :: SignedTransmission Cmd
t'@(Maybe TAuthorizations
_, ByteString
_, t'' :: (CorrId, RecipientId, Cmd)
t''@(CorrId
corrId', RecipientId
entId', Cmd
cmd'))
                | Bool
allowed -> IO (Either (Transmission BrokerMsg) (VerifiedTransmission s))
-> ReaderT
     (Env s)
     IO
     (Either (Transmission BrokerMsg) (VerifiedTransmission s))
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either (Transmission BrokerMsg) (VerifiedTransmission s))
 -> ReaderT
      (Env s)
      IO
      (Either (Transmission BrokerMsg) (VerifiedTransmission s)))
-> IO (Either (Transmission BrokerMsg) (VerifiedTransmission s))
-> ReaderT
     (Env s)
     IO
     (Either (Transmission BrokerMsg) (VerifiedTransmission s))
forall a b. (a -> b) -> a -> b
$ VerificationResult s
-> Either (Transmission BrokerMsg) (VerifiedTransmission s)
verified (VerificationResult s
 -> Either (Transmission BrokerMsg) (VerifiedTransmission s))
-> IO (VerificationResult s)
-> IO (Either (Transmission BrokerMsg) (VerifiedTransmission s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> s
-> Maybe THPeerClientService
-> Maybe (THandleAuth 'TServer)
-> SignedTransmission Cmd
-> IO (VerificationResult s)
forall s.
MsgStoreClass s =>
s
-> Maybe THPeerClientService
-> Maybe (THandleAuth 'TServer)
-> SignedTransmission Cmd
-> IO (VerificationResult s)
verifyTransmission s
ms Maybe THPeerClientService
forall a. Maybe a
Nothing Maybe (THandleAuth 'TServer)
clntThAuth SignedTransmission Cmd
t'
                | Bool
otherwise -> Either (Transmission BrokerMsg) (VerifiedTransmission s)
-> ReaderT
     (Env s)
     IO
     (Either (Transmission BrokerMsg) (VerifiedTransmission s))
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Transmission BrokerMsg) (VerifiedTransmission s)
 -> ReaderT
      (Env s)
      IO
      (Either (Transmission BrokerMsg) (VerifiedTransmission s)))
-> Either (Transmission BrokerMsg) (VerifiedTransmission s)
-> ReaderT
     (Env s)
     IO
     (Either (Transmission BrokerMsg) (VerifiedTransmission s))
forall a b. (a -> b) -> a -> b
$ Transmission BrokerMsg
-> Either (Transmission BrokerMsg) (VerifiedTransmission s)
forall a b. a -> Either a b
Left (CorrId
corrId', RecipientId
entId', ErrorType -> BrokerMsg
ERR (ErrorType -> BrokerMsg) -> ErrorType -> BrokerMsg
forall a b. (a -> b) -> a -> b
$ CommandError -> ErrorType
CMD CommandError
PROHIBITED)
                where
                  allowed :: Bool
allowed = case Cmd
cmd' of
                    Cmd SParty p
SSender SEND {} -> Bool
True
                    Cmd SParty p
SSender (SKEY RcvPublicAuthKey
_) -> Bool
True
                    Cmd SParty p
SSenderLink (LKEY RcvPublicAuthKey
_) -> Bool
True
                    Cmd SParty p
SSenderLink Command p
LGET -> Bool
True
                    Cmd
_ -> Bool
False
                  verified :: VerificationResult s
-> Either (Transmission BrokerMsg) (VerifiedTransmission s)
verified = \case
                    VRVerified Maybe (StoreQueue s, QueueRec)
q -> VerifiedTransmission s
-> Either (Transmission BrokerMsg) (VerifiedTransmission s)
forall a b. b -> Either a b
Right (Maybe (StoreQueue s, QueueRec)
q, (CorrId, RecipientId, Cmd)
t'')
                    VRFailed ErrorType
e -> Transmission BrokerMsg
-> Either (Transmission BrokerMsg) (VerifiedTransmission s)
forall a b. a -> Either a b
Left (CorrId
corrId', RecipientId
entId', ErrorType -> BrokerMsg
ERR ErrorType
e)

        encryptMsg :: QueueRec -> Message -> RcvMessage
        encryptMsg :: QueueRec -> Message -> RcvMessage
encryptMsg QueueRec
qr Message
msg = MaxLenBS 16104 -> RcvMessage
forall (i :: Natural). KnownNat i => MaxLenBS i -> RcvMessage
encrypt (MaxLenBS 16104 -> RcvMessage)
-> (RcvMsgBody -> MaxLenBS 16104) -> RcvMsgBody -> RcvMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RcvMsgBody -> MaxLenBS 16104
RcvMsgBody -> MaxLenBS MaxRcvMessageLen
encodeRcvMsgBody (RcvMsgBody -> RcvMessage) -> RcvMsgBody -> RcvMessage
forall a b. (a -> b) -> a -> b
$ case Message
msg of
          Message {MsgFlags
$sel:msgFlags:Message :: Message -> MsgFlags
msgFlags :: MsgFlags
msgFlags, MaxLenBS MaxMessageLen
msgBody :: MaxLenBS MaxMessageLen
$sel:msgBody:Message :: Message -> MaxLenBS MaxMessageLen
msgBody} -> RcvMsgBody {$sel:msgTs:RcvMsgBody :: SystemTime
msgTs = SystemTime
msgTs', MsgFlags
msgFlags :: MsgFlags
$sel:msgFlags:RcvMsgBody :: MsgFlags
msgFlags, MaxLenBS MaxMessageLen
msgBody :: MaxLenBS MaxMessageLen
$sel:msgBody:RcvMsgBody :: MaxLenBS MaxMessageLen
msgBody}
          MessageQuota {} -> SystemTime -> RcvMsgBody
RcvMsgQuota SystemTime
msgTs'
          where
            encrypt :: KnownNat i => C.MaxLenBS i -> RcvMessage
            encrypt :: forall (i :: Natural). KnownNat i => MaxLenBS i -> RcvMessage
encrypt MaxLenBS i
body = ByteString -> EncRcvMsgBody -> RcvMessage
RcvMessage ByteString
msgId' (EncRcvMsgBody -> RcvMessage)
-> (ByteString -> EncRcvMsgBody) -> ByteString -> RcvMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> EncRcvMsgBody
EncRcvMsgBody (ByteString -> RcvMessage) -> ByteString -> RcvMessage
forall a b. (a -> b) -> a -> b
$ DhSecret 'X25519 -> CbNonce -> MaxLenBS i -> ByteString
forall (i :: Natural).
KnownNat i =>
DhSecret 'X25519 -> CbNonce -> MaxLenBS i -> ByteString
C.cbEncryptMaxLenBS (QueueRec -> DhSecret 'X25519
rcvDhSecret QueueRec
qr) (ByteString -> CbNonce
C.cbNonce ByteString
msgId') MaxLenBS i
body
            msgId' :: ByteString
msgId' = Message -> ByteString
messageId Message
msg
            msgTs' :: SystemTime
msgTs' = Message -> SystemTime
messageTs Message
msg

        setDelivered :: Sub -> Message -> SystemSeconds -> STM ()
        setDelivered :: Sub -> Message -> SystemSeconds -> STM ()
setDelivered Sub {TVar (Maybe (ByteString, SystemSeconds))
$sel:delivered:Sub :: Sub -> TVar (Maybe (ByteString, SystemSeconds))
delivered :: TVar (Maybe (ByteString, SystemSeconds))
delivered} Message
msg !SystemSeconds
ts = do
          let !msgId :: ByteString
msgId = Message -> ByteString
messageId Message
msg
          TVar (Maybe (ByteString, SystemSeconds))
-> Maybe (ByteString, SystemSeconds) -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe (ByteString, SystemSeconds))
delivered (Maybe (ByteString, SystemSeconds) -> STM ())
-> Maybe (ByteString, SystemSeconds) -> STM ()
forall a b. (a -> b) -> a -> b
$ (ByteString, SystemSeconds) -> Maybe (ByteString, SystemSeconds)
forall a. a -> Maybe a
Just (ByteString
msgId, SystemSeconds
ts)

        delQueueAndMsgs :: (StoreQueue s, QueueRec) -> M s (Transmission BrokerMsg)
        delQueueAndMsgs :: (StoreQueue s, QueueRec) -> M s (Transmission BrokerMsg)
delQueueAndMsgs (StoreQueue s
q, QueueRec {Maybe RecipientId
$sel:rcvServiceId:QueueRec :: QueueRec -> Maybe RecipientId
rcvServiceId :: Maybe RecipientId
rcvServiceId}) = do
          IO (Either ErrorType QueueRec)
-> ReaderT (Env s) IO (Either ErrorType QueueRec)
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (s -> StoreQueue s -> IO (Either ErrorType QueueRec)
forall s.
MsgStoreClass s =>
s -> StoreQueue s -> IO (Either ErrorType QueueRec)
deleteQueue s
ms StoreQueue s
q) ReaderT (Env s) IO (Either ErrorType QueueRec)
-> (Either ErrorType QueueRec -> M s (Transmission BrokerMsg))
-> M s (Transmission BrokerMsg)
forall a b.
ReaderT (Env s) IO a
-> (a -> ReaderT (Env s) IO b) -> ReaderT (Env s) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Right QueueRec
qr -> do
              -- Possibly, the same should be done if the queue is suspended, but currently we do not use it
              -- queue is usually deleted by the same client that is currently subscribed,
              -- we delete subscription here, so the client with no subscriptions can be disconnected.
              Maybe Sub
sub <- STM (Maybe Sub) -> ReaderT (Env s) IO (Maybe Sub)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Maybe Sub) -> ReaderT (Env s) IO (Maybe Sub))
-> STM (Maybe Sub) -> ReaderT (Env s) IO (Maybe Sub)
forall a b. (a -> b) -> a -> b
$ RecipientId -> TMap RecipientId Sub -> STM (Maybe Sub)
forall k a. Ord k => k -> TMap k a -> STM (Maybe a)
TM.lookupDelete RecipientId
entId (TMap RecipientId Sub -> STM (Maybe Sub))
-> TMap RecipientId Sub -> STM (Maybe Sub)
forall a b. (a -> b) -> a -> b
$ Client s -> TMap RecipientId Sub
forall s. Client s -> TMap RecipientId Sub
subscriptions Client s
clnt
              IO () -> M s ()
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
forall a b. (a -> b) -> a -> b
$ (Sub -> IO ()) -> Maybe Sub -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Sub -> IO ()
cancelSub Maybe Sub
sub
              STM () -> M s ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> M s ()) -> STM () -> M s ()
forall a b. (a -> b) -> a -> b
$ TQueue (ClientSub, Int) -> (ClientSub, Int) -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue (ServerSubscribers s -> TQueue (ClientSub, Int)
forall s. ServerSubscribers s -> TQueue (ClientSub, Int)
subQ ServerSubscribers s
subscribers) (RecipientId -> Maybe RecipientId -> ClientSub
CSDeleted RecipientId
entId Maybe RecipientId
rcvServiceId, Int
clientId)
              Maybe NtfCreds -> (NtfCreds -> M s ()) -> M s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (QueueRec -> Maybe NtfCreds
notifier QueueRec
qr) ((NtfCreds -> M s ()) -> M s ()) -> (NtfCreds -> M s ()) -> M s ()
forall a b. (a -> b) -> a -> b
$ \NtfCreds {$sel:notifierId:NtfCreds :: NtfCreds -> RecipientId
notifierId = RecipientId
nId, Maybe RecipientId
$sel:ntfServiceId:NtfCreds :: NtfCreds -> Maybe RecipientId
ntfServiceId :: Maybe RecipientId
ntfServiceId} -> do
                -- queue is deleted by a different client from the one subscribed to notifications,
                -- so we don't need to remove subscription from the current client.
                ServerStats
stats <- (Env s -> ServerStats) -> ReaderT (Env s) IO ServerStats
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> ServerStats
forall s. Env s -> ServerStats
serverStats
                Int
deleted <- (Env s -> NtfStore) -> ReaderT (Env s) IO NtfStore
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> NtfStore
forall s. Env s -> NtfStore
ntfStore ReaderT (Env s) IO NtfStore
-> (NtfStore -> ReaderT (Env s) IO Int) -> ReaderT (Env s) IO Int
forall a b.
ReaderT (Env s) IO a
-> (a -> ReaderT (Env s) IO b) -> ReaderT (Env s) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO Int -> ReaderT (Env s) IO Int
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> ReaderT (Env s) IO Int)
-> (NtfStore -> IO Int) -> NtfStore -> ReaderT (Env s) IO Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NtfStore -> RecipientId -> IO Int
`deleteNtfs` RecipientId
nId)
                Bool -> M s () -> M s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
deleted Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (M s () -> M s ()) -> M s () -> M s ()
forall a b. (a -> b) -> a -> b
$ IO () -> M s ()
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
forall a b. (a -> b) -> a -> b
$ IORef Int -> (Int -> Int) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef'_ (ServerStats -> IORef Int
ntfCount ServerStats
stats) (Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
deleted)
                STM () -> M s ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> M s ()) -> STM () -> M s ()
forall a b. (a -> b) -> a -> b
$ TQueue (ClientSub, Int) -> (ClientSub, Int) -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue (ServerSubscribers s -> TQueue (ClientSub, Int)
forall s. ServerSubscribers s -> TQueue (ClientSub, Int)
subQ ServerSubscribers s
ntfSubscribers) (RecipientId -> Maybe RecipientId -> ClientSub
CSDeleted RecipientId
nId Maybe RecipientId
ntfServiceId, Int
clientId)
              QueueRec -> M s ()
forall s. QueueRec -> M s ()
updateDeletedStats QueueRec
qr
              Transmission BrokerMsg -> M s (Transmission BrokerMsg)
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Transmission BrokerMsg
ok
            Left ErrorType
e -> Transmission BrokerMsg -> M s (Transmission BrokerMsg)
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Transmission BrokerMsg -> M s (Transmission BrokerMsg))
-> Transmission BrokerMsg -> M s (Transmission BrokerMsg)
forall a b. (a -> b) -> a -> b
$ ErrorType -> Transmission BrokerMsg
err ErrorType
e

        getQueueInfo :: StoreQueue s -> QueueRec -> M s BrokerMsg
        getQueueInfo :: StoreQueue s -> QueueRec -> ReaderT (Env s) IO BrokerMsg
getQueueInfo StoreQueue s
q QueueRec {Maybe RcvPublicAuthKey
$sel:senderKey:QueueRec :: QueueRec -> Maybe RcvPublicAuthKey
senderKey :: Maybe RcvPublicAuthKey
senderKey, Maybe NtfCreds
$sel:notifier:QueueRec :: QueueRec -> Maybe NtfCreds
notifier :: Maybe NtfCreds
notifier} = do
          (Either ErrorType QueueInfo -> BrokerMsg)
-> ReaderT (Env s) IO (Either ErrorType QueueInfo)
-> ReaderT (Env s) IO BrokerMsg
forall a b.
(a -> b) -> ReaderT (Env s) IO a -> ReaderT (Env s) IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ErrorType -> BrokerMsg)
-> (QueueInfo -> BrokerMsg)
-> Either ErrorType QueueInfo
-> BrokerMsg
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ErrorType -> BrokerMsg
ERR QueueInfo -> BrokerMsg
INFO) (ReaderT (Env s) IO (Either ErrorType QueueInfo)
 -> ReaderT (Env s) IO BrokerMsg)
-> ReaderT (Env s) IO (Either ErrorType QueueInfo)
-> ReaderT (Env s) IO BrokerMsg
forall a b. (a -> b) -> a -> b
$ IO (Either ErrorType QueueInfo)
-> ReaderT (Env s) IO (Either ErrorType QueueInfo)
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ErrorType QueueInfo)
 -> ReaderT (Env s) IO (Either ErrorType QueueInfo))
-> IO (Either ErrorType QueueInfo)
-> ReaderT (Env s) IO (Either ErrorType QueueInfo)
forall a b. (a -> b) -> a -> b
$ ExceptT ErrorType IO QueueInfo -> IO (Either ErrorType QueueInfo)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ErrorType IO QueueInfo -> IO (Either ErrorType QueueInfo))
-> ExceptT ErrorType IO QueueInfo
-> IO (Either ErrorType QueueInfo)
forall a b. (a -> b) -> a -> b
$ do
            Maybe QSub
qiSub <- IO (Maybe QSub) -> ExceptT ErrorType IO (Maybe QSub)
forall a. IO a -> ExceptT ErrorType IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe QSub) -> ExceptT ErrorType IO (Maybe QSub))
-> IO (Maybe QSub) -> ExceptT ErrorType IO (Maybe QSub)
forall a b. (a -> b) -> a -> b
$ RecipientId -> TMap RecipientId Sub -> IO (Maybe Sub)
forall k a. Ord k => k -> TMap k a -> IO (Maybe a)
TM.lookupIO RecipientId
entId (Client s -> TMap RecipientId Sub
forall s. Client s -> TMap RecipientId Sub
subscriptions Client s
clnt) IO (Maybe Sub) -> (Maybe Sub -> IO (Maybe QSub)) -> IO (Maybe QSub)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Sub -> IO QSub) -> Maybe Sub -> IO (Maybe QSub)
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) -> Maybe a -> m (Maybe b)
mapM Sub -> IO QSub
forall {m :: * -> *}. MonadIO m => Sub -> m QSub
mkQSub
            Int
qiSize <- s -> StoreQueue s -> ExceptT ErrorType IO Int
forall s.
MsgStoreClass s =>
s -> StoreQueue s -> ExceptT ErrorType IO Int
getQueueSize s
ms StoreQueue s
q
            Maybe MsgInfo
qiMsg <- Message -> MsgInfo
toMsgInfo (Message -> MsgInfo)
-> ExceptT ErrorType IO (Maybe Message)
-> ExceptT ErrorType IO (Maybe MsgInfo)
forall (f :: * -> *) (g :: * -> *) a b.
(Functor f, Functor g) =>
(a -> b) -> f (g a) -> f (g b)
<$$> s -> StoreQueue s -> ExceptT ErrorType IO (Maybe Message)
forall s.
MsgStoreClass s =>
s -> StoreQueue s -> ExceptT ErrorType IO (Maybe Message)
tryPeekMsg s
ms StoreQueue s
q
            let info :: QueueInfo
info = QueueInfo {qiSnd :: Bool
qiSnd = Maybe RcvPublicAuthKey -> Bool
forall a. Maybe a -> Bool
isJust Maybe RcvPublicAuthKey
senderKey, qiNtf :: Bool
qiNtf = Maybe NtfCreds -> Bool
forall a. Maybe a -> Bool
isJust Maybe NtfCreds
notifier, Maybe QSub
qiSub :: Maybe QSub
qiSub :: Maybe QSub
qiSub, Int
qiSize :: Int
qiSize :: Int
qiSize, Maybe MsgInfo
qiMsg :: Maybe MsgInfo
qiMsg :: Maybe MsgInfo
qiMsg}
            QueueInfo -> ExceptT ErrorType IO QueueInfo
forall a. a -> ExceptT ErrorType IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure QueueInfo
info
          where
            mkQSub :: Sub -> m QSub
mkQSub Sub {ServerSub
$sel:subThread:Sub :: Sub -> ServerSub
subThread :: ServerSub
subThread, TVar (Maybe (ByteString, SystemSeconds))
$sel:delivered:Sub :: Sub -> TVar (Maybe (ByteString, SystemSeconds))
delivered :: TVar (Maybe (ByteString, SystemSeconds))
delivered} = do
              QSubThread
qSubThread <- case ServerSub
subThread of
                ServerSub TVar SubscriptionThread
t -> do
                  SubscriptionThread
st <- TVar SubscriptionThread -> m SubscriptionThread
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar SubscriptionThread
t
                  QSubThread -> m QSubThread
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (QSubThread -> m QSubThread) -> QSubThread -> m QSubThread
forall a b. (a -> b) -> a -> b
$ case SubscriptionThread
st of
                    SubscriptionThread
NoSub -> QSubThread
QNoSub
                    SubscriptionThread
SubPending -> QSubThread
QSubPending
                    SubThread Weak ThreadId
_ -> QSubThread
QSubThread
                ServerSub
ProhibitSub -> QSubThread -> m QSubThread
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure QSubThread
QProhibitSub
              Maybe Text
qDelivered <- ByteString -> Text
decodeLatin1 (ByteString -> Text)
-> ((ByteString, SystemSeconds) -> ByteString)
-> (ByteString, SystemSeconds)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
encode (ByteString -> ByteString)
-> ((ByteString, SystemSeconds) -> ByteString)
-> (ByteString, SystemSeconds)
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, SystemSeconds) -> ByteString
forall a b. (a, b) -> a
fst ((ByteString, SystemSeconds) -> Text)
-> m (Maybe (ByteString, SystemSeconds)) -> m (Maybe Text)
forall (f :: * -> *) (g :: * -> *) a b.
(Functor f, Functor g) =>
(a -> b) -> f (g a) -> f (g b)
<$$> TVar (Maybe (ByteString, SystemSeconds))
-> m (Maybe (ByteString, SystemSeconds))
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Maybe (ByteString, SystemSeconds))
delivered
              QSub -> m QSub
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure QSub {QSubThread
qSubThread :: QSubThread
qSubThread :: QSubThread
qSubThread, Maybe Text
qDelivered :: Maybe Text
qDelivered :: Maybe Text
qDelivered}

        ok :: Transmission BrokerMsg
        ok :: Transmission BrokerMsg
ok = (CorrId
corrId, RecipientId
entId, BrokerMsg
OK)
        {-# INLINE ok #-}

        err :: ErrorType -> Transmission BrokerMsg
        err :: ErrorType -> Transmission BrokerMsg
err ErrorType
e = (CorrId
corrId, RecipientId
entId, ErrorType -> BrokerMsg
ERR ErrorType
e)
        {-# INLINE err #-}

        response :: Transmission BrokerMsg -> Maybe ResponseAndMessage
        response :: Transmission BrokerMsg
-> Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
response = (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
-> Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
forall a. a -> Maybe a
Just ((Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
 -> Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
-> (Transmission BrokerMsg
    -> (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)))
-> Transmission BrokerMsg
-> Maybe (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,Maybe (Transmission BrokerMsg)
forall a. Maybe a
Nothing)
        {-# INLINE response #-}

updateDeletedStats :: QueueRec -> M s ()
updateDeletedStats :: forall s. QueueRec -> M s ()
updateDeletedStats QueueRec
q = do
  ServerStats
stats <- (Env s -> ServerStats) -> ReaderT (Env s) IO ServerStats
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> ServerStats
forall s. Env s -> ServerStats
serverStats
  let delSel :: ServerStats -> IORef Int
delSel = if Maybe RcvPublicAuthKey -> Bool
forall a. Maybe a -> Bool
isNothing (QueueRec -> Maybe RcvPublicAuthKey
senderKey QueueRec
q) then ServerStats -> IORef Int
qDeletedNew else ServerStats -> IORef Int
qDeletedSecured
  IORef Int -> M s ()
forall (m :: * -> *). MonadIO m => IORef Int -> m ()
incStat (IORef Int -> M s ()) -> IORef Int -> M s ()
forall a b. (a -> b) -> a -> b
$ ServerStats -> IORef Int
delSel ServerStats
stats
  IORef Int -> M s ()
forall (m :: * -> *). MonadIO m => IORef Int -> m ()
incStat (IORef Int -> M s ()) -> IORef Int -> M s ()
forall a b. (a -> b) -> a -> b
$ ServerStats -> IORef Int
qDeletedAll ServerStats
stats
  IO () -> M s ()
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> M s ()) -> IO () -> M s ()
forall a b. (a -> b) -> a -> b
$ IORef Int -> (Int -> Int) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef'_ (ServerStats -> IORef Int
qCount ServerStats
stats) (Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
1)

incStat :: MonadIO m => IORef Int -> m ()
incStat :: forall (m :: * -> *). MonadIO m => IORef Int -> m ()
incStat IORef Int
r = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef Int -> (Int -> Int) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef'_ IORef Int
r (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
{-# INLINE incStat #-}

randomId' :: Int -> M s ByteString
randomId' :: forall s. Int -> M s ByteString
randomId' Int
n = STM ByteString -> ReaderT (Env s) IO ByteString
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM ByteString -> ReaderT (Env s) IO ByteString)
-> (TVar ChaChaDRG -> STM ByteString)
-> TVar ChaChaDRG
-> ReaderT (Env s) IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> TVar ChaChaDRG -> STM ByteString
C.randomBytes Int
n (TVar ChaChaDRG -> ReaderT (Env s) IO ByteString)
-> ReaderT (Env s) IO (TVar ChaChaDRG)
-> ReaderT (Env s) IO ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Env s -> TVar ChaChaDRG) -> ReaderT (Env s) IO (TVar ChaChaDRG)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> TVar ChaChaDRG
forall s. Env s -> TVar ChaChaDRG
random

randomId :: Int -> M s EntityId
randomId :: forall s. Int -> M s RecipientId
randomId = (ByteString -> RecipientId)
-> ReaderT (Env s) IO ByteString -> ReaderT (Env s) IO RecipientId
forall a b.
(a -> b) -> ReaderT (Env s) IO a -> ReaderT (Env s) IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> RecipientId
EntityId (ReaderT (Env s) IO ByteString -> ReaderT (Env s) IO RecipientId)
-> (Int -> ReaderT (Env s) IO ByteString)
-> Int
-> ReaderT (Env s) IO RecipientId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ReaderT (Env s) IO ByteString
forall s. Int -> M s ByteString
randomId'
{-# INLINE randomId #-}

saveServerMessages :: Bool -> MsgStore s -> IO ()
saveServerMessages :: forall s. Bool -> MsgStore s -> IO ()
saveServerMessages Bool
drainMsgs MsgStore s
ms = case MsgStore s
ms of
  StoreMemory STMMsgStore {$sel:storeConfig:STMMsgStore :: STMMsgStore -> STMStoreConfig
storeConfig = STMStoreConfig {Maybe String
storePath :: Maybe String
$sel:storePath:STMStoreConfig :: STMStoreConfig -> Maybe String
storePath}} -> case Maybe String
storePath of
    Just String
f -> Bool -> MsgStore s -> String -> Bool -> IO ()
forall s.
MsgStoreClass s =>
Bool -> MsgStore s -> String -> Bool -> IO ()
exportMessages Bool
False MsgStore s
ms String
f Bool
drainMsgs
    Maybe String
Nothing -> Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logNote Text
"undelivered messages are not saved"
  StoreJournal JournalMsgStore qs
_ -> Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logNote Text
"closed journal message storage"
#if defined(dbServerPostgres)
  StoreDatabase _ -> logNote "closed postgres message storage"
#endif

exportMessages :: forall s. MsgStoreClass s => Bool -> MsgStore s -> FilePath -> Bool -> IO ()
exportMessages :: forall s.
MsgStoreClass s =>
Bool -> MsgStore s -> String -> Bool -> IO ()
exportMessages Bool
tty MsgStore s
st String
f Bool
drainMsgs = do
  Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logNote (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"saving messages to file " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
f
  (Handle -> IO Int) -> IO ()
run ((Handle -> IO Int) -> IO ()) -> (Handle -> IO Int) -> IO ()
forall a b. (a -> b) -> a -> b
$ case MsgStore s
st of
    StoreMemory STMMsgStore
ms -> s -> (StoreQueue s -> IO [Message]) -> Handle -> IO Int
exportMessages_ s
STMMsgStore
ms ((StoreQueue s -> IO [Message]) -> Handle -> IO Int)
-> (StoreQueue s -> IO [Message]) -> Handle -> IO Int
forall a b. (a -> b) -> a -> b
$ STMMsgStore -> StoreQueue STMMsgStore -> IO [Message]
forall s'. MsgStoreClass s' => s' -> StoreQueue s' -> IO [Message]
getMsgs STMMsgStore
ms
    StoreJournal JournalMsgStore qs
ms -> s -> (StoreQueue s -> IO [Message]) -> Handle -> IO Int
exportMessages_ s
JournalMsgStore qs
ms ((StoreQueue s -> IO [Message]) -> Handle -> IO Int)
-> (StoreQueue s -> IO [Message]) -> Handle -> IO Int
forall a b. (a -> b) -> a -> b
$ JournalMsgStore qs -> JournalQueue qs -> IO [Message]
forall {s :: QSType}.
JournalMsgStore s -> JournalQueue s -> IO [Message]
getJournalMsgs JournalMsgStore qs
ms
#if defined(dbServerPostgres)
    StoreDatabase ms -> exportDbMessages tty ms
#endif
  where
    exportMessages_ :: s -> (StoreQueue s -> IO [Message]) -> Handle -> IO Int
exportMessages_ s
ms StoreQueue s -> IO [Message]
get = (Sum Int -> Int) -> IO (Sum Int) -> IO Int
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Sum Int
n) -> Int
n) (IO (Sum Int) -> IO Int)
-> (Handle -> IO (Sum Int)) -> Handle -> IO Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> s -> (StoreQueue s -> IO (Sum Int)) -> IO (Sum Int)
forall a. Monoid a => Bool -> s -> (StoreQueue s -> IO a) -> IO a
forall s a.
(MsgStoreClass s, Monoid a) =>
Bool -> s -> (StoreQueue s -> IO a) -> IO a
unsafeWithAllMsgQueues Bool
tty s
ms ((StoreQueue s -> IO (Sum Int)) -> IO (Sum Int))
-> (Handle -> StoreQueue s -> IO (Sum Int))
-> Handle
-> IO (Sum Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StoreQueue s -> IO [Message])
-> Handle -> StoreQueue s -> IO (Sum Int)
saveQueueMsgs StoreQueue s -> IO [Message]
get
    run :: (Handle -> IO Int) -> IO ()
    run :: (Handle -> IO Int) -> IO ()
run Handle -> IO Int
a = IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IOMode -> (Handle -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> IOMode -> (Handle -> m a) -> m a
withFile String
f IOMode
WriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO Int -> IO (Either SomeException Int)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (IO Int -> IO (Either SomeException Int))
-> (Handle -> IO Int) -> Handle -> IO (Either SomeException Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> IO Int
a (Handle -> IO (Either SomeException Int))
-> (Either SomeException Int -> IO ()) -> Handle -> IO ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \case
      Right Int
n -> Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logNote (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"messages saved: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
n
      Left SomeException
e -> do
        Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logError (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"error exporting messages: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeException -> Text
forall a. Show a => a -> Text
tshow SomeException
e
        IO ()
forall a. IO a
exitFailure
    getJournalMsgs :: JournalMsgStore s -> JournalQueue s -> IO [Message]
getJournalMsgs JournalMsgStore s
ms JournalQueue s
q =
      TVar (Maybe (JournalMsgQueue s)) -> IO (Maybe (JournalMsgQueue s))
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (JournalQueue s -> TVar (Maybe (JournalMsgQueue s))
forall (s :: QSType).
JournalQueue s -> TVar (Maybe (JournalMsgQueue s))
msgQueue' JournalQueue s
q) IO (Maybe (JournalMsgQueue s))
-> (Maybe (JournalMsgQueue s) -> IO [Message]) -> IO [Message]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just JournalMsgQueue s
_ -> JournalMsgStore s -> StoreQueue (JournalMsgStore s) -> IO [Message]
forall s'. MsgStoreClass s' => s' -> StoreQueue s' -> IO [Message]
getMsgs JournalMsgStore s
ms StoreQueue (JournalMsgStore s)
JournalQueue s
q
        Maybe (JournalMsgQueue s)
Nothing -> JournalMsgStore s -> JournalQueue s -> IO [Message]
forall {s :: QSType}.
JournalMsgStore s -> JournalQueue s -> IO [Message]
getJournalQueueMessages JournalMsgStore s
ms JournalQueue s
q
    getMsgs :: MsgStoreClass s' => s' -> StoreQueue s' -> IO [Message]
    getMsgs :: forall s'. MsgStoreClass s' => s' -> StoreQueue s' -> IO [Message]
getMsgs s'
ms StoreQueue s'
q = StoreQueue s' -> Text -> StoreMonad s' [Message] -> IO [Message]
forall s a.
MsgStoreClass s =>
StoreQueue s -> Text -> StoreMonad s a -> IO a
forall a. StoreQueue s' -> Text -> StoreMonad s' a -> IO a
unsafeRunStore StoreQueue s'
q Text
"saveQueueMsgs" (StoreMonad s' [Message] -> IO [Message])
-> StoreMonad s' [Message] -> IO [Message]
forall a b. (a -> b) -> a -> b
$ Bool -> StoreQueue s' -> MsgQueue s' -> StoreMonad s' [Message]
forall s.
MsgStoreClass s =>
Bool -> StoreQueue s -> MsgQueue s -> StoreMonad s [Message]
getQueueMessages_ Bool
drainMsgs StoreQueue s'
q (MsgQueue s' -> StoreMonad s' [Message])
-> StoreMonad s' (MsgQueue s') -> StoreMonad s' [Message]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< s' -> StoreQueue s' -> Bool -> StoreMonad s' (MsgQueue s')
forall s.
MsgStoreClass s =>
s -> StoreQueue s -> Bool -> StoreMonad s (MsgQueue s)
getMsgQueue s'
ms StoreQueue s'
q Bool
False
    saveQueueMsgs :: (StoreQueue s -> IO [Message]) -> Handle -> StoreQueue s -> IO (Sum Int)
    saveQueueMsgs :: (StoreQueue s -> IO [Message])
-> Handle -> StoreQueue s -> IO (Sum Int)
saveQueueMsgs StoreQueue s -> IO [Message]
get Handle
h StoreQueue s
q = do
      [Message]
msgs <- StoreQueue s -> IO [Message]
get StoreQueue s
q
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Message] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Message]
msgs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> Builder -> IO ()
BLD.hPutBuilder Handle
h (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ RecipientId -> [Message] -> Builder
encodeMessages (StoreQueue s -> RecipientId
forall q. StoreQueueClass q => q -> RecipientId
recipientId StoreQueue s
q) [Message]
msgs
      Sum Int -> IO (Sum Int)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Sum Int -> IO (Sum Int)) -> Sum Int -> IO (Sum Int)
forall a b. (a -> b) -> a -> b
$ Int -> Sum Int
forall a. a -> Sum a
Sum (Int -> Sum Int) -> Int -> Sum Int
forall a b. (a -> b) -> a -> b
$ [Message] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Message]
msgs
    encodeMessages :: RecipientId -> [Message] -> Builder
encodeMessages RecipientId
rId = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder)
-> ([Message] -> [Builder]) -> [Message] -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Message -> Builder) -> [Message] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (\Message
msg -> ByteString -> Builder
BLD.byteString (MsgLogRecord -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode (MsgLogRecord -> ByteString) -> MsgLogRecord -> ByteString
forall a b. (a -> b) -> a -> b
$ RecipientId -> Message -> MsgLogRecord
MLRv3 RecipientId
rId Message
msg) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
BLD.char8 Char
'\n')

processServerMessages :: forall s'. StartOptions -> M s' (Maybe MessageStats)
processServerMessages :: forall s'. StartOptions -> M s' (Maybe MessageStats)
processServerMessages StartOptions {Bool
skipWarnings :: Bool
$sel:skipWarnings:StartOptions :: StartOptions -> Bool
skipWarnings} = do
  Maybe Int64
old_ <- (Env s' -> Maybe ExpirationConfig)
-> ReaderT (Env s') IO (Maybe ExpirationConfig)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerConfig s' -> Maybe ExpirationConfig
forall s. ServerConfig s -> Maybe ExpirationConfig
messageExpiration (ServerConfig s' -> Maybe ExpirationConfig)
-> (Env s' -> ServerConfig s') -> Env s' -> Maybe ExpirationConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env s' -> ServerConfig s'
forall s. Env s -> ServerConfig s
config) ReaderT (Env s') IO (Maybe ExpirationConfig)
-> (ExpirationConfig -> ReaderT (Env s') IO (Maybe Int64))
-> ReaderT (Env s') IO (Maybe Int64)
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Monad f, Traversable f) =>
m (f a) -> (a -> m (f b)) -> m (f b)
$>>= (IO (Maybe Int64) -> ReaderT (Env s') IO (Maybe Int64)
forall a. IO a -> ReaderT (Env s') IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Int64) -> ReaderT (Env s') IO (Maybe Int64))
-> (ExpirationConfig -> IO (Maybe Int64))
-> ExpirationConfig
-> ReaderT (Env s') IO (Maybe Int64)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int64 -> Maybe Int64) -> IO Int64 -> IO (Maybe Int64)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int64 -> Maybe Int64
forall a. a -> Maybe a
Just (IO Int64 -> IO (Maybe Int64))
-> (ExpirationConfig -> IO Int64)
-> ExpirationConfig
-> IO (Maybe Int64)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExpirationConfig -> IO Int64
expireBeforeEpoch)
  Bool
expire <- (Env s' -> Bool) -> ReaderT (Env s') IO Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Env s' -> Bool) -> ReaderT (Env s') IO Bool)
-> (Env s' -> Bool) -> ReaderT (Env s') IO Bool
forall a b. (a -> b) -> a -> b
$ ServerConfig s' -> Bool
forall s. ServerConfig s -> Bool
expireMessagesOnStart (ServerConfig s' -> Bool)
-> (Env s' -> ServerConfig s') -> Env s' -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env s' -> ServerConfig s'
forall s. Env s -> ServerConfig s
config
  (Env s' -> MsgStore s') -> ReaderT (Env s') IO (MsgStore s')
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s' -> MsgStore s'
forall s. Env s -> MsgStore s
msgStore_ ReaderT (Env s') IO (MsgStore s')
-> (MsgStore s' -> M s' (Maybe MessageStats))
-> M s' (Maybe MessageStats)
forall a b.
ReaderT (Env s') IO a
-> (a -> ReaderT (Env s') IO b) -> ReaderT (Env s') IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO (Maybe MessageStats) -> M s' (Maybe MessageStats)
forall a. IO a -> ReaderT (Env s') IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe MessageStats) -> M s' (Maybe MessageStats))
-> (MsgStore s' -> IO (Maybe MessageStats))
-> MsgStore s'
-> M s' (Maybe MessageStats)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Int64 -> Bool -> MsgStore s' -> IO (Maybe MessageStats)
processMessages Maybe Int64
old_ Bool
expire
    where
      processMessages :: Maybe Int64 -> Bool -> MsgStore s' -> IO (Maybe MessageStats)
      processMessages :: Maybe Int64 -> Bool -> MsgStore s' -> IO (Maybe MessageStats)
processMessages Maybe Int64
old_ Bool
expire = \case
        StoreMemory ms :: STMMsgStore
ms@STMMsgStore {$sel:storeConfig:STMMsgStore :: STMMsgStore -> STMStoreConfig
storeConfig = STMStoreConfig {Maybe String
$sel:storePath:STMStoreConfig :: STMStoreConfig -> Maybe String
storePath :: Maybe String
storePath}} -> case Maybe String
storePath of
          Just String
f -> IO Bool
-> IO (Maybe MessageStats)
-> IO (Maybe MessageStats)
-> IO (Maybe MessageStats)
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (String -> IO Bool
forall (m :: * -> *). MonadIO m => String -> m Bool
doesFileExist String
f) (MessageStats -> Maybe MessageStats
forall a. a -> Maybe a
Just (MessageStats -> Maybe MessageStats)
-> IO MessageStats -> IO (Maybe MessageStats)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool
-> STMMsgStore -> String -> Maybe Int64 -> Bool -> IO MessageStats
forall s.
MsgStoreClass s =>
Bool -> s -> String -> Maybe Int64 -> Bool -> IO MessageStats
importMessages Bool
False STMMsgStore
ms String
f Maybe Int64
old_ Bool
skipWarnings) (Maybe MessageStats -> IO (Maybe MessageStats)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe MessageStats
forall a. Maybe a
Nothing)
          Maybe String
Nothing -> Maybe MessageStats -> IO (Maybe MessageStats)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe MessageStats
forall a. Maybe a
Nothing
        StoreJournal JournalMsgStore qs
ms -> Maybe Int64
-> Bool -> JournalMsgStore qs -> IO (Maybe MessageStats)
forall (s :: QSType).
Maybe Int64 -> Bool -> JournalMsgStore s -> IO (Maybe MessageStats)
processJournalMessages Maybe Int64
old_ Bool
expire JournalMsgStore qs
ms
#if defined(dbServerPostgres)
        StoreDatabase ms -> processDbMessages old_ expire ms
#endif
      processJournalMessages :: forall s. Maybe Int64 -> Bool -> JournalMsgStore s -> IO (Maybe MessageStats)
      processJournalMessages :: forall (s :: QSType).
Maybe Int64 -> Bool -> JournalMsgStore s -> IO (Maybe MessageStats)
processJournalMessages Maybe Int64
old_ Bool
expire JournalMsgStore s
ms
        | Bool
expire = MessageStats -> Maybe MessageStats
forall a. a -> Maybe a
Just (MessageStats -> Maybe MessageStats)
-> IO MessageStats -> IO (Maybe MessageStats)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Maybe Int64
old_ of
            Just Int64
old -> do
              Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logNote Text
"expiring journal store messages..."
              (JournalQueue s -> IO MessageStats) -> IO MessageStats
run ((JournalQueue s -> IO MessageStats) -> IO MessageStats)
-> (JournalQueue s -> IO MessageStats) -> IO MessageStats
forall a b. (a -> b) -> a -> b
$ Int64 -> JournalQueue s -> IO MessageStats
processExpireQueue Int64
old
            Maybe Int64
Nothing -> do
              Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logNote Text
"validating journal store messages..."
              (JournalQueue s -> IO MessageStats) -> IO MessageStats
run JournalQueue s -> IO MessageStats
processValidateQueue
        | Bool
otherwise = Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logWarn Text
"skipping message expiration" IO () -> Maybe MessageStats -> IO (Maybe MessageStats)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe MessageStats
forall a. Maybe a
Nothing
        where
          run :: (JournalQueue s -> IO MessageStats) -> IO MessageStats
run JournalQueue s -> IO MessageStats
a = Bool
-> JournalMsgStore s
-> (StoreQueue (JournalMsgStore s) -> IO MessageStats)
-> IO MessageStats
forall a.
Monoid a =>
Bool
-> JournalMsgStore s
-> (StoreQueue (JournalMsgStore s) -> IO a)
-> IO a
forall s a.
(MsgStoreClass s, Monoid a) =>
Bool -> s -> (StoreQueue s -> IO a) -> IO a
unsafeWithAllMsgQueues Bool
False JournalMsgStore s
ms StoreQueue (JournalMsgStore s) -> IO MessageStats
JournalQueue s -> IO MessageStats
a IO MessageStats
-> (SomeException -> IO MessageStats) -> IO MessageStats
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` \SomeException
_ -> IO MessageStats
forall a. IO a
exitFailure
          processExpireQueue :: Int64 -> JournalQueue s -> IO MessageStats
          processExpireQueue :: Int64 -> JournalQueue s -> IO MessageStats
processExpireQueue Int64
old JournalQueue s
q = StoreQueue (JournalMsgStore s)
-> Text
-> StoreMonad (JournalMsgStore s) MessageStats
-> IO MessageStats
forall s a.
MsgStoreClass s =>
StoreQueue s -> Text -> StoreMonad s a -> IO a
forall a.
StoreQueue (JournalMsgStore s)
-> Text -> StoreMonad (JournalMsgStore s) a -> IO a
unsafeRunStore StoreQueue (JournalMsgStore s)
JournalQueue s
q Text
"processExpireQueue" (StoreMonad (JournalMsgStore s) MessageStats -> IO MessageStats)
-> StoreMonad (JournalMsgStore s) MessageStats -> IO MessageStats
forall a b. (a -> b) -> a -> b
$ do
            JournalMsgQueue s
mq <- JournalMsgStore s
-> StoreQueue (JournalMsgStore s)
-> Bool
-> StoreMonad (JournalMsgStore s) (MsgQueue (JournalMsgStore s))
forall s.
MsgStoreClass s =>
s -> StoreQueue s -> Bool -> StoreMonad s (MsgQueue s)
getMsgQueue JournalMsgStore s
ms StoreQueue (JournalMsgStore s)
JournalQueue s
q Bool
False
            Int
expiredMsgsCount <- Int64
-> StoreQueue (JournalMsgStore s)
-> MsgQueue (JournalMsgStore s)
-> StoreMonad (JournalMsgStore s) Int
forall s.
MsgStoreClass s =>
Int64 -> StoreQueue s -> MsgQueue s -> StoreMonad s Int
deleteExpireMsgs_ Int64
old StoreQueue (JournalMsgStore s)
JournalQueue s
q MsgQueue (JournalMsgStore s)
JournalMsgQueue s
mq
            Int
storedMsgsCount <- MsgQueue (JournalMsgStore s) -> StoreMonad (JournalMsgStore s) Int
forall s. MsgStoreClass s => MsgQueue s -> StoreMonad s Int
getQueueSize_ MsgQueue (JournalMsgStore s)
JournalMsgQueue s
mq
            MessageStats -> StoreIO s MessageStats
forall a. a -> StoreIO s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MessageStats {Int
$sel:storedMsgsCount:MessageStats :: Int
storedMsgsCount :: Int
storedMsgsCount, Int
$sel:expiredMsgsCount:MessageStats :: Int
expiredMsgsCount :: Int
expiredMsgsCount, $sel:storedQueues:MessageStats :: Int
storedQueues = Int
1}
          processValidateQueue :: JournalQueue s -> IO MessageStats
          processValidateQueue :: JournalQueue s -> IO MessageStats
processValidateQueue JournalQueue s
q = StoreQueue (JournalMsgStore s)
-> Text
-> StoreMonad (JournalMsgStore s) MessageStats
-> IO MessageStats
forall s a.
MsgStoreClass s =>
StoreQueue s -> Text -> StoreMonad s a -> IO a
forall a.
StoreQueue (JournalMsgStore s)
-> Text -> StoreMonad (JournalMsgStore s) a -> IO a
unsafeRunStore StoreQueue (JournalMsgStore s)
JournalQueue s
q Text
"processValidateQueue" (StoreMonad (JournalMsgStore s) MessageStats -> IO MessageStats)
-> StoreMonad (JournalMsgStore s) MessageStats -> IO MessageStats
forall a b. (a -> b) -> a -> b
$ do
            Int
storedMsgsCount <- MsgQueue (JournalMsgStore s) -> StoreMonad (JournalMsgStore s) Int
MsgQueue (JournalMsgStore s) -> StoreIO s Int
forall s. MsgStoreClass s => MsgQueue s -> StoreMonad s Int
getQueueSize_ (MsgQueue (JournalMsgStore s) -> StoreIO s Int)
-> StoreIO s (MsgQueue (JournalMsgStore s)) -> StoreIO s Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JournalMsgStore s
-> StoreQueue (JournalMsgStore s)
-> Bool
-> StoreMonad (JournalMsgStore s) (MsgQueue (JournalMsgStore s))
forall s.
MsgStoreClass s =>
s -> StoreQueue s -> Bool -> StoreMonad s (MsgQueue s)
getMsgQueue JournalMsgStore s
ms StoreQueue (JournalMsgStore s)
JournalQueue s
q Bool
False
            MessageStats -> StoreIO s MessageStats
forall a. a -> StoreIO s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MessageStats
newMessageStats {storedMsgsCount, storedQueues = 1}
#if defined(dbServerPostgres)
      processDbMessages old_ expire ms
        | expire = Just <$> case old_ of
            Just old -> do
              -- TODO [messages] expire messages from all queues, not only recent
              logNote "expiring database store messages..."
              now <- systemSeconds <$> getSystemTime
              expireOldMessages False ms now (now - old)
            Nothing -> getDbMessageStats ms
        | otherwise = logWarn "skipping message expiration" $> Nothing
#endif

importMessages :: forall s. MsgStoreClass s => Bool -> s -> FilePath -> Maybe Int64 -> Bool -> IO MessageStats
importMessages :: forall s.
MsgStoreClass s =>
Bool -> s -> String -> Maybe Int64 -> Bool -> IO MessageStats
importMessages Bool
tty s
ms String
f Maybe Int64
old_ Bool
skipWarnings  = do
  Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logNote (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"restoring messages from file " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
f
  (Maybe (RecipientId, StoreQueue s)
_, (Int
storedMsgsCount, Int
expiredMsgsCount, Map RecipientId (StoreQueue s)
overQuota)) <-
    Bool
-> String
-> ((Maybe (RecipientId, StoreQueue s),
     (Int, Int, Map RecipientId (StoreQueue s)))
    -> Bool
    -> ByteString
    -> IO
         (Maybe (RecipientId, StoreQueue s),
          (Int, Int, Map RecipientId (StoreQueue s))))
-> (Maybe (RecipientId, StoreQueue s),
    (Int, Int, Map RecipientId (StoreQueue s)))
-> IO
     (Maybe (RecipientId, StoreQueue s),
      (Int, Int, Map RecipientId (StoreQueue s)))
forall a.
Bool -> String -> (a -> Bool -> ByteString -> IO a) -> a -> IO a
foldLogLines Bool
tty String
f (Maybe (RecipientId, StoreQueue s),
 (Int, Int, Map RecipientId (StoreQueue s)))
-> Bool
-> ByteString
-> IO
     (Maybe (RecipientId, StoreQueue s),
      (Int, Int, Map RecipientId (StoreQueue s)))
restoreMsg (Maybe (RecipientId, StoreQueue s)
forall a. Maybe a
Nothing, (Int
0, Int
0, Map RecipientId (StoreQueue s)
forall k a. Map k a
M.empty))
  String -> String -> IO ()
forall (m :: * -> *). MonadIO m => String -> String -> m ()
renameFile String
f (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
f String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
".bak"
  (StoreQueue s -> IO ()) -> Map RecipientId (StoreQueue s) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ StoreQueue s -> IO ()
forall s. MsgStoreClass s => StoreQueue s -> IO ()
setOverQuota_ Map RecipientId (StoreQueue s)
overQuota
  s -> IO ()
forall s. MsgStoreClass s => s -> IO ()
logQueueStates s
ms
  EntityCounts {Int
queueCount :: EntityCounts -> Int
queueCount :: Int
queueCount} <- IO EntityCounts -> IO EntityCounts
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO EntityCounts -> IO EntityCounts)
-> IO EntityCounts -> IO EntityCounts
forall a b. (a -> b) -> a -> b
$ forall q s. QueueStoreClass q s => s -> IO EntityCounts
getEntityCounts @(StoreQueue s) (QueueStore s -> IO EntityCounts)
-> QueueStore s -> IO EntityCounts
forall a b. (a -> b) -> a -> b
$ s -> QueueStore s
forall s. MsgStoreClass s => s -> QueueStore s
queueStore s
ms
  MessageStats -> IO MessageStats
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MessageStats {Int
$sel:storedMsgsCount:MessageStats :: Int
storedMsgsCount :: Int
storedMsgsCount, Int
$sel:expiredMsgsCount:MessageStats :: Int
expiredMsgsCount :: Int
expiredMsgsCount, $sel:storedQueues:MessageStats :: Int
storedQueues = Int
queueCount}
  where
    restoreMsg :: (Maybe (RecipientId, StoreQueue s), (Int, Int, Map RecipientId (StoreQueue s))) -> Bool -> ByteString -> IO (Maybe (RecipientId, StoreQueue s), (Int, Int, Map RecipientId (StoreQueue s)))
    restoreMsg :: (Maybe (RecipientId, StoreQueue s),
 (Int, Int, Map RecipientId (StoreQueue s)))
-> Bool
-> ByteString
-> IO
     (Maybe (RecipientId, StoreQueue s),
      (Int, Int, Map RecipientId (StoreQueue s)))
restoreMsg (Maybe (RecipientId, StoreQueue s)
q_, counts :: (Int, Int, Map RecipientId (StoreQueue s))
counts@(!Int
stored, !Int
expired, !Map RecipientId (StoreQueue s)
overQuota)) Bool
eof ByteString
s = case ByteString -> Either String MsgLogRecord
forall a. StrEncoding a => ByteString -> Either String a
strDecode ByteString
s of
      Right (MLRv3 RecipientId
rId Message
msg) -> ExceptT
  ErrorType
  IO
  (Maybe (RecipientId, StoreQueue s),
   (Int, Int, Map RecipientId (StoreQueue s)))
-> IO
     (Either
        ErrorType
        (Maybe (RecipientId, StoreQueue s),
         (Int, Int, Map RecipientId (StoreQueue s))))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (RecipientId
-> Message
-> ExceptT
     ErrorType
     IO
     (Maybe (RecipientId, StoreQueue s),
      (Int, Int, Map RecipientId (StoreQueue s)))
addToMsgQueue RecipientId
rId Message
msg) IO
  (Either
     ErrorType
     (Maybe (RecipientId, StoreQueue s),
      (Int, Int, Map RecipientId (StoreQueue s))))
-> (Either
      ErrorType
      (Maybe (RecipientId, StoreQueue s),
       (Int, Int, Map RecipientId (StoreQueue s)))
    -> IO
         (Maybe (RecipientId, StoreQueue s),
          (Int, Int, Map RecipientId (StoreQueue s))))
-> IO
     (Maybe (RecipientId, StoreQueue s),
      (Int, Int, Map RecipientId (StoreQueue s)))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ErrorType
 -> IO
      (Maybe (RecipientId, StoreQueue s),
       (Int, Int, Map RecipientId (StoreQueue s))))
-> ((Maybe (RecipientId, StoreQueue s),
     (Int, Int, Map RecipientId (StoreQueue s)))
    -> IO
         (Maybe (RecipientId, StoreQueue s),
          (Int, Int, Map RecipientId (StoreQueue s))))
-> Either
     ErrorType
     (Maybe (RecipientId, StoreQueue s),
      (Int, Int, Map RecipientId (StoreQueue s)))
-> IO
     (Maybe (RecipientId, StoreQueue s),
      (Int, Int, Map RecipientId (StoreQueue s)))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text
-> IO
     (Maybe (RecipientId, StoreQueue s),
      (Int, Int, Map RecipientId (StoreQueue s)))
exitErr (Text
 -> IO
      (Maybe (RecipientId, StoreQueue s),
       (Int, Int, Map RecipientId (StoreQueue s))))
-> (ErrorType -> Text)
-> ErrorType
-> IO
     (Maybe (RecipientId, StoreQueue s),
      (Int, Int, Map RecipientId (StoreQueue s)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorType -> Text
forall a. Show a => a -> Text
tshow) (Maybe (RecipientId, StoreQueue s),
 (Int, Int, Map RecipientId (StoreQueue s)))
-> IO
     (Maybe (RecipientId, StoreQueue s),
      (Int, Int, Map RecipientId (StoreQueue s)))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      Left String
e
        | Bool
eof -> Text -> IO ()
warnOrExit (String -> Text
parsingErr String
e) IO ()
-> (Maybe (RecipientId, StoreQueue s),
    (Int, Int, Map RecipientId (StoreQueue s)))
-> IO
     (Maybe (RecipientId, StoreQueue s),
      (Int, Int, Map RecipientId (StoreQueue s)))
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (Maybe (RecipientId, StoreQueue s)
q_, (Int, Int, Map RecipientId (StoreQueue s))
counts)
        | Bool
otherwise -> Text
-> IO
     (Maybe (RecipientId, StoreQueue s),
      (Int, Int, Map RecipientId (StoreQueue s)))
exitErr (Text
 -> IO
      (Maybe (RecipientId, StoreQueue s),
       (Int, Int, Map RecipientId (StoreQueue s))))
-> Text
-> IO
     (Maybe (RecipientId, StoreQueue s),
      (Int, Int, Map RecipientId (StoreQueue s)))
forall a b. (a -> b) -> a -> b
$ String -> Text
parsingErr String
e
      where
        exitErr :: Text
-> IO
     (Maybe (RecipientId, StoreQueue s),
      (Int, Int, Map RecipientId (StoreQueue s)))
exitErr Text
e = do
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
tty (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
""
          Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logError (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"error restoring messages: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
e
          IO
  (Maybe (RecipientId, StoreQueue s),
   (Int, Int, Map RecipientId (StoreQueue s)))
-> IO
     (Maybe (RecipientId, StoreQueue s),
      (Int, Int, Map RecipientId (StoreQueue s)))
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO
  (Maybe (RecipientId, StoreQueue s),
   (Int, Int, Map RecipientId (StoreQueue s)))
forall a. IO a
exitFailure
        parsingErr :: String -> Text
        parsingErr :: String -> Text
parsingErr String
e = Text
"parsing error (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
e Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"): " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
safeDecodeUtf8 (Int -> ByteString -> ByteString
B.take Int
100 ByteString
s)
        addToMsgQueue :: RecipientId
-> Message
-> ExceptT
     ErrorType
     IO
     (Maybe (RecipientId, StoreQueue s),
      (Int, Int, Map RecipientId (StoreQueue s)))
addToMsgQueue RecipientId
rId Message
msg = do
          Either ErrorType (StoreQueue s)
qOrErr <- case Maybe (RecipientId, StoreQueue s)
q_ of
            -- to avoid lookup when restoring the next message to the same queue
            Just (RecipientId
rId', StoreQueue s
q') | RecipientId
rId' RecipientId -> RecipientId -> Bool
forall a. Eq a => a -> a -> Bool
== RecipientId
rId -> Either ErrorType (StoreQueue s)
-> ExceptT ErrorType IO (Either ErrorType (StoreQueue s))
forall a. a -> ExceptT ErrorType IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrorType (StoreQueue s)
 -> ExceptT ErrorType IO (Either ErrorType (StoreQueue s)))
-> Either ErrorType (StoreQueue s)
-> ExceptT ErrorType IO (Either ErrorType (StoreQueue s))
forall a b. (a -> b) -> a -> b
$ StoreQueue s -> Either ErrorType (StoreQueue s)
forall a b. b -> Either a b
Right StoreQueue s
q'
            Maybe (RecipientId, StoreQueue s)
_ -> IO (Either ErrorType (StoreQueue s))
-> ExceptT ErrorType IO (Either ErrorType (StoreQueue s))
forall a. IO a -> ExceptT ErrorType IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ErrorType (StoreQueue s))
 -> ExceptT ErrorType IO (Either ErrorType (StoreQueue s)))
-> IO (Either ErrorType (StoreQueue s))
-> ExceptT ErrorType IO (Either ErrorType (StoreQueue s))
forall a b. (a -> b) -> a -> b
$ s
-> SParty 'Recipient
-> RecipientId
-> IO (Either ErrorType (StoreQueue s))
forall s (p :: Party).
(MsgStoreClass s, QueueParty p) =>
s
-> SParty p -> RecipientId -> IO (Either ErrorType (StoreQueue s))
getQueue s
ms SParty 'Recipient
SRecipient RecipientId
rId
          case Either ErrorType (StoreQueue s)
qOrErr of
            Right StoreQueue s
q -> StoreQueue s
-> RecipientId
-> Message
-> ExceptT
     ErrorType
     IO
     (Maybe (RecipientId, StoreQueue s),
      (Int, Int, Map RecipientId (StoreQueue s)))
addToQueue_ StoreQueue s
q RecipientId
rId Message
msg
            Left ErrorType
AUTH -> IO
  (Maybe (RecipientId, StoreQueue s),
   (Int, Int, Map RecipientId (StoreQueue s)))
-> ExceptT
     ErrorType
     IO
     (Maybe (RecipientId, StoreQueue s),
      (Int, Int, Map RecipientId (StoreQueue s)))
forall a. IO a -> ExceptT ErrorType IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   (Maybe (RecipientId, StoreQueue s),
    (Int, Int, Map RecipientId (StoreQueue s)))
 -> ExceptT
      ErrorType
      IO
      (Maybe (RecipientId, StoreQueue s),
       (Int, Int, Map RecipientId (StoreQueue s))))
-> IO
     (Maybe (RecipientId, StoreQueue s),
      (Int, Int, Map RecipientId (StoreQueue s)))
-> ExceptT
     ErrorType
     IO
     (Maybe (RecipientId, StoreQueue s),
      (Int, Int, Map RecipientId (StoreQueue s)))
forall a b. (a -> b) -> a -> b
$ do
              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
tty (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
""
              Text -> IO ()
warnOrExit (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"queue " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
safeDecodeUtf8 (ByteString -> ByteString
encode (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ RecipientId -> ByteString
unEntityId RecipientId
rId) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" does not exist"
              (Maybe (RecipientId, StoreQueue s),
 (Int, Int, Map RecipientId (StoreQueue s)))
-> IO
     (Maybe (RecipientId, StoreQueue s),
      (Int, Int, Map RecipientId (StoreQueue s)))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (RecipientId, StoreQueue s)
forall a. Maybe a
Nothing, (Int, Int, Map RecipientId (StoreQueue s))
counts)
            Left ErrorType
e -> ErrorType
-> ExceptT
     ErrorType
     IO
     (Maybe (RecipientId, StoreQueue s),
      (Int, Int, Map RecipientId (StoreQueue s)))
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE ErrorType
e
        addToQueue_ :: StoreQueue s
-> RecipientId
-> Message
-> ExceptT
     ErrorType
     IO
     (Maybe (RecipientId, StoreQueue s),
      (Int, Int, Map RecipientId (StoreQueue s)))
addToQueue_ StoreQueue s
q RecipientId
rId Message
msg =
          ((RecipientId, StoreQueue s) -> Maybe (RecipientId, StoreQueue s)
forall a. a -> Maybe a
Just (RecipientId
rId, StoreQueue s
q),) ((Int, Int, Map RecipientId (StoreQueue s))
 -> (Maybe (RecipientId, StoreQueue s),
     (Int, Int, Map RecipientId (StoreQueue s))))
-> ExceptT ErrorType IO (Int, Int, Map RecipientId (StoreQueue s))
-> ExceptT
     ErrorType
     IO
     (Maybe (RecipientId, StoreQueue s),
      (Int, Int, Map RecipientId (StoreQueue s)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Message
msg of
            Message {SystemTime
$sel:msgTs:Message :: Message -> SystemTime
msgTs :: SystemTime
msgTs}
              | Bool -> (Int64 -> Bool) -> Maybe Int64 -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (SystemTime -> Int64
systemSeconds SystemTime
msgTs Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
>=) Maybe Int64
old_ -> do
                  s
-> StoreQueue s
-> Bool
-> Message
-> ExceptT ErrorType IO (Maybe (Message, Bool))
forall s.
MsgStoreClass s =>
s
-> StoreQueue s
-> Bool
-> Message
-> ExceptT ErrorType IO (Maybe (Message, Bool))
writeMsg s
ms StoreQueue s
q Bool
False Message
msg ExceptT ErrorType IO (Maybe (Message, Bool))
-> (Maybe (Message, Bool)
    -> ExceptT ErrorType IO (Int, Int, Map RecipientId (StoreQueue s)))
-> ExceptT ErrorType IO (Int, Int, Map RecipientId (StoreQueue s))
forall a b.
ExceptT ErrorType IO a
-> (a -> ExceptT ErrorType IO b) -> ExceptT ErrorType IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                    Just (Message, Bool)
_ -> (Int, Int, Map RecipientId (StoreQueue s))
-> ExceptT ErrorType IO (Int, Int, Map RecipientId (StoreQueue s))
forall a. a -> ExceptT ErrorType IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
stored Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
expired, Map RecipientId (StoreQueue s)
overQuota)
                    Maybe (Message, Bool)
Nothing -> IO (Int, Int, Map RecipientId (StoreQueue s))
-> ExceptT ErrorType IO (Int, Int, Map RecipientId (StoreQueue s))
forall a. IO a -> ExceptT ErrorType IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Int, Int, Map RecipientId (StoreQueue s))
 -> ExceptT ErrorType IO (Int, Int, Map RecipientId (StoreQueue s)))
-> IO (Int, Int, Map RecipientId (StoreQueue s))
-> ExceptT ErrorType IO (Int, Int, Map RecipientId (StoreQueue s))
forall a b. (a -> b) -> a -> b
$ do
                      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
tty (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
""
                      Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logError (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decodeLatin1 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString
"message queue " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> RecipientId -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode RecipientId
rId ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" is full, message not restored: " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode (Message -> ByteString
messageId Message
msg)
                      (Int, Int, Map RecipientId (StoreQueue s))
-> IO (Int, Int, Map RecipientId (StoreQueue s))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int, Int, Map RecipientId (StoreQueue s))
counts
              | Bool
otherwise -> (Int, Int, Map RecipientId (StoreQueue s))
-> ExceptT ErrorType IO (Int, Int, Map RecipientId (StoreQueue s))
forall a. a -> ExceptT ErrorType IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
stored, Int
expired Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Map RecipientId (StoreQueue s)
overQuota)
            MessageQuota {} ->
              -- queue was over quota at some point,
              -- it will be set as over quota once fully imported
              ExceptT ErrorType IO ()
mergeQuotaMsgs ExceptT ErrorType IO ()
-> ExceptT ErrorType IO (Int, Int, Map RecipientId (StoreQueue s))
-> ExceptT ErrorType IO (Int, Int, Map RecipientId (StoreQueue s))
forall a b.
ExceptT ErrorType IO a
-> ExceptT ErrorType IO b -> ExceptT ErrorType IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> s
-> StoreQueue s
-> Bool
-> Message
-> ExceptT ErrorType IO (Maybe (Message, Bool))
forall s.
MsgStoreClass s =>
s
-> StoreQueue s
-> Bool
-> Message
-> ExceptT ErrorType IO (Maybe (Message, Bool))
writeMsg s
ms StoreQueue s
q Bool
False Message
msg ExceptT ErrorType IO (Maybe (Message, Bool))
-> (Int, Int, Map RecipientId (StoreQueue s))
-> ExceptT ErrorType IO (Int, Int, Map RecipientId (StoreQueue s))
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (Int
stored, Int
expired, RecipientId
-> StoreQueue s
-> Map RecipientId (StoreQueue s)
-> Map RecipientId (StoreQueue s)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert RecipientId
rId StoreQueue s
q Map RecipientId (StoreQueue s)
overQuota)
              where
                -- if the first message in queue head is "quota", remove it.
                mergeQuotaMsgs :: ExceptT ErrorType IO ()
mergeQuotaMsgs =
                  s
-> StoreQueue s
-> Text
-> (Maybe (MsgQueue s, Message) -> StoreMonad s ())
-> ExceptT ErrorType IO ()
forall s a.
MsgStoreClass s =>
s
-> StoreQueue s
-> Text
-> (Maybe (MsgQueue s, Message) -> StoreMonad s a)
-> ExceptT ErrorType IO a
withPeekMsgQueue s
ms StoreQueue s
q Text
"mergeQuotaMsgs" ((Maybe (MsgQueue s, Message) -> StoreMonad s ())
 -> ExceptT ErrorType IO ())
-> (Maybe (MsgQueue s, Message) -> StoreMonad s ())
-> ExceptT ErrorType IO ()
forall a b. (a -> b) -> a -> b
$ StoreMonad s ()
-> ((MsgQueue s, Message) -> StoreMonad s ())
-> Maybe (MsgQueue s, Message)
-> StoreMonad s ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> StoreMonad s ()
forall a. a -> StoreMonad s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (((MsgQueue s, Message) -> StoreMonad s ())
 -> Maybe (MsgQueue s, Message) -> StoreMonad s ())
-> ((MsgQueue s, Message) -> StoreMonad s ())
-> Maybe (MsgQueue s, Message)
-> StoreMonad s ()
forall a b. (a -> b) -> a -> b
$ \case
                    (MsgQueue s
mq, MessageQuota {}) -> StoreQueue s -> MsgQueue s -> Bool -> StoreMonad s ()
forall s.
MsgStoreClass s =>
StoreQueue s -> MsgQueue s -> Bool -> StoreMonad s ()
tryDeleteMsg_ StoreQueue s
q MsgQueue s
mq Bool
False
                    (MsgQueue s, Message)
_ -> () -> StoreMonad s ()
forall a. a -> StoreMonad s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        warnOrExit :: Text -> IO ()
warnOrExit Text
e
          | Bool
skipWarnings = Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logWarn Text
e'
          | Bool
otherwise = do
              Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logWarn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
e' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", start with --skip-warnings option to ignore this error"
              IO ()
forall a. IO a
exitFailure
          where
            e' :: Text
e' = Text
"warning restoring messages: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
e

printMessageStats :: T.Text -> MessageStats -> IO ()
printMessageStats :: Text -> MessageStats -> IO ()
printMessageStats Text
name MessageStats {Int
$sel:storedMsgsCount:MessageStats :: MessageStats -> Int
storedMsgsCount :: Int
storedMsgsCount, Int
$sel:expiredMsgsCount:MessageStats :: MessageStats -> Int
expiredMsgsCount :: Int
expiredMsgsCount, Int
$sel:storedQueues:MessageStats :: MessageStats -> Int
storedQueues :: Int
storedQueues} =
  Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logNote (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" stored: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
storedMsgsCount Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", expired: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
expiredMsgsCount Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", queues: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
storedQueues

saveServerNtfs :: M s ()
saveServerNtfs :: forall s. M s ()
saveServerNtfs = (Env s -> Maybe String) -> ReaderT (Env s) IO (Maybe String)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerConfig s -> Maybe String
forall s. ServerConfig s -> Maybe String
storeNtfsFile (ServerConfig s -> Maybe String)
-> (Env s -> ServerConfig s) -> Env s -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env s -> ServerConfig s
forall s. Env s -> ServerConfig s
config) ReaderT (Env s) IO (Maybe String)
-> (Maybe String -> ReaderT (Env s) IO ()) -> ReaderT (Env s) IO ()
forall a b.
ReaderT (Env s) IO a
-> (a -> ReaderT (Env s) IO b) -> ReaderT (Env s) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> ReaderT (Env s) IO ())
-> Maybe String -> ReaderT (Env s) IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> ReaderT (Env s) IO ()
forall {m :: * -> *} {s}.
(MonadIO m, MonadReader (Env s) m) =>
String -> m ()
saveNtfs
  where
    saveNtfs :: String -> m ()
saveNtfs String
f = do
      Text -> m ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logNote (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"saving notifications to file " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
f
      NtfStore TMap RecipientId (TVar [MsgNtf])
ns <- (Env s -> NtfStore) -> m NtfStore
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> NtfStore
forall s. Env s -> NtfStore
ntfStore
      IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ())
-> ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IOMode -> (Handle -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> IOMode -> (Handle -> m a) -> m a
withFile String
f IOMode
WriteMode ((Handle -> IO ()) -> m ()) -> (Handle -> IO ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Handle
h ->
        TMap RecipientId (TVar [MsgNtf])
-> IO (Map RecipientId (TVar [MsgNtf]))
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TMap RecipientId (TVar [MsgNtf])
ns IO (Map RecipientId (TVar [MsgNtf]))
-> (Map RecipientId (TVar [MsgNtf]) -> 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
>>= ((RecipientId, TVar [MsgNtf]) -> IO ())
-> [(RecipientId, TVar [MsgNtf])] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> (RecipientId, TVar [MsgNtf]) -> IO ()
saveQueueNtfs Handle
h) ([(RecipientId, TVar [MsgNtf])] -> IO ())
-> (Map RecipientId (TVar [MsgNtf])
    -> [(RecipientId, TVar [MsgNtf])])
-> Map RecipientId (TVar [MsgNtf])
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map RecipientId (TVar [MsgNtf]) -> [(RecipientId, TVar [MsgNtf])]
forall k a. Map k a -> [(k, a)]
M.assocs
      Text -> m ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logNote Text
"notifications saved"
      where
        -- reverse on save, to save notifications in order, will become reversed again when restoring.
        saveQueueNtfs :: Handle -> (RecipientId, TVar [MsgNtf]) -> IO ()
saveQueueNtfs Handle
h (RecipientId
nId, TVar [MsgNtf]
v) = Handle -> Builder -> IO ()
BLD.hPutBuilder Handle
h (Builder -> IO ()) -> ([MsgNtf] -> Builder) -> [MsgNtf] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecipientId -> [MsgNtf] -> Builder
encodeNtfs RecipientId
nId ([MsgNtf] -> Builder)
-> ([MsgNtf] -> [MsgNtf]) -> [MsgNtf] -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [MsgNtf] -> [MsgNtf]
forall a. [a] -> [a]
reverse ([MsgNtf] -> IO ()) -> IO [MsgNtf] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TVar [MsgNtf] -> IO [MsgNtf]
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar [MsgNtf]
v
        encodeNtfs :: RecipientId -> [MsgNtf] -> Builder
encodeNtfs RecipientId
nId = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder)
-> ([MsgNtf] -> [Builder]) -> [MsgNtf] -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MsgNtf -> Builder) -> [MsgNtf] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (\MsgNtf
ntf -> ByteString -> Builder
BLD.byteString (NtfLogRecord -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode (NtfLogRecord -> ByteString) -> NtfLogRecord -> ByteString
forall a b. (a -> b) -> a -> b
$ RecipientId -> MsgNtf -> NtfLogRecord
NLRv1 RecipientId
nId MsgNtf
ntf) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
BLD.char8 Char
'\n')

restoreServerNtfs :: M s MessageStats
restoreServerNtfs :: forall s. M s MessageStats
restoreServerNtfs =
  (Env s -> Maybe String) -> ReaderT (Env s) IO (Maybe String)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerConfig s -> Maybe String
forall s. ServerConfig s -> Maybe String
storeNtfsFile (ServerConfig s -> Maybe String)
-> (Env s -> ServerConfig s) -> Env s -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env s -> ServerConfig s
forall s. Env s -> ServerConfig s
config) ReaderT (Env s) IO (Maybe String)
-> (Maybe String -> ReaderT (Env s) IO MessageStats)
-> ReaderT (Env s) IO MessageStats
forall a b.
ReaderT (Env s) IO a
-> (a -> ReaderT (Env s) IO b) -> ReaderT (Env s) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just String
f -> ReaderT (Env s) IO Bool
-> ReaderT (Env s) IO MessageStats
-> ReaderT (Env s) IO MessageStats
-> ReaderT (Env s) IO MessageStats
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (String -> ReaderT (Env s) IO Bool
forall (m :: * -> *). MonadIO m => String -> m Bool
doesFileExist String
f) (String -> ReaderT (Env s) IO MessageStats
forall {m :: * -> *} {s}.
(MonadIO m, MonadReader (Env s) m) =>
String -> m MessageStats
restoreNtfs String
f) (MessageStats -> ReaderT (Env s) IO MessageStats
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MessageStats
newMessageStats)
    Maybe String
Nothing -> MessageStats -> ReaderT (Env s) IO MessageStats
forall a. a -> ReaderT (Env s) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MessageStats
newMessageStats
  where
    restoreNtfs :: String -> m MessageStats
restoreNtfs String
f = do
      Text -> m ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logNote (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"restoring notifications from file " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
f
      NtfStore
ns <- (Env s -> NtfStore) -> m NtfStore
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> NtfStore
forall s. Env s -> NtfStore
ntfStore
      Int64
old <- (Env s -> ExpirationConfig) -> m ExpirationConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerConfig s -> ExpirationConfig
forall s. ServerConfig s -> ExpirationConfig
notificationExpiration (ServerConfig s -> ExpirationConfig)
-> (Env s -> ServerConfig s) -> Env s -> ExpirationConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env s -> ServerConfig s
forall s. Env s -> ServerConfig s
config) m ExpirationConfig -> (ExpirationConfig -> m Int64) -> m Int64
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO Int64 -> m Int64
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int64 -> m Int64)
-> (ExpirationConfig -> IO Int64) -> ExpirationConfig -> m Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExpirationConfig -> IO Int64
expireBeforeEpoch
      IO MessageStats -> m MessageStats
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO MessageStats -> m MessageStats)
-> IO MessageStats -> m MessageStats
forall a b. (a -> b) -> a -> b
$
        String -> IO ByteString
LB.readFile String
f IO ByteString
-> (ByteString -> IO (Either String (Int, Int, Int)))
-> IO (Either String (Int, Int, Int))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ExceptT String IO (Int, Int, Int)
-> IO (Either String (Int, Int, Int))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT String IO (Int, Int, Int)
 -> IO (Either String (Int, Int, Int)))
-> (ByteString -> ExceptT String IO (Int, Int, Int))
-> ByteString
-> IO (Either String (Int, Int, Int))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Int, Int)
 -> ByteString -> ExceptT String IO (Int, Int, Int))
-> (Int, Int, Int)
-> [ByteString]
-> ExceptT String IO (Int, Int, Int)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (NtfStore
-> Int64
-> (Int, Int, Int)
-> ByteString
-> ExceptT String IO (Int, Int, Int)
restoreNtf NtfStore
ns Int64
old) (Int
0, Int
0, Int
0) ([ByteString] -> ExceptT String IO (Int, Int, Int))
-> (ByteString -> [ByteString])
-> ByteString
-> ExceptT String IO (Int, Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
LB.lines IO (Either String (Int, Int, Int))
-> (Either String (Int, Int, Int) -> IO MessageStats)
-> IO MessageStats
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Left String
e -> do
            Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logError (Text -> IO ()) -> (String -> Text) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"error restoring notifications: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
e
            IO MessageStats -> IO MessageStats
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO MessageStats
forall a. IO a
exitFailure
          Right (Int
lineCount, Int
storedMsgsCount, Int
expiredMsgsCount) -> do
            String -> String -> IO ()
forall (m :: * -> *). MonadIO m => String -> String -> m ()
renameFile String
f (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
f String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
".bak"
            let NtfStore TMap RecipientId (TVar [MsgNtf])
ns' = NtfStore
ns
            Int
storedQueues <- Map RecipientId (TVar [MsgNtf]) -> Int
forall k a. Map k a -> Int
M.size (Map RecipientId (TVar [MsgNtf]) -> Int)
-> IO (Map RecipientId (TVar [MsgNtf])) -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TMap RecipientId (TVar [MsgNtf])
-> IO (Map RecipientId (TVar [MsgNtf]))
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TMap RecipientId (TVar [MsgNtf])
ns'
            Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logNote (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"notifications restored, " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
lineCount Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" lines processed"
            MessageStats -> IO MessageStats
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MessageStats {Int
$sel:storedMsgsCount:MessageStats :: Int
storedMsgsCount :: Int
storedMsgsCount, Int
$sel:expiredMsgsCount:MessageStats :: Int
expiredMsgsCount :: Int
expiredMsgsCount, Int
$sel:storedQueues:MessageStats :: Int
storedQueues :: Int
storedQueues}
      where
        restoreNtf :: NtfStore -> Int64 -> (Int, Int, Int) -> LB.ByteString -> ExceptT String IO (Int, Int, Int)
        restoreNtf :: NtfStore
-> Int64
-> (Int, Int, Int)
-> ByteString
-> ExceptT String IO (Int, Int, Int)
restoreNtf NtfStore
ns Int64
old (!Int
lineCount, !Int
stored, !Int
expired) ByteString
s' = do
          NLRv1 RecipientId
nId MsgNtf
ntf <- Either String NtfLogRecord -> ExceptT String IO NtfLogRecord
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either String NtfLogRecord -> ExceptT String IO NtfLogRecord)
-> (Either String NtfLogRecord -> Either String NtfLogRecord)
-> Either String NtfLogRecord
-> ExceptT String IO NtfLogRecord
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String)
-> Either String NtfLogRecord -> Either String NtfLogRecord
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (String -> String -> String
forall e. Show e => String -> e -> String
ntfErr String
"parsing") (Either String NtfLogRecord -> ExceptT String IO NtfLogRecord)
-> Either String NtfLogRecord -> ExceptT String IO NtfLogRecord
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String NtfLogRecord
forall a. StrEncoding a => ByteString -> Either String a
strDecode ByteString
s
          IO (Int, Int, Int) -> ExceptT String IO (Int, Int, Int)
forall a. IO a -> ExceptT String IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Int, Int, Int) -> ExceptT String IO (Int, Int, Int))
-> IO (Int, Int, Int) -> ExceptT String IO (Int, Int, Int)
forall a b. (a -> b) -> a -> b
$ RecipientId -> MsgNtf -> IO (Int, Int, Int)
addToNtfs RecipientId
nId MsgNtf
ntf
          where
            s :: ByteString
s = ByteString -> ByteString
LB.toStrict ByteString
s'
            addToNtfs :: RecipientId -> MsgNtf -> IO (Int, Int, Int)
addToNtfs RecipientId
nId ntf :: MsgNtf
ntf@MsgNtf {SystemTime
ntfTs :: MsgNtf -> SystemTime
ntfTs :: SystemTime
ntfTs}
              | SystemTime -> Int64
systemSeconds SystemTime
ntfTs Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int64
old = (Int, Int, Int) -> IO (Int, Int, Int)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
lineCount Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
stored, Int
expired Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
              | Bool
otherwise = NtfStore -> RecipientId -> MsgNtf -> IO ()
storeNtf NtfStore
ns RecipientId
nId MsgNtf
ntf IO () -> (Int, Int, Int) -> IO (Int, Int, Int)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (Int
lineCount Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
stored Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
expired)
            ntfErr :: Show e => String -> e -> String
            ntfErr :: forall e. Show e => String -> e -> String
ntfErr String
op e
e = String
op String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" error (" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> e -> String
forall a. Show a => a -> String
show e
e String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"): " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
B.unpack (Int -> ByteString -> ByteString
B.take Int
100 ByteString
s)

saveServerStats :: M s ()
saveServerStats :: forall s. M s ()
saveServerStats =
  (Env s -> Maybe String) -> ReaderT (Env s) IO (Maybe String)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerConfig s -> Maybe String
forall s. ServerConfig s -> Maybe String
serverStatsBackupFile (ServerConfig s -> Maybe String)
-> (Env s -> ServerConfig s) -> Env s -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env s -> ServerConfig s
forall s. Env s -> ServerConfig s
config)
    ReaderT (Env s) IO (Maybe String)
-> (Maybe String -> ReaderT (Env s) IO ()) -> ReaderT (Env s) IO ()
forall a b.
ReaderT (Env s) IO a
-> (a -> ReaderT (Env s) IO b) -> ReaderT (Env s) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> ReaderT (Env s) IO ())
-> Maybe String -> ReaderT (Env s) IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\String
f -> (Env s -> ServerStats) -> ReaderT (Env s) IO ServerStats
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> ServerStats
forall s. Env s -> ServerStats
serverStats ReaderT (Env s) IO ServerStats
-> (ServerStats -> ReaderT (Env s) IO ServerStatsData)
-> ReaderT (Env s) IO ServerStatsData
forall a b.
ReaderT (Env s) IO a
-> (a -> ReaderT (Env s) IO b) -> ReaderT (Env s) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO ServerStatsData -> ReaderT (Env s) IO ServerStatsData
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ServerStatsData -> ReaderT (Env s) IO ServerStatsData)
-> (ServerStats -> IO ServerStatsData)
-> ServerStats
-> ReaderT (Env s) IO ServerStatsData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerStats -> IO ServerStatsData
getServerStatsData ReaderT (Env s) IO ServerStatsData
-> (ServerStatsData -> ReaderT (Env s) IO ())
-> ReaderT (Env s) IO ()
forall a b.
ReaderT (Env s) IO a
-> (a -> ReaderT (Env s) IO b) -> ReaderT (Env s) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> ReaderT (Env s) IO ()
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT (Env s) IO ())
-> (ServerStatsData -> IO ())
-> ServerStatsData
-> ReaderT (Env s) IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ServerStatsData -> IO ()
forall {a}. StrEncoding a => String -> a -> IO ()
saveStats String
f)
  where
    saveStats :: String -> a -> IO ()
saveStats String
f a
stats = do
      Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logNote (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"saving server stats to file " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
f
      String -> ByteString -> IO ()
B.writeFile String
f (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode a
stats
      Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logNote Text
"server stats saved"

restoreServerStats :: forall s. MsgStoreClass s => Maybe MessageStats -> MessageStats -> M s ()
restoreServerStats :: forall s.
MsgStoreClass s =>
Maybe MessageStats -> MessageStats -> M s ()
restoreServerStats Maybe MessageStats
msgStats_ MessageStats
ntfStats = (Env s -> Maybe String) -> ReaderT (Env s) IO (Maybe String)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerConfig s -> Maybe String
forall s. ServerConfig s -> Maybe String
serverStatsBackupFile (ServerConfig s -> Maybe String)
-> (Env s -> ServerConfig s) -> Env s -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env s -> ServerConfig s
forall s. Env s -> ServerConfig s
config) ReaderT (Env s) IO (Maybe String)
-> (Maybe String -> ReaderT (Env s) IO ()) -> ReaderT (Env s) IO ()
forall a b.
ReaderT (Env s) IO a
-> (a -> ReaderT (Env s) IO b) -> ReaderT (Env s) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> ReaderT (Env s) IO ())
-> Maybe String -> ReaderT (Env s) IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> ReaderT (Env s) IO ()
restoreStats
  where
    restoreStats :: String -> ReaderT (Env s) IO ()
restoreStats String
f = ReaderT (Env s) IO Bool
-> ReaderT (Env s) IO () -> ReaderT (Env s) IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (String -> ReaderT (Env s) IO Bool
forall (m :: * -> *). MonadIO m => String -> m Bool
doesFileExist String
f) (ReaderT (Env s) IO () -> ReaderT (Env s) IO ())
-> ReaderT (Env s) IO () -> ReaderT (Env s) IO ()
forall a b. (a -> b) -> a -> b
$ do
      Text -> ReaderT (Env s) IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logNote (Text -> ReaderT (Env s) IO ()) -> Text -> ReaderT (Env s) IO ()
forall a b. (a -> b) -> a -> b
$ Text
"restoring server stats from file " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
f
      IO (Either String ServerStatsData)
-> ReaderT (Env s) IO (Either String ServerStatsData)
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ByteString -> Either String ServerStatsData
forall a. StrEncoding a => ByteString -> Either String a
strDecode (ByteString -> Either String ServerStatsData)
-> IO ByteString -> IO (Either String ServerStatsData)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
B.readFile String
f) ReaderT (Env s) IO (Either String ServerStatsData)
-> (Either String ServerStatsData -> ReaderT (Env s) IO ())
-> ReaderT (Env s) IO ()
forall a b.
ReaderT (Env s) IO a
-> (a -> ReaderT (Env s) IO b) -> ReaderT (Env s) IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Right d :: ServerStatsData
d@ServerStatsData {_qCount :: ServerStatsData -> Int
_qCount = Int
statsQCount, _msgCount :: ServerStatsData -> Int
_msgCount = Int
statsMsgCount, _ntfCount :: ServerStatsData -> Int
_ntfCount = Int
statsNtfCount} -> do
          ServerStats
s <- (Env s -> ServerStats) -> ReaderT (Env s) IO ServerStats
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> ServerStats
forall s. Env s -> ServerStats
serverStats
          s
st <- (Env s -> s) -> ReaderT (Env s) IO s
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env s -> s
forall s. Env s -> s
msgStore
          EntityCounts {queueCount :: EntityCounts -> Int
queueCount = Int
_qCount} <- IO EntityCounts -> ReaderT (Env s) IO EntityCounts
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO EntityCounts -> ReaderT (Env s) IO EntityCounts)
-> IO EntityCounts -> ReaderT (Env s) IO EntityCounts
forall a b. (a -> b) -> a -> b
$ forall q s. QueueStoreClass q s => s -> IO EntityCounts
getEntityCounts @(StoreQueue s) (QueueStore s -> IO EntityCounts)
-> QueueStore s -> IO EntityCounts
forall a b. (a -> b) -> a -> b
$ s -> QueueStore s
forall s. MsgStoreClass s => s -> QueueStore s
queueStore s
st
          let _msgCount :: Int
_msgCount = Int -> (MessageStats -> Int) -> Maybe MessageStats -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
statsMsgCount MessageStats -> Int
storedMsgsCount Maybe MessageStats
msgStats_
              _ntfCount :: Int
_ntfCount = MessageStats -> Int
storedMsgsCount MessageStats
ntfStats
              _msgExpired' :: Int
_msgExpired' = ServerStatsData -> Int
_msgExpired ServerStatsData
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> (MessageStats -> Int) -> Maybe MessageStats -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 MessageStats -> Int
expiredMsgsCount Maybe MessageStats
msgStats_
              _msgNtfExpired' :: Int
_msgNtfExpired' = ServerStatsData -> Int
_msgNtfExpired ServerStatsData
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ MessageStats -> Int
expiredMsgsCount MessageStats
ntfStats
          IO () -> ReaderT (Env s) IO ()
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT (Env s) IO ()) -> IO () -> ReaderT (Env s) IO ()
forall a b. (a -> b) -> a -> b
$ ServerStats -> ServerStatsData -> IO ()
setServerStats ServerStats
s ServerStatsData
d {_qCount, _msgCount, _ntfCount, _msgExpired = _msgExpired', _msgNtfExpired = _msgNtfExpired'}
          String -> String -> ReaderT (Env s) IO ()
forall (m :: * -> *). MonadIO m => String -> String -> m ()
renameFile String
f (String -> ReaderT (Env s) IO ())
-> String -> ReaderT (Env s) IO ()
forall a b. (a -> b) -> a -> b
$ String
f String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
".bak"
          Text -> ReaderT (Env s) IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logNote Text
"server stats restored"
          Text -> Int -> Int -> ReaderT (Env s) IO ()
forall {f :: * -> *} {a}.
(Eq a, MonadIO f, Show a) =>
Text -> a -> a -> f ()
compareCounts Text
"Queue" Int
statsQCount Int
_qCount
          Text -> Int -> Int -> ReaderT (Env s) IO ()
forall {f :: * -> *} {a}.
(Eq a, MonadIO f, Show a) =>
Text -> a -> a -> f ()
compareCounts Text
"Message" Int
statsMsgCount Int
_msgCount
          Text -> Int -> Int -> ReaderT (Env s) IO ()
forall {f :: * -> *} {a}.
(Eq a, MonadIO f, Show a) =>
Text -> a -> a -> f ()
compareCounts Text
"Notification" Int
statsNtfCount Int
_ntfCount
        Left String
e -> do
          Text -> ReaderT (Env s) IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logNote (Text -> ReaderT (Env s) IO ()) -> Text -> ReaderT (Env s) IO ()
forall a b. (a -> b) -> a -> b
$ Text
"error restoring server stats: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
e
          IO () -> ReaderT (Env s) IO ()
forall a. IO a -> ReaderT (Env s) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
forall a. IO a
exitFailure
    compareCounts :: Text -> a -> a -> f ()
compareCounts Text
name a
statsCnt a
storeCnt =
      Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (a
statsCnt a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
storeCnt) (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$ Text -> f ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logWarn (Text -> f ()) -> Text -> f ()
forall a b. (a -> b) -> a -> b
$ Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" count differs: stats: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. Show a => a -> Text
tshow a
statsCnt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", store: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. Show a => a -> Text
tshow a
storeCnt