mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-07-29 01:10:31 +00:00
agent: support different timeouts for interactive and background requests (#1582)
* agent: support different timeouts for interactive and background requests * fix tests * use one constructor for the first request and for retries
This commit is contained in:
Evgeny
@@ -36,8 +36,10 @@ import Simplex.FileTransfer.Protocol
|
||||
import Simplex.FileTransfer.Transport
|
||||
import Simplex.Messaging.Client
|
||||
( NetworkConfig (..),
|
||||
NetworkRequestMode (..),
|
||||
ProtocolClientError (..),
|
||||
TransportSession,
|
||||
netTimeoutInt,
|
||||
chooseTransportHost,
|
||||
defaultNetworkConfig,
|
||||
transportClientConfig,
|
||||
@@ -107,7 +109,7 @@ getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN,
|
||||
let socksCreds = clientSocksCredentials xftpNetworkConfig proxySessTs transportSession
|
||||
ProtocolServer _ host port keyHash = srv
|
||||
useHost <- liftEither $ chooseTransportHost xftpNetworkConfig host
|
||||
let tcConfig = transportClientConfig xftpNetworkConfig useHost False clientALPN
|
||||
let tcConfig = transportClientConfig xftpNetworkConfig NRMBackground useHost False clientALPN
|
||||
http2Config = xftpHTTP2Config tcConfig config
|
||||
clientVar <- newTVarIO Nothing
|
||||
let usePort = if null port then "443" else port
|
||||
@@ -178,7 +180,7 @@ xftpHTTP2Config transportConfig XFTPClientConfig {xftpNetworkConfig = NetworkCon
|
||||
defaultHTTP2ClientConfig
|
||||
{ bodyHeadSize = xftpBlockSize,
|
||||
suportedTLSParams = defaultSupportedParams,
|
||||
connTimeout = tcpConnectTimeout,
|
||||
connTimeout = netTimeoutInt tcpConnectTimeout NRMBackground,
|
||||
transportConfig
|
||||
}
|
||||
|
||||
@@ -268,11 +270,11 @@ downloadXFTPChunk g c@XFTPClient {config} rpKey fId chunkSpec@XFTPRcvChunkSpec {
|
||||
|
||||
xftpReqTimeout :: XFTPClientConfig -> Maybe Word32 -> Int
|
||||
xftpReqTimeout cfg@XFTPClientConfig {xftpNetworkConfig = NetworkConfig {tcpTimeout}} chunkSize_ =
|
||||
maybe tcpTimeout (chunkTimeout cfg) chunkSize_
|
||||
maybe (netTimeoutInt tcpTimeout NRMBackground) (chunkTimeout cfg) chunkSize_
|
||||
|
||||
chunkTimeout :: XFTPClientConfig -> Word32 -> Int
|
||||
chunkTimeout XFTPClientConfig {xftpNetworkConfig = NetworkConfig {tcpTimeout, tcpTimeoutPerKb}} sz =
|
||||
tcpTimeout + fromIntegral (min ((fromIntegral sz `div` 1024) * tcpTimeoutPerKb) (fromIntegral (maxBound :: Int)))
|
||||
netTimeoutInt tcpTimeout NRMBackground + fromIntegral (min ((fromIntegral sz `div` 1024) * tcpTimeoutPerKb) (fromIntegral (maxBound :: Int)))
|
||||
|
||||
deleteXFTPChunk :: XFTPClient -> C.APrivateAuthKey -> SenderId -> ExceptT XFTPClientError IO ()
|
||||
deleteXFTPChunk c spKey sId = sendXFTPCommand c spKey sId FDEL Nothing >>= okResponse
|
||||
|
||||
@@ -19,7 +19,7 @@ import Data.Text.Encoding (decodeUtf8)
|
||||
import Data.Time.Clock (UTCTime, getCurrentTime)
|
||||
import Simplex.FileTransfer.Client
|
||||
import Simplex.Messaging.Agent.RetryInterval
|
||||
import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientError (..), temporaryClientError)
|
||||
import Simplex.Messaging.Client (NetworkConfig (..), NetworkRequestMode (..), ProtocolClientError (..), netTimeoutInt, temporaryClientError)
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Protocol (ProtocolServer (..), XFTPServer)
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
@@ -90,7 +90,7 @@ getXFTPServerClient XFTPClientAgent {xftpClients, startedAt, config} srv = do
|
||||
waitForXFTPClient :: XFTPClientVar -> ME XFTPClient
|
||||
waitForXFTPClient clientVar = do
|
||||
let XFTPClientConfig {xftpNetworkConfig = NetworkConfig {tcpConnectTimeout}} = xftpConfig config
|
||||
client_ <- liftIO $ tcpConnectTimeout `timeout` atomically (readTMVar clientVar)
|
||||
client_ <- liftIO $ netTimeoutInt tcpConnectTimeout NRMBackground `timeout` atomically (readTMVar clientVar)
|
||||
liftEither $ case client_ of
|
||||
Just (Right c) -> Right c
|
||||
Just (Left e) -> Left e
|
||||
@@ -127,6 +127,6 @@ closeXFTPServerClient XFTPClientAgent {xftpClients, config} srv =
|
||||
where
|
||||
closeClient cVar = do
|
||||
let NetworkConfig {tcpConnectTimeout} = xftpNetworkConfig $ xftpConfig config
|
||||
tcpConnectTimeout `timeout` atomically (readTMVar cVar) >>= \case
|
||||
netTimeoutInt tcpConnectTimeout NRMBackground `timeout` atomically (readTMVar cVar) >>= \case
|
||||
Just (Right client) -> closeXFTPClient client `catchAll_` pure ()
|
||||
_ -> pure ()
|
||||
|
||||
+141
-139
@@ -182,7 +182,7 @@ import Simplex.Messaging.Agent.Store.Common (DBStore)
|
||||
import qualified Simplex.Messaging.Agent.Store.DB as DB
|
||||
import Simplex.Messaging.Agent.Store.Interface (closeDBStore, execSQL, getCurrentMigrations)
|
||||
import Simplex.Messaging.Agent.Store.Shared (UpMigration (..), upMigration)
|
||||
import Simplex.Messaging.Client (SMPClientError, ServerTransmission (..), ServerTransmissionBatch, nonBlockingWriteTBQueue, temporaryClientError, unexpectedResponse)
|
||||
import Simplex.Messaging.Client (NetworkRequestMode (..), SMPClientError, ServerTransmission (..), ServerTransmissionBatch, nonBlockingWriteTBQueue, temporaryClientError, unexpectedResponse)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Crypto.File (CryptoFile, CryptoFileArgs)
|
||||
import Simplex.Messaging.Crypto.Ratchet (PQEncryption, PQSupport (..), pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn)
|
||||
@@ -368,22 +368,22 @@ deleteConnectionsAsync c waitDelivery = withAgentEnv c . deleteConnectionsAsync'
|
||||
{-# INLINE deleteConnectionsAsync #-}
|
||||
|
||||
-- | Create SMP agent connection (NEW command)
|
||||
createConnection :: ConnectionModeI c => AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe UserLinkData -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> AE (ConnId, (CreatedConnLink c, Maybe ClientServiceId))
|
||||
createConnection c userId enableNtfs = withAgentEnv c .::. newConn c userId enableNtfs
|
||||
createConnection :: ConnectionModeI c => AgentClient -> NetworkRequestMode -> UserId -> Bool -> SConnectionMode c -> Maybe UserLinkData -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> AE (ConnId, (CreatedConnLink c, Maybe ClientServiceId))
|
||||
createConnection c nm userId enableNtfs = withAgentEnv c .::. newConn c nm userId enableNtfs
|
||||
{-# INLINE createConnection #-}
|
||||
|
||||
-- | Create or update user's contact connection short link
|
||||
setConnShortLink :: AgentClient -> ConnId -> SConnectionMode c -> UserLinkData -> Maybe CRClientData -> AE (ConnShortLink c)
|
||||
setConnShortLink c = withAgentEnv c .:: setConnShortLink' c
|
||||
setConnShortLink :: AgentClient -> NetworkRequestMode -> ConnId -> SConnectionMode c -> UserLinkData -> Maybe CRClientData -> AE (ConnShortLink c)
|
||||
setConnShortLink c = withAgentEnv c .::. setConnShortLink' c
|
||||
{-# INLINE setConnShortLink #-}
|
||||
|
||||
deleteConnShortLink :: AgentClient -> ConnId -> SConnectionMode c -> AE ()
|
||||
deleteConnShortLink c = withAgentEnv c .: deleteConnShortLink' c
|
||||
deleteConnShortLink :: AgentClient -> NetworkRequestMode -> ConnId -> SConnectionMode c -> AE ()
|
||||
deleteConnShortLink c = withAgentEnv c .:. deleteConnShortLink' c
|
||||
{-# INLINE deleteConnShortLink #-}
|
||||
|
||||
-- | Get and verify data from short link. For 1-time invitations it preserves the key to allow retries
|
||||
getConnShortLink :: AgentClient -> UserId -> ConnShortLink c -> AE (ConnectionRequestUri c, ConnLinkData c)
|
||||
getConnShortLink c = withAgentEnv c .: getConnShortLink' c
|
||||
getConnShortLink :: AgentClient -> NetworkRequestMode -> UserId -> ConnShortLink c -> AE (ConnectionRequestUri c, ConnLinkData c)
|
||||
getConnShortLink c = withAgentEnv c .:. getConnShortLink' c
|
||||
{-# INLINE getConnShortLink #-}
|
||||
|
||||
-- | This irreversibly deletes short link data, and it won't be retrievable again
|
||||
@@ -411,8 +411,8 @@ prepareConnectionToAccept c userId enableNtfs = withAgentEnv c .: newConnToAccep
|
||||
{-# INLINE prepareConnectionToAccept #-}
|
||||
|
||||
-- | Join SMP agent connection (JOIN command).
|
||||
joinConnection :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AE (SndQueueSecured, Maybe ClientServiceId)
|
||||
joinConnection c userId connId enableNtfs = withAgentEnv c .:: joinConn c userId connId enableNtfs
|
||||
joinConnection :: AgentClient -> NetworkRequestMode -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AE (SndQueueSecured, Maybe ClientServiceId)
|
||||
joinConnection c nm userId connId enableNtfs = withAgentEnv c .:: joinConn c nm userId connId enableNtfs
|
||||
{-# INLINE joinConnection #-}
|
||||
|
||||
-- | Allow connection to continue after CONF notification (LET command)
|
||||
@@ -421,8 +421,8 @@ allowConnection c = withAgentEnv c .:. allowConnection' c
|
||||
{-# INLINE allowConnection #-}
|
||||
|
||||
-- | Accept contact after REQ notification (ACPT command)
|
||||
acceptContact :: AgentClient -> UserId -> ConnId -> Bool -> ConfirmationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AE (SndQueueSecured, Maybe ClientServiceId)
|
||||
acceptContact c userId connId enableNtfs = withAgentEnv c .:: acceptContact' c userId connId enableNtfs
|
||||
acceptContact :: AgentClient -> NetworkRequestMode -> UserId -> ConnId -> Bool -> ConfirmationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AE (SndQueueSecured, Maybe ClientServiceId)
|
||||
acceptContact c userId connId enableNtfs = withAgentEnv c .::. acceptContact' c userId connId enableNtfs
|
||||
{-# INLINE acceptContact #-}
|
||||
|
||||
-- | Reject contact (RJCT command)
|
||||
@@ -501,13 +501,13 @@ ackMessage :: AgentClient -> ConnId -> AgentMsgId -> Maybe MsgReceiptInfo -> AE
|
||||
ackMessage c = withAgentEnv c .:. ackMessage' c
|
||||
{-# INLINE ackMessage #-}
|
||||
|
||||
getConnectionQueueInfo :: AgentClient -> ConnId -> AE ServerQueueInfo
|
||||
getConnectionQueueInfo c = withAgentEnv c . getConnectionQueueInfo' c
|
||||
getConnectionQueueInfo :: AgentClient -> NetworkRequestMode -> ConnId -> AE ServerQueueInfo
|
||||
getConnectionQueueInfo c = withAgentEnv c .: getConnectionQueueInfo' c
|
||||
{-# INLINE getConnectionQueueInfo #-}
|
||||
|
||||
-- | Switch connection to the new receive queue
|
||||
switchConnection :: AgentClient -> ConnId -> AE ConnectionStats
|
||||
switchConnection c = withAgentEnv c . switchConnection' c
|
||||
switchConnection :: AgentClient -> NetworkRequestMode -> ConnId -> AE ConnectionStats
|
||||
switchConnection c = withAgentEnv c .: switchConnection' c
|
||||
{-# INLINE switchConnection #-}
|
||||
|
||||
-- | Abort switching connection to the new receive queue
|
||||
@@ -521,18 +521,18 @@ synchronizeRatchet c = withAgentEnv c .:. synchronizeRatchet' c
|
||||
{-# INLINE synchronizeRatchet #-}
|
||||
|
||||
-- | Suspend SMP agent connection (OFF command)
|
||||
suspendConnection :: AgentClient -> ConnId -> AE ()
|
||||
suspendConnection c = withAgentEnv c . suspendConnection' c
|
||||
suspendConnection :: AgentClient -> NetworkRequestMode -> ConnId -> AE ()
|
||||
suspendConnection c = withAgentEnv c .: suspendConnection' c
|
||||
{-# INLINE suspendConnection #-}
|
||||
|
||||
-- | Delete SMP agent connection (DEL command)
|
||||
deleteConnection :: AgentClient -> ConnId -> AE ()
|
||||
deleteConnection c = withAgentEnv c . deleteConnection' c
|
||||
deleteConnection :: AgentClient -> NetworkRequestMode -> ConnId -> AE ()
|
||||
deleteConnection c = withAgentEnv c .: deleteConnection' c
|
||||
{-# INLINE deleteConnection #-}
|
||||
|
||||
-- | Delete multiple connections, batching commands when possible
|
||||
deleteConnections :: AgentClient -> [ConnId] -> AE (Map ConnId (Either AgentErrorType ()))
|
||||
deleteConnections c = withAgentEnv c . deleteConnections' c
|
||||
deleteConnections :: AgentClient -> NetworkRequestMode -> [ConnId] -> AE (Map ConnId (Either AgentErrorType ()))
|
||||
deleteConnections c = withAgentEnv c .: deleteConnections' c
|
||||
{-# INLINE deleteConnections #-}
|
||||
|
||||
-- | get servers used for connection
|
||||
@@ -546,11 +546,11 @@ getConnectionRatchetAdHash c = withAgentEnv c . getConnectionRatchetAdHash' c
|
||||
{-# INLINE getConnectionRatchetAdHash #-}
|
||||
|
||||
-- | Test protocol server
|
||||
testProtocolServer :: forall p. ProtocolTypeI p => AgentClient -> UserId -> ProtoServerWithAuth p -> IO (Maybe ProtocolTestFailure)
|
||||
testProtocolServer c userId srv = withAgentEnv' c $ case protocolTypeI @p of
|
||||
SPSMP -> runSMPServerTest c userId srv
|
||||
SPXFTP -> runXFTPServerTest c userId srv
|
||||
SPNTF -> runNTFServerTest c userId srv
|
||||
testProtocolServer :: forall p. ProtocolTypeI p => AgentClient -> NetworkRequestMode -> UserId -> ProtoServerWithAuth p -> IO (Maybe ProtocolTestFailure)
|
||||
testProtocolServer c nm userId srv = withAgentEnv' c $ case protocolTypeI @p of
|
||||
SPSMP -> runSMPServerTest c nm userId srv
|
||||
SPXFTP -> runXFTPServerTest c nm userId srv
|
||||
SPNTF -> runNTFServerTest c nm userId srv
|
||||
|
||||
-- | set SOCKS5 proxy on/off and optionally set TCP timeouts for fast network
|
||||
setNetworkConfig :: AgentClient -> NetworkConfig -> IO ()
|
||||
@@ -583,17 +583,17 @@ reconnectAllServers c = do
|
||||
reconnectServerClients c ntfClients
|
||||
|
||||
-- | Register device notifications token
|
||||
registerNtfToken :: AgentClient -> DeviceToken -> NotificationsMode -> AE NtfTknStatus
|
||||
registerNtfToken c = withAgentEnv c .: registerNtfToken' c
|
||||
registerNtfToken :: AgentClient -> NetworkRequestMode -> DeviceToken -> NotificationsMode -> AE NtfTknStatus
|
||||
registerNtfToken c = withAgentEnv c .:. registerNtfToken' c
|
||||
{-# INLINE registerNtfToken #-}
|
||||
|
||||
-- | Verify device notifications token
|
||||
verifyNtfToken :: AgentClient -> DeviceToken -> C.CbNonce -> ByteString -> AE ()
|
||||
verifyNtfToken c = withAgentEnv c .:. verifyNtfToken' c
|
||||
verifyNtfToken :: AgentClient -> NetworkRequestMode -> DeviceToken -> C.CbNonce -> ByteString -> AE ()
|
||||
verifyNtfToken c = withAgentEnv c .:: verifyNtfToken' c
|
||||
{-# INLINE verifyNtfToken #-}
|
||||
|
||||
checkNtfToken :: AgentClient -> DeviceToken -> AE NtfTknStatus
|
||||
checkNtfToken c = withAgentEnv c . checkNtfToken' c
|
||||
checkNtfToken :: AgentClient -> NetworkRequestMode -> DeviceToken -> AE NtfTknStatus
|
||||
checkNtfToken c = withAgentEnv c .: checkNtfToken' c
|
||||
{-# INLINE checkNtfToken #-}
|
||||
|
||||
deleteNtfToken :: AgentClient -> DeviceToken -> AE ()
|
||||
@@ -812,7 +812,7 @@ deleteConnectionsAsync_ onSuccess c waitDelivery connIds = case connIds of
|
||||
withStore' c $ \db -> forM_ connIds' $ setConnDeleted db waitDelivery
|
||||
void . lift . forkIO $
|
||||
withLock' (deleteLock c) "deleteConnectionsAsync" $
|
||||
deleteConnQueues c waitDelivery True rqs >> void (runExceptT onSuccess)
|
||||
deleteConnQueues c NRMBackground waitDelivery True rqs >> void (runExceptT onSuccess)
|
||||
|
||||
-- | Add connection to the new receive queue
|
||||
switchConnectionAsync' :: AgentClient -> ACorrId -> ConnId -> AM ConnectionStats
|
||||
@@ -829,22 +829,22 @@ switchConnectionAsync' c corrId connId =
|
||||
pure . connectionStats $ DuplexConnection cData rqs' sqs
|
||||
_ -> throwE $ CMD PROHIBITED "switchConnectionAsync: not duplex"
|
||||
|
||||
newConn :: ConnectionModeI c => AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe UserLinkData -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> AM (ConnId, (CreatedConnLink c, Maybe ClientServiceId))
|
||||
newConn c userId enableNtfs cMode userData_ clientData pqInitKeys subMode = do
|
||||
newConn :: ConnectionModeI c => AgentClient -> NetworkRequestMode -> UserId -> Bool -> SConnectionMode c -> Maybe UserLinkData -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> AM (ConnId, (CreatedConnLink c, Maybe ClientServiceId))
|
||||
newConn c nm userId enableNtfs cMode userData_ clientData pqInitKeys subMode = do
|
||||
srv <- getSMPServer c userId
|
||||
connId <- newConnNoQueues c userId enableNtfs cMode (CR.connPQEncryption pqInitKeys)
|
||||
(connId,) <$> newRcvConnSrv c userId connId enableNtfs cMode userData_ clientData pqInitKeys subMode srv
|
||||
(connId,) <$> newRcvConnSrv c nm userId connId enableNtfs cMode userData_ clientData pqInitKeys subMode srv
|
||||
`catchE` \e -> withStore' c (`deleteConnRecord` connId) >> throwE e
|
||||
|
||||
setConnShortLink' :: AgentClient -> ConnId -> SConnectionMode c -> UserLinkData -> Maybe CRClientData -> AM (ConnShortLink c)
|
||||
setConnShortLink' c connId cMode userData clientData =
|
||||
setConnShortLink' :: AgentClient -> NetworkRequestMode -> ConnId -> SConnectionMode c -> UserLinkData -> Maybe CRClientData -> AM (ConnShortLink c)
|
||||
setConnShortLink' c nm connId cMode userData clientData =
|
||||
withConnLock c connId "setConnShortLink" $ do
|
||||
SomeConn _ conn <- withStore c (`getConn` connId)
|
||||
(rq, lnkId, sl, d) <- case (conn, cMode) of
|
||||
(ContactConnection _ rq, SCMContact) -> prepareContactLinkData rq
|
||||
(RcvConnection _ rq, SCMInvitation) -> prepareInvLinkData rq
|
||||
_ -> throwE $ CMD PROHIBITED "setConnShortLink: invalid connection or mode"
|
||||
addQueueLink c rq lnkId d
|
||||
addQueueLink c nm rq lnkId d
|
||||
pure sl
|
||||
where
|
||||
prepareContactLinkData :: RcvQueue -> AM (RcvQueue, SMP.LinkId, ConnShortLink 'CMContact, QueueLinkData)
|
||||
@@ -879,18 +879,18 @@ setConnShortLink' c connId cMode userData clientData =
|
||||
pure (rq, shortLinkId, sl, (linkEncFixedData, d))
|
||||
Nothing -> throwE $ CMD PROHIBITED "setConnShortLink: no ShortLinkCreds in invitation"
|
||||
|
||||
deleteConnShortLink' :: AgentClient -> ConnId -> SConnectionMode c -> AM ()
|
||||
deleteConnShortLink' c connId cMode =
|
||||
deleteConnShortLink' :: AgentClient -> NetworkRequestMode -> ConnId -> SConnectionMode c -> AM ()
|
||||
deleteConnShortLink' c nm connId cMode =
|
||||
withConnLock c connId "deleteConnShortLink" $ do
|
||||
SomeConn _ conn <- withStore c (`getConn` connId)
|
||||
case (conn, cMode) of
|
||||
(ContactConnection _ rq, SCMContact) -> deleteQueueLink c rq
|
||||
(RcvConnection _ rq, SCMInvitation) -> deleteQueueLink c rq
|
||||
(ContactConnection _ rq, SCMContact) -> deleteQueueLink c nm rq
|
||||
(RcvConnection _ rq, SCMInvitation) -> deleteQueueLink c nm rq
|
||||
_ -> throwE $ CMD PROHIBITED "deleteConnShortLink: not contact address"
|
||||
|
||||
-- TODO [short links] remove 1-time invitation data and link ID from the server after the message is sent.
|
||||
getConnShortLink' :: forall c. AgentClient -> UserId -> ConnShortLink c -> AM (ConnectionRequestUri c, ConnLinkData c)
|
||||
getConnShortLink' c userId = \case
|
||||
getConnShortLink' :: forall c. AgentClient -> NetworkRequestMode -> UserId -> ConnShortLink c -> AM (ConnectionRequestUri c, ConnLinkData c)
|
||||
getConnShortLink' c nm userId = \case
|
||||
CSLInvitation _ srv linkId linkKey -> do
|
||||
g <- asks random
|
||||
invLink <- withStore' c $ \db -> do
|
||||
@@ -902,12 +902,12 @@ getConnShortLink' c userId = \case
|
||||
createInvShortLink db sl
|
||||
pure sl
|
||||
let k = SL.invShortLinkKdf linkKey
|
||||
ld@(sndId, _) <- secureGetQueueLink c userId invLink
|
||||
ld@(sndId, _) <- secureGetQueueLink c nm userId invLink
|
||||
withStore' c $ \db -> setInvShortLinkSndId db invLink sndId
|
||||
decryptData srv linkKey k ld
|
||||
CSLContact _ _ srv linkKey -> do
|
||||
let (linkId, k) = SL.contactShortLinkKdf linkKey
|
||||
ld <- getQueueLink c userId srv linkId
|
||||
ld <- getQueueLink c nm userId srv linkId
|
||||
decryptData srv linkKey k ld
|
||||
where
|
||||
decryptData :: ConnectionModeI c => SMPServer -> LinkKey -> C.SbKey -> (SMP.SenderId, QueueLinkData) -> AM (ConnectionRequestUri c, ConnLinkData c)
|
||||
@@ -932,8 +932,8 @@ changeConnectionUser' c oldUserId connId newUserId = do
|
||||
where
|
||||
updateConn = withStore' c $ \db -> setConnUserId db oldUserId connId newUserId
|
||||
|
||||
newRcvConnSrv :: forall c. ConnectionModeI c => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe UserLinkData -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> SMPServerWithAuth -> AM (CreatedConnLink c, Maybe ClientServiceId)
|
||||
newRcvConnSrv c userId connId enableNtfs cMode userData_ clientData pqInitKeys subMode srvWithAuth@(ProtoServerWithAuth srv _) = do
|
||||
newRcvConnSrv :: forall c. ConnectionModeI c => AgentClient -> NetworkRequestMode -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe UserLinkData -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> SMPServerWithAuth -> AM (CreatedConnLink c, Maybe ClientServiceId)
|
||||
newRcvConnSrv c nm userId connId enableNtfs cMode userData_ clientData pqInitKeys subMode srvWithAuth@(ProtoServerWithAuth srv _) = do
|
||||
case (cMode, pqInitKeys) of
|
||||
(SCMContact, CR.IKUsePQ) -> throwE $ CMD PROHIBITED "newRcvConnSrv"
|
||||
_ -> pure ()
|
||||
@@ -955,7 +955,7 @@ newRcvConnSrv c userId connId enableNtfs cMode userData_ clientData pqInitKeys s
|
||||
AgentConfig {smpClientVRange = vr} <- asks config
|
||||
-- TODO [notifications] send correct NTF credentials here
|
||||
-- let ntfCreds_ = Nothing
|
||||
(rq, qUri, tSess, sessId) <- newRcvQueue_ c userId connId srvWithAuth vr qd subMode nonce_ e2eKeys `catchAgentError` \e -> liftIO (print e) >> throwE e
|
||||
(rq, qUri, tSess, sessId) <- newRcvQueue_ c nm userId connId srvWithAuth vr qd subMode nonce_ e2eKeys `catchAgentError` \e -> liftIO (print e) >> throwE e
|
||||
atomically $ incSMPServerStat c userId srv connCreated
|
||||
rq' <- withStore c $ \db -> updateNewConnRcv db connId rq
|
||||
lift . when (subMode == SMSubscribe) $ addNewQueueSubscription c rq' tSess sessId
|
||||
@@ -1038,10 +1038,10 @@ newConnToAccept c userId connId enableNtfs invId pqSup = do
|
||||
Invitation {connReq} <- withStore c $ \db -> getInvitation db "newConnToAccept" invId
|
||||
newConnToJoin c userId connId enableNtfs connReq pqSup
|
||||
|
||||
joinConn :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AM (SndQueueSecured, Maybe ClientServiceId)
|
||||
joinConn c userId connId enableNtfs cReq cInfo pqSupport subMode = do
|
||||
joinConn :: AgentClient -> NetworkRequestMode -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AM (SndQueueSecured, Maybe ClientServiceId)
|
||||
joinConn c nm userId connId enableNtfs cReq cInfo pqSupport subMode = do
|
||||
srv <- getNextSMPServer c userId [qServer $ connReqQueue cReq]
|
||||
joinConnSrv c userId connId enableNtfs cReq cInfo pqSupport subMode srv
|
||||
joinConnSrv c nm userId connId enableNtfs cReq cInfo pqSupport subMode srv
|
||||
|
||||
connReqQueue :: ConnectionRequestUri c -> SMPQueueUri
|
||||
connReqQueue = \case
|
||||
@@ -1118,8 +1118,8 @@ versionPQSupport_ :: VersionSMPA -> Maybe CR.VersionE2E -> PQSupport
|
||||
versionPQSupport_ agentV e2eV_ = PQSupport $ agentV >= pqdrSMPAgentVersion && maybe True (>= CR.pqRatchetE2EEncryptVersion) e2eV_
|
||||
{-# INLINE versionPQSupport_ #-}
|
||||
|
||||
joinConnSrv :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> SMPServerWithAuth -> AM (SndQueueSecured, Maybe ClientServiceId)
|
||||
joinConnSrv c userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSup subMode srv =
|
||||
joinConnSrv :: AgentClient -> NetworkRequestMode -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> SMPServerWithAuth -> AM (SndQueueSecured, Maybe ClientServiceId)
|
||||
joinConnSrv c nm userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSup subMode srv =
|
||||
withInvLock c (strEncode inv) "joinConnSrv" $ do
|
||||
SomeConn cType conn <- withStore c (`getConn` connId)
|
||||
case conn of
|
||||
@@ -1132,19 +1132,19 @@ joinConnSrv c userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSup subMod
|
||||
doJoin :: Maybe RcvQueue -> Maybe SndQueue -> AM (SndQueueSecured, Maybe ClientServiceId)
|
||||
doJoin rq_ sq_ = do
|
||||
(cData, sq, e2eSndParams, lnkId_) <- startJoinInvitation c userId connId sq_ enableNtfs inv pqSup
|
||||
secureConfirmQueue c cData rq_ sq srv cInfo (Just e2eSndParams) subMode
|
||||
secureConfirmQueue c nm cData rq_ sq srv cInfo (Just e2eSndParams) subMode
|
||||
>>= (mapM_ (delInvSL c connId srv) lnkId_ $>)
|
||||
joinConnSrv c userId connId enableNtfs cReqUri@CRContactUri {} cInfo pqSup subMode srv =
|
||||
joinConnSrv c nm userId connId enableNtfs cReqUri@CRContactUri {} cInfo pqSup subMode srv =
|
||||
lift (compatibleContactUri cReqUri) >>= \case
|
||||
Just (qInfo, vrsn@(Compatible v)) ->
|
||||
withInvLock c (strEncode cReqUri) "joinConnSrv" $ do
|
||||
SomeConn cType conn <- withStore c (`getConn` connId)
|
||||
let pqInitKeys = CR.joinContactInitialKeys (v >= pqdrSMPAgentVersion) pqSup
|
||||
(CCLink cReq _, service) <- case conn of
|
||||
NewConnection _ -> newRcvConnSrv c userId connId enableNtfs SCMInvitation Nothing Nothing pqInitKeys subMode srv
|
||||
NewConnection _ -> newRcvConnSrv c NRMBackground userId connId enableNtfs SCMInvitation Nothing Nothing pqInitKeys subMode srv
|
||||
RcvConnection _ rq -> mkJoinInvitation rq pqInitKeys
|
||||
_ -> throwE $ CMD PROHIBITED $ "joinConnSrv: bad connection " <> show cType
|
||||
void $ sendInvitation c userId connId qInfo vrsn cReq cInfo
|
||||
void $ sendInvitation c nm userId connId qInfo vrsn cReq cInfo
|
||||
pure (False, service)
|
||||
where
|
||||
mkJoinInvitation rq@RcvQueue {clientService} pqInitKeys = do
|
||||
@@ -1190,10 +1190,10 @@ joinConnSrvAsync c userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSuppo
|
||||
joinConnSrvAsync _c _userId _connId _enableNtfs (CRContactUri _) _cInfo _subMode _pqSupport _srv = do
|
||||
throwE $ CMD PROHIBITED "joinConnSrvAsync"
|
||||
|
||||
createReplyQueue :: AgentClient -> ConnData -> SndQueue -> SubscriptionMode -> SMPServerWithAuth -> AM (SMPQueueInfo, Maybe ClientServiceId)
|
||||
createReplyQueue c ConnData {userId, connId, enableNtfs} SndQueue {smpClientVersion} subMode srv = do
|
||||
createReplyQueue :: AgentClient -> NetworkRequestMode -> ConnData -> SndQueue -> SubscriptionMode -> SMPServerWithAuth -> AM (SMPQueueInfo, Maybe ClientServiceId)
|
||||
createReplyQueue c nm ConnData {userId, connId, enableNtfs} SndQueue {smpClientVersion} subMode srv = do
|
||||
-- TODO [notifications] send correct NTF credentials here
|
||||
(rq, qUri, tSess, sessId) <- newRcvQueue c userId connId srv (versionToRange smpClientVersion) SCMInvitation subMode -- Nothing
|
||||
(rq, qUri, tSess, sessId) <- newRcvQueue c nm userId connId srv (versionToRange smpClientVersion) SCMInvitation subMode -- Nothing
|
||||
atomically $ incSMPServerStat c userId (qServer rq) connCreated
|
||||
let qInfo = toVersionT qUri smpClientVersion
|
||||
rq' <- withStore c $ \db -> upgradeSndConnToDuplex db connId rq
|
||||
@@ -1214,10 +1214,10 @@ allowConnection' c connId confId ownConnInfo = withConnLock c connId "allowConne
|
||||
_ -> throwE $ CMD PROHIBITED "allowConnection"
|
||||
|
||||
-- | Accept contact (ACPT command) in Reader monad
|
||||
acceptContact' :: AgentClient -> UserId -> ConnId -> Bool -> InvitationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AM (SndQueueSecured, Maybe ClientServiceId)
|
||||
acceptContact' c userId connId enableNtfs invId ownConnInfo pqSupport subMode = withConnLock c connId "acceptContact" $ do
|
||||
acceptContact' :: AgentClient -> NetworkRequestMode -> UserId -> ConnId -> Bool -> InvitationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AM (SndQueueSecured, Maybe ClientServiceId)
|
||||
acceptContact' c nm userId connId enableNtfs invId ownConnInfo pqSupport subMode = withConnLock c connId "acceptContact" $ do
|
||||
Invitation {connReq} <- withStore c $ \db -> getInvitation db "acceptContact'" invId
|
||||
r <- joinConn c userId connId enableNtfs connReq ownConnInfo pqSupport subMode
|
||||
r <- joinConn c nm userId connId enableNtfs connReq ownConnInfo pqSupport subMode
|
||||
withStore' c $ \db -> acceptInvitation db invId ownConnInfo
|
||||
pure r
|
||||
|
||||
@@ -1486,7 +1486,7 @@ runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do
|
||||
NEW enableNtfs (ACM cMode) pqEnc subMode -> noServer $ do
|
||||
triedHosts <- newTVarIO S.empty
|
||||
tryCommand . withNextSrv c userId storageSrvs triedHosts [] $ \srv -> do
|
||||
(CCLink cReq _, service) <- newRcvConnSrv c userId connId enableNtfs cMode Nothing Nothing pqEnc subMode srv
|
||||
(CCLink cReq _, service) <- newRcvConnSrv c NRMBackground userId connId enableNtfs cMode Nothing Nothing pqEnc subMode srv
|
||||
notify $ INV (ACR cMode cReq) service
|
||||
JOIN enableNtfs (ACR _ cReq@(CRInvitationUri ConnReqUriData {crSmpQueues = q :| _} _)) pqEnc subMode connInfo -> noServer $ do
|
||||
triedHosts <- newTVarIO S.empty
|
||||
@@ -1499,9 +1499,9 @@ runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do
|
||||
noServer . tryWithLock "switchConnection" $
|
||||
withStore c (`getConn` connId) >>= \case
|
||||
SomeConn _ conn@(DuplexConnection _ (replaced :| _rqs) _) ->
|
||||
switchDuplexConnection c conn replaced >>= notify . SWITCH QDRcv SPStarted
|
||||
switchDuplexConnection c NRMBackground conn replaced >>= notify . SWITCH QDRcv SPStarted
|
||||
_ -> throwE $ CMD PROHIBITED "SWCH: not duplex"
|
||||
DEL -> withServer' . tryCommand $ deleteConnection' c connId >> notify OK
|
||||
DEL -> withServer' . tryCommand $ deleteConnection' c NRMBackground connId >> notify OK
|
||||
_ -> notify $ ERR $ INTERNAL $ "unsupported async command " <> show (aCommandTag cmd)
|
||||
AInternalCommand cmd -> case cmd of
|
||||
ICAckDel rId srvMsgId msgId -> withServer $ \srv -> tryWithLock "ICAckDel" $ ack srv rId srvMsgId >> withStore' c (\db -> deleteMsg db connId msgId)
|
||||
@@ -1535,7 +1535,7 @@ runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do
|
||||
ICDeleteConn -> withStore' c (`deleteCommand` cmdId)
|
||||
ICDeleteRcvQueue rId -> withServer $ \srv -> tryWithLock "ICDeleteRcvQueue" $ do
|
||||
rq <- withStore c (\db -> getDeletedRcvQueue db connId srv rId)
|
||||
deleteQueue c rq
|
||||
deleteQueue c NRMBackground rq
|
||||
withStore' c (`deleteConnRcvQueue` rq)
|
||||
ICQSecure rId senderKey ->
|
||||
withServer $ \srv -> tryWithLock "ICQSecure" . withDuplexConn $ \(DuplexConnection cData rqs sqs) ->
|
||||
@@ -1543,7 +1543,7 @@ runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do
|
||||
Just rq'@RcvQueue {server, sndId, status, dbReplaceQueueId = Just replaceQId} ->
|
||||
case find ((replaceQId ==) . dbQId) rqs of
|
||||
Just rq1 -> when (status == Confirmed) $ do
|
||||
secureQueue c rq' senderKey
|
||||
secureQueue c NRMBackground rq' senderKey
|
||||
-- we may add more statistics special to queue rotation later on,
|
||||
-- not accounting secure during rotation for now:
|
||||
-- atomically $ incSMPServerStat c userId server connSecured
|
||||
@@ -1563,7 +1563,7 @@ runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do
|
||||
| primary -> internalErr "ICQDelete: cannot delete primary rcv queue"
|
||||
| otherwise -> do
|
||||
checkRQSwchStatus rq' RSReceivedMessage
|
||||
tryError (deleteQueue c rq') >>= \case
|
||||
tryError (deleteQueue c NRMBackground rq') >>= \case
|
||||
Right () -> finalizeSwitch
|
||||
Left e
|
||||
| temporaryOrHostError e -> throwE e
|
||||
@@ -1583,7 +1583,7 @@ runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do
|
||||
ackQueueMessage c rq srvMsgId
|
||||
secure :: RcvQueue -> SMP.SndPublicAuthKey -> AM ()
|
||||
secure rq@RcvQueue {server} senderKey = do
|
||||
secureQueue c rq senderKey
|
||||
secureQueue c NRMBackground rq senderKey
|
||||
atomically $ incSMPServerStat c userId server connSecured
|
||||
withStore' c $ \db -> setRcvQueueStatus db rq Secured
|
||||
where
|
||||
@@ -1749,8 +1749,8 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} ConnData {connId} sq@SndQueue {userI
|
||||
liftIO $ waitWhileSuspended c
|
||||
liftIO $ waitForUserNetwork c
|
||||
resp <- tryError $ case msgType of
|
||||
AM_CONN_INFO -> sendConfirmation c sq msgBody
|
||||
AM_CONN_INFO_REPLY -> sendConfirmation c sq msgBody
|
||||
AM_CONN_INFO -> sendConfirmation c NRMBackground sq msgBody
|
||||
AM_CONN_INFO_REPLY -> sendConfirmation c NRMBackground sq msgBody
|
||||
_ -> case pendingMsgPrepData_ of
|
||||
Nothing -> sendAgentMessage c sq msgFlags msgBody
|
||||
Just PendingMsgPrepData {encryptKey, paddedLen, sndMsgBody} -> do
|
||||
@@ -1944,18 +1944,18 @@ ackMessage' c connId msgId rcptInfo_ = withConnLock c connId "ackMessage" $ do
|
||||
withStore' c $ \db -> deleteDeliveredSndMsg db connId $ InternalId sndMsgId
|
||||
_ -> pure ()
|
||||
|
||||
getConnectionQueueInfo' :: AgentClient -> ConnId -> AM ServerQueueInfo
|
||||
getConnectionQueueInfo' c connId = do
|
||||
getConnectionQueueInfo' :: AgentClient -> NetworkRequestMode -> ConnId -> AM ServerQueueInfo
|
||||
getConnectionQueueInfo' c nm connId = do
|
||||
SomeConn _ conn <- withStore c (`getConn` connId)
|
||||
case conn of
|
||||
DuplexConnection _ (rq :| _) _ -> getQueueInfo c rq
|
||||
RcvConnection _ rq -> getQueueInfo c rq
|
||||
ContactConnection _ rq -> getQueueInfo c rq
|
||||
DuplexConnection _ (rq :| _) _ -> getQueueInfo c nm rq
|
||||
RcvConnection _ rq -> getQueueInfo c nm rq
|
||||
ContactConnection _ rq -> getQueueInfo c nm rq
|
||||
SndConnection {} -> throwE $ CONN SIMPLEX "getConnectionQueueInfo"
|
||||
NewConnection _ -> throwE $ CMD PROHIBITED "getConnectionQueueInfo: NewConnection"
|
||||
|
||||
switchConnection' :: AgentClient -> ConnId -> AM ConnectionStats
|
||||
switchConnection' c connId =
|
||||
switchConnection' :: AgentClient -> NetworkRequestMode -> ConnId -> AM ConnectionStats
|
||||
switchConnection' c nm connId =
|
||||
withConnLock c connId "switchConnection" $
|
||||
withStore c (`getConn` connId) >>= \case
|
||||
SomeConn _ conn@(DuplexConnection cData rqs@(rq :| _rqs) _)
|
||||
@@ -1963,18 +1963,18 @@ switchConnection' c connId =
|
||||
| otherwise -> do
|
||||
when (ratchetSyncSendProhibited cData) $ throwE $ CMD PROHIBITED "switchConnection: send prohibited"
|
||||
rq' <- withStore' c $ \db -> setRcvSwitchStatus db rq $ Just RSSwitchStarted
|
||||
switchDuplexConnection c conn rq'
|
||||
switchDuplexConnection c nm conn rq'
|
||||
_ -> throwE $ CMD PROHIBITED "switchConnection: not duplex"
|
||||
|
||||
switchDuplexConnection :: AgentClient -> Connection 'CDuplex -> RcvQueue -> AM ConnectionStats
|
||||
switchDuplexConnection c (DuplexConnection cData@ConnData {connId, userId} rqs sqs) rq@RcvQueue {server, dbQueueId = DBEntityId dbQueueId, sndId} = do
|
||||
switchDuplexConnection :: AgentClient -> NetworkRequestMode -> Connection 'CDuplex -> RcvQueue -> AM ConnectionStats
|
||||
switchDuplexConnection c nm (DuplexConnection cData@ConnData {connId, userId} rqs sqs) rq@RcvQueue {server, dbQueueId = DBEntityId dbQueueId, sndId} = do
|
||||
checkRQSwchStatus rq RSSwitchStarted
|
||||
clientVRange <- asks $ smpClientVRange . config
|
||||
-- try to get the server that is different from all queues, or at least from the primary rcv queue
|
||||
srvAuth@(ProtoServerWithAuth srv _) <- getNextSMPServer c userId $ map qServer (L.toList rqs) <> map qServer (L.toList sqs)
|
||||
srv' <- if srv == server then getNextSMPServer c userId [server] else pure srvAuth
|
||||
-- TODO [notifications] send correct NTF credentials here
|
||||
(q, qUri, tSess, sessId) <- newRcvQueue c userId connId srv' clientVRange SCMInvitation SMSubscribe -- Nothing
|
||||
(q, qUri, tSess, sessId) <- newRcvQueue c nm userId connId srv' clientVRange SCMInvitation SMSubscribe -- Nothing
|
||||
let rq' = (q :: NewRcvQueue) {primary = True, dbReplaceQueueId = Just dbQueueId}
|
||||
rq'' <- withStore c $ \db -> addConnRcvQueue db connId rq'
|
||||
lift $ addNewQueueSubscription c rq'' tSess sessId
|
||||
@@ -2046,21 +2046,21 @@ ackQueueMessage c rq@RcvQueue {userId, connId, server} srvMsgId = do
|
||||
atomically $ writeTBQueue (subQ c) ("", connId, AEvt SAEConn $ MSGNTF srvMsgId brokerTs_)
|
||||
|
||||
-- | Suspend SMP agent connection (OFF command) in Reader monad
|
||||
suspendConnection' :: AgentClient -> ConnId -> AM ()
|
||||
suspendConnection' c connId = withConnLock c connId "suspendConnection" $ do
|
||||
suspendConnection' :: AgentClient -> NetworkRequestMode -> ConnId -> AM ()
|
||||
suspendConnection' c nm connId = withConnLock c connId "suspendConnection" $ do
|
||||
SomeConn _ conn <- withStore c (`getConn` connId)
|
||||
case conn of
|
||||
DuplexConnection _ rqs _ -> mapM_ (suspendQueue c) rqs
|
||||
RcvConnection _ rq -> suspendQueue c rq
|
||||
ContactConnection _ rq -> suspendQueue c rq
|
||||
DuplexConnection _ rqs _ -> mapM_ (suspendQueue c nm) rqs
|
||||
RcvConnection _ rq -> suspendQueue c nm rq
|
||||
ContactConnection _ rq -> suspendQueue c nm rq
|
||||
SndConnection _ _ -> throwE $ CONN SIMPLEX "suspendConnection"
|
||||
NewConnection _ -> throwE $ CMD PROHIBITED "suspendConnection"
|
||||
|
||||
-- | Delete SMP agent connection (DEL command) in Reader monad
|
||||
-- unlike deleteConnectionAsync, this function does not mark connection as deleted in case of deletion failure
|
||||
-- currently it is used only in tests
|
||||
deleteConnection' :: AgentClient -> ConnId -> AM ()
|
||||
deleteConnection' c connId = toConnResult connId =<< deleteConnections' c [connId]
|
||||
deleteConnection' :: AgentClient -> NetworkRequestMode -> ConnId -> AM ()
|
||||
deleteConnection' c nm connId = toConnResult connId =<< deleteConnections' c nm [connId]
|
||||
{-# INLINE deleteConnection' #-}
|
||||
|
||||
connRcvQueues :: Connection d -> [RcvQueue]
|
||||
@@ -2072,16 +2072,16 @@ connRcvQueues = \case
|
||||
NewConnection _ -> []
|
||||
|
||||
-- Unlike deleteConnectionsAsync, this function does not mark connections as deleted in case of deletion failure.
|
||||
deleteConnections' :: AgentClient -> [ConnId] -> AM (Map ConnId (Either AgentErrorType ()))
|
||||
deleteConnections' :: AgentClient -> NetworkRequestMode -> [ConnId] -> AM (Map ConnId (Either AgentErrorType ()))
|
||||
deleteConnections' = deleteConnections_ getConns False False
|
||||
{-# INLINE deleteConnections' #-}
|
||||
|
||||
deleteDeletedConns :: AgentClient -> [ConnId] -> AM (Map ConnId (Either AgentErrorType ()))
|
||||
deleteDeletedConns = deleteConnections_ getDeletedConns True False
|
||||
deleteDeletedConns c = deleteConnections_ getDeletedConns True False c NRMBackground
|
||||
{-# INLINE deleteDeletedConns #-}
|
||||
|
||||
deleteDeletedWaitingDeliveryConns :: AgentClient -> [ConnId] -> AM (Map ConnId (Either AgentErrorType ()))
|
||||
deleteDeletedWaitingDeliveryConns = deleteConnections_ getConns True True
|
||||
deleteDeletedWaitingDeliveryConns c = deleteConnections_ getConns True True c NRMBackground
|
||||
{-# INLINE deleteDeletedWaitingDeliveryConns #-}
|
||||
|
||||
prepareDeleteConnections_ ::
|
||||
@@ -2119,9 +2119,9 @@ prepareDeleteConnections_ getConnections c waitDelivery connIds = do
|
||||
atomically $ writeTBQueue (ntfSubQ ns) (NSCDeleteSub, connIds')
|
||||
notify = atomically . writeTBQueue (subQ c)
|
||||
|
||||
deleteConnQueues :: AgentClient -> Bool -> Bool -> [RcvQueue] -> AM' (Map ConnId (Either AgentErrorType ()))
|
||||
deleteConnQueues c waitDelivery ntf rqs = do
|
||||
rs <- connResults <$> (deleteQueueRecs =<< deleteQueues c rqs)
|
||||
deleteConnQueues :: AgentClient -> NetworkRequestMode -> Bool -> Bool -> [RcvQueue] -> AM' (Map ConnId (Either AgentErrorType ()))
|
||||
deleteConnQueues c nm waitDelivery ntf rqs = do
|
||||
rs <- connResults <$> (deleteQueueRecs =<< deleteQueues c nm rqs)
|
||||
let connIds = M.keys $ M.filter isRight rs
|
||||
deliveryTimeout <- if waitDelivery then asks (Just . connDeleteDeliveryTimeout . config) else pure Nothing
|
||||
cIds_ <- L.nonEmpty . catMaybes . rights <$> withStoreBatch' c (\db -> map (deleteConn db deliveryTimeout) connIds)
|
||||
@@ -2172,12 +2172,13 @@ deleteConnections_ ::
|
||||
Bool ->
|
||||
Bool ->
|
||||
AgentClient ->
|
||||
NetworkRequestMode ->
|
||||
[ConnId] ->
|
||||
AM (Map ConnId (Either AgentErrorType ()))
|
||||
deleteConnections_ _ _ _ _ [] = pure M.empty
|
||||
deleteConnections_ getConnections ntf waitDelivery c connIds = do
|
||||
deleteConnections_ _ _ _ _ _ [] = pure M.empty
|
||||
deleteConnections_ getConnections ntf waitDelivery c nm connIds = do
|
||||
(rs, rqs, _) <- prepareDeleteConnections_ getConnections c waitDelivery connIds
|
||||
rcvRs <- lift $ deleteConnQueues c waitDelivery ntf rqs
|
||||
rcvRs <- lift $ deleteConnQueues c nm waitDelivery ntf rqs
|
||||
let rs' = M.union rs rcvRs
|
||||
notifyResultError rs'
|
||||
pure rs'
|
||||
@@ -2233,8 +2234,8 @@ checkUserServers name srvs =
|
||||
unless (any (\ServerCfg {enabled} -> enabled) srvs) $
|
||||
logWarn (name <> ": all passed servers are disabled, using all servers.")
|
||||
|
||||
registerNtfToken' :: AgentClient -> DeviceToken -> NotificationsMode -> AM NtfTknStatus
|
||||
registerNtfToken' c suppliedDeviceToken suppliedNtfMode =
|
||||
registerNtfToken' :: AgentClient -> NetworkRequestMode -> DeviceToken -> NotificationsMode -> AM NtfTknStatus
|
||||
registerNtfToken' c nm suppliedDeviceToken suppliedNtfMode =
|
||||
withStore' c getSavedNtfToken >>= \case
|
||||
Just tkn@NtfToken {deviceToken = savedDeviceToken, ntfTokenId, ntfTknStatus, ntfTknAction, ntfMode = savedNtfMode} -> do
|
||||
status <- case (ntfTokenId, ntfTknAction) of
|
||||
@@ -2248,18 +2249,18 @@ registerNtfToken' c suppliedDeviceToken suppliedNtfMode =
|
||||
| otherwise -> replaceToken tknId
|
||||
(Just tknId, Just (NTAVerify code))
|
||||
| savedDeviceToken == suppliedDeviceToken ->
|
||||
t tkn (NTActive, Just NTACheck) $ agentNtfVerifyToken c tknId tkn code
|
||||
t tkn (NTActive, Just NTACheck) $ agentNtfVerifyToken c nm tknId tkn code
|
||||
| otherwise -> replaceToken tknId
|
||||
(Just tknId, Just NTACheck)
|
||||
| savedDeviceToken == suppliedDeviceToken -> do
|
||||
ns <- asks ntfSupervisor
|
||||
let tkn' = tkn {ntfMode = suppliedNtfMode}
|
||||
atomically $ nsUpdateToken ns tkn'
|
||||
agentNtfCheckToken c tknId tkn' >>= \case
|
||||
agentNtfCheckToken c nm tknId tkn' >>= \case
|
||||
NTActive -> do
|
||||
when (suppliedNtfMode == NMInstant) $ initializeNtfSubs c
|
||||
when (suppliedNtfMode == NMPeriodic && savedNtfMode == NMInstant) $ deleteNtfSubs c NSCSmpDelete
|
||||
lift $ setCronInterval c tknId tkn
|
||||
lift $ setCronInterval c nm tknId tkn
|
||||
t tkn' (NTActive, Just NTACheck) $ pure ()
|
||||
status -> t tkn' (status, Nothing) $ pure ()
|
||||
| otherwise -> replaceToken tknId
|
||||
@@ -2281,13 +2282,13 @@ registerNtfToken' c suppliedDeviceToken suppliedNtfMode =
|
||||
createToken
|
||||
where
|
||||
tryReplace ns = do
|
||||
agentNtfReplaceToken c tknId tkn suppliedDeviceToken
|
||||
agentNtfReplaceToken c nm tknId tkn suppliedDeviceToken
|
||||
withStore' c $ \db -> updateDeviceToken db tkn suppliedDeviceToken
|
||||
atomically $ nsUpdateToken ns tkn {deviceToken = suppliedDeviceToken, ntfTknStatus = NTRegistered, ntfMode = suppliedNtfMode}
|
||||
pure NTRegistered
|
||||
_ -> createToken
|
||||
where
|
||||
t tkn = withToken c tkn Nothing
|
||||
t tkn = withToken c nm tkn Nothing
|
||||
createToken :: AM NtfTknStatus
|
||||
createToken =
|
||||
lift (getNtfServer c) >>= \case
|
||||
@@ -2304,37 +2305,37 @@ registerNtfToken' c suppliedDeviceToken suppliedNtfMode =
|
||||
_ -> throwE $ CMD PROHIBITED "createToken"
|
||||
registerToken :: NtfToken -> AM ()
|
||||
registerToken tkn@NtfToken {ntfPubKey, ntfDhKeys = (pubDhKey, privDhKey)} = do
|
||||
(tknId, srvPubDhKey) <- agentNtfRegisterToken c tkn ntfPubKey pubDhKey
|
||||
(tknId, srvPubDhKey) <- agentNtfRegisterToken c nm tkn ntfPubKey pubDhKey
|
||||
let dhSecret = C.dh' srvPubDhKey privDhKey
|
||||
withStore' c $ \db -> updateNtfTokenRegistration db tkn tknId dhSecret
|
||||
ns <- asks ntfSupervisor
|
||||
atomically $ nsUpdateToken ns tkn {deviceToken = suppliedDeviceToken, ntfTknStatus = NTRegistered, ntfMode = suppliedNtfMode}
|
||||
|
||||
verifyNtfToken' :: AgentClient -> DeviceToken -> C.CbNonce -> ByteString -> AM ()
|
||||
verifyNtfToken' c deviceToken nonce code =
|
||||
verifyNtfToken' :: AgentClient -> NetworkRequestMode -> DeviceToken -> C.CbNonce -> ByteString -> AM ()
|
||||
verifyNtfToken' c nm deviceToken nonce code =
|
||||
withStore' c getSavedNtfToken >>= \case
|
||||
Just tkn@NtfToken {deviceToken = savedDeviceToken, ntfTokenId = Just tknId, ntfDhSecret = Just dhSecret, ntfMode} -> do
|
||||
when (deviceToken /= savedDeviceToken) . throwE $ CMD PROHIBITED "verifyNtfToken: different token"
|
||||
code' <- liftEither . bimap cryptoError NtfRegCode $ C.cbDecrypt dhSecret nonce code
|
||||
toStatus <-
|
||||
withToken c tkn (Just (NTConfirmed, NTAVerify code')) (NTActive, Just NTACheck) $
|
||||
agentNtfVerifyToken c tknId tkn code'
|
||||
withToken c nm tkn (Just (NTConfirmed, NTAVerify code')) (NTActive, Just NTACheck) $
|
||||
agentNtfVerifyToken c nm tknId tkn code'
|
||||
when (toStatus == NTActive) $ do
|
||||
lift $ setCronInterval c tknId tkn
|
||||
lift $ setCronInterval c nm tknId tkn
|
||||
when (ntfMode == NMInstant) $ initializeNtfSubs c
|
||||
_ -> throwE $ CMD PROHIBITED "verifyNtfToken: no token"
|
||||
|
||||
setCronInterval :: AgentClient -> NtfTokenId -> NtfToken -> AM' ()
|
||||
setCronInterval c tknId tkn = do
|
||||
setCronInterval :: AgentClient -> NetworkRequestMode -> NtfTokenId -> NtfToken -> AM' ()
|
||||
setCronInterval c nm tknId tkn = do
|
||||
cron <- asks $ ntfCron . config
|
||||
void $ forkIO $ void $ runExceptT $ agentNtfSetCronInterval c tknId tkn cron
|
||||
void $ forkIO $ void $ runExceptT $ agentNtfSetCronInterval c nm tknId tkn cron
|
||||
|
||||
checkNtfToken' :: AgentClient -> DeviceToken -> AM NtfTknStatus
|
||||
checkNtfToken' c deviceToken =
|
||||
checkNtfToken' :: AgentClient -> NetworkRequestMode -> DeviceToken -> AM NtfTknStatus
|
||||
checkNtfToken' c nm deviceToken =
|
||||
withStore' c getSavedNtfToken >>= \case
|
||||
Just tkn@NtfToken {deviceToken = savedDeviceToken, ntfTokenId = Just tknId, ntfTknAction} -> do
|
||||
when (deviceToken /= savedDeviceToken) . throwE $ CMD PROHIBITED "checkNtfToken: different token"
|
||||
status <- agentNtfCheckToken c tknId tkn
|
||||
status <- agentNtfCheckToken c nm tknId tkn
|
||||
let action = case status of
|
||||
NTInvalid _ -> Nothing
|
||||
NTExpired -> Nothing
|
||||
@@ -2383,8 +2384,8 @@ toggleConnectionNtfs' c connId enable = do
|
||||
let cmd = if enable then NSCCreate else NSCSmpDelete
|
||||
atomically $ sendNtfSubCommand ns (cmd, [connId])
|
||||
|
||||
withToken :: AgentClient -> NtfToken -> Maybe (NtfTknStatus, NtfTknAction) -> (NtfTknStatus, Maybe NtfTknAction) -> AM a -> AM NtfTknStatus
|
||||
withToken c tkn@NtfToken {deviceToken, ntfMode} from_ (toStatus, toAction_) f = do
|
||||
withToken :: AgentClient -> NetworkRequestMode -> NtfToken -> Maybe (NtfTknStatus, NtfTknAction) -> (NtfTknStatus, Maybe NtfTknAction) -> AM a -> AM NtfTknStatus
|
||||
withToken c nm tkn@NtfToken {deviceToken, ntfMode} from_ (toStatus, toAction_) f = do
|
||||
ns <- asks ntfSupervisor
|
||||
forM_ from_ $ \(status, action) -> do
|
||||
withStore' c $ \db -> updateNtfToken db tkn status (Just action)
|
||||
@@ -2398,7 +2399,7 @@ withToken c tkn@NtfToken {deviceToken, ntfMode} from_ (toStatus, toAction_) f =
|
||||
Left e@(NTF _ AUTH) -> do
|
||||
withStore' c $ \db -> removeNtfToken db tkn
|
||||
atomically $ nsRemoveNtfToken ns
|
||||
void $ registerNtfToken' c deviceToken ntfMode
|
||||
void $ registerNtfToken' c nm deviceToken ntfMode
|
||||
throwE e
|
||||
Left e -> throwE e
|
||||
|
||||
@@ -3186,6 +3187,7 @@ switchStatusError q expected actual =
|
||||
<> (", expected=" <> show expected)
|
||||
<> (", actual=" <> show actual)
|
||||
|
||||
-- used only in background
|
||||
connectReplyQueues :: AgentClient -> ConnData -> ConnInfo -> Maybe SndQueue -> NonEmpty SMPQueueInfo -> AM ()
|
||||
connectReplyQueues c cData@ConnData {userId, connId} ownConnInfo sq_ (qInfo :| _) = do
|
||||
clientVRange <- asks $ smpClientVRange . config
|
||||
@@ -3194,7 +3196,7 @@ connectReplyQueues c cData@ConnData {userId, connId} ownConnInfo sq_ (qInfo :| _
|
||||
Just qInfo' -> do
|
||||
-- in case of SKEY retry the connection is already duplex
|
||||
sq' <- maybe upgradeConn pure sq_
|
||||
void $ agentSecureSndQueue c cData sq'
|
||||
void $ agentSecureSndQueue c NRMBackground cData sq'
|
||||
enqueueConfirmation c cData sq' ownConnInfo Nothing
|
||||
where
|
||||
upgradeConn = do
|
||||
@@ -3203,18 +3205,18 @@ connectReplyQueues c cData@ConnData {userId, connId} ownConnInfo sq_ (qInfo :| _
|
||||
|
||||
secureConfirmQueueAsync :: AgentClient -> ConnData -> Maybe RcvQueue -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> SubscriptionMode -> AM (SndQueueSecured, Maybe ClientServiceId)
|
||||
secureConfirmQueueAsync c cData rq_ sq srv connInfo e2eEncryption_ subMode = do
|
||||
sqSecured <- agentSecureSndQueue c cData sq
|
||||
(qInfo, service) <- mkAgentConfirmation c cData rq_ sq srv connInfo subMode
|
||||
sqSecured <- agentSecureSndQueue c NRMBackground cData sq
|
||||
(qInfo, service) <- mkAgentConfirmation c NRMBackground cData rq_ sq srv connInfo subMode
|
||||
storeConfirmation c cData sq e2eEncryption_ qInfo
|
||||
lift $ submitPendingMsg c cData sq
|
||||
pure (sqSecured, service)
|
||||
|
||||
secureConfirmQueue :: AgentClient -> ConnData -> Maybe RcvQueue -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> SubscriptionMode -> AM (SndQueueSecured, Maybe ClientServiceId)
|
||||
secureConfirmQueue c cData@ConnData {connId, connAgentVersion, pqSupport} rq_ sq srv connInfo e2eEncryption_ subMode = do
|
||||
sqSecured <- agentSecureSndQueue c cData sq
|
||||
(qInfo, service) <- mkAgentConfirmation c cData rq_ sq srv connInfo subMode
|
||||
secureConfirmQueue :: AgentClient -> NetworkRequestMode -> ConnData -> Maybe RcvQueue -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> SubscriptionMode -> AM (SndQueueSecured, Maybe ClientServiceId)
|
||||
secureConfirmQueue c nm cData@ConnData {connId, connAgentVersion, pqSupport} rq_ sq srv connInfo e2eEncryption_ subMode = do
|
||||
sqSecured <- agentSecureSndQueue c nm cData sq
|
||||
(qInfo, service) <- mkAgentConfirmation c nm cData rq_ sq srv connInfo subMode
|
||||
msg <- mkConfirmation qInfo
|
||||
void $ sendConfirmation c sq msg
|
||||
void $ sendConfirmation c nm sq msg
|
||||
withStore' c $ \db -> setSndQueueStatus db sq Confirmed
|
||||
pure (sqSecured, service)
|
||||
where
|
||||
@@ -3229,10 +3231,10 @@ secureConfirmQueue c cData@ConnData {connId, connAgentVersion, pqSupport} rq_ sq
|
||||
(encConnInfo, _) <- agentRatchetEncrypt db cData agentMsgBody e2eEncConnInfoLength (Just pqEnc) currentE2EVersion
|
||||
pure . smpEncode $ AgentConfirmation {agentVersion = connAgentVersion, e2eEncryption_, encConnInfo}
|
||||
|
||||
agentSecureSndQueue :: AgentClient -> ConnData -> SndQueue -> AM SndQueueSecured
|
||||
agentSecureSndQueue c ConnData {connAgentVersion} sq@SndQueue {queueMode, status}
|
||||
agentSecureSndQueue :: AgentClient -> NetworkRequestMode -> ConnData -> SndQueue -> AM SndQueueSecured
|
||||
agentSecureSndQueue c nm ConnData {connAgentVersion} sq@SndQueue {queueMode, status}
|
||||
| sndSecure && status == New = do
|
||||
secureSndQueue c sq
|
||||
secureSndQueue c nm sq
|
||||
withStore' c $ \db -> setSndQueueStatus db sq Secured
|
||||
pure initiatorRatchetOnConf
|
||||
-- on repeat JOIN processing (e.g. previous attempt to create reply queue failed)
|
||||
@@ -3242,10 +3244,10 @@ agentSecureSndQueue c ConnData {connAgentVersion} sq@SndQueue {queueMode, status
|
||||
sndSecure = senderCanSecure queueMode
|
||||
initiatorRatchetOnConf = connAgentVersion >= ratchetOnConfSMPAgentVersion
|
||||
|
||||
mkAgentConfirmation :: AgentClient -> ConnData -> Maybe RcvQueue -> SndQueue -> SMPServerWithAuth -> ConnInfo -> SubscriptionMode -> AM (AgentMessage, Maybe ClientServiceId)
|
||||
mkAgentConfirmation c cData rq_ sq srv connInfo subMode = do
|
||||
mkAgentConfirmation :: AgentClient -> NetworkRequestMode -> ConnData -> Maybe RcvQueue -> SndQueue -> SMPServerWithAuth -> ConnInfo -> SubscriptionMode -> AM (AgentMessage, Maybe ClientServiceId)
|
||||
mkAgentConfirmation c nm cData rq_ sq srv connInfo subMode = do
|
||||
(qInfo, service) <- case rq_ of
|
||||
Nothing -> createReplyQueue c cData sq subMode srv
|
||||
Nothing -> createReplyQueue c nm cData sq subMode srv
|
||||
Just rq@RcvQueue {smpClientVersion = v, clientService} -> pure (SMPQueueInfo v $ rcvSMPQueueAddress rq, dbServiceId <$> clientService)
|
||||
pure (AgentConnInfoReply (qInfo :| []) connInfo, service)
|
||||
|
||||
|
||||
@@ -568,8 +568,9 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg, presetDomai
|
||||
|
||||
slowNetworkConfig :: NetworkConfig -> NetworkConfig
|
||||
slowNetworkConfig cfg@NetworkConfig {tcpConnectTimeout, tcpTimeout, tcpTimeoutPerKb} =
|
||||
cfg {tcpConnectTimeout = slow tcpConnectTimeout, tcpTimeout = slow tcpTimeout, tcpTimeoutPerKb = slow tcpTimeoutPerKb}
|
||||
cfg {tcpConnectTimeout = slowTimeout tcpConnectTimeout, tcpTimeout = slowTimeout tcpTimeout, tcpTimeoutPerKb = slow tcpTimeoutPerKb}
|
||||
where
|
||||
slowTimeout (NetworkTimeout t1 t2) = NetworkTimeout (slow t1) (slow t2)
|
||||
slow :: Integral a => a -> a
|
||||
slow t = (t * 3) `div` 2
|
||||
|
||||
@@ -583,7 +584,7 @@ agentDRG AgentClient {agentEnv = Env {random}} = random
|
||||
|
||||
class (Encoding err, Show err) => ProtocolServerClient v err msg | msg -> v, msg -> err where
|
||||
type Client msg = c | c -> msg
|
||||
getProtocolServerClient :: AgentClient -> TransportSession msg -> AM (Client msg)
|
||||
getProtocolServerClient :: AgentClient -> NetworkRequestMode -> TransportSession msg -> AM (Client msg)
|
||||
type ProtoClient msg = c | c -> msg
|
||||
protocolClient :: Client msg -> ProtoClient msg
|
||||
clientProtocolError :: HostName -> err -> AgentErrorType
|
||||
@@ -613,7 +614,7 @@ instance ProtocolServerClient NTFVersion ErrorType NtfResponse where
|
||||
|
||||
instance ProtocolServerClient XFTPVersion XFTPErrorType FileResponse where
|
||||
type Client FileResponse = XFTPClient
|
||||
getProtocolServerClient = getXFTPServerClient
|
||||
getProtocolServerClient c _ = getXFTPServerClient c
|
||||
type ProtoClient FileResponse = XFTPClient
|
||||
protocolClient = id
|
||||
clientProtocolError = XFTP
|
||||
@@ -621,19 +622,19 @@ instance ProtocolServerClient XFTPVersion XFTPErrorType FileResponse where
|
||||
clientServer = X.xftpClientServer
|
||||
clientTransportHost = X.xftpTransportHost
|
||||
|
||||
getSMPServerClient :: AgentClient -> SMPTransportSession -> AM SMPConnectedClient
|
||||
getSMPServerClient c@AgentClient {active, smpClients, workerSeq} tSess = do
|
||||
getSMPServerClient :: AgentClient -> NetworkRequestMode -> SMPTransportSession -> AM SMPConnectedClient
|
||||
getSMPServerClient c@AgentClient {active, smpClients, workerSeq} nm tSess = do
|
||||
unlessM (readTVarIO active) $ throwE INACTIVE
|
||||
ts <- liftIO getCurrentTime
|
||||
atomically (getSessVar workerSeq tSess smpClients ts)
|
||||
>>= either newClient (waitForProtocolClient c tSess smpClients)
|
||||
>>= either newClient (waitForProtocolClient c nm tSess smpClients)
|
||||
where
|
||||
newClient v = do
|
||||
prs <- liftIO TM.emptyIO
|
||||
smpConnectClient c tSess prs v
|
||||
smpConnectClient c nm tSess prs v
|
||||
|
||||
getSMPProxyClient :: AgentClient -> Maybe SMPServerWithAuth -> SMPTransportSession -> AM (SMPConnectedClient, Either AgentErrorType ProxiedRelay)
|
||||
getSMPProxyClient c@AgentClient {active, smpClients, smpProxiedRelays, workerSeq} proxySrv_ destSess@(userId, destSrv, qId) = do
|
||||
getSMPProxyClient :: AgentClient -> NetworkRequestMode -> Maybe SMPServerWithAuth -> SMPTransportSession -> AM (SMPConnectedClient, Either AgentErrorType ProxiedRelay)
|
||||
getSMPProxyClient c@AgentClient {active, smpClients, smpProxiedRelays, workerSeq} nm proxySrv_ destSess@(userId, destSrv, qId) = do
|
||||
unlessM (readTVarIO active) $ throwE INACTIVE
|
||||
proxySrv <- maybe (getNextServer c userId proxySrvs [destSrv]) pure proxySrv_
|
||||
ts <- liftIO getCurrentTime
|
||||
@@ -651,11 +652,11 @@ getSMPProxyClient c@AgentClient {active, smpClients, smpProxiedRelays, workerSeq
|
||||
-- we do not need to check if it is a new proxied relay session,
|
||||
-- as the client is just created and there are no sessions yet
|
||||
rv <- atomically $ either id id <$> getSessVar workerSeq destSrv prs ts
|
||||
clnt <- smpConnectClient c tSess prs v
|
||||
clnt <- smpConnectClient c nm tSess prs v
|
||||
(clnt,) <$> newProxiedRelay clnt auth rv
|
||||
waitForProxyClient :: SMPTransportSession -> Maybe SMP.BasicAuth -> SMPClientVar -> AM (SMPConnectedClient, Either AgentErrorType ProxiedRelay)
|
||||
waitForProxyClient tSess auth v = do
|
||||
clnt@(SMPConnectedClient _ prs) <- waitForProtocolClient c tSess smpClients v
|
||||
clnt@(SMPConnectedClient _ prs) <- waitForProtocolClient c nm tSess smpClients v
|
||||
ts <- liftIO getCurrentTime
|
||||
sess <-
|
||||
atomically (getSessVar workerSeq destSrv prs ts)
|
||||
@@ -663,7 +664,7 @@ getSMPProxyClient c@AgentClient {active, smpClients, smpProxiedRelays, workerSeq
|
||||
pure (clnt, sess)
|
||||
newProxiedRelay :: SMPConnectedClient -> Maybe SMP.BasicAuth -> ProxiedRelayVar -> AM (Either AgentErrorType ProxiedRelay)
|
||||
newProxiedRelay (SMPConnectedClient smp prs) proxyAuth rv =
|
||||
tryAgentError (liftClient SMP (clientServer smp) $ connectSMPProxiedRelay smp destSrv proxyAuth) >>= \case
|
||||
tryAgentError (liftClient SMP (clientServer smp) $ connectSMPProxiedRelay smp nm destSrv proxyAuth) >>= \case
|
||||
Right sess -> do
|
||||
atomically $ putTMVar (sessionVar rv) (Right sess)
|
||||
pure $ Right sess
|
||||
@@ -677,14 +678,14 @@ getSMPProxyClient c@AgentClient {active, smpClients, smpProxiedRelays, workerSeq
|
||||
waitForProxiedRelay :: SMPTransportSession -> ProxiedRelayVar -> AM (Either AgentErrorType ProxiedRelay)
|
||||
waitForProxiedRelay (_, srv, _) rv = do
|
||||
NetworkConfig {tcpConnectTimeout} <- getNetworkConfig c
|
||||
sess_ <- liftIO $ tcpConnectTimeout `timeout` atomically (readTMVar $ sessionVar rv)
|
||||
sess_ <- liftIO $ netTimeoutInt tcpConnectTimeout nm `timeout` atomically (readTMVar $ sessionVar rv)
|
||||
pure $ case sess_ of
|
||||
Just (Right sess) -> Right sess
|
||||
Just (Left e) -> Left e
|
||||
Nothing -> Left $ BROKER (B.unpack $ strEncode srv) TIMEOUT
|
||||
|
||||
smpConnectClient :: AgentClient -> SMPTransportSession -> TMap SMPServer ProxiedRelayVar -> SMPClientVar -> AM SMPConnectedClient
|
||||
smpConnectClient c@AgentClient {smpClients, msgQ, proxySessTs} tSess@(_, srv, _) prs v =
|
||||
smpConnectClient :: AgentClient -> NetworkRequestMode -> SMPTransportSession -> TMap SMPServer ProxiedRelayVar -> SMPClientVar -> AM SMPConnectedClient
|
||||
smpConnectClient c@AgentClient {smpClients, msgQ, proxySessTs} nm tSess@(_, srv, _) prs v =
|
||||
newProtocolClient c tSess smpClients connectClient v
|
||||
`catchAgentError` \e -> lift (resubscribeSMPSession c tSess) >> throwE e
|
||||
where
|
||||
@@ -695,7 +696,7 @@ smpConnectClient c@AgentClient {smpClients, msgQ, proxySessTs} tSess@(_, srv, _)
|
||||
env <- ask
|
||||
liftError (protocolClientError SMP $ B.unpack $ strEncode srv) $ do
|
||||
ts <- readTVarIO proxySessTs
|
||||
smp <- ExceptT $ getProtocolClient g tSess cfg (presetSMPDomains c) (Just msgQ) ts $ smpClientDisconnected c tSess env v' prs
|
||||
smp <- ExceptT $ getProtocolClient g nm tSess cfg (presetSMPDomains c) (Just msgQ) ts $ smpClientDisconnected c tSess env v' prs
|
||||
pure SMPConnectedClient {connectedClient = smp, proxiedRelays = prs}
|
||||
|
||||
smpClientDisconnected :: AgentClient -> SMPTransportSession -> Env -> SMPClientVar -> TMap SMPServer ProxiedRelayVar -> SMPClient -> IO ()
|
||||
@@ -783,14 +784,14 @@ reconnectSMPClient c tSess@(_, srv, _) qs = handleNotify $ do
|
||||
notifySub :: forall e. AEntityI e => ConnId -> AEvent e -> AM' ()
|
||||
notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, AEvt (sAEntity @e) cmd)
|
||||
|
||||
getNtfServerClient :: AgentClient -> NtfTransportSession -> AM NtfClient
|
||||
getNtfServerClient c@AgentClient {active, ntfClients, workerSeq, proxySessTs} tSess@(_, srv, _) = do
|
||||
getNtfServerClient :: AgentClient -> NetworkRequestMode -> NtfTransportSession -> AM NtfClient
|
||||
getNtfServerClient c@AgentClient {active, ntfClients, workerSeq, proxySessTs} nm tSess@(_, srv, _) = do
|
||||
unlessM (readTVarIO active) $ throwE INACTIVE
|
||||
ts <- liftIO getCurrentTime
|
||||
atomically (getSessVar workerSeq tSess ntfClients ts)
|
||||
>>= either
|
||||
(newProtocolClient c tSess ntfClients connectClient)
|
||||
(waitForProtocolClient c tSess ntfClients)
|
||||
(waitForProtocolClient c nm tSess ntfClients)
|
||||
where
|
||||
connectClient :: NtfClientVar -> AM NtfClient
|
||||
connectClient v = do
|
||||
@@ -798,7 +799,7 @@ getNtfServerClient c@AgentClient {active, ntfClients, workerSeq, proxySessTs} tS
|
||||
g <- asks random
|
||||
ts <- readTVarIO proxySessTs
|
||||
liftError' (protocolClientError NTF $ B.unpack $ strEncode srv) $
|
||||
getProtocolClient g tSess cfg [] Nothing ts $
|
||||
getProtocolClient g nm tSess cfg [] Nothing ts $
|
||||
clientDisconnected v
|
||||
|
||||
clientDisconnected :: NtfClientVar -> NtfClient -> IO ()
|
||||
@@ -814,7 +815,7 @@ getXFTPServerClient c@AgentClient {active, xftpClients, workerSeq, proxySessTs}
|
||||
atomically (getSessVar workerSeq tSess xftpClients ts)
|
||||
>>= either
|
||||
(newProtocolClient c tSess xftpClients connectClient)
|
||||
(waitForProtocolClient c tSess xftpClients)
|
||||
(waitForProtocolClient c NRMBackground tSess xftpClients)
|
||||
where
|
||||
connectClient :: XFTPClientVar -> AM XFTPClient
|
||||
connectClient v = do
|
||||
@@ -834,13 +835,14 @@ getXFTPServerClient c@AgentClient {active, xftpClients, workerSeq, proxySessTs}
|
||||
waitForProtocolClient ::
|
||||
(ProtocolTypeI (ProtoType msg), ProtocolServerClient v err msg) =>
|
||||
AgentClient ->
|
||||
NetworkRequestMode ->
|
||||
TransportSession msg ->
|
||||
TMap (TransportSession msg) (ClientVar msg) ->
|
||||
ClientVar msg ->
|
||||
AM (Client msg)
|
||||
waitForProtocolClient c tSess@(_, srv, _) clients v = do
|
||||
waitForProtocolClient c nm tSess@(_, srv, _) clients v = do
|
||||
NetworkConfig {tcpConnectTimeout} <- getNetworkConfig c
|
||||
client_ <- liftIO $ tcpConnectTimeout `timeout` atomically (readTMVar $ sessionVar v)
|
||||
client_ <- liftIO $ netTimeoutInt tcpConnectTimeout nm `timeout` atomically (readTMVar $ sessionVar v)
|
||||
case client_ of
|
||||
Just (Right smpClient) -> pure smpClient
|
||||
Just (Left (e, ts_)) -> case ts_ of
|
||||
@@ -848,7 +850,7 @@ waitForProtocolClient c tSess@(_, srv, _) clients v = do
|
||||
Just ts ->
|
||||
ifM
|
||||
((ts <) <$> liftIO getCurrentTime)
|
||||
(atomically (removeSessVar v tSess clients) >> getProtocolServerClient c tSess)
|
||||
(atomically (removeSessVar v tSess clients) >> getProtocolServerClient c nm tSess)
|
||||
(throwE e)
|
||||
Nothing -> throwE $ BROKER (B.unpack $ strEncode srv) TIMEOUT
|
||||
|
||||
@@ -979,7 +981,7 @@ closeClient_ :: ProtocolServerClient v err msg => AgentClient -> ClientVar msg -
|
||||
closeClient_ c v = do
|
||||
NetworkConfig {tcpConnectTimeout} <- getNetworkConfig c
|
||||
E.handle (\BlockedIndefinitelyOnSTM -> pure ()) $
|
||||
tcpConnectTimeout `timeout` atomically (readTMVar $ sessionVar v) >>= \case
|
||||
netTimeoutInt tcpConnectTimeout NRMBackground `timeout` atomically (readTMVar $ sessionVar v) >>= \case
|
||||
Just (Right client) -> closeProtocolServerClient (protocolClient client) `catchAll_` pure ()
|
||||
_ -> pure ()
|
||||
|
||||
@@ -1021,9 +1023,9 @@ getMapLock locks key = TM.lookup key locks >>= maybe newLock pure
|
||||
where
|
||||
newLock = createLock >>= \l -> TM.insert key l locks $> l
|
||||
|
||||
withClient_ :: forall a v err msg. ProtocolServerClient v err msg => AgentClient -> TransportSession msg -> (Client msg -> AM a) -> AM a
|
||||
withClient_ c tSess@(_, srv, _) action = do
|
||||
cl <- getProtocolServerClient c tSess
|
||||
withClient_ :: forall a v err msg. ProtocolServerClient v err msg => AgentClient -> NetworkRequestMode -> TransportSession msg -> (Client msg -> AM a) -> AM a
|
||||
withClient_ c nm tSess@(_, srv, _) action = do
|
||||
cl <- getProtocolServerClient c nm tSess
|
||||
action cl `catchAgentError` logServerError
|
||||
where
|
||||
logServerError :: AgentErrorType -> AM a
|
||||
@@ -1031,9 +1033,9 @@ withClient_ c tSess@(_, srv, _) action = do
|
||||
logServer "<--" c srv NoEntity $ bshow e
|
||||
throwE e
|
||||
|
||||
withProxySession :: AgentClient -> Maybe SMPServerWithAuth -> SMPTransportSession -> SMP.SenderId -> ByteString -> ((SMPConnectedClient, ProxiedRelay) -> AM a) -> AM a
|
||||
withProxySession c proxySrv_ destSess@(_, destSrv, _) entId cmdStr action = do
|
||||
(cl, sess_) <- getSMPProxyClient c proxySrv_ destSess
|
||||
withProxySession :: AgentClient -> NetworkRequestMode -> Maybe SMPServerWithAuth -> SMPTransportSession -> SMP.SenderId -> ByteString -> ((SMPConnectedClient, ProxiedRelay) -> AM a) -> AM a
|
||||
withProxySession c nm proxySrv_ destSess@(_, destSrv, _) entId cmdStr action = do
|
||||
(cl, sess_) <- getSMPProxyClient c nm proxySrv_ destSess
|
||||
logServer ("--> " <> proxySrv cl <> " >") c destSrv entId cmdStr
|
||||
case sess_ of
|
||||
Right sess -> do
|
||||
@@ -1048,41 +1050,42 @@ withProxySession c proxySrv_ destSess@(_, destSrv, _) entId cmdStr action = do
|
||||
logServer ("<-- " <> proxySrv cl <> " <") c destSrv NoEntity $ bshow e
|
||||
throwE e
|
||||
|
||||
withLogClient_ :: ProtocolServerClient v err msg => AgentClient -> TransportSession msg -> ByteString -> ByteString -> (Client msg -> AM a) -> AM a
|
||||
withLogClient_ c tSess@(_, srv, _) entId cmdStr action = do
|
||||
withLogClient_ :: ProtocolServerClient v err msg => AgentClient -> NetworkRequestMode -> TransportSession msg -> ByteString -> ByteString -> (Client msg -> AM a) -> AM a
|
||||
withLogClient_ c nm tSess@(_, srv, _) entId cmdStr action = do
|
||||
logServer' "-->" c srv entId cmdStr
|
||||
res <- withClient_ c tSess action
|
||||
res <- withClient_ c nm tSess action
|
||||
logServer' "<--" c srv entId "OK"
|
||||
return res
|
||||
|
||||
withClient :: forall v err msg a. ProtocolServerClient v err msg => AgentClient -> TransportSession msg -> (Client msg -> ExceptT (ProtocolClientError err) IO a) -> AM a
|
||||
withClient c tSess action = withClient_ c tSess $ \client -> liftClient (clientProtocolError @v @err @msg) (clientServer $ protocolClient client) $ action client
|
||||
withClient :: forall v err msg a. ProtocolServerClient v err msg => AgentClient -> NetworkRequestMode -> TransportSession msg -> (Client msg -> ExceptT (ProtocolClientError err) IO a) -> AM a
|
||||
withClient c nm tSess action = withClient_ c nm tSess $ \client -> liftClient (clientProtocolError @v @err @msg) (clientServer $ protocolClient client) $ action client
|
||||
{-# INLINE withClient #-}
|
||||
|
||||
withLogClient :: forall v err msg a. ProtocolServerClient v err msg => AgentClient -> TransportSession msg -> ByteString -> ByteString -> (Client msg -> ExceptT (ProtocolClientError err) IO a) -> AM a
|
||||
withLogClient c tSess entId cmdStr action = withLogClient_ c tSess entId cmdStr $ \client -> liftClient (clientProtocolError @v @err @msg) (clientServer $ protocolClient client) $ action client
|
||||
withLogClient :: forall v err msg a. ProtocolServerClient v err msg => AgentClient -> NetworkRequestMode -> TransportSession msg -> ByteString -> ByteString -> (Client msg -> ExceptT (ProtocolClientError err) IO a) -> AM a
|
||||
withLogClient c nm tSess entId cmdStr action = withLogClient_ c nm tSess entId cmdStr $ \client -> liftClient (clientProtocolError @v @err @msg) (clientServer $ protocolClient client) $ action client
|
||||
{-# INLINE withLogClient #-}
|
||||
|
||||
withSMPClient :: SMPQueueRec q => AgentClient -> q -> ByteString -> (SMPClient -> ExceptT SMPClientError IO a) -> AM a
|
||||
withSMPClient c q cmdStr action = do
|
||||
withSMPClient :: SMPQueueRec q => AgentClient -> NetworkRequestMode -> q -> ByteString -> (SMPClient -> ExceptT SMPClientError IO a) -> AM a
|
||||
withSMPClient c nm q cmdStr action = do
|
||||
tSess <- mkSMPTransportSession c q
|
||||
withLogClient c tSess (unEntityId $ queueId q) cmdStr $ action . connectedClient
|
||||
withLogClient c nm tSess (unEntityId $ queueId q) cmdStr $ action . connectedClient
|
||||
|
||||
sendOrProxySMPMessage :: AgentClient -> UserId -> SMPServer -> ConnId -> ByteString -> Maybe SMP.SndPrivateAuthKey -> SMP.SenderId -> MsgFlags -> SMP.MsgBody -> AM (Maybe SMPServer)
|
||||
sendOrProxySMPMessage c userId destSrv connId cmdStr spKey_ senderId msgFlags msg =
|
||||
fst <$> sendOrProxySMPCommand c userId destSrv connId cmdStr senderId sendViaProxy sendDirectly
|
||||
sendOrProxySMPMessage :: AgentClient -> NetworkRequestMode -> UserId -> SMPServer -> ConnId -> ByteString -> Maybe SMP.SndPrivateAuthKey -> SMP.SenderId -> MsgFlags -> SMP.MsgBody -> AM (Maybe SMPServer)
|
||||
sendOrProxySMPMessage c nm userId destSrv connId cmdStr spKey_ senderId msgFlags msg =
|
||||
fst <$> sendOrProxySMPCommand c nm userId destSrv connId cmdStr senderId sendViaProxy sendDirectly
|
||||
where
|
||||
sendViaProxy smp proxySess = do
|
||||
atomically $ incSMPServerStat c userId destSrv sentViaProxyAttempts
|
||||
atomically $ incSMPServerStat c userId (protocolClientServer' smp) sentProxiedAttempts
|
||||
proxySMPMessage smp proxySess spKey_ senderId msgFlags msg
|
||||
proxySMPMessage smp nm proxySess spKey_ senderId msgFlags msg
|
||||
sendDirectly smp = do
|
||||
atomically $ incSMPServerStat c userId destSrv sentDirectAttempts
|
||||
sendSMPMessage smp spKey_ senderId msgFlags msg
|
||||
sendSMPMessage smp nm spKey_ senderId msgFlags msg
|
||||
|
||||
sendOrProxySMPCommand ::
|
||||
forall a.
|
||||
AgentClient ->
|
||||
NetworkRequestMode ->
|
||||
UserId ->
|
||||
SMPServer ->
|
||||
ConnId -> -- session entity ID, for short links LinkId is used
|
||||
@@ -1091,7 +1094,7 @@ sendOrProxySMPCommand ::
|
||||
(SMPClient -> ProxiedRelay -> ExceptT SMPClientError IO (Either ProxyClientError a)) ->
|
||||
(SMPClient -> ExceptT SMPClientError IO a) ->
|
||||
AM (Maybe SMPServer, a)
|
||||
sendOrProxySMPCommand c userId destSrv@ProtocolServer {host = destHosts} connId cmdStr entId sendCmdViaProxy sendCmdDirectly = do
|
||||
sendOrProxySMPCommand c nm userId destSrv@ProtocolServer {host = destHosts} connId cmdStr entId sendCmdViaProxy sendCmdDirectly = do
|
||||
tSess <- mkTransportSession c userId destSrv connId
|
||||
ifM shouldUseProxy (sendViaProxy Nothing tSess) ((Nothing,) <$> sendDirectly tSess)
|
||||
where
|
||||
@@ -1113,7 +1116,7 @@ sendOrProxySMPCommand c userId destSrv@ProtocolServer {host = destHosts} connId
|
||||
unknownServer = liftIO $ maybe True (\srvs -> all (`S.notMember` knownHosts srvs) destHosts) <$> TM.lookupIO userId (smpServers c)
|
||||
sendViaProxy :: Maybe SMPServerWithAuth -> SMPTransportSession -> AM (Maybe SMPServer, a)
|
||||
sendViaProxy proxySrv_ destSess@(_, _, connId_) = do
|
||||
r <- tryAgentError . withProxySession c proxySrv_ destSess entId ("PFWD " <> cmdStr) $ \(SMPConnectedClient smp _, proxySess@ProxiedRelay {prBasicAuth}) -> do
|
||||
r <- tryAgentError . withProxySession c nm proxySrv_ destSess entId ("PFWD " <> cmdStr) $ \(SMPConnectedClient smp _, proxySess@ProxiedRelay {prBasicAuth}) -> do
|
||||
r' <- liftClient SMP (clientServer smp) $ sendCmdViaProxy smp proxySess
|
||||
let proxySrv = protocolClientServer' smp
|
||||
case r' of
|
||||
@@ -1159,7 +1162,7 @@ sendOrProxySMPCommand c userId destSrv@ProtocolServer {host = destHosts} connId
|
||||
| serverHostError e -> ifM directAllowed ((Nothing,) <$> sendDirectly destSess) (throwE e)
|
||||
| otherwise -> throwE e
|
||||
sendDirectly tSess =
|
||||
withLogClient_ c tSess (unEntityId entId) ("SEND " <> cmdStr) $ \(SMPConnectedClient smp _) -> do
|
||||
withLogClient_ c nm tSess (unEntityId entId) ("SEND " <> cmdStr) $ \(SMPConnectedClient smp _) -> do
|
||||
tryAgentError (liftClient SMP (clientServer smp) $ sendCmdDirectly smp) >>= \case
|
||||
Right r -> r <$ atomically (incSMPServerStat c userId destSrv sentDirect)
|
||||
Left e -> throwE e
|
||||
@@ -1170,8 +1173,8 @@ ipAddressProtected NetworkConfig {socksProxy, hostMode} (ProtocolServer _ hosts
|
||||
where
|
||||
isOnionHost = \case THOnionHost _ -> True; _ -> False
|
||||
|
||||
withNtfClient :: AgentClient -> NtfServer -> EntityId -> ByteString -> (NtfClient -> ExceptT NtfClientError IO a) -> AM a
|
||||
withNtfClient c srv (EntityId entId) = withLogClient c (0, srv, Nothing) entId
|
||||
withNtfClient :: AgentClient -> NetworkRequestMode -> NtfServer -> EntityId -> ByteString -> (NtfClient -> ExceptT NtfClientError IO a) -> AM a
|
||||
withNtfClient c nm srv (EntityId entId) = withLogClient c nm (0, srv, Nothing) entId
|
||||
|
||||
withXFTPClient ::
|
||||
ProtocolServerClient v err msg =>
|
||||
@@ -1182,7 +1185,7 @@ withXFTPClient ::
|
||||
AM b
|
||||
withXFTPClient c (userId, srv, sessEntId) cmdStr action = do
|
||||
tSess <- mkTransportSession c userId srv sessEntId
|
||||
withLogClient c tSess sessEntId cmdStr action
|
||||
withLogClient c NRMBackground tSess sessEntId cmdStr action
|
||||
|
||||
liftClient :: (Show err, Encoding err) => (HostName -> err -> AgentErrorType) -> HostName -> ExceptT (ProtocolClientError err) IO a -> AM a
|
||||
liftClient protocolError_ = liftError . protocolClientError protocolError_
|
||||
@@ -1222,8 +1225,8 @@ data ProtocolTestFailure = ProtocolTestFailure
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
runSMPServerTest :: AgentClient -> UserId -> SMPServerWithAuth -> AM' (Maybe ProtocolTestFailure)
|
||||
runSMPServerTest c userId (ProtoServerWithAuth srv auth) = do
|
||||
runSMPServerTest :: AgentClient -> NetworkRequestMode -> UserId -> SMPServerWithAuth -> AM' (Maybe ProtocolTestFailure)
|
||||
runSMPServerTest c nm userId (ProtoServerWithAuth srv auth) = do
|
||||
cfg <- getClientConfig c smpCfg
|
||||
C.AuthAlg ra <- asks $ rcvAuthAlg . config
|
||||
C.AuthAlg sa <- asks $ sndAuthAlg . config
|
||||
@@ -1231,20 +1234,20 @@ runSMPServerTest c userId (ProtoServerWithAuth srv auth) = do
|
||||
liftIO $ do
|
||||
let tSess = (userId, srv, Nothing)
|
||||
ts <- readTVarIO $ proxySessTs c
|
||||
getProtocolClient g tSess cfg (presetSMPDomains c) Nothing ts (\_ -> pure ()) >>= \case
|
||||
getProtocolClient g nm tSess cfg (presetSMPDomains c) Nothing ts (\_ -> pure ()) >>= \case
|
||||
Right smp -> do
|
||||
rKeys@(_, rpKey) <- atomically $ C.generateAuthKeyPair ra g
|
||||
(sKey, spKey) <- atomically $ C.generateAuthKeyPair sa g
|
||||
(dhKey, _) <- atomically $ C.generateKeyPair g
|
||||
r <- runExceptT $ do
|
||||
-- TODO [notifications]
|
||||
SMP.QIK {rcvId, sndId, queueMode} <- liftError (testErr TSCreateQueue) $ createSMPQueue smp Nothing rKeys dhKey auth SMSubscribe (QRMessaging Nothing) -- Nothing
|
||||
SMP.QIK {rcvId, sndId, queueMode} <- liftError (testErr TSCreateQueue) $ createSMPQueue smp nm Nothing rKeys dhKey auth SMSubscribe (QRMessaging Nothing) -- Nothing
|
||||
liftError (testErr TSSecureQueue) $
|
||||
case queueMode of
|
||||
Just QMMessaging -> secureSndSMPQueue smp spKey sndId sKey
|
||||
_ -> secureSMPQueue smp rpKey rcvId sKey
|
||||
liftError (testErr TSDeleteQueue) $ deleteSMPQueue smp rpKey rcvId
|
||||
ok <- tcpTimeout (networkConfig cfg) `timeout` closeProtocolClient smp
|
||||
Just QMMessaging -> secureSndSMPQueue smp nm spKey sndId sKey
|
||||
_ -> secureSMPQueue smp nm rpKey rcvId sKey
|
||||
liftError (testErr TSDeleteQueue) $ deleteSMPQueue smp nm rpKey rcvId
|
||||
ok <- netTimeoutInt (tcpTimeout $ networkConfig cfg) nm `timeout` closeProtocolClient smp
|
||||
pure $ either Just (const Nothing) r <|> maybe (Just (ProtocolTestFailure TSDisconnect $ BROKER addr TIMEOUT)) (const Nothing) ok
|
||||
Left e -> pure (Just $ testErr TSConnect e)
|
||||
where
|
||||
@@ -1252,8 +1255,8 @@ runSMPServerTest c userId (ProtoServerWithAuth srv auth) = do
|
||||
testErr :: ProtocolTestStep -> SMPClientError -> ProtocolTestFailure
|
||||
testErr step = ProtocolTestFailure step . protocolClientError SMP addr
|
||||
|
||||
runXFTPServerTest :: AgentClient -> UserId -> XFTPServerWithAuth -> AM' (Maybe ProtocolTestFailure)
|
||||
runXFTPServerTest c userId (ProtoServerWithAuth srv auth) = do
|
||||
runXFTPServerTest :: AgentClient -> NetworkRequestMode -> UserId -> XFTPServerWithAuth -> AM' (Maybe ProtocolTestFailure)
|
||||
runXFTPServerTest c nm userId (ProtoServerWithAuth srv auth) = do
|
||||
cfg <- asks $ xftpCfg . config
|
||||
g <- asks random
|
||||
xftpNetworkConfig <- getNetworkConfig c
|
||||
@@ -1277,7 +1280,7 @@ runXFTPServerTest c userId (ProtoServerWithAuth srv auth) = do
|
||||
rcvDigest <- liftIO $ C.sha256Hash <$> B.readFile rcvPath
|
||||
unless (digest == rcvDigest) $ throwE $ ProtocolTestFailure TSCompareFile $ XFTP (B.unpack $ strEncode srv) DIGEST
|
||||
liftError (testErr TSDeleteFile) $ X.deleteXFTPChunk xftp spKey sId
|
||||
ok <- tcpTimeout xftpNetworkConfig `timeout` X.closeXFTPClient xftp
|
||||
ok <- netTimeoutInt (tcpTimeout xftpNetworkConfig) nm `timeout` X.closeXFTPClient xftp
|
||||
pure $ either Just (const Nothing) r <|> maybe (Just (ProtocolTestFailure TSDisconnect $ BROKER addr TIMEOUT)) (const Nothing) ok
|
||||
Left e -> pure (Just $ testErr TSConnect e)
|
||||
where
|
||||
@@ -1300,23 +1303,23 @@ runXFTPServerTest c userId (ProtoServerWithAuth srv auth) = do
|
||||
createTestChunk :: FilePath -> IO ()
|
||||
createTestChunk fp = B.writeFile fp =<< atomically . C.randomBytes chSize =<< C.newRandom
|
||||
|
||||
runNTFServerTest :: AgentClient -> UserId -> NtfServerWithAuth -> AM' (Maybe ProtocolTestFailure)
|
||||
runNTFServerTest c userId (ProtoServerWithAuth srv _) = do
|
||||
runNTFServerTest :: AgentClient -> NetworkRequestMode -> UserId -> NtfServerWithAuth -> AM' (Maybe ProtocolTestFailure)
|
||||
runNTFServerTest c nm userId (ProtoServerWithAuth srv _) = do
|
||||
cfg <- getClientConfig c ntfCfg
|
||||
C.AuthAlg a <- asks $ rcvAuthAlg . config
|
||||
g <- asks random
|
||||
liftIO $ do
|
||||
let tSess = (userId, srv, Nothing)
|
||||
ts <- readTVarIO $ proxySessTs c
|
||||
getProtocolClient g tSess cfg [] Nothing ts (\_ -> pure ()) >>= \case
|
||||
getProtocolClient g nm tSess cfg [] Nothing ts (\_ -> pure ()) >>= \case
|
||||
Right ntf -> do
|
||||
(nKey, npKey) <- atomically $ C.generateAuthKeyPair a g
|
||||
(dhKey, _) <- atomically $ C.generateKeyPair g
|
||||
r <- runExceptT $ do
|
||||
let deviceToken = DeviceToken PPApnsNull "test_ntf_token"
|
||||
(tknId, _) <- liftError (testErr TSCreateNtfToken) $ ntfRegisterToken ntf npKey (NewNtfTkn deviceToken nKey dhKey)
|
||||
liftError (testErr TSDeleteNtfToken) $ ntfDeleteToken ntf npKey tknId
|
||||
ok <- tcpTimeout (networkConfig cfg) `timeout` closeProtocolClient ntf
|
||||
(tknId, _) <- liftError (testErr TSCreateNtfToken) $ ntfRegisterToken ntf nm npKey (NewNtfTkn deviceToken nKey dhKey)
|
||||
liftError (testErr TSDeleteNtfToken) $ ntfDeleteToken ntf nm npKey tknId
|
||||
ok <- netTimeoutInt (tcpTimeout $ networkConfig cfg) nm `timeout` closeProtocolClient ntf
|
||||
pure $ either Just (const Nothing) r <|> maybe (Just (ProtocolTestFailure TSDisconnect $ BROKER addr TIMEOUT)) (const Nothing) ok
|
||||
Left e -> pure (Just $ testErr TSConnect e)
|
||||
where
|
||||
@@ -1350,11 +1353,11 @@ getSessionMode = fmap sessionMode . getNetworkConfig
|
||||
{-# INLINE getSessionMode #-}
|
||||
|
||||
-- TODO [notifications]
|
||||
newRcvQueue :: AgentClient -> UserId -> ConnId -> SMPServerWithAuth -> VersionRangeSMPC -> SConnectionMode c -> SubscriptionMode -> AM (NewRcvQueue, SMPQueueUri, SMPTransportSession, SessionId)
|
||||
newRcvQueue c userId connId srv vRange cMode subMode = do
|
||||
newRcvQueue :: AgentClient -> NetworkRequestMode -> UserId -> ConnId -> SMPServerWithAuth -> VersionRangeSMPC -> SConnectionMode c -> SubscriptionMode -> AM (NewRcvQueue, SMPQueueUri, SMPTransportSession, SessionId)
|
||||
newRcvQueue c nm userId connId srv vRange cMode subMode = do
|
||||
let qrd = case cMode of SCMInvitation -> CQRMessaging Nothing; SCMContact -> CQRContact Nothing
|
||||
e2eKeys <- atomically . C.generateKeyPair =<< asks random
|
||||
newRcvQueue_ c userId connId srv vRange qrd subMode Nothing e2eKeys
|
||||
newRcvQueue_ c nm userId connId srv vRange qrd subMode Nothing e2eKeys
|
||||
|
||||
data ClntQueueReqData
|
||||
= CQRMessaging (Maybe (CQRData (SMP.SenderId, QueueLinkData)))
|
||||
@@ -1371,8 +1374,8 @@ queueReqData = \case
|
||||
CQRMessaging d -> QRMessaging $ srvReq <$> d
|
||||
CQRContact d -> QRContact $ srvReq <$> d
|
||||
|
||||
newRcvQueue_ :: AgentClient -> UserId -> ConnId -> SMPServerWithAuth -> VersionRangeSMPC -> ClntQueueReqData -> SubscriptionMode -> Maybe C.CbNonce -> C.KeyPairX25519 -> AM (NewRcvQueue, SMPQueueUri, SMPTransportSession, SessionId)
|
||||
newRcvQueue_ c userId connId (ProtoServerWithAuth srv auth) vRange cqrd subMode nonce_ (e2eDhKey, e2ePrivKey) = do
|
||||
newRcvQueue_ :: AgentClient -> NetworkRequestMode -> UserId -> ConnId -> SMPServerWithAuth -> VersionRangeSMPC -> ClntQueueReqData -> SubscriptionMode -> Maybe C.CbNonce -> C.KeyPairX25519 -> AM (NewRcvQueue, SMPQueueUri, SMPTransportSession, SessionId)
|
||||
newRcvQueue_ c nm userId connId (ProtoServerWithAuth srv auth) vRange cqrd subMode nonce_ (e2eDhKey, e2ePrivKey) = do
|
||||
C.AuthAlg a <- asks (rcvAuthAlg . config)
|
||||
g <- asks random
|
||||
rKeys@(_, rcvPrivateKey) <- atomically $ C.generateAuthKeyPair a g
|
||||
@@ -1381,8 +1384,8 @@ newRcvQueue_ c userId connId (ProtoServerWithAuth srv auth) vRange cqrd subMode
|
||||
tSess <- mkTransportSession c userId srv connId
|
||||
-- TODO [notifications]
|
||||
r@(thParams', QIK {rcvId, sndId, rcvPublicDhKey, queueMode, serviceId}) <-
|
||||
withClient c tSess $ \(SMPConnectedClient smp _) ->
|
||||
(thParams smp,) <$> createSMPQueue smp nonce_ rKeys dhKey auth subMode (queueReqData cqrd)
|
||||
withClient c nm tSess $ \(SMPConnectedClient smp _) ->
|
||||
(thParams smp,) <$> createSMPQueue smp nm nonce_ rKeys dhKey auth subMode (queueReqData cqrd)
|
||||
-- TODO [certs rcv] validate that serviceId is the same as in the client session
|
||||
liftIO . logServer "<--" c srv NoEntity $ B.unwords ["IDS", logSecret rcvId, logSecret sndId]
|
||||
shortLink <- mkShortLinkCreds r
|
||||
@@ -1493,7 +1496,7 @@ subscribeQueues c qs = do
|
||||
env <- ask
|
||||
-- only "checked" queues are subscribed
|
||||
session <- newTVarIO Nothing
|
||||
rs <- sendTSessionBatches "SUB" id (subscribeQueues_ env session) c qs'
|
||||
rs <- sendTSessionBatches "SUB" id (subscribeQueues_ env session) c NRMBackground qs'
|
||||
(errs <> rs,) <$> readTVarIO session
|
||||
where
|
||||
checkQueue rq = do
|
||||
@@ -1503,7 +1506,7 @@ subscribeQueues c qs = do
|
||||
subscribeQueues_ env session smp qs' = do
|
||||
let (userId, srv, _) = transportSession' smp
|
||||
atomically $ incSMPServerStat' c userId srv connSubAttempts $ length qs'
|
||||
rs <- sendBatch subscribeSMPQueues smp qs'
|
||||
rs <- sendBatch (\smp' _ -> subscribeSMPQueues smp') smp NRMBackground qs'
|
||||
active <-
|
||||
atomically $
|
||||
ifM
|
||||
@@ -1534,8 +1537,8 @@ type BatchResponses q e r = NonEmpty (q, Either e r)
|
||||
|
||||
-- Please note: this function does not preserve order of results to be the same as the order of arguments,
|
||||
-- it includes arguments in the results instead.
|
||||
sendTSessionBatches :: forall q r. ByteString -> (q -> RcvQueue) -> (SMPClient -> NonEmpty q -> IO (BatchResponses q SMPClientError r)) -> AgentClient -> [q] -> AM' [(q, Either AgentErrorType r)]
|
||||
sendTSessionBatches statCmd toRQ action c qs =
|
||||
sendTSessionBatches :: forall q r. ByteString -> (q -> RcvQueue) -> (SMPClient -> NonEmpty q -> IO (BatchResponses q SMPClientError r)) -> AgentClient -> NetworkRequestMode -> [q] -> AM' [(q, Either AgentErrorType r)]
|
||||
sendTSessionBatches statCmd toRQ action c nm qs =
|
||||
concatMap L.toList <$> (mapConcurrently sendClientBatch =<< batchQueues)
|
||||
where
|
||||
batchQueues :: AM' [(SMPTransportSession, NonEmpty q)]
|
||||
@@ -1548,7 +1551,7 @@ sendTSessionBatches statCmd toRQ action c qs =
|
||||
in M.alter (Just . maybe [q] (q <|)) tSess m
|
||||
sendClientBatch :: (SMPTransportSession, NonEmpty q) -> AM' (BatchResponses q AgentErrorType r)
|
||||
sendClientBatch (tSess@(_, srv, _), qs') =
|
||||
tryAgentError' (getSMPServerClient c tSess) >>= \case
|
||||
tryAgentError' (getSMPServerClient c nm tSess) >>= \case
|
||||
Left e -> pure $ L.map (,Left e) qs'
|
||||
Right (SMPConnectedClient smp _) -> liftIO $ do
|
||||
logServer' "-->" c srv (bshow (length qs') <> " queues") statCmd
|
||||
@@ -1556,8 +1559,8 @@ sendTSessionBatches statCmd toRQ action c qs =
|
||||
where
|
||||
agentError = second . first $ protocolClientError SMP $ clientServer smp
|
||||
|
||||
sendBatch :: (SMPClient -> NonEmpty (SMP.RecipientId, SMP.RcvPrivateAuthKey) -> IO (NonEmpty (Either SMPClientError a))) -> SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses RcvQueue SMPClientError a)
|
||||
sendBatch smpCmdFunc smp qs = L.zip qs <$> smpCmdFunc smp (L.map queueCreds qs)
|
||||
sendBatch :: (SMPClient -> NetworkRequestMode -> NonEmpty (SMP.RecipientId, SMP.RcvPrivateAuthKey) -> IO (NonEmpty (Either SMPClientError a))) -> SMPClient -> NetworkRequestMode -> NonEmpty RcvQueue -> IO (BatchResponses RcvQueue SMPClientError a)
|
||||
sendBatch smpCmdFunc smp nm qs = L.zip qs <$> smpCmdFunc smp nm (L.map queueCreds qs)
|
||||
where
|
||||
queueCreds RcvQueue {rcvPrivateKey, rcvId} = (rcvId, rcvPrivateKey)
|
||||
|
||||
@@ -1626,18 +1629,18 @@ logSecret' :: ByteString -> ByteString
|
||||
logSecret' = B64.encode . B.take 3
|
||||
{-# INLINE logSecret' #-}
|
||||
|
||||
sendConfirmation :: AgentClient -> SndQueue -> ByteString -> AM (Maybe SMPServer)
|
||||
sendConfirmation c sq@SndQueue {userId, server, connId, sndId, queueMode, sndPublicKey, sndPrivateKey, e2ePubKey = e2ePubKey@Just {}} agentConfirmation = do
|
||||
sendConfirmation :: AgentClient -> NetworkRequestMode -> SndQueue -> ByteString -> AM (Maybe SMPServer)
|
||||
sendConfirmation c nm sq@SndQueue {userId, server, connId, sndId, queueMode, sndPublicKey, sndPrivateKey, e2ePubKey = e2ePubKey@Just {}} agentConfirmation = do
|
||||
let (privHdr, spKey) = if senderCanSecure queueMode then (SMP.PHEmpty, Just sndPrivateKey) else (SMP.PHConfirmation sndPublicKey, Nothing)
|
||||
clientMsg = SMP.ClientMessage privHdr agentConfirmation
|
||||
msg <- agentCbEncrypt sq e2ePubKey $ smpEncode clientMsg
|
||||
sendOrProxySMPMessage c userId server connId "<CONF>" spKey sndId (MsgFlags {notification = True}) msg
|
||||
sendConfirmation _ _ _ = throwE $ INTERNAL "sendConfirmation called without snd_queue public key(s) in the database"
|
||||
sendOrProxySMPMessage c nm userId server connId "<CONF>" spKey sndId (MsgFlags {notification = True}) msg
|
||||
sendConfirmation _ _ _ _ = throwE $ INTERNAL "sendConfirmation called without snd_queue public key(s) in the database"
|
||||
|
||||
sendInvitation :: AgentClient -> UserId -> ConnId -> Compatible SMPQueueInfo -> Compatible VersionSMPA -> ConnectionRequestUri 'CMInvitation -> ConnInfo -> AM (Maybe SMPServer)
|
||||
sendInvitation c userId connId (Compatible (SMPQueueInfo v SMPQueueAddress {smpServer, senderId, dhPublicKey})) (Compatible agentVersion) connReq connInfo = do
|
||||
sendInvitation :: AgentClient -> NetworkRequestMode -> UserId -> ConnId -> Compatible SMPQueueInfo -> Compatible VersionSMPA -> ConnectionRequestUri 'CMInvitation -> ConnInfo -> AM (Maybe SMPServer)
|
||||
sendInvitation c nm userId connId (Compatible (SMPQueueInfo v SMPQueueAddress {smpServer, senderId, dhPublicKey})) (Compatible agentVersion) connReq connInfo = do
|
||||
msg <- mkInvitation
|
||||
sendOrProxySMPMessage c userId smpServer connId "<INV>" Nothing senderId (MsgFlags {notification = True}) msg
|
||||
sendOrProxySMPMessage c nm userId smpServer connId "<INV>" Nothing senderId (MsgFlags {notification = True}) msg
|
||||
where
|
||||
mkInvitation :: AM ByteString
|
||||
-- this is only encrypted with per-queue E2E, not with double ratchet
|
||||
@@ -1649,7 +1652,7 @@ sendInvitation c userId connId (Compatible (SMPQueueInfo v SMPQueueAddress {smpS
|
||||
getQueueMessage :: AgentClient -> RcvQueue -> AM (Maybe SMPMsgMeta)
|
||||
getQueueMessage c rq@RcvQueue {server, rcvId, rcvPrivateKey} = do
|
||||
atomically createTakeGetLock
|
||||
msg_ <- withSMPClient c rq "GET" $ \smp ->
|
||||
msg_ <- withSMPClient c NRMInteractive rq "GET" $ \smp ->
|
||||
getSMPMessage smp rcvPrivateKey rcvId
|
||||
mapM decryptMeta msg_
|
||||
where
|
||||
@@ -1668,44 +1671,44 @@ decryptSMPMessage rq SMP.RcvMessage {msgId, msgBody = SMP.EncRcvMsgBody body} =
|
||||
where
|
||||
decrypt = agentCbDecrypt (rcvDhSecret rq) (C.cbNonce msgId)
|
||||
|
||||
secureQueue :: AgentClient -> RcvQueue -> SndPublicAuthKey -> AM ()
|
||||
secureQueue c rq@RcvQueue {rcvId, rcvPrivateKey} senderKey =
|
||||
withSMPClient c rq "KEY <key>" $ \smp ->
|
||||
secureSMPQueue smp rcvPrivateKey rcvId senderKey
|
||||
secureQueue :: AgentClient -> NetworkRequestMode -> RcvQueue -> SndPublicAuthKey -> AM ()
|
||||
secureQueue c nm rq@RcvQueue {rcvId, rcvPrivateKey} senderKey =
|
||||
withSMPClient c nm rq "KEY <key>" $ \smp ->
|
||||
secureSMPQueue smp nm rcvPrivateKey rcvId senderKey
|
||||
|
||||
secureSndQueue :: AgentClient -> SndQueue -> AM ()
|
||||
secureSndQueue c SndQueue {userId, connId, server, sndId, sndPrivateKey, sndPublicKey} =
|
||||
void $ sendOrProxySMPCommand c userId server connId "SKEY <key>" sndId secureViaProxy secureDirectly
|
||||
secureSndQueue :: AgentClient -> NetworkRequestMode -> SndQueue -> AM ()
|
||||
secureSndQueue c nm SndQueue {userId, connId, server, sndId, sndPrivateKey, sndPublicKey} =
|
||||
void $ sendOrProxySMPCommand c nm userId server connId "SKEY <key>" sndId secureViaProxy secureDirectly
|
||||
where
|
||||
-- TODO track statistics
|
||||
secureViaProxy smp proxySess = proxySecureSndSMPQueue smp proxySess sndPrivateKey sndId sndPublicKey
|
||||
secureDirectly smp = secureSndSMPQueue smp sndPrivateKey sndId sndPublicKey
|
||||
secureViaProxy smp proxySess = proxySecureSndSMPQueue smp nm proxySess sndPrivateKey sndId sndPublicKey
|
||||
secureDirectly smp = secureSndSMPQueue smp nm sndPrivateKey sndId sndPublicKey
|
||||
|
||||
addQueueLink :: AgentClient -> RcvQueue -> SMP.LinkId -> QueueLinkData -> AM ()
|
||||
addQueueLink c rq@RcvQueue {rcvId, rcvPrivateKey} lnkId d =
|
||||
withSMPClient c rq "LSET" $ \smp -> addSMPQueueLink smp rcvPrivateKey rcvId lnkId d
|
||||
addQueueLink :: AgentClient -> NetworkRequestMode -> RcvQueue -> SMP.LinkId -> QueueLinkData -> AM ()
|
||||
addQueueLink c nm rq@RcvQueue {rcvId, rcvPrivateKey} lnkId d =
|
||||
withSMPClient c nm rq "LSET" $ \smp -> addSMPQueueLink smp nm rcvPrivateKey rcvId lnkId d
|
||||
|
||||
deleteQueueLink :: AgentClient -> RcvQueue -> AM ()
|
||||
deleteQueueLink c rq@RcvQueue {rcvId, rcvPrivateKey} =
|
||||
withSMPClient c rq "LDEL" $ \smp -> deleteSMPQueueLink smp rcvPrivateKey rcvId
|
||||
deleteQueueLink :: AgentClient -> NetworkRequestMode -> RcvQueue -> AM ()
|
||||
deleteQueueLink c nm rq@RcvQueue {rcvId, rcvPrivateKey} =
|
||||
withSMPClient c nm rq "LDEL" $ \smp -> deleteSMPQueueLink smp nm rcvPrivateKey rcvId
|
||||
|
||||
secureGetQueueLink :: AgentClient -> UserId -> InvShortLink -> AM (SMP.SenderId, QueueLinkData)
|
||||
secureGetQueueLink c userId InvShortLink {server, linkId, sndPrivateKey, sndPublicKey} =
|
||||
snd <$> sendOrProxySMPCommand c userId server (unEntityId linkId) "LKEY <key>" linkId secureGetViaProxy secureGetDirectly
|
||||
secureGetQueueLink :: AgentClient -> NetworkRequestMode -> UserId -> InvShortLink -> AM (SMP.SenderId, QueueLinkData)
|
||||
secureGetQueueLink c nm userId InvShortLink {server, linkId, sndPrivateKey, sndPublicKey} =
|
||||
snd <$> sendOrProxySMPCommand c nm userId server (unEntityId linkId) "LKEY <key>" linkId secureGetViaProxy secureGetDirectly
|
||||
where
|
||||
secureGetViaProxy smp proxySess = proxySecureGetSMPQueueLink smp proxySess sndPrivateKey linkId sndPublicKey
|
||||
secureGetDirectly smp = secureGetSMPQueueLink smp sndPrivateKey linkId sndPublicKey
|
||||
secureGetViaProxy smp proxySess = proxySecureGetSMPQueueLink smp nm proxySess sndPrivateKey linkId sndPublicKey
|
||||
secureGetDirectly smp = secureGetSMPQueueLink smp nm sndPrivateKey linkId sndPublicKey
|
||||
|
||||
getQueueLink :: AgentClient -> UserId -> SMPServer -> SMP.LinkId -> AM (SMP.SenderId, QueueLinkData)
|
||||
getQueueLink c userId server lnkId =
|
||||
snd <$> sendOrProxySMPCommand c userId server (unEntityId lnkId) "LGET" lnkId getViaProxy getDirectly
|
||||
getQueueLink :: AgentClient -> NetworkRequestMode -> UserId -> SMPServer -> SMP.LinkId -> AM (SMP.SenderId, QueueLinkData)
|
||||
getQueueLink c nm userId server lnkId =
|
||||
snd <$> sendOrProxySMPCommand c nm userId server (unEntityId lnkId) "LGET" lnkId getViaProxy getDirectly
|
||||
where
|
||||
getViaProxy smp proxySess = proxyGetSMPQueueLink smp proxySess lnkId
|
||||
getDirectly smp = getSMPQueueLink smp lnkId
|
||||
getViaProxy smp proxySess = proxyGetSMPQueueLink smp nm proxySess lnkId
|
||||
getDirectly smp = getSMPQueueLink smp nm lnkId
|
||||
|
||||
enableQueueNotifications :: AgentClient -> RcvQueue -> SMP.NtfPublicAuthKey -> SMP.RcvNtfPublicDhKey -> AM (SMP.NotifierId, SMP.RcvNtfPublicDhKey)
|
||||
enableQueueNotifications c rq@RcvQueue {rcvId, rcvPrivateKey} notifierKey rcvNtfPublicDhKey =
|
||||
withSMPClient c rq "NKEY <nkey>" $ \smp ->
|
||||
withSMPClient c NRMBackground rq "NKEY <nkey>" $ \smp ->
|
||||
enableSMPQueueNotifications smp rcvPrivateKey rcvId notifierKey rcvNtfPublicDhKey
|
||||
|
||||
data EnableQueueNtfReq = EnableQueueNtfReq
|
||||
@@ -1716,7 +1719,7 @@ data EnableQueueNtfReq = EnableQueueNtfReq
|
||||
}
|
||||
|
||||
enableQueuesNtfs :: AgentClient -> [EnableQueueNtfReq] -> AM' [(EnableQueueNtfReq, Either AgentErrorType (SMP.NotifierId, SMP.RcvNtfPublicDhKey))]
|
||||
enableQueuesNtfs = sendTSessionBatches "NKEY" eqnrRq enableQueues_
|
||||
enableQueuesNtfs c = sendTSessionBatches "NKEY" eqnrRq enableQueues_ c NRMBackground
|
||||
where
|
||||
enableQueues_ :: SMPClient -> NonEmpty EnableQueueNtfReq -> IO (NonEmpty (EnableQueueNtfReq, Either (ProtocolClientError ErrorType) (SMP.NotifierId, RcvNtfPublicDhKey)))
|
||||
enableQueues_ smp qs' = L.zip qs' <$> enableSMPQueuesNtfs smp (L.map queueCreds qs')
|
||||
@@ -1729,13 +1732,13 @@ enableQueuesNtfs = sendTSessionBatches "NKEY" eqnrRq enableQueues_
|
||||
|
||||
disableQueueNotifications :: AgentClient -> RcvQueue -> AM ()
|
||||
disableQueueNotifications c rq@RcvQueue {rcvId, rcvPrivateKey} =
|
||||
withSMPClient c rq "NDEL" $ \smp ->
|
||||
withSMPClient c NRMBackground rq "NDEL" $ \smp ->
|
||||
disableSMPQueueNotifications smp rcvPrivateKey rcvId
|
||||
|
||||
type DisableQueueNtfReq = (NtfSubscription, RcvQueue)
|
||||
|
||||
disableQueuesNtfs :: AgentClient -> [DisableQueueNtfReq] -> AM' [(DisableQueueNtfReq, Either AgentErrorType ())]
|
||||
disableQueuesNtfs = sendTSessionBatches "NDEL" snd disableQueues_
|
||||
disableQueuesNtfs c = sendTSessionBatches "NDEL" snd disableQueues_ c NRMBackground
|
||||
where
|
||||
disableQueues_ :: SMPClient -> NonEmpty DisableQueueNtfReq -> IO (NonEmpty (DisableQueueNtfReq, Either (ProtocolClientError ErrorType) ()))
|
||||
disableQueues_ smp qs' = L.zip qs' <$> disableSMPQueuesNtfs smp (L.map queueCreds qs')
|
||||
@@ -1744,7 +1747,7 @@ disableQueuesNtfs = sendTSessionBatches "NDEL" snd disableQueues_
|
||||
|
||||
sendAck :: AgentClient -> RcvQueue -> MsgId -> AM ()
|
||||
sendAck c rq@RcvQueue {rcvId, rcvPrivateKey} msgId =
|
||||
withSMPClient c rq ("ACK:" <> logSecret' msgId) $ \smp ->
|
||||
withSMPClient c NRMBackground rq ("ACK:" <> logSecret' msgId) $ \smp ->
|
||||
ackSMPMessage smp rcvPrivateKey rcvId msgId
|
||||
|
||||
hasGetLock :: AgentClient -> RcvQueue -> IO Bool
|
||||
@@ -1757,32 +1760,33 @@ releaseGetLock c RcvQueue {server, rcvId} =
|
||||
TM.lookup (server, rcvId) (getMsgLocks c) >>= mapM_ (`tryPutTMVar` ())
|
||||
{-# INLINE releaseGetLock #-}
|
||||
|
||||
suspendQueue :: AgentClient -> RcvQueue -> AM ()
|
||||
suspendQueue c rq@RcvQueue {rcvId, rcvPrivateKey} =
|
||||
withSMPClient c rq "OFF" $ \smp ->
|
||||
suspendSMPQueue smp rcvPrivateKey rcvId
|
||||
suspendQueue :: AgentClient -> NetworkRequestMode -> RcvQueue -> AM ()
|
||||
suspendQueue c nm rq@RcvQueue {rcvId, rcvPrivateKey} =
|
||||
withSMPClient c nm rq "OFF" $ \smp ->
|
||||
suspendSMPQueue smp nm rcvPrivateKey rcvId
|
||||
|
||||
deleteQueue :: AgentClient -> RcvQueue -> AM ()
|
||||
deleteQueue c rq@RcvQueue {rcvId, rcvPrivateKey} = do
|
||||
withSMPClient c rq "DEL" $ \smp ->
|
||||
deleteSMPQueue smp rcvPrivateKey rcvId
|
||||
deleteQueue :: AgentClient -> NetworkRequestMode -> RcvQueue -> AM ()
|
||||
deleteQueue c nm rq@RcvQueue {rcvId, rcvPrivateKey} = do
|
||||
withSMPClient c nm rq "DEL" $ \smp ->
|
||||
deleteSMPQueue smp nm rcvPrivateKey rcvId
|
||||
|
||||
deleteQueues :: AgentClient -> [RcvQueue] -> AM' [(RcvQueue, Either AgentErrorType ())]
|
||||
deleteQueues c = sendTSessionBatches "DEL" id deleteQueues_ c
|
||||
deleteQueues :: AgentClient -> NetworkRequestMode -> [RcvQueue] -> AM' [(RcvQueue, Either AgentErrorType ())]
|
||||
deleteQueues c nm = sendTSessionBatches "DEL" id deleteQueues_ c nm
|
||||
where
|
||||
deleteQueues_ smp rqs = do
|
||||
let (userId, srv, _) = transportSession' smp
|
||||
atomically $ incSMPServerStat' c userId srv connDelAttempts $ length rqs
|
||||
rs <- sendBatch deleteSMPQueues smp rqs
|
||||
rs <- sendBatch deleteSMPQueues smp nm rqs
|
||||
let successes = foldl' (\n (_, r) -> if isRight r then n + 1 else n) 0 rs
|
||||
atomically $ incSMPServerStat' c userId srv connDeleted successes
|
||||
pure rs
|
||||
|
||||
-- This is only used in background
|
||||
sendAgentMessage :: AgentClient -> SndQueue -> MsgFlags -> ByteString -> AM (Maybe SMPServer)
|
||||
sendAgentMessage c sq@SndQueue {userId, server, connId, sndId, sndPrivateKey} msgFlags agentMsg = do
|
||||
let clientMsg = SMP.ClientMessage SMP.PHEmpty agentMsg
|
||||
msg <- agentCbEncrypt sq Nothing $ smpEncode clientMsg
|
||||
sendOrProxySMPMessage c userId server connId "<MSG>" (Just sndPrivateKey) sndId msgFlags msg
|
||||
sendOrProxySMPMessage c NRMBackground userId server connId "<MSG>" (Just sndPrivateKey) sndId msgFlags msg
|
||||
|
||||
data ServerQueueInfo = ServerQueueInfo
|
||||
{ server :: SMPServer,
|
||||
@@ -1794,50 +1798,50 @@ data ServerQueueInfo = ServerQueueInfo
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
getQueueInfo :: AgentClient -> RcvQueue -> AM ServerQueueInfo
|
||||
getQueueInfo c rq@RcvQueue {server, rcvId, rcvPrivateKey, sndId, status, clientNtfCreds} =
|
||||
withSMPClient c rq "QUE" $ \smp -> do
|
||||
info <- getSMPQueueInfo smp rcvPrivateKey rcvId
|
||||
getQueueInfo :: AgentClient -> NetworkRequestMode -> RcvQueue -> AM ServerQueueInfo
|
||||
getQueueInfo c nm rq@RcvQueue {server, rcvId, rcvPrivateKey, sndId, status, clientNtfCreds} =
|
||||
withSMPClient c nm rq "QUE" $ \smp -> do
|
||||
info <- getSMPQueueInfo smp nm rcvPrivateKey rcvId
|
||||
let ntfId = enc . (\ClientNtfCreds {notifierId} -> notifierId) <$> clientNtfCreds
|
||||
pure ServerQueueInfo {server, rcvId = enc rcvId, sndId = enc sndId, ntfId, status = serializeQueueStatus status, info}
|
||||
where
|
||||
enc = decodeLatin1 . B64.encode . unEntityId
|
||||
|
||||
agentNtfRegisterToken :: AgentClient -> NtfToken -> NtfPublicAuthKey -> C.PublicKeyX25519 -> AM (NtfTokenId, C.PublicKeyX25519)
|
||||
agentNtfRegisterToken c NtfToken {deviceToken, ntfServer, ntfPrivKey} ntfPubKey pubDhKey =
|
||||
withClient c (0, ntfServer, Nothing) $ \ntf -> ntfRegisterToken ntf ntfPrivKey (NewNtfTkn deviceToken ntfPubKey pubDhKey)
|
||||
agentNtfRegisterToken :: AgentClient -> NetworkRequestMode -> NtfToken -> NtfPublicAuthKey -> C.PublicKeyX25519 -> AM (NtfTokenId, C.PublicKeyX25519)
|
||||
agentNtfRegisterToken c nm NtfToken {deviceToken, ntfServer, ntfPrivKey} ntfPubKey pubDhKey =
|
||||
withClient c nm (0, ntfServer, Nothing) $ \ntf -> ntfRegisterToken ntf nm ntfPrivKey (NewNtfTkn deviceToken ntfPubKey pubDhKey)
|
||||
|
||||
agentNtfVerifyToken :: AgentClient -> NtfTokenId -> NtfToken -> NtfRegCode -> AM ()
|
||||
agentNtfVerifyToken c tknId NtfToken {ntfServer, ntfPrivKey} code =
|
||||
withNtfClient c ntfServer tknId "TVFY" $ \ntf -> ntfVerifyToken ntf ntfPrivKey tknId code
|
||||
agentNtfVerifyToken :: AgentClient -> NetworkRequestMode -> NtfTokenId -> NtfToken -> NtfRegCode -> AM ()
|
||||
agentNtfVerifyToken c nm tknId NtfToken {ntfServer, ntfPrivKey} code =
|
||||
withNtfClient c nm ntfServer tknId "TVFY" $ \ntf -> ntfVerifyToken ntf nm ntfPrivKey tknId code
|
||||
|
||||
agentNtfCheckToken :: AgentClient -> NtfTokenId -> NtfToken -> AM NtfTknStatus
|
||||
agentNtfCheckToken c tknId NtfToken {ntfServer, ntfPrivKey} =
|
||||
withNtfClient c ntfServer tknId "TCHK" $ \ntf -> ntfCheckToken ntf ntfPrivKey tknId
|
||||
agentNtfCheckToken :: AgentClient -> NetworkRequestMode -> NtfTokenId -> NtfToken -> AM NtfTknStatus
|
||||
agentNtfCheckToken c nm tknId NtfToken {ntfServer, ntfPrivKey} =
|
||||
withNtfClient c nm ntfServer tknId "TCHK" $ \ntf -> ntfCheckToken ntf nm ntfPrivKey tknId
|
||||
|
||||
agentNtfReplaceToken :: AgentClient -> NtfTokenId -> NtfToken -> DeviceToken -> AM ()
|
||||
agentNtfReplaceToken c tknId NtfToken {ntfServer, ntfPrivKey} token =
|
||||
withNtfClient c ntfServer tknId "TRPL" $ \ntf -> ntfReplaceToken ntf ntfPrivKey tknId token
|
||||
agentNtfReplaceToken :: AgentClient -> NetworkRequestMode -> NtfTokenId -> NtfToken -> DeviceToken -> AM ()
|
||||
agentNtfReplaceToken c nm tknId NtfToken {ntfServer, ntfPrivKey} token =
|
||||
withNtfClient c nm ntfServer tknId "TRPL" $ \ntf -> ntfReplaceToken ntf nm ntfPrivKey tknId token
|
||||
|
||||
agentNtfDeleteToken :: AgentClient -> NtfServer -> C.APrivateAuthKey -> NtfTokenId -> AM ()
|
||||
agentNtfDeleteToken c ntfServer ntfPrivKey tknId =
|
||||
withNtfClient c ntfServer tknId "TDEL" $ \ntf -> ntfDeleteToken ntf ntfPrivKey tknId
|
||||
agentNtfDeleteToken :: AgentClient -> NetworkRequestMode -> NtfServer -> C.APrivateAuthKey -> NtfTokenId -> AM ()
|
||||
agentNtfDeleteToken c nm ntfServer ntfPrivKey tknId =
|
||||
withNtfClient c nm ntfServer tknId "TDEL" $ \ntf -> ntfDeleteToken ntf nm ntfPrivKey tknId
|
||||
|
||||
-- set to 0 to disable
|
||||
agentNtfSetCronInterval :: AgentClient -> NtfTokenId -> NtfToken -> Word16 -> AM ()
|
||||
agentNtfSetCronInterval c tknId NtfToken {ntfServer, ntfPrivKey} interval =
|
||||
withNtfClient c ntfServer tknId "TCRN" $ \ntf -> ntfSetCronInterval ntf ntfPrivKey tknId interval
|
||||
agentNtfSetCronInterval :: AgentClient -> NetworkRequestMode -> NtfTokenId -> NtfToken -> Word16 -> AM ()
|
||||
agentNtfSetCronInterval c nm tknId NtfToken {ntfServer, ntfPrivKey} interval =
|
||||
withNtfClient c nm ntfServer tknId "TCRN" $ \ntf -> ntfSetCronInterval ntf nm ntfPrivKey tknId interval
|
||||
|
||||
agentNtfCreateSubscription :: AgentClient -> NtfTokenId -> NtfToken -> SMPQueueNtf -> SMP.NtfPrivateAuthKey -> AM NtfSubscriptionId
|
||||
agentNtfCreateSubscription c tknId NtfToken {ntfServer, ntfPrivKey} smpQueue nKey =
|
||||
withNtfClient c ntfServer tknId "SNEW" $ \ntf -> ntfCreateSubscription ntf ntfPrivKey (NewNtfSub tknId smpQueue nKey)
|
||||
withNtfClient c NRMBackground ntfServer tknId "SNEW" $ \ntf -> ntfCreateSubscription ntf ntfPrivKey (NewNtfSub tknId smpQueue nKey)
|
||||
|
||||
agentNtfCreateSubscriptions :: AgentClient -> NtfToken -> NonEmpty (NewNtfEntity 'Subscription) -> AM' (NonEmpty (Either AgentErrorType NtfSubscriptionId))
|
||||
agentNtfCreateSubscriptions = withNtfBatch "SNEW" ntfCreateSubscriptions
|
||||
|
||||
agentNtfCheckSubscription :: AgentClient -> NtfToken -> NtfSubscriptionId -> AM NtfSubStatus
|
||||
agentNtfCheckSubscription c NtfToken {ntfServer, ntfPrivKey} subId =
|
||||
withNtfClient c ntfServer subId "SCHK" $ \ntf -> ntfCheckSubscription ntf ntfPrivKey subId
|
||||
withNtfClient c NRMBackground ntfServer subId "SCHK" $ \ntf -> ntfCheckSubscription ntf ntfPrivKey subId
|
||||
|
||||
agentNtfCheckSubscriptions :: AgentClient -> NtfToken -> NonEmpty NtfSubscriptionId -> AM' (NonEmpty (Either AgentErrorType NtfSubStatus))
|
||||
agentNtfCheckSubscriptions = withNtfBatch "SCHK" ntfCheckSubscriptions
|
||||
@@ -1852,7 +1856,7 @@ withNtfBatch ::
|
||||
AM' (NonEmpty (Either AgentErrorType r))
|
||||
withNtfBatch cmdStr action c NtfToken {ntfServer, ntfPrivKey} subs = do
|
||||
let tSess = (0, ntfServer, Nothing)
|
||||
tryAgentError' (getNtfServerClient c tSess) >>= \case
|
||||
tryAgentError' (getNtfServerClient c NRMBackground tSess) >>= \case
|
||||
Left e -> pure $ L.map (\_ -> Left e) subs
|
||||
Right ntf -> liftIO $ do
|
||||
logServer' "-->" c ntfServer (bshow (length subs) <> " subscriptions") cmdStr
|
||||
@@ -1862,7 +1866,7 @@ withNtfBatch cmdStr action c NtfToken {ntfServer, ntfPrivKey} subs = do
|
||||
|
||||
agentNtfDeleteSubscription :: AgentClient -> NtfSubscriptionId -> NtfToken -> AM ()
|
||||
agentNtfDeleteSubscription c subId NtfToken {ntfServer, ntfPrivKey} =
|
||||
withNtfClient c ntfServer subId "SDEL" $ \ntf -> ntfDeleteSubscription ntf ntfPrivKey subId
|
||||
withNtfClient c NRMBackground ntfServer subId "SDEL" $ \ntf -> ntfDeleteSubscription ntf ntfPrivKey subId
|
||||
|
||||
agentXFTPDownloadChunk :: AgentClient -> UserId -> FileDigest -> RcvFileChunkReplica -> XFTPRcvChunkSpec -> AM ()
|
||||
agentXFTPDownloadChunk c userId (FileDigest chunkDigest) RcvFileChunkReplica {server, replicaId = ChunkReplicaId fId, replicaKey} chunkSpec = do
|
||||
@@ -1876,7 +1880,7 @@ agentXFTPNewChunk c SndFileChunk {userId, chunkSpec = XFTPChunkSpec {chunkSize},
|
||||
let fileInfo = FileInfo {sndKey, size = chunkSize, digest = chunkDigest}
|
||||
logServer "-->" c srv NoEntity "FNEW"
|
||||
tSess <- mkTransportSession c userId srv chunkDigest
|
||||
(sndId, rIds) <- withClient c tSess $ \xftp -> X.createXFTPChunk xftp replicaKey fileInfo (L.map fst rKeys) auth
|
||||
(sndId, rIds) <- withClient c NRMBackground tSess $ \xftp -> X.createXFTPChunk xftp replicaKey fileInfo (L.map fst rKeys) auth
|
||||
logServer "<--" c srv NoEntity $ B.unwords ["SIDS", logSecret sndId]
|
||||
pure NewSndChunkReplica {server = srv, replicaId = ChunkReplicaId sndId, replicaKey, rcvIdsKeys = L.toList $ xftpRcvIdsKeys rIds rKeys}
|
||||
|
||||
|
||||
@@ -45,6 +45,7 @@ import Simplex.Messaging.Agent.Stats
|
||||
import Simplex.Messaging.Agent.Store
|
||||
import Simplex.Messaging.Agent.Store.AgentStore
|
||||
import qualified Simplex.Messaging.Agent.Store.DB as DB
|
||||
import Simplex.Messaging.Client (NetworkRequestMode (..))
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Notifications.Protocol
|
||||
import Simplex.Messaging.Notifications.Types
|
||||
@@ -572,7 +573,7 @@ runNtfTknDelWorker c srv Worker {doWork} =
|
||||
notifyInternalError' c (show e)
|
||||
processTknToDelete :: NtfTokenToDelete -> AM ()
|
||||
processTknToDelete (tknDbId, ntfPrivKey, tknId) = do
|
||||
agentNtfDeleteToken c srv ntfPrivKey tknId
|
||||
agentNtfDeleteToken c NRMBackground srv ntfPrivKey tknId
|
||||
withStore' c $ \db -> deleteNtfTokenToDelete db tknDbId
|
||||
|
||||
closeNtfSupervisor :: NtfSupervisor -> IO ()
|
||||
|
||||
+146
-99
@@ -8,6 +8,7 @@
|
||||
{-# LANGUAGE NumericUnderscores #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
@@ -81,12 +82,16 @@ module Simplex.Messaging.Client
|
||||
unexpectedResponse,
|
||||
ProtocolClientConfig (..),
|
||||
NetworkConfig (..),
|
||||
NetworkTimeout (..),
|
||||
NetworkRequestMode (..),
|
||||
pattern NRMInteractive,
|
||||
TransportSessionMode (..),
|
||||
HostMode (..),
|
||||
SocksMode (..),
|
||||
SMPProxyMode (..),
|
||||
SMPProxyFallback (..),
|
||||
SMPWebPortServers (..),
|
||||
netTimeoutInt,
|
||||
defaultClientConfig,
|
||||
defaultSMPClientConfig,
|
||||
defaultNetworkConfig,
|
||||
@@ -154,7 +159,7 @@ import Simplex.Messaging.Server.QueueStore.QueueInfo
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Transport
|
||||
import Simplex.Messaging.Transport.Client (SocksAuth (..), SocksProxyWithAuth (..), TransportClientConfig (..), TransportHost (..), defaultSMPPort, defaultTcpConnectTimeout, runTransportClient)
|
||||
import Simplex.Messaging.Transport.Client (SocksAuth (..), SocksProxyWithAuth (..), TransportClientConfig (..), TransportHost (..), defaultSMPPort, runTransportClient)
|
||||
import Simplex.Messaging.Transport.KeepAlive
|
||||
import Simplex.Messaging.Util
|
||||
import Simplex.Messaging.Version
|
||||
@@ -175,8 +180,8 @@ data PClient v err msg = PClient
|
||||
{ connected :: TVar Bool,
|
||||
transportSession :: TransportSession msg,
|
||||
transportHost :: TransportHost,
|
||||
tcpConnectTimeout :: Int,
|
||||
tcpTimeout :: Int,
|
||||
tcpConnectTimeout :: NetworkTimeout,
|
||||
tcpTimeout :: NetworkTimeout,
|
||||
sendPings :: TVar Bool,
|
||||
lastReceived :: TVar UTCTime,
|
||||
timeoutErrorCount :: TVar Int,
|
||||
@@ -198,6 +203,7 @@ smpClientStub g sessionId thVersion thAuth = do
|
||||
timeoutErrorCount <- newTVarIO 0
|
||||
sndQ <- newTBQueueIO 100
|
||||
rcvQ <- newTBQueueIO 100
|
||||
let NetworkConfig {tcpConnectTimeout, tcpTimeout} = defaultNetworkConfig
|
||||
return
|
||||
ProtocolClient
|
||||
{ action = Nothing,
|
||||
@@ -219,8 +225,8 @@ smpClientStub g sessionId thVersion thAuth = do
|
||||
{ connected,
|
||||
transportSession = (1, "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5001", Nothing),
|
||||
transportHost = "localhost",
|
||||
tcpConnectTimeout = 20_000_000,
|
||||
tcpTimeout = 15_000_000,
|
||||
tcpConnectTimeout,
|
||||
tcpTimeout,
|
||||
sendPings,
|
||||
lastReceived,
|
||||
timeoutErrorCount,
|
||||
@@ -298,9 +304,9 @@ data NetworkConfig = NetworkConfig
|
||||
-- | use web port 443 for SMP protocol
|
||||
smpWebPortServers :: SMPWebPortServers,
|
||||
-- | timeout for the initial client TCP/TLS connection (microseconds)
|
||||
tcpConnectTimeout :: Int,
|
||||
tcpConnectTimeout :: NetworkTimeout,
|
||||
-- | timeout of protocol commands (microseconds)
|
||||
tcpTimeout :: Int,
|
||||
tcpTimeout :: NetworkTimeout,
|
||||
-- | additional timeout per kilobyte (1024 bytes) to be sent
|
||||
tcpTimeoutPerKb :: Int64,
|
||||
-- | break response timeouts into groups, so later responses get later deadlines
|
||||
@@ -315,6 +321,28 @@ data NetworkConfig = NetworkConfig
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data NetworkTimeout = NetworkTimeout {backgroundTimeout :: Int, interactiveTimeout :: Int}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data NetworkRequestMode
|
||||
= NRMBackground
|
||||
| NRMInteractive' {retryCount :: Int}
|
||||
|
||||
pattern NRMInteractive :: NetworkRequestMode
|
||||
pattern NRMInteractive = NRMInteractive' 0
|
||||
|
||||
netTimeoutInt :: NetworkTimeout -> NetworkRequestMode -> Int
|
||||
netTimeoutInt NetworkTimeout {backgroundTimeout, interactiveTimeout} = \case
|
||||
NRMBackground -> backgroundTimeout
|
||||
NRMInteractive' n
|
||||
| n <= 0 -> interactiveTimeout
|
||||
| otherwise ->
|
||||
let (m, d)
|
||||
| n == 1 = (3, 2)
|
||||
| n == 2 = (9, 4)
|
||||
| otherwise = (27, 8)
|
||||
in (interactiveTimeout * m) `div` d
|
||||
|
||||
data TransportSessionMode = TSMUser | TSMSession | TSMServer | TSMEntity
|
||||
deriving (Eq, Show)
|
||||
|
||||
@@ -387,8 +415,8 @@ defaultNetworkConfig =
|
||||
smpProxyMode = SPMNever,
|
||||
smpProxyFallback = SPFAllow,
|
||||
smpWebPortServers = SWPPreset,
|
||||
tcpConnectTimeout = defaultTcpConnectTimeout,
|
||||
tcpTimeout = 15_000_000,
|
||||
tcpConnectTimeout = NetworkTimeout {backgroundTimeout = 45_000000, interactiveTimeout = 15_000000},
|
||||
tcpTimeout = NetworkTimeout {backgroundTimeout = 30_000000, interactiveTimeout = 10_000000},
|
||||
tcpTimeoutPerKb = 5_000,
|
||||
rcvConcurrency = 8,
|
||||
tcpKeepAlive = Just defaultKeepAliveOpts,
|
||||
@@ -397,10 +425,11 @@ defaultNetworkConfig =
|
||||
logTLSErrors = False
|
||||
}
|
||||
|
||||
transportClientConfig :: NetworkConfig -> TransportHost -> Bool -> Maybe [ALPN] -> TransportClientConfig
|
||||
transportClientConfig NetworkConfig {socksProxy, socksMode, tcpConnectTimeout, tcpKeepAlive, logTLSErrors} host useSNI clientALPN =
|
||||
TransportClientConfig {socksProxy = useSocksProxy socksMode, tcpConnectTimeout, tcpKeepAlive, logTLSErrors, clientCredentials = Nothing, clientALPN, useSNI}
|
||||
transportClientConfig :: NetworkConfig -> NetworkRequestMode -> TransportHost -> Bool -> Maybe [ALPN] -> TransportClientConfig
|
||||
transportClientConfig NetworkConfig {socksProxy, socksMode, tcpConnectTimeout, tcpKeepAlive, logTLSErrors} nm host useSNI clientALPN =
|
||||
TransportClientConfig {socksProxy = useSocksProxy socksMode, tcpConnectTimeout = tOut, tcpKeepAlive, logTLSErrors, clientCredentials = Nothing, clientALPN, useSNI}
|
||||
where
|
||||
tOut = netTimeoutInt tcpConnectTimeout nm
|
||||
socksProxy' = (\(SocksProxyWithAuth _ proxy) -> proxy) <$> socksProxy
|
||||
useSocksProxy SMAlways = socksProxy'
|
||||
useSocksProxy SMOnion = case host of
|
||||
@@ -523,8 +552,8 @@ type TransportSession msg = (UserId, ProtoServer msg, Maybe ByteString)
|
||||
--
|
||||
-- A single queue can be used for multiple 'SMPClient' instances,
|
||||
-- as 'SMPServerTransmission' includes server information.
|
||||
getProtocolClient :: forall v err msg. Protocol v err msg => TVar ChaChaDRG -> TransportSession msg -> ProtocolClientConfig v -> [HostName] -> Maybe (TBQueue (ServerTransmissionBatch v err msg)) -> UTCTime -> (ProtocolClient v err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
|
||||
getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, clientALPN, serviceCredentials, serverVRange, agreeSecret, proxyServer, useSNI} presetDomains msgQ proxySessTs disconnected = do
|
||||
getProtocolClient :: forall v err msg. Protocol v err msg => TVar ChaChaDRG -> NetworkRequestMode -> TransportSession msg -> ProtocolClientConfig v -> [HostName] -> Maybe (TBQueue (ServerTransmissionBatch v err msg)) -> UTCTime -> (ProtocolClient v err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
|
||||
getProtocolClient g nm transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, clientALPN, serviceCredentials, serverVRange, agreeSecret, proxyServer, useSNI} presetDomains msgQ proxySessTs disconnected = do
|
||||
case chooseTransportHost networkConfig (host srv) of
|
||||
Right useHost ->
|
||||
(getCurrentTime >>= mkProtocolClient useHost >>= runClient useTransport useHost)
|
||||
@@ -562,12 +591,12 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
|
||||
runClient :: (ServiceName, ATransport 'TClient) -> TransportHost -> PClient v err msg -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
|
||||
runClient (port', ATransport t) useHost c = do
|
||||
cVar <- newEmptyTMVarIO
|
||||
let tcConfig = (transportClientConfig networkConfig useHost useSNI clientALPN) {clientCredentials = serviceCreds <$> serviceCredentials}
|
||||
let tcConfig = (transportClientConfig networkConfig nm useHost useSNI clientALPN) {clientCredentials = serviceCreds <$> serviceCredentials}
|
||||
socksCreds = clientSocksCredentials networkConfig proxySessTs transportSession
|
||||
tId <-
|
||||
runTransportClient tcConfig socksCreds useHost port' (Just $ keyHash srv) (client t c cVar)
|
||||
`forkFinally` \_ -> void (atomically . tryPutTMVar cVar $ Left PCENetworkError)
|
||||
c_ <- tcpConnectTimeout `timeout` atomically (takeTMVar cVar)
|
||||
c_ <- netTimeoutInt tcpConnectTimeout nm `timeout` atomically (takeTMVar cVar)
|
||||
case c_ of
|
||||
Just (Right c') -> mkWeakThreadId tId >>= \tId' -> pure $ Right c' {action = Just tId'}
|
||||
Just (Left e) -> pure $ Left e
|
||||
@@ -631,7 +660,7 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
|
||||
if remaining > 1_000_000 -- delay pings only for significant time
|
||||
then loop remaining
|
||||
else do
|
||||
whenM (readTVarIO sendPings) $ void . runExceptT $ sendProtocolCommand c Nothing NoEntity (protocolPing @v @err @msg)
|
||||
whenM (readTVarIO sendPings) $ void . runExceptT $ sendProtocolCommand c NRMBackground Nothing NoEntity (protocolPing @v @err @msg)
|
||||
-- sendProtocolCommand/getResponse updates counter for each command
|
||||
cnt <- readTVarIO timeoutErrorCount
|
||||
-- drop client when maxCnt of commands have timed out in sequence, but only after some time has passed after last received response
|
||||
@@ -757,6 +786,7 @@ smpProxyError = \case
|
||||
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#create-queue-command
|
||||
createSMPQueue ::
|
||||
SMPClient ->
|
||||
NetworkRequestMode ->
|
||||
Maybe C.CbNonce -> -- used as correlation ID to allow deriving SenderId from it for short links
|
||||
C.AAuthKeyPair -> -- SMP v6 - signature key pair, SMP v7 - DH key pair
|
||||
RcvPublicDhKey ->
|
||||
@@ -766,29 +796,32 @@ createSMPQueue ::
|
||||
-- TODO [notifications]
|
||||
-- Maybe NewNtfCreds ->
|
||||
ExceptT SMPClientError IO QueueIdsKeys
|
||||
createSMPQueue c nonce_ (rKey, rpKey) dhKey auth subMode qrd =
|
||||
sendProtocolCommand_ c nonce_ Nothing (Just rpKey) NoEntity (Cmd SCreator $ NEW $ NewQueueReq rKey dhKey auth subMode (Just qrd)) >>= \case
|
||||
createSMPQueue c nm nonce_ (rKey, rpKey) dhKey auth subMode qrd =
|
||||
sendProtocolCommand_ c nm nonce_ Nothing (Just rpKey) NoEntity (Cmd SCreator $ NEW $ NewQueueReq rKey dhKey auth subMode (Just qrd)) >>= \case
|
||||
IDS qik -> pure qik
|
||||
r -> throwE $ unexpectedResponse r
|
||||
|
||||
-- | Subscribe to the SMP queue.
|
||||
--
|
||||
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#subscribe-to-queue
|
||||
-- This command is always sent in background request mode
|
||||
subscribeSMPQueue :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO (Maybe ServiceId)
|
||||
subscribeSMPQueue c rpKey rId = do
|
||||
liftIO $ enablePings c
|
||||
sendSMPCommand c (Just rpKey) rId SUB >>= liftIO . processSUBResponse_ c rId >>= except
|
||||
sendSMPCommand c NRMBackground (Just rpKey) rId SUB >>= liftIO . processSUBResponse_ c rId >>= except
|
||||
|
||||
-- | Subscribe to multiple SMP queues batching commands if supported.
|
||||
-- This command is always sent in background request mode
|
||||
subscribeSMPQueues :: SMPClient -> NonEmpty (RecipientId, RcvPrivateAuthKey) -> IO (NonEmpty (Either SMPClientError (Maybe ServiceId)))
|
||||
subscribeSMPQueues c qs = do
|
||||
liftIO $ enablePings c
|
||||
sendProtocolCommands c cs >>= mapM (processSUBResponse c)
|
||||
sendProtocolCommands c NRMBackground cs >>= mapM (processSUBResponse c)
|
||||
where
|
||||
cs = L.map (\(rId, rpKey) -> (rId, Just rpKey, Cmd SRecipient SUB)) qs
|
||||
|
||||
-- This command is always sent in background request mode
|
||||
streamSubscribeSMPQueues :: SMPClient -> NonEmpty (RecipientId, RcvPrivateAuthKey) -> ([(RecipientId, Either SMPClientError (Maybe ServiceId))] -> IO ()) -> IO ()
|
||||
streamSubscribeSMPQueues c qs cb = streamProtocolCommands c cs $ mapM process >=> cb
|
||||
streamSubscribeSMPQueues c qs cb = streamProtocolCommands c NRMBackground cs $ mapM process >=> cb
|
||||
where
|
||||
cs = L.map (\(rId, rpKey) -> (rId, Just rpKey, Cmd SRecipient SUB)) qs
|
||||
process r@(Response rId _) = (rId,) <$> processSUBResponse c r
|
||||
@@ -813,9 +846,10 @@ serverTransmission ProtocolClient {thParams = THandleParams {thVersion, sessionI
|
||||
-- | Get message from SMP queue. The server returns ERR PROHIBITED if a client uses SUB and GET via the same transport connection for the same queue
|
||||
--
|
||||
-- https://github.covm/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#receive-a-message-from-the-queue
|
||||
-- This command is always sent in interactive request mode, as NSE has limited time
|
||||
getSMPMessage :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO (Maybe RcvMessage)
|
||||
getSMPMessage c rpKey rId =
|
||||
sendSMPCommand c (Just rpKey) rId GET >>= \case
|
||||
sendSMPCommand c NRMInteractive (Just rpKey) rId GET >>= \case
|
||||
OK -> pure Nothing
|
||||
cmd@(MSG msg) -> liftIO (writeSMPMessage c rId cmd) $> Just msg
|
||||
r -> throwE $ unexpectedResponse r
|
||||
@@ -824,16 +858,18 @@ getSMPMessage c rpKey rId =
|
||||
-- | Subscribe to the SMP queue notifications.
|
||||
--
|
||||
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#subscribe-to-queue-notifications
|
||||
-- This command is always sent in background request mode
|
||||
subscribeSMPQueueNotifications :: SMPClient -> NtfPrivateAuthKey -> NotifierId -> ExceptT SMPClientError IO (Maybe ServiceId)
|
||||
subscribeSMPQueueNotifications c npKey nId = do
|
||||
liftIO $ enablePings c
|
||||
sendSMPCommand c (Just npKey) nId NSUB >>= except . nsubResponse_
|
||||
sendSMPCommand c NRMBackground (Just npKey) nId NSUB >>= except . nsubResponse_
|
||||
|
||||
-- | Subscribe to multiple SMP queues notifications batching commands if supported.
|
||||
-- This command is always sent in background request mode
|
||||
subscribeSMPQueuesNtfs :: SMPClient -> NonEmpty (NotifierId, NtfPrivateAuthKey) -> IO (NonEmpty (Either SMPClientError (Maybe ServiceId)))
|
||||
subscribeSMPQueuesNtfs c qs = do
|
||||
liftIO $ enablePings c
|
||||
L.map nsubResponse <$> sendProtocolCommands c cs
|
||||
L.map nsubResponse <$> sendProtocolCommands c NRMBackground cs
|
||||
where
|
||||
cs = L.map (\(nId, npKey) -> (nId, Just npKey, Cmd SNotifier NSUB)) qs
|
||||
|
||||
@@ -848,11 +884,12 @@ nsubResponse_ = \case
|
||||
r' -> Left $ unexpectedResponse r'
|
||||
{-# INLINE nsubResponse_ #-}
|
||||
|
||||
-- This command is always sent in background request mode
|
||||
subscribeService :: forall p. (PartyI p, ServiceParty p) => SMPClient -> SParty p -> ExceptT SMPClientError IO Int64
|
||||
subscribeService c party = case smpClientService c of
|
||||
Just THClientService {serviceId, serviceKey} -> do
|
||||
liftIO $ enablePings c
|
||||
sendSMPCommand c (Just (C.APrivateAuthKey C.SEd25519 serviceKey)) serviceId subCmd >>= \case
|
||||
sendSMPCommand c NRMBackground (Just (C.APrivateAuthKey C.SEd25519 serviceKey)) serviceId subCmd >>= \case
|
||||
SOKS n -> pure n
|
||||
r -> throwE $ unexpectedResponse r
|
||||
where
|
||||
@@ -873,53 +910,54 @@ enablePings ProtocolClient {client_ = PClient {sendPings}} = atomically $ writeT
|
||||
-- | 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 -> RcvPrivateAuthKey -> RecipientId -> SndPublicAuthKey -> ExceptT SMPClientError IO ()
|
||||
secureSMPQueue c rpKey rId senderKey = okSMPCommand (KEY senderKey) c rpKey rId
|
||||
secureSMPQueue :: SMPClient -> NetworkRequestMode -> RcvPrivateAuthKey -> RecipientId -> SndPublicAuthKey -> ExceptT SMPClientError IO ()
|
||||
secureSMPQueue c nm rpKey rId senderKey = okSMPCommand (KEY senderKey) c nm rpKey rId
|
||||
{-# INLINE secureSMPQueue #-}
|
||||
|
||||
-- | Secure the SMP queue via sender queue ID.
|
||||
secureSndSMPQueue :: SMPClient -> SndPrivateAuthKey -> SenderId -> SndPublicAuthKey -> ExceptT SMPClientError IO ()
|
||||
secureSndSMPQueue c spKey sId senderKey = okSMPCommand (SKEY senderKey) c spKey sId
|
||||
secureSndSMPQueue :: SMPClient -> NetworkRequestMode -> SndPrivateAuthKey -> SenderId -> SndPublicAuthKey -> ExceptT SMPClientError IO ()
|
||||
secureSndSMPQueue c nm spKey sId senderKey = okSMPCommand (SKEY senderKey) c nm spKey sId
|
||||
{-# INLINE secureSndSMPQueue #-}
|
||||
|
||||
proxySecureSndSMPQueue :: SMPClient -> ProxiedRelay -> SndPrivateAuthKey -> SenderId -> SndPublicAuthKey -> ExceptT SMPClientError IO (Either ProxyClientError ())
|
||||
proxySecureSndSMPQueue c proxiedRelay spKey sId senderKey = proxyOKSMPCommand c proxiedRelay (Just spKey) sId (SKEY senderKey)
|
||||
proxySecureSndSMPQueue :: SMPClient -> NetworkRequestMode -> ProxiedRelay -> SndPrivateAuthKey -> SenderId -> SndPublicAuthKey -> ExceptT SMPClientError IO (Either ProxyClientError ())
|
||||
proxySecureSndSMPQueue c nm proxiedRelay spKey sId senderKey = proxyOKSMPCommand c nm proxiedRelay (Just spKey) sId (SKEY senderKey)
|
||||
{-# INLINE proxySecureSndSMPQueue #-}
|
||||
|
||||
-- | Add or update date for queue link
|
||||
addSMPQueueLink :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> LinkId -> QueueLinkData -> ExceptT SMPClientError IO ()
|
||||
addSMPQueueLink c rpKey rId lnkId d = okSMPCommand (LSET lnkId d) c rpKey rId
|
||||
addSMPQueueLink :: SMPClient -> NetworkRequestMode -> RcvPrivateAuthKey -> RecipientId -> LinkId -> QueueLinkData -> ExceptT SMPClientError IO ()
|
||||
addSMPQueueLink c nm rpKey rId lnkId d = okSMPCommand (LSET lnkId d) c nm rpKey rId
|
||||
{-# INLINE addSMPQueueLink #-}
|
||||
|
||||
-- | Delete queue link
|
||||
deleteSMPQueueLink :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO ()
|
||||
deleteSMPQueueLink :: SMPClient -> NetworkRequestMode -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO ()
|
||||
deleteSMPQueueLink = okSMPCommand LDEL
|
||||
{-# INLINE deleteSMPQueueLink #-}
|
||||
|
||||
-- | Get 1-time inviation SMP queue link data and secure the queue via queue link ID.
|
||||
secureGetSMPQueueLink :: SMPClient -> SndPrivateAuthKey -> LinkId -> SndPublicAuthKey -> ExceptT SMPClientError IO (SenderId, QueueLinkData)
|
||||
secureGetSMPQueueLink c spKey lnkId senderKey =
|
||||
sendSMPCommand c (Just spKey) lnkId (LKEY senderKey) >>= \case
|
||||
secureGetSMPQueueLink :: SMPClient -> NetworkRequestMode -> SndPrivateAuthKey -> LinkId -> SndPublicAuthKey -> ExceptT SMPClientError IO (SenderId, QueueLinkData)
|
||||
secureGetSMPQueueLink c nm spKey lnkId senderKey =
|
||||
sendSMPCommand c nm (Just spKey) lnkId (LKEY senderKey) >>= \case
|
||||
LNK sId d -> pure (sId, d)
|
||||
r -> throwE $ unexpectedResponse r
|
||||
|
||||
proxySecureGetSMPQueueLink :: SMPClient -> ProxiedRelay -> SndPrivateAuthKey -> LinkId -> SndPublicAuthKey -> ExceptT SMPClientError IO (Either ProxyClientError (SenderId, QueueLinkData))
|
||||
proxySecureGetSMPQueueLink c proxiedRelay spKey lnkId senderKey =
|
||||
proxySMPCommand c proxiedRelay (Just spKey) lnkId (LKEY senderKey) >>= \case
|
||||
proxySecureGetSMPQueueLink :: SMPClient -> NetworkRequestMode -> ProxiedRelay -> SndPrivateAuthKey -> LinkId -> SndPublicAuthKey -> ExceptT SMPClientError IO (Either ProxyClientError (SenderId, QueueLinkData))
|
||||
proxySecureGetSMPQueueLink c nm proxiedRelay spKey lnkId senderKey =
|
||||
proxySMPCommand c nm proxiedRelay (Just spKey) lnkId (LKEY senderKey) >>= \case
|
||||
Right (LNK sId d) -> pure $ Right (sId, d)
|
||||
Right r -> throwE $ unexpectedResponse r
|
||||
Left e -> pure $ Left e
|
||||
|
||||
-- | Get contact address SMP queue link data.
|
||||
getSMPQueueLink :: SMPClient -> LinkId -> ExceptT SMPClientError IO (SenderId, QueueLinkData)
|
||||
getSMPQueueLink c lnkId =
|
||||
sendSMPCommand c Nothing lnkId LGET >>= \case
|
||||
getSMPQueueLink :: SMPClient -> NetworkRequestMode -> LinkId -> ExceptT SMPClientError IO (SenderId, QueueLinkData)
|
||||
getSMPQueueLink c nm lnkId =
|
||||
sendSMPCommand c nm Nothing lnkId LGET >>= \case
|
||||
LNK sId d -> pure (sId, d)
|
||||
r -> throwE $ unexpectedResponse r
|
||||
|
||||
proxyGetSMPQueueLink :: SMPClient -> ProxiedRelay -> LinkId -> ExceptT SMPClientError IO (Either ProxyClientError (SenderId, QueueLinkData))
|
||||
proxyGetSMPQueueLink c proxiedRelay lnkId =
|
||||
proxySMPCommand c proxiedRelay Nothing lnkId LGET >>= \case
|
||||
-- LGET command - get short link data
|
||||
proxyGetSMPQueueLink :: SMPClient -> NetworkRequestMode -> ProxiedRelay -> LinkId -> ExceptT SMPClientError IO (Either ProxyClientError (SenderId, QueueLinkData))
|
||||
proxyGetSMPQueueLink c nm proxiedRelay lnkId =
|
||||
proxySMPCommand c nm proxiedRelay Nothing lnkId LGET >>= \case
|
||||
Right (LNK sId d) -> pure $ Right (sId, d)
|
||||
Right r -> throwE $ unexpectedResponse r
|
||||
Left e -> pure $ Left e
|
||||
@@ -929,13 +967,14 @@ proxyGetSMPQueueLink c proxiedRelay lnkId =
|
||||
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#enable-notifications-command
|
||||
enableSMPQueueNotifications :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> NtfPublicAuthKey -> RcvNtfPublicDhKey -> ExceptT SMPClientError IO (NotifierId, RcvNtfPublicDhKey)
|
||||
enableSMPQueueNotifications c rpKey rId notifierKey rcvNtfPublicDhKey =
|
||||
sendSMPCommand c (Just rpKey) rId (NKEY notifierKey rcvNtfPublicDhKey) >>= \case
|
||||
sendSMPCommand c NRMBackground (Just rpKey) rId (NKEY notifierKey rcvNtfPublicDhKey) >>= \case
|
||||
NID nId rcvNtfSrvPublicDhKey -> pure (nId, rcvNtfSrvPublicDhKey)
|
||||
r -> throwE $ unexpectedResponse r
|
||||
|
||||
-- | Enable notifications for the multiple queues for push notifications server.
|
||||
-- This command is always sent in background request mode
|
||||
enableSMPQueuesNtfs :: SMPClient -> NonEmpty (RecipientId, RcvPrivateAuthKey, NtfPublicAuthKey, RcvNtfPublicDhKey) -> IO (NonEmpty (Either SMPClientError (NotifierId, RcvNtfPublicDhKey)))
|
||||
enableSMPQueuesNtfs c qs = L.map process <$> sendProtocolCommands c cs
|
||||
enableSMPQueuesNtfs c qs = L.map process <$> sendProtocolCommands c NRMBackground cs
|
||||
where
|
||||
cs = L.map (\(rId, rpKey, notifierKey, rcvNtfPublicDhKey) -> (rId, Just rpKey, Cmd SRecipient $ NKEY notifierKey rcvNtfPublicDhKey)) qs
|
||||
process (Response _ r) = case r of
|
||||
@@ -946,33 +985,36 @@ enableSMPQueuesNtfs c qs = L.map process <$> sendProtocolCommands c cs
|
||||
-- | Disable notifications for the queue for push notifications server.
|
||||
--
|
||||
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#disable-notifications-command
|
||||
-- This command is always sent in background request mode
|
||||
disableSMPQueueNotifications :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO ()
|
||||
disableSMPQueueNotifications = okSMPCommand NDEL
|
||||
disableSMPQueueNotifications c = okSMPCommand NDEL c NRMBackground
|
||||
{-# INLINE disableSMPQueueNotifications #-}
|
||||
|
||||
-- | Disable notifications for multiple queues for push notifications server.
|
||||
-- This command is always sent in background request mode
|
||||
disableSMPQueuesNtfs :: SMPClient -> NonEmpty (RecipientId, RcvPrivateAuthKey) -> IO (NonEmpty (Either SMPClientError ()))
|
||||
disableSMPQueuesNtfs = okSMPCommands NDEL
|
||||
disableSMPQueuesNtfs c = okSMPCommands NDEL c NRMBackground
|
||||
{-# INLINE disableSMPQueuesNtfs #-}
|
||||
|
||||
-- | Send SMP message.
|
||||
--
|
||||
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#send-message
|
||||
sendSMPMessage :: SMPClient -> Maybe SndPrivateAuthKey -> SenderId -> MsgFlags -> MsgBody -> ExceptT SMPClientError IO ()
|
||||
sendSMPMessage c spKey sId flags msg =
|
||||
sendSMPCommand c spKey sId (SEND flags msg) >>= \case
|
||||
sendSMPMessage :: SMPClient -> NetworkRequestMode -> Maybe SndPrivateAuthKey -> SenderId -> MsgFlags -> MsgBody -> ExceptT SMPClientError IO ()
|
||||
sendSMPMessage c nm spKey sId flags msg =
|
||||
sendSMPCommand c nm spKey sId (SEND flags msg) >>= \case
|
||||
OK -> pure ()
|
||||
r -> throwE $ unexpectedResponse r
|
||||
|
||||
proxySMPMessage :: SMPClient -> ProxiedRelay -> Maybe SndPrivateAuthKey -> SenderId -> MsgFlags -> MsgBody -> ExceptT SMPClientError IO (Either ProxyClientError ())
|
||||
proxySMPMessage c proxiedRelay spKey sId flags msg = proxyOKSMPCommand c proxiedRelay spKey sId (SEND flags msg)
|
||||
proxySMPMessage :: SMPClient -> NetworkRequestMode -> ProxiedRelay -> Maybe SndPrivateAuthKey -> SenderId -> MsgFlags -> MsgBody -> ExceptT SMPClientError IO (Either ProxyClientError ())
|
||||
proxySMPMessage c nm proxiedRelay spKey sId flags msg = proxyOKSMPCommand c nm proxiedRelay spKey sId (SEND flags msg)
|
||||
|
||||
-- | Acknowledge message delivery (server deletes the message).
|
||||
--
|
||||
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#acknowledge-message-delivery
|
||||
-- This command is always sent in background request mode
|
||||
ackSMPMessage :: SMPClient -> RcvPrivateAuthKey -> QueueId -> MsgId -> ExceptT SMPClientError IO ()
|
||||
ackSMPMessage c rpKey rId msgId =
|
||||
sendSMPCommand c (Just rpKey) rId (ACK msgId) >>= \case
|
||||
sendSMPCommand c NRMBackground (Just rpKey) rId (ACK msgId) >>= \case
|
||||
OK -> return ()
|
||||
cmd@MSG {} -> liftIO $ writeSMPMessage c rId cmd
|
||||
r -> throwE $ unexpectedResponse r
|
||||
@@ -981,28 +1023,28 @@ ackSMPMessage c rpKey rId msgId =
|
||||
-- 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 -> RcvPrivateAuthKey -> QueueId -> ExceptT SMPClientError IO ()
|
||||
suspendSMPQueue :: SMPClient -> NetworkRequestMode -> RcvPrivateAuthKey -> QueueId -> ExceptT SMPClientError IO ()
|
||||
suspendSMPQueue = okSMPCommand OFF
|
||||
{-# INLINE suspendSMPQueue #-}
|
||||
|
||||
-- | 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 -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO ()
|
||||
deleteSMPQueue :: SMPClient -> NetworkRequestMode -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO ()
|
||||
deleteSMPQueue = okSMPCommand DEL
|
||||
{-# INLINE deleteSMPQueue #-}
|
||||
|
||||
-- | Delete multiple SMP queues batching commands if supported.
|
||||
deleteSMPQueues :: SMPClient -> NonEmpty (RecipientId, RcvPrivateAuthKey) -> IO (NonEmpty (Either SMPClientError ()))
|
||||
deleteSMPQueues :: SMPClient -> NetworkRequestMode -> NonEmpty (RecipientId, RcvPrivateAuthKey) -> IO (NonEmpty (Either SMPClientError ()))
|
||||
deleteSMPQueues = okSMPCommands DEL
|
||||
{-# INLINE deleteSMPQueues #-}
|
||||
|
||||
-- send PRXY :: SMPServer -> Maybe BasicAuth -> Command Sender
|
||||
-- receives PKEY :: SessionId -> X.CertificateChain -> X.SignedExact X.PubKey -> BrokerMsg
|
||||
connectSMPProxiedRelay :: SMPClient -> SMPServer -> Maybe BasicAuth -> ExceptT SMPClientError IO ProxiedRelay
|
||||
connectSMPProxiedRelay c@ProtocolClient {client_ = PClient {tcpConnectTimeout, tcpTimeout}} relayServ@ProtocolServer {keyHash = C.KeyHash kh} proxyAuth
|
||||
connectSMPProxiedRelay :: SMPClient -> NetworkRequestMode -> SMPServer -> Maybe BasicAuth -> ExceptT SMPClientError IO ProxiedRelay
|
||||
connectSMPProxiedRelay c@ProtocolClient {client_ = PClient {tcpConnectTimeout, tcpTimeout}} nm relayServ@ProtocolServer {keyHash = C.KeyHash kh} proxyAuth
|
||||
| thVersion (thParams c) >= sendingProxySMPVersion =
|
||||
sendProtocolCommand_ c Nothing tOut Nothing NoEntity (Cmd SProxiedClient (PRXY relayServ proxyAuth)) >>= \case
|
||||
sendProtocolCommand_ c nm Nothing tOut Nothing NoEntity (Cmd SProxiedClient (PRXY relayServ proxyAuth)) >>= \case
|
||||
PKEY sId vr (CertChainPubKey chain key) ->
|
||||
case supportedClientSMPRelayVRange `compatibleVersion` vr of
|
||||
Nothing -> throwE $ transportErr TEVersion
|
||||
@@ -1010,7 +1052,7 @@ connectSMPProxiedRelay c@ProtocolClient {client_ = PClient {tcpConnectTimeout, t
|
||||
r -> throwE $ unexpectedResponse r
|
||||
| otherwise = throwE $ PCETransportError TEVersion
|
||||
where
|
||||
tOut = Just $ tcpConnectTimeout + tcpTimeout
|
||||
tOut = Just $ netTimeoutInt tcpConnectTimeout nm + netTimeoutInt tcpTimeout nm
|
||||
transportErr = PCEProtocolError . PROXY . BROKER . TRANSPORT
|
||||
validateRelay :: X.CertificateChain -> X.SignedExact X.PubKey -> Either String C.PublicKeyX25519
|
||||
validateRelay (X.CertificateChain cert) exact = do
|
||||
@@ -1076,9 +1118,9 @@ instance StrEncoding ProxyClientError where
|
||||
-- - other errors from the client running on proxy and connected to relay in PREProxiedRelayError
|
||||
|
||||
-- This function proxies Sender commands that return OK or ERR
|
||||
proxyOKSMPCommand :: SMPClient -> ProxiedRelay -> Maybe SndPrivateAuthKey -> SenderId -> Command 'Sender -> ExceptT SMPClientError IO (Either ProxyClientError ())
|
||||
proxyOKSMPCommand c proxiedRelay spKey sId command =
|
||||
proxySMPCommand c proxiedRelay spKey sId command >>= \case
|
||||
proxyOKSMPCommand :: SMPClient -> NetworkRequestMode -> ProxiedRelay -> Maybe SndPrivateAuthKey -> SenderId -> Command 'Sender -> ExceptT SMPClientError IO (Either ProxyClientError ())
|
||||
proxyOKSMPCommand c nm proxiedRelay spKey sId command =
|
||||
proxySMPCommand c nm proxiedRelay spKey sId command >>= \case
|
||||
Right OK -> pure $ Right ()
|
||||
Right r -> throwE $ unexpectedResponse r
|
||||
Left e -> pure $ Left e
|
||||
@@ -1087,6 +1129,7 @@ proxySMPCommand ::
|
||||
forall p.
|
||||
PartyI p =>
|
||||
SMPClient ->
|
||||
NetworkRequestMode ->
|
||||
-- proxy session from PKEY
|
||||
ProxiedRelay ->
|
||||
-- message to deliver
|
||||
@@ -1094,7 +1137,7 @@ proxySMPCommand ::
|
||||
SenderId ->
|
||||
Command p ->
|
||||
ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg)
|
||||
proxySMPCommand c@ProtocolClient {thParams = proxyThParams, client_ = PClient {clientCorrId = g, tcpTimeout}} (ProxiedRelay sessionId v _ serverKey) spKey sId command = do
|
||||
proxySMPCommand c@ProtocolClient {thParams = proxyThParams, client_ = PClient {clientCorrId = g, tcpTimeout}} nm (ProxiedRelay sessionId v _ serverKey) spKey sId command = do
|
||||
-- prepare params
|
||||
let serverThAuth = (\ta -> ta {peerServerPubKey = serverKey}) <$> thAuth proxyThParams
|
||||
serverThParams = smpTHParamsSetVersion v proxyThParams {sessionId, thAuth = serverThAuth}
|
||||
@@ -1112,8 +1155,8 @@ proxySMPCommand c@ProtocolClient {thParams = proxyThParams, client_ = PClient {c
|
||||
TBTransmissions s _ _ : _ -> pure s
|
||||
et <- liftEitherWith PCECryptoError $ EncTransmission <$> C.cbEncrypt cmdSecret nonce b paddedProxiedTLength
|
||||
-- proxy interaction errors are wrapped
|
||||
let tOut = Just $ 2 * tcpTimeout
|
||||
tryE (sendProtocolCommand_ c (Just nonce) tOut Nothing (EntityId sessionId) (Cmd SProxiedClient (PFWD v cmdPubKey et))) >>= \case
|
||||
let tOut = Just $ 2 * netTimeoutInt tcpTimeout nm
|
||||
tryE (sendProtocolCommand_ c nm (Just nonce) tOut Nothing (EntityId sessionId) (Cmd SProxiedClient (PFWD v cmdPubKey et))) >>= \case
|
||||
Right r -> case r of
|
||||
PRES (EncResponse er) -> do
|
||||
-- server interaction errors are thrown directly
|
||||
@@ -1137,6 +1180,7 @@ proxySMPCommand c@ProtocolClient {thParams = proxyThParams, client_ = PClient {c
|
||||
-- sends RFWD :: EncFwdTransmission -> Command Sender
|
||||
-- receives RRES :: EncFwdResponse -> BrokerMsg
|
||||
-- proxy should send PRES to the client with EncResponse
|
||||
-- Always uses background timeout mode
|
||||
forwardSMPTransmission :: SMPClient -> CorrId -> VersionSMP -> C.PublicKeyX25519 -> EncTransmission -> ExceptT SMPClientError IO EncResponse
|
||||
forwardSMPTransmission c@ProtocolClient {thParams, client_ = PClient {clientCorrId = g}} fwdCorrId fwdVersion fwdKey fwdTransmission = do
|
||||
-- prepare params
|
||||
@@ -1148,7 +1192,7 @@ forwardSMPTransmission c@ProtocolClient {thParams, client_ = PClient {clientCorr
|
||||
let fwdT = FwdTransmission {fwdCorrId, fwdVersion, fwdKey, fwdTransmission}
|
||||
eft = EncFwdTransmission $ C.cbEncryptNoPad sessSecret nonce (smpEncode fwdT)
|
||||
-- send
|
||||
sendProtocolCommand_ c (Just nonce) Nothing Nothing NoEntity (Cmd SProxyService (RFWD eft)) >>= \case
|
||||
sendProtocolCommand_ c NRMBackground (Just nonce) Nothing Nothing NoEntity (Cmd SProxyService (RFWD eft)) >>= \case
|
||||
RRES (EncFwdResponse efr) -> do
|
||||
-- unwrap
|
||||
r' <- liftEitherWith PCECryptoError $ C.cbDecryptNoPad sessSecret (C.reverseNonce nonce) efr
|
||||
@@ -1156,20 +1200,21 @@ forwardSMPTransmission c@ProtocolClient {thParams, client_ = PClient {clientCorr
|
||||
pure fwdResponse
|
||||
r -> throwE $ unexpectedResponse r
|
||||
|
||||
getSMPQueueInfo :: SMPClient -> C.APrivateAuthKey -> QueueId -> ExceptT SMPClientError IO QueueInfo
|
||||
getSMPQueueInfo c pKey qId =
|
||||
sendSMPCommand c (Just pKey) qId QUE >>= \case
|
||||
-- get queue information - always sent interactively
|
||||
getSMPQueueInfo :: SMPClient -> NetworkRequestMode -> C.APrivateAuthKey -> QueueId -> ExceptT SMPClientError IO QueueInfo
|
||||
getSMPQueueInfo c nm pKey qId =
|
||||
sendSMPCommand c nm (Just pKey) qId QUE >>= \case
|
||||
INFO info -> pure info
|
||||
r -> throwE $ unexpectedResponse r
|
||||
|
||||
okSMPCommand :: PartyI p => Command p -> SMPClient -> C.APrivateAuthKey -> QueueId -> ExceptT SMPClientError IO ()
|
||||
okSMPCommand cmd c pKey qId =
|
||||
sendSMPCommand c (Just pKey) qId cmd >>= \case
|
||||
okSMPCommand :: PartyI p => Command p -> SMPClient -> NetworkRequestMode -> C.APrivateAuthKey -> QueueId -> ExceptT SMPClientError IO ()
|
||||
okSMPCommand cmd c nm pKey qId =
|
||||
sendSMPCommand c nm (Just pKey) qId cmd >>= \case
|
||||
OK -> return ()
|
||||
r -> throwE $ unexpectedResponse r
|
||||
|
||||
okSMPCommands :: PartyI p => Command p -> SMPClient -> NonEmpty (QueueId, C.APrivateAuthKey) -> IO (NonEmpty (Either SMPClientError ()))
|
||||
okSMPCommands cmd c qs = L.map process <$> sendProtocolCommands c cs
|
||||
okSMPCommands :: PartyI p => Command p -> SMPClient -> NetworkRequestMode -> NonEmpty (QueueId, C.APrivateAuthKey) -> IO (NonEmpty (Either SMPClientError ()))
|
||||
okSMPCommands cmd c nm qs = L.map process <$> sendProtocolCommands c nm cs
|
||||
where
|
||||
aCmd = Cmd sParty cmd
|
||||
cs = L.map (\(qId, pKey) -> (qId, Just pKey, aCmd)) qs
|
||||
@@ -1179,17 +1224,17 @@ okSMPCommands cmd c qs = L.map process <$> sendProtocolCommands c cs
|
||||
Left e -> Left e
|
||||
|
||||
-- | Send SMP command
|
||||
sendSMPCommand :: PartyI p => SMPClient -> Maybe C.APrivateAuthKey -> QueueId -> Command p -> ExceptT SMPClientError IO BrokerMsg
|
||||
sendSMPCommand c pKey qId cmd = sendProtocolCommand c pKey qId (Cmd sParty cmd)
|
||||
sendSMPCommand :: PartyI p => SMPClient -> NetworkRequestMode -> Maybe C.APrivateAuthKey -> QueueId -> Command p -> ExceptT SMPClientError IO BrokerMsg
|
||||
sendSMPCommand c nm pKey qId cmd = sendProtocolCommand c nm pKey qId (Cmd sParty cmd)
|
||||
{-# INLINE sendSMPCommand #-}
|
||||
|
||||
type PCTransmission err msg = (Either TransportError SentRawTransmission, Request err msg)
|
||||
|
||||
-- | Send multiple commands with batching and collect responses
|
||||
sendProtocolCommands :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> NonEmpty (ClientCommand msg) -> IO (NonEmpty (Response err msg))
|
||||
sendProtocolCommands c@ProtocolClient {thParams} cs = do
|
||||
sendProtocolCommands :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> NetworkRequestMode -> NonEmpty (ClientCommand msg) -> IO (NonEmpty (Response err msg))
|
||||
sendProtocolCommands c@ProtocolClient {thParams} nm cs = do
|
||||
bs <- batchTransmissions' thParams <$> mapM (mkTransmission c) cs
|
||||
validate . concat =<< mapM (sendBatch c) bs
|
||||
validate . concat =<< mapM (sendBatch c nm) bs
|
||||
where
|
||||
validate :: [Response err msg] -> IO (NonEmpty (Response err msg))
|
||||
validate rs
|
||||
@@ -1203,13 +1248,13 @@ sendProtocolCommands c@ProtocolClient {thParams} cs = do
|
||||
where
|
||||
diff = L.length cs - length rs
|
||||
|
||||
streamProtocolCommands :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> NonEmpty (ClientCommand msg) -> ([Response err msg] -> IO ()) -> IO ()
|
||||
streamProtocolCommands c@ProtocolClient {thParams} cs cb = do
|
||||
streamProtocolCommands :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> NetworkRequestMode -> NonEmpty (ClientCommand msg) -> ([Response err msg] -> IO ()) -> IO ()
|
||||
streamProtocolCommands c@ProtocolClient {thParams} nm cs cb = do
|
||||
bs <- batchTransmissions' thParams <$> mapM (mkTransmission c) cs
|
||||
mapM_ (cb <=< sendBatch c) bs
|
||||
mapM_ (cb <=< sendBatch c nm) bs
|
||||
|
||||
sendBatch :: ProtocolClient v err msg -> TransportBatch (Request err msg) -> IO [Response err msg]
|
||||
sendBatch c@ProtocolClient {client_ = PClient {sndQ}} b = do
|
||||
sendBatch :: ProtocolClient v err msg -> NetworkRequestMode -> TransportBatch (Request err msg) -> IO [Response err msg]
|
||||
sendBatch c@ProtocolClient {client_ = PClient {sndQ}} nm b = do
|
||||
case b of
|
||||
TBError e Request {entityId} -> do
|
||||
putStrLn "send error: large message"
|
||||
@@ -1217,15 +1262,15 @@ sendBatch c@ProtocolClient {client_ = PClient {sndQ}} b = do
|
||||
TBTransmissions s n rs
|
||||
| n > 0 -> do
|
||||
nonBlockingWriteTBQueue sndQ (Nothing, s) -- do not expire batched responses
|
||||
mapConcurrently (getResponse c Nothing) rs
|
||||
mapConcurrently (getResponse c nm Nothing) rs
|
||||
| otherwise -> pure []
|
||||
TBTransmission s r -> do
|
||||
nonBlockingWriteTBQueue sndQ (Nothing, s)
|
||||
(: []) <$> getResponse c Nothing r
|
||||
(: []) <$> getResponse c nm Nothing r
|
||||
|
||||
-- | Send Protocol command
|
||||
sendProtocolCommand :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> Maybe C.APrivateAuthKey -> EntityId -> ProtoCommand msg -> ExceptT (ProtocolClientError err) IO msg
|
||||
sendProtocolCommand c = sendProtocolCommand_ c Nothing Nothing
|
||||
sendProtocolCommand :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> NetworkRequestMode -> Maybe C.APrivateAuthKey -> EntityId -> ProtoCommand msg -> ExceptT (ProtocolClientError err) IO msg
|
||||
sendProtocolCommand c nm = sendProtocolCommand_ c nm Nothing Nothing
|
||||
|
||||
-- Currently there is coupling - batch commands do not expire, and individually sent commands do.
|
||||
-- This is to reflect the fact that we send subscriptions only as batches, and also because we do not track a separate timeout for the whole batch, so it is not obvious when should we expire it.
|
||||
@@ -1233,8 +1278,8 @@ sendProtocolCommand c = sendProtocolCommand_ c Nothing Nothing
|
||||
-- But a better solution is to process delayed delete responses.
|
||||
--
|
||||
-- Please note: if nonce is passed it is also used as a correlation ID
|
||||
sendProtocolCommand_ :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> Maybe C.CbNonce -> Maybe Int -> Maybe C.APrivateAuthKey -> EntityId -> ProtoCommand msg -> ExceptT (ProtocolClientError err) IO msg
|
||||
sendProtocolCommand_ c@ProtocolClient {client_ = PClient {sndQ}, thParams = THandleParams {batch, blockSize, serviceAuth}} nonce_ tOut pKey entId cmd =
|
||||
sendProtocolCommand_ :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> NetworkRequestMode -> Maybe C.CbNonce -> Maybe Int -> Maybe C.APrivateAuthKey -> EntityId -> ProtoCommand msg -> ExceptT (ProtocolClientError err) IO msg
|
||||
sendProtocolCommand_ c@ProtocolClient {client_ = PClient {sndQ}, thParams = THandleParams {batch, blockSize, serviceAuth}} nm nonce_ tOut pKey entId cmd =
|
||||
ExceptT $ uncurry sendRecv =<< mkTransmission_ c nonce_ (entId, pKey, cmd)
|
||||
where
|
||||
-- two separate "atomically" needed to avoid blocking
|
||||
@@ -1245,7 +1290,7 @@ sendProtocolCommand_ c@ProtocolClient {client_ = PClient {sndQ}, thParams = THan
|
||||
| B.length s > blockSize - 2 -> pure . Left $ PCETransportError TELargeMsg
|
||||
| otherwise -> do
|
||||
nonBlockingWriteTBQueue sndQ (Just r, s)
|
||||
response <$> getResponse c tOut r
|
||||
response <$> getResponse c nm tOut r
|
||||
where
|
||||
s
|
||||
| batch = tEncodeBatch1 serviceAuth t
|
||||
@@ -1256,9 +1301,9 @@ nonBlockingWriteTBQueue q x = do
|
||||
sent <- atomically $ tryWriteTBQueue q x
|
||||
unless sent $ void $ forkIO $ atomically $ writeTBQueue q x
|
||||
|
||||
getResponse :: ProtocolClient v err msg -> Maybe Int -> Request err msg -> IO (Response err msg)
|
||||
getResponse ProtocolClient {client_ = PClient {tcpTimeout, timeoutErrorCount}} tOut Request {entityId, pending, responseVar} = do
|
||||
r <- fromMaybe tcpTimeout tOut `timeout` atomically (takeTMVar responseVar)
|
||||
getResponse :: ProtocolClient v err msg -> NetworkRequestMode -> Maybe Int -> Request err msg -> IO (Response err msg)
|
||||
getResponse ProtocolClient {client_ = PClient {tcpTimeout, timeoutErrorCount}} nm tOut Request {entityId, pending, responseVar} = do
|
||||
r <- fromMaybe (netTimeoutInt tcpTimeout nm) tOut `timeout` atomically (takeTMVar responseVar)
|
||||
response <- atomically $ do
|
||||
writeTVar pending False
|
||||
-- Try to read response again in case it arrived after timeout expired
|
||||
@@ -1345,6 +1390,8 @@ $(J.deriveJSON (enumJSON $ dropPrefix "SPF") ''SMPProxyFallback)
|
||||
|
||||
$(J.deriveJSON (enumJSON $ dropPrefix "SWP") ''SMPWebPortServers)
|
||||
|
||||
$(J.deriveJSON defaultJSON ''NetworkTimeout)
|
||||
|
||||
$(J.deriveJSON defaultJSON ''NetworkConfig)
|
||||
|
||||
$(J.deriveJSON (sumTypeJSON $ dropPrefix "Proxy") ''ProxyClientError)
|
||||
|
||||
@@ -203,7 +203,7 @@ getSMPServerClient'' ca@SMPClientAgent {agentCfg, smpClients, smpSessions, worke
|
||||
waitForSMPClient :: SMPClientVar -> ExceptT SMPClientError IO (OwnServer, SMPClient)
|
||||
waitForSMPClient v = do
|
||||
let ProtocolClientConfig {networkConfig = NetworkConfig {tcpConnectTimeout}} = smpCfg agentCfg
|
||||
smpClient_ <- liftIO $ tcpConnectTimeout `timeout` atomically (readTMVar $ sessionVar v)
|
||||
smpClient_ <- liftIO $ netTimeoutInt tcpConnectTimeout NRMBackground `timeout` atomically (readTMVar $ sessionVar v)
|
||||
case smpClient_ of
|
||||
Just (Right smpClient) -> pure smpClient
|
||||
Just (Left (e, ts_)) -> case ts_ of
|
||||
@@ -249,7 +249,7 @@ isOwnServer SMPClientAgent {agentCfg} ProtocolServer {host} =
|
||||
-- | Run an SMP client for SMPClientVar
|
||||
connectClient :: SMPClientAgent p -> SMPServer -> SMPClientVar -> IO (Either SMPClientError SMPClient)
|
||||
connectClient ca@SMPClientAgent {agentCfg, smpClients, smpSessions, msgQ, randomDrg, startedAt} srv v =
|
||||
getProtocolClient randomDrg (1, srv, Nothing) (smpCfg agentCfg) [] (Just msgQ) startedAt clientDisconnected
|
||||
getProtocolClient randomDrg NRMBackground (1, srv, Nothing) (smpCfg agentCfg) [] (Just msgQ) startedAt clientDisconnected
|
||||
where
|
||||
clientDisconnected :: SMPClient -> IO ()
|
||||
clientDisconnected smp = do
|
||||
@@ -313,7 +313,7 @@ reconnectClient ca@SMPClientAgent {active, agentCfg, smpSubWorkers, workerSeq} s
|
||||
withRetryInterval (reconnectInterval agentCfg) $ \_ loop -> do
|
||||
subs <- getPending TM.lookupIO readTVarIO
|
||||
unless (noPending subs) $ whenM (readTVarIO active) $ do
|
||||
void $ tcpConnectTimeout `timeout` runExceptT (reconnectSMPClient ca srv subs)
|
||||
void $ netTimeoutInt tcpConnectTimeout NRMBackground `timeout` runExceptT (reconnectSMPClient ca srv subs)
|
||||
loop
|
||||
ProtocolClientConfig {networkConfig = NetworkConfig {tcpConnectTimeout}} = smpCfg agentCfg
|
||||
noPending (sSub, qSubs) = isNothing sSub && maybe True M.null qSubs
|
||||
|
||||
@@ -28,39 +28,39 @@ defaultNTFClientConfig =
|
||||
{defaultTransport = ("443", transport @TLS)}
|
||||
{-# INLINE defaultNTFClientConfig #-}
|
||||
|
||||
ntfRegisterToken :: NtfClient -> C.APrivateAuthKey -> NewNtfEntity 'Token -> ExceptT NtfClientError IO (NtfTokenId, C.PublicKeyX25519)
|
||||
ntfRegisterToken c pKey newTkn =
|
||||
sendNtfCommand c (Just pKey) NoEntity (TNEW newTkn) >>= \case
|
||||
ntfRegisterToken :: NtfClient -> NetworkRequestMode -> C.APrivateAuthKey -> NewNtfEntity 'Token -> ExceptT NtfClientError IO (NtfTokenId, C.PublicKeyX25519)
|
||||
ntfRegisterToken c nm pKey newTkn =
|
||||
sendNtfCommand c nm (Just pKey) NoEntity (TNEW newTkn) >>= \case
|
||||
NRTknId tknId dhKey -> pure (tknId, dhKey)
|
||||
r -> throwE $ unexpectedResponse r
|
||||
|
||||
ntfVerifyToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> NtfRegCode -> ExceptT NtfClientError IO ()
|
||||
ntfVerifyToken c pKey tknId code = okNtfCommand (TVFY code) c pKey tknId
|
||||
ntfVerifyToken :: NtfClient -> NetworkRequestMode -> C.APrivateAuthKey -> NtfTokenId -> NtfRegCode -> ExceptT NtfClientError IO ()
|
||||
ntfVerifyToken c nm pKey tknId code = okNtfCommand (TVFY code) c nm pKey tknId
|
||||
|
||||
ntfCheckToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> ExceptT NtfClientError IO NtfTknStatus
|
||||
ntfCheckToken c pKey tknId =
|
||||
sendNtfCommand c (Just pKey) tknId TCHK >>= \case
|
||||
ntfCheckToken :: NtfClient -> NetworkRequestMode -> C.APrivateAuthKey -> NtfTokenId -> ExceptT NtfClientError IO NtfTknStatus
|
||||
ntfCheckToken c nm pKey tknId =
|
||||
sendNtfCommand c nm (Just pKey) tknId TCHK >>= \case
|
||||
NRTkn stat -> pure stat
|
||||
r -> throwE $ unexpectedResponse r
|
||||
|
||||
ntfReplaceToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> DeviceToken -> ExceptT NtfClientError IO ()
|
||||
ntfReplaceToken c pKey tknId token = okNtfCommand (TRPL token) c pKey tknId
|
||||
ntfReplaceToken :: NtfClient -> NetworkRequestMode -> C.APrivateAuthKey -> NtfTokenId -> DeviceToken -> ExceptT NtfClientError IO ()
|
||||
ntfReplaceToken c nm pKey tknId token = okNtfCommand (TRPL token) c nm pKey tknId
|
||||
|
||||
ntfDeleteToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> ExceptT NtfClientError IO ()
|
||||
ntfDeleteToken :: NtfClient -> NetworkRequestMode -> C.APrivateAuthKey -> NtfTokenId -> ExceptT NtfClientError IO ()
|
||||
ntfDeleteToken = okNtfCommand TDEL
|
||||
|
||||
-- set to 0 to disable
|
||||
ntfSetCronInterval :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> Word16 -> ExceptT NtfClientError IO ()
|
||||
ntfSetCronInterval c pKey tknId int = okNtfCommand (TCRN int) c pKey tknId
|
||||
ntfSetCronInterval :: NtfClient -> NetworkRequestMode -> C.APrivateAuthKey -> NtfTokenId -> Word16 -> ExceptT NtfClientError IO ()
|
||||
ntfSetCronInterval c nm pKey tknId int = okNtfCommand (TCRN int) c nm pKey tknId
|
||||
|
||||
ntfCreateSubscription :: NtfClient -> C.APrivateAuthKey -> NewNtfEntity 'Subscription -> ExceptT NtfClientError IO NtfSubscriptionId
|
||||
ntfCreateSubscription c pKey newSub =
|
||||
sendNtfCommand c (Just pKey) NoEntity (SNEW newSub) >>= \case
|
||||
sendNtfCommand c NRMBackground (Just pKey) NoEntity (SNEW newSub) >>= \case
|
||||
NRSubId subId -> pure subId
|
||||
r -> throwE $ unexpectedResponse r
|
||||
|
||||
ntfCreateSubscriptions :: NtfClient -> C.APrivateAuthKey -> NonEmpty (NewNtfEntity 'Subscription) -> IO (NonEmpty (Either NtfClientError NtfSubscriptionId))
|
||||
ntfCreateSubscriptions c pKey newSubs = L.map process <$> sendProtocolCommands c cs
|
||||
ntfCreateSubscriptions c pKey newSubs = L.map process <$> sendProtocolCommands c NRMBackground cs
|
||||
where
|
||||
cs = L.map (\newSub -> (NoEntity, Just pKey, NtfCmd SSubscription $ SNEW newSub)) newSubs
|
||||
process (Response _ r) = case r of
|
||||
@@ -70,12 +70,12 @@ ntfCreateSubscriptions c pKey newSubs = L.map process <$> sendProtocolCommands c
|
||||
|
||||
ntfCheckSubscription :: NtfClient -> C.APrivateAuthKey -> NtfSubscriptionId -> ExceptT NtfClientError IO NtfSubStatus
|
||||
ntfCheckSubscription c pKey subId =
|
||||
sendNtfCommand c (Just pKey) subId SCHK >>= \case
|
||||
sendNtfCommand c NRMBackground (Just pKey) subId SCHK >>= \case
|
||||
NRSub stat -> pure stat
|
||||
r -> throwE $ unexpectedResponse r
|
||||
|
||||
ntfCheckSubscriptions :: NtfClient -> C.APrivateAuthKey -> NonEmpty NtfSubscriptionId -> IO (NonEmpty (Either NtfClientError NtfSubStatus))
|
||||
ntfCheckSubscriptions c pKey subIds = L.map process <$> sendProtocolCommands c cs
|
||||
ntfCheckSubscriptions c pKey subIds = L.map process <$> sendProtocolCommands c NRMBackground cs
|
||||
where
|
||||
cs = L.map (\subId -> (subId, Just pKey, NtfCmd SSubscription SCHK)) subIds
|
||||
process (Response _ r) = case r of
|
||||
@@ -84,14 +84,14 @@ ntfCheckSubscriptions c pKey subIds = L.map process <$> sendProtocolCommands c c
|
||||
Left e -> Left e
|
||||
|
||||
ntfDeleteSubscription :: NtfClient -> C.APrivateAuthKey -> NtfSubscriptionId -> ExceptT NtfClientError IO ()
|
||||
ntfDeleteSubscription = okNtfCommand SDEL
|
||||
ntfDeleteSubscription c = okNtfCommand SDEL c NRMBackground
|
||||
|
||||
-- | Send notification server command
|
||||
sendNtfCommand :: NtfEntityI e => NtfClient -> Maybe C.APrivateAuthKey -> NtfEntityId -> NtfCommand e -> ExceptT NtfClientError IO NtfResponse
|
||||
sendNtfCommand c pKey entId cmd = sendProtocolCommand c pKey entId (NtfCmd sNtfEntity cmd)
|
||||
sendNtfCommand :: NtfEntityI e => NtfClient -> NetworkRequestMode -> Maybe C.APrivateAuthKey -> NtfEntityId -> NtfCommand e -> ExceptT NtfClientError IO NtfResponse
|
||||
sendNtfCommand c nm pKey entId cmd = sendProtocolCommand c nm pKey entId (NtfCmd sNtfEntity cmd)
|
||||
|
||||
okNtfCommand :: NtfEntityI e => NtfCommand e -> NtfClient -> C.APrivateAuthKey -> NtfEntityId -> ExceptT NtfClientError IO ()
|
||||
okNtfCommand cmd c pKey entId =
|
||||
sendNtfCommand c (Just pKey) entId cmd >>= \case
|
||||
okNtfCommand :: NtfEntityI e => NtfCommand e -> NtfClient -> NetworkRequestMode -> C.APrivateAuthKey -> NtfEntityId -> ExceptT NtfClientError IO ()
|
||||
okNtfCommand cmd c nm pKey entId =
|
||||
sendNtfCommand c nm (Just pKey) entId cmd >>= \case
|
||||
NROk -> return ()
|
||||
r -> throwE $ unexpectedResponse r
|
||||
|
||||
@@ -81,7 +81,7 @@ import Data.Word (Word16)
|
||||
import GHC.Stack (withFrozenCallStack)
|
||||
import SMPAgentClient
|
||||
import SMPClient
|
||||
import Simplex.Messaging.Agent hiding (createConnection, joinConnection, subscribeConnection, sendMessage)
|
||||
import Simplex.Messaging.Agent hiding (acceptContact, createConnection, deleteConnection, deleteConnections, getConnShortLink, joinConnection, sendMessage, setConnShortLink, subscribeConnection, suspendConnection)
|
||||
import qualified Simplex.Messaging.Agent as A
|
||||
import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), ServerQueueInfo (..), UserNetworkInfo (..), UserNetworkType (..), waitForUserNetwork)
|
||||
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), Env (..), InitialAgentServers (..), createAgentStore)
|
||||
@@ -91,7 +91,7 @@ import Simplex.Messaging.Agent.Store.Common (DBStore (..), withTransaction)
|
||||
import Simplex.Messaging.Agent.Store.Interface
|
||||
import qualified Simplex.Messaging.Agent.Store.DB as DB
|
||||
import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..), MigrationError (..))
|
||||
import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientConfig (..), TransportSessionMode (..), defaultClientConfig)
|
||||
import Simplex.Messaging.Client (pattern NRMInteractive, NetworkConfig (..), ProtocolClientConfig (..), TransportSessionMode (..), defaultClientConfig)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Crypto.Ratchet (InitialKeys (..), PQEncryption (..), PQSupport (..), pattern IKPQOff, pattern IKPQOn, pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn)
|
||||
import qualified Simplex.Messaging.Crypto.Ratchet as CR
|
||||
@@ -276,15 +276,18 @@ inAnyOrder g rs = withFrozenCallStack $ do
|
||||
|
||||
createConnection :: ConnectionModeI c => AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe CRClientData -> SubscriptionMode -> AE (ConnId, ConnectionRequestUri c)
|
||||
createConnection c userId enableNtfs cMode clientData subMode = do
|
||||
(connId, (CCLink cReq _, Nothing)) <- A.createConnection c userId enableNtfs cMode Nothing clientData IKPQOn subMode
|
||||
(connId, (CCLink cReq _, Nothing)) <- A.createConnection c NRMInteractive userId enableNtfs cMode Nothing clientData IKPQOn subMode
|
||||
pure (connId, cReq)
|
||||
|
||||
joinConnection :: AgentClient -> UserId -> Bool -> ConnectionRequestUri c -> ConnInfo -> SubscriptionMode -> AE (ConnId, SndQueueSecured)
|
||||
joinConnection c userId enableNtfs cReq connInfo subMode = do
|
||||
connId <- A.prepareConnectionToJoin c userId enableNtfs cReq PQSupportOn
|
||||
(sndSecure, Nothing) <- A.joinConnection c userId connId enableNtfs cReq connInfo PQSupportOn subMode
|
||||
(sndSecure, Nothing) <- A.joinConnection c NRMInteractive userId connId enableNtfs cReq connInfo PQSupportOn subMode
|
||||
pure (connId, sndSecure)
|
||||
|
||||
acceptContact :: AgentClient -> UserId -> ConnId -> Bool -> ConfirmationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AE (SndQueueSecured, Maybe ClientServiceId)
|
||||
acceptContact c = A.acceptContact c NRMInteractive
|
||||
|
||||
subscribeConnection :: AgentClient -> ConnId -> AE ()
|
||||
subscribeConnection c = void . A.subscribeConnection c
|
||||
|
||||
@@ -294,6 +297,21 @@ sendMessage c connId msgFlags msgBody = do
|
||||
liftIO $ pqEnc `shouldBe` PQEncOn
|
||||
pure msgId
|
||||
|
||||
deleteConnection :: AgentClient -> ConnId -> AE ()
|
||||
deleteConnection c = A.deleteConnection c NRMInteractive
|
||||
|
||||
deleteConnections :: AgentClient -> [ConnId] -> AE (M.Map ConnId (Either AgentErrorType ()))
|
||||
deleteConnections c = A.deleteConnections c NRMInteractive
|
||||
|
||||
getConnShortLink :: AgentClient -> UserId -> ConnShortLink c -> AE (ConnectionRequestUri c, ConnLinkData c)
|
||||
getConnShortLink c = A.getConnShortLink c NRMInteractive
|
||||
|
||||
setConnShortLink :: AgentClient -> ConnId -> SConnectionMode c -> UserLinkData -> Maybe CRClientData -> AE (ConnShortLink c)
|
||||
setConnShortLink c = A.setConnShortLink c NRMInteractive
|
||||
|
||||
suspendConnection :: AgentClient -> ConnId -> AE ()
|
||||
suspendConnection c = A.suspendConnection c NRMInteractive
|
||||
|
||||
functionalAPITests :: (ASrvTransport, AStoreType) -> Spec
|
||||
functionalAPITests ps = do
|
||||
describe "Establishing duplex connection" $ do
|
||||
@@ -680,9 +698,9 @@ runAgentClientTest pqSupport sqSecured viaProxy alice bob baseId =
|
||||
runAgentClientTestPQ :: HasCallStack => SndQueueSecured -> Bool -> (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()
|
||||
runAgentClientTestPQ sqSecured viaProxy (alice, aPQ) (bob, bPQ) baseId =
|
||||
runRight_ $ do
|
||||
(bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice 1 True SCMInvitation Nothing Nothing aPQ SMSubscribe
|
||||
(bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive 1 True SCMInvitation Nothing Nothing aPQ SMSubscribe
|
||||
aliceId <- A.prepareConnectionToJoin bob 1 True qInfo bPQ
|
||||
(sqSecured', Nothing) <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" bPQ SMSubscribe
|
||||
(sqSecured', Nothing) <- A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" bPQ SMSubscribe
|
||||
liftIO $ sqSecured' `shouldBe` sqSecured
|
||||
("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
|
||||
liftIO $ pqSup' `shouldBe` CR.connPQEncryption aPQ
|
||||
@@ -882,9 +900,9 @@ runAgentClientContactTest pqSupport sqSecured viaProxy alice bob baseId =
|
||||
runAgentClientContactTestPQ :: HasCallStack => SndQueueSecured -> Bool -> PQSupport -> (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()
|
||||
runAgentClientContactTestPQ sqSecured viaProxy reqPQSupport (alice, aPQ) (bob, bPQ) baseId =
|
||||
runRight_ $ do
|
||||
(_, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice 1 True SCMContact Nothing Nothing aPQ SMSubscribe
|
||||
(_, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive 1 True SCMContact Nothing Nothing aPQ SMSubscribe
|
||||
aliceId <- A.prepareConnectionToJoin bob 1 True qInfo bPQ
|
||||
(sqSecuredJoin, Nothing) <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" bPQ SMSubscribe
|
||||
(sqSecuredJoin, Nothing) <- A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" bPQ SMSubscribe
|
||||
liftIO $ sqSecuredJoin `shouldBe` False -- joining via contact address connection
|
||||
("", _, A.REQ invId pqSup' _ "bob's connInfo") <- get alice
|
||||
liftIO $ pqSup' `shouldBe` reqPQSupport
|
||||
@@ -926,7 +944,7 @@ runAgentClientContactTestPQ sqSecured viaProxy reqPQSupport (alice, aPQ) (bob, b
|
||||
|
||||
runAgentClientContactTestPQ3 :: HasCallStack => Bool -> (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()
|
||||
runAgentClientContactTestPQ3 viaProxy (alice, aPQ) (bob, bPQ) (tom, tPQ) baseId = runRight_ $ do
|
||||
(_, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice 1 True SCMContact Nothing Nothing aPQ SMSubscribe
|
||||
(_, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive 1 True SCMContact Nothing Nothing aPQ SMSubscribe
|
||||
(bAliceId, bobId, abPQEnc) <- connectViaContact bob bPQ qInfo
|
||||
sentMessages abPQEnc alice bobId bob bAliceId
|
||||
(tAliceId, tomId, atPQEnc) <- connectViaContact tom tPQ qInfo
|
||||
@@ -935,7 +953,7 @@ runAgentClientContactTestPQ3 viaProxy (alice, aPQ) (bob, bPQ) (tom, tPQ) baseId
|
||||
msgId = subtract baseId . fst
|
||||
connectViaContact b pq qInfo = do
|
||||
aId <- A.prepareConnectionToJoin b 1 True qInfo pq
|
||||
(sqSecuredJoin, Nothing) <- A.joinConnection b 1 aId True qInfo "bob's connInfo" pq SMSubscribe
|
||||
(sqSecuredJoin, Nothing) <- A.joinConnection b NRMInteractive 1 aId True qInfo "bob's connInfo" pq SMSubscribe
|
||||
liftIO $ sqSecuredJoin `shouldBe` False -- joining via contact address connection
|
||||
("", _, A.REQ invId pqSup' _ "bob's connInfo") <- get alice
|
||||
liftIO $ pqSup' `shouldBe` PQSupportOn
|
||||
@@ -979,9 +997,9 @@ noMessages_ ingoreQCONT c err = tryGet `shouldReturn` ()
|
||||
testRejectContactRequest :: HasCallStack => IO ()
|
||||
testRejectContactRequest =
|
||||
withAgentClients2 $ \alice bob -> runRight_ $ do
|
||||
(_addrConnId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice 1 True SCMContact Nothing Nothing IKPQOn SMSubscribe
|
||||
(_addrConnId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive 1 True SCMContact Nothing Nothing IKPQOn SMSubscribe
|
||||
aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
|
||||
(sqSecured, Nothing) <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
|
||||
(sqSecured, Nothing) <- A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
|
||||
liftIO $ sqSecured `shouldBe` False -- joining via contact address connection
|
||||
("", _, A.REQ invId PQSupportOn _ "bob's connInfo") <- get alice
|
||||
rejectContact alice invId
|
||||
@@ -994,7 +1012,7 @@ testUpdateConnectionUserId =
|
||||
newUserId <- createUser alice [noAuthSrvCfg testSMPServer] [noAuthSrvCfg testXFTPServer]
|
||||
_ <- changeConnectionUser alice 1 connId newUserId
|
||||
aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
|
||||
(sqSecured', Nothing) <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
|
||||
(sqSecured', Nothing) <- A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
|
||||
liftIO $ sqSecured' `shouldBe` True
|
||||
("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
|
||||
liftIO $ pqSup' `shouldBe` PQSupportOn
|
||||
@@ -1154,13 +1172,13 @@ testInvitationErrors ps restart = do
|
||||
("", "", DOWN _ [_]) <- nGet a
|
||||
aId <- runRight $ A.prepareConnectionToJoin b 1 True cReq PQSupportOn
|
||||
-- fails to secure the queue on testPort
|
||||
BROKER srv NETWORK <- runLeft $ A.joinConnection b 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe
|
||||
BROKER srv NETWORK <- runLeft $ A.joinConnection b NRMInteractive 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe
|
||||
(testPort `isSuffixOf` srv) `shouldBe` True
|
||||
withServer1 ps $ do
|
||||
("", "", UP _ [_]) <- nGet a
|
||||
let loopSecure = do
|
||||
-- secures the queue on testPort, but fails to create reply queue on testPort2
|
||||
BROKER srv2 NETWORK <- runLeft $ A.joinConnection b 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe
|
||||
BROKER srv2 NETWORK <- runLeft $ A.joinConnection b NRMInteractive 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe
|
||||
unless (testPort2 `isSuffixOf` srv2) $ putStrLn "retrying secure" >> threadDelay 200000 >> loopSecure
|
||||
loopSecure
|
||||
("", "", DOWN _ [_]) <- nGet a
|
||||
@@ -1168,7 +1186,7 @@ testInvitationErrors ps restart = do
|
||||
threadDelay 200000
|
||||
let loopCreate = do
|
||||
-- creates the reply queue on testPort2, but fails to send it to testPort
|
||||
BROKER srv' NETWORK <- runLeft $ A.joinConnection b 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe
|
||||
BROKER srv' NETWORK <- runLeft $ A.joinConnection b NRMInteractive 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe
|
||||
unless (testPort `isSuffixOf` srv') $ putStrLn "retrying create" >> threadDelay 200000 >> loopCreate
|
||||
loopCreate
|
||||
restartAgentB restart b [aId]
|
||||
@@ -1177,7 +1195,7 @@ testInvitationErrors ps restart = do
|
||||
("", "", UP _ [_]) <- nGet a
|
||||
threadDelay 200000
|
||||
let loopConfirm n =
|
||||
runExceptT (A.joinConnection b' 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe) >>= \case
|
||||
runExceptT (A.joinConnection b' NRMInteractive 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe) >>= \case
|
||||
Right (True, Nothing) -> pure n
|
||||
Right r -> error $ "unexpected result " <> show r
|
||||
Left _ -> putStrLn "retrying confirm" >> threadDelay 200000 >> loopConfirm (n + 1)
|
||||
@@ -1224,12 +1242,12 @@ testContactErrors ps restart = do
|
||||
("", "", DOWN _ [_]) <- nGet a
|
||||
aId <- runRight $ A.prepareConnectionToJoin b 1 True cReq PQSupportOn
|
||||
-- fails to create queue on testPort2
|
||||
BROKER srv2 NETWORK <- runLeft $ A.joinConnection b 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe
|
||||
BROKER srv2 NETWORK <- runLeft $ A.joinConnection b NRMInteractive 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe
|
||||
(testPort2 `isSuffixOf` srv2) `shouldBe` True
|
||||
b' <- restartAgentB restart b [aId]
|
||||
let loopCreate2 = do
|
||||
-- creates the reply queue on testPort2, but fails to send invitation to testPort
|
||||
BROKER srv' NETWORK <- runLeft $ A.joinConnection b' 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe
|
||||
BROKER srv' NETWORK <- runLeft $ A.joinConnection b' NRMInteractive 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe
|
||||
unless (testPort `isSuffixOf` srv') $ putStrLn "retrying create 2" >> threadDelay 200000 >> loopCreate2
|
||||
b'' <- withServer2 ps $ do
|
||||
loopCreate2
|
||||
@@ -1239,7 +1257,7 @@ testContactErrors ps restart = do
|
||||
("", "", UP _ [_]) <- nGet a
|
||||
let loopSend = do
|
||||
-- sends the invitation to testPort
|
||||
runExceptT (A.joinConnection b'' 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe) >>= \case
|
||||
runExceptT (A.joinConnection b'' NRMInteractive 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe) >>= \case
|
||||
Right (False, Nothing) -> pure ()
|
||||
Right r -> error $ "unexpected result " <> show r
|
||||
Left _ -> putStrLn "retrying send" >> threadDelay 200000 >> loopSend
|
||||
@@ -1305,7 +1323,7 @@ testInviationShortLink :: HasCallStack => Bool -> AgentClient -> AgentClient ->
|
||||
testInviationShortLink viaProxy a b =
|
||||
withAgent 3 agentCfg initAgentServers testDB3 $ \c -> do
|
||||
let userData = UserLinkData "some user data"
|
||||
(bId, (CCLink connReq (Just shortLink), Nothing)) <- runRight $ A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMSubscribe
|
||||
(bId, (CCLink connReq (Just shortLink), Nothing)) <- runRight $ A.createConnection a NRMInteractive 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMSubscribe
|
||||
(connReq', connData') <- runRight $ getConnShortLink b 1 shortLink
|
||||
strDecode (strEncode shortLink) `shouldBe` Right shortLink
|
||||
connReq' `shouldBe` connReq
|
||||
@@ -1327,7 +1345,7 @@ testInviationShortLink viaProxy a b =
|
||||
testJoinConn_ :: Bool -> Bool -> AgentClient -> ConnId -> AgentClient -> ConnectionRequestUri c -> ExceptT AgentErrorType IO ()
|
||||
testJoinConn_ viaProxy sndSecure a bId b connReq = do
|
||||
aId <- A.prepareConnectionToJoin b 1 True connReq PQSupportOn
|
||||
(sndSecure', Nothing) <- A.joinConnection b 1 aId True connReq "bob's connInfo" PQSupportOn SMSubscribe
|
||||
(sndSecure', Nothing) <- A.joinConnection b NRMInteractive 1 aId True connReq "bob's connInfo" PQSupportOn SMSubscribe
|
||||
liftIO $ sndSecure' `shouldBe` sndSecure
|
||||
("", _, CONF confId _ "bob's connInfo") <- get a
|
||||
allowConnection a bId confId "alice's connInfo"
|
||||
@@ -1340,13 +1358,13 @@ testInviationShortLinkPrev :: HasCallStack => Bool -> Bool -> AgentClient -> Age
|
||||
testInviationShortLinkPrev viaProxy sndSecure a b = runRight_ $ do
|
||||
let userData = UserLinkData "some user data"
|
||||
-- can't create short link with previous version
|
||||
(bId, (CCLink connReq Nothing, Nothing)) <- A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKPQOn SMSubscribe
|
||||
(bId, (CCLink connReq Nothing, Nothing)) <- A.createConnection a NRMInteractive 1 True SCMInvitation (Just userData) Nothing CR.IKPQOn SMSubscribe
|
||||
testJoinConn_ viaProxy sndSecure a bId b connReq
|
||||
|
||||
testInviationShortLinkAsync :: HasCallStack => Bool -> AgentClient -> AgentClient -> IO ()
|
||||
testInviationShortLinkAsync viaProxy a b = do
|
||||
let userData = UserLinkData "some user data"
|
||||
(bId, (CCLink connReq (Just shortLink), Nothing)) <- runRight $ A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMSubscribe
|
||||
(bId, (CCLink connReq (Just shortLink), Nothing)) <- runRight $ A.createConnection a NRMInteractive 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMSubscribe
|
||||
(connReq', connData') <- runRight $ getConnShortLink b 1 shortLink
|
||||
strDecode (strEncode shortLink) `shouldBe` Right shortLink
|
||||
connReq' `shouldBe` connReq
|
||||
@@ -1365,7 +1383,7 @@ testContactShortLink :: HasCallStack => Bool -> AgentClient -> AgentClient -> IO
|
||||
testContactShortLink viaProxy a b =
|
||||
withAgent 3 agentCfg initAgentServers testDB3 $ \c -> do
|
||||
let userData = UserLinkData "some user data"
|
||||
(contactId, (CCLink connReq0 (Just shortLink), Nothing)) <- runRight $ A.createConnection a 1 True SCMContact (Just userData) Nothing CR.IKPQOn SMSubscribe
|
||||
(contactId, (CCLink connReq0 (Just shortLink), Nothing)) <- runRight $ A.createConnection a NRMInteractive 1 True SCMContact (Just userData) Nothing CR.IKPQOn SMSubscribe
|
||||
Right connReq <- pure $ smpDecode (smpEncode connReq0)
|
||||
(connReq', connData') <- runRight $ getConnShortLink b 1 shortLink
|
||||
strDecode (strEncode shortLink) `shouldBe` Right shortLink
|
||||
@@ -1403,14 +1421,14 @@ testContactShortLink viaProxy a b =
|
||||
shortLink2 <- runRight $ setConnShortLink a contactId SCMContact updatedData Nothing
|
||||
shortLink2 `shouldBe` shortLink
|
||||
-- delete short link
|
||||
runRight_ $ deleteConnShortLink a contactId SCMContact
|
||||
runRight_ $ deleteConnShortLink a NRMInteractive contactId SCMContact
|
||||
Left (SMP _ AUTH) <- runExceptT $ getConnShortLink c 1 shortLink
|
||||
pure ()
|
||||
|
||||
testAddContactShortLink :: HasCallStack => Bool -> AgentClient -> AgentClient -> IO ()
|
||||
testAddContactShortLink viaProxy a b =
|
||||
withAgent 3 agentCfg initAgentServers testDB3 $ \c -> do
|
||||
(contactId, (CCLink connReq0 Nothing, Nothing)) <- runRight $ A.createConnection a 1 True SCMContact Nothing Nothing CR.IKPQOn SMSubscribe
|
||||
(contactId, (CCLink connReq0 Nothing, Nothing)) <- runRight $ A.createConnection a NRMInteractive 1 True SCMContact Nothing Nothing CR.IKPQOn SMSubscribe
|
||||
Right connReq <- pure $ smpDecode (smpEncode connReq0) --
|
||||
let userData = UserLinkData "some user data"
|
||||
shortLink <- runRight $ setConnShortLink a contactId SCMContact userData Nothing
|
||||
@@ -1451,7 +1469,7 @@ testInviationShortLinkRestart :: HasCallStack => (ASrvTransport, AStoreType) ->
|
||||
testInviationShortLinkRestart ps = withAgentClients2 $ \a b -> do
|
||||
let userData = UserLinkData "some user data"
|
||||
(bId, (CCLink connReq (Just shortLink), Nothing)) <- withSmpServer ps $
|
||||
runRight $ A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMOnlyCreate
|
||||
runRight $ A.createConnection a NRMInteractive 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMOnlyCreate
|
||||
withSmpServer ps $ do
|
||||
runRight_ $ subscribeConnection a bId
|
||||
(connReq', connData') <- runRight $ getConnShortLink b 1 shortLink
|
||||
@@ -1463,7 +1481,7 @@ testContactShortLinkRestart :: HasCallStack => (ASrvTransport, AStoreType) -> IO
|
||||
testContactShortLinkRestart ps = withAgentClients2 $ \a b -> do
|
||||
let userData = UserLinkData "some user data"
|
||||
(contactId, (CCLink connReq0 (Just shortLink), Nothing)) <- withSmpServer ps $
|
||||
runRight $ A.createConnection a 1 True SCMContact (Just userData) Nothing CR.IKPQOn SMOnlyCreate
|
||||
runRight $ A.createConnection a NRMInteractive 1 True SCMContact (Just userData) Nothing CR.IKPQOn SMOnlyCreate
|
||||
Right connReq <- pure $ smpDecode (smpEncode connReq0)
|
||||
let updatedData = UserLinkData "updated user data"
|
||||
withSmpServer ps $ do
|
||||
@@ -1483,7 +1501,7 @@ testAddContactShortLinkRestart :: HasCallStack => (ASrvTransport, AStoreType) ->
|
||||
testAddContactShortLinkRestart ps = withAgentClients2 $ \a b -> do
|
||||
let userData = UserLinkData "some user data"
|
||||
((contactId, (CCLink connReq0 Nothing, Nothing)), shortLink) <- withSmpServer ps $ runRight $ do
|
||||
r@(contactId, _) <- A.createConnection a 1 True SCMContact Nothing Nothing CR.IKPQOn SMOnlyCreate
|
||||
r@(contactId, _) <- A.createConnection a NRMInteractive 1 True SCMContact Nothing Nothing CR.IKPQOn SMOnlyCreate
|
||||
(r,) <$> setConnShortLink a contactId SCMContact userData Nothing
|
||||
Right connReq <- pure $ smpDecode (smpEncode connReq0)
|
||||
let updatedData = UserLinkData "updated user data"
|
||||
@@ -1503,7 +1521,7 @@ testAddContactShortLinkRestart ps = withAgentClients2 $ \a b -> do
|
||||
testOldContactQueueShortLink :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
|
||||
testOldContactQueueShortLink ps@(_, msType) = withAgentClients2 $ \a b -> do
|
||||
(contactId, (CCLink connReq Nothing, Nothing)) <- withSmpServer ps $ runRight $
|
||||
A.createConnection a 1 True SCMContact Nothing Nothing CR.IKPQOn SMOnlyCreate
|
||||
A.createConnection a NRMInteractive 1 True SCMContact Nothing Nothing CR.IKPQOn SMOnlyCreate
|
||||
-- make it an "old" queue
|
||||
let updateStoreLog f = replaceSubstringInFile f " queue_mode=C" ""
|
||||
() <- case testServerStoreConfig msType of
|
||||
@@ -2234,9 +2252,9 @@ makeConnectionForUsers = makeConnectionForUsers_ PQSupportOn True
|
||||
|
||||
makeConnectionForUsers_ :: HasCallStack => PQSupport -> SndQueueSecured -> AgentClient -> UserId -> AgentClient -> UserId -> ExceptT AgentErrorType IO (ConnId, ConnId)
|
||||
makeConnectionForUsers_ pqSupport sqSecured alice aliceUserId bob bobUserId = do
|
||||
(bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice aliceUserId True SCMInvitation Nothing Nothing (IKLinkPQ pqSupport) SMSubscribe
|
||||
(bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive aliceUserId True SCMInvitation Nothing Nothing (IKLinkPQ pqSupport) SMSubscribe
|
||||
aliceId <- A.prepareConnectionToJoin bob bobUserId True qInfo pqSupport
|
||||
(sqSecured', Nothing) <- A.joinConnection bob bobUserId aliceId True qInfo "bob's connInfo" pqSupport SMSubscribe
|
||||
(sqSecured', Nothing) <- A.joinConnection bob NRMInteractive bobUserId aliceId True qInfo "bob's connInfo" pqSupport SMSubscribe
|
||||
liftIO $ sqSecured' `shouldBe` sqSecured
|
||||
("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
|
||||
liftIO $ pqSup' `shouldBe` pqSupport
|
||||
@@ -3383,7 +3401,7 @@ testSMPServerConnectionTest (t, msType) newQueueBasicAuth srv =
|
||||
withSmpServerConfigOn t cfg' testPort2 $ \_ -> do
|
||||
-- initially passed server is not running
|
||||
withAgent 1 agentCfg initAgentServers testDB $ \a ->
|
||||
testProtocolServer a 1 srv
|
||||
testProtocolServer a NRMInteractive 1 srv
|
||||
where
|
||||
cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {newQueueBasicAuth}
|
||||
|
||||
@@ -3781,7 +3799,7 @@ testServerQueueInfo = do
|
||||
liftIO $ isJust r `shouldBe` True
|
||||
pure r
|
||||
checkQ c cId qiSnd' qiSubThread_ qiSize' msgType_ = do
|
||||
ServerQueueInfo {info = QueueInfo {qiSnd, qiNtf, qiSub, qiSize, qiMsg}} <- getConnectionQueueInfo c cId
|
||||
ServerQueueInfo {info = QueueInfo {qiSnd, qiNtf, qiSub, qiSize, qiMsg}} <- getConnectionQueueInfo c NRMInteractive cId
|
||||
liftIO $ do
|
||||
qiSnd `shouldBe` qiSnd'
|
||||
qiNtf `shouldBe` False
|
||||
|
||||
@@ -61,7 +61,8 @@ import qualified Database.PostgreSQL.Simple as PSQL
|
||||
import NtfClient
|
||||
import SMPAgentClient (agentCfg, initAgentServers, initAgentServers2, testDB, testDB2, testNtfServer, testNtfServer2)
|
||||
import SMPClient
|
||||
import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMessage)
|
||||
import Simplex.Messaging.Agent hiding (checkNtfToken, createConnection, joinConnection, registerNtfToken, sendMessage, verifyNtfToken)
|
||||
import qualified Simplex.Messaging.Agent as A
|
||||
import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), withStore')
|
||||
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, Env (..), InitialAgentServers)
|
||||
import Simplex.Messaging.Agent.Protocol hiding (CON, CONF, INFO, SENT)
|
||||
@@ -69,6 +70,7 @@ import Simplex.Messaging.Agent.Store.AgentStore (getSavedNtfToken)
|
||||
import Simplex.Messaging.Agent.Store.Common (withTransaction)
|
||||
import qualified Simplex.Messaging.Agent.Store.DB as DB
|
||||
import Simplex.Messaging.Agent.Store.Interface (closeDBStore, reopenDBStore)
|
||||
import Simplex.Messaging.Client (pattern NRMInteractive)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Notifications.Protocol
|
||||
@@ -194,6 +196,15 @@ testNtfMatrix ps@(_, msType) runTest = do
|
||||
cfg' = cfgMS msType
|
||||
cfgVPrev' = cfgVPrev msType
|
||||
|
||||
registerNtfToken :: AgentClient -> DeviceToken -> NotificationsMode -> AE NtfTknStatus
|
||||
registerNtfToken c = A.registerNtfToken c NRMInteractive
|
||||
|
||||
checkNtfToken :: AgentClient -> DeviceToken -> AE NtfTknStatus
|
||||
checkNtfToken c = A.checkNtfToken c NRMInteractive
|
||||
|
||||
verifyNtfToken :: AgentClient -> DeviceToken -> C.CbNonce -> ByteString -> AE ()
|
||||
verifyNtfToken c = A.verifyNtfToken c NRMInteractive
|
||||
|
||||
runNtfTestCfg :: HasCallStack => (ASrvTransport, AStoreType) -> AgentMsgId -> AServerConfig -> NtfServerConfig -> AgentConfig -> AgentConfig -> (APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> IO ()
|
||||
runNtfTestCfg (t, msType) baseId smpCfg ntfCfg aCfg bCfg runTest = do
|
||||
ASSCfg qt mt serverStoreCfg <- pure $ testServerStoreConfig msType
|
||||
@@ -529,7 +540,7 @@ testRunNTFServerTests :: ASrvTransport -> NtfServer -> IO (Maybe ProtocolTestFai
|
||||
testRunNTFServerTests t srv =
|
||||
withNtfServer t $
|
||||
withAgent 1 agentCfg initAgentServers testDB $ \a ->
|
||||
testProtocolServer a 1 $ ProtoServerWithAuth srv Nothing
|
||||
testProtocolServer a NRMInteractive 1 $ ProtoServerWithAuth srv Nothing
|
||||
|
||||
testNotificationSubscriptionExistingConnection :: APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()
|
||||
testNotificationSubscriptionExistingConnection apns baseId alice@AgentClient {agentEnv = Env {config = aliceCfg, store}} bob = do
|
||||
|
||||
@@ -91,7 +91,7 @@ testSocksMode = do
|
||||
where
|
||||
transportSocks proxy socksMode = transportSocksCfg defaultNetworkConfig {socksProxy = proxy, socksMode}
|
||||
transportSocksCfg cfg host =
|
||||
let TransportClientConfig {socksProxy} = transportClientConfig cfg host False Nothing
|
||||
let TransportClientConfig {socksProxy} = transportClientConfig cfg NRMInteractive host False Nothing
|
||||
in socksProxy
|
||||
|
||||
testSocksProxyEncoding :: Spec
|
||||
|
||||
@@ -19,7 +19,7 @@ import SMPClient (proxyVRangeV8, ntfTestPort, testPort)
|
||||
import Simplex.Messaging.Agent.Env.SQLite
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
import Simplex.Messaging.Agent.RetryInterval
|
||||
import Simplex.Messaging.Client (ProtocolClientConfig (..), SMPProxyFallback (..), SMPProxyMode (..), defaultNetworkConfig, defaultSMPClientConfig)
|
||||
import Simplex.Messaging.Client (NetworkTimeout (..), ProtocolClientConfig (..), SMPProxyFallback (..), SMPProxyMode (..), defaultNetworkConfig, defaultSMPClientConfig)
|
||||
import Simplex.Messaging.Notifications.Client (defaultNTFClientConfig)
|
||||
import Simplex.Messaging.Protocol (NtfServer, ProtoServerWithAuth (..), ProtocolServer)
|
||||
import Simplex.Messaging.Transport
|
||||
@@ -64,7 +64,7 @@ initAgentServers =
|
||||
{ smp = userServers [testSMPServer],
|
||||
ntf = [testNtfServer],
|
||||
xftp = userServers [testXFTPServer],
|
||||
netCfg = defaultNetworkConfig {tcpTimeout = 500_000, tcpConnectTimeout = 500_000},
|
||||
netCfg = defaultNetworkConfig {tcpTimeout = NetworkTimeout 500000 500000, tcpConnectTimeout = NetworkTimeout 500000 500000},
|
||||
presetDomains = []
|
||||
}
|
||||
|
||||
@@ -96,7 +96,7 @@ agentCfg =
|
||||
certificateFile = "tests/fixtures/server.crt"
|
||||
}
|
||||
where
|
||||
networkConfig = defaultNetworkConfig {tcpConnectTimeout = 1_000_000, tcpTimeout = 2_000_000}
|
||||
networkConfig = defaultNetworkConfig {tcpConnectTimeout = NetworkTimeout 1_000000 1_000000, tcpTimeout = NetworkTimeout 2_000000 2_000000}
|
||||
|
||||
agentProxyCfgV8 :: AgentConfig
|
||||
agentProxyCfgV8 = agentCfg {smpCfg = (smpCfg agentCfg) {serverVRange = proxyVRangeV8}}
|
||||
|
||||
+19
-19
@@ -167,37 +167,37 @@ deliverMessagesViaProxy proxyServ relayServ alg unsecuredMsgs securedMsgs = do
|
||||
g <- C.newRandom
|
||||
-- set up proxy
|
||||
ts <- getCurrentTime
|
||||
pc' <- getProtocolClient g (1, proxyServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion currentClientSMPRelayVersion} [] Nothing ts (\_ -> pure ())
|
||||
pc' <- getProtocolClient g NRMInteractive (1, proxyServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion currentClientSMPRelayVersion} [] Nothing ts (\_ -> pure ())
|
||||
pc <- either (fail . show) pure pc'
|
||||
THAuthClient {} <- maybe (fail "getProtocolClient returned no thAuth") pure $ thAuth $ thParams pc
|
||||
-- set up relay
|
||||
msgQ <- newTBQueueIO 1024
|
||||
rc' <- getProtocolClient g (2, relayServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion currentClientSMPRelayVersion} [] (Just msgQ) ts (\_ -> pure ())
|
||||
rc' <- getProtocolClient g NRMInteractive (2, relayServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion currentClientSMPRelayVersion} [] (Just msgQ) ts (\_ -> pure ())
|
||||
rc <- either (fail . show) pure rc'
|
||||
-- prepare receiving queue
|
||||
(rPub, rPriv) <- atomically $ C.generateAuthKeyPair alg g
|
||||
(rdhPub, rdhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
|
||||
SMP.QIK {rcvId, sndId, rcvPublicDhKey = srvDh} <- runExceptT' $ createSMPQueue rc Nothing (rPub, rPriv) rdhPub (Just "correct") SMSubscribe (QRMessaging Nothing)
|
||||
SMP.QIK {rcvId, sndId, rcvPublicDhKey = srvDh} <- runExceptT' $ createSMPQueue rc NRMInteractive Nothing (rPub, rPriv) rdhPub (Just "correct") SMSubscribe (QRMessaging Nothing)
|
||||
let dec = decryptMsgV3 $ C.dh' srvDh rdhPriv
|
||||
-- get proxy session
|
||||
sess0 <- runExceptT' $ connectSMPProxiedRelay pc relayServ (Just "correct")
|
||||
sess <- runExceptT' $ connectSMPProxiedRelay pc relayServ (Just "correct")
|
||||
sess0 <- runExceptT' $ connectSMPProxiedRelay pc NRMInteractive relayServ (Just "correct")
|
||||
sess <- runExceptT' $ connectSMPProxiedRelay pc NRMInteractive relayServ (Just "correct")
|
||||
sess0 `shouldBe` sess
|
||||
-- send via proxy to unsecured queue
|
||||
forM_ unsecuredMsgs $ \msg -> do
|
||||
runExceptT' (proxySMPMessage pc sess Nothing sndId noMsgFlags msg) `shouldReturn` Right ()
|
||||
runExceptT' (proxySMPMessage pc sess {prSessionId = "bad session"} Nothing sndId noMsgFlags msg) `shouldReturn` Left (ProxyProtocolError $ SMP.PROXY SMP.NO_SESSION)
|
||||
runExceptT' (proxySMPMessage pc NRMInteractive sess Nothing sndId noMsgFlags msg) `shouldReturn` Right ()
|
||||
runExceptT' (proxySMPMessage pc NRMInteractive sess {prSessionId = "bad session"} Nothing sndId noMsgFlags msg) `shouldReturn` Left (ProxyProtocolError $ SMP.PROXY SMP.NO_SESSION)
|
||||
-- receive 1
|
||||
(_tSess, _v, _sid, [(_entId, STEvent (Right (SMP.MSG RcvMessage {msgId, msgBody = EncRcvMsgBody encBody})))]) <- atomically $ readTBQueue msgQ
|
||||
dec msgId encBody `shouldBe` Right msg
|
||||
runExceptT' $ ackSMPMessage rc rPriv rcvId msgId
|
||||
-- secure queue
|
||||
(sPub, sPriv) <- atomically $ C.generateAuthKeyPair alg g
|
||||
runExceptT' $ secureSMPQueue rc rPriv rcvId sPub
|
||||
runExceptT' $ secureSMPQueue rc NRMInteractive rPriv rcvId sPub
|
||||
-- send via proxy to secured queue
|
||||
waitSendRecv
|
||||
( forM_ securedMsgs $ \msg' ->
|
||||
runExceptT' (proxySMPMessage pc sess (Just sPriv) sndId noMsgFlags msg') `shouldReturn` Right ()
|
||||
runExceptT' (proxySMPMessage pc NRMInteractive sess (Just sPriv) sndId noMsgFlags msg') `shouldReturn` Right ()
|
||||
)
|
||||
( forM_ securedMsgs $ \msg' -> do
|
||||
(_tSess, _v, _sid, [(_entId, STEvent (Right (SMP.MSG RcvMessage {msgId = msgId', msgBody = EncRcvMsgBody encBody'})))]) <- atomically $ readTBQueue msgQ
|
||||
@@ -210,12 +210,12 @@ proxyConnectDeadRelay n d proxyServ = do
|
||||
g <- C.newRandom
|
||||
-- set up proxy
|
||||
ts <- getCurrentTime
|
||||
pc' <- getProtocolClient g (1, proxyServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion sendingProxySMPVersion} [] Nothing ts (\_ -> pure ())
|
||||
pc' <- getProtocolClient g NRMInteractive (1, proxyServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion sendingProxySMPVersion} [] Nothing ts (\_ -> pure ())
|
||||
pc <- either (fail . show) pure pc'
|
||||
THAuthClient {} <- maybe (fail "getProtocolClient returned no thAuth") pure $ thAuth $ thParams pc
|
||||
-- get proxy session
|
||||
replicateM_ n $ do
|
||||
sess0 <- runExceptT $ connectSMPProxiedRelay pc (SMPServer testHost "45678" testKeyHash) (Just "correct")
|
||||
sess0 <- runExceptT $ connectSMPProxiedRelay pc NRMInteractive (SMPServer testHost "45678" testKeyHash) (Just "correct")
|
||||
case sess0 of
|
||||
Right !_noWay -> error "got unexpected client"
|
||||
Left !_err -> threadDelay d
|
||||
@@ -224,9 +224,9 @@ agentDeliverMessageViaProxy :: (C.AlgorithmI a, C.AuthAlgorithm a) => (NonEmpty
|
||||
agentDeliverMessageViaProxy aTestCfg@(aSrvs, _, aViaProxy) bTestCfg@(bSrvs, _, bViaProxy) alg msg1 msg2 baseId =
|
||||
withAgent 1 aCfg (servers aTestCfg) testDB $ \alice ->
|
||||
withAgent 2 aCfg (servers bTestCfg) testDB2 $ \bob -> runRight_ $ do
|
||||
(bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice 1 True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe
|
||||
(bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive 1 True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe
|
||||
aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
|
||||
(sqSecured, Nothing) <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
|
||||
(sqSecured, Nothing) <- A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
|
||||
liftIO $ sqSecured `shouldBe` True
|
||||
("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
|
||||
liftIO $ pqSup' `shouldBe` PQSupportOn
|
||||
@@ -280,9 +280,9 @@ agentDeliverMessagesViaProxyConc agentServers msgs =
|
||||
-- agent connections have to be set up in advance
|
||||
-- otherwise the CONF messages would get mixed with MSG
|
||||
prePair alice bob = do
|
||||
(bobId, (CCLink qInfo Nothing, Nothing)) <- runExceptT' $ A.createConnection alice 1 True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe
|
||||
(bobId, (CCLink qInfo Nothing, Nothing)) <- runExceptT' $ A.createConnection alice NRMInteractive 1 True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe
|
||||
aliceId <- runExceptT' $ A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
|
||||
(sqSecured, Nothing) <- runExceptT' $ A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
|
||||
(sqSecured, Nothing) <- runExceptT' $ A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
|
||||
liftIO $ sqSecured `shouldBe` True
|
||||
confId <-
|
||||
get alice >>= \case
|
||||
@@ -331,9 +331,9 @@ agentViaProxyVersionError =
|
||||
withAgent 1 agentCfg (servers [SMPServer testHost testPort testKeyHash]) testDB $ \alice -> do
|
||||
Left (A.BROKER _ (TRANSPORT TEVersion)) <-
|
||||
withAgent 2 agentCfg (servers [SMPServer testHost2 testPort2 testKeyHash]) testDB2 $ \bob -> runExceptT $ do
|
||||
(_bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice 1 True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe
|
||||
(_bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive 1 True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe
|
||||
aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
|
||||
A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
|
||||
A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
|
||||
pure ()
|
||||
where
|
||||
servers srvs = (initAgentServersProxy_ SPMUnknown SPFProhibit) {smp = userServers srvs}
|
||||
@@ -351,9 +351,9 @@ agentViaProxyRetryOffline = do
|
||||
let pqEnc = CR.PQEncOn
|
||||
withServer $ \_ -> do
|
||||
(aliceId, bobId) <- withServer2 $ \_ -> runRight $ do
|
||||
(bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice 1 True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe
|
||||
(bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive 1 True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe
|
||||
aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
|
||||
(sqSecured, Nothing) <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
|
||||
(sqSecured, Nothing) <- A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
|
||||
liftIO $ sqSecured `shouldBe` True
|
||||
("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
|
||||
liftIO $ pqSup' `shouldBe` PQSupportOn
|
||||
|
||||
+2
-1
@@ -33,6 +33,7 @@ import Simplex.Messaging.Agent (AgentClient, testProtocolServer, xftpDeleteRcvFi
|
||||
import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..))
|
||||
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, xftpCfg)
|
||||
import Simplex.Messaging.Agent.Protocol (AEvent (..), AgentErrorType (..), BrokerErrorType (..), noAuthSrv)
|
||||
import Simplex.Messaging.Client (pattern NRMInteractive)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs)
|
||||
import qualified Simplex.Messaging.Crypto.File as CF
|
||||
@@ -674,4 +675,4 @@ testXFTPServerTest newFileBasicAuth srv =
|
||||
withXFTPServerCfg testXFTPServerConfig {newFileBasicAuth, xftpPort = xftpTestPort2} $ \_ ->
|
||||
-- initially passed server is not running
|
||||
withAgent 1 agentCfg initAgentServers testDB $ \a ->
|
||||
testProtocolServer a 1 srv
|
||||
testProtocolServer a NRMInteractive 1 srv
|
||||
|
||||
Reference in New Issue
Block a user