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

module Simplex.Messaging.Agent.Client
  ( AgentClient (..),
    newAgentClient,
    AgentMonad,
    getSMPServerClient,
    closeSMPServerClients,
    newReceiveQueue,
    subscribeQueue,
    sendConfirmation,
    sendHello,
    secureQueue,
    sendAgentMessage,
    decryptAndVerify,
    verifyMessage,
    sendAck,
    suspendQueue,
    deleteQueue,
    logServer,
    removeSubscription,
    cryptoError,
  )
where

import Control.Logger.Simple
import Control.Monad.Except
import Control.Monad.IO.Unlift
import Control.Monad.Reader
import Control.Monad.Trans.Except
import Data.ByteString.Base64
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Set (Set)
import qualified Data.Set as S
import Data.Text.Encoding
import Data.Time.Clock
import Simplex.Messaging.Agent.Env.SQLite
import Simplex.Messaging.Agent.Protocol
import Simplex.Messaging.Agent.Store
import Simplex.Messaging.Client
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Protocol (ErrorType (AUTH), MsgBody, QueueId, SenderPublicKey)
import Simplex.Messaging.Util (bshow, liftEitherError, liftError)
import UnliftIO.Concurrent
import UnliftIO.Exception (IOException)
import qualified UnliftIO.Exception as E
import UnliftIO.STM

data AgentClient = AgentClient
  { AgentClient -> TBQueue (ATransmission 'Client)
rcvQ :: TBQueue (ATransmission 'Client),
    AgentClient -> TBQueue (ATransmission 'Agent)
sndQ :: TBQueue (ATransmission 'Agent),
    AgentClient -> TBQueue SMPServerTransmission
msgQ :: TBQueue SMPServerTransmission,
    AgentClient -> TVar (Map SMPServer SMPClient)
smpClients :: TVar (Map SMPServer SMPClient),
    AgentClient -> TVar (Map SMPServer (Set ConnAlias))
subscrSrvrs :: TVar (Map SMPServer (Set ConnAlias)),
    AgentClient -> TVar (Map ConnAlias SMPServer)
subscrConns :: TVar (Map ConnAlias SMPServer),
    AgentClient -> Int
clientId :: Int
  }

newAgentClient :: TVar Int -> AgentConfig -> STM AgentClient
newAgentClient :: TVar Int -> AgentConfig -> STM AgentClient
newAgentClient TVar Int
cc AgentConfig {Natural
$sel:tbqSize:AgentConfig :: AgentConfig -> Natural
tbqSize :: Natural
tbqSize} = do
  TBQueue (ATransmission 'Client)
rcvQ <- Natural -> STM (TBQueue (ATransmission 'Client))
forall a. Natural -> STM (TBQueue a)
newTBQueue Natural
tbqSize
  TBQueue (ATransmission 'Agent)
sndQ <- Natural -> STM (TBQueue (ATransmission 'Agent))
forall a. Natural -> STM (TBQueue a)
newTBQueue Natural
tbqSize
  TBQueue SMPServerTransmission
msgQ <- Natural -> STM (TBQueue SMPServerTransmission)
forall a. Natural -> STM (TBQueue a)
newTBQueue Natural
tbqSize
  TVar (Map SMPServer SMPClient)
smpClients <- Map SMPServer SMPClient -> STM (TVar (Map SMPServer SMPClient))
forall a. a -> STM (TVar a)
newTVar Map SMPServer SMPClient
forall k a. Map k a
M.empty
  TVar (Map SMPServer (Set ConnAlias))
subscrSrvrs <- Map SMPServer (Set ConnAlias)
-> STM (TVar (Map SMPServer (Set ConnAlias)))
forall a. a -> STM (TVar a)
newTVar Map SMPServer (Set ConnAlias)
forall k a. Map k a
M.empty
  TVar (Map ConnAlias SMPServer)
subscrConns <- Map ConnAlias SMPServer -> STM (TVar (Map ConnAlias SMPServer))
forall a. a -> STM (TVar a)
newTVar Map ConnAlias SMPServer
forall k a. Map k a
M.empty
  Int
clientId <- (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int -> Int) -> STM Int -> STM Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar Int -> STM Int
forall a. TVar a -> STM a
readTVar TVar Int
cc
  TVar Int -> Int -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Int
cc Int
clientId
  AgentClient -> STM AgentClient
forall (m :: * -> *) a. Monad m => a -> m a
return AgentClient :: TBQueue (ATransmission 'Client)
-> TBQueue (ATransmission 'Agent)
-> TBQueue SMPServerTransmission
-> TVar (Map SMPServer SMPClient)
-> TVar (Map SMPServer (Set ConnAlias))
-> TVar (Map ConnAlias SMPServer)
-> Int
-> AgentClient
AgentClient {TBQueue (ATransmission 'Client)
rcvQ :: TBQueue (ATransmission 'Client)
$sel:rcvQ:AgentClient :: TBQueue (ATransmission 'Client)
rcvQ, TBQueue (ATransmission 'Agent)
sndQ :: TBQueue (ATransmission 'Agent)
$sel:sndQ:AgentClient :: TBQueue (ATransmission 'Agent)
sndQ, TBQueue SMPServerTransmission
msgQ :: TBQueue SMPServerTransmission
$sel:msgQ:AgentClient :: TBQueue SMPServerTransmission
msgQ, TVar (Map SMPServer SMPClient)
smpClients :: TVar (Map SMPServer SMPClient)
$sel:smpClients:AgentClient :: TVar (Map SMPServer SMPClient)
smpClients, TVar (Map SMPServer (Set ConnAlias))
subscrSrvrs :: TVar (Map SMPServer (Set ConnAlias))
$sel:subscrSrvrs:AgentClient :: TVar (Map SMPServer (Set ConnAlias))
subscrSrvrs, TVar (Map ConnAlias SMPServer)
subscrConns :: TVar (Map ConnAlias SMPServer)
$sel:subscrConns:AgentClient :: TVar (Map ConnAlias SMPServer)
subscrConns, Int
clientId :: Int
$sel:clientId:AgentClient :: Int
clientId}

type AgentMonad m = (MonadUnliftIO m, MonadReader Env m, MonadError AgentErrorType m)

getSMPServerClient :: forall m. AgentMonad m => AgentClient -> SMPServer -> m SMPClient
getSMPServerClient :: AgentClient -> SMPServer -> m SMPClient
getSMPServerClient c :: AgentClient
c@AgentClient {TVar (Map SMPServer SMPClient)
smpClients :: TVar (Map SMPServer SMPClient)
$sel:smpClients:AgentClient :: AgentClient -> TVar (Map SMPServer SMPClient)
smpClients, TBQueue SMPServerTransmission
msgQ :: TBQueue SMPServerTransmission
$sel:msgQ:AgentClient :: AgentClient -> TBQueue SMPServerTransmission
msgQ} SMPServer
srv =
  TVar (Map SMPServer SMPClient) -> m (Map SMPServer SMPClient)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Map SMPServer SMPClient)
smpClients
    m (Map SMPServer SMPClient)
-> (Map SMPServer SMPClient -> m SMPClient) -> m SMPClient
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m SMPClient
-> (SMPClient -> m SMPClient) -> Maybe SMPClient -> m SMPClient
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m SMPClient
newSMPClient SMPClient -> m SMPClient
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SMPClient -> m SMPClient)
-> (Map SMPServer SMPClient -> Maybe SMPClient)
-> Map SMPServer SMPClient
-> m SMPClient
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SMPServer -> Map SMPServer SMPClient -> Maybe SMPClient
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup SMPServer
srv
  where
    newSMPClient :: m SMPClient
    newSMPClient :: m SMPClient
newSMPClient = do
      SMPClient
smp <- m SMPClient
connectClient
      Text -> m ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logInfo (Text -> m ()) -> (ConnAlias -> Text) -> ConnAlias -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnAlias -> Text
decodeUtf8 (ConnAlias -> m ()) -> ConnAlias -> m ()
forall a b. (a -> b) -> a -> b
$ ConnAlias
"Agent connected to " ConnAlias -> ConnAlias -> ConnAlias
forall a. Semigroup a => a -> a -> a
<> SMPServer -> ConnAlias
showServer SMPServer
srv
      STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ())
-> ((Map SMPServer SMPClient -> Map SMPServer SMPClient) -> STM ())
-> (Map SMPServer SMPClient -> Map SMPServer SMPClient)
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar (Map SMPServer SMPClient)
-> (Map SMPServer SMPClient -> Map SMPServer SMPClient) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Map SMPServer SMPClient)
smpClients ((Map SMPServer SMPClient -> Map SMPServer SMPClient) -> m ())
-> (Map SMPServer SMPClient -> Map SMPServer SMPClient) -> m ()
forall a b. (a -> b) -> a -> b
$ SMPServer
-> SMPClient -> Map SMPServer SMPClient -> Map SMPServer SMPClient
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert SMPServer
srv SMPClient
smp
      SMPClient -> m SMPClient
forall (m :: * -> *) a. Monad m => a -> m a
return SMPClient
smp

    connectClient :: m SMPClient
    connectClient :: m SMPClient
connectClient = do
      SMPClientConfig
cfg <- (Env -> SMPClientConfig) -> m SMPClientConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Env -> SMPClientConfig) -> m SMPClientConfig)
-> (Env -> SMPClientConfig) -> m SMPClientConfig
forall a b. (a -> b) -> a -> b
$ AgentConfig -> SMPClientConfig
smpCfg (AgentConfig -> SMPClientConfig)
-> (Env -> AgentConfig) -> Env -> SMPClientConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> AgentConfig
config
      (SMPClientError -> AgentErrorType)
-> IO (Either SMPClientError SMPClient) -> m SMPClient
forall (m :: * -> *) e' e a.
(MonadIO m, MonadError e' m) =>
(e -> e') -> IO (Either e a) -> m a
liftEitherError SMPClientError -> AgentErrorType
smpClientError (SMPServer
-> SMPClientConfig
-> TBQueue SMPServerTransmission
-> IO ()
-> IO (Either SMPClientError SMPClient)
getSMPClient SMPServer
srv SMPClientConfig
cfg TBQueue SMPServerTransmission
msgQ IO ()
clientDisconnected)
        m SMPClient -> (IOException -> m SMPClient) -> m SMPClient
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`E.catch` IOException -> m SMPClient
internalError
      where
        internalError :: IOException -> m SMPClient
        internalError :: IOException -> m SMPClient
internalError = AgentErrorType -> m SMPClient
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (AgentErrorType -> m SMPClient)
-> (IOException -> AgentErrorType) -> IOException -> m SMPClient
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> AgentErrorType
INTERNAL (String -> AgentErrorType)
-> (IOException -> String) -> IOException -> AgentErrorType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOException -> String
forall a. Show a => a -> String
show

    clientDisconnected :: IO ()
    clientDisconnected :: IO ()
clientDisconnected = do
      IO (Maybe (Set ConnAlias))
removeSubs IO (Maybe (Set ConnAlias))
-> (Maybe (Set ConnAlias) -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Set ConnAlias -> IO ()) -> Maybe (Set ConnAlias) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((ConnAlias -> IO ()) -> Set ConnAlias -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ConnAlias -> IO ()
notifySub)
      Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logInfo (Text -> IO ()) -> (ConnAlias -> Text) -> ConnAlias -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnAlias -> Text
decodeUtf8 (ConnAlias -> IO ()) -> ConnAlias -> IO ()
forall a b. (a -> b) -> a -> b
$ ConnAlias
"Agent disconnected from " ConnAlias -> ConnAlias -> ConnAlias
forall a. Semigroup a => a -> a -> a
<> SMPServer -> ConnAlias
showServer SMPServer
srv

    removeSubs :: IO (Maybe (Set ConnAlias))
    removeSubs :: IO (Maybe (Set ConnAlias))
removeSubs = STM (Maybe (Set ConnAlias)) -> IO (Maybe (Set ConnAlias))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Maybe (Set ConnAlias)) -> IO (Maybe (Set ConnAlias)))
-> STM (Maybe (Set ConnAlias)) -> IO (Maybe (Set ConnAlias))
forall a b. (a -> b) -> a -> b
$ do
      TVar (Map SMPServer SMPClient)
-> (Map SMPServer SMPClient -> Map SMPServer SMPClient) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Map SMPServer SMPClient)
smpClients ((Map SMPServer SMPClient -> Map SMPServer SMPClient) -> STM ())
-> (Map SMPServer SMPClient -> Map SMPServer SMPClient) -> STM ()
forall a b. (a -> b) -> a -> b
$ SMPServer -> Map SMPServer SMPClient -> Map SMPServer SMPClient
forall k a. Ord k => k -> Map k a -> Map k a
M.delete SMPServer
srv
      Maybe (Set ConnAlias)
cs <- SMPServer -> Map SMPServer (Set ConnAlias) -> Maybe (Set ConnAlias)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup SMPServer
srv (Map SMPServer (Set ConnAlias) -> Maybe (Set ConnAlias))
-> STM (Map SMPServer (Set ConnAlias))
-> STM (Maybe (Set ConnAlias))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map SMPServer (Set ConnAlias))
-> STM (Map SMPServer (Set ConnAlias))
forall a. TVar a -> STM a
readTVar (AgentClient -> TVar (Map SMPServer (Set ConnAlias))
subscrSrvrs AgentClient
c)
      TVar (Map SMPServer (Set ConnAlias))
-> (Map SMPServer (Set ConnAlias) -> Map SMPServer (Set ConnAlias))
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar (AgentClient -> TVar (Map SMPServer (Set ConnAlias))
subscrSrvrs AgentClient
c) ((Map SMPServer (Set ConnAlias) -> Map SMPServer (Set ConnAlias))
 -> STM ())
-> (Map SMPServer (Set ConnAlias) -> Map SMPServer (Set ConnAlias))
-> STM ()
forall a b. (a -> b) -> a -> b
$ SMPServer
-> Map SMPServer (Set ConnAlias) -> Map SMPServer (Set ConnAlias)
forall k a. Ord k => k -> Map k a -> Map k a
M.delete SMPServer
srv
      TVar (Map ConnAlias SMPServer)
-> (Map ConnAlias SMPServer -> Map ConnAlias SMPServer) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar (AgentClient -> TVar (Map ConnAlias SMPServer)
subscrConns AgentClient
c) ((Map ConnAlias SMPServer -> Map ConnAlias SMPServer) -> STM ())
-> (Map ConnAlias SMPServer -> Map ConnAlias SMPServer) -> STM ()
forall a b. (a -> b) -> a -> b
$ (Map ConnAlias SMPServer -> Map ConnAlias SMPServer)
-> (Set ConnAlias
    -> Map ConnAlias SMPServer -> Map ConnAlias SMPServer)
-> Maybe (Set ConnAlias)
-> Map ConnAlias SMPServer
-> Map ConnAlias SMPServer
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map ConnAlias SMPServer -> Map ConnAlias SMPServer
forall a. a -> a
id Set ConnAlias -> Map ConnAlias SMPServer -> Map ConnAlias SMPServer
forall k a. Ord k => Set k -> Map k a -> Map k a
deleteKeys Maybe (Set ConnAlias)
cs
      Maybe (Set ConnAlias) -> STM (Maybe (Set ConnAlias))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Set ConnAlias)
cs
      where
        deleteKeys :: Ord k => Set k -> Map k a -> Map k a
        deleteKeys :: Set k -> Map k a -> Map k a
deleteKeys Set k
ks Map k a
m = (k -> Map k a -> Map k a) -> Map k a -> Set k -> Map k a
forall a b. (a -> b -> b) -> b -> Set a -> b
S.foldr' k -> Map k a -> Map k a
forall k a. Ord k => k -> Map k a -> Map k a
M.delete Map k a
m Set k
ks

    notifySub :: ConnAlias -> IO ()
    notifySub :: ConnAlias -> IO ()
notifySub ConnAlias
connAlias = STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TBQueue (ATransmission 'Agent) -> ATransmission 'Agent -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue (AgentClient -> TBQueue (ATransmission 'Agent)
sndQ AgentClient
c) (CorrId
"", ConnAlias
connAlias, ACommand 'Agent
END)

closeSMPServerClients :: MonadUnliftIO m => AgentClient -> m ()
closeSMPServerClients :: AgentClient -> m ()
closeSMPServerClients AgentClient
c = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ TVar (Map SMPServer SMPClient) -> IO (Map SMPServer SMPClient)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (AgentClient -> TVar (Map SMPServer SMPClient)
smpClients AgentClient
c) IO (Map SMPServer SMPClient)
-> (Map SMPServer SMPClient -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (SMPClient -> IO ()) -> Map SMPServer SMPClient -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ SMPClient -> IO ()
closeSMPClient

withSMP_ :: forall a m. AgentMonad m => AgentClient -> SMPServer -> (SMPClient -> m a) -> m a
withSMP_ :: AgentClient -> SMPServer -> (SMPClient -> m a) -> m a
withSMP_ AgentClient
c SMPServer
srv SMPClient -> m a
action =
  (AgentClient -> SMPServer -> m SMPClient
forall (m :: * -> *).
AgentMonad m =>
AgentClient -> SMPServer -> m SMPClient
getSMPServerClient AgentClient
c SMPServer
srv m SMPClient -> (SMPClient -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SMPClient -> m a
action) m a -> (AgentErrorType -> m a) -> m a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` AgentErrorType -> m a
logServerError
  where
    logServerError :: AgentErrorType -> m a
    logServerError :: AgentErrorType -> m a
logServerError AgentErrorType
e = do
      ConnAlias
-> AgentClient -> SMPServer -> ConnAlias -> ConnAlias -> m ()
forall (m :: * -> *).
AgentMonad m =>
ConnAlias
-> AgentClient -> SMPServer -> ConnAlias -> ConnAlias -> m ()
logServer ConnAlias
"<--" AgentClient
c SMPServer
srv ConnAlias
"" (ConnAlias -> m ()) -> ConnAlias -> m ()
forall a b. (a -> b) -> a -> b
$ AgentErrorType -> ConnAlias
forall a. Show a => a -> ConnAlias
bshow AgentErrorType
e
      AgentErrorType -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError AgentErrorType
e

withLogSMP_ :: AgentMonad m => AgentClient -> SMPServer -> QueueId -> ByteString -> (SMPClient -> m a) -> m a
withLogSMP_ :: AgentClient
-> SMPServer -> ConnAlias -> ConnAlias -> (SMPClient -> m a) -> m a
withLogSMP_ AgentClient
c SMPServer
srv ConnAlias
qId ConnAlias
cmdStr SMPClient -> m a
action = do
  ConnAlias
-> AgentClient -> SMPServer -> ConnAlias -> ConnAlias -> m ()
forall (m :: * -> *).
AgentMonad m =>
ConnAlias
-> AgentClient -> SMPServer -> ConnAlias -> ConnAlias -> m ()
logServer ConnAlias
"-->" AgentClient
c SMPServer
srv ConnAlias
qId ConnAlias
cmdStr
  a
res <- AgentClient -> SMPServer -> (SMPClient -> m a) -> m a
forall a (m :: * -> *).
AgentMonad m =>
AgentClient -> SMPServer -> (SMPClient -> m a) -> m a
withSMP_ AgentClient
c SMPServer
srv SMPClient -> m a
action
  ConnAlias
-> AgentClient -> SMPServer -> ConnAlias -> ConnAlias -> m ()
forall (m :: * -> *).
AgentMonad m =>
ConnAlias
-> AgentClient -> SMPServer -> ConnAlias -> ConnAlias -> m ()
logServer ConnAlias
"<--" AgentClient
c SMPServer
srv ConnAlias
qId ConnAlias
"OK"
  a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res

withSMP :: AgentMonad m => AgentClient -> SMPServer -> (SMPClient -> ExceptT SMPClientError IO a) -> m a
withSMP :: AgentClient
-> SMPServer -> (SMPClient -> ExceptT SMPClientError IO a) -> m a
withSMP AgentClient
c SMPServer
srv SMPClient -> ExceptT SMPClientError IO a
action = AgentClient -> SMPServer -> (SMPClient -> m a) -> m a
forall a (m :: * -> *).
AgentMonad m =>
AgentClient -> SMPServer -> (SMPClient -> m a) -> m a
withSMP_ AgentClient
c SMPServer
srv ((SMPClient -> m a) -> m a) -> (SMPClient -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ ExceptT SMPClientError IO a -> m a
forall (m :: * -> *) a.
AgentMonad m =>
ExceptT SMPClientError IO a -> m a
liftSMP (ExceptT SMPClientError IO a -> m a)
-> (SMPClient -> ExceptT SMPClientError IO a) -> SMPClient -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SMPClient -> ExceptT SMPClientError IO a
action

withLogSMP :: AgentMonad m => AgentClient -> SMPServer -> QueueId -> ByteString -> (SMPClient -> ExceptT SMPClientError IO a) -> m a
withLogSMP :: AgentClient
-> SMPServer
-> ConnAlias
-> ConnAlias
-> (SMPClient -> ExceptT SMPClientError IO a)
-> m a
withLogSMP AgentClient
c SMPServer
srv ConnAlias
qId ConnAlias
cmdStr SMPClient -> ExceptT SMPClientError IO a
action = AgentClient
-> SMPServer -> ConnAlias -> ConnAlias -> (SMPClient -> m a) -> m a
forall (m :: * -> *) a.
AgentMonad m =>
AgentClient
-> SMPServer -> ConnAlias -> ConnAlias -> (SMPClient -> m a) -> m a
withLogSMP_ AgentClient
c SMPServer
srv ConnAlias
qId ConnAlias
cmdStr ((SMPClient -> m a) -> m a) -> (SMPClient -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ ExceptT SMPClientError IO a -> m a
forall (m :: * -> *) a.
AgentMonad m =>
ExceptT SMPClientError IO a -> m a
liftSMP (ExceptT SMPClientError IO a -> m a)
-> (SMPClient -> ExceptT SMPClientError IO a) -> SMPClient -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SMPClient -> ExceptT SMPClientError IO a
action

liftSMP :: AgentMonad m => ExceptT SMPClientError IO a -> m a
liftSMP :: ExceptT SMPClientError IO a -> m a
liftSMP = (SMPClientError -> AgentErrorType)
-> ExceptT SMPClientError IO a -> m a
forall (m :: * -> *) e' e a.
(MonadIO m, MonadError e' m) =>
(e -> e') -> ExceptT e IO a -> m a
liftError SMPClientError -> AgentErrorType
smpClientError

smpClientError :: SMPClientError -> AgentErrorType
smpClientError :: SMPClientError -> AgentErrorType
smpClientError = \case
  SMPServerError ErrorType
e -> ErrorType -> AgentErrorType
SMP ErrorType
e
  SMPResponseError ErrorType
e -> BrokerErrorType -> AgentErrorType
BROKER (BrokerErrorType -> AgentErrorType)
-> BrokerErrorType -> AgentErrorType
forall a b. (a -> b) -> a -> b
$ ErrorType -> BrokerErrorType
RESPONSE ErrorType
e
  SMPClientError
SMPUnexpectedResponse -> BrokerErrorType -> AgentErrorType
BROKER BrokerErrorType
UNEXPECTED
  SMPClientError
SMPResponseTimeout -> BrokerErrorType -> AgentErrorType
BROKER BrokerErrorType
TIMEOUT
  SMPClientError
SMPNetworkError -> BrokerErrorType -> AgentErrorType
BROKER BrokerErrorType
NETWORK
  SMPTransportError TransportError
e -> BrokerErrorType -> AgentErrorType
BROKER (BrokerErrorType -> AgentErrorType)
-> BrokerErrorType -> AgentErrorType
forall a b. (a -> b) -> a -> b
$ TransportError -> BrokerErrorType
TRANSPORT TransportError
e
  SMPClientError
e -> String -> AgentErrorType
INTERNAL (String -> AgentErrorType) -> String -> AgentErrorType
forall a b. (a -> b) -> a -> b
$ SMPClientError -> String
forall a. Show a => a -> String
show SMPClientError
e

newReceiveQueue :: AgentMonad m => AgentClient -> SMPServer -> ConnAlias -> m (RcvQueue, SMPQueueInfo)
newReceiveQueue :: AgentClient -> SMPServer -> ConnAlias -> m (RcvQueue, SMPQueueInfo)
newReceiveQueue AgentClient
c SMPServer
srv ConnAlias
connAlias = do
  Int
size <- (Env -> Int) -> m Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Env -> Int) -> m Int) -> (Env -> Int) -> m Int
forall a b. (a -> b) -> a -> b
$ AgentConfig -> Int
rsaKeySize (AgentConfig -> Int) -> (Env -> AgentConfig) -> Env -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> AgentConfig
config
  (PublicKey
recipientKey, RecipientPrivateKey
rcvPrivateKey) <- IO (PublicKey, RecipientPrivateKey)
-> m (PublicKey, RecipientPrivateKey)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (PublicKey, RecipientPrivateKey)
 -> m (PublicKey, RecipientPrivateKey))
-> IO (PublicKey, RecipientPrivateKey)
-> m (PublicKey, RecipientPrivateKey)
forall a b. (a -> b) -> a -> b
$ Int -> IO (PublicKey, RecipientPrivateKey)
forall k. PrivateKey k => Int -> IO (KeyPair k)
C.generateKeyPair Int
size
  ConnAlias
-> AgentClient -> SMPServer -> ConnAlias -> ConnAlias -> m ()
forall (m :: * -> *).
AgentMonad m =>
ConnAlias
-> AgentClient -> SMPServer -> ConnAlias -> ConnAlias -> m ()
logServer ConnAlias
"-->" AgentClient
c SMPServer
srv ConnAlias
"" ConnAlias
"NEW"
  (ConnAlias
rcvId, ConnAlias
sId) <- AgentClient
-> SMPServer
-> (SMPClient -> ExceptT SMPClientError IO (ConnAlias, ConnAlias))
-> m (ConnAlias, ConnAlias)
forall (m :: * -> *) a.
AgentMonad m =>
AgentClient
-> SMPServer -> (SMPClient -> ExceptT SMPClientError IO a) -> m a
withSMP AgentClient
c SMPServer
srv ((SMPClient -> ExceptT SMPClientError IO (ConnAlias, ConnAlias))
 -> m (ConnAlias, ConnAlias))
-> (SMPClient -> ExceptT SMPClientError IO (ConnAlias, ConnAlias))
-> m (ConnAlias, ConnAlias)
forall a b. (a -> b) -> a -> b
$ \SMPClient
smp -> SMPClient
-> RecipientPrivateKey
-> PublicKey
-> ExceptT SMPClientError IO (ConnAlias, ConnAlias)
createSMPQueue SMPClient
smp RecipientPrivateKey
rcvPrivateKey PublicKey
recipientKey
  ConnAlias
-> AgentClient -> SMPServer -> ConnAlias -> ConnAlias -> m ()
forall (m :: * -> *).
AgentMonad m =>
ConnAlias
-> AgentClient -> SMPServer -> ConnAlias -> ConnAlias -> m ()
logServer ConnAlias
"<--" AgentClient
c SMPServer
srv ConnAlias
"" (ConnAlias -> m ()) -> ConnAlias -> m ()
forall a b. (a -> b) -> a -> b
$ [ConnAlias] -> ConnAlias
B.unwords [ConnAlias
"IDS", ConnAlias -> ConnAlias
logSecret ConnAlias
rcvId, ConnAlias -> ConnAlias
logSecret ConnAlias
sId]
  (PublicKey
encryptKey, RecipientPrivateKey
decryptKey) <- IO (PublicKey, RecipientPrivateKey)
-> m (PublicKey, RecipientPrivateKey)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (PublicKey, RecipientPrivateKey)
 -> m (PublicKey, RecipientPrivateKey))
-> IO (PublicKey, RecipientPrivateKey)
-> m (PublicKey, RecipientPrivateKey)
forall a b. (a -> b) -> a -> b
$ Int -> IO (PublicKey, RecipientPrivateKey)
forall k. PrivateKey k => Int -> IO (KeyPair k)
C.generateKeyPair Int
size
  let rq :: RcvQueue
rq =
        RcvQueue :: SMPServer
-> ConnAlias
-> ConnAlias
-> RecipientPrivateKey
-> Maybe ConnAlias
-> Maybe PublicKey
-> RecipientPrivateKey
-> Maybe PublicKey
-> QueueStatus
-> RcvQueue
RcvQueue
          { $sel:server:RcvQueue :: SMPServer
server = SMPServer
srv,
            ConnAlias
$sel:rcvId:RcvQueue :: ConnAlias
rcvId :: ConnAlias
rcvId,
            ConnAlias
$sel:connAlias:RcvQueue :: ConnAlias
connAlias :: ConnAlias
connAlias,
            RecipientPrivateKey
$sel:rcvPrivateKey:RcvQueue :: RecipientPrivateKey
rcvPrivateKey :: RecipientPrivateKey
rcvPrivateKey,
            $sel:sndId:RcvQueue :: Maybe ConnAlias
sndId = ConnAlias -> Maybe ConnAlias
forall a. a -> Maybe a
Just ConnAlias
sId,
            $sel:sndKey:RcvQueue :: Maybe PublicKey
sndKey = Maybe PublicKey
forall a. Maybe a
Nothing,
            RecipientPrivateKey
$sel:decryptKey:RcvQueue :: RecipientPrivateKey
decryptKey :: RecipientPrivateKey
decryptKey,
            $sel:verifyKey:RcvQueue :: Maybe PublicKey
verifyKey = Maybe PublicKey
forall a. Maybe a
Nothing,
            $sel:status:RcvQueue :: QueueStatus
status = QueueStatus
New
          }
  AgentClient -> RcvQueue -> ConnAlias -> m ()
forall (m :: * -> *).
MonadUnliftIO m =>
AgentClient -> RcvQueue -> ConnAlias -> m ()
addSubscription AgentClient
c RcvQueue
rq ConnAlias
connAlias
  (RcvQueue, SMPQueueInfo) -> m (RcvQueue, SMPQueueInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (RcvQueue
rq, SMPServer -> ConnAlias -> PublicKey -> SMPQueueInfo
SMPQueueInfo SMPServer
srv ConnAlias
sId PublicKey
encryptKey)

subscribeQueue :: AgentMonad m => AgentClient -> RcvQueue -> ConnAlias -> m ()
subscribeQueue :: AgentClient -> RcvQueue -> ConnAlias -> m ()
subscribeQueue AgentClient
c rq :: RcvQueue
rq@RcvQueue {SMPServer
server :: SMPServer
$sel:server:RcvQueue :: RcvQueue -> SMPServer
server, RecipientPrivateKey
rcvPrivateKey :: RecipientPrivateKey
$sel:rcvPrivateKey:RcvQueue :: RcvQueue -> RecipientPrivateKey
rcvPrivateKey, ConnAlias
rcvId :: ConnAlias
$sel:rcvId:RcvQueue :: RcvQueue -> ConnAlias
rcvId} ConnAlias
connAlias = do
  AgentClient
-> SMPServer
-> ConnAlias
-> ConnAlias
-> (SMPClient -> ExceptT SMPClientError IO ())
-> m ()
forall (m :: * -> *) a.
AgentMonad m =>
AgentClient
-> SMPServer
-> ConnAlias
-> ConnAlias
-> (SMPClient -> ExceptT SMPClientError IO a)
-> m a
withLogSMP AgentClient
c SMPServer
server ConnAlias
rcvId ConnAlias
"SUB" ((SMPClient -> ExceptT SMPClientError IO ()) -> m ())
-> (SMPClient -> ExceptT SMPClientError IO ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \SMPClient
smp ->
    SMPClient
-> RecipientPrivateKey -> ConnAlias -> ExceptT SMPClientError IO ()
subscribeSMPQueue SMPClient
smp RecipientPrivateKey
rcvPrivateKey ConnAlias
rcvId
  AgentClient -> RcvQueue -> ConnAlias -> m ()
forall (m :: * -> *).
MonadUnliftIO m =>
AgentClient -> RcvQueue -> ConnAlias -> m ()
addSubscription AgentClient
c RcvQueue
rq ConnAlias
connAlias

addSubscription :: MonadUnliftIO m => AgentClient -> RcvQueue -> ConnAlias -> m ()
addSubscription :: AgentClient -> RcvQueue -> ConnAlias -> m ()
addSubscription AgentClient
c RcvQueue {SMPServer
server :: SMPServer
$sel:server:RcvQueue :: RcvQueue -> SMPServer
server} ConnAlias
connAlias = STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  TVar (Map ConnAlias SMPServer)
-> (Map ConnAlias SMPServer -> Map ConnAlias SMPServer) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar (AgentClient -> TVar (Map ConnAlias SMPServer)
subscrConns AgentClient
c) ((Map ConnAlias SMPServer -> Map ConnAlias SMPServer) -> STM ())
-> (Map ConnAlias SMPServer -> Map ConnAlias SMPServer) -> STM ()
forall a b. (a -> b) -> a -> b
$ ConnAlias
-> SMPServer -> Map ConnAlias SMPServer -> Map ConnAlias SMPServer
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert ConnAlias
connAlias SMPServer
server
  TVar (Map SMPServer (Set ConnAlias))
-> (Map SMPServer (Set ConnAlias) -> Map SMPServer (Set ConnAlias))
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar (AgentClient -> TVar (Map SMPServer (Set ConnAlias))
subscrSrvrs AgentClient
c) ((Map SMPServer (Set ConnAlias) -> Map SMPServer (Set ConnAlias))
 -> STM ())
-> (Map SMPServer (Set ConnAlias) -> Map SMPServer (Set ConnAlias))
-> STM ()
forall a b. (a -> b) -> a -> b
$ (Maybe (Set ConnAlias) -> Maybe (Set ConnAlias))
-> SMPServer
-> Map SMPServer (Set ConnAlias)
-> Map SMPServer (Set ConnAlias)
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter (Set ConnAlias -> Maybe (Set ConnAlias)
forall a. a -> Maybe a
Just (Set ConnAlias -> Maybe (Set ConnAlias))
-> (Maybe (Set ConnAlias) -> Set ConnAlias)
-> Maybe (Set ConnAlias)
-> Maybe (Set ConnAlias)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Set ConnAlias) -> Set ConnAlias
addSub) SMPServer
server
  where
    addSub :: Maybe (Set ConnAlias) -> Set ConnAlias
    addSub :: Maybe (Set ConnAlias) -> Set ConnAlias
addSub (Just Set ConnAlias
cs) = ConnAlias -> Set ConnAlias -> Set ConnAlias
forall a. Ord a => a -> Set a -> Set a
S.insert ConnAlias
connAlias Set ConnAlias
cs
    addSub Maybe (Set ConnAlias)
_ = ConnAlias -> Set ConnAlias
forall a. a -> Set a
S.singleton ConnAlias
connAlias

removeSubscription :: AgentMonad m => AgentClient -> ConnAlias -> m ()
removeSubscription :: AgentClient -> ConnAlias -> m ()
removeSubscription AgentClient {TVar (Map ConnAlias SMPServer)
subscrConns :: TVar (Map ConnAlias SMPServer)
$sel:subscrConns:AgentClient :: AgentClient -> TVar (Map ConnAlias SMPServer)
subscrConns, TVar (Map SMPServer (Set ConnAlias))
subscrSrvrs :: TVar (Map SMPServer (Set ConnAlias))
$sel:subscrSrvrs:AgentClient :: AgentClient -> TVar (Map SMPServer (Set ConnAlias))
subscrSrvrs} ConnAlias
connAlias = STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  Map ConnAlias SMPServer
cs <- TVar (Map ConnAlias SMPServer) -> STM (Map ConnAlias SMPServer)
forall a. TVar a -> STM a
readTVar TVar (Map ConnAlias SMPServer)
subscrConns
  TVar (Map ConnAlias SMPServer) -> Map ConnAlias SMPServer -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Map ConnAlias SMPServer)
subscrConns (Map ConnAlias SMPServer -> STM ())
-> Map ConnAlias SMPServer -> STM ()
forall a b. (a -> b) -> a -> b
$ ConnAlias -> Map ConnAlias SMPServer -> Map ConnAlias SMPServer
forall k a. Ord k => k -> Map k a -> Map k a
M.delete ConnAlias
connAlias Map ConnAlias SMPServer
cs
  (SMPServer -> STM ()) -> Maybe SMPServer -> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
    (TVar (Map SMPServer (Set ConnAlias))
-> (Map SMPServer (Set ConnAlias) -> Map SMPServer (Set ConnAlias))
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Map SMPServer (Set ConnAlias))
subscrSrvrs ((Map SMPServer (Set ConnAlias) -> Map SMPServer (Set ConnAlias))
 -> STM ())
-> (SMPServer
    -> Map SMPServer (Set ConnAlias) -> Map SMPServer (Set ConnAlias))
-> SMPServer
-> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (Set ConnAlias) -> Maybe (Set ConnAlias))
-> SMPServer
-> Map SMPServer (Set ConnAlias)
-> Map SMPServer (Set ConnAlias)
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter (Maybe (Set ConnAlias)
-> (Set ConnAlias -> Maybe (Set ConnAlias))
-> Maybe (Set ConnAlias)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Set ConnAlias -> Maybe (Set ConnAlias)
delSub))
    (ConnAlias -> Map ConnAlias SMPServer -> Maybe SMPServer
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ConnAlias
connAlias Map ConnAlias SMPServer
cs)
  where
    delSub :: Set ConnAlias -> Maybe (Set ConnAlias)
    delSub :: Set ConnAlias -> Maybe (Set ConnAlias)
delSub Set ConnAlias
cs =
      let cs' :: Set ConnAlias
cs' = ConnAlias -> Set ConnAlias -> Set ConnAlias
forall a. Ord a => a -> Set a -> Set a
S.delete ConnAlias
connAlias Set ConnAlias
cs
       in if Set ConnAlias -> Bool
forall a. Set a -> Bool
S.null Set ConnAlias
cs' then Maybe (Set ConnAlias)
forall a. Maybe a
Nothing else Set ConnAlias -> Maybe (Set ConnAlias)
forall a. a -> Maybe a
Just Set ConnAlias
cs'

logServer :: AgentMonad m => ByteString -> AgentClient -> SMPServer -> QueueId -> ByteString -> m ()
logServer :: ConnAlias
-> AgentClient -> SMPServer -> ConnAlias -> ConnAlias -> m ()
logServer ConnAlias
dir AgentClient {Int
clientId :: Int
$sel:clientId:AgentClient :: AgentClient -> Int
clientId} SMPServer
srv ConnAlias
qId ConnAlias
cmdStr =
  Text -> m ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logInfo (Text -> m ()) -> (ConnAlias -> Text) -> ConnAlias -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnAlias -> Text
decodeUtf8 (ConnAlias -> m ()) -> ConnAlias -> m ()
forall a b. (a -> b) -> a -> b
$ [ConnAlias] -> ConnAlias
B.unwords [ConnAlias
"A", ConnAlias
"(" ConnAlias -> ConnAlias -> ConnAlias
forall a. Semigroup a => a -> a -> a
<> Int -> ConnAlias
forall a. Show a => a -> ConnAlias
bshow Int
clientId ConnAlias -> ConnAlias -> ConnAlias
forall a. Semigroup a => a -> a -> a
<> ConnAlias
")", ConnAlias
dir, SMPServer -> ConnAlias
showServer SMPServer
srv, ConnAlias
":", ConnAlias -> ConnAlias
logSecret ConnAlias
qId, ConnAlias
cmdStr]

showServer :: SMPServer -> ByteString
showServer :: SMPServer -> ConnAlias
showServer SMPServer
srv = String -> ConnAlias
B.pack (String -> ConnAlias) -> String -> ConnAlias
forall a b. (a -> b) -> a -> b
$ SMPServer -> String
host SMPServer
srv String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (String
":" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) (SMPServer -> Maybe String
port SMPServer
srv)

logSecret :: ByteString -> ByteString
logSecret :: ConnAlias -> ConnAlias
logSecret ConnAlias
bs = ConnAlias -> ConnAlias
encode (ConnAlias -> ConnAlias) -> ConnAlias -> ConnAlias
forall a b. (a -> b) -> a -> b
$ Int -> ConnAlias -> ConnAlias
B.take Int
3 ConnAlias
bs

sendConfirmation :: forall m. AgentMonad m => AgentClient -> SndQueue -> SenderPublicKey -> m ()
sendConfirmation :: AgentClient -> SndQueue -> PublicKey -> m ()
sendConfirmation AgentClient
c sq :: SndQueue
sq@SndQueue {SMPServer
$sel:server:SndQueue :: SndQueue -> SMPServer
server :: SMPServer
server, ConnAlias
$sel:sndId:SndQueue :: SndQueue -> ConnAlias
sndId :: ConnAlias
sndId} PublicKey
senderKey =
  AgentClient
-> SMPServer
-> ConnAlias
-> ConnAlias
-> (SMPClient -> m ())
-> m ()
forall (m :: * -> *) a.
AgentMonad m =>
AgentClient
-> SMPServer -> ConnAlias -> ConnAlias -> (SMPClient -> m a) -> m a
withLogSMP_ AgentClient
c SMPServer
server ConnAlias
sndId ConnAlias
"SEND <KEY>" ((SMPClient -> m ()) -> m ()) -> (SMPClient -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \SMPClient
smp -> do
    ConnAlias
msg <- SMPClient -> m ConnAlias
mkConfirmation SMPClient
smp
    ExceptT SMPClientError IO () -> m ()
forall (m :: * -> *) a.
AgentMonad m =>
ExceptT SMPClientError IO a -> m a
liftSMP (ExceptT SMPClientError IO () -> m ())
-> ExceptT SMPClientError IO () -> m ()
forall a b. (a -> b) -> a -> b
$ SMPClient
-> Maybe RecipientPrivateKey
-> ConnAlias
-> ConnAlias
-> ExceptT SMPClientError IO ()
sendSMPMessage SMPClient
smp Maybe RecipientPrivateKey
forall a. Maybe a
Nothing ConnAlias
sndId ConnAlias
msg
  where
    mkConfirmation :: SMPClient -> m MsgBody
    mkConfirmation :: SMPClient -> m ConnAlias
mkConfirmation SMPClient
smp = SMPClient -> SndQueue -> ConnAlias -> m ConnAlias
forall (m :: * -> *).
AgentMonad m =>
SMPClient -> SndQueue -> ConnAlias -> m ConnAlias
encryptAndSign SMPClient
smp SndQueue
sq (ConnAlias -> m ConnAlias)
-> (SMPMessage -> ConnAlias) -> SMPMessage -> m ConnAlias
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SMPMessage -> ConnAlias
serializeSMPMessage (SMPMessage -> m ConnAlias) -> SMPMessage -> m ConnAlias
forall a b. (a -> b) -> a -> b
$ PublicKey -> SMPMessage
SMPConfirmation PublicKey
senderKey

sendHello :: forall m. AgentMonad m => AgentClient -> SndQueue -> VerificationKey -> m ()
sendHello :: AgentClient -> SndQueue -> PublicKey -> m ()
sendHello AgentClient
c sq :: SndQueue
sq@SndQueue {SMPServer
server :: SMPServer
$sel:server:SndQueue :: SndQueue -> SMPServer
server, ConnAlias
sndId :: ConnAlias
$sel:sndId:SndQueue :: SndQueue -> ConnAlias
sndId, RecipientPrivateKey
$sel:sndPrivateKey:SndQueue :: SndQueue -> RecipientPrivateKey
sndPrivateKey :: RecipientPrivateKey
sndPrivateKey} PublicKey
verifyKey =
  AgentClient
-> SMPServer
-> ConnAlias
-> ConnAlias
-> (SMPClient -> m ())
-> m ()
forall (m :: * -> *) a.
AgentMonad m =>
AgentClient
-> SMPServer -> ConnAlias -> ConnAlias -> (SMPClient -> m a) -> m a
withLogSMP_ AgentClient
c SMPServer
server ConnAlias
sndId ConnAlias
"SEND <HELLO> (retrying)" ((SMPClient -> m ()) -> m ()) -> (SMPClient -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \SMPClient
smp -> do
    ConnAlias
msg <- SMPClient -> AckMode -> m ConnAlias
mkHello SMPClient
smp (AckMode -> m ConnAlias) -> AckMode -> m ConnAlias
forall a b. (a -> b) -> a -> b
$ OnOff -> AckMode
AckMode OnOff
On
    ExceptT SMPClientError IO () -> m ()
forall (m :: * -> *) a.
AgentMonad m =>
ExceptT SMPClientError IO a -> m a
liftSMP (ExceptT SMPClientError IO () -> m ())
-> ExceptT SMPClientError IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Int
-> Int -> ConnAlias -> SMPClient -> ExceptT SMPClientError IO ()
send Int
8 Int
100000 ConnAlias
msg SMPClient
smp
  where
    mkHello :: SMPClient -> AckMode -> m ByteString
    mkHello :: SMPClient -> AckMode -> m ConnAlias
mkHello SMPClient
smp AckMode
ackMode = do
      UTCTime
senderTimestamp <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
      SMPClient -> SndQueue -> ConnAlias -> m ConnAlias
forall (m :: * -> *).
AgentMonad m =>
SMPClient -> SndQueue -> ConnAlias -> m ConnAlias
encryptAndSign SMPClient
smp SndQueue
sq (ConnAlias -> m ConnAlias)
-> (SMPMessage -> ConnAlias) -> SMPMessage -> m ConnAlias
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SMPMessage -> ConnAlias
serializeSMPMessage (SMPMessage -> m ConnAlias) -> SMPMessage -> m ConnAlias
forall a b. (a -> b) -> a -> b
$
        SMPMessage :: AgentMsgId -> UTCTime -> ConnAlias -> AMessage -> SMPMessage
SMPMessage
          { senderMsgId :: AgentMsgId
senderMsgId = AgentMsgId
0,
            UTCTime
senderTimestamp :: UTCTime
senderTimestamp :: UTCTime
senderTimestamp,
            previousMsgHash :: ConnAlias
previousMsgHash = ConnAlias
"",
            agentMessage :: AMessage
agentMessage = PublicKey -> AckMode -> AMessage
HELLO PublicKey
verifyKey AckMode
ackMode
          }

    send :: Int -> Int -> ByteString -> SMPClient -> ExceptT SMPClientError IO ()
    send :: Int
-> Int -> ConnAlias -> SMPClient -> ExceptT SMPClientError IO ()
send Int
0 Int
_ ConnAlias
_ SMPClient
_ = SMPClientError -> ExceptT SMPClientError IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (SMPClientError -> ExceptT SMPClientError IO ())
-> SMPClientError -> ExceptT SMPClientError IO ()
forall a b. (a -> b) -> a -> b
$ ErrorType -> SMPClientError
SMPServerError ErrorType
AUTH
    send Int
retry Int
delay ConnAlias
msg SMPClient
smp =
      SMPClient
-> Maybe RecipientPrivateKey
-> ConnAlias
-> ConnAlias
-> ExceptT SMPClientError IO ()
sendSMPMessage SMPClient
smp (RecipientPrivateKey -> Maybe RecipientPrivateKey
forall a. a -> Maybe a
Just RecipientPrivateKey
sndPrivateKey) ConnAlias
sndId ConnAlias
msg ExceptT SMPClientError IO ()
-> (SMPClientError -> ExceptT SMPClientError IO ())
-> ExceptT SMPClientError IO ()
forall (m :: * -> *) e a e'.
Monad m =>
ExceptT e m a -> (e -> ExceptT e' m a) -> ExceptT e' m a
`catchE` \case
        SMPServerError ErrorType
AUTH -> do
          Int -> ExceptT SMPClientError IO ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay Int
delay
          Int
-> Int -> ConnAlias -> SMPClient -> ExceptT SMPClientError IO ()
send (Int
retry Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int
delay Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
3 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) ConnAlias
msg SMPClient
smp
        SMPClientError
e -> SMPClientError -> ExceptT SMPClientError IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE SMPClientError
e

secureQueue :: AgentMonad m => AgentClient -> RcvQueue -> SenderPublicKey -> m ()
secureQueue :: AgentClient -> RcvQueue -> PublicKey -> m ()
secureQueue AgentClient
c RcvQueue {SMPServer
server :: SMPServer
$sel:server:RcvQueue :: RcvQueue -> SMPServer
server, ConnAlias
rcvId :: ConnAlias
$sel:rcvId:RcvQueue :: RcvQueue -> ConnAlias
rcvId, RecipientPrivateKey
rcvPrivateKey :: RecipientPrivateKey
$sel:rcvPrivateKey:RcvQueue :: RcvQueue -> RecipientPrivateKey
rcvPrivateKey} PublicKey
senderKey =
  AgentClient
-> SMPServer
-> ConnAlias
-> ConnAlias
-> (SMPClient -> ExceptT SMPClientError IO ())
-> m ()
forall (m :: * -> *) a.
AgentMonad m =>
AgentClient
-> SMPServer
-> ConnAlias
-> ConnAlias
-> (SMPClient -> ExceptT SMPClientError IO a)
-> m a
withLogSMP AgentClient
c SMPServer
server ConnAlias
rcvId ConnAlias
"KEY <key>" ((SMPClient -> ExceptT SMPClientError IO ()) -> m ())
-> (SMPClient -> ExceptT SMPClientError IO ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \SMPClient
smp ->
    SMPClient
-> RecipientPrivateKey
-> ConnAlias
-> PublicKey
-> ExceptT SMPClientError IO ()
secureSMPQueue SMPClient
smp RecipientPrivateKey
rcvPrivateKey ConnAlias
rcvId PublicKey
senderKey

sendAck :: AgentMonad m => AgentClient -> RcvQueue -> m ()
sendAck :: AgentClient -> RcvQueue -> m ()
sendAck AgentClient
c RcvQueue {SMPServer
server :: SMPServer
$sel:server:RcvQueue :: RcvQueue -> SMPServer
server, ConnAlias
rcvId :: ConnAlias
$sel:rcvId:RcvQueue :: RcvQueue -> ConnAlias
rcvId, RecipientPrivateKey
rcvPrivateKey :: RecipientPrivateKey
$sel:rcvPrivateKey:RcvQueue :: RcvQueue -> RecipientPrivateKey
rcvPrivateKey} =
  AgentClient
-> SMPServer
-> ConnAlias
-> ConnAlias
-> (SMPClient -> ExceptT SMPClientError IO ())
-> m ()
forall (m :: * -> *) a.
AgentMonad m =>
AgentClient
-> SMPServer
-> ConnAlias
-> ConnAlias
-> (SMPClient -> ExceptT SMPClientError IO a)
-> m a
withLogSMP AgentClient
c SMPServer
server ConnAlias
rcvId ConnAlias
"ACK" ((SMPClient -> ExceptT SMPClientError IO ()) -> m ())
-> (SMPClient -> ExceptT SMPClientError IO ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \SMPClient
smp ->
    SMPClient
-> RecipientPrivateKey -> ConnAlias -> ExceptT SMPClientError IO ()
ackSMPMessage SMPClient
smp RecipientPrivateKey
rcvPrivateKey ConnAlias
rcvId

suspendQueue :: AgentMonad m => AgentClient -> RcvQueue -> m ()
suspendQueue :: AgentClient -> RcvQueue -> m ()
suspendQueue AgentClient
c RcvQueue {SMPServer
server :: SMPServer
$sel:server:RcvQueue :: RcvQueue -> SMPServer
server, ConnAlias
rcvId :: ConnAlias
$sel:rcvId:RcvQueue :: RcvQueue -> ConnAlias
rcvId, RecipientPrivateKey
rcvPrivateKey :: RecipientPrivateKey
$sel:rcvPrivateKey:RcvQueue :: RcvQueue -> RecipientPrivateKey
rcvPrivateKey} =
  AgentClient
-> SMPServer
-> ConnAlias
-> ConnAlias
-> (SMPClient -> ExceptT SMPClientError IO ())
-> m ()
forall (m :: * -> *) a.
AgentMonad m =>
AgentClient
-> SMPServer
-> ConnAlias
-> ConnAlias
-> (SMPClient -> ExceptT SMPClientError IO a)
-> m a
withLogSMP AgentClient
c SMPServer
server ConnAlias
rcvId ConnAlias
"OFF" ((SMPClient -> ExceptT SMPClientError IO ()) -> m ())
-> (SMPClient -> ExceptT SMPClientError IO ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \SMPClient
smp ->
    SMPClient
-> RecipientPrivateKey -> ConnAlias -> ExceptT SMPClientError IO ()
suspendSMPQueue SMPClient
smp RecipientPrivateKey
rcvPrivateKey ConnAlias
rcvId

deleteQueue :: AgentMonad m => AgentClient -> RcvQueue -> m ()
deleteQueue :: AgentClient -> RcvQueue -> m ()
deleteQueue AgentClient
c RcvQueue {SMPServer
server :: SMPServer
$sel:server:RcvQueue :: RcvQueue -> SMPServer
server, ConnAlias
rcvId :: ConnAlias
$sel:rcvId:RcvQueue :: RcvQueue -> ConnAlias
rcvId, RecipientPrivateKey
rcvPrivateKey :: RecipientPrivateKey
$sel:rcvPrivateKey:RcvQueue :: RcvQueue -> RecipientPrivateKey
rcvPrivateKey} =
  AgentClient
-> SMPServer
-> ConnAlias
-> ConnAlias
-> (SMPClient -> ExceptT SMPClientError IO ())
-> m ()
forall (m :: * -> *) a.
AgentMonad m =>
AgentClient
-> SMPServer
-> ConnAlias
-> ConnAlias
-> (SMPClient -> ExceptT SMPClientError IO a)
-> m a
withLogSMP AgentClient
c SMPServer
server ConnAlias
rcvId ConnAlias
"DEL" ((SMPClient -> ExceptT SMPClientError IO ()) -> m ())
-> (SMPClient -> ExceptT SMPClientError IO ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \SMPClient
smp ->
    SMPClient
-> RecipientPrivateKey -> ConnAlias -> ExceptT SMPClientError IO ()
deleteSMPQueue SMPClient
smp RecipientPrivateKey
rcvPrivateKey ConnAlias
rcvId

sendAgentMessage :: AgentMonad m => AgentClient -> SndQueue -> ByteString -> m ()
sendAgentMessage :: AgentClient -> SndQueue -> ConnAlias -> m ()
sendAgentMessage AgentClient
c sq :: SndQueue
sq@SndQueue {SMPServer
server :: SMPServer
$sel:server:SndQueue :: SndQueue -> SMPServer
server, ConnAlias
sndId :: ConnAlias
$sel:sndId:SndQueue :: SndQueue -> ConnAlias
sndId, RecipientPrivateKey
sndPrivateKey :: RecipientPrivateKey
$sel:sndPrivateKey:SndQueue :: SndQueue -> RecipientPrivateKey
sndPrivateKey} ConnAlias
msg =
  AgentClient
-> SMPServer
-> ConnAlias
-> ConnAlias
-> (SMPClient -> m ())
-> m ()
forall (m :: * -> *) a.
AgentMonad m =>
AgentClient
-> SMPServer -> ConnAlias -> ConnAlias -> (SMPClient -> m a) -> m a
withLogSMP_ AgentClient
c SMPServer
server ConnAlias
sndId ConnAlias
"SEND <message>" ((SMPClient -> m ()) -> m ()) -> (SMPClient -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \SMPClient
smp -> do
    ConnAlias
msg' <- SMPClient -> SndQueue -> ConnAlias -> m ConnAlias
forall (m :: * -> *).
AgentMonad m =>
SMPClient -> SndQueue -> ConnAlias -> m ConnAlias
encryptAndSign SMPClient
smp SndQueue
sq ConnAlias
msg
    ExceptT SMPClientError IO () -> m ()
forall (m :: * -> *) a.
AgentMonad m =>
ExceptT SMPClientError IO a -> m a
liftSMP (ExceptT SMPClientError IO () -> m ())
-> ExceptT SMPClientError IO () -> m ()
forall a b. (a -> b) -> a -> b
$ SMPClient
-> Maybe RecipientPrivateKey
-> ConnAlias
-> ConnAlias
-> ExceptT SMPClientError IO ()
sendSMPMessage SMPClient
smp (RecipientPrivateKey -> Maybe RecipientPrivateKey
forall a. a -> Maybe a
Just RecipientPrivateKey
sndPrivateKey) ConnAlias
sndId ConnAlias
msg'

encryptAndSign :: AgentMonad m => SMPClient -> SndQueue -> ByteString -> m ByteString
encryptAndSign :: SMPClient -> SndQueue -> ConnAlias -> m ConnAlias
encryptAndSign SMPClient
smp SndQueue {PublicKey
$sel:encryptKey:SndQueue :: SndQueue -> PublicKey
encryptKey :: PublicKey
encryptKey, RecipientPrivateKey
$sel:signKey:SndQueue :: SndQueue -> RecipientPrivateKey
signKey :: RecipientPrivateKey
signKey} ConnAlias
msg = do
  Int
paddedSize <- (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
$ (SMPClient -> Int
blockSize SMPClient
smp Int -> Int -> Int
forall a. Num a => a -> a -> a
-) (Int -> Int) -> (Env -> Int) -> Env -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> Int
reservedMsgSize
  (CryptoError -> AgentErrorType)
-> ExceptT CryptoError IO ConnAlias -> m ConnAlias
forall (m :: * -> *) e' e a.
(MonadIO m, MonadError e' m) =>
(e -> e') -> ExceptT e IO a -> m a
liftError CryptoError -> AgentErrorType
cryptoError (ExceptT CryptoError IO ConnAlias -> m ConnAlias)
-> ExceptT CryptoError IO ConnAlias -> m ConnAlias
forall a b. (a -> b) -> a -> b
$ do
    ConnAlias
enc <- PublicKey -> Int -> ConnAlias -> ExceptT CryptoError IO ConnAlias
C.encrypt PublicKey
encryptKey Int
paddedSize ConnAlias
msg
    C.Signature ConnAlias
sig <- RecipientPrivateKey
-> ConnAlias -> ExceptT CryptoError IO Signature
forall k.
PrivateKey k =>
k -> ConnAlias -> ExceptT CryptoError IO Signature
C.sign RecipientPrivateKey
signKey ConnAlias
enc
    ConnAlias -> ExceptT CryptoError IO ConnAlias
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConnAlias -> ExceptT CryptoError IO ConnAlias)
-> ConnAlias -> ExceptT CryptoError IO ConnAlias
forall a b. (a -> b) -> a -> b
$ ConnAlias
sig ConnAlias -> ConnAlias -> ConnAlias
forall a. Semigroup a => a -> a -> a
<> ConnAlias
enc

decryptAndVerify :: AgentMonad m => RcvQueue -> ByteString -> m ByteString
decryptAndVerify :: RcvQueue -> ConnAlias -> m ConnAlias
decryptAndVerify RcvQueue {RecipientPrivateKey
decryptKey :: RecipientPrivateKey
$sel:decryptKey:RcvQueue :: RcvQueue -> RecipientPrivateKey
decryptKey, Maybe PublicKey
verifyKey :: Maybe PublicKey
$sel:verifyKey:RcvQueue :: RcvQueue -> Maybe PublicKey
verifyKey} ConnAlias
msg =
  Maybe PublicKey -> ConnAlias -> m ConnAlias
forall (m :: * -> *).
AgentMonad m =>
Maybe PublicKey -> ConnAlias -> m ConnAlias
verifyMessage Maybe PublicKey
verifyKey ConnAlias
msg
    m ConnAlias -> (ConnAlias -> m ConnAlias) -> m ConnAlias
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (CryptoError -> AgentErrorType)
-> ExceptT CryptoError IO ConnAlias -> m ConnAlias
forall (m :: * -> *) e' e a.
(MonadIO m, MonadError e' m) =>
(e -> e') -> ExceptT e IO a -> m a
liftError CryptoError -> AgentErrorType
cryptoError (ExceptT CryptoError IO ConnAlias -> m ConnAlias)
-> (ConnAlias -> ExceptT CryptoError IO ConnAlias)
-> ConnAlias
-> m ConnAlias
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecipientPrivateKey
-> ConnAlias -> ExceptT CryptoError IO ConnAlias
forall k.
PrivateKey k =>
k -> ConnAlias -> ExceptT CryptoError IO ConnAlias
C.decrypt RecipientPrivateKey
decryptKey

verifyMessage :: AgentMonad m => Maybe VerificationKey -> ByteString -> m ByteString
verifyMessage :: Maybe PublicKey -> ConnAlias -> m ConnAlias
verifyMessage Maybe PublicKey
verifyKey ConnAlias
msg = 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
  let (ConnAlias
sig, ConnAlias
enc) = Int -> ConnAlias -> (ConnAlias, ConnAlias)
B.splitAt Int
size ConnAlias
msg
  case Maybe PublicKey
verifyKey of
    Maybe PublicKey
Nothing -> ConnAlias -> m ConnAlias
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConnAlias
enc
    Just PublicKey
k
      | PublicKey -> Signature -> ConnAlias -> Bool
C.verify PublicKey
k (ConnAlias -> Signature
C.Signature ConnAlias
sig) ConnAlias
enc -> ConnAlias -> m ConnAlias
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConnAlias
enc
      | Bool
otherwise -> AgentErrorType -> m ConnAlias
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (AgentErrorType -> m ConnAlias) -> AgentErrorType -> m ConnAlias
forall a b. (a -> b) -> a -> b
$ SMPAgentError -> AgentErrorType
AGENT SMPAgentError
A_SIGNATURE

cryptoError :: C.CryptoError -> AgentErrorType
cryptoError :: CryptoError -> AgentErrorType
cryptoError = \case
  CryptoError
C.CryptoLargeMsgError -> CommandErrorType -> AgentErrorType
CMD CommandErrorType
LARGE
  C.RSADecryptError Error
_ -> SMPAgentError -> AgentErrorType
AGENT SMPAgentError
A_ENCRYPTION
  C.CryptoHeaderError String
_ -> SMPAgentError -> AgentErrorType
AGENT SMPAgentError
A_ENCRYPTION
  CryptoError
C.AESDecryptError -> SMPAgentError -> AgentErrorType
AGENT SMPAgentError
A_ENCRYPTION
  CryptoError
e -> String -> AgentErrorType
INTERNAL (String -> AgentErrorType) -> String -> AgentErrorType
forall a b. (a -> b) -> a -> b
$ CryptoError -> String
forall a. Show a => a -> String
show CryptoError
e