{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}

-- |
-- 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
  ( -- * SMP agent over TCP
    runSMPAgent,
    runSMPAgentBlocking,

    -- * queue-based SMP agent
    getAgentClient,
    runAgentClient,

    -- * SMP agent functional API
    AgentClient (..),
    AgentMonad,
    AgentErrorMonad,
    getSMPAgentClient,
    disconnectAgentClient, -- used in tests
    withAgentLock,
    createConnection,
    joinConnection,
    allowConnection,
    acceptContact,
    rejectContact,
    subscribeConnection,
    sendMessage,
    ackMessage,
    suspendConnection,
    deleteConnection,
  )
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.Bifunctor (second)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Composition ((.:), (.:.))
import Data.Functor (($>))
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as L
import qualified Data.Map.Strict as M
import Data.Maybe (isJust)
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.RetryInterval
import Simplex.Messaging.Agent.Store
import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore)
import Simplex.Messaging.Client (SMPServerTransmission)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Protocol (MsgBody, SenderPublicKey)
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Transport (ATransport (..), TProxy, Transport (..), currentSMPVersionStr, runTransportServer)
import Simplex.Messaging.Util (bshow, tryError, unlessM)
import System.Random (randomR)
import UnliftIO.Async (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' ()) -> (ByteString -> IO ()) -> ByteString -> m' ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> ByteString -> IO ()
forall c. Transport c => c -> ByteString -> IO ()
putLn c
h (ByteString -> m' ()) -> ByteString -> m' ()
forall a b. (a -> b) -> a -> b
$ ByteString
"Welcome to SMP agent v" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
currentSMPVersionStr
      AgentClient
c <- m' AgentClient
forall (m :: * -> *).
(MonadUnliftIO m, MonadReader Env m) =>
m AgentClient
getAgentClient
      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 ()
runAgentClient 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 ()
disconnectAgentClient AgentClient
c

-- | Creates an SMP agent client instance
getSMPAgentClient :: (MonadRandom m, MonadUnliftIO m) => AgentConfig -> m AgentClient
getSMPAgentClient :: AgentConfig -> m AgentClient
getSMPAgentClient AgentConfig
cfg = AgentConfig -> m Env
forall (m :: * -> *).
(MonadUnliftIO m, MonadRandom m) =>
AgentConfig -> m Env
newSMPAgentEnv AgentConfig
cfg m Env -> (Env -> m AgentClient) -> m AgentClient
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ReaderT Env m AgentClient -> Env -> m AgentClient
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT Env m AgentClient
runAgent
  where
    runAgent :: ReaderT Env m AgentClient
runAgent = do
      AgentClient
c <- ReaderT Env m AgentClient
forall (m :: * -> *).
(MonadUnliftIO m, MonadReader Env m) =>
m AgentClient
getAgentClient
      Async ()
action <- ReaderT Env m () -> ReaderT Env m (Async ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async (ReaderT Env m () -> ReaderT Env m (Async ()))
-> ReaderT Env m () -> ReaderT Env m (Async ())
forall a b. (a -> b) -> a -> b
$ AgentClient -> ReaderT Env m ()
forall (m :: * -> *).
(MonadUnliftIO m, MonadReader Env m) =>
AgentClient -> m ()
subscriber AgentClient
c ReaderT Env m () -> ReaderT Env m () -> ReaderT Env m ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`E.finally` AgentClient -> ReaderT Env m ()
forall (m :: * -> *). MonadUnliftIO m => AgentClient -> m ()
disconnectAgentClient AgentClient
c
      AgentClient -> ReaderT Env m AgentClient
forall (f :: * -> *) a. Applicative f => a -> f a
pure AgentClient
c {$sel:smpSubscriber:AgentClient :: Async ()
smpSubscriber = Async ()
action}

disconnectAgentClient :: MonadUnliftIO m => AgentClient -> m ()
disconnectAgentClient :: AgentClient -> m ()
disconnectAgentClient AgentClient
c = AgentClient -> m ()
forall (m :: * -> *). MonadUnliftIO m => AgentClient -> m ()
closeAgentClient 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

-- |
type AgentErrorMonad m = (MonadUnliftIO m, MonadError AgentErrorType m)

-- | Create SMP agent connection (NEW command)
createConnection :: AgentErrorMonad m => AgentClient -> SConnectionMode c -> m (ConnId, ConnectionRequest c)
createConnection :: AgentClient
-> SConnectionMode c -> m (ByteString, ConnectionRequest c)
createConnection AgentClient
c SConnectionMode c
cMode = AgentClient
-> ReaderT Env m (ByteString, ConnectionRequest c)
-> m (ByteString, ConnectionRequest c)
forall (m :: * -> *) a. AgentClient -> ReaderT Env m a -> m a
withAgentEnv AgentClient
c (ReaderT Env m (ByteString, ConnectionRequest c)
 -> m (ByteString, ConnectionRequest c))
-> ReaderT Env m (ByteString, ConnectionRequest c)
-> m (ByteString, ConnectionRequest c)
forall a b. (a -> b) -> a -> b
$ AgentClient
-> ByteString
-> SConnectionMode c
-> ReaderT Env m (ByteString, ConnectionRequest c)
forall (m :: * -> *) (c :: ConnectionMode).
AgentMonad m =>
AgentClient
-> ByteString
-> SConnectionMode c
-> m (ByteString, ConnectionRequest c)
newConn AgentClient
c ByteString
"" SConnectionMode c
cMode

-- | Join SMP agent connection (JOIN command)
joinConnection :: AgentErrorMonad m => AgentClient -> ConnectionRequest c -> ConnInfo -> m ConnId
joinConnection :: AgentClient -> ConnectionRequest c -> ByteString -> m ByteString
joinConnection AgentClient
c = AgentClient -> ReaderT Env m ByteString -> m ByteString
forall (m :: * -> *) a. AgentClient -> ReaderT Env m a -> m a
withAgentEnv AgentClient
c (ReaderT Env m ByteString -> m ByteString)
-> (ConnectionRequest c -> ByteString -> ReaderT Env m ByteString)
-> ConnectionRequest c
-> ByteString
-> m ByteString
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.: AgentClient
-> ByteString
-> ConnectionRequest c
-> ByteString
-> ReaderT Env m ByteString
forall (m :: * -> *) (c :: ConnectionMode).
AgentMonad m =>
AgentClient
-> ByteString -> ConnectionRequest c -> ByteString -> m ByteString
joinConn AgentClient
c ByteString
""

-- | Allow connection to continue after CONF notification (LET command)
allowConnection :: AgentErrorMonad m => AgentClient -> ConnId -> ConfirmationId -> ConnInfo -> m ()
allowConnection :: AgentClient -> ByteString -> ByteString -> ByteString -> m ()
allowConnection AgentClient
c = AgentClient -> ReaderT Env m () -> m ()
forall (m :: * -> *) a. AgentClient -> ReaderT Env m a -> m a
withAgentEnv AgentClient
c (ReaderT Env m () -> m ())
-> (ByteString -> ByteString -> ByteString -> ReaderT Env m ())
-> ByteString
-> ByteString
-> ByteString
-> m ()
forall d e a b c.
(d -> e) -> (a -> b -> c -> d) -> a -> b -> c -> e
.:. AgentClient
-> ByteString -> ByteString -> ByteString -> ReaderT Env m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> ByteString -> ByteString -> ByteString -> m ()
allowConnection' AgentClient
c

-- | Accept contact after REQ notification (ACPT command)
acceptContact :: AgentErrorMonad m => AgentClient -> ConfirmationId -> ConnInfo -> m ConnId
acceptContact :: AgentClient -> ByteString -> ByteString -> m ByteString
acceptContact AgentClient
c = AgentClient -> ReaderT Env m ByteString -> m ByteString
forall (m :: * -> *) a. AgentClient -> ReaderT Env m a -> m a
withAgentEnv AgentClient
c (ReaderT Env m ByteString -> m ByteString)
-> (ByteString -> ByteString -> ReaderT Env m ByteString)
-> ByteString
-> ByteString
-> m ByteString
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.: AgentClient
-> ByteString
-> ByteString
-> ByteString
-> ReaderT Env m ByteString
forall (m :: * -> *).
AgentMonad m =>
AgentClient
-> ByteString -> ByteString -> ByteString -> m ByteString
acceptContact' AgentClient
c ByteString
""

-- | Reject contact (RJCT command)
rejectContact :: AgentErrorMonad m => AgentClient -> ConnId -> ConfirmationId -> m ()
rejectContact :: AgentClient -> ByteString -> ByteString -> m ()
rejectContact AgentClient
c = AgentClient -> ReaderT Env m () -> m ()
forall (m :: * -> *) a. AgentClient -> ReaderT Env m a -> m a
withAgentEnv AgentClient
c (ReaderT Env m () -> m ())
-> (ByteString -> ByteString -> ReaderT Env m ())
-> ByteString
-> ByteString
-> m ()
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.: AgentClient -> ByteString -> ByteString -> ReaderT Env m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> ByteString -> ByteString -> m ()
rejectContact' AgentClient
c

-- | Subscribe to receive connection messages (SUB command)
subscribeConnection :: AgentErrorMonad m => AgentClient -> ConnId -> m ()
subscribeConnection :: AgentClient -> ByteString -> m ()
subscribeConnection AgentClient
c = AgentClient -> ReaderT Env m () -> m ()
forall (m :: * -> *) a. AgentClient -> ReaderT Env m a -> m a
withAgentEnv AgentClient
c (ReaderT Env m () -> m ())
-> (ByteString -> ReaderT Env m ()) -> ByteString -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient -> ByteString -> ReaderT Env m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> ByteString -> m ()
subscribeConnection' AgentClient
c

-- | Send message to the connection (SEND command)
sendMessage :: AgentErrorMonad m => AgentClient -> ConnId -> MsgBody -> m AgentMsgId
sendMessage :: AgentClient -> ByteString -> ByteString -> m AgentMsgId
sendMessage AgentClient
c = AgentClient -> ReaderT Env m AgentMsgId -> m AgentMsgId
forall (m :: * -> *) a. AgentClient -> ReaderT Env m a -> m a
withAgentEnv AgentClient
c (ReaderT Env m AgentMsgId -> m AgentMsgId)
-> (ByteString -> ByteString -> ReaderT Env m AgentMsgId)
-> ByteString
-> ByteString
-> m AgentMsgId
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.: AgentClient -> ByteString -> ByteString -> ReaderT Env m AgentMsgId
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> ByteString -> ByteString -> m AgentMsgId
sendMessage' AgentClient
c

ackMessage :: AgentErrorMonad m => AgentClient -> ConnId -> AgentMsgId -> m ()
ackMessage :: AgentClient -> ByteString -> AgentMsgId -> m ()
ackMessage AgentClient
c = AgentClient -> ReaderT Env m () -> m ()
forall (m :: * -> *) a. AgentClient -> ReaderT Env m a -> m a
withAgentEnv AgentClient
c (ReaderT Env m () -> m ())
-> (ByteString -> AgentMsgId -> ReaderT Env m ())
-> ByteString
-> AgentMsgId
-> m ()
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.: AgentClient -> ByteString -> AgentMsgId -> ReaderT Env m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> ByteString -> AgentMsgId -> m ()
ackMessage' AgentClient
c

-- | Suspend SMP agent connection (OFF command)
suspendConnection :: AgentErrorMonad m => AgentClient -> ConnId -> m ()
suspendConnection :: AgentClient -> ByteString -> m ()
suspendConnection AgentClient
c = AgentClient -> ReaderT Env m () -> m ()
forall (m :: * -> *) a. AgentClient -> ReaderT Env m a -> m a
withAgentEnv AgentClient
c (ReaderT Env m () -> m ())
-> (ByteString -> ReaderT Env m ()) -> ByteString -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient -> ByteString -> ReaderT Env m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> ByteString -> m ()
suspendConnection' AgentClient
c

-- | Delete SMP agent connection (DEL command)
deleteConnection :: AgentErrorMonad m => AgentClient -> ConnId -> m ()
deleteConnection :: AgentClient -> ByteString -> m ()
deleteConnection AgentClient
c = AgentClient -> ReaderT Env m () -> m ()
forall (m :: * -> *) a. AgentClient -> ReaderT Env m a -> m a
withAgentEnv AgentClient
c (ReaderT Env m () -> m ())
-> (ByteString -> ReaderT Env m ()) -> ByteString -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentClient -> ByteString -> ReaderT Env m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> ByteString -> m ()
deleteConnection' AgentClient
c

withAgentEnv :: AgentClient -> ReaderT Env m a -> m a
withAgentEnv :: AgentClient -> ReaderT Env m a -> m a
withAgentEnv AgentClient
c = (ReaderT Env m a -> Env -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` AgentClient -> Env
agentEnv AgentClient
c)

-- withAgentClient :: AgentErrorMonad m => AgentClient -> ReaderT Env m a -> m a
-- withAgentClient c = withAgentLock c . withAgentEnv c

-- | Creates an SMP agent client instance that receives commands and sends responses via 'TBQueue's.
getAgentClient :: (MonadUnliftIO m, MonadReader Env m) => m AgentClient
getAgentClient :: m AgentClient
getAgentClient = m Env
forall r (m :: * -> *). MonadReader r m => m r
ask m Env -> (Env -> m AgentClient) -> m AgentClient
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STM AgentClient -> m AgentClient
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM AgentClient -> m AgentClient)
-> (Env -> STM AgentClient) -> Env -> m AgentClient
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> STM AgentClient
newAgentClient

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 [Item [Text]
"client", Int -> Text
forall a. Show a => a -> Text
showText (AgentClient -> Int
clientId AgentClient
c), Text
Item [Text]
event, Item [Text]
"Agent"]

-- | Runs an SMP agent instance that receives commands and sends responses via 'TBQueue's.
runAgentClient :: (MonadUnliftIO m, MonadReader Env m) => AgentClient -> m ()
runAgentClient :: AgentClient -> m ()
runAgentClient AgentClient
c = m () -> m () -> m ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m ()
race_ (AgentClient -> m ()
forall (m :: * -> *).
(MonadUnliftIO m, MonadReader Env m) =>
AgentClient -> m ()
subscriber AgentClient
c) (AgentClient -> m ()
forall (m :: * -> *).
(MonadUnliftIO m, MonadReader Env m) =>
AgentClient -> m ()
client AgentClient
c)

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:subQ:AgentClient :: AgentClient -> TBQueue (ATransmission 'Agent)
subQ :: TBQueue (ATransmission 'Agent)
subQ} = 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
  (ByteString
corrId, ByteString
connId, Either AgentErrorType (ACommand 'Client)
cmdOrErr) <- SAParty 'Client
-> c
-> m (ByteString, 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 (ByteString
corrId, ByteString
connId, 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)
subQ (ByteString
corrId, ByteString
connId, 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)
subQ :: TBQueue (ATransmission 'Agent)
$sel:subQ:AgentClient :: AgentClient -> TBQueue (ATransmission 'Agent)
subQ} = 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)
subQ
  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 (ByteString
corrId, ByteString
connId, 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
Item [ByteString]
dir, Item [ByteString]
"A :", ByteString
Item [ByteString]
corrId, ByteString
Item [ByteString]
connId, (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 :: forall m. (MonadUnliftIO m, MonadReader Env m) => AgentClient -> m ()
client :: AgentClient -> m ()
client c :: AgentClient
c@AgentClient {TBQueue (ATransmission 'Client)
rcvQ :: TBQueue (ATransmission 'Client)
$sel:rcvQ:AgentClient :: AgentClient -> TBQueue (ATransmission 'Client)
rcvQ, TBQueue (ATransmission 'Agent)
subQ :: TBQueue (ATransmission 'Agent)
$sel:subQ:AgentClient :: AgentClient -> TBQueue (ATransmission 'Agent)
subQ} = 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
  (ByteString
corrId, ByteString
connId, ACommand 'Client
cmd) <- 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
  AgentClient
-> m (Either AgentErrorType (ByteString, ACommand 'Agent))
-> m (Either AgentErrorType (ByteString, ACommand 'Agent))
forall (m :: * -> *) a.
MonadUnliftIO m =>
AgentClient -> m a -> m a
withAgentLock AgentClient
c (ExceptT AgentErrorType m (ByteString, ACommand 'Agent)
-> m (Either AgentErrorType (ByteString, ACommand 'Agent))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT AgentErrorType m (ByteString, ACommand 'Agent)
 -> m (Either AgentErrorType (ByteString, ACommand 'Agent)))
-> ExceptT AgentErrorType m (ByteString, ACommand 'Agent)
-> m (Either AgentErrorType (ByteString, ACommand 'Agent))
forall a b. (a -> b) -> a -> b
$ AgentClient
-> (ByteString, ACommand 'Client)
-> ExceptT AgentErrorType m (ByteString, ACommand 'Agent)
forall (m :: * -> *).
AgentMonad m =>
AgentClient
-> (ByteString, ACommand 'Client)
-> m (ByteString, ACommand 'Agent)
processCommand AgentClient
c (ByteString
connId, ACommand 'Client
cmd))
    m (Either AgentErrorType (ByteString, ACommand 'Agent))
-> (Either AgentErrorType (ByteString, ACommand 'Agent) -> m ())
-> m ()
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 ())
-> (Either AgentErrorType (ByteString, ACommand 'Agent) -> STM ())
-> Either AgentErrorType (ByteString, ACommand 'Agent)
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TBQueue (ATransmission 'Agent) -> ATransmission 'Agent -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue (ATransmission 'Agent)
subQ (ATransmission 'Agent -> STM ())
-> (Either AgentErrorType (ByteString, ACommand 'Agent)
    -> ATransmission 'Agent)
-> Either AgentErrorType (ByteString, ACommand 'Agent)
-> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      Left AgentErrorType
e -> (ByteString
corrId, ByteString
connId, AgentErrorType -> ACommand 'Agent
ERR AgentErrorType
e)
      Right (ByteString
connId', ACommand 'Agent
resp) -> (ByteString
corrId, ByteString
connId', ACommand 'Agent
resp)

withStore ::
  AgentMonad m =>
  (forall m'. (MonadUnliftIO m', MonadError StoreError m') => SQLiteStore -> m' a) ->
  m a
withStore :: (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' a)
-> m a
withStore forall (m' :: * -> *).
(MonadUnliftIO m', MonadError StoreError m') =>
SQLiteStore -> m' a
action = do
  SQLiteStore
st <- (Env -> SQLiteStore) -> m SQLiteStore
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> SQLiteStore
store
  ExceptT StoreError m a -> m (Either StoreError a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (SQLiteStore -> ExceptT StoreError m a
forall (m' :: * -> *).
(MonadUnliftIO m', MonadError StoreError m') =>
SQLiteStore -> m' a
action SQLiteStore
st 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
    -- TODO when parsing exception happens in store, the agent hangs;
    -- changing SQLError to SomeException does not help
    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
NOT_FOUND
      StoreError
SEConnDuplicate -> ConnectionErrorType -> AgentErrorType
CONN ConnectionErrorType
DUPLICATE
      SEBadConnType ConnType
CRcv -> ConnectionErrorType -> AgentErrorType
CONN ConnectionErrorType
SIMPLEX
      SEBadConnType ConnType
CSnd -> ConnectionErrorType -> AgentErrorType
CONN ConnectionErrorType
SIMPLEX
      StoreError
SEInvitationNotFound -> CommandErrorType -> AgentErrorType
CMD CommandErrorType
PROHIBITED
      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

-- | execute any SMP agent command
processCommand :: forall m. AgentMonad m => AgentClient -> (ConnId, ACommand 'Client) -> m (ConnId, ACommand 'Agent)
processCommand :: AgentClient
-> (ByteString, ACommand 'Client)
-> m (ByteString, ACommand 'Agent)
processCommand AgentClient
c (ByteString
connId, ACommand 'Client
cmd) = case ACommand 'Client
cmd of
  NEW (ACM SConnectionMode m
cMode) -> (ConnectionRequest m -> ACommand 'Agent)
-> (ByteString, ConnectionRequest m)
-> (ByteString, ACommand 'Agent)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (AConnectionRequest -> ACommand 'Agent
INV (AConnectionRequest -> ACommand 'Agent)
-> (ConnectionRequest m -> AConnectionRequest)
-> ConnectionRequest m
-> ACommand 'Agent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SConnectionMode m -> ConnectionRequest m -> AConnectionRequest
forall (m :: ConnectionMode).
SConnectionMode m -> ConnectionRequest m -> AConnectionRequest
ACR SConnectionMode m
cMode) ((ByteString, ConnectionRequest m)
 -> (ByteString, ACommand 'Agent))
-> m (ByteString, ConnectionRequest m)
-> m (ByteString, ACommand 'Agent)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AgentClient
-> ByteString
-> SConnectionMode m
-> m (ByteString, ConnectionRequest m)
forall (m :: * -> *) (c :: ConnectionMode).
AgentMonad m =>
AgentClient
-> ByteString
-> SConnectionMode c
-> m (ByteString, ConnectionRequest c)
newConn AgentClient
c ByteString
connId SConnectionMode m
cMode
  JOIN (ACR SConnectionMode m
_ ConnectionRequest m
cReq) ByteString
connInfo -> (,ACommand 'Agent
OK) (ByteString -> (ByteString, ACommand 'Agent))
-> m ByteString -> m (ByteString, ACommand 'Agent)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AgentClient
-> ByteString -> ConnectionRequest m -> ByteString -> m ByteString
forall (m :: * -> *) (c :: ConnectionMode).
AgentMonad m =>
AgentClient
-> ByteString -> ConnectionRequest c -> ByteString -> m ByteString
joinConn AgentClient
c ByteString
connId ConnectionRequest m
cReq ByteString
connInfo
  LET ByteString
confId ByteString
ownCInfo -> AgentClient -> ByteString -> ByteString -> ByteString -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> ByteString -> ByteString -> ByteString -> m ()
allowConnection' AgentClient
c ByteString
connId ByteString
confId ByteString
ownCInfo m ()
-> (ByteString, ACommand 'Agent) -> m (ByteString, ACommand 'Agent)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (ByteString
connId, ACommand 'Agent
OK)
  ACPT ByteString
invId ByteString
ownCInfo -> (,ACommand 'Agent
OK) (ByteString -> (ByteString, ACommand 'Agent))
-> m ByteString -> m (ByteString, ACommand 'Agent)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AgentClient
-> ByteString -> ByteString -> ByteString -> m ByteString
forall (m :: * -> *).
AgentMonad m =>
AgentClient
-> ByteString -> ByteString -> ByteString -> m ByteString
acceptContact' AgentClient
c ByteString
connId ByteString
invId ByteString
ownCInfo
  RJCT ByteString
invId -> AgentClient -> ByteString -> ByteString -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> ByteString -> ByteString -> m ()
rejectContact' AgentClient
c ByteString
connId ByteString
invId m ()
-> (ByteString, ACommand 'Agent) -> m (ByteString, ACommand 'Agent)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (ByteString
connId, ACommand 'Agent
OK)
  ACommand 'Client
SUB -> AgentClient -> ByteString -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> ByteString -> m ()
subscribeConnection' AgentClient
c ByteString
connId m ()
-> (ByteString, ACommand 'Agent) -> m (ByteString, ACommand 'Agent)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (ByteString
connId, ACommand 'Agent
OK)
  SEND ByteString
msgBody -> (ByteString
connId,) (ACommand 'Agent -> (ByteString, ACommand 'Agent))
-> (AgentMsgId -> ACommand 'Agent)
-> AgentMsgId
-> (ByteString, ACommand 'Agent)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AgentMsgId -> ACommand 'Agent
MID (AgentMsgId -> (ByteString, ACommand 'Agent))
-> m AgentMsgId -> m (ByteString, ACommand 'Agent)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AgentClient -> ByteString -> ByteString -> m AgentMsgId
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> ByteString -> ByteString -> m AgentMsgId
sendMessage' AgentClient
c ByteString
connId ByteString
msgBody
  ACK AgentMsgId
msgId -> AgentClient -> ByteString -> AgentMsgId -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> ByteString -> AgentMsgId -> m ()
ackMessage' AgentClient
c ByteString
connId AgentMsgId
msgId m ()
-> (ByteString, ACommand 'Agent) -> m (ByteString, ACommand 'Agent)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (ByteString
connId, ACommand 'Agent
OK)
  ACommand 'Client
OFF -> AgentClient -> ByteString -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> ByteString -> m ()
suspendConnection' AgentClient
c ByteString
connId m ()
-> (ByteString, ACommand 'Agent) -> m (ByteString, ACommand 'Agent)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (ByteString
connId, ACommand 'Agent
OK)
  ACommand 'Client
DEL -> AgentClient -> ByteString -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> ByteString -> m ()
deleteConnection' AgentClient
c ByteString
connId m ()
-> (ByteString, ACommand 'Agent) -> m (ByteString, ACommand 'Agent)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (ByteString
connId, ACommand 'Agent
OK)

newConn :: AgentMonad m => AgentClient -> ConnId -> SConnectionMode c -> m (ConnId, ConnectionRequest c)
newConn :: AgentClient
-> ByteString
-> SConnectionMode c
-> m (ByteString, ConnectionRequest c)
newConn AgentClient
c ByteString
connId SConnectionMode c
cMode = do
  SMPServer
srv <- m SMPServer
forall (m :: * -> *). AgentMonad m => m SMPServer
getSMPServer
  (RcvQueue
rq, SMPQueueUri
qUri, EncryptionKey
encryptKey) <- AgentClient
-> SMPServer -> m (RcvQueue, SMPQueueUri, EncryptionKey)
forall (m :: * -> *).
AgentMonad m =>
AgentClient
-> SMPServer -> m (RcvQueue, SMPQueueUri, EncryptionKey)
newRcvQueue AgentClient
c SMPServer
srv
  TVar ChaChaDRG
g <- (Env -> TVar ChaChaDRG) -> m (TVar ChaChaDRG)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> TVar ChaChaDRG
idsDrg
  let cData :: ConnData
cData = ConnData :: ByteString -> ConnData
ConnData {ByteString
$sel:connId:ConnData :: ByteString
connId :: ByteString
connId}
  ByteString
connId' <- (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' ByteString)
-> m ByteString
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' a)
-> m a
withStore ((forall (m' :: * -> *).
  (MonadUnliftIO m', MonadError StoreError m') =>
  SQLiteStore -> m' ByteString)
 -> m ByteString)
-> (forall (m' :: * -> *).
    (MonadUnliftIO m', MonadError StoreError m') =>
    SQLiteStore -> m' ByteString)
-> m ByteString
forall a b. (a -> b) -> a -> b
$ \SQLiteStore
st -> SQLiteStore
-> TVar ChaChaDRG
-> ConnData
-> RcvQueue
-> SConnectionMode c
-> m' ByteString
forall s (m :: * -> *) (c :: ConnectionMode).
MonadAgentStore s m =>
s
-> TVar ChaChaDRG
-> ConnData
-> RcvQueue
-> SConnectionMode c
-> m ByteString
createRcvConn SQLiteStore
st TVar ChaChaDRG
g ConnData
cData RcvQueue
rq SConnectionMode c
cMode
  AgentClient -> RcvQueue -> ByteString -> m ()
forall (m :: * -> *).
MonadUnliftIO m =>
AgentClient -> RcvQueue -> ByteString -> m ()
addSubscription AgentClient
c RcvQueue
rq ByteString
connId'
  let crData :: ConnReqData
crData = ConnReqScheme
-> NonEmpty SMPQueueUri -> EncryptionKey -> ConnReqData
ConnReqData ConnReqScheme
simplexChat [Item (NonEmpty SMPQueueUri)
SMPQueueUri
qUri] EncryptionKey
encryptKey
  (ByteString, ConnectionRequest c)
-> m (ByteString, ConnectionRequest c)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((ByteString, ConnectionRequest c)
 -> m (ByteString, ConnectionRequest c))
-> (ConnectionRequest c -> (ByteString, ConnectionRequest c))
-> ConnectionRequest c
-> m (ByteString, ConnectionRequest c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString
connId',) (ConnectionRequest c -> m (ByteString, ConnectionRequest c))
-> ConnectionRequest c -> m (ByteString, ConnectionRequest c)
forall a b. (a -> b) -> a -> b
$ case SConnectionMode c
cMode of
    SConnectionMode c
SCMInvitation -> ConnReqData -> ConnectionRequest 'CMInvitation
CRInvitation ConnReqData
crData
    SConnectionMode c
SCMContact -> ConnReqData -> ConnectionRequest 'CMContact
CRContact ConnReqData
crData

joinConn :: AgentMonad m => AgentClient -> ConnId -> ConnectionRequest c -> ConnInfo -> m ConnId
joinConn :: AgentClient
-> ByteString -> ConnectionRequest c -> ByteString -> m ByteString
joinConn AgentClient
c ByteString
connId (CRInvitation (ConnReqData ConnReqScheme
_ (SMPQueueUri
qUri :| [SMPQueueUri]
_) EncryptionKey
encryptKey)) ByteString
cInfo = do
  (SndQueue
sq, EncryptionKey
senderKey, EncryptionKey
verifyKey) <- SMPQueueUri
-> EncryptionKey -> m (SndQueue, EncryptionKey, EncryptionKey)
forall (m :: * -> *).
(MonadUnliftIO m, MonadReader Env m) =>
SMPQueueUri
-> EncryptionKey -> m (SndQueue, EncryptionKey, EncryptionKey)
newSndQueue SMPQueueUri
qUri EncryptionKey
encryptKey
  TVar ChaChaDRG
g <- (Env -> TVar ChaChaDRG) -> m (TVar ChaChaDRG)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> TVar ChaChaDRG
idsDrg
  AgentConfig
cfg <- (Env -> AgentConfig) -> m AgentConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> AgentConfig
config
  let cData :: ConnData
cData = ConnData :: ByteString -> ConnData
ConnData {ByteString
connId :: ByteString
$sel:connId:ConnData :: ByteString
connId}
  ByteString
connId' <- (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' ByteString)
-> m ByteString
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' a)
-> m a
withStore ((forall (m' :: * -> *).
  (MonadUnliftIO m', MonadError StoreError m') =>
  SQLiteStore -> m' ByteString)
 -> m ByteString)
-> (forall (m' :: * -> *).
    (MonadUnliftIO m', MonadError StoreError m') =>
    SQLiteStore -> m' ByteString)
-> m ByteString
forall a b. (a -> b) -> a -> b
$ \SQLiteStore
st -> SQLiteStore
-> TVar ChaChaDRG -> ConnData -> SndQueue -> m' ByteString
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> TVar ChaChaDRG -> ConnData -> SndQueue -> m ByteString
createSndConn SQLiteStore
st TVar ChaChaDRG
g ConnData
cData SndQueue
sq
  AgentClient -> SndQueue -> EncryptionKey -> ByteString -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> SndQueue -> EncryptionKey -> ByteString -> m ()
confirmQueue AgentClient
c SndQueue
sq EncryptionKey
senderKey ByteString
cInfo
  AgentClient
-> ByteString -> SndQueue -> EncryptionKey -> RetryInterval -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient
-> ByteString -> SndQueue -> EncryptionKey -> RetryInterval -> m ()
activateQueueJoining AgentClient
c ByteString
connId' SndQueue
sq EncryptionKey
verifyKey (RetryInterval -> m ()) -> RetryInterval -> m ()
forall a b. (a -> b) -> a -> b
$ AgentConfig -> RetryInterval
retryInterval AgentConfig
cfg
  ByteString -> m ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
connId'
joinConn AgentClient
c ByteString
connId (CRContact (ConnReqData ConnReqScheme
_ (SMPQueueUri
qUri :| [SMPQueueUri]
_) EncryptionKey
encryptKey)) ByteString
cInfo = do
  (ByteString
connId', ConnectionRequest 'CMInvitation
cReq) <- AgentClient
-> ByteString
-> SConnectionMode 'CMInvitation
-> m (ByteString, ConnectionRequest 'CMInvitation)
forall (m :: * -> *) (c :: ConnectionMode).
AgentMonad m =>
AgentClient
-> ByteString
-> SConnectionMode c
-> m (ByteString, ConnectionRequest c)
newConn AgentClient
c ByteString
connId SConnectionMode 'CMInvitation
SCMInvitation
  AgentClient
-> SMPQueueUri
-> EncryptionKey
-> ConnectionRequest 'CMInvitation
-> ByteString
-> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient
-> SMPQueueUri
-> EncryptionKey
-> ConnectionRequest 'CMInvitation
-> ByteString
-> m ()
sendInvitation AgentClient
c SMPQueueUri
qUri EncryptionKey
encryptKey ConnectionRequest 'CMInvitation
cReq ByteString
cInfo
  ByteString -> m ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
connId'

activateQueueJoining :: forall m. AgentMonad m => AgentClient -> ConnId -> SndQueue -> VerificationKey -> RetryInterval -> m ()
activateQueueJoining :: AgentClient
-> ByteString -> SndQueue -> EncryptionKey -> RetryInterval -> m ()
activateQueueJoining AgentClient
c ByteString
connId SndQueue
sq EncryptionKey
verifyKey RetryInterval
retryInterval =
  AgentClient
-> ByteString
-> SndQueue
-> EncryptionKey
-> RetryInterval
-> m ()
-> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient
-> ByteString
-> SndQueue
-> EncryptionKey
-> RetryInterval
-> m ()
-> m ()
activateQueue AgentClient
c ByteString
connId SndQueue
sq EncryptionKey
verifyKey RetryInterval
retryInterval m ()
createReplyQueue
  where
    createReplyQueue :: m ()
    createReplyQueue :: m ()
createReplyQueue = do
      SMPServer
srv <- m SMPServer
forall (m :: * -> *). AgentMonad m => m SMPServer
getSMPServer
      (RcvQueue
rq, SMPQueueUri
qUri', EncryptionKey
encryptKey) <- AgentClient
-> SMPServer -> m (RcvQueue, SMPQueueUri, EncryptionKey)
forall (m :: * -> *).
AgentMonad m =>
AgentClient
-> SMPServer -> m (RcvQueue, SMPQueueUri, EncryptionKey)
newRcvQueue AgentClient
c SMPServer
srv
      AgentClient -> RcvQueue -> ByteString -> m ()
forall (m :: * -> *).
MonadUnliftIO m =>
AgentClient -> RcvQueue -> ByteString -> m ()
addSubscription AgentClient
c RcvQueue
rq ByteString
connId
      (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' ())
-> m ()
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' a)
-> m a
withStore ((forall (m' :: * -> *).
  (MonadUnliftIO m', MonadError StoreError m') =>
  SQLiteStore -> m' ())
 -> m ())
-> (forall (m' :: * -> *).
    (MonadUnliftIO m', MonadError StoreError m') =>
    SQLiteStore -> m' ())
-> m ()
forall a b. (a -> b) -> a -> b
$ \SQLiteStore
st -> SQLiteStore -> ByteString -> RcvQueue -> m' ()
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> ByteString -> RcvQueue -> m ()
upgradeSndConnToDuplex SQLiteStore
st ByteString
connId RcvQueue
rq
      AgentClient -> SndQueue -> AMessage -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> SndQueue -> AMessage -> m ()
sendControlMessage AgentClient
c SndQueue
sq (AMessage -> m ())
-> (ConnectionRequest 'CMInvitation -> AMessage)
-> ConnectionRequest 'CMInvitation
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnectionRequest 'CMInvitation -> AMessage
REPLY (ConnectionRequest 'CMInvitation -> m ())
-> ConnectionRequest 'CMInvitation -> m ()
forall a b. (a -> b) -> a -> b
$ ConnReqData -> ConnectionRequest 'CMInvitation
CRInvitation (ConnReqData -> ConnectionRequest 'CMInvitation)
-> ConnReqData -> ConnectionRequest 'CMInvitation
forall a b. (a -> b) -> a -> b
$ ConnReqScheme
-> NonEmpty SMPQueueUri -> EncryptionKey -> ConnReqData
ConnReqData ConnReqScheme
CRSSimplex [Item (NonEmpty SMPQueueUri)
SMPQueueUri
qUri'] EncryptionKey
encryptKey

-- | Approve confirmation (LET command) in Reader monad
allowConnection' :: AgentMonad m => AgentClient -> ConnId -> ConfirmationId -> ConnInfo -> m ()
allowConnection' :: AgentClient -> ByteString -> ByteString -> ByteString -> m ()
allowConnection' AgentClient
c ByteString
connId ByteString
confId ByteString
ownConnInfo = do
  (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' SomeConn)
-> m SomeConn
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' a)
-> m a
withStore (SQLiteStore -> ByteString -> m' SomeConn
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> ByteString -> m SomeConn
`getConn` ByteString
connId) m SomeConn -> (SomeConn -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    SomeConn SConnType d
_ (RcvConnection ConnData
_ RcvQueue
rq) -> do
      AcceptedConfirmation {EncryptionKey
$sel:senderKey:AcceptedConfirmation :: AcceptedConfirmation -> EncryptionKey
senderKey :: EncryptionKey
senderKey} <- (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' AcceptedConfirmation)
-> m AcceptedConfirmation
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' a)
-> m a
withStore ((forall (m' :: * -> *).
  (MonadUnliftIO m', MonadError StoreError m') =>
  SQLiteStore -> m' AcceptedConfirmation)
 -> m AcceptedConfirmation)
-> (forall (m' :: * -> *).
    (MonadUnliftIO m', MonadError StoreError m') =>
    SQLiteStore -> m' AcceptedConfirmation)
-> m AcceptedConfirmation
forall a b. (a -> b) -> a -> b
$ \SQLiteStore
st -> SQLiteStore -> ByteString -> ByteString -> m' AcceptedConfirmation
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> ByteString -> ByteString -> m AcceptedConfirmation
acceptConfirmation SQLiteStore
st ByteString
confId ByteString
ownConnInfo
      AgentClient -> RcvQueue -> EncryptionKey -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> RcvQueue -> EncryptionKey -> m ()
processConfirmation AgentClient
c RcvQueue
rq EncryptionKey
senderKey
    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
$ CommandErrorType -> AgentErrorType
CMD CommandErrorType
PROHIBITED

-- | Accept contact (ACPT command) in Reader monad
acceptContact' :: AgentMonad m => AgentClient -> ConnId -> InvitationId -> ConnInfo -> m ConnId
acceptContact' :: AgentClient
-> ByteString -> ByteString -> ByteString -> m ByteString
acceptContact' AgentClient
c ByteString
connId ByteString
invId ByteString
ownConnInfo = do
  Invitation {ByteString
$sel:contactConnId:Invitation :: Invitation -> ByteString
contactConnId :: ByteString
contactConnId, ConnectionRequest 'CMInvitation
$sel:connReq:Invitation :: Invitation -> ConnectionRequest 'CMInvitation
connReq :: ConnectionRequest 'CMInvitation
connReq} <- (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' Invitation)
-> m Invitation
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' a)
-> m a
withStore (SQLiteStore -> ByteString -> m' Invitation
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> ByteString -> m Invitation
`getInvitation` ByteString
invId)
  (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' SomeConn)
-> m SomeConn
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' a)
-> m a
withStore (SQLiteStore -> ByteString -> m' SomeConn
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> ByteString -> m SomeConn
`getConn` ByteString
contactConnId) m SomeConn -> (SomeConn -> m ByteString) -> m ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    SomeConn SConnType d
_ ContactConnection {} -> do
      (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' ())
-> m ()
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' a)
-> m a
withStore ((forall (m' :: * -> *).
  (MonadUnliftIO m', MonadError StoreError m') =>
  SQLiteStore -> m' ())
 -> m ())
-> (forall (m' :: * -> *).
    (MonadUnliftIO m', MonadError StoreError m') =>
    SQLiteStore -> m' ())
-> m ()
forall a b. (a -> b) -> a -> b
$ \SQLiteStore
st -> SQLiteStore -> ByteString -> ByteString -> m' ()
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> ByteString -> ByteString -> m ()
acceptInvitation SQLiteStore
st ByteString
invId ByteString
ownConnInfo
      AgentClient
-> ByteString
-> ConnectionRequest 'CMInvitation
-> ByteString
-> m ByteString
forall (m :: * -> *) (c :: ConnectionMode).
AgentMonad m =>
AgentClient
-> ByteString -> ConnectionRequest c -> ByteString -> m ByteString
joinConn AgentClient
c ByteString
connId ConnectionRequest 'CMInvitation
connReq ByteString
ownConnInfo
    SomeConn
_ -> AgentErrorType -> m ByteString
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (AgentErrorType -> m ByteString) -> AgentErrorType -> m ByteString
forall a b. (a -> b) -> a -> b
$ CommandErrorType -> AgentErrorType
CMD CommandErrorType
PROHIBITED

-- | Reject contact (RJCT command) in Reader monad
rejectContact' :: AgentMonad m => AgentClient -> ConnId -> InvitationId -> m ()
rejectContact' :: AgentClient -> ByteString -> ByteString -> m ()
rejectContact' AgentClient
_ ByteString
contactConnId ByteString
invId =
  (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' ())
-> m ()
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' a)
-> m a
withStore ((forall (m' :: * -> *).
  (MonadUnliftIO m', MonadError StoreError m') =>
  SQLiteStore -> m' ())
 -> m ())
-> (forall (m' :: * -> *).
    (MonadUnliftIO m', MonadError StoreError m') =>
    SQLiteStore -> m' ())
-> m ()
forall a b. (a -> b) -> a -> b
$ \SQLiteStore
st -> SQLiteStore -> ByteString -> ByteString -> m' ()
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> ByteString -> ByteString -> m ()
deleteInvitation SQLiteStore
st ByteString
contactConnId ByteString
invId

processConfirmation :: AgentMonad m => AgentClient -> RcvQueue -> SenderPublicKey -> m ()
processConfirmation :: AgentClient -> RcvQueue -> EncryptionKey -> m ()
processConfirmation AgentClient
c RcvQueue
rq EncryptionKey
sndKey = do
  (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' ())
-> m ()
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' a)
-> m a
withStore ((forall (m' :: * -> *).
  (MonadUnliftIO m', MonadError StoreError m') =>
  SQLiteStore -> m' ())
 -> m ())
-> (forall (m' :: * -> *).
    (MonadUnliftIO m', MonadError StoreError m') =>
    SQLiteStore -> m' ())
-> m ()
forall a b. (a -> b) -> a -> b
$ \SQLiteStore
st -> SQLiteStore -> RcvQueue -> QueueStatus -> m' ()
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> RcvQueue -> QueueStatus -> m ()
setRcvQueueStatus SQLiteStore
st RcvQueue
rq QueueStatus
Confirmed
  AgentClient -> RcvQueue -> EncryptionKey -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> RcvQueue -> EncryptionKey -> m ()
secureQueue AgentClient
c RcvQueue
rq EncryptionKey
sndKey
  (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' ())
-> m ()
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' a)
-> m a
withStore ((forall (m' :: * -> *).
  (MonadUnliftIO m', MonadError StoreError m') =>
  SQLiteStore -> m' ())
 -> m ())
-> (forall (m' :: * -> *).
    (MonadUnliftIO m', MonadError StoreError m') =>
    SQLiteStore -> m' ())
-> m ()
forall a b. (a -> b) -> a -> b
$ \SQLiteStore
st -> SQLiteStore -> RcvQueue -> QueueStatus -> m' ()
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> RcvQueue -> QueueStatus -> m ()
setRcvQueueStatus SQLiteStore
st RcvQueue
rq QueueStatus
Secured

-- | Subscribe to receive connection messages (SUB command) in Reader monad
subscribeConnection' :: forall m. AgentMonad m => AgentClient -> ConnId -> m ()
subscribeConnection' :: AgentClient -> ByteString -> m ()
subscribeConnection' AgentClient
c ByteString
connId =
  (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' SomeConn)
-> m SomeConn
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' a)
-> m a
withStore (SQLiteStore -> ByteString -> m' SomeConn
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> ByteString -> m SomeConn
`getConn` ByteString
connId) m SomeConn -> (SomeConn -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    SomeConn SConnType d
_ (DuplexConnection ConnData
_ RcvQueue
rq SndQueue
sq) -> do
      AgentClient -> ByteString -> SndQueue -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> ByteString -> SndQueue -> m ()
resumeMsgDelivery AgentClient
c ByteString
connId SndQueue
sq
      case SndQueue -> QueueStatus
status (SndQueue
sq :: SndQueue) of
        QueueStatus
Confirmed -> SndQueue -> (EncryptionKey -> m ()) -> m ()
withVerifyKey SndQueue
sq ((EncryptionKey -> m ()) -> m ())
-> (EncryptionKey -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \EncryptionKey
verifyKey -> do
          AcceptedConfirmation
conf <- (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' AcceptedConfirmation)
-> m AcceptedConfirmation
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' a)
-> m a
withStore (SQLiteStore -> ByteString -> m' AcceptedConfirmation
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> ByteString -> m AcceptedConfirmation
`getAcceptedConfirmation` ByteString
connId)
          AgentClient -> RcvQueue -> EncryptionKey -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> RcvQueue -> EncryptionKey -> m ()
secureQueue AgentClient
c RcvQueue
rq (EncryptionKey -> m ()) -> EncryptionKey -> m ()
forall a b. (a -> b) -> a -> b
$ AcceptedConfirmation -> EncryptionKey
senderKey (AcceptedConfirmation
conf :: AcceptedConfirmation)
          (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' ())
-> m ()
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' a)
-> m a
withStore ((forall (m' :: * -> *).
  (MonadUnliftIO m', MonadError StoreError m') =>
  SQLiteStore -> m' ())
 -> m ())
-> (forall (m' :: * -> *).
    (MonadUnliftIO m', MonadError StoreError m') =>
    SQLiteStore -> m' ())
-> m ()
forall a b. (a -> b) -> a -> b
$ \SQLiteStore
st -> SQLiteStore -> RcvQueue -> QueueStatus -> m' ()
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> RcvQueue -> QueueStatus -> m ()
setRcvQueueStatus SQLiteStore
st RcvQueue
rq QueueStatus
Secured
          RcvQueue -> SndQueue -> EncryptionKey -> m ()
activateSecuredQueue RcvQueue
rq SndQueue
sq EncryptionKey
verifyKey
        QueueStatus
Secured -> SndQueue -> (EncryptionKey -> m ()) -> m ()
withVerifyKey SndQueue
sq ((EncryptionKey -> m ()) -> m ())
-> (EncryptionKey -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ RcvQueue -> SndQueue -> EncryptionKey -> m ()
activateSecuredQueue RcvQueue
rq SndQueue
sq
        QueueStatus
Active -> AgentClient -> RcvQueue -> ByteString -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> RcvQueue -> ByteString -> m ()
subscribeQueue AgentClient
c RcvQueue
rq ByteString
connId
        QueueStatus
_ -> AgentErrorType -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (AgentErrorType -> m ()) -> AgentErrorType -> m ()
forall a b. (a -> b) -> a -> b
$ ServiceName -> AgentErrorType
INTERNAL ServiceName
"unexpected queue status"
    SomeConn SConnType d
_ (SndConnection ConnData
_ SndQueue
sq) -> do
      AgentClient -> ByteString -> SndQueue -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> ByteString -> SndQueue -> m ()
resumeMsgDelivery AgentClient
c ByteString
connId SndQueue
sq
      case SndQueue -> QueueStatus
status (SndQueue
sq :: SndQueue) of
        QueueStatus
Confirmed -> SndQueue -> (EncryptionKey -> m ()) -> m ()
withVerifyKey SndQueue
sq ((EncryptionKey -> m ()) -> m ())
-> (EncryptionKey -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \EncryptionKey
verifyKey ->
          AgentClient
-> ByteString -> SndQueue -> EncryptionKey -> RetryInterval -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient
-> ByteString -> SndQueue -> EncryptionKey -> RetryInterval -> m ()
activateQueueJoining AgentClient
c ByteString
connId SndQueue
sq EncryptionKey
verifyKey (RetryInterval -> m ()) -> m RetryInterval -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m RetryInterval
resumeInterval
        QueueStatus
Active -> 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
        QueueStatus
_ -> AgentErrorType -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (AgentErrorType -> m ()) -> AgentErrorType -> m ()
forall a b. (a -> b) -> a -> b
$ ServiceName -> AgentErrorType
INTERNAL ServiceName
"unexpected queue status"
    SomeConn SConnType d
_ (RcvConnection ConnData
_ RcvQueue
rq) -> AgentClient -> RcvQueue -> ByteString -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> RcvQueue -> ByteString -> m ()
subscribeQueue AgentClient
c RcvQueue
rq ByteString
connId
    SomeConn SConnType d
_ (ContactConnection ConnData
_ RcvQueue
rq) -> AgentClient -> RcvQueue -> ByteString -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> RcvQueue -> ByteString -> m ()
subscribeQueue AgentClient
c RcvQueue
rq ByteString
connId
  where
    withVerifyKey :: SndQueue -> (C.PublicKey -> m ()) -> m ()
    withVerifyKey :: SndQueue -> (EncryptionKey -> m ()) -> m ()
withVerifyKey SndQueue
sq EncryptionKey -> m ()
action =
      let err :: m a
err = 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
$ ServiceName -> AgentErrorType
INTERNAL ServiceName
"missing signing key public counterpart"
       in m () -> (EncryptionKey -> m ()) -> Maybe EncryptionKey -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m ()
forall a. m a
err EncryptionKey -> m ()
action (Maybe EncryptionKey -> m ())
-> (SignatureKey -> Maybe EncryptionKey) -> SignatureKey -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SignatureKey -> Maybe EncryptionKey
forall k. PrivateKey k => k -> Maybe EncryptionKey
C.publicKey (SignatureKey -> m ()) -> SignatureKey -> m ()
forall a b. (a -> b) -> a -> b
$ SndQueue -> SignatureKey
signKey SndQueue
sq
    activateSecuredQueue :: RcvQueue -> SndQueue -> C.PublicKey -> m ()
    activateSecuredQueue :: RcvQueue -> SndQueue -> EncryptionKey -> m ()
activateSecuredQueue RcvQueue
rq SndQueue
sq EncryptionKey
verifyKey = do
      AgentClient
-> ByteString -> SndQueue -> EncryptionKey -> RetryInterval -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient
-> ByteString -> SndQueue -> EncryptionKey -> RetryInterval -> m ()
activateQueueInitiating AgentClient
c ByteString
connId SndQueue
sq EncryptionKey
verifyKey (RetryInterval -> m ()) -> m RetryInterval -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m RetryInterval
resumeInterval
      AgentClient -> RcvQueue -> ByteString -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> RcvQueue -> ByteString -> m ()
subscribeQueue AgentClient
c RcvQueue
rq ByteString
connId
    resumeInterval :: m RetryInterval
    resumeInterval :: m RetryInterval
resumeInterval = do
      RetryInterval
r <- (Env -> RetryInterval) -> m RetryInterval
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Env -> RetryInterval) -> m RetryInterval)
-> (Env -> RetryInterval) -> m RetryInterval
forall a b. (a -> b) -> a -> b
$ AgentConfig -> RetryInterval
retryInterval (AgentConfig -> RetryInterval)
-> (Env -> AgentConfig) -> Env -> RetryInterval
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> AgentConfig
config
      RetryInterval -> m RetryInterval
forall (f :: * -> *) a. Applicative f => a -> f a
pure RetryInterval
r {initialInterval :: Int
initialInterval = Int
5_000_000}

-- | Send message to the connection (SEND command) in Reader monad
sendMessage' :: forall m. AgentMonad m => AgentClient -> ConnId -> MsgBody -> m AgentMsgId
sendMessage' :: AgentClient -> ByteString -> ByteString -> m AgentMsgId
sendMessage' AgentClient
c ByteString
connId ByteString
msg =
  (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' SomeConn)
-> m SomeConn
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' a)
-> m a
withStore (SQLiteStore -> ByteString -> m' SomeConn
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> ByteString -> m SomeConn
`getConn` ByteString
connId) m SomeConn -> (SomeConn -> m AgentMsgId) -> m AgentMsgId
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    SomeConn SConnType d
_ (DuplexConnection ConnData
_ RcvQueue
_ SndQueue
sq) -> SndQueue -> m AgentMsgId
enqueueMessage SndQueue
sq
    SomeConn SConnType d
_ (SndConnection ConnData
_ SndQueue
sq) -> SndQueue -> m AgentMsgId
enqueueMessage SndQueue
sq
    SomeConn
_ -> AgentErrorType -> m AgentMsgId
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (AgentErrorType -> m AgentMsgId) -> AgentErrorType -> m AgentMsgId
forall a b. (a -> b) -> a -> b
$ ConnectionErrorType -> AgentErrorType
CONN ConnectionErrorType
SIMPLEX
  where
    enqueueMessage :: SndQueue -> m AgentMsgId
    enqueueMessage :: SndQueue -> m AgentMsgId
enqueueMessage SndQueue
sq = do
      AgentClient -> ByteString -> SndQueue -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> ByteString -> SndQueue -> m ()
resumeMsgDelivery AgentClient
c ByteString
connId SndQueue
sq
      InternalId
msgId <- m InternalId
storeSentMsg
      AgentClient -> ByteString -> SndQueue -> [InternalId] -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> ByteString -> SndQueue -> [InternalId] -> m ()
queuePendingMsgs AgentClient
c ByteString
connId SndQueue
sq [Item [InternalId]
InternalId
msgId]
      AgentMsgId -> m AgentMsgId
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AgentMsgId -> m AgentMsgId) -> AgentMsgId -> m AgentMsgId
forall a b. (a -> b) -> a -> b
$ InternalId -> AgentMsgId
unId InternalId
msgId
      where
        storeSentMsg :: m InternalId
        storeSentMsg :: m InternalId
storeSentMsg = do
          UTCTime
internalTs <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
          (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' InternalId)
-> m InternalId
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' a)
-> m a
withStore ((forall (m' :: * -> *).
  (MonadUnliftIO m', MonadError StoreError m') =>
  SQLiteStore -> m' InternalId)
 -> m InternalId)
-> (forall (m' :: * -> *).
    (MonadUnliftIO m', MonadError StoreError m') =>
    SQLiteStore -> m' InternalId)
-> m InternalId
forall a b. (a -> b) -> a -> b
$ \SQLiteStore
st -> do
            (InternalId
internalId, InternalSndId
internalSndId, ByteString
previousMsgHash) <- SQLiteStore
-> ByteString -> m' (InternalId, InternalSndId, ByteString)
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> ByteString -> m (InternalId, InternalSndId, ByteString)
updateSndIds SQLiteStore
st ByteString
connId
            let msgBody :: ByteString
msgBody =
                  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
msg
                      }
                internalHash :: ByteString
internalHash = ByteString -> ByteString
C.sha256Hash ByteString
msgBody
                msgData :: SndMsgData
msgData = SndMsgData :: InternalId
-> InternalSndId
-> UTCTime
-> ByteString
-> ByteString
-> ByteString
-> SndMsgData
SndMsgData {ByteString
UTCTime
InternalId
InternalSndId
$sel:previousMsgHash:SndMsgData :: ByteString
$sel:internalHash:SndMsgData :: ByteString
$sel:msgBody:SndMsgData :: ByteString
$sel:internalTs:SndMsgData :: UTCTime
$sel:internalSndId:SndMsgData :: InternalSndId
$sel:internalId:SndMsgData :: InternalId
internalHash :: ByteString
msgBody :: ByteString
previousMsgHash :: ByteString
internalSndId :: InternalSndId
internalId :: InternalId
internalTs :: UTCTime
..}
            SQLiteStore -> ByteString -> SndMsgData -> m' ()
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> ByteString -> SndMsgData -> m ()
createSndMsg SQLiteStore
st ByteString
connId SndMsgData
msgData
            InternalId -> m' InternalId
forall (f :: * -> *) a. Applicative f => a -> f a
pure InternalId
internalId

resumeMsgDelivery :: forall m. AgentMonad m => AgentClient -> ConnId -> SndQueue -> m ()
resumeMsgDelivery :: AgentClient -> ByteString -> SndQueue -> m ()
resumeMsgDelivery AgentClient
c ByteString
connId sq :: SndQueue
sq@SndQueue {SMPServer
$sel:server:SndQueue :: SndQueue -> SMPServer
server :: SMPServer
server, ByteString
$sel:sndId:SndQueue :: SndQueue -> ByteString
sndId :: ByteString
sndId} = do
  let qKey :: (ByteString, SMPServer, ByteString)
qKey = (ByteString
connId, SMPServer
server, ByteString
sndId)
  m Bool -> m () -> m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM ((ByteString, SMPServer, ByteString) -> m Bool
queueDelivering (ByteString, SMPServer, ByteString)
qKey) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    m () -> m (Async ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async (AgentClient -> ByteString -> SndQueue -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> ByteString -> SndQueue -> m ()
runSmpQueueMsgDelivery AgentClient
c ByteString
connId SndQueue
sq)
      m (Async ()) -> (Async () -> m ()) -> m ()
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 ()) -> (Async () -> STM ()) -> Async () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar (Map (ByteString, SMPServer, ByteString) (Async ()))
-> (Map (ByteString, SMPServer, ByteString) (Async ())
    -> Map (ByteString, SMPServer, ByteString) (Async ()))
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar (AgentClient
-> TVar (Map (ByteString, SMPServer, ByteString) (Async ()))
smpQueueMsgDeliveries AgentClient
c) ((Map (ByteString, SMPServer, ByteString) (Async ())
  -> Map (ByteString, SMPServer, ByteString) (Async ()))
 -> STM ())
-> (Async ()
    -> Map (ByteString, SMPServer, ByteString) (Async ())
    -> Map (ByteString, SMPServer, ByteString) (Async ()))
-> Async ()
-> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, SMPServer, ByteString)
-> Async ()
-> Map (ByteString, SMPServer, ByteString) (Async ())
-> Map (ByteString, SMPServer, ByteString) (Async ())
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (ByteString, SMPServer, ByteString)
qKey
  m Bool -> m () -> m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM m Bool
connQueued (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' [InternalId])
-> m [InternalId]
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' a)
-> m a
withStore (SQLiteStore -> ByteString -> m' [InternalId]
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> ByteString -> m [InternalId]
`getPendingMsgs` ByteString
connId)
      m [InternalId] -> ([InternalId] -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= AgentClient -> ByteString -> SndQueue -> [InternalId] -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> ByteString -> SndQueue -> [InternalId] -> m ()
queuePendingMsgs AgentClient
c ByteString
connId SndQueue
sq
  where
    queueDelivering :: (ByteString, SMPServer, ByteString) -> m Bool
queueDelivering (ByteString, SMPServer, ByteString)
qKey = Maybe (Async ()) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Async ()) -> Bool)
-> (Map (ByteString, SMPServer, ByteString) (Async ())
    -> Maybe (Async ()))
-> Map (ByteString, SMPServer, ByteString) (Async ())
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, SMPServer, ByteString)
-> Map (ByteString, SMPServer, ByteString) (Async ())
-> Maybe (Async ())
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (ByteString, SMPServer, ByteString)
qKey (Map (ByteString, SMPServer, ByteString) (Async ()) -> Bool)
-> m (Map (ByteString, SMPServer, ByteString) (Async ())) -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map (ByteString, SMPServer, ByteString) (Async ()))
-> m (Map (ByteString, SMPServer, ByteString) (Async ()))
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (AgentClient
-> TVar (Map (ByteString, SMPServer, ByteString) (Async ()))
smpQueueMsgDeliveries AgentClient
c)
    connQueued :: m Bool
connQueued =
      STM Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Bool -> m Bool) -> STM Bool -> m Bool
forall a b. (a -> b) -> a -> b
$
        Maybe Bool -> Bool
forall a. Maybe a -> Bool
isJust
          (Maybe Bool -> Bool) -> STM (Maybe Bool) -> STM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map ByteString Bool)
-> (Map ByteString Bool -> (Maybe Bool, Map ByteString Bool))
-> STM (Maybe Bool)
forall s a. TVar s -> (s -> (a, s)) -> STM a
stateTVar
            (AgentClient -> TVar (Map ByteString Bool)
connMsgsQueued AgentClient
c)
            (\Map ByteString Bool
m -> (ByteString -> Map ByteString Bool -> Maybe Bool
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ByteString
connId Map ByteString Bool
m, ByteString -> Bool -> Map ByteString Bool -> Map ByteString Bool
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert ByteString
connId Bool
True Map ByteString Bool
m))

queuePendingMsgs :: AgentMonad m => AgentClient -> ConnId -> SndQueue -> [InternalId] -> m ()
queuePendingMsgs :: AgentClient -> ByteString -> SndQueue -> [InternalId] -> m ()
queuePendingMsgs AgentClient
c ByteString
connId SndQueue
sq [InternalId]
msgIds = STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  TQueue InternalId
q <- AgentClient -> ByteString -> SndQueue -> STM (TQueue InternalId)
getPendingMsgQ AgentClient
c ByteString
connId SndQueue
sq
  (InternalId -> STM ()) -> [InternalId] -> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TQueue InternalId -> InternalId -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue InternalId
q) [InternalId]
msgIds

getPendingMsgQ :: AgentClient -> ConnId -> SndQueue -> STM (TQueue InternalId)
getPendingMsgQ :: AgentClient -> ByteString -> SndQueue -> STM (TQueue InternalId)
getPendingMsgQ AgentClient
c ByteString
connId SndQueue {SMPServer
server :: SMPServer
$sel:server:SndQueue :: SndQueue -> SMPServer
server, ByteString
sndId :: ByteString
$sel:sndId:SndQueue :: SndQueue -> ByteString
sndId} = do
  let qKey :: (ByteString, SMPServer, ByteString)
qKey = (ByteString
connId, SMPServer
server, ByteString
sndId)
  STM (TQueue InternalId)
-> (TQueue InternalId -> STM (TQueue InternalId))
-> Maybe (TQueue InternalId)
-> STM (TQueue InternalId)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((ByteString, SMPServer, ByteString) -> STM (TQueue InternalId)
newMsgQueue (ByteString, SMPServer, ByteString)
qKey) TQueue InternalId -> STM (TQueue InternalId)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (TQueue InternalId) -> STM (TQueue InternalId))
-> (Map (ByteString, SMPServer, ByteString) (TQueue InternalId)
    -> Maybe (TQueue InternalId))
-> Map (ByteString, SMPServer, ByteString) (TQueue InternalId)
-> STM (TQueue InternalId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, SMPServer, ByteString)
-> Map (ByteString, SMPServer, ByteString) (TQueue InternalId)
-> Maybe (TQueue InternalId)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (ByteString, SMPServer, ByteString)
qKey (Map (ByteString, SMPServer, ByteString) (TQueue InternalId)
 -> STM (TQueue InternalId))
-> STM
     (Map (ByteString, SMPServer, ByteString) (TQueue InternalId))
-> STM (TQueue InternalId)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TVar (Map (ByteString, SMPServer, ByteString) (TQueue InternalId))
-> STM
     (Map (ByteString, SMPServer, ByteString) (TQueue InternalId))
forall a. TVar a -> STM a
readTVar (AgentClient
-> TVar
     (Map (ByteString, SMPServer, ByteString) (TQueue InternalId))
smpQueueMsgQueues AgentClient
c)
  where
    newMsgQueue :: (ByteString, SMPServer, ByteString) -> STM (TQueue InternalId)
newMsgQueue (ByteString, SMPServer, ByteString)
qKey = do
      TQueue InternalId
mq <- STM (TQueue InternalId)
forall a. STM (TQueue a)
newTQueue
      TVar (Map (ByteString, SMPServer, ByteString) (TQueue InternalId))
-> (Map (ByteString, SMPServer, ByteString) (TQueue InternalId)
    -> Map (ByteString, SMPServer, ByteString) (TQueue InternalId))
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar (AgentClient
-> TVar
     (Map (ByteString, SMPServer, ByteString) (TQueue InternalId))
smpQueueMsgQueues AgentClient
c) ((Map (ByteString, SMPServer, ByteString) (TQueue InternalId)
  -> Map (ByteString, SMPServer, ByteString) (TQueue InternalId))
 -> STM ())
-> (Map (ByteString, SMPServer, ByteString) (TQueue InternalId)
    -> Map (ByteString, SMPServer, ByteString) (TQueue InternalId))
-> STM ()
forall a b. (a -> b) -> a -> b
$ (ByteString, SMPServer, ByteString)
-> TQueue InternalId
-> Map (ByteString, SMPServer, ByteString) (TQueue InternalId)
-> Map (ByteString, SMPServer, ByteString) (TQueue InternalId)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (ByteString, SMPServer, ByteString)
qKey TQueue InternalId
mq
      TQueue InternalId -> STM (TQueue InternalId)
forall (f :: * -> *) a. Applicative f => a -> f a
pure TQueue InternalId
mq

runSmpQueueMsgDelivery :: forall m. AgentMonad m => AgentClient -> ConnId -> SndQueue -> m ()
runSmpQueueMsgDelivery :: AgentClient -> ByteString -> SndQueue -> m ()
runSmpQueueMsgDelivery c :: AgentClient
c@AgentClient {TBQueue (ATransmission 'Agent)
subQ :: TBQueue (ATransmission 'Agent)
$sel:subQ:AgentClient :: AgentClient -> TBQueue (ATransmission 'Agent)
subQ} ByteString
connId SndQueue
sq = do
  TQueue InternalId
mq <- STM (TQueue InternalId) -> m (TQueue InternalId)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (TQueue InternalId) -> m (TQueue InternalId))
-> STM (TQueue InternalId) -> m (TQueue InternalId)
forall a b. (a -> b) -> a -> b
$ AgentClient -> ByteString -> SndQueue -> STM (TQueue InternalId)
getPendingMsgQ AgentClient
c ByteString
connId SndQueue
sq
  RetryInterval
ri <- (Env -> RetryInterval) -> m RetryInterval
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Env -> RetryInterval) -> m RetryInterval)
-> (Env -> RetryInterval) -> m RetryInterval
forall a b. (a -> b) -> a -> b
$ AgentConfig -> RetryInterval
reconnectInterval (AgentConfig -> RetryInterval)
-> (Env -> AgentConfig) -> Env -> RetryInterval
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> AgentConfig
config
  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
    InternalId
msgId <- STM InternalId -> m InternalId
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM InternalId -> m InternalId) -> STM InternalId -> m InternalId
forall a b. (a -> b) -> a -> b
$ TQueue InternalId -> STM InternalId
forall a. TQueue a -> STM a
readTQueue TQueue InternalId
mq
    let mId :: AgentMsgId
mId = InternalId -> AgentMsgId
unId InternalId
msgId
    (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' (Either SomeException ByteString))
-> m (Either SomeException ByteString)
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' a)
-> m a
withStore (\SQLiteStore
st -> m' ByteString -> m' (Either SomeException ByteString)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
E.try (m' ByteString -> m' (Either SomeException ByteString))
-> m' ByteString -> m' (Either SomeException ByteString)
forall a b. (a -> b) -> a -> b
$ SQLiteStore -> ByteString -> InternalId -> m' ByteString
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> ByteString -> InternalId -> m ByteString
getPendingMsgData SQLiteStore
st ByteString
connId InternalId
msgId) m (Either SomeException ByteString)
-> (Either SomeException ByteString -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left (SomeException
e :: E.SomeException) ->
        ACommand 'Agent -> m ()
notify (ACommand 'Agent -> m ()) -> ACommand 'Agent -> m ()
forall a b. (a -> b) -> a -> b
$ AgentMsgId -> AgentErrorType -> ACommand 'Agent
MERR AgentMsgId
mId (ServiceName -> AgentErrorType
INTERNAL (ServiceName -> AgentErrorType) -> ServiceName -> AgentErrorType
forall a b. (a -> b) -> a -> b
$ SomeException -> ServiceName
forall a. Show a => a -> ServiceName
show SomeException
e)
      Right ByteString
msgBody -> do
        RetryInterval -> (m () -> m ()) -> m ()
forall (m :: * -> *).
MonadIO m =>
RetryInterval -> (m () -> m ()) -> m ()
withRetryInterval RetryInterval
ri ((m () -> m ()) -> m ()) -> (m () -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \m ()
loop -> do
          m () -> m (Either AgentErrorType ())
forall e (m :: * -> *) a. MonadError e m => m a -> m (Either e a)
tryError (AgentClient -> SndQueue -> ByteString -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> SndQueue -> ByteString -> m ()
sendAgentMessage AgentClient
c SndQueue
sq ByteString
msgBody) m (Either AgentErrorType ())
-> (Either AgentErrorType () -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left AgentErrorType
e -> case AgentErrorType
e of
              SMP ErrorType
SMP.QUOTA -> m ()
loop
              SMP {} -> ACommand 'Agent -> m ()
notify (ACommand 'Agent -> m ()) -> ACommand 'Agent -> m ()
forall a b. (a -> b) -> a -> b
$ AgentMsgId -> AgentErrorType -> ACommand 'Agent
MERR AgentMsgId
mId AgentErrorType
e
              CMD {} -> ACommand 'Agent -> m ()
notify (ACommand 'Agent -> m ()) -> ACommand 'Agent -> m ()
forall a b. (a -> b) -> a -> b
$ AgentMsgId -> AgentErrorType -> ACommand 'Agent
MERR AgentMsgId
mId AgentErrorType
e
              AgentErrorType
_ -> m ()
loop
            Right () -> do
              ACommand 'Agent -> m ()
notify (ACommand 'Agent -> m ()) -> ACommand 'Agent -> m ()
forall a b. (a -> b) -> a -> b
$ AgentMsgId -> ACommand 'Agent
SENT AgentMsgId
mId
              (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' ())
-> m ()
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' a)
-> m a
withStore ((forall (m' :: * -> *).
  (MonadUnliftIO m', MonadError StoreError m') =>
  SQLiteStore -> m' ())
 -> m ())
-> (forall (m' :: * -> *).
    (MonadUnliftIO m', MonadError StoreError m') =>
    SQLiteStore -> m' ())
-> m ()
forall a b. (a -> b) -> a -> b
$ \SQLiteStore
st -> SQLiteStore -> ByteString -> InternalId -> SndMsgStatus -> m' ()
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> ByteString -> InternalId -> SndMsgStatus -> m ()
updateSndMsgStatus SQLiteStore
st ByteString
connId InternalId
msgId SndMsgStatus
SndMsgSent
  where
    notify :: ACommand 'Agent -> m ()
    notify :: ACommand 'Agent -> m ()
notify ACommand 'Agent
cmd = 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)
subQ (ByteString
"", ByteString
connId, ACommand 'Agent
cmd)

ackMessage' :: forall m. AgentMonad m => AgentClient -> ConnId -> AgentMsgId -> m ()
ackMessage' :: AgentClient -> ByteString -> AgentMsgId -> m ()
ackMessage' AgentClient
c ByteString
connId AgentMsgId
msgId = do
  (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' SomeConn)
-> m SomeConn
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' a)
-> m a
withStore (SQLiteStore -> ByteString -> m' SomeConn
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> ByteString -> m SomeConn
`getConn` ByteString
connId) m SomeConn -> (SomeConn -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    SomeConn SConnType d
_ (DuplexConnection ConnData
_ RcvQueue
rq SndQueue
_) -> RcvQueue -> m ()
ack RcvQueue
rq
    SomeConn SConnType d
_ (RcvConnection ConnData
_ RcvQueue
rq) -> RcvQueue -> m ()
ack 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
    ack :: RcvQueue -> m ()
    ack :: RcvQueue -> m ()
ack RcvQueue
rq = do
      let mId :: InternalId
mId = AgentMsgId -> InternalId
InternalId AgentMsgId
msgId
      (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' ())
-> m ()
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' a)
-> m a
withStore ((forall (m' :: * -> *).
  (MonadUnliftIO m', MonadError StoreError m') =>
  SQLiteStore -> m' ())
 -> m ())
-> (forall (m' :: * -> *).
    (MonadUnliftIO m', MonadError StoreError m') =>
    SQLiteStore -> m' ())
-> m ()
forall a b. (a -> b) -> a -> b
$ \SQLiteStore
st -> SQLiteStore -> ByteString -> InternalId -> m' ()
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> ByteString -> InternalId -> m ()
checkRcvMsg SQLiteStore
st ByteString
connId InternalId
mId
      AgentClient -> RcvQueue -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> RcvQueue -> m ()
sendAck AgentClient
c RcvQueue
rq
      (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' ())
-> m ()
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' a)
-> m a
withStore ((forall (m' :: * -> *).
  (MonadUnliftIO m', MonadError StoreError m') =>
  SQLiteStore -> m' ())
 -> m ())
-> (forall (m' :: * -> *).
    (MonadUnliftIO m', MonadError StoreError m') =>
    SQLiteStore -> m' ())
-> m ()
forall a b. (a -> b) -> a -> b
$ \SQLiteStore
st -> SQLiteStore -> ByteString -> InternalId -> m' ()
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> ByteString -> InternalId -> m ()
updateRcvMsgAck SQLiteStore
st ByteString
connId InternalId
mId

-- | Suspend SMP agent connection (OFF command) in Reader monad
suspendConnection' :: AgentMonad m => AgentClient -> ConnId -> m ()
suspendConnection' :: AgentClient -> ByteString -> m ()
suspendConnection' AgentClient
c ByteString
connId =
  (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' SomeConn)
-> m SomeConn
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' a)
-> m a
withStore (SQLiteStore -> ByteString -> m' SomeConn
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> ByteString -> m SomeConn
`getConn` ByteString
connId) m SomeConn -> (SomeConn -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    SomeConn SConnType d
_ (DuplexConnection ConnData
_ RcvQueue
rq SndQueue
_) -> AgentClient -> RcvQueue -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> RcvQueue -> m ()
suspendQueue AgentClient
c RcvQueue
rq
    SomeConn SConnType d
_ (RcvConnection ConnData
_ RcvQueue
rq) -> AgentClient -> RcvQueue -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> RcvQueue -> m ()
suspendQueue AgentClient
c 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

-- | Delete SMP agent connection (DEL command) in Reader monad
deleteConnection' :: forall m. AgentMonad m => AgentClient -> ConnId -> m ()
deleteConnection' :: AgentClient -> ByteString -> m ()
deleteConnection' AgentClient
c ByteString
connId =
  (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' SomeConn)
-> m SomeConn
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' a)
-> m a
withStore (SQLiteStore -> ByteString -> m' SomeConn
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> ByteString -> m SomeConn
`getConn` ByteString
connId) m SomeConn -> (SomeConn -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    SomeConn SConnType d
_ (DuplexConnection ConnData
_ RcvQueue
rq SndQueue
_) -> RcvQueue -> m ()
delete RcvQueue
rq
    SomeConn SConnType d
_ (RcvConnection ConnData
_ RcvQueue
rq) -> RcvQueue -> m ()
delete RcvQueue
rq
    SomeConn SConnType d
_ (ContactConnection ConnData
_ RcvQueue
rq) -> RcvQueue -> m ()
delete RcvQueue
rq
    SomeConn SConnType d
_ (SndConnection ConnData
_ SndQueue
_) -> (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' ())
-> m ()
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' a)
-> m a
withStore (SQLiteStore -> ByteString -> m' ()
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> ByteString -> m ()
`deleteConn` ByteString
connId)
  where
    delete :: RcvQueue -> m ()
    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
connId
      (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' ())
-> m ()
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' a)
-> m a
withStore (SQLiteStore -> ByteString -> m' ()
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> ByteString -> m ()
`deleteConn` ByteString
connId)

getSMPServer :: AgentMonad m => 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

sendControlMessage :: AgentMonad m => AgentClient -> SndQueue -> AMessage -> m ()
sendControlMessage :: AgentClient -> SndQueue -> AMessage -> m ()
sendControlMessage AgentClient
c SndQueue
sq AMessage
agentMessage = do
  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
"",
        AMessage
agentMessage :: AMessage
agentMessage :: AMessage
agentMessage
      }

subscriber :: (MonadUnliftIO m, MonadReader Env m) => AgentClient -> m ()
subscriber :: AgentClient -> m ()
subscriber c :: AgentClient
c@AgentClient {TBQueue SMPServerTransmission
$sel:msgQ:AgentClient :: AgentClient -> TBQueue SMPServerTransmission
msgQ :: TBQueue SMPServerTransmission
msgQ} = 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
  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
  AgentClient
-> m (Either AgentErrorType ()) -> m (Either AgentErrorType ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
AgentClient -> m a -> m a
withAgentLock AgentClient
c (ExceptT AgentErrorType m () -> m (Either AgentErrorType ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT AgentErrorType m () -> m (Either AgentErrorType ()))
-> ExceptT AgentErrorType m () -> m (Either AgentErrorType ())
forall a b. (a -> b) -> a -> b
$ AgentClient -> SMPServerTransmission -> ExceptT AgentErrorType m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> SMPServerTransmission -> m ()
processSMPTransmission AgentClient
c 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 -> SMPServerTransmission -> m ()
processSMPTransmission :: AgentClient -> SMPServerTransmission -> m ()
processSMPTransmission c :: AgentClient
c@AgentClient {TBQueue (ATransmission 'Agent)
subQ :: TBQueue (ATransmission 'Agent)
$sel:subQ:AgentClient :: AgentClient -> TBQueue (ATransmission 'Agent)
subQ} (SMPServer
srv, ByteString
rId, Command 'Broker
cmd) = do
  (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' SomeConn)
-> m SomeConn
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' a)
-> m a
withStore (\SQLiteStore
st -> 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 ConnData
cData RcvQueue
rq SndQueue
_) -> SConnType 'CDuplex -> ConnData -> RcvQueue -> m ()
forall (c :: ConnType). SConnType c -> ConnData -> RcvQueue -> m ()
processSMP SConnType 'CDuplex
SCDuplex ConnData
cData RcvQueue
rq
    SomeConn SConnType d
SCRcv (RcvConnection ConnData
cData RcvQueue
rq) -> SConnType 'CRcv -> ConnData -> RcvQueue -> m ()
forall (c :: ConnType). SConnType c -> ConnData -> RcvQueue -> m ()
processSMP SConnType 'CRcv
SCRcv ConnData
cData RcvQueue
rq
    SomeConn SConnType d
SCContact (ContactConnection ConnData
cData RcvQueue
rq) -> SConnType 'CContact -> ConnData -> RcvQueue -> m ()
forall (c :: ConnType). SConnType c -> ConnData -> RcvQueue -> m ()
processSMP SConnType 'CContact
SCContact ConnData
cData 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)
subQ (ByteString
"", ByteString
"", AgentErrorType -> ACommand 'Agent
ERR (AgentErrorType -> ACommand 'Agent)
-> AgentErrorType -> ACommand 'Agent
forall a b. (a -> b) -> a -> b
$ ConnectionErrorType -> AgentErrorType
CONN ConnectionErrorType
NOT_FOUND)
  where
    processSMP :: SConnType c -> ConnData -> RcvQueue -> m ()
    processSMP :: SConnType c -> ConnData -> RcvQueue -> m ()
processSMP SConnType c
cType ConnData {ByteString
connId :: ByteString
$sel:connId:ConnData :: ConnData -> ByteString
connId} rq :: RcvQueue
rq@RcvQueue {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
          case ByteString -> Either AgentErrorType SMPMessage
parseSMPMessage ByteString
msg of
            Left AgentErrorType
e -> ACommand 'Agent -> m ()
notify (AgentErrorType -> ACommand 'Agent
ERR AgentErrorType
e) m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> AgentClient -> RcvQueue -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> RcvQueue -> m ()
sendAck AgentClient
c RcvQueue
rq
            Right (SMPConfirmation EncryptionKey
senderKey ByteString
cInfo) -> EncryptionKey -> ByteString -> m ()
smpConfirmation EncryptionKey
senderKey ByteString
cInfo m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> AgentClient -> RcvQueue -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> RcvQueue -> m ()
sendAck AgentClient
c RcvQueue
rq
            Right 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 EncryptionKey
verifyKey AckMode
_ -> EncryptionKey -> ByteString -> m ()
helloMsg EncryptionKey
verifyKey ByteString
msgBody m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> AgentClient -> RcvQueue -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> RcvQueue -> m ()
sendAck AgentClient
c RcvQueue
rq
                REPLY ConnectionRequest 'CMInvitation
cReq -> ConnectionRequest 'CMInvitation -> m ()
replyMsg ConnectionRequest 'CMInvitation
cReq m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> AgentClient -> RcvQueue -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> RcvQueue -> m ()
sendAck AgentClient
c RcvQueue
rq
                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
                A_INV ConnectionRequest 'CMInvitation
cReq ByteString
cInfo -> ConnectionRequest 'CMInvitation -> ByteString -> m ()
smpInvitation ConnectionRequest 'CMInvitation
cReq ByteString
cInfo m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> AgentClient -> RcvQueue -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> RcvQueue -> m ()
sendAck AgentClient
c RcvQueue
rq
        Command 'Broker
SMP.END -> do
          AgentClient -> ByteString -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> ByteString -> m ()
removeSubscription AgentClient
c ByteString
connId
          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)
subQ (ByteString
"", ByteString
connId, 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 -> ConnInfo -> m ()
        smpConfirmation :: EncryptionKey -> ByteString -> m ()
smpConfirmation EncryptionKey
senderKey ByteString
cInfo = 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 -> case SConnType c
cType of
              SConnType c
SCRcv -> do
                TVar ChaChaDRG
g <- (Env -> TVar ChaChaDRG) -> m (TVar ChaChaDRG)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> TVar ChaChaDRG
idsDrg
                let newConfirmation :: NewConfirmation
newConfirmation = NewConfirmation :: ByteString -> EncryptionKey -> ByteString -> NewConfirmation
NewConfirmation {ByteString
$sel:connId:NewConfirmation :: ByteString
connId :: ByteString
connId, EncryptionKey
$sel:senderKey:NewConfirmation :: EncryptionKey
senderKey :: EncryptionKey
senderKey, $sel:senderConnInfo:NewConfirmation :: ByteString
senderConnInfo = ByteString
cInfo}
                ByteString
confId <- (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' ByteString)
-> m ByteString
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' a)
-> m a
withStore ((forall (m' :: * -> *).
  (MonadUnliftIO m', MonadError StoreError m') =>
  SQLiteStore -> m' ByteString)
 -> m ByteString)
-> (forall (m' :: * -> *).
    (MonadUnliftIO m', MonadError StoreError m') =>
    SQLiteStore -> m' ByteString)
-> m ByteString
forall a b. (a -> b) -> a -> b
$ \SQLiteStore
st -> SQLiteStore -> TVar ChaChaDRG -> NewConfirmation -> m' ByteString
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> TVar ChaChaDRG -> NewConfirmation -> m ByteString
createConfirmation SQLiteStore
st TVar ChaChaDRG
g NewConfirmation
newConfirmation
                ACommand 'Agent -> m ()
notify (ACommand 'Agent -> m ()) -> ACommand 'Agent -> m ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> ACommand 'Agent
CONF ByteString
confId ByteString
cInfo
              SConnType c
SCDuplex -> do
                ACommand 'Agent -> m ()
notify (ACommand 'Agent -> m ()) -> ACommand 'Agent -> m ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ACommand 'Agent
INFO ByteString
cInfo
                AgentClient -> RcvQueue -> EncryptionKey -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> RcvQueue -> EncryptionKey -> m ()
processConfirmation AgentClient
c RcvQueue
rq EncryptionKey
senderKey
              SConnType c
_ -> m ()
prohibited
            QueueStatus
_ -> m ()
prohibited

        helloMsg :: SenderPublicKey -> ByteString -> m ()
        helloMsg :: EncryptionKey -> ByteString -> m ()
helloMsg EncryptionKey
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 EncryptionKey -> ByteString -> m ByteString
forall (m :: * -> *).
AgentMonad m =>
Maybe EncryptionKey -> ByteString -> m ByteString
verifyMessage (EncryptionKey -> Maybe EncryptionKey
forall a. a -> Maybe a
Just EncryptionKey
verifyKey) ByteString
msgBody
              (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' ())
-> m ()
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' a)
-> m a
withStore ((forall (m' :: * -> *).
  (MonadUnliftIO m', MonadError StoreError m') =>
  SQLiteStore -> m' ())
 -> m ())
-> (forall (m' :: * -> *).
    (MonadUnliftIO m', MonadError StoreError m') =>
    SQLiteStore -> m' ())
-> m ()
forall a b. (a -> b) -> a -> b
$ \SQLiteStore
st -> SQLiteStore -> RcvQueue -> EncryptionKey -> m' ()
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> RcvQueue -> EncryptionKey -> m ()
setRcvQueueActive SQLiteStore
st RcvQueue
rq EncryptionKey
verifyKey
              case SConnType c
cType of
                SConnType c
SCDuplex -> AgentClient -> ByteString -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> ByteString -> m ()
notifyConnected AgentClient
c ByteString
connId
                SConnType c
_ -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

        replyMsg :: ConnectionRequest 'CMInvitation -> m ()
        replyMsg :: ConnectionRequest 'CMInvitation -> m ()
replyMsg (CRInvitation (ConnReqData ConnReqScheme
_ (SMPQueueUri
qUri :| [SMPQueueUri]
_) EncryptionKey
encryptKey)) = 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
              AcceptedConfirmation {ByteString
$sel:ownConnInfo:AcceptedConfirmation :: AcceptedConfirmation -> ByteString
ownConnInfo :: ByteString
ownConnInfo} <- (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' AcceptedConfirmation)
-> m AcceptedConfirmation
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' a)
-> m a
withStore (SQLiteStore -> ByteString -> m' AcceptedConfirmation
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> ByteString -> m AcceptedConfirmation
`getAcceptedConfirmation` ByteString
connId)
              (SndQueue
sq, EncryptionKey
senderKey, EncryptionKey
verifyKey) <- SMPQueueUri
-> EncryptionKey -> m (SndQueue, EncryptionKey, EncryptionKey)
forall (m :: * -> *).
(MonadUnliftIO m, MonadReader Env m) =>
SMPQueueUri
-> EncryptionKey -> m (SndQueue, EncryptionKey, EncryptionKey)
newSndQueue SMPQueueUri
qUri EncryptionKey
encryptKey
              (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' ())
-> m ()
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' a)
-> m a
withStore ((forall (m' :: * -> *).
  (MonadUnliftIO m', MonadError StoreError m') =>
  SQLiteStore -> m' ())
 -> m ())
-> (forall (m' :: * -> *).
    (MonadUnliftIO m', MonadError StoreError m') =>
    SQLiteStore -> m' ())
-> m ()
forall a b. (a -> b) -> a -> b
$ \SQLiteStore
st -> SQLiteStore -> ByteString -> SndQueue -> m' ()
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> ByteString -> SndQueue -> m ()
upgradeRcvConnToDuplex SQLiteStore
st ByteString
connId SndQueue
sq
              AgentClient -> SndQueue -> EncryptionKey -> ByteString -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> SndQueue -> EncryptionKey -> ByteString -> m ()
confirmQueue AgentClient
c SndQueue
sq EncryptionKey
senderKey ByteString
ownConnInfo
              (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' ())
-> m ()
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' a)
-> m a
withStore (SQLiteStore -> ByteString -> m' ()
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> ByteString -> m ()
`removeConfirmations` ByteString
connId)
              AgentConfig
cfg <- (Env -> AgentConfig) -> m AgentConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> AgentConfig
config
              AgentClient
-> ByteString -> SndQueue -> EncryptionKey -> RetryInterval -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient
-> ByteString -> SndQueue -> EncryptionKey -> RetryInterval -> m ()
activateQueueInitiating AgentClient
c ByteString
connId SndQueue
sq EncryptionKey
verifyKey (RetryInterval -> m ()) -> RetryInterval -> m ()
forall a b. (a -> b) -> a -> b
$ AgentConfig -> RetryInterval
retryInterval AgentConfig
cfg
            SConnType c
_ -> m ()
prohibited

        agentClientMsg :: PrevRcvMsgHash -> (ExternalSndId, ExternalSndTs) -> (BrokerId, BrokerTs) -> MsgBody -> MsgHash -> m ()
        agentClientMsg :: ByteString
-> (AgentMsgId, UTCTime)
-> (ByteString, UTCTime)
-> ByteString
-> ByteString
-> m ()
agentClientMsg ByteString
externalPrevSndHash (AgentMsgId, UTCTime)
sender (ByteString, UTCTime)
broker ByteString
msgBody ByteString
internalHash = 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>"
          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') =>
 SQLiteStore
 -> m' (InternalId, InternalRcvId, AgentMsgId, ByteString))
-> m (InternalId, InternalRcvId, AgentMsgId, ByteString)
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' a)
-> m a
withStore (SQLiteStore
-> ByteString
-> m' (InternalId, InternalRcvId, AgentMsgId, ByteString)
forall s (m :: * -> *).
MonadAgentStore s m =>
s
-> ByteString
-> m (InternalId, InternalRcvId, AgentMsgId, ByteString)
`updateRcvIds` ByteString
connId)
          let integrity :: MsgIntegrity
integrity = AgentMsgId
-> AgentMsgId -> ByteString -> ByteString -> MsgIntegrity
checkMsgIntegrity AgentMsgId
prevExtSndId ((AgentMsgId, UTCTime) -> AgentMsgId
forall a b. (a, b) -> a
fst (AgentMsgId, UTCTime)
sender) ByteString
prevRcvMsgHash ByteString
externalPrevSndHash
              recipient :: (AgentMsgId, UTCTime)
recipient = (InternalId -> AgentMsgId
unId InternalId
internalId, UTCTime
internalTs)
              msgMeta :: MsgMeta
msgMeta = MsgMeta :: MsgIntegrity
-> (AgentMsgId, UTCTime)
-> (ByteString, UTCTime)
-> (AgentMsgId, UTCTime)
-> MsgMeta
MsgMeta {MsgIntegrity
integrity :: MsgIntegrity
integrity :: MsgIntegrity
integrity, (AgentMsgId, UTCTime)
recipient :: (AgentMsgId, UTCTime)
recipient :: (AgentMsgId, UTCTime)
recipient, (AgentMsgId, UTCTime)
sender :: (AgentMsgId, UTCTime)
sender :: (AgentMsgId, UTCTime)
sender, (ByteString, UTCTime)
broker :: (ByteString, UTCTime)
broker :: (ByteString, UTCTime)
broker}
              rcvMsg :: RcvMsgData
rcvMsg = RcvMsgData :: MsgMeta
-> ByteString
-> InternalRcvId
-> ByteString
-> ByteString
-> RcvMsgData
RcvMsgData {ByteString
MsgMeta
InternalRcvId
$sel:externalPrevSndHash:RcvMsgData :: ByteString
$sel:internalHash:RcvMsgData :: ByteString
$sel:internalRcvId:RcvMsgData :: InternalRcvId
$sel:msgBody:RcvMsgData :: ByteString
$sel:msgMeta:RcvMsgData :: MsgMeta
msgMeta :: MsgMeta
internalRcvId :: InternalRcvId
internalHash :: ByteString
msgBody :: ByteString
externalPrevSndHash :: ByteString
..}
          (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' ())
-> m ()
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' a)
-> m a
withStore ((forall (m' :: * -> *).
  (MonadUnliftIO m', MonadError StoreError m') =>
  SQLiteStore -> m' ())
 -> m ())
-> (forall (m' :: * -> *).
    (MonadUnliftIO m', MonadError StoreError m') =>
    SQLiteStore -> m' ())
-> m ()
forall a b. (a -> b) -> a -> b
$ \SQLiteStore
st -> SQLiteStore -> ByteString -> RcvMsgData -> m' ()
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> ByteString -> RcvMsgData -> m ()
createRcvMsg SQLiteStore
st ByteString
connId RcvMsgData
rcvMsg
          ACommand 'Agent -> m ()
notify (ACommand 'Agent -> m ()) -> ACommand 'Agent -> m ()
forall a b. (a -> b) -> a -> b
$ MsgMeta -> ByteString -> ACommand 'Agent
MSG MsgMeta
msgMeta ByteString
msgBody

        smpInvitation :: ConnectionRequest 'CMInvitation -> ConnInfo -> m ()
        smpInvitation :: ConnectionRequest 'CMInvitation -> ByteString -> m ()
smpInvitation ConnectionRequest 'CMInvitation
connReq ByteString
cInfo = 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 SConnType c
cType of
            SConnType c
SCContact -> do
              TVar ChaChaDRG
g <- (Env -> TVar ChaChaDRG) -> m (TVar ChaChaDRG)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> TVar ChaChaDRG
idsDrg
              let newInv :: NewInvitation
newInv = NewInvitation :: ByteString
-> ConnectionRequest 'CMInvitation -> ByteString -> NewInvitation
NewInvitation {$sel:contactConnId:NewInvitation :: ByteString
contactConnId = ByteString
connId, ConnectionRequest 'CMInvitation
$sel:connReq:NewInvitation :: ConnectionRequest 'CMInvitation
connReq :: ConnectionRequest 'CMInvitation
connReq, $sel:recipientConnInfo:NewInvitation :: ByteString
recipientConnInfo = ByteString
cInfo}
              ByteString
invId <- (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' ByteString)
-> m ByteString
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' a)
-> m a
withStore ((forall (m' :: * -> *).
  (MonadUnliftIO m', MonadError StoreError m') =>
  SQLiteStore -> m' ByteString)
 -> m ByteString)
-> (forall (m' :: * -> *).
    (MonadUnliftIO m', MonadError StoreError m') =>
    SQLiteStore -> m' ByteString)
-> m ByteString
forall a b. (a -> b) -> a -> b
$ \SQLiteStore
st -> SQLiteStore -> TVar ChaChaDRG -> NewInvitation -> m' ByteString
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> TVar ChaChaDRG -> NewInvitation -> m ByteString
createInvitation SQLiteStore
st TVar ChaChaDRG
g NewInvitation
newInv
              ACommand 'Agent -> m ()
notify (ACommand 'Agent -> m ()) -> ACommand 'Agent -> m ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> ACommand 'Agent
REQ ByteString
invId ByteString
cInfo
            SConnType c
_ -> 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

confirmQueue :: AgentMonad m => AgentClient -> SndQueue -> SenderPublicKey -> ConnInfo -> m ()
confirmQueue :: AgentClient -> SndQueue -> EncryptionKey -> ByteString -> m ()
confirmQueue AgentClient
c SndQueue
sq EncryptionKey
senderKey ByteString
cInfo = do
  AgentClient -> SndQueue -> EncryptionKey -> ByteString -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> SndQueue -> EncryptionKey -> ByteString -> m ()
sendConfirmation AgentClient
c SndQueue
sq EncryptionKey
senderKey ByteString
cInfo
  (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' ())
-> m ()
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' a)
-> m a
withStore ((forall (m' :: * -> *).
  (MonadUnliftIO m', MonadError StoreError m') =>
  SQLiteStore -> m' ())
 -> m ())
-> (forall (m' :: * -> *).
    (MonadUnliftIO m', MonadError StoreError m') =>
    SQLiteStore -> m' ())
-> m ()
forall a b. (a -> b) -> a -> b
$ \SQLiteStore
st -> SQLiteStore -> SndQueue -> QueueStatus -> m' ()
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> SndQueue -> QueueStatus -> m ()
setSndQueueStatus SQLiteStore
st SndQueue
sq QueueStatus
Confirmed

activateQueueInitiating :: AgentMonad m => AgentClient -> ConnId -> SndQueue -> VerificationKey -> RetryInterval -> m ()
activateQueueInitiating :: AgentClient
-> ByteString -> SndQueue -> EncryptionKey -> RetryInterval -> m ()
activateQueueInitiating AgentClient
c ByteString
connId SndQueue
sq EncryptionKey
verifyKey RetryInterval
retryInterval =
  AgentClient
-> ByteString
-> SndQueue
-> EncryptionKey
-> RetryInterval
-> m ()
-> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient
-> ByteString
-> SndQueue
-> EncryptionKey
-> RetryInterval
-> m ()
-> m ()
activateQueue AgentClient
c ByteString
connId SndQueue
sq EncryptionKey
verifyKey RetryInterval
retryInterval (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ AgentClient -> ByteString -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> ByteString -> m ()
notifyConnected AgentClient
c ByteString
connId

activateQueue :: forall m. AgentMonad m => AgentClient -> ConnId -> SndQueue -> VerificationKey -> RetryInterval -> m () -> m ()
activateQueue :: AgentClient
-> ByteString
-> SndQueue
-> EncryptionKey
-> RetryInterval
-> m ()
-> m ()
activateQueue AgentClient
c ByteString
connId SndQueue
sq EncryptionKey
verifyKey RetryInterval
retryInterval m ()
afterActivation =
  AgentClient -> ByteString -> m (Maybe (Async ()))
forall (m :: * -> *).
MonadUnliftIO m =>
AgentClient -> ByteString -> m (Maybe (Async ()))
getActivation AgentClient
c ByteString
connId m (Maybe (Async ())) -> (Maybe (Async ()) -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe (Async ())
Nothing -> m () -> m (Async ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async m ()
runActivation m (Async ()) -> (Async () -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= AgentClient -> ByteString -> Async () -> m ()
forall (m :: * -> *).
MonadUnliftIO m =>
AgentClient -> ByteString -> Async () -> m ()
addActivation AgentClient
c ByteString
connId
    Just Async ()
_ -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    runActivation :: m ()
    runActivation :: m ()
runActivation = do
      AgentClient -> SndQueue -> EncryptionKey -> RetryInterval -> m ()
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> SndQueue -> EncryptionKey -> RetryInterval -> m ()
sendHello AgentClient
c SndQueue
sq EncryptionKey
verifyKey RetryInterval
retryInterval
      (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' ())
-> m ()
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' a)
-> m a
withStore ((forall (m' :: * -> *).
  (MonadUnliftIO m', MonadError StoreError m') =>
  SQLiteStore -> m' ())
 -> m ())
-> (forall (m' :: * -> *).
    (MonadUnliftIO m', MonadError StoreError m') =>
    SQLiteStore -> m' ())
-> m ()
forall a b. (a -> b) -> a -> b
$ \SQLiteStore
st -> SQLiteStore -> SndQueue -> QueueStatus -> m' ()
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> SndQueue -> QueueStatus -> m ()
setSndQueueStatus SQLiteStore
st SndQueue
sq QueueStatus
Active
      AgentClient -> ByteString -> m ()
forall (m :: * -> *).
MonadUnliftIO m =>
AgentClient -> ByteString -> m ()
removeActivation AgentClient
c ByteString
connId
      m ()
removeVerificationKey
      m ()
afterActivation
    removeVerificationKey :: m ()
    removeVerificationKey :: m ()
removeVerificationKey =
      let safeSignKey :: SignatureKey
safeSignKey = SignatureKey -> SignatureKey
C.removePublicKey (SignatureKey -> SignatureKey) -> SignatureKey -> SignatureKey
forall a b. (a -> b) -> a -> b
$ SndQueue -> SignatureKey
signKey SndQueue
sq
       in (forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' ())
-> m ()
forall (m :: * -> *) a.
AgentMonad m =>
(forall (m' :: * -> *).
 (MonadUnliftIO m', MonadError StoreError m') =>
 SQLiteStore -> m' a)
-> m a
withStore ((forall (m' :: * -> *).
  (MonadUnliftIO m', MonadError StoreError m') =>
  SQLiteStore -> m' ())
 -> m ())
-> (forall (m' :: * -> *).
    (MonadUnliftIO m', MonadError StoreError m') =>
    SQLiteStore -> m' ())
-> m ()
forall a b. (a -> b) -> a -> b
$ \SQLiteStore
st -> SQLiteStore -> SndQueue -> SignatureKey -> m' ()
forall s (m :: * -> *).
MonadAgentStore s m =>
s -> SndQueue -> SignatureKey -> m ()
updateSignKey SQLiteStore
st SndQueue
sq SignatureKey
safeSignKey

notifyConnected :: AgentMonad m => AgentClient -> ConnId -> m ()
notifyConnected :: AgentClient -> ByteString -> m ()
notifyConnected AgentClient
c ByteString
connId = 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 (AgentClient -> TBQueue (ATransmission 'Agent)
subQ AgentClient
c) (ByteString
"", ByteString
connId, ACommand 'Agent
CON)

newSndQueue ::
  (MonadUnliftIO m, MonadReader Env m) => SMPQueueUri -> EncryptionKey -> m (SndQueue, SenderPublicKey, VerificationKey)
newSndQueue :: SMPQueueUri
-> EncryptionKey -> m (SndQueue, EncryptionKey, EncryptionKey)
newSndQueue (SMPQueueUri SMPServer
smpServer ByteString
senderId EncryptionKey
_) EncryptionKey
encryptKey = 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
  (EncryptionKey
senderKey, SenderPrivateKey
sndPrivateKey) <- IO (EncryptionKey, SenderPrivateKey)
-> m (EncryptionKey, SenderPrivateKey)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (EncryptionKey, SenderPrivateKey)
 -> m (EncryptionKey, SenderPrivateKey))
-> IO (EncryptionKey, SenderPrivateKey)
-> m (EncryptionKey, SenderPrivateKey)
forall a b. (a -> b) -> a -> b
$ Int -> IO (EncryptionKey, SenderPrivateKey)
forall k. PrivateKey k => Int -> IO (KeyPair k)
C.generateKeyPair Int
size
  (EncryptionKey
verifyKey, SignatureKey
signKey) <- IO (EncryptionKey, SignatureKey) -> m (EncryptionKey, SignatureKey)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (EncryptionKey, SignatureKey)
 -> m (EncryptionKey, SignatureKey))
-> IO (EncryptionKey, SignatureKey)
-> m (EncryptionKey, SignatureKey)
forall a b. (a -> b) -> a -> b
$ Int -> IO (EncryptionKey, SignatureKey)
forall k. PrivateKey k => Int -> IO (KeyPair k)
C.generateKeyPair Int
size
  let sndQueue :: SndQueue
sndQueue =
        SndQueue :: SMPServer
-> ByteString
-> SenderPrivateKey
-> EncryptionKey
-> SignatureKey
-> QueueStatus
-> SndQueue
SndQueue
          { $sel:server:SndQueue :: SMPServer
server = SMPServer
smpServer,
            $sel:sndId:SndQueue :: ByteString
sndId = ByteString
senderId,
            SenderPrivateKey
$sel:sndPrivateKey:SndQueue :: SenderPrivateKey
sndPrivateKey :: SenderPrivateKey
sndPrivateKey,
            EncryptionKey
$sel:encryptKey:SndQueue :: EncryptionKey
encryptKey :: EncryptionKey
encryptKey,
            SignatureKey
signKey :: SignatureKey
$sel:signKey:SndQueue :: SignatureKey
signKey,
            $sel:status:SndQueue :: QueueStatus
status = QueueStatus
New
          }
  (SndQueue, EncryptionKey, EncryptionKey)
-> m (SndQueue, EncryptionKey, EncryptionKey)
forall (m :: * -> *) a. Monad m => a -> m a
return (SndQueue
sndQueue, EncryptionKey
senderKey, EncryptionKey
verifyKey)