{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- |
-- Module      : Simplex.Messaging.Agent
-- Copyright   : (c) simplex.chat
-- License     : AGPL-3
--
-- Maintainer  : chat@simplex.chat
-- Stability   : experimental
-- Portability : non-portable
--
-- This module defines SMP protocol agent with SQLite persistence.
--
-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md
module Simplex.Messaging.Agent
  ( runSMPAgent,
    runSMPAgentBlocking,
    getSMPAgentClient,
    runSMPAgentClient,
  )
where

import Control.Concurrent.STM (stateTVar)
import Control.Logger.Simple (logInfo, showText)
import Control.Monad.Except
import Control.Monad.IO.Unlift (MonadUnliftIO)
import Control.Monad.Reader
import Crypto.Random (MonadRandom)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as L
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8)
import Data.Time.Clock
import Database.SQLite.Simple (SQLError)
import Simplex.Messaging.Agent.Client
import Simplex.Messaging.Agent.Env.SQLite
import Simplex.Messaging.Agent.Protocol
import Simplex.Messaging.Agent.Store
import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore, connectSQLiteStore)
import Simplex.Messaging.Client (SMPServerTransmission)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Protocol (CorrId (..), MsgBody, SenderPublicKey)
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Transport (ATransport (..), TProxy, Transport (..), runTransportServer)
import Simplex.Messaging.Util (bshow)
import System.Random (randomR)
import UnliftIO.Async (race_)
import qualified UnliftIO.Exception as E
import UnliftIO.STM

-- | Runs an SMP agent as a TCP service using passed configuration.
--
-- See a full agent executable here: https://github.com/simplex-chat/simplexmq/blob/master/apps/smp-agent/Main.hs
runSMPAgent :: (MonadRandom m, MonadUnliftIO m) => ATransport -> AgentConfig -> m ()
runSMPAgent :: ATransport -> AgentConfig -> m ()
runSMPAgent ATransport
t AgentConfig
cfg = do
  TMVar Bool
started <- m (TMVar Bool)
forall (m :: * -> *) a. MonadIO m => m (TMVar a)
newEmptyTMVarIO
  ATransport -> TMVar Bool -> AgentConfig -> m ()
forall (m :: * -> *).
(MonadRandom m, MonadUnliftIO m) =>
ATransport -> TMVar Bool -> AgentConfig -> m ()
runSMPAgentBlocking ATransport
t TMVar Bool
started AgentConfig
cfg

-- | Runs an SMP agent as a TCP service 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).
runSMPAgentBlocking :: (MonadRandom m, MonadUnliftIO m) => ATransport -> TMVar Bool -> AgentConfig -> m ()
runSMPAgentBlocking :: ATransport -> TMVar Bool -> AgentConfig -> m ()
runSMPAgentBlocking (ATransport TProxy c
t) TMVar Bool
started cfg :: AgentConfig
cfg@AgentConfig {ServiceName
$sel:tcpPort:AgentConfig :: AgentConfig -> ServiceName
tcpPort :: ServiceName
tcpPort} = ReaderT Env m () -> Env -> m ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (TProxy c -> ReaderT Env m ()
forall c (m' :: * -> *).
(Transport c, MonadUnliftIO m', MonadReader Env m') =>
TProxy c -> m' ()
smpAgent TProxy c
t) (Env -> m ()) -> m Env -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< AgentConfig -> m Env
forall (m :: * -> *).
(MonadUnliftIO m, MonadRandom m) =>
AgentConfig -> m Env
newSMPAgentEnv AgentConfig
cfg
  where
    smpAgent :: forall c m'. (Transport c, MonadUnliftIO m', MonadReader Env m') => TProxy c -> m' ()
    smpAgent :: TProxy c -> m' ()
smpAgent TProxy c
_ = TMVar Bool -> ServiceName -> (c -> m' ()) -> m' ()
forall c (m :: * -> *).
(Transport c, MonadUnliftIO m) =>
TMVar Bool -> ServiceName -> (c -> m ()) -> m ()
runTransportServer TMVar Bool
started ServiceName
tcpPort ((c -> m' ()) -> m' ()) -> (c -> m' ()) -> m' ()
forall a b. (a -> b) -> a -> b
$ \(c
h :: c) -> do
      IO () -> m' ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m' ()) -> IO () -> m' ()
forall a b. (a -> b) -> a -> b
$ c -> ByteString -> IO ()
forall c. Transport c => c -> ByteString -> IO ()
putLn c
h ByteString
"Welcome to SMP v0.3.2 agent"
      AgentClient
c <- m' AgentClient
forall (m :: * -> *).
(MonadUnliftIO m, MonadReader Env m) =>
m AgentClient
getSMPAgentClient
      AgentClient -> Bool -> m' ()
forall (m :: * -> *).
MonadUnliftIO m =>
AgentClient -> Bool -> m ()
logConnection AgentClient
c Bool
True
      m' () -> m' () -> m' ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m ()
race_ (c -> AgentClient -> m' ()
forall c (m :: * -> *).
(Transport c, MonadUnliftIO m) =>
c -> AgentClient -> m ()
connectClient c
h AgentClient
c) (AgentClient -> m' ()
forall (m :: * -> *).
(MonadUnliftIO m, MonadReader Env m) =>
AgentClient -> m ()
runSMPAgentClient AgentClient
c)
        m' () -> m' () -> m' ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`E.finally` (AgentClient -> m' ()
forall (m :: * -> *). MonadUnliftIO m => AgentClient -> m ()
closeSMPServerClients AgentClient
c m' () -> m' () -> m' ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> AgentClient -> Bool -> m' ()
forall (m :: * -> *).
MonadUnliftIO m =>
AgentClient -> Bool -> m ()
logConnection AgentClient
c Bool
False)

-- | Creates an SMP agent instance that receives commands and sends responses via 'TBQueue's.
getSMPAgentClient :: (MonadUnliftIO m, MonadReader Env m) => m AgentClient
getSMPAgentClient :: m AgentClient
getSMPAgentClient = do
  TVar Int
n <- (Env -> TVar Int) -> m (TVar Int)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> TVar Int
clientCounter
  AgentConfig
cfg <- (Env -> AgentConfig) -> m AgentConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> AgentConfig
config
  STM AgentClient -> m AgentClient
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM AgentClient -> m AgentClient)
-> STM AgentClient -> m AgentClient
forall a b. (a -> b) -> a -> b
$ TVar Int -> AgentConfig -> STM AgentClient
newAgentClient TVar Int
n AgentConfig
cfg

connectClient :: Transport c => MonadUnliftIO m => c -> AgentClient -> m ()
connectClient :: c -> AgentClient -> m ()
connectClient c
h AgentClient
c = m () -> m () -> m ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m ()
race_ (c -> AgentClient -> m ()
forall c (m :: * -> *).
(Transport c, MonadUnliftIO m) =>
c -> AgentClient -> m ()
send c
h AgentClient
c) (c -> AgentClient -> m ()
forall c (m :: * -> *).
(Transport c, MonadUnliftIO m) =>
c -> AgentClient -> m ()
receive c
h AgentClient
c)

logConnection :: MonadUnliftIO m => AgentClient -> Bool -> m ()
logConnection :: AgentClient -> Bool -> m ()
logConnection AgentClient
c Bool
connected =
  let event :: Text
event = if Bool
connected then Text
"connected to" else Text
"disconnected from"
   in Text -> m ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logInfo (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unwords [Text
"client", Int -> Text
forall a. Show a => a -> Text
showText (AgentClient -> Int
clientId AgentClient
c), Text
event, Text
"Agent"]

-- | Runs an SMP agent instance that receives commands and sends responses via 'TBQueue's.
runSMPAgentClient :: (MonadUnliftIO m, MonadReader Env m) => AgentClient -> m ()
runSMPAgentClient :: AgentClient -> m ()
runSMPAgentClient AgentClient
c = do
  ServiceName
db <- (Env -> ServiceName) -> m ServiceName
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Env -> ServiceName) -> m ServiceName)
-> (Env -> ServiceName) -> m ServiceName
forall a b. (a -> b) -> a -> b
$ AgentConfig -> ServiceName
dbFile (AgentConfig -> ServiceName)
-> (Env -> AgentConfig) -> Env -> ServiceName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> AgentConfig
config
  SQLiteStore
s1 <- ServiceName -> m SQLiteStore
forall (m :: * -> *).
MonadUnliftIO m =>
ServiceName -> m SQLiteStore
connectSQLiteStore ServiceName
db
  SQLiteStore
s2 <- ServiceName -> m SQLiteStore
forall (m :: * -> *).
MonadUnliftIO m =>
ServiceName -> m SQLiteStore
connectSQLiteStore ServiceName
db
  m () -> m () -> m ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m ()
race_ (AgentClient -> SQLiteStore -> m ()
forall (m :: * -> *).
(MonadUnliftIO m, MonadReader Env m) =>
AgentClient -> SQLiteStore -> m ()
subscriber AgentClient
c SQLiteStore
s1) (AgentClient -> SQLiteStore -> m ()
forall (m :: * -> *).
(MonadUnliftIO m, MonadReader Env m) =>
AgentClient -> SQLiteStore -> m ()
client AgentClient
c SQLiteStore
s2)

receive :: forall c m. (Transport c, MonadUnliftIO m) => c -> AgentClient -> m ()
receive :: c -> AgentClient -> m ()
receive c
h c :: AgentClient
c@AgentClient {TBQueue (ATransmission 'Client)
$sel:rcvQ:AgentClient :: AgentClient -> TBQueue (ATransmission 'Client)
rcvQ :: TBQueue (ATransmission 'Client)
rcvQ, TBQueue (ATransmission 'Agent)
$sel:sndQ:AgentClient :: AgentClient -> TBQueue (ATransmission 'Agent)
sndQ :: TBQueue (ATransmission 'Agent)
sndQ} = m () -> m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  (CorrId
corrId, ByteString
cAlias, Either AgentErrorType (ACommand 'Client)
cmdOrErr) <- SAParty 'Client
-> c
-> m (CorrId, ByteString, Either AgentErrorType (ACommand 'Client))
forall c (m :: * -> *) (p :: AParty).
(Transport c, MonadIO m) =>
SAParty p -> c -> m (ATransmissionOrError p)
tGet SAParty 'Client
SClient c
h
  case Either AgentErrorType (ACommand 'Client)
cmdOrErr of
    Right ACommand 'Client
cmd -> TBQueue (ATransmission 'Client) -> ATransmission 'Client -> m ()
forall (p :: AParty).
TBQueue (ATransmission p) -> ATransmission p -> m ()
write TBQueue (ATransmission 'Client)
rcvQ (CorrId
corrId, ByteString
cAlias, ACommand 'Client
cmd)
    Left AgentErrorType
e -> TBQueue (ATransmission 'Agent) -> ATransmission 'Agent -> m ()
forall (p :: AParty).
TBQueue (ATransmission p) -> ATransmission p -> m ()
write TBQueue (ATransmission 'Agent)
sndQ (CorrId
corrId, ByteString
cAlias, AgentErrorType -> ACommand 'Agent
ERR AgentErrorType
e)
  where
    write :: TBQueue (ATransmission p) -> ATransmission p -> m ()
    write :: TBQueue (ATransmission p) -> ATransmission p -> m ()
write TBQueue (ATransmission p)
q ATransmission p
t = do
      AgentClient -> ByteString -> ATransmission p -> m ()
forall (m :: * -> *) (a :: AParty).
MonadUnliftIO m =>
AgentClient -> ByteString -> ATransmission a -> m ()
logClient AgentClient
c ByteString
"-->" ATransmission p
t
      STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ TBQueue (ATransmission p) -> ATransmission p -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue (ATransmission p)
q ATransmission p
t

send :: (Transport c, MonadUnliftIO m) => c -> AgentClient -> m ()
send :: c -> AgentClient -> m ()
send c
h c :: AgentClient
c@AgentClient {TBQueue (ATransmission 'Agent)
sndQ :: TBQueue (ATransmission 'Agent)
$sel:sndQ:AgentClient :: AgentClient -> TBQueue (ATransmission 'Agent)
sndQ} = m () -> m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  ATransmission 'Agent
t <- STM (ATransmission 'Agent) -> m (ATransmission 'Agent)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (ATransmission 'Agent) -> m (ATransmission 'Agent))
-> STM (ATransmission 'Agent) -> m (ATransmission 'Agent)
forall a b. (a -> b) -> a -> b
$ TBQueue (ATransmission 'Agent) -> STM (ATransmission 'Agent)
forall a. TBQueue a -> STM a
readTBQueue TBQueue (ATransmission 'Agent)
sndQ
  c -> ATransmission 'Agent -> m ()
forall c (m :: * -> *) (p :: AParty).
(Transport c, MonadIO m) =>
c -> ATransmission p -> m ()
tPut c
h ATransmission 'Agent
t
  AgentClient -> ByteString -> ATransmission 'Agent -> m ()
forall (m :: * -> *) (a :: AParty).
MonadUnliftIO m =>
AgentClient -> ByteString -> ATransmission a -> m ()
logClient AgentClient
c ByteString
"<--" ATransmission 'Agent
t

logClient :: MonadUnliftIO m => AgentClient -> ByteString -> ATransmission a -> m ()
logClient :: AgentClient -> ByteString -> ATransmission a -> m ()
logClient AgentClient {Int
clientId :: Int
$sel:clientId:AgentClient :: AgentClient -> Int
clientId} ByteString
dir (CorrId ByteString
corrId, ByteString
cAlias, ACommand a
cmd) = do
  Text -> m ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logInfo (Text -> m ()) -> (ByteString -> Text) -> ByteString -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8 (ByteString -> m ()) -> ByteString -> m ()
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
B.unwords [Int -> ByteString
forall a. Show a => a -> ByteString
bshow Int
clientId, ByteString
dir, ByteString
"A :", ByteString
corrId, ByteString
cAlias, (Char -> Bool) -> ByteString -> ByteString
B.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
' ') (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ACommand a -> ByteString
forall (p :: AParty). ACommand p -> ByteString
serializeCommand ACommand a
cmd]

client :: (MonadUnliftIO m, MonadReader Env m) => AgentClient -> SQLiteStore -> m ()
client :: AgentClient -> SQLiteStore -> m ()
client c :: AgentClient
c@AgentClient {TBQueue (ATransmission 'Client)
rcvQ :: TBQueue (ATransmission 'Client)
$sel:rcvQ:AgentClient :: AgentClient -> TBQueue (ATransmission 'Client)
rcvQ, TBQueue (ATransmission 'Agent)
sndQ :: TBQueue (ATransmission 'Agent)
$sel:sndQ:AgentClient :: AgentClient -> TBQueue (ATransmission 'Agent)
sndQ} SQLiteStore
st = m () -> m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  t :: ATransmission 'Client
t@(CorrId
corrId, ByteString
cAlias, ACommand 'Client
_) <- STM (ATransmission 'Client) -> m (ATransmission 'Client)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (ATransmission 'Client) -> m (ATransmission 'Client))
-> STM (ATransmission 'Client) -> m (ATransmission 'Client)
forall a b. (a -> b) -> a -> b
$ TBQueue (ATransmission 'Client) -> STM (ATransmission 'Client)
forall a. TBQueue a -> STM a
readTBQueue TBQueue (ATransmission 'Client)
rcvQ
  ExceptT AgentErrorType m () -> m (Either AgentErrorType ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (AgentClient
-> SQLiteStore
-> ATransmission 'Client
-> ExceptT AgentErrorType m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> SQLiteStore -> ATransmission 'Client -> m ()
processCommand AgentClient
c SQLiteStore
st ATransmission 'Client
t) m (Either AgentErrorType ())
-> (Either AgentErrorType () -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left AgentErrorType
e -> STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ TBQueue (ATransmission 'Agent) -> ATransmission 'Agent -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue (ATransmission 'Agent)
sndQ (CorrId
corrId, ByteString
cAlias, AgentErrorType -> ACommand 'Agent
ERR AgentErrorType
e)
    Right ()
_ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

withStore ::
  AgentMonad m =>
  (forall m'. (MonadUnliftIO m', MonadError StoreError m') => m' a) ->
  m a
withStore :: (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 m' a)
-> m a
withStore forall (m' :: * -> *).
(MonadUnliftIO m', MonadError StoreError m') =>
m' a
action = do
  ExceptT StoreError m a -> m (Either StoreError a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT StoreError m a
forall (m' :: * -> *).
(MonadUnliftIO m', MonadError StoreError m') =>
m' a
action ExceptT StoreError m a
-> (SQLError -> ExceptT StoreError m a) -> ExceptT StoreError m a
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`E.catch` SQLError -> ExceptT StoreError m a
forall (m' :: * -> *) a.
MonadError StoreError m' =>
SQLError -> m' a
handleInternal) m (Either StoreError a) -> (Either StoreError a -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Right a
c -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
c
    Left StoreError
e -> AgentErrorType -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (AgentErrorType -> m a) -> AgentErrorType -> m a
forall a b. (a -> b) -> a -> b
$ StoreError -> AgentErrorType
storeError StoreError
e
  where
    handleInternal :: (MonadError StoreError m') => SQLError -> m' a
    handleInternal :: SQLError -> m' a
handleInternal SQLError
e = StoreError -> m' a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (StoreError -> m' a)
-> (ByteString -> StoreError) -> ByteString -> m' a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> StoreError
SEInternal (ByteString -> m' a) -> ByteString -> m' a
forall a b. (a -> b) -> a -> b
$ SQLError -> ByteString
forall a. Show a => a -> ByteString
bshow SQLError
e
    storeError :: StoreError -> AgentErrorType
    storeError :: StoreError -> AgentErrorType
storeError = \case
      StoreError
SEConnNotFound -> ConnectionErrorType -> AgentErrorType
CONN ConnectionErrorType
UNKNOWN
      StoreError
SEConnDuplicate -> ConnectionErrorType -> AgentErrorType
CONN ConnectionErrorType
DUPLICATE
      StoreError
e -> ServiceName -> AgentErrorType
INTERNAL (ServiceName -> AgentErrorType) -> ServiceName -> AgentErrorType
forall a b. (a -> b) -> a -> b
$ StoreError -> ServiceName
forall a. Show a => a -> ServiceName
show StoreError
e

processCommand :: forall m. AgentMonad m => AgentClient -> SQLiteStore -> ATransmission 'Client -> m ()
processCommand :: AgentClient -> SQLiteStore -> ATransmission 'Client -> m ()
processCommand c :: AgentClient
c@AgentClient {TBQueue (ATransmission 'Agent)
sndQ :: TBQueue (ATransmission 'Agent)
$sel:sndQ:AgentClient :: AgentClient -> TBQueue (ATransmission 'Agent)
sndQ} SQLiteStore
st (CorrId
corrId, ByteString
connAlias, ACommand 'Client
cmd) =
  case ACommand 'Client
cmd of
    ACommand 'Client
NEW -> m ()
createNewConnection
    JOIN SMPQueueInfo
smpQueueInfo ReplyMode
replyMode -> SMPQueueInfo -> ReplyMode -> m ()
joinConnection SMPQueueInfo
smpQueueInfo ReplyMode
replyMode
    ACommand 'Client
SUB -> ByteString -> m ()
subscribeConnection ByteString
connAlias
    ACommand 'Client
SUBALL -> m ()
subscribeAll
    SEND ByteString
msgBody -> ByteString -> m ()
sendMessage ByteString
msgBody
    ACommand 'Client
OFF -> m ()
suspendConnection
    ACommand 'Client
DEL -> m ()
deleteConnection
  where
    createNewConnection :: m ()
    createNewConnection :: m ()
createNewConnection = do
      -- TODO create connection alias if not passed
      -- make connAlias Maybe?
      SMPServer
srv <- m SMPServer
getSMPServer
      (RcvQueue
rq, SMPQueueInfo
qInfo) <- AgentClient
-> SMPServer -> ByteString -> m (RcvQueue, SMPQueueInfo)
forall (m :: * -> *).
AgentMonad m =>
AgentClient
-> SMPServer -> ByteString -> m (RcvQueue, SMPQueueInfo)
newReceiveQueue AgentClient
c SMPServer
srv ByteString
connAlias
      (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 m' ())
-> m ()
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 m' a)
-> m a
withStore ((forall (m' :: * -> *).
  (MonadUnliftIO m', MonadError StoreError m') =>
  m' ())
 -> m ())
-> (forall (m' :: * -> *).
    (MonadUnliftIO m', MonadError StoreError m') =>
    m' ())
-> m ()
forall a b. (a -> b) -> a -> b
$ SQLiteStore -> RcvQueue -> m' ()
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> RcvQueue -> m ()
createRcvConn SQLiteStore
st RcvQueue
rq
      ACommand 'Agent -> m ()
respond (ACommand 'Agent -> m ()) -> ACommand 'Agent -> m ()
forall a b. (a -> b) -> a -> b
$ SMPQueueInfo -> ACommand 'Agent
INV SMPQueueInfo
qInfo

    getSMPServer :: m SMPServer
    getSMPServer :: m SMPServer
getSMPServer =
      (Env -> NonEmpty SMPServer) -> m (NonEmpty SMPServer)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (AgentConfig -> NonEmpty SMPServer
smpServers (AgentConfig -> NonEmpty SMPServer)
-> (Env -> AgentConfig) -> Env -> NonEmpty SMPServer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> AgentConfig
config) m (NonEmpty SMPServer)
-> (NonEmpty SMPServer -> m SMPServer) -> m SMPServer
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        SMPServer
srv :| [] -> SMPServer -> m SMPServer
forall (f :: * -> *) a. Applicative f => a -> f a
pure SMPServer
srv
        NonEmpty SMPServer
servers -> do
          TVar StdGen
gen <- (Env -> TVar StdGen) -> m (TVar StdGen)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> TVar StdGen
randomServer
          Int
i <- STM Int -> m Int
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Int -> m Int)
-> ((StdGen -> (Int, StdGen)) -> STM Int)
-> (StdGen -> (Int, StdGen))
-> m Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar StdGen -> (StdGen -> (Int, StdGen)) -> STM Int
forall s a. TVar s -> (s -> (a, s)) -> STM a
stateTVar TVar StdGen
gen ((StdGen -> (Int, StdGen)) -> m Int)
-> (StdGen -> (Int, StdGen)) -> m Int
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> StdGen -> (Int, StdGen)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (Int
0, NonEmpty SMPServer -> Int
forall a. NonEmpty a -> Int
L.length NonEmpty SMPServer
servers Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
          SMPServer -> m SMPServer
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SMPServer -> m SMPServer) -> SMPServer -> m SMPServer
forall a b. (a -> b) -> a -> b
$ NonEmpty SMPServer
servers NonEmpty SMPServer -> Int -> SMPServer
forall a. NonEmpty a -> Int -> a
L.!! Int
i

    joinConnection :: SMPQueueInfo -> ReplyMode -> m ()
    joinConnection :: SMPQueueInfo -> ReplyMode -> m ()
joinConnection SMPQueueInfo
qInfo (ReplyMode OnOff
replyMode) = do
      -- TODO create connection alias if not passed
      -- make connAlias Maybe?
      (SndQueue
sq, SenderPublicKey
senderKey, SenderPublicKey
verifyKey) <- SMPQueueInfo
-> ByteString -> m (SndQueue, SenderPublicKey, SenderPublicKey)
forall (m :: * -> *).
(MonadUnliftIO m, MonadReader Env m) =>
SMPQueueInfo
-> ByteString -> m (SndQueue, SenderPublicKey, SenderPublicKey)
newSendQueue SMPQueueInfo
qInfo ByteString
connAlias
      (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 m' ())
-> m ()
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 m' a)
-> m a
withStore ((forall (m' :: * -> *).
  (MonadUnliftIO m', MonadError StoreError m') =>
  m' ())
 -> m ())
-> (forall (m' :: * -> *).
    (MonadUnliftIO m', MonadError StoreError m') =>
    m' ())
-> m ()
forall a b. (a -> b) -> a -> b
$ SQLiteStore -> SndQueue -> m' ()
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> SndQueue -> m ()
createSndConn SQLiteStore
st SndQueue
sq
      AgentClient
-> SQLiteStore
-> SndQueue
-> SenderPublicKey
-> SenderPublicKey
-> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient
-> SQLiteStore
-> SndQueue
-> SenderPublicKey
-> SenderPublicKey
-> m ()
connectToSendQueue AgentClient
c SQLiteStore
st SndQueue
sq SenderPublicKey
senderKey SenderPublicKey
verifyKey
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (OnOff
replyMode OnOff -> OnOff -> Bool
forall a. Eq a => a -> a -> Bool
== OnOff
On) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ SndQueue -> m ()
createReplyQueue SndQueue
sq
    -- TODO this response is disabled to avoid two responses in terminal client (OK + CON),
    -- respond OK

    subscribeConnection :: ConnAlias -> m ()
    subscribeConnection :: ByteString -> m ()
subscribeConnection ByteString
cAlias =
      (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 m' SomeConn)
-> m SomeConn
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 m' a)
-> m a
withStore (SQLiteStore -> ByteString -> m' SomeConn
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> ByteString -> m SomeConn
getConn SQLiteStore
st ByteString
cAlias) m SomeConn -> (SomeConn -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        SomeConn SConnType d
_ (DuplexConnection ByteString
_ RcvQueue
rq SndQueue
_) -> RcvQueue -> m ()
subscribe RcvQueue
rq
        SomeConn SConnType d
_ (RcvConnection ByteString
_ RcvQueue
rq) -> RcvQueue -> m ()
subscribe RcvQueue
rq
        SomeConn
_ -> AgentErrorType -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (AgentErrorType -> m ()) -> AgentErrorType -> m ()
forall a b. (a -> b) -> a -> b
$ ConnectionErrorType -> AgentErrorType
CONN ConnectionErrorType
SIMPLEX
      where
        subscribe :: RcvQueue -> m ()
subscribe RcvQueue
rq = AgentClient -> RcvQueue -> ByteString -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> RcvQueue -> ByteString -> m ()
subscribeQueue AgentClient
c RcvQueue
rq ByteString
cAlias m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ByteString -> ACommand 'Agent -> m ()
respond' ByteString
cAlias ACommand 'Agent
OK

    -- TODO remove - hack for subscribing to all; respond' and parameterization of subscribeConnection are byproduct
    subscribeAll :: m ()
    subscribeAll :: m ()
subscribeAll = (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 m' [ByteString])
-> m [ByteString]
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 m' a)
-> m a
withStore (SQLiteStore -> m' [ByteString]
forall s (m :: * -> *). MonadAgentStore s m => s -> m [ByteString]
getAllConnAliases SQLiteStore
st) m [ByteString] -> ([ByteString] -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ByteString -> m ()) -> [ByteString] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ByteString -> m ()
subscribeConnection

    sendMessage :: MsgBody -> m ()
    sendMessage :: ByteString -> m ()
sendMessage ByteString
msgBody =
      (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 m' SomeConn)
-> m SomeConn
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 m' a)
-> m a
withStore (SQLiteStore -> ByteString -> m' SomeConn
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> ByteString -> m SomeConn
getConn SQLiteStore
st ByteString
connAlias) m SomeConn -> (SomeConn -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        SomeConn SConnType d
_ (DuplexConnection ByteString
_ RcvQueue
_ SndQueue
sq) -> SndQueue -> m ()
sendMsg SndQueue
sq
        SomeConn SConnType d
_ (SndConnection ByteString
_ SndQueue
sq) -> SndQueue -> m ()
sendMsg SndQueue
sq
        SomeConn
_ -> AgentErrorType -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (AgentErrorType -> m ()) -> AgentErrorType -> m ()
forall a b. (a -> b) -> a -> b
$ ConnectionErrorType -> AgentErrorType
CONN ConnectionErrorType
SIMPLEX
      where
        sendMsg :: SndQueue -> m ()
sendMsg SndQueue
sq = do
          UTCTime
internalTs <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
          (InternalId
internalId, InternalSndId
internalSndId, ByteString
previousMsgHash) <- (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 m' (InternalId, InternalSndId, ByteString))
-> m (InternalId, InternalSndId, ByteString)
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 m' a)
-> m a
withStore ((forall (m' :: * -> *).
  (MonadUnliftIO m', MonadError StoreError m') =>
  m' (InternalId, InternalSndId, ByteString))
 -> m (InternalId, InternalSndId, ByteString))
-> (forall (m' :: * -> *).
    (MonadUnliftIO m', MonadError StoreError m') =>
    m' (InternalId, InternalSndId, ByteString))
-> m (InternalId, InternalSndId, ByteString)
forall a b. (a -> b) -> a -> b
$ SQLiteStore
-> SndQueue -> m' (InternalId, InternalSndId, ByteString)
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> SndQueue -> m (InternalId, InternalSndId, ByteString)
updateSndIds SQLiteStore
st SndQueue
sq
          let msgStr :: ByteString
msgStr =
                SMPMessage -> ByteString
serializeSMPMessage
                  SMPMessage :: AgentMsgId -> UTCTime -> ByteString -> AMessage -> SMPMessage
SMPMessage
                    { senderMsgId :: AgentMsgId
senderMsgId = InternalSndId -> AgentMsgId
unSndId InternalSndId
internalSndId,
                      senderTimestamp :: UTCTime
senderTimestamp = UTCTime
internalTs,
                      ByteString
previousMsgHash :: ByteString
previousMsgHash :: ByteString
previousMsgHash,
                      agentMessage :: AMessage
agentMessage = ByteString -> AMessage
A_MSG ByteString
msgBody
                    }
              msgHash :: ByteString
msgHash = ByteString -> ByteString
C.sha256Hash ByteString
msgStr
          (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 m' ())
-> m ()
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 m' a)
-> m a
withStore ((forall (m' :: * -> *).
  (MonadUnliftIO m', MonadError StoreError m') =>
  m' ())
 -> m ())
-> (forall (m' :: * -> *).
    (MonadUnliftIO m', MonadError StoreError m') =>
    m' ())
-> m ()
forall a b. (a -> b) -> a -> b
$
            SQLiteStore -> SndQueue -> SndMsgData -> m' ()
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> SndQueue -> SndMsgData -> m ()
createSndMsg SQLiteStore
st SndQueue
sq (SndMsgData -> m' ()) -> SndMsgData -> m' ()
forall a b. (a -> b) -> a -> b
$
              SndMsgData :: InternalId
-> InternalSndId
-> UTCTime
-> ByteString
-> ByteString
-> SndMsgData
SndMsgData {InternalId
$sel:internalId:SndMsgData :: InternalId
internalId :: InternalId
internalId, InternalSndId
$sel:internalSndId:SndMsgData :: InternalSndId
internalSndId :: InternalSndId
internalSndId, UTCTime
$sel:internalTs:SndMsgData :: UTCTime
internalTs :: UTCTime
internalTs, ByteString
$sel:msgBody:SndMsgData :: ByteString
msgBody :: ByteString
msgBody, $sel:internalHash:SndMsgData :: ByteString
internalHash = ByteString
msgHash}
          AgentClient -> SndQueue -> ByteString -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> SndQueue -> ByteString -> m ()
sendAgentMessage AgentClient
c SndQueue
sq ByteString
msgStr
          ACommand 'Agent -> m ()
respond (ACommand 'Agent -> m ()) -> ACommand 'Agent -> m ()
forall a b. (a -> b) -> a -> b
$ AgentMsgId -> ACommand 'Agent
SENT (InternalId -> AgentMsgId
unId InternalId
internalId)

    suspendConnection :: m ()
    suspendConnection :: m ()
suspendConnection =
      (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 m' SomeConn)
-> m SomeConn
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 m' a)
-> m a
withStore (SQLiteStore -> ByteString -> m' SomeConn
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> ByteString -> m SomeConn
getConn SQLiteStore
st ByteString
connAlias) m SomeConn -> (SomeConn -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        SomeConn SConnType d
_ (DuplexConnection ByteString
_ RcvQueue
rq SndQueue
_) -> RcvQueue -> m ()
suspend RcvQueue
rq
        SomeConn SConnType d
_ (RcvConnection ByteString
_ RcvQueue
rq) -> RcvQueue -> m ()
suspend RcvQueue
rq
        SomeConn
_ -> AgentErrorType -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (AgentErrorType -> m ()) -> AgentErrorType -> m ()
forall a b. (a -> b) -> a -> b
$ ConnectionErrorType -> AgentErrorType
CONN ConnectionErrorType
SIMPLEX
      where
        suspend :: RcvQueue -> m ()
suspend RcvQueue
rq = AgentClient -> RcvQueue -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> RcvQueue -> m ()
suspendQueue AgentClient
c RcvQueue
rq m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ACommand 'Agent -> m ()
respond ACommand 'Agent
OK

    deleteConnection :: m ()
    deleteConnection :: m ()
deleteConnection =
      (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 m' SomeConn)
-> m SomeConn
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 m' a)
-> m a
withStore (SQLiteStore -> ByteString -> m' SomeConn
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> ByteString -> m SomeConn
getConn SQLiteStore
st ByteString
connAlias) m SomeConn -> (SomeConn -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        SomeConn SConnType d
_ (DuplexConnection ByteString
_ RcvQueue
rq SndQueue
_) -> RcvQueue -> m ()
delete RcvQueue
rq
        SomeConn SConnType d
_ (RcvConnection ByteString
_ RcvQueue
rq) -> RcvQueue -> m ()
delete RcvQueue
rq
        SomeConn
_ -> m ()
delConn
      where
        delConn :: m ()
delConn = (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 m' ())
-> m ()
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 m' a)
-> m a
withStore (SQLiteStore -> ByteString -> m' ()
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> ByteString -> m ()
deleteConn SQLiteStore
st ByteString
connAlias) m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ACommand 'Agent -> m ()
respond ACommand 'Agent
OK
        delete :: RcvQueue -> m ()
delete RcvQueue
rq = do
          AgentClient -> RcvQueue -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> RcvQueue -> m ()
deleteQueue AgentClient
c RcvQueue
rq
          AgentClient -> ByteString -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> ByteString -> m ()
removeSubscription AgentClient
c ByteString
connAlias
          m ()
delConn

    createReplyQueue :: SndQueue -> m ()
    createReplyQueue :: SndQueue -> m ()
createReplyQueue SndQueue
sq = do
      SMPServer
srv <- m SMPServer
getSMPServer
      (RcvQueue
rq, SMPQueueInfo
qInfo) <- AgentClient
-> SMPServer -> ByteString -> m (RcvQueue, SMPQueueInfo)
forall (m :: * -> *).
AgentMonad m =>
AgentClient
-> SMPServer -> ByteString -> m (RcvQueue, SMPQueueInfo)
newReceiveQueue AgentClient
c SMPServer
srv ByteString
connAlias
      (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 m' ())
-> m ()
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 m' a)
-> m a
withStore ((forall (m' :: * -> *).
  (MonadUnliftIO m', MonadError StoreError m') =>
  m' ())
 -> m ())
-> (forall (m' :: * -> *).
    (MonadUnliftIO m', MonadError StoreError m') =>
    m' ())
-> m ()
forall a b. (a -> b) -> a -> b
$ SQLiteStore -> ByteString -> RcvQueue -> m' ()
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> ByteString -> RcvQueue -> m ()
upgradeSndConnToDuplex SQLiteStore
st ByteString
connAlias RcvQueue
rq
      UTCTime
senderTimestamp <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
      AgentClient -> SndQueue -> ByteString -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> SndQueue -> ByteString -> m ()
sendAgentMessage AgentClient
c SndQueue
sq (ByteString -> m ())
-> (SMPMessage -> ByteString) -> SMPMessage -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SMPMessage -> ByteString
serializeSMPMessage (SMPMessage -> m ()) -> SMPMessage -> m ()
forall a b. (a -> b) -> a -> b
$
        SMPMessage :: AgentMsgId -> UTCTime -> ByteString -> AMessage -> SMPMessage
SMPMessage
          { senderMsgId :: AgentMsgId
senderMsgId = AgentMsgId
0,
            UTCTime
senderTimestamp :: UTCTime
senderTimestamp :: UTCTime
senderTimestamp,
            previousMsgHash :: ByteString
previousMsgHash = ByteString
"",
            agentMessage :: AMessage
agentMessage = SMPQueueInfo -> AMessage
REPLY SMPQueueInfo
qInfo
          }

    respond :: ACommand 'Agent -> m ()
    respond :: ACommand 'Agent -> m ()
respond = ByteString -> ACommand 'Agent -> m ()
respond' ByteString
connAlias

    respond' :: ConnAlias -> ACommand 'Agent -> m ()
    respond' :: ByteString -> ACommand 'Agent -> m ()
respond' ByteString
cAlias ACommand 'Agent
resp = STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ TBQueue (ATransmission 'Agent) -> ATransmission 'Agent -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue (ATransmission 'Agent)
sndQ (CorrId
corrId, ByteString
cAlias, ACommand 'Agent
resp)

subscriber :: (MonadUnliftIO m, MonadReader Env m) => AgentClient -> SQLiteStore -> m ()
subscriber :: AgentClient -> SQLiteStore -> m ()
subscriber c :: AgentClient
c@AgentClient {TBQueue SMPServerTransmission
$sel:msgQ:AgentClient :: AgentClient -> TBQueue SMPServerTransmission
msgQ :: TBQueue SMPServerTransmission
msgQ} SQLiteStore
st = m () -> m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  -- TODO this will only process messages and notifications
  SMPServerTransmission
t <- STM SMPServerTransmission -> m SMPServerTransmission
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM SMPServerTransmission -> m SMPServerTransmission)
-> STM SMPServerTransmission -> m SMPServerTransmission
forall a b. (a -> b) -> a -> b
$ TBQueue SMPServerTransmission -> STM SMPServerTransmission
forall a. TBQueue a -> STM a
readTBQueue TBQueue SMPServerTransmission
msgQ
  ExceptT AgentErrorType m () -> m (Either AgentErrorType ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (AgentClient
-> SQLiteStore
-> SMPServerTransmission
-> ExceptT AgentErrorType m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> SQLiteStore -> SMPServerTransmission -> m ()
processSMPTransmission AgentClient
c SQLiteStore
st SMPServerTransmission
t) m (Either AgentErrorType ())
-> (Either AgentErrorType () -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left AgentErrorType
e -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ AgentErrorType -> IO ()
forall a. Show a => a -> IO ()
print AgentErrorType
e
    Right ()
_ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

processSMPTransmission :: forall m. AgentMonad m => AgentClient -> SQLiteStore -> SMPServerTransmission -> m ()
processSMPTransmission :: AgentClient -> SQLiteStore -> SMPServerTransmission -> m ()
processSMPTransmission c :: AgentClient
c@AgentClient {TBQueue (ATransmission 'Agent)
sndQ :: TBQueue (ATransmission 'Agent)
$sel:sndQ:AgentClient :: AgentClient -> TBQueue (ATransmission 'Agent)
sndQ} SQLiteStore
st (SMPServer
srv, ByteString
rId, Command 'Broker
cmd) = do
  (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 m' SomeConn)
-> m SomeConn
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 m' a)
-> m a
withStore (SQLiteStore -> SMPServer -> ByteString -> m' SomeConn
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> SMPServer -> ByteString -> m SomeConn
getRcvConn SQLiteStore
st SMPServer
srv ByteString
rId) m SomeConn -> (SomeConn -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    SomeConn SConnType d
SCDuplex (DuplexConnection ByteString
_ RcvQueue
rq SndQueue
_) -> SConnType 'CDuplex -> RcvQueue -> m ()
forall (c :: ConnType). SConnType c -> RcvQueue -> m ()
processSMP SConnType 'CDuplex
SCDuplex RcvQueue
rq
    SomeConn SConnType d
SCRcv (RcvConnection ByteString
_ RcvQueue
rq) -> SConnType 'CRcv -> RcvQueue -> m ()
forall (c :: ConnType). SConnType c -> RcvQueue -> m ()
processSMP SConnType 'CRcv
SCRcv RcvQueue
rq
    SomeConn
_ -> STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ TBQueue (ATransmission 'Agent) -> ATransmission 'Agent -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue (ATransmission 'Agent)
sndQ (CorrId
"", ByteString
"", AgentErrorType -> ACommand 'Agent
ERR (AgentErrorType -> ACommand 'Agent)
-> AgentErrorType -> ACommand 'Agent
forall a b. (a -> b) -> a -> b
$ ConnectionErrorType -> AgentErrorType
CONN ConnectionErrorType
SIMPLEX)
  where
    processSMP :: SConnType c -> RcvQueue -> m ()
    processSMP :: SConnType c -> RcvQueue -> m ()
processSMP SConnType c
cType rq :: RcvQueue
rq@RcvQueue {ByteString
$sel:connAlias:RcvQueue :: RcvQueue -> ByteString
connAlias :: ByteString
connAlias, QueueStatus
$sel:status:RcvQueue :: RcvQueue -> QueueStatus
status :: QueueStatus
status} =
      case Command 'Broker
cmd of
        SMP.MSG ByteString
srvMsgId UTCTime
srvTs ByteString
msgBody -> do
          -- TODO deduplicate with previously received
          ByteString
msg <- RcvQueue -> ByteString -> m ByteString
forall (m :: * -> *).
AgentMonad m =>
RcvQueue -> ByteString -> m ByteString
decryptAndVerify RcvQueue
rq ByteString
msgBody
          let msgHash :: ByteString
msgHash = ByteString -> ByteString
C.sha256Hash ByteString
msg
          SMPMessage
agentMsg <- Either AgentErrorType SMPMessage -> m SMPMessage
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either AgentErrorType SMPMessage -> m SMPMessage)
-> Either AgentErrorType SMPMessage -> m SMPMessage
forall a b. (a -> b) -> a -> b
$ ByteString -> Either AgentErrorType SMPMessage
parseSMPMessage ByteString
msg
          case SMPMessage
agentMsg of
            SMPConfirmation SenderPublicKey
senderKey -> SenderPublicKey -> m ()
smpConfirmation SenderPublicKey
senderKey
            SMPMessage {AMessage
agentMessage :: AMessage
agentMessage :: SMPMessage -> AMessage
agentMessage, AgentMsgId
senderMsgId :: AgentMsgId
senderMsgId :: SMPMessage -> AgentMsgId
senderMsgId, UTCTime
senderTimestamp :: UTCTime
senderTimestamp :: SMPMessage -> UTCTime
senderTimestamp, ByteString
previousMsgHash :: ByteString
previousMsgHash :: SMPMessage -> ByteString
previousMsgHash} ->
              case AMessage
agentMessage of
                HELLO SenderPublicKey
verifyKey AckMode
_ -> SenderPublicKey -> ByteString -> m ()
helloMsg SenderPublicKey
verifyKey ByteString
msgBody
                REPLY SMPQueueInfo
qInfo -> SMPQueueInfo -> m ()
replyMsg SMPQueueInfo
qInfo
                A_MSG ByteString
body -> ByteString
-> (AgentMsgId, UTCTime)
-> (ByteString, UTCTime)
-> ByteString
-> ByteString
-> m ()
agentClientMsg ByteString
previousMsgHash (AgentMsgId
senderMsgId, UTCTime
senderTimestamp) (ByteString
srvMsgId, UTCTime
srvTs) ByteString
body ByteString
msgHash
          AgentClient -> RcvQueue -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> RcvQueue -> m ()
sendAck AgentClient
c RcvQueue
rq
          () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Command 'Broker
SMP.END -> do
          AgentClient -> ByteString -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> ByteString -> m ()
removeSubscription AgentClient
c ByteString
connAlias
          ByteString
-> AgentClient -> SMPServer -> ByteString -> ByteString -> m ()
forall (m :: * -> *).
AgentMonad m =>
ByteString
-> AgentClient -> SMPServer -> ByteString -> ByteString -> m ()
logServer ByteString
"<--" AgentClient
c SMPServer
srv ByteString
rId ByteString
"END"
          ACommand 'Agent -> m ()
notify ACommand 'Agent
END
        Command 'Broker
_ -> do
          ByteString
-> AgentClient -> SMPServer -> ByteString -> ByteString -> m ()
forall (m :: * -> *).
AgentMonad m =>
ByteString
-> AgentClient -> SMPServer -> ByteString -> ByteString -> m ()
logServer ByteString
"<--" AgentClient
c SMPServer
srv ByteString
rId (ByteString -> m ()) -> ByteString -> m ()
forall a b. (a -> b) -> a -> b
$ ByteString
"unexpected: " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Command 'Broker -> ByteString
forall a. Show a => a -> ByteString
bshow Command 'Broker
cmd
          ACommand 'Agent -> m ()
notify (ACommand 'Agent -> m ())
-> (AgentErrorType -> ACommand 'Agent) -> AgentErrorType -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentErrorType -> ACommand 'Agent
ERR (AgentErrorType -> m ()) -> AgentErrorType -> m ()
forall a b. (a -> b) -> a -> b
$ BrokerErrorType -> AgentErrorType
BROKER BrokerErrorType
UNEXPECTED
      where
        notify :: ACommand 'Agent -> m ()
        notify :: ACommand 'Agent -> m ()
notify ACommand 'Agent
msg = STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ TBQueue (ATransmission 'Agent) -> ATransmission 'Agent -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue (ATransmission 'Agent)
sndQ (CorrId
"", ByteString
connAlias, ACommand 'Agent
msg)

        prohibited :: m ()
        prohibited :: m ()
prohibited = ACommand 'Agent -> m ()
notify (ACommand 'Agent -> m ())
-> (AgentErrorType -> ACommand 'Agent) -> AgentErrorType -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentErrorType -> ACommand 'Agent
ERR (AgentErrorType -> m ()) -> AgentErrorType -> m ()
forall a b. (a -> b) -> a -> b
$ SMPAgentError -> AgentErrorType
AGENT SMPAgentError
A_PROHIBITED

        smpConfirmation :: SenderPublicKey -> m ()
        smpConfirmation :: SenderPublicKey -> m ()
smpConfirmation SenderPublicKey
senderKey = do
          ByteString
-> AgentClient -> SMPServer -> ByteString -> ByteString -> m ()
forall (m :: * -> *).
AgentMonad m =>
ByteString
-> AgentClient -> SMPServer -> ByteString -> ByteString -> m ()
logServer ByteString
"<--" AgentClient
c SMPServer
srv ByteString
rId ByteString
"MSG <KEY>"
          case QueueStatus
status of
            QueueStatus
New -> do
              -- TODO currently it automatically allows whoever sends the confirmation
              -- Commands CONF and LET are not supported in v0.2
              (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 m' ())
-> m ()
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 m' a)
-> m a
withStore ((forall (m' :: * -> *).
  (MonadUnliftIO m', MonadError StoreError m') =>
  m' ())
 -> m ())
-> (forall (m' :: * -> *).
    (MonadUnliftIO m', MonadError StoreError m') =>
    m' ())
-> m ()
forall a b. (a -> b) -> a -> b
$ SQLiteStore -> RcvQueue -> QueueStatus -> m' ()
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> RcvQueue -> QueueStatus -> m ()
setRcvQueueStatus SQLiteStore
st RcvQueue
rq QueueStatus
Confirmed
              -- TODO update sender key in the store?
              AgentClient -> RcvQueue -> SenderPublicKey -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> RcvQueue -> SenderPublicKey -> m ()
secureQueue AgentClient
c RcvQueue
rq SenderPublicKey
senderKey
              (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 m' ())
-> m ()
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 m' a)
-> m a
withStore ((forall (m' :: * -> *).
  (MonadUnliftIO m', MonadError StoreError m') =>
  m' ())
 -> m ())
-> (forall (m' :: * -> *).
    (MonadUnliftIO m', MonadError StoreError m') =>
    m' ())
-> m ()
forall a b. (a -> b) -> a -> b
$ SQLiteStore -> RcvQueue -> QueueStatus -> m' ()
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> RcvQueue -> QueueStatus -> m ()
setRcvQueueStatus SQLiteStore
st RcvQueue
rq QueueStatus
Secured
            QueueStatus
_ -> m ()
prohibited

        helloMsg :: SenderPublicKey -> ByteString -> m ()
        helloMsg :: SenderPublicKey -> ByteString -> m ()
helloMsg SenderPublicKey
verifyKey ByteString
msgBody = do
          ByteString
-> AgentClient -> SMPServer -> ByteString -> ByteString -> m ()
forall (m :: * -> *).
AgentMonad m =>
ByteString
-> AgentClient -> SMPServer -> ByteString -> ByteString -> m ()
logServer ByteString
"<--" AgentClient
c SMPServer
srv ByteString
rId ByteString
"MSG <HELLO>"
          case QueueStatus
status of
            QueueStatus
Active -> m ()
prohibited
            QueueStatus
_ -> do
              m ByteString -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m ByteString -> m ()) -> m ByteString -> m ()
forall a b. (a -> b) -> a -> b
$ Maybe SenderPublicKey -> ByteString -> m ByteString
forall (m :: * -> *).
AgentMonad m =>
Maybe SenderPublicKey -> ByteString -> m ByteString
verifyMessage (SenderPublicKey -> Maybe SenderPublicKey
forall a. a -> Maybe a
Just SenderPublicKey
verifyKey) ByteString
msgBody
              (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 m' ())
-> m ()
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 m' a)
-> m a
withStore ((forall (m' :: * -> *).
  (MonadUnliftIO m', MonadError StoreError m') =>
  m' ())
 -> m ())
-> (forall (m' :: * -> *).
    (MonadUnliftIO m', MonadError StoreError m') =>
    m' ())
-> m ()
forall a b. (a -> b) -> a -> b
$ SQLiteStore -> RcvQueue -> SenderPublicKey -> m' ()
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> RcvQueue -> SenderPublicKey -> m ()
setRcvQueueActive SQLiteStore
st RcvQueue
rq SenderPublicKey
verifyKey
              case SConnType c
cType of
                SConnType c
SCDuplex -> ACommand 'Agent -> m ()
notify ACommand 'Agent
CON
                SConnType c
_ -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

        replyMsg :: SMPQueueInfo -> m ()
        replyMsg :: SMPQueueInfo -> m ()
replyMsg SMPQueueInfo
qInfo = do
          ByteString
-> AgentClient -> SMPServer -> ByteString -> ByteString -> m ()
forall (m :: * -> *).
AgentMonad m =>
ByteString
-> AgentClient -> SMPServer -> ByteString -> ByteString -> m ()
logServer ByteString
"<--" AgentClient
c SMPServer
srv ByteString
rId ByteString
"MSG <REPLY>"
          case SConnType c
cType of
            SConnType c
SCRcv -> do
              (SndQueue
sq, SenderPublicKey
senderKey, SenderPublicKey
verifyKey) <- SMPQueueInfo
-> ByteString -> m (SndQueue, SenderPublicKey, SenderPublicKey)
forall (m :: * -> *).
(MonadUnliftIO m, MonadReader Env m) =>
SMPQueueInfo
-> ByteString -> m (SndQueue, SenderPublicKey, SenderPublicKey)
newSendQueue SMPQueueInfo
qInfo ByteString
connAlias
              (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 m' ())
-> m ()
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 m' a)
-> m a
withStore ((forall (m' :: * -> *).
  (MonadUnliftIO m', MonadError StoreError m') =>
  m' ())
 -> m ())
-> (forall (m' :: * -> *).
    (MonadUnliftIO m', MonadError StoreError m') =>
    m' ())
-> m ()
forall a b. (a -> b) -> a -> b
$ SQLiteStore -> ByteString -> SndQueue -> m' ()
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> ByteString -> SndQueue -> m ()
upgradeRcvConnToDuplex SQLiteStore
st ByteString
connAlias SndQueue
sq
              AgentClient
-> SQLiteStore
-> SndQueue
-> SenderPublicKey
-> SenderPublicKey
-> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient
-> SQLiteStore
-> SndQueue
-> SenderPublicKey
-> SenderPublicKey
-> m ()
connectToSendQueue AgentClient
c SQLiteStore
st SndQueue
sq SenderPublicKey
senderKey SenderPublicKey
verifyKey
              ACommand 'Agent -> m ()
notify ACommand 'Agent
CON
            SConnType c
_ -> m ()
prohibited

        agentClientMsg :: PrevRcvMsgHash -> (ExternalSndId, ExternalSndTs) -> (BrokerId, BrokerTs) -> MsgBody -> MsgHash -> m ()
        agentClientMsg :: ByteString
-> (AgentMsgId, UTCTime)
-> (ByteString, UTCTime)
-> ByteString
-> ByteString
-> m ()
agentClientMsg ByteString
receivedPrevMsgHash (AgentMsgId, UTCTime)
senderMeta (ByteString, UTCTime)
brokerMeta ByteString
msgBody ByteString
msgHash = do
          ByteString
-> AgentClient -> SMPServer -> ByteString -> ByteString -> m ()
forall (m :: * -> *).
AgentMonad m =>
ByteString
-> AgentClient -> SMPServer -> ByteString -> ByteString -> m ()
logServer ByteString
"<--" AgentClient
c SMPServer
srv ByteString
rId ByteString
"MSG <MSG>"
          case QueueStatus
status of
            QueueStatus
Active -> do
              UTCTime
internalTs <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
              (InternalId
internalId, InternalRcvId
internalRcvId, AgentMsgId
prevExtSndId, ByteString
prevRcvMsgHash) <- (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 m' (InternalId, InternalRcvId, AgentMsgId, ByteString))
-> m (InternalId, InternalRcvId, AgentMsgId, ByteString)
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 m' a)
-> m a
withStore ((forall (m' :: * -> *).
  (MonadUnliftIO m', MonadError StoreError m') =>
  m' (InternalId, InternalRcvId, AgentMsgId, ByteString))
 -> m (InternalId, InternalRcvId, AgentMsgId, ByteString))
-> (forall (m' :: * -> *).
    (MonadUnliftIO m', MonadError StoreError m') =>
    m' (InternalId, InternalRcvId, AgentMsgId, ByteString))
-> m (InternalId, InternalRcvId, AgentMsgId, ByteString)
forall a b. (a -> b) -> a -> b
$ SQLiteStore
-> RcvQueue
-> m' (InternalId, InternalRcvId, AgentMsgId, ByteString)
forall s (m :: * -> *).
MonadAgentStore s m =>
s
-> RcvQueue
-> m (InternalId, InternalRcvId, AgentMsgId, ByteString)
updateRcvIds SQLiteStore
st RcvQueue
rq
              let msgIntegrity :: MsgIntegrity
msgIntegrity = AgentMsgId
-> AgentMsgId -> ByteString -> ByteString -> MsgIntegrity
checkMsgIntegrity AgentMsgId
prevExtSndId ((AgentMsgId, UTCTime) -> AgentMsgId
forall a b. (a, b) -> a
fst (AgentMsgId, UTCTime)
senderMeta) ByteString
prevRcvMsgHash ByteString
receivedPrevMsgHash
              (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 m' ())
-> m ()
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 m' a)
-> m a
withStore ((forall (m' :: * -> *).
  (MonadUnliftIO m', MonadError StoreError m') =>
  m' ())
 -> m ())
-> (forall (m' :: * -> *).
    (MonadUnliftIO m', MonadError StoreError m') =>
    m' ())
-> m ()
forall a b. (a -> b) -> a -> b
$
                SQLiteStore -> RcvQueue -> RcvMsgData -> m' ()
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> RcvQueue -> RcvMsgData -> m ()
createRcvMsg SQLiteStore
st RcvQueue
rq (RcvMsgData -> m' ()) -> RcvMsgData -> m' ()
forall a b. (a -> b) -> a -> b
$
                  RcvMsgData :: InternalId
-> InternalRcvId
-> UTCTime
-> (AgentMsgId, UTCTime)
-> (ByteString, UTCTime)
-> ByteString
-> ByteString
-> ByteString
-> MsgIntegrity
-> RcvMsgData
RcvMsgData
                    { InternalId
$sel:internalId:RcvMsgData :: InternalId
internalId :: InternalId
internalId,
                      InternalRcvId
$sel:internalRcvId:RcvMsgData :: InternalRcvId
internalRcvId :: InternalRcvId
internalRcvId,
                      UTCTime
$sel:internalTs:RcvMsgData :: UTCTime
internalTs :: UTCTime
internalTs,
                      (AgentMsgId, UTCTime)
$sel:senderMeta:RcvMsgData :: (AgentMsgId, UTCTime)
senderMeta :: (AgentMsgId, UTCTime)
senderMeta,
                      (ByteString, UTCTime)
$sel:brokerMeta:RcvMsgData :: (ByteString, UTCTime)
brokerMeta :: (ByteString, UTCTime)
brokerMeta,
                      ByteString
$sel:msgBody:RcvMsgData :: ByteString
msgBody :: ByteString
msgBody,
                      $sel:internalHash:RcvMsgData :: ByteString
internalHash = ByteString
msgHash,
                      $sel:externalPrevSndHash:RcvMsgData :: ByteString
externalPrevSndHash = ByteString
receivedPrevMsgHash,
                      MsgIntegrity
$sel:msgIntegrity:RcvMsgData :: MsgIntegrity
msgIntegrity :: MsgIntegrity
msgIntegrity
                    }
              ACommand 'Agent -> m ()
notify
                MSG :: (AgentMsgId, UTCTime)
-> (ByteString, UTCTime)
-> (AgentMsgId, UTCTime)
-> MsgIntegrity
-> ByteString
-> ACommand 'Agent
MSG
                  { recipientMeta :: (AgentMsgId, UTCTime)
recipientMeta = (InternalId -> AgentMsgId
unId InternalId
internalId, UTCTime
internalTs),
                    (AgentMsgId, UTCTime)
senderMeta :: (AgentMsgId, UTCTime)
senderMeta :: (AgentMsgId, UTCTime)
senderMeta,
                    (ByteString, UTCTime)
brokerMeta :: (ByteString, UTCTime)
brokerMeta :: (ByteString, UTCTime)
brokerMeta,
                    ByteString
msgBody :: ByteString
msgBody :: ByteString
msgBody,
                    MsgIntegrity
msgIntegrity :: MsgIntegrity
msgIntegrity :: MsgIntegrity
msgIntegrity
                  }
            QueueStatus
_ -> m ()
prohibited

        checkMsgIntegrity :: PrevExternalSndId -> ExternalSndId -> PrevRcvMsgHash -> ByteString -> MsgIntegrity
        checkMsgIntegrity :: AgentMsgId
-> AgentMsgId -> ByteString -> ByteString -> MsgIntegrity
checkMsgIntegrity AgentMsgId
prevExtSndId AgentMsgId
extSndId ByteString
internalPrevMsgHash ByteString
receivedPrevMsgHash
          | AgentMsgId
extSndId AgentMsgId -> AgentMsgId -> Bool
forall a. Eq a => a -> a -> Bool
== AgentMsgId
prevExtSndId AgentMsgId -> AgentMsgId -> AgentMsgId
forall a. Num a => a -> a -> a
+ AgentMsgId
1 Bool -> Bool -> Bool
&& ByteString
internalPrevMsgHash ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
receivedPrevMsgHash = MsgIntegrity
MsgOk
          | AgentMsgId
extSndId AgentMsgId -> AgentMsgId -> Bool
forall a. Ord a => a -> a -> Bool
< AgentMsgId
prevExtSndId = MsgErrorType -> MsgIntegrity
MsgError (MsgErrorType -> MsgIntegrity) -> MsgErrorType -> MsgIntegrity
forall a b. (a -> b) -> a -> b
$ AgentMsgId -> MsgErrorType
MsgBadId AgentMsgId
extSndId
          | AgentMsgId
extSndId AgentMsgId -> AgentMsgId -> Bool
forall a. Eq a => a -> a -> Bool
== AgentMsgId
prevExtSndId = MsgErrorType -> MsgIntegrity
MsgError MsgErrorType
MsgDuplicate -- ? deduplicate
          | AgentMsgId
extSndId AgentMsgId -> AgentMsgId -> Bool
forall a. Ord a => a -> a -> Bool
> AgentMsgId
prevExtSndId AgentMsgId -> AgentMsgId -> AgentMsgId
forall a. Num a => a -> a -> a
+ AgentMsgId
1 = MsgErrorType -> MsgIntegrity
MsgError (MsgErrorType -> MsgIntegrity) -> MsgErrorType -> MsgIntegrity
forall a b. (a -> b) -> a -> b
$ AgentMsgId -> AgentMsgId -> MsgErrorType
MsgSkipped (AgentMsgId
prevExtSndId AgentMsgId -> AgentMsgId -> AgentMsgId
forall a. Num a => a -> a -> a
+ AgentMsgId
1) (AgentMsgId
extSndId AgentMsgId -> AgentMsgId -> AgentMsgId
forall a. Num a => a -> a -> a
- AgentMsgId
1)
          | ByteString
internalPrevMsgHash ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
receivedPrevMsgHash = MsgErrorType -> MsgIntegrity
MsgError MsgErrorType
MsgBadHash
          | Bool
otherwise = MsgErrorType -> MsgIntegrity
MsgError MsgErrorType
MsgDuplicate -- this case is not possible

connectToSendQueue :: AgentMonad m => AgentClient -> SQLiteStore -> SndQueue -> SenderPublicKey -> VerificationKey -> m ()
connectToSendQueue :: AgentClient
-> SQLiteStore
-> SndQueue
-> SenderPublicKey
-> SenderPublicKey
-> m ()
connectToSendQueue AgentClient
c SQLiteStore
st SndQueue
sq SenderPublicKey
senderKey SenderPublicKey
verifyKey = do
  AgentClient -> SndQueue -> SenderPublicKey -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> SndQueue -> SenderPublicKey -> m ()
sendConfirmation AgentClient
c SndQueue
sq SenderPublicKey
senderKey
  (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 m' ())
-> m ()
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 m' a)
-> m a
withStore ((forall (m' :: * -> *).
  (MonadUnliftIO m', MonadError StoreError m') =>
  m' ())
 -> m ())
-> (forall (m' :: * -> *).
    (MonadUnliftIO m', MonadError StoreError m') =>
    m' ())
-> m ()
forall a b. (a -> b) -> a -> b
$ SQLiteStore -> SndQueue -> QueueStatus -> m' ()
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> SndQueue -> QueueStatus -> m ()
setSndQueueStatus SQLiteStore
st SndQueue
sq QueueStatus
Confirmed
  AgentClient -> SndQueue -> SenderPublicKey -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> SndQueue -> SenderPublicKey -> m ()
sendHello AgentClient
c SndQueue
sq SenderPublicKey
verifyKey
  (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 m' ())
-> m ()
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 m' a)
-> m a
withStore ((forall (m' :: * -> *).
  (MonadUnliftIO m', MonadError StoreError m') =>
  m' ())
 -> m ())
-> (forall (m' :: * -> *).
    (MonadUnliftIO m', MonadError StoreError m') =>
    m' ())
-> m ()
forall a b. (a -> b) -> a -> b
$ SQLiteStore -> SndQueue -> QueueStatus -> m' ()
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> SndQueue -> QueueStatus -> m ()
setSndQueueStatus SQLiteStore
st SndQueue
sq QueueStatus
Active

newSendQueue ::
  (MonadUnliftIO m, MonadReader Env m) => SMPQueueInfo -> ConnAlias -> m (SndQueue, SenderPublicKey, VerificationKey)
newSendQueue :: SMPQueueInfo
-> ByteString -> m (SndQueue, SenderPublicKey, SenderPublicKey)
newSendQueue (SMPQueueInfo SMPServer
smpServer ByteString
senderId SenderPublicKey
encryptKey) ByteString
connAlias = do
  Int
size <- (Env -> Int) -> m Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Env -> Int) -> m Int) -> (Env -> Int) -> m Int
forall a b. (a -> b) -> a -> b
$ AgentConfig -> Int
rsaKeySize (AgentConfig -> Int) -> (Env -> AgentConfig) -> Env -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> AgentConfig
config
  (SenderPublicKey
senderKey, SenderPrivateKey
sndPrivateKey) <- IO (SenderPublicKey, SenderPrivateKey)
-> m (SenderPublicKey, SenderPrivateKey)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (SenderPublicKey, SenderPrivateKey)
 -> m (SenderPublicKey, SenderPrivateKey))
-> IO (SenderPublicKey, SenderPrivateKey)
-> m (SenderPublicKey, SenderPrivateKey)
forall a b. (a -> b) -> a -> b
$ Int -> IO (SenderPublicKey, SenderPrivateKey)
forall k. PrivateKey k => Int -> IO (KeyPair k)
C.generateKeyPair Int
size
  (SenderPublicKey
verifyKey, SenderPrivateKey
signKey) <- IO (SenderPublicKey, SenderPrivateKey)
-> m (SenderPublicKey, SenderPrivateKey)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (SenderPublicKey, SenderPrivateKey)
 -> m (SenderPublicKey, SenderPrivateKey))
-> IO (SenderPublicKey, SenderPrivateKey)
-> m (SenderPublicKey, SenderPrivateKey)
forall a b. (a -> b) -> a -> b
$ Int -> IO (SenderPublicKey, SenderPrivateKey)
forall k. PrivateKey k => Int -> IO (KeyPair k)
C.generateKeyPair Int
size
  let sndQueue :: SndQueue
sndQueue =
        SndQueue :: SMPServer
-> ByteString
-> ByteString
-> SenderPrivateKey
-> SenderPublicKey
-> SenderPrivateKey
-> QueueStatus
-> SndQueue
SndQueue
          { $sel:server:SndQueue :: SMPServer
server = SMPServer
smpServer,
            $sel:sndId:SndQueue :: ByteString
sndId = ByteString
senderId,
            ByteString
$sel:connAlias:SndQueue :: ByteString
connAlias :: ByteString
connAlias,
            SenderPrivateKey
$sel:sndPrivateKey:SndQueue :: SenderPrivateKey
sndPrivateKey :: SenderPrivateKey
sndPrivateKey,
            SenderPublicKey
$sel:encryptKey:SndQueue :: SenderPublicKey
encryptKey :: SenderPublicKey
encryptKey,
            SenderPrivateKey
$sel:signKey:SndQueue :: SenderPrivateKey
signKey :: SenderPrivateKey
signKey,
            $sel:status:SndQueue :: QueueStatus
status = QueueStatus
New
          }
  (SndQueue, SenderPublicKey, SenderPublicKey)
-> m (SndQueue, SenderPublicKey, SenderPublicKey)
forall (m :: * -> *) a. Monad m => a -> m a
return (SndQueue
sndQueue, SenderPublicKey
senderKey, SenderPublicKey
verifyKey)