{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- |
-- Module      : Simplex.Messaging.Client
-- Copyright   : (c) simplex.chat
-- License     : AGPL-3
--
-- Maintainer  : chat@simplex.chat
-- Stability   : experimental
-- Portability : non-portable
--
-- This module provides a functional client API for SMP protocol.
--
-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md
module Simplex.Messaging.Client
  ( -- * Connect (disconnect) client to (from) SMP server
    SMPClient (blockSize),
    getSMPClient,
    closeSMPClient,

    -- * SMP protocol command functions
    createSMPQueue,
    subscribeSMPQueue,
    secureSMPQueue,
    sendSMPMessage,
    ackSMPMessage,
    suspendSMPQueue,
    deleteSMPQueue,
    sendSMPCommand,

    -- * Supporting types and client configuration
    SMPClientError (..),
    SMPClientConfig (..),
    smpDefaultConfig,
    SMPServerTransmission,
  )
where

import Control.Concurrent (threadDelay)
import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Exception
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except
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.Maybe (fromMaybe)
import Network.Socket (ServiceName)
import Numeric.Natural
import Simplex.Messaging.Agent.Protocol (SMPServer (..))
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Protocol
import Simplex.Messaging.Transport (ATransport (..), TCP, THandle (..), TProxy, Transport (..), TransportError, clientHandshake, runTransportClient)
import Simplex.Messaging.Transport.WebSockets (WS)
import Simplex.Messaging.Util (bshow, liftError, raceAny_)
import System.Timeout (timeout)

-- | 'SMPClient' is a handle used to send commands to a specific SMP server.
--
-- The only exported selector is blockSize that is negotiated
-- with the server during the TCP transport handshake.
--
-- Use 'getSMPClient' to connect to an SMP server and create a client handle.
data SMPClient = SMPClient
  { SMPClient -> Async ()
action :: Async (),
    SMPClient -> TVar Bool
connected :: TVar Bool,
    SMPClient -> SMPServer
smpServer :: SMPServer,
    SMPClient -> Int
tcpTimeout :: Int,
    SMPClient -> TVar Natural
clientCorrId :: TVar Natural,
    SMPClient -> TVar (Map CorrId Request)
sentCommands :: TVar (Map CorrId Request),
    SMPClient -> TBQueue SignedRawTransmission
sndQ :: TBQueue SignedRawTransmission,
    SMPClient -> TBQueue SignedTransmissionOrError
rcvQ :: TBQueue SignedTransmissionOrError,
    SMPClient -> TBQueue SMPServerTransmission
msgQ :: TBQueue SMPServerTransmission,
    SMPClient -> Int
blockSize :: Int
  }

-- | Type synonym for transmission from some SPM server queue.
type SMPServerTransmission = (SMPServer, RecipientId, Command 'Broker)

-- | SMP client configuration.
data SMPClientConfig = SMPClientConfig
  { -- | size of TBQueue to use for server commands and responses
    SMPClientConfig -> Natural
qSize :: Natural,
    -- | default SMP server port if port is not specified in SMPServer
    SMPClientConfig -> (ServiceName, ATransport)
defaultTransport :: (ServiceName, ATransport),
    -- | timeout of TCP commands (microseconds)
    SMPClientConfig -> Int
tcpTimeout :: Int,
    -- | period for SMP ping commands (microseconds)
    SMPClientConfig -> Int
smpPing :: Int,
    -- | SMP transport block size, Nothing - the block size will be set by the server.
    -- Allowed sizes are 4, 8, 16, 32, 64 KiB (* 1024 bytes).
    SMPClientConfig -> Maybe Int
smpBlockSize :: Maybe Int,
    -- | estimated maximum size of SMP command excluding message body,
    -- determines the maximum allowed message size
    SMPClientConfig -> Int
smpCommandSize :: Int
  }

-- | Default SMP client configuration.
smpDefaultConfig :: SMPClientConfig
smpDefaultConfig :: SMPClientConfig
smpDefaultConfig =
  SMPClientConfig :: Natural
-> (ServiceName, ATransport)
-> Int
-> Int
-> Maybe Int
-> Int
-> SMPClientConfig
SMPClientConfig
    { $sel:qSize:SMPClientConfig :: Natural
qSize = Natural
16,
      $sel:defaultTransport:SMPClientConfig :: (ServiceName, ATransport)
defaultTransport = (ServiceName
"5223", Transport TCP => ATransport
forall c. Transport c => ATransport
transport @TCP),
      $sel:tcpTimeout:SMPClientConfig :: Int
tcpTimeout = Int
4_000_000,
      $sel:smpPing:SMPClientConfig :: Int
smpPing = Int
30_000_000,
      $sel:smpBlockSize:SMPClientConfig :: Maybe Int
smpBlockSize = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
8192,
      $sel:smpCommandSize:SMPClientConfig :: Int
smpCommandSize = Int
256
    }

data Request = Request
  { Request -> QueueId
queueId :: QueueId,
    Request -> TMVar Response
responseVar :: TMVar Response
  }

type Response = Either SMPClientError Cmd

-- | Connects to 'SMPServer' using passed client configuration
-- and queue for messages and notifications.
--
-- A single queue can be used for multiple 'SMPClient' instances,
-- as 'SMPServerTransmission' includes server information.
getSMPClient :: SMPServer -> SMPClientConfig -> TBQueue SMPServerTransmission -> IO () -> IO (Either SMPClientError SMPClient)
getSMPClient :: SMPServer
-> SMPClientConfig
-> TBQueue SMPServerTransmission
-> IO ()
-> IO (Either SMPClientError SMPClient)
getSMPClient SMPServer
smpServer cfg :: SMPClientConfig
cfg@SMPClientConfig {Natural
qSize :: Natural
$sel:qSize:SMPClientConfig :: SMPClientConfig -> Natural
qSize, Int
tcpTimeout :: Int
$sel:tcpTimeout:SMPClientConfig :: SMPClientConfig -> Int
tcpTimeout, Int
smpPing :: Int
$sel:smpPing:SMPClientConfig :: SMPClientConfig -> Int
smpPing, Maybe Int
smpBlockSize :: Maybe Int
$sel:smpBlockSize:SMPClientConfig :: SMPClientConfig -> Maybe Int
smpBlockSize} TBQueue SMPServerTransmission
msgQ IO ()
disconnected =
  STM SMPClient -> IO SMPClient
forall a. STM a -> IO a
atomically STM SMPClient
mkSMPClient IO SMPClient
-> (SMPClient -> IO (Either SMPClientError SMPClient))
-> IO (Either SMPClientError SMPClient)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ServiceName, ATransport)
-> SMPClient -> IO (Either SMPClientError SMPClient)
runClient (ServiceName, ATransport)
useTransport
  where
    mkSMPClient :: STM SMPClient
    mkSMPClient :: STM SMPClient
mkSMPClient = do
      TVar Bool
connected <- Bool -> STM (TVar Bool)
forall a. a -> STM (TVar a)
newTVar Bool
False
      TVar Natural
clientCorrId <- Natural -> STM (TVar Natural)
forall a. a -> STM (TVar a)
newTVar Natural
0
      TVar (Map CorrId Request)
sentCommands <- Map CorrId Request -> STM (TVar (Map CorrId Request))
forall a. a -> STM (TVar a)
newTVar Map CorrId Request
forall k a. Map k a
M.empty
      TBQueue SignedRawTransmission
sndQ <- Natural -> STM (TBQueue SignedRawTransmission)
forall a. Natural -> STM (TBQueue a)
newTBQueue Natural
qSize
      TBQueue SignedTransmissionOrError
rcvQ <- Natural -> STM (TBQueue SignedTransmissionOrError)
forall a. Natural -> STM (TBQueue a)
newTBQueue Natural
qSize
      SMPClient -> STM SMPClient
forall (m :: * -> *) a. Monad m => a -> m a
return
        SMPClient :: Async ()
-> TVar Bool
-> SMPServer
-> Int
-> TVar Natural
-> TVar (Map CorrId Request)
-> TBQueue SignedRawTransmission
-> TBQueue SignedTransmissionOrError
-> TBQueue SMPServerTransmission
-> Int
-> SMPClient
SMPClient
          { $sel:action:SMPClient :: Async ()
action = Async ()
forall a. HasCallStack => a
undefined,
            $sel:blockSize:SMPClient :: Int
blockSize = Int
forall a. HasCallStack => a
undefined,
            TVar Bool
connected :: TVar Bool
$sel:connected:SMPClient :: TVar Bool
connected,
            SMPServer
smpServer :: SMPServer
$sel:smpServer:SMPClient :: SMPServer
smpServer,
            Int
tcpTimeout :: Int
$sel:tcpTimeout:SMPClient :: Int
tcpTimeout,
            TVar Natural
clientCorrId :: TVar Natural
$sel:clientCorrId:SMPClient :: TVar Natural
clientCorrId,
            TVar (Map CorrId Request)
sentCommands :: TVar (Map CorrId Request)
$sel:sentCommands:SMPClient :: TVar (Map CorrId Request)
sentCommands,
            TBQueue SignedRawTransmission
sndQ :: TBQueue SignedRawTransmission
$sel:sndQ:SMPClient :: TBQueue SignedRawTransmission
sndQ,
            TBQueue SignedTransmissionOrError
rcvQ :: TBQueue SignedTransmissionOrError
$sel:rcvQ:SMPClient :: TBQueue SignedTransmissionOrError
rcvQ,
            TBQueue SMPServerTransmission
msgQ :: TBQueue SMPServerTransmission
$sel:msgQ:SMPClient :: TBQueue SMPServerTransmission
msgQ
          }

    runClient :: (ServiceName, ATransport) -> SMPClient -> IO (Either SMPClientError SMPClient)
    runClient :: (ServiceName, ATransport)
-> SMPClient -> IO (Either SMPClientError SMPClient)
runClient (ServiceName
port', ATransport TProxy c
t) SMPClient
c = do
      TMVar (Either SMPClientError Int)
thVar <- IO (TMVar (Either SMPClientError Int))
forall a. IO (TMVar a)
newEmptyTMVarIO
      Async ()
action <-
        IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$
          ServiceName -> ServiceName -> (c -> IO ()) -> IO ()
forall c (m :: * -> *) a.
(Transport c, MonadUnliftIO m) =>
ServiceName -> ServiceName -> (c -> m a) -> m a
runTransportClient (SMPServer -> ServiceName
host SMPServer
smpServer) ServiceName
port' (TProxy c
-> SMPClient -> TMVar (Either SMPClientError Int) -> c -> IO ()
forall c.
Transport c =>
TProxy c
-> SMPClient -> TMVar (Either SMPClientError Int) -> c -> IO ()
client TProxy c
t SMPClient
c TMVar (Either SMPClientError Int)
thVar)
            IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` STM () -> IO ()
forall a. STM a -> IO a
atomically (TMVar (Either SMPClientError Int)
-> Either SMPClientError Int -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar (Either SMPClientError Int)
thVar (Either SMPClientError Int -> STM ())
-> Either SMPClientError Int -> STM ()
forall a b. (a -> b) -> a -> b
$ SMPClientError -> Either SMPClientError Int
forall a b. a -> Either a b
Left SMPClientError
SMPNetworkError)
      Maybe (Either SMPClientError Int)
bSize <- Int
tcpTimeout Int
-> IO (Either SMPClientError Int)
-> IO (Maybe (Either SMPClientError Int))
forall a. Int -> IO a -> IO (Maybe a)
`timeout` STM (Either SMPClientError Int) -> IO (Either SMPClientError Int)
forall a. STM a -> IO a
atomically (TMVar (Either SMPClientError Int)
-> STM (Either SMPClientError Int)
forall a. TMVar a -> STM a
takeTMVar TMVar (Either SMPClientError Int)
thVar)
      Either SMPClientError SMPClient
-> IO (Either SMPClientError SMPClient)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SMPClientError SMPClient
 -> IO (Either SMPClientError SMPClient))
-> Either SMPClientError SMPClient
-> IO (Either SMPClientError SMPClient)
forall a b. (a -> b) -> a -> b
$ case Maybe (Either SMPClientError Int)
bSize of
        Just (Right Int
blockSize) -> SMPClient -> Either SMPClientError SMPClient
forall a b. b -> Either a b
Right SMPClient
c {Async ()
action :: Async ()
$sel:action:SMPClient :: Async ()
action, Int
blockSize :: Int
$sel:blockSize:SMPClient :: Int
blockSize}
        Just (Left SMPClientError
e) -> SMPClientError -> Either SMPClientError SMPClient
forall a b. a -> Either a b
Left SMPClientError
e
        Maybe (Either SMPClientError Int)
Nothing -> SMPClientError -> Either SMPClientError SMPClient
forall a b. a -> Either a b
Left SMPClientError
SMPNetworkError

    useTransport :: (ServiceName, ATransport)
    useTransport :: (ServiceName, ATransport)
useTransport = case SMPServer -> Maybe ServiceName
port SMPServer
smpServer of
      Maybe ServiceName
Nothing -> SMPClientConfig -> (ServiceName, ATransport)
defaultTransport SMPClientConfig
cfg
      Just ServiceName
"80" -> (ServiceName
"80", Transport WS => ATransport
forall c. Transport c => ATransport
transport @WS)
      Just ServiceName
p -> (ServiceName
p, Transport TCP => ATransport
forall c. Transport c => ATransport
transport @TCP)

    client :: forall c. Transport c => TProxy c -> SMPClient -> TMVar (Either SMPClientError Int) -> c -> IO ()
    client :: TProxy c
-> SMPClient -> TMVar (Either SMPClientError Int) -> c -> IO ()
client TProxy c
_ SMPClient
c TMVar (Either SMPClientError Int)
thVar c
h =
      ExceptT TransportError IO (THandle c)
-> IO (Either TransportError (THandle c))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (c
-> Maybe Int
-> Maybe KeyHash
-> ExceptT TransportError IO (THandle c)
forall c.
Transport c =>
c
-> Maybe Int
-> Maybe KeyHash
-> ExceptT TransportError IO (THandle c)
clientHandshake c
h Maybe Int
smpBlockSize (Maybe KeyHash -> ExceptT TransportError IO (THandle c))
-> Maybe KeyHash -> ExceptT TransportError IO (THandle c)
forall a b. (a -> b) -> a -> b
$ SMPServer -> Maybe KeyHash
keyHash SMPServer
smpServer) IO (Either TransportError (THandle c))
-> (Either TransportError (THandle c) -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left TransportError
e -> STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ())
-> (SMPClientError -> STM ()) -> SMPClientError -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TMVar (Either SMPClientError Int)
-> Either SMPClientError Int -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar (Either SMPClientError Int)
thVar (Either SMPClientError Int -> STM ())
-> (SMPClientError -> Either SMPClientError Int)
-> SMPClientError
-> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SMPClientError -> Either SMPClientError Int
forall a b. a -> Either a b
Left (SMPClientError -> IO ()) -> SMPClientError -> IO ()
forall a b. (a -> b) -> a -> b
$ TransportError -> SMPClientError
SMPTransportError TransportError
e
        Right THandle c
th -> do
          STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (SMPClient -> TVar Bool
connected SMPClient
c) Bool
True
            TMVar (Either SMPClientError Int)
-> Either SMPClientError Int -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar (Either SMPClientError Int)
thVar (Either SMPClientError Int -> STM ())
-> (Int -> Either SMPClientError Int) -> Int -> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Either SMPClientError Int
forall a b. b -> Either a b
Right (Int -> STM ()) -> Int -> STM ()
forall a b. (a -> b) -> a -> b
$ THandle c -> Int
forall c. THandle c -> Int
blockSize (THandle c
th :: THandle c)
          [IO ()] -> IO ()
forall (m :: * -> *) a. MonadUnliftIO m => [m a] -> m ()
raceAny_ [SMPClient -> THandle c -> IO ()
forall c. Transport c => SMPClient -> THandle c -> IO ()
send SMPClient
c THandle c
th, SMPClient -> IO ()
process SMPClient
c, SMPClient -> THandle c -> IO ()
forall c. Transport c => SMPClient -> THandle c -> IO ()
receive SMPClient
c THandle c
th, SMPClient -> IO ()
ping SMPClient
c]
            IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` IO ()
disconnected

    send :: Transport c => SMPClient -> THandle c -> IO ()
    send :: SMPClient -> THandle c -> IO ()
send SMPClient {TBQueue SignedRawTransmission
sndQ :: TBQueue SignedRawTransmission
$sel:sndQ:SMPClient :: SMPClient -> TBQueue SignedRawTransmission
sndQ} THandle c
h = IO (Either TransportError ()) -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO (Either TransportError ()) -> IO ())
-> IO (Either TransportError ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ STM SignedRawTransmission -> IO SignedRawTransmission
forall a. STM a -> IO a
atomically (TBQueue SignedRawTransmission -> STM SignedRawTransmission
forall a. TBQueue a -> STM a
readTBQueue TBQueue SignedRawTransmission
sndQ) IO SignedRawTransmission
-> (SignedRawTransmission -> IO (Either TransportError ()))
-> IO (Either TransportError ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= THandle c -> SignedRawTransmission -> IO (Either TransportError ())
forall c.
Transport c =>
THandle c -> SignedRawTransmission -> IO (Either TransportError ())
tPut THandle c
h

    receive :: Transport c => SMPClient -> THandle c -> IO ()
    receive :: SMPClient -> THandle c -> IO ()
receive SMPClient {TBQueue SignedTransmissionOrError
rcvQ :: TBQueue SignedTransmissionOrError
$sel:rcvQ:SMPClient :: SMPClient -> TBQueue SignedTransmissionOrError
rcvQ} THandle c
h = IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (Cmd -> Either ErrorType Cmd)
-> THandle c -> IO SignedTransmissionOrError
forall c (m :: * -> *).
(Transport c, MonadIO m) =>
(Cmd -> Either ErrorType Cmd)
-> THandle c -> m SignedTransmissionOrError
tGet Cmd -> Either ErrorType Cmd
fromServer THandle c
h IO SignedTransmissionOrError
-> (SignedTransmissionOrError -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ())
-> (SignedTransmissionOrError -> STM ())
-> SignedTransmissionOrError
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TBQueue SignedTransmissionOrError
-> SignedTransmissionOrError -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue SignedTransmissionOrError
rcvQ

    ping :: SMPClient -> IO ()
    ping :: SMPClient -> IO ()
ping SMPClient
c = IO Response -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO Response -> IO ()) -> IO Response -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Int -> IO ()
threadDelay Int
smpPing
      ExceptT SMPClientError IO Cmd -> IO Response
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT SMPClientError IO Cmd -> IO Response)
-> ExceptT SMPClientError IO Cmd -> IO Response
forall a b. (a -> b) -> a -> b
$ SMPClient
-> Maybe SafePrivateKey
-> QueueId
-> Cmd
-> ExceptT SMPClientError IO Cmd
sendSMPCommand SMPClient
c Maybe SafePrivateKey
forall a. Maybe a
Nothing QueueId
"" (SParty 'Sender -> Command 'Sender -> Cmd
forall (a :: Party). SParty a -> Command a -> Cmd
Cmd SParty 'Sender
SSender Command 'Sender
PING)

    process :: SMPClient -> IO ()
    process :: SMPClient -> IO ()
process SMPClient {TBQueue SignedTransmissionOrError
rcvQ :: TBQueue SignedTransmissionOrError
$sel:rcvQ:SMPClient :: SMPClient -> TBQueue SignedTransmissionOrError
rcvQ, TVar (Map CorrId Request)
sentCommands :: TVar (Map CorrId Request)
$sel:sentCommands:SMPClient :: SMPClient -> TVar (Map CorrId Request)
sentCommands} = IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      (Signature
_, (CorrId
corrId, QueueId
qId, Either ErrorType Cmd
respOrErr)) <- STM SignedTransmissionOrError -> IO SignedTransmissionOrError
forall a. STM a -> IO a
atomically (STM SignedTransmissionOrError -> IO SignedTransmissionOrError)
-> STM SignedTransmissionOrError -> IO SignedTransmissionOrError
forall a b. (a -> b) -> a -> b
$ TBQueue SignedTransmissionOrError -> STM SignedTransmissionOrError
forall a. TBQueue a -> STM a
readTBQueue TBQueue SignedTransmissionOrError
rcvQ
      if QueueId -> Bool
B.null (QueueId -> Bool) -> QueueId -> Bool
forall a b. (a -> b) -> a -> b
$ CorrId -> QueueId
bs CorrId
corrId
        then QueueId -> Either ErrorType Cmd -> IO ()
sendMsg QueueId
qId Either ErrorType Cmd
respOrErr
        else do
          Map CorrId Request
cs <- TVar (Map CorrId Request) -> IO (Map CorrId Request)
forall a. TVar a -> IO a
readTVarIO TVar (Map CorrId Request)
sentCommands
          case CorrId -> Map CorrId Request -> Maybe Request
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup CorrId
corrId Map CorrId Request
cs of
            Maybe Request
Nothing -> QueueId -> Either ErrorType Cmd -> IO ()
sendMsg QueueId
qId Either ErrorType Cmd
respOrErr
            Just Request {QueueId
queueId :: QueueId
$sel:queueId:Request :: Request -> QueueId
queueId, TMVar Response
responseVar :: TMVar Response
$sel:responseVar:Request :: Request -> TMVar Response
responseVar} -> STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
              TVar (Map CorrId Request)
-> (Map CorrId Request -> Map CorrId Request) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Map CorrId Request)
sentCommands ((Map CorrId Request -> Map CorrId Request) -> STM ())
-> (Map CorrId Request -> Map CorrId Request) -> STM ()
forall a b. (a -> b) -> a -> b
$ CorrId -> Map CorrId Request -> Map CorrId Request
forall k a. Ord k => k -> Map k a -> Map k a
M.delete CorrId
corrId
              TMVar Response -> Response -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar Response
responseVar (Response -> STM ()) -> Response -> STM ()
forall a b. (a -> b) -> a -> b
$
                if QueueId
queueId QueueId -> QueueId -> Bool
forall a. Eq a => a -> a -> Bool
== QueueId
qId
                  then case Either ErrorType Cmd
respOrErr of
                    Left ErrorType
e -> SMPClientError -> Response
forall a b. a -> Either a b
Left (SMPClientError -> Response) -> SMPClientError -> Response
forall a b. (a -> b) -> a -> b
$ ErrorType -> SMPClientError
SMPResponseError ErrorType
e
                    Right (Cmd SParty a
_ (ERR ErrorType
e)) -> SMPClientError -> Response
forall a b. a -> Either a b
Left (SMPClientError -> Response) -> SMPClientError -> Response
forall a b. (a -> b) -> a -> b
$ ErrorType -> SMPClientError
SMPServerError ErrorType
e
                    Right Cmd
r -> Cmd -> Response
forall a b. b -> Either a b
Right Cmd
r
                  else SMPClientError -> Response
forall a b. a -> Either a b
Left SMPClientError
SMPUnexpectedResponse

    sendMsg :: QueueId -> Either ErrorType Cmd -> IO ()
    sendMsg :: QueueId -> Either ErrorType Cmd -> IO ()
sendMsg QueueId
qId = \case
      Right (Cmd SParty a
SBroker Command a
cmd) -> STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TBQueue SMPServerTransmission -> SMPServerTransmission -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue SMPServerTransmission
msgQ (SMPServer
smpServer, QueueId
qId, Command a
Command 'Broker
cmd)
      -- TODO send everything else to errQ and log in agent
      Either ErrorType Cmd
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Disconnects SMP client from the server and terminates client threads.
closeSMPClient :: SMPClient -> IO ()
closeSMPClient :: SMPClient -> IO ()
closeSMPClient = Async () -> IO ()
forall a. Async a -> IO ()
uninterruptibleCancel (Async () -> IO ())
-> (SMPClient -> Async ()) -> SMPClient -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SMPClient -> Async ()
action

-- | SMP client error type.
data SMPClientError
  = -- | Correctly parsed SMP server ERR response.
    -- This error is forwarded to the agent client as `ERR SMP err`.
    SMPServerError ErrorType
  | -- | Invalid server response that failed to parse.
    -- Forwarded to the agent client as `ERR BROKER RESPONSE`.
    SMPResponseError ErrorType
  | -- | Different response from what is expected to a certain SMP command,
    -- e.g. server should respond `IDS` or `ERR` to `NEW` command,
    -- other responses would result in this error.
    -- Forwarded to the agent client as `ERR BROKER UNEXPECTED`.
    SMPUnexpectedResponse
  | -- | Used for TCP connection and command response timeouts.
    -- Forwarded to the agent client as `ERR BROKER TIMEOUT`.
    SMPResponseTimeout
  | -- | Failure to establish TCP connection.
    -- Forwarded to the agent client as `ERR BROKER NETWORK`.
    SMPNetworkError
  | -- | TCP transport handshake or some other transport error.
    -- Forwarded to the agent client as `ERR BROKER TRANSPORT e`.
    SMPTransportError TransportError
  | -- | Error when cryptographically "signing" the command.
    SMPSignatureError C.CryptoError
  deriving (SMPClientError -> SMPClientError -> Bool
(SMPClientError -> SMPClientError -> Bool)
-> (SMPClientError -> SMPClientError -> Bool) -> Eq SMPClientError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SMPClientError -> SMPClientError -> Bool
$c/= :: SMPClientError -> SMPClientError -> Bool
== :: SMPClientError -> SMPClientError -> Bool
$c== :: SMPClientError -> SMPClientError -> Bool
Eq, Int -> SMPClientError -> ShowS
[SMPClientError] -> ShowS
SMPClientError -> ServiceName
(Int -> SMPClientError -> ShowS)
-> (SMPClientError -> ServiceName)
-> ([SMPClientError] -> ShowS)
-> Show SMPClientError
forall a.
(Int -> a -> ShowS)
-> (a -> ServiceName) -> ([a] -> ShowS) -> Show a
showList :: [SMPClientError] -> ShowS
$cshowList :: [SMPClientError] -> ShowS
show :: SMPClientError -> ServiceName
$cshow :: SMPClientError -> ServiceName
showsPrec :: Int -> SMPClientError -> ShowS
$cshowsPrec :: Int -> SMPClientError -> ShowS
Show, Show SMPClientError
Typeable SMPClientError
Typeable SMPClientError
-> Show SMPClientError
-> (SMPClientError -> SomeException)
-> (SomeException -> Maybe SMPClientError)
-> (SMPClientError -> ServiceName)
-> Exception SMPClientError
SomeException -> Maybe SMPClientError
SMPClientError -> ServiceName
SMPClientError -> SomeException
forall e.
Typeable e
-> Show e
-> (e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> ServiceName)
-> Exception e
displayException :: SMPClientError -> ServiceName
$cdisplayException :: SMPClientError -> ServiceName
fromException :: SomeException -> Maybe SMPClientError
$cfromException :: SomeException -> Maybe SMPClientError
toException :: SMPClientError -> SomeException
$ctoException :: SMPClientError -> SomeException
$cp2Exception :: Show SMPClientError
$cp1Exception :: Typeable SMPClientError
Exception)

-- | Create a new SMP queue.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#create-queue-command
createSMPQueue ::
  SMPClient ->
  RecipientPrivateKey ->
  RecipientPublicKey ->
  ExceptT SMPClientError IO (RecipientId, SenderId)
createSMPQueue :: SMPClient
-> SafePrivateKey
-> RecipientPublicKey
-> ExceptT SMPClientError IO (QueueId, QueueId)
createSMPQueue SMPClient
c SafePrivateKey
rpKey RecipientPublicKey
rKey =
  -- TODO add signing this request too - requires changes in the server
  SMPClient
-> Maybe SafePrivateKey
-> QueueId
-> Cmd
-> ExceptT SMPClientError IO Cmd
sendSMPCommand SMPClient
c (SafePrivateKey -> Maybe SafePrivateKey
forall a. a -> Maybe a
Just SafePrivateKey
rpKey) QueueId
"" (SParty 'Recipient -> Command 'Recipient -> Cmd
forall (a :: Party). SParty a -> Command a -> Cmd
Cmd SParty 'Recipient
SRecipient (Command 'Recipient -> Cmd) -> Command 'Recipient -> Cmd
forall a b. (a -> b) -> a -> b
$ RecipientPublicKey -> Command 'Recipient
NEW RecipientPublicKey
rKey) ExceptT SMPClientError IO Cmd
-> (Cmd -> ExceptT SMPClientError IO (QueueId, QueueId))
-> ExceptT SMPClientError IO (QueueId, QueueId)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Cmd SParty a
_ (IDS QueueId
rId QueueId
sId) -> (QueueId, QueueId) -> ExceptT SMPClientError IO (QueueId, QueueId)
forall (m :: * -> *) a. Monad m => a -> m a
return (QueueId
rId, QueueId
sId)
    Cmd
_ -> SMPClientError -> ExceptT SMPClientError IO (QueueId, QueueId)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE SMPClientError
SMPUnexpectedResponse

-- | Subscribe to the SMP queue.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#subscribe-to-queue
subscribeSMPQueue :: SMPClient -> RecipientPrivateKey -> RecipientId -> ExceptT SMPClientError IO ()
subscribeSMPQueue :: SMPClient
-> SafePrivateKey -> QueueId -> ExceptT SMPClientError IO ()
subscribeSMPQueue c :: SMPClient
c@SMPClient {SMPServer
smpServer :: SMPServer
$sel:smpServer:SMPClient :: SMPClient -> SMPServer
smpServer, TBQueue SMPServerTransmission
msgQ :: TBQueue SMPServerTransmission
$sel:msgQ:SMPClient :: SMPClient -> TBQueue SMPServerTransmission
msgQ} SafePrivateKey
rpKey QueueId
rId =
  SMPClient
-> Maybe SafePrivateKey
-> QueueId
-> Cmd
-> ExceptT SMPClientError IO Cmd
sendSMPCommand SMPClient
c (SafePrivateKey -> Maybe SafePrivateKey
forall a. a -> Maybe a
Just SafePrivateKey
rpKey) QueueId
rId (SParty 'Recipient -> Command 'Recipient -> Cmd
forall (a :: Party). SParty a -> Command a -> Cmd
Cmd SParty 'Recipient
SRecipient Command 'Recipient
SUB) ExceptT SMPClientError IO Cmd
-> (Cmd -> ExceptT SMPClientError IO ())
-> ExceptT SMPClientError IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Cmd SParty a
_ Command a
OK -> () -> ExceptT SMPClientError IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Cmd SParty a
_ cmd :: Command a
cmd@MSG {} ->
      IO () -> ExceptT SMPClientError IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT SMPClientError IO ())
-> (STM () -> IO ()) -> STM () -> ExceptT SMPClientError IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> ExceptT SMPClientError IO ())
-> STM () -> ExceptT SMPClientError IO ()
forall a b. (a -> b) -> a -> b
$ TBQueue SMPServerTransmission -> SMPServerTransmission -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue SMPServerTransmission
msgQ (SMPServer
smpServer, QueueId
rId, Command a
Command 'Broker
cmd)
    Cmd
_ -> SMPClientError -> ExceptT SMPClientError IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE SMPClientError
SMPUnexpectedResponse

-- | Secure the SMP queue by adding a sender public key.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#secure-queue-command
secureSMPQueue :: SMPClient -> RecipientPrivateKey -> RecipientId -> SenderPublicKey -> ExceptT SMPClientError IO ()
secureSMPQueue :: SMPClient
-> SafePrivateKey
-> QueueId
-> RecipientPublicKey
-> ExceptT SMPClientError IO ()
secureSMPQueue SMPClient
c SafePrivateKey
rpKey QueueId
rId RecipientPublicKey
senderKey = Cmd
-> SMPClient
-> SafePrivateKey
-> QueueId
-> ExceptT SMPClientError IO ()
okSMPCommand (SParty 'Recipient -> Command 'Recipient -> Cmd
forall (a :: Party). SParty a -> Command a -> Cmd
Cmd SParty 'Recipient
SRecipient (Command 'Recipient -> Cmd) -> Command 'Recipient -> Cmd
forall a b. (a -> b) -> a -> b
$ RecipientPublicKey -> Command 'Recipient
KEY RecipientPublicKey
senderKey) SMPClient
c SafePrivateKey
rpKey QueueId
rId

-- | Send SMP message.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#send-message
sendSMPMessage :: SMPClient -> Maybe SenderPrivateKey -> SenderId -> MsgBody -> ExceptT SMPClientError IO ()
sendSMPMessage :: SMPClient
-> Maybe SafePrivateKey
-> QueueId
-> QueueId
-> ExceptT SMPClientError IO ()
sendSMPMessage SMPClient
c Maybe SafePrivateKey
spKey QueueId
sId QueueId
msg =
  SMPClient
-> Maybe SafePrivateKey
-> QueueId
-> Cmd
-> ExceptT SMPClientError IO Cmd
sendSMPCommand SMPClient
c Maybe SafePrivateKey
spKey QueueId
sId (SParty 'Sender -> Command 'Sender -> Cmd
forall (a :: Party). SParty a -> Command a -> Cmd
Cmd SParty 'Sender
SSender (Command 'Sender -> Cmd) -> Command 'Sender -> Cmd
forall a b. (a -> b) -> a -> b
$ QueueId -> Command 'Sender
SEND QueueId
msg) ExceptT SMPClientError IO Cmd
-> (Cmd -> ExceptT SMPClientError IO ())
-> ExceptT SMPClientError IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Cmd SParty a
_ Command a
OK -> () -> ExceptT SMPClientError IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Cmd
_ -> SMPClientError -> ExceptT SMPClientError IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE SMPClientError
SMPUnexpectedResponse

-- | Acknowledge message delivery (server deletes the message).
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#acknowledge-message-delivery
ackSMPMessage :: SMPClient -> RecipientPrivateKey -> QueueId -> ExceptT SMPClientError IO ()
ackSMPMessage :: SMPClient
-> SafePrivateKey -> QueueId -> ExceptT SMPClientError IO ()
ackSMPMessage c :: SMPClient
c@SMPClient {SMPServer
smpServer :: SMPServer
$sel:smpServer:SMPClient :: SMPClient -> SMPServer
smpServer, TBQueue SMPServerTransmission
msgQ :: TBQueue SMPServerTransmission
$sel:msgQ:SMPClient :: SMPClient -> TBQueue SMPServerTransmission
msgQ} SafePrivateKey
rpKey QueueId
rId =
  SMPClient
-> Maybe SafePrivateKey
-> QueueId
-> Cmd
-> ExceptT SMPClientError IO Cmd
sendSMPCommand SMPClient
c (SafePrivateKey -> Maybe SafePrivateKey
forall a. a -> Maybe a
Just SafePrivateKey
rpKey) QueueId
rId (SParty 'Recipient -> Command 'Recipient -> Cmd
forall (a :: Party). SParty a -> Command a -> Cmd
Cmd SParty 'Recipient
SRecipient Command 'Recipient
ACK) ExceptT SMPClientError IO Cmd
-> (Cmd -> ExceptT SMPClientError IO ())
-> ExceptT SMPClientError IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Cmd SParty a
_ Command a
OK -> () -> ExceptT SMPClientError IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Cmd SParty a
_ cmd :: Command a
cmd@MSG {} ->
      IO () -> ExceptT SMPClientError IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT SMPClientError IO ())
-> (STM () -> IO ()) -> STM () -> ExceptT SMPClientError IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> ExceptT SMPClientError IO ())
-> STM () -> ExceptT SMPClientError IO ()
forall a b. (a -> b) -> a -> b
$ TBQueue SMPServerTransmission -> SMPServerTransmission -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue SMPServerTransmission
msgQ (SMPServer
smpServer, QueueId
rId, Command a
Command 'Broker
cmd)
    Cmd
_ -> SMPClientError -> ExceptT SMPClientError IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE SMPClientError
SMPUnexpectedResponse

-- | Irreversibly suspend SMP queue.
-- The existing messages from the queue will still be delivered.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#suspend-queue
suspendSMPQueue :: SMPClient -> RecipientPrivateKey -> QueueId -> ExceptT SMPClientError IO ()
suspendSMPQueue :: SMPClient
-> SafePrivateKey -> QueueId -> ExceptT SMPClientError IO ()
suspendSMPQueue = Cmd
-> SMPClient
-> SafePrivateKey
-> QueueId
-> ExceptT SMPClientError IO ()
okSMPCommand (Cmd
 -> SMPClient
 -> SafePrivateKey
 -> QueueId
 -> ExceptT SMPClientError IO ())
-> Cmd
-> SMPClient
-> SafePrivateKey
-> QueueId
-> ExceptT SMPClientError IO ()
forall a b. (a -> b) -> a -> b
$ SParty 'Recipient -> Command 'Recipient -> Cmd
forall (a :: Party). SParty a -> Command a -> Cmd
Cmd SParty 'Recipient
SRecipient Command 'Recipient
OFF

-- | Irreversibly delete SMP queue and all messages in it.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#delete-queue
deleteSMPQueue :: SMPClient -> RecipientPrivateKey -> QueueId -> ExceptT SMPClientError IO ()
deleteSMPQueue :: SMPClient
-> SafePrivateKey -> QueueId -> ExceptT SMPClientError IO ()
deleteSMPQueue = Cmd
-> SMPClient
-> SafePrivateKey
-> QueueId
-> ExceptT SMPClientError IO ()
okSMPCommand (Cmd
 -> SMPClient
 -> SafePrivateKey
 -> QueueId
 -> ExceptT SMPClientError IO ())
-> Cmd
-> SMPClient
-> SafePrivateKey
-> QueueId
-> ExceptT SMPClientError IO ()
forall a b. (a -> b) -> a -> b
$ SParty 'Recipient -> Command 'Recipient -> Cmd
forall (a :: Party). SParty a -> Command a -> Cmd
Cmd SParty 'Recipient
SRecipient Command 'Recipient
DEL

okSMPCommand :: Cmd -> SMPClient -> C.SafePrivateKey -> QueueId -> ExceptT SMPClientError IO ()
okSMPCommand :: Cmd
-> SMPClient
-> SafePrivateKey
-> QueueId
-> ExceptT SMPClientError IO ()
okSMPCommand Cmd
cmd SMPClient
c SafePrivateKey
pKey QueueId
qId =
  SMPClient
-> Maybe SafePrivateKey
-> QueueId
-> Cmd
-> ExceptT SMPClientError IO Cmd
sendSMPCommand SMPClient
c (SafePrivateKey -> Maybe SafePrivateKey
forall a. a -> Maybe a
Just SafePrivateKey
pKey) QueueId
qId Cmd
cmd ExceptT SMPClientError IO Cmd
-> (Cmd -> ExceptT SMPClientError IO ())
-> ExceptT SMPClientError IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Cmd SParty a
_ Command a
OK -> () -> ExceptT SMPClientError IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Cmd
_ -> SMPClientError -> ExceptT SMPClientError IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE SMPClientError
SMPUnexpectedResponse

-- | Send any SMP command ('Cmd' type).
sendSMPCommand :: SMPClient -> Maybe C.SafePrivateKey -> QueueId -> Cmd -> ExceptT SMPClientError IO Cmd
sendSMPCommand :: SMPClient
-> Maybe SafePrivateKey
-> QueueId
-> Cmd
-> ExceptT SMPClientError IO Cmd
sendSMPCommand SMPClient {TBQueue SignedRawTransmission
sndQ :: TBQueue SignedRawTransmission
$sel:sndQ:SMPClient :: SMPClient -> TBQueue SignedRawTransmission
sndQ, TVar (Map CorrId Request)
sentCommands :: TVar (Map CorrId Request)
$sel:sentCommands:SMPClient :: SMPClient -> TVar (Map CorrId Request)
sentCommands, TVar Natural
clientCorrId :: TVar Natural
$sel:clientCorrId:SMPClient :: SMPClient -> TVar Natural
clientCorrId, Int
tcpTimeout :: Int
$sel:tcpTimeout:SMPClient :: SMPClient -> Int
tcpTimeout} Maybe SafePrivateKey
pKey QueueId
qId Cmd
cmd = do
  CorrId
corrId <- STM CorrId -> ExceptT SMPClientError IO CorrId
forall a. STM a -> ExceptT SMPClientError IO a
lift_ STM CorrId
getNextCorrId
  SignedRawTransmission
t <- QueueId -> ExceptT SMPClientError IO SignedRawTransmission
signTransmission (QueueId -> ExceptT SMPClientError IO SignedRawTransmission)
-> QueueId -> ExceptT SMPClientError IO SignedRawTransmission
forall a b. (a -> b) -> a -> b
$ Transmission -> QueueId
serializeTransmission (CorrId
corrId, QueueId
qId, Cmd
cmd)
  IO Response -> ExceptT SMPClientError IO Cmd
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO Response -> ExceptT SMPClientError IO Cmd)
-> IO Response -> ExceptT SMPClientError IO Cmd
forall a b. (a -> b) -> a -> b
$ CorrId -> SignedRawTransmission -> IO Response
sendRecv CorrId
corrId SignedRawTransmission
t
  where
    lift_ :: STM a -> ExceptT SMPClientError IO a
    lift_ :: STM a -> ExceptT SMPClientError IO a
lift_ STM a
action = IO (Either SMPClientError a) -> ExceptT SMPClientError IO a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either SMPClientError a) -> ExceptT SMPClientError IO a)
-> IO (Either SMPClientError a) -> ExceptT SMPClientError IO a
forall a b. (a -> b) -> a -> b
$ a -> Either SMPClientError a
forall a b. b -> Either a b
Right (a -> Either SMPClientError a)
-> IO a -> IO (Either SMPClientError a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM a -> IO a
forall a. STM a -> IO a
atomically STM a
action

    getNextCorrId :: STM CorrId
    getNextCorrId :: STM CorrId
getNextCorrId = do
      Natural
i <- TVar Natural -> (Natural -> (Natural, Natural)) -> STM Natural
forall s a. TVar s -> (s -> (a, s)) -> STM a
stateTVar TVar Natural
clientCorrId ((Natural -> (Natural, Natural)) -> STM Natural)
-> (Natural -> (Natural, Natural)) -> STM Natural
forall a b. (a -> b) -> a -> b
$ \Natural
i -> (Natural
i, Natural
i Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
1)
      CorrId -> STM CorrId
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CorrId -> STM CorrId)
-> (QueueId -> CorrId) -> QueueId -> STM CorrId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QueueId -> CorrId
CorrId (QueueId -> STM CorrId) -> QueueId -> STM CorrId
forall a b. (a -> b) -> a -> b
$ Natural -> QueueId
forall a. Show a => a -> QueueId
bshow Natural
i

    signTransmission :: ByteString -> ExceptT SMPClientError IO SignedRawTransmission
    signTransmission :: QueueId -> ExceptT SMPClientError IO SignedRawTransmission
signTransmission QueueId
t = case Maybe SafePrivateKey
pKey of
      Maybe SafePrivateKey
Nothing -> SignedRawTransmission
-> ExceptT SMPClientError IO SignedRawTransmission
forall (m :: * -> *) a. Monad m => a -> m a
return (Signature
"", QueueId
t)
      Just SafePrivateKey
pk -> do
        Signature
sig <- (CryptoError -> SMPClientError)
-> ExceptT CryptoError IO Signature
-> ExceptT SMPClientError IO Signature
forall (m :: * -> *) e' e a.
(MonadIO m, MonadError e' m) =>
(e -> e') -> ExceptT e IO a -> m a
liftError CryptoError -> SMPClientError
SMPSignatureError (ExceptT CryptoError IO Signature
 -> ExceptT SMPClientError IO Signature)
-> ExceptT CryptoError IO Signature
-> ExceptT SMPClientError IO Signature
forall a b. (a -> b) -> a -> b
$ SafePrivateKey -> QueueId -> ExceptT CryptoError IO Signature
forall k.
PrivateKey k =>
k -> QueueId -> ExceptT CryptoError IO Signature
C.sign SafePrivateKey
pk QueueId
t
        SignedRawTransmission
-> ExceptT SMPClientError IO SignedRawTransmission
forall (m :: * -> *) a. Monad m => a -> m a
return (Signature
sig, QueueId
t)

    -- two separate "atomically" needed to avoid blocking
    sendRecv :: CorrId -> SignedRawTransmission -> IO Response
    sendRecv :: CorrId -> SignedRawTransmission -> IO Response
sendRecv CorrId
corrId SignedRawTransmission
t = STM (TMVar Response) -> IO (TMVar Response)
forall a. STM a -> IO a
atomically (CorrId -> SignedRawTransmission -> STM (TMVar Response)
send CorrId
corrId SignedRawTransmission
t) IO (TMVar Response)
-> (TMVar Response -> IO Response) -> IO Response
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO Response -> IO Response
withTimeout (IO Response -> IO Response)
-> (TMVar Response -> IO Response) -> TMVar Response -> IO Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM Response -> IO Response
forall a. STM a -> IO a
atomically (STM Response -> IO Response)
-> (TMVar Response -> STM Response)
-> TMVar Response
-> IO Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TMVar Response -> STM Response
forall a. TMVar a -> STM a
takeTMVar
      where
        withTimeout :: IO Response -> IO Response
withTimeout IO Response
a = Response -> Maybe Response -> Response
forall a. a -> Maybe a -> a
fromMaybe (SMPClientError -> Response
forall a b. a -> Either a b
Left SMPClientError
SMPResponseTimeout) (Maybe Response -> Response) -> IO (Maybe Response) -> IO Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO Response -> IO (Maybe Response)
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
tcpTimeout IO Response
a

    send :: CorrId -> SignedRawTransmission -> STM (TMVar Response)
    send :: CorrId -> SignedRawTransmission -> STM (TMVar Response)
send CorrId
corrId SignedRawTransmission
t = do
      TMVar Response
r <- STM (TMVar Response)
forall a. STM (TMVar a)
newEmptyTMVar
      TVar (Map CorrId Request)
-> (Map CorrId Request -> Map CorrId Request) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Map CorrId Request)
sentCommands ((Map CorrId Request -> Map CorrId Request) -> STM ())
-> (Request -> Map CorrId Request -> Map CorrId Request)
-> Request
-> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CorrId -> Request -> Map CorrId Request -> Map CorrId Request
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert CorrId
corrId (Request -> STM ()) -> Request -> STM ()
forall a b. (a -> b) -> a -> b
$ QueueId -> TMVar Response -> Request
Request QueueId
qId TMVar Response
r
      TBQueue SignedRawTransmission -> SignedRawTransmission -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue SignedRawTransmission
sndQ SignedRawTransmission
t
      TMVar Response -> STM (TMVar Response)
forall (m :: * -> *) a. Monad m => a -> m a
return TMVar Response
r