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

-- |
-- 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 Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe
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 (THandle (..), TransportError, clientHandshake, runTCPClient)
import Simplex.Messaging.Util (bshow, liftError, raceAny_)
import System.IO
import System.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
defaultPort :: ServiceName,
    -- | timeout of TCP commands (microseconds)
    SMPClientConfig -> Int
tcpTimeout :: Int,
    -- | period for SMP ping commands (microseconds)
    SMPClientConfig -> Int
smpPing :: 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 -> Int -> Int -> Int -> SMPClientConfig
SMPClientConfig
    { $sel:qSize:SMPClientConfig :: Natural
qSize = 16,
      $sel:defaultPort:SMPClientConfig :: ServiceName
defaultPort = "5223",
      $sel:tcpTimeout:SMPClientConfig :: Int
tcpTimeout = 4_000_000,
      $sel:smpPing:SMPClientConfig :: Int
smpPing = 30_000_000,
      $sel:smpCommandSize:SMPClientConfig :: Int
smpCommandSize = 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
smpServer@SMPServer {ServiceName
host :: SMPServer -> ServiceName
host :: ServiceName
host, Maybe ServiceName
port :: SMPServer -> Maybe ServiceName
port :: Maybe ServiceName
port, Maybe KeyHash
keyHash :: SMPServer -> Maybe KeyHash
keyHash :: Maybe KeyHash
keyHash}
  SMPClientConfig {Natural
qSize :: Natural
$sel:qSize:SMPClientConfig :: SMPClientConfig -> Natural
qSize, ServiceName
defaultPort :: ServiceName
$sel:defaultPort:SMPClientConfig :: SMPClientConfig -> ServiceName
defaultPort, Int
tcpTimeout :: Int
$sel:tcpTimeout:SMPClientConfig :: SMPClientConfig -> Int
tcpTimeout, Int
smpPing :: Int
$sel:smpPing:SMPClientConfig :: SMPClientConfig -> Int
smpPing}
  msgQ :: TBQueue SMPServerTransmission
msgQ
  disconnected :: IO ()
disconnected = do
    SMPClient
c <- STM SMPClient -> IO SMPClient
forall a. STM a -> IO a
atomically STM SMPClient
mkSMPClient
    TMVar (Either SMPClientError THandle)
thVar <- IO (TMVar (Either SMPClientError THandle))
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 -> (Handle -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
ServiceName -> ServiceName -> (Handle -> m a) -> m a
runTCPClient ServiceName
host (ServiceName -> Maybe ServiceName -> ServiceName
forall a. a -> Maybe a -> a
fromMaybe ServiceName
defaultPort Maybe ServiceName
port) (SMPClient
-> TMVar (Either SMPClientError THandle) -> Handle -> IO ()
client SMPClient
c TMVar (Either SMPClientError THandle)
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 THandle)
-> Either SMPClientError THandle -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar (Either SMPClientError THandle)
thVar (Either SMPClientError THandle -> STM ())
-> Either SMPClientError THandle -> STM ()
forall a b. (a -> b) -> a -> b
$ SMPClientError -> Either SMPClientError THandle
forall a b. a -> Either a b
Left SMPClientError
SMPNetworkError)
    Maybe (Either SMPClientError THandle)
tHandle <- Int
tcpTimeout Int
-> IO (Either SMPClientError THandle)
-> IO (Maybe (Either SMPClientError THandle))
forall a. Int -> IO a -> IO (Maybe a)
`timeout` STM (Either SMPClientError THandle)
-> IO (Either SMPClientError THandle)
forall a. STM a -> IO a
atomically (TMVar (Either SMPClientError THandle)
-> STM (Either SMPClientError THandle)
forall a. TMVar a -> STM a
takeTMVar TMVar (Either SMPClientError THandle)
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 THandle)
tHandle of
      Just (Right THandle {Int
$sel:blockSize:THandle :: THandle -> Int
blockSize :: 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 e :: SMPClientError
e) -> SMPClientError -> Either SMPClientError SMPClient
forall a b. a -> Either a b
Left SMPClientError
e
      Nothing -> SMPClientError -> Either SMPClientError SMPClient
forall a b. a -> Either a b
Left SMPClientError
SMPNetworkError
    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 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
            }

      client :: SMPClient -> TMVar (Either SMPClientError THandle) -> Handle -> IO ()
      client :: SMPClient
-> TMVar (Either SMPClientError THandle) -> Handle -> IO ()
client c :: SMPClient
c thVar :: TMVar (Either SMPClientError THandle)
thVar h :: Handle
h =
        ExceptT TransportError IO THandle
-> IO (Either TransportError THandle)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (Handle -> Maybe KeyHash -> ExceptT TransportError IO THandle
clientHandshake Handle
h Maybe KeyHash
keyHash) IO (Either TransportError THandle)
-> (Either TransportError THandle -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Right th :: THandle
th -> SMPClient
-> TMVar (Either SMPClientError THandle) -> THandle -> IO ()
clientTransport SMPClient
c TMVar (Either SMPClientError THandle)
thVar THandle
th
          Left e :: 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 THandle)
-> Either SMPClientError THandle -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar (Either SMPClientError THandle)
thVar (Either SMPClientError THandle -> STM ())
-> (SMPClientError -> Either SMPClientError THandle)
-> SMPClientError
-> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SMPClientError -> Either SMPClientError THandle
forall a b. a -> Either a b
Left (SMPClientError -> IO ()) -> SMPClientError -> IO ()
forall a b. (a -> b) -> a -> b
$ TransportError -> SMPClientError
SMPTransportError TransportError
e

      clientTransport :: SMPClient -> TMVar (Either SMPClientError THandle) -> THandle -> IO ()
      clientTransport :: SMPClient
-> TMVar (Either SMPClientError THandle) -> THandle -> IO ()
clientTransport c :: SMPClient
c thVar :: TMVar (Either SMPClientError THandle)
thVar th :: THandle
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 THandle)
-> Either SMPClientError THandle -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar (Either SMPClientError THandle)
thVar (Either SMPClientError THandle -> STM ())
-> Either SMPClientError THandle -> STM ()
forall a b. (a -> b) -> a -> b
$ THandle -> Either SMPClientError THandle
forall a b. b -> Either a b
Right THandle
th
        [IO ()] -> IO ()
forall (m :: * -> *) a. MonadUnliftIO m => [m a] -> m ()
raceAny_ [SMPClient -> THandle -> IO ()
send SMPClient
c THandle
th, SMPClient -> IO ()
process SMPClient
c, SMPClient -> THandle -> IO ()
receive SMPClient
c THandle
th, SMPClient -> IO ()
ping SMPClient
c]
          IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` IO ()
disconnected

      send :: SMPClient -> THandle -> IO ()
      send :: SMPClient -> THandle -> IO ()
send SMPClient {TBQueue SignedRawTransmission
sndQ :: TBQueue SignedRawTransmission
$sel:sndQ:SMPClient :: SMPClient -> TBQueue SignedRawTransmission
sndQ} h :: THandle
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 -> SignedRawTransmission -> IO (Either TransportError ())
tPut THandle
h

      receive :: SMPClient -> THandle -> IO ()
      receive :: SMPClient -> THandle -> IO ()
receive SMPClient {TBQueue SignedTransmissionOrError
rcvQ :: TBQueue SignedTransmissionOrError
$sel:rcvQ:SMPClient :: SMPClient -> TBQueue SignedTransmissionOrError
rcvQ} h :: THandle
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 -> IO SignedTransmissionOrError
forall (m :: * -> *).
MonadIO m =>
(Cmd -> Either ErrorType Cmd)
-> THandle -> m SignedTransmissionOrError
tGet Cmd -> Either ErrorType Cmd
fromServer THandle
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 c :: 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 "" (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
        (_, (corrId :: CorrId
corrId, qId :: QueueId
qId, respOrErr :: 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
        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
          Nothing -> do
            case Either ErrorType Cmd
respOrErr of
              Right (Cmd SBroker cmd :: 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
              _ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          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 e :: 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 _ (ERR e :: 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 r :: 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

-- | 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 c :: SMPClient
c rpKey :: SafePrivateKey
rpKey rKey :: 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) "" (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 _ (IDS rId :: QueueId
rId sId :: QueueId
sId) -> (QueueId, QueueId) -> ExceptT SMPClientError IO (QueueId, QueueId)
forall (m :: * -> *) a. Monad m => a -> m a
return (QueueId
rId, QueueId
sId)
    _ -> 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} rpKey :: SafePrivateKey
rpKey rId :: 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 _ OK -> () -> ExceptT SMPClientError IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Cmd _ 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)
    _ -> 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 c :: SMPClient
c rpKey :: SafePrivateKey
rpKey rId :: QueueId
rId senderKey :: 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 c :: SMPClient
c spKey :: Maybe SafePrivateKey
spKey sId :: QueueId
sId msg :: 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 _ OK -> () -> ExceptT SMPClientError IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    _ -> 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} rpKey :: SafePrivateKey
rpKey rId :: 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 _ OK -> () -> ExceptT SMPClientError IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Cmd _ 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)
    _ -> 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
cmd c :: SMPClient
c pKey :: SafePrivateKey
pKey qId :: 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 _ OK -> () -> ExceptT SMPClientError IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    _ -> 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} pKey :: Maybe SafePrivateKey
pKey qId :: QueueId
qId cmd :: 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_ action :: 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
$ \i :: Natural
i -> (Natural
i, Natural
i Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ 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 t :: QueueId
t = case Maybe SafePrivateKey
pKey of
      Nothing -> SignedRawTransmission
-> ExceptT SMPClientError IO SignedRawTransmission
forall (m :: * -> *) a. Monad m => a -> m a
return ("", QueueId
t)
      Just pk :: 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
corrId t :: 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 a :: 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
corrId t :: 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