Compare commits

..
71 changed files with 1767 additions and 3260 deletions
+2 -2
View File
@@ -63,7 +63,7 @@ jobs:
mv $(cabal list-bin xftp) xftp-ubuntu-${{ matrix.platform_name}}
- name: Build changelog
if: startsWith(github.ref, 'refs/tags/v') && matrix.os == 'ubuntu-22.04'
if: startsWith(github.ref, 'refs/tags/v') && matrix.os == 'ubuntu-20.04'
id: build_changelog
uses: mikepenz/release-changelog-builder-action@v1
with:
@@ -75,7 +75,7 @@ jobs:
GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
- name: Create release
if: startsWith(github.ref, 'refs/tags/v') && matrix.ghc != '8.10.7'
if: startsWith(github.ref, 'refs/tags/v') && matrix.os == 'ubuntu-20.04' && matrix.ghc == '9.6.3'
uses: softprops/action-gh-release@v1
with:
body: |
-54
View File
@@ -1,57 +1,3 @@
# 5.7.4
SMP agent:
- remove re-subscription timeouts (as they are tracked per operation, and could cause failed subscriptions).
- reconnect XFTP clients when network settings changes.
- fix lock contention resulting in stuck subscriptions on network change.
# 5.7.3
SMP/NTF protocol:
- add ALPN for handshake version negotiation, similar to XFTP (to preserve backwards compatibility with the old clients).
- upgrade clients to versions v7/v2 of the protocols.
SMP server:
- faster responses to subscription requests.
XFTP client:
- fix network exception during file download treated as permanent file error.
SMP agent:
- do not report subscription timeouts while client is offline.
# 5.7.2
SMP agent:
- fix connections failing when connecting via link due to race condition on slow network.
- remove concurrency limit when waiting for connection subscription.
- remove TLS timeout.
# 5.7.1
SMP agent:
- increase timeout for TLS connection via SOCKS
# 5.7.0
Version 5.7.0.4
_Please note_: the earliest SimpleX Chat clients supported by this version of the servers is 5.5.3 (released on February 11, 2024).
SMP server:
- increase max SMP protocol version to 7 (support for deniable authenticators).
NTF server:
- increase max NTF protocol version to 2 (support for deniable authenticators).
XFTP server:
- version handshake using ALPN.
SMP agent:
- increase timeouts for XFTP files.
- don't send commands after timeout.
- PQ encryption support.
# 5.6.2
Version 5.6.2.2.
+3 -22
View File
@@ -1,5 +1,5 @@
name: simplexmq
version: 5.8.0.5
version: 5.6.2.2
synopsis: SimpleXMQ message broker
description: |
This package includes <./docs/Simplex-Messaging-Server.html server>,
@@ -177,31 +177,12 @@ tests:
ghc-options:
# - -haddock
- -Weverything
- -Wno-missing-exported-signatures
- -Wno-missing-import-lists
- -Wno-missed-specialisations
- -Wno-all-missed-specialisations
- -Wno-unsafe
- -Wno-safe
- -Wno-missing-local-signatures
- -Wno-missing-kind-signatures
- -Wno-missing-deriving-strategies
- -Wno-monomorphism-restriction
- -Wno-prepositive-qualified-module
- -Wno-unused-packages
- -Wno-implicit-prelude
- -Wno-missing-safe-haskell-mode
- -Wno-missing-export-lists
- -Wno-partial-fields
- -Wall
- -Wcompat
- -Werror=incomplete-record-updates
- -Werror=incomplete-patterns
- -Werror=incomplete-uni-patterns
- -Werror=missing-methods
- -Werror=tabs
- -Wredundant-constraints
- -Wincomplete-record-updates
- -Wincomplete-uni-patterns
- -Wunused-type-patterns
- -O2
-50
View File
@@ -196,56 +196,6 @@ dhPublic = length x509encoded
The above assumes that the client can only send one message to an SMP relay and then has to wait for response before sending the next message. Missing the response would cause re-delivery (further improvement is possible when proxy detects these redelieveries and not send them to relays but simply reply with the same response).
### Implementation considerations for the client
While client/server protocol is rather straightforward to implement, and it is already working, there are some decisions to make about how the client makes decisions about.
1. When to use proxy and when to connect directly to the destination relay.
While from the perspective of threat model improvement it may be beneficial to always use the proxy, choosing the proxy that is different from other relays in the connection, initially we need to make it opt-in, with an option to only use it for unknown destination relays, to minimize any unexpected adverse effect on the delivery latency.
Proxy mode will be passed from the client via NetworkConfig.
2. Which proxying relays to use.
Ability to request access to the session with the destination relay (and to create such session) is protected with the same basic auth approach as creating queues - the logic here is that opening private servers to all users as proxies would increase the scenarios for DoS attacks (which is the case with the public servers).
The open question is whether the client should choose proxies from:
- all configured relays.
- there should be a subset of configured relays.
- there should be a separate list.
E.g., there could be a second toggle in the relay configuration to allow using relay as proxy, in addition to the current toggle that allows creating queues.
For simplicity, initially we will just use all enabled relays as potential proxies.
3. How many proxying relays should be used during one session.
This is not a simple question, and it creates a contradiction between two risks:
- collusion between proxies and destination relays simplifies correlating sending clients by session - from the point of view of this risk, clients should follow the same policy for creating connections with proxies, that is to create a new connection for each user profile, and if transport isolation is set to "per connection" - for each destination queue.
- traffic correlation by observable traffic sessions (particularly if an attacker can observe user's ISP traffic or multiple proxies) - from this point of view, it would be beneficial to use fewer proxies and fewer connections with proxies and see the risk of proxy colluding with the destination relay as lower than the risk of traffic observation that in the case of multiple sessions would allow to correlate traffic to rarely used destination relays (any private self-hosted relays) and the traffic of the user to a given proxy, to prove the fact of user communicating with the destination relay via the proxy.
While we can transfer this choice on the users, it seems a complex decision to make, and overall the second risk (traffic correlation) seems more important to address than the first.
In any case possible options are:
1. Extreme option 1: Create a new proxy session, with the new random proxy, for each potential transport session that would exist if the user were to be connected to destination relays directly. That is, never to mix access to multiple relays from multiple user profiles (and in case of per-connection isolation, to multiple queues) into a one client session with proxy. This is a rather radical option that nullifies any advantages of having fewer sessions with proxies than there would have been with the destination relays and removes any benefits of batching destination server session requests (PRXY comands).
2. Extreme option 2: Use only one proxy session at the time, mixing traffic from all user profiles and to all destination servers (and for all queues) into a session with one proxy. This minimizes the risks of traffic correlation in case of non-colluding proxy, but maximises the risk in case it colludes with the destination relays.
3. Balanced option: Use one proxy session per user profile, but mix traffic to multiple queues irrespective of connection isolation option and to all destination servers. Given that connection isolation is an experimental option, this makes the most sense, but it would have to be disclosed.
4. Less balanced option: take connection isolation option into account and create a new proxy connection for each destination queue. This feels worse than option 3.
If option 3 is chosen, then the transport session key with the proxy would be different from the transport session key with the relay - proxy session will only use UserId as the key, and the relay session uses (UserId, Server, Maybe EntityId) as the key.
If option 4 is chosen, the keys would also be different, as the proxy would then use (UserId, Maybe (Server, EntityId)) as the key.
We could potentially key proxy sessions (and create proxy connections) per each destination relay, in the same way as we key relays themselves, but it seems to have the least sense, as we neither achieve isolation by queue in case proxy and destination relay collude, nor we sufficiently protect from traffic correlation by any observers.
The implemented design is this:
- for each destination relay a random proxy is chosen and used to send all messages - all requests from a client coalesce to a single session.
- transport isolation mode is taken into account, that is if per-connection isolation is enabled, then a separate proxy connection will be created for each messaging queue.
- supported modes when proxy is used: always, for unknown relays, for unknown relays when IP address is not protected, never.
This decision is made because the argument for protection against collusion between proxy and relay and more balanced traffic distribution is stronger than the argument for protection against traffic correlation, because even mixing all messages to one proxy connection does not provide protection against traffic correlation by time, so in any case it requires adding delays.
### Threat model for SMP proxy and changes to threat model for SMP
#### SMP proxy
+8 -9
View File
@@ -5,7 +5,7 @@ cabal-version: 1.12
-- see: https://github.com/sol/hpack
name: simplexmq
version: 5.8.0.5
version: 5.6.2.2
synopsis: SimpleXMQ message broker
description: This package includes <./docs/Simplex-Messaging-Server.html server>,
<./docs/Simplex-Messaging-Client.html client> and
@@ -105,7 +105,6 @@ library
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240124_file_redirect
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240223_connections_wait_delivery
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240225_ratchet_kem
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240417_rcv_files_approved_relays
Simplex.Messaging.Agent.TRcvQueues
Simplex.Messaging.Client
Simplex.Messaging.Client.Agent
@@ -175,7 +174,7 @@ library
src
default-extensions:
StrictData
ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2
ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -O2
include-dirs:
cbits
c-sources:
@@ -256,7 +255,7 @@ executable ntf-server
apps/ntf-server
default-extensions:
StrictData
ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts
ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -O2 -threaded -rtsopts
build-depends:
aeson ==2.2.*
, ansi-terminal >=0.10 && <0.12
@@ -331,7 +330,7 @@ executable smp-agent
apps/smp-agent
default-extensions:
StrictData
ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts
ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -O2 -threaded -rtsopts
build-depends:
aeson ==2.2.*
, ansi-terminal >=0.10 && <0.12
@@ -406,7 +405,7 @@ executable smp-server
apps/smp-server
default-extensions:
StrictData
ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts
ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -O2 -threaded -rtsopts
build-depends:
aeson ==2.2.*
, ansi-terminal >=0.10 && <0.12
@@ -481,7 +480,7 @@ executable xftp
apps/xftp
default-extensions:
StrictData
ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts
ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -O2 -threaded -rtsopts
build-depends:
aeson ==2.2.*
, ansi-terminal >=0.10 && <0.12
@@ -556,7 +555,7 @@ executable xftp-server
apps/xftp-server
default-extensions:
StrictData
ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts
ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -O2 -threaded -rtsopts
build-depends:
aeson ==2.2.*
, ansi-terminal >=0.10 && <0.12
@@ -664,7 +663,7 @@ test-suite simplexmq-test
tests
default-extensions:
StrictData
ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts -with-rtsopts=-A64M -with-rtsopts=-N1
ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -O2 -threaded -rtsopts -with-rtsopts=-A64M -with-rtsopts=-N1
build-depends:
HUnit ==1.6.*
, QuickCheck ==2.14.*
+24 -30
View File
@@ -112,8 +112,8 @@ closeXFTPAgent a = do
where
stopWorkers workers = atomically (swapTVar workers M.empty) >>= mapM_ (liftIO . cancelWorker)
xftpReceiveFile' :: AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Maybe CryptoFileArgs -> Bool -> AM RcvFileId
xftpReceiveFile' c userId (ValidFileDescription fd@FileDescription {chunks, redirect}) cfArgs approvedRelays = do
xftpReceiveFile' :: AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Maybe CryptoFileArgs -> AM RcvFileId
xftpReceiveFile' c userId (ValidFileDescription fd@FileDescription {chunks, redirect}) cfArgs = do
g <- asks random
prefixPath <- lift $ getPrefixPath "rcv.xftp"
createDirectory prefixPath
@@ -124,7 +124,7 @@ xftpReceiveFile' c userId (ValidFileDescription fd@FileDescription {chunks, redi
lift $ createEmptyFile =<< toFSFilePath relSavePath
let saveFile = CryptoFile relSavePath cfArgs
fId <- case redirect of
Nothing -> withStore c $ \db -> createRcvFile db g userId fd relPrefixPath relTmpPath saveFile approvedRelays
Nothing -> withStore c $ \db -> createRcvFile db g userId fd relPrefixPath relTmpPath saveFile
Just _ -> do
-- prepare description paths
let relTmpPathRedirect = relPrefixPath </> "xftp.redirect-encrypted"
@@ -134,7 +134,7 @@ xftpReceiveFile' c userId (ValidFileDescription fd@FileDescription {chunks, redi
cfArgsRedirect <- atomically $ CF.randomArgs g
let saveFileRedirect = CryptoFile relSavePathRedirect $ Just cfArgsRedirect
-- create download tasks
withStore c $ \db -> createRcvFileRedirect db g userId fd relPrefixPath relTmpPathRedirect saveFileRedirect relTmpPath saveFile approvedRelays
withStore c $ \db -> createRcvFileRedirect db g userId fd relPrefixPath relTmpPathRedirect saveFileRedirect relTmpPath saveFile
forM_ chunks (downloadChunk c)
pure fId
@@ -176,12 +176,12 @@ runXFTPRcvWorker c srv Worker {doWork} = do
runXFTPOperation :: AgentConfig -> AM ()
runXFTPOperation AgentConfig {rcvFilesTTL, reconnectInterval = ri, xftpNotifyErrsOnRetry = notifyOnRetry, xftpConsecutiveRetries} =
withWork c doWork (\db -> getNextRcvChunkToDownload db srv rcvFilesTTL) $ \case
(RcvFileChunk {rcvFileId, rcvFileEntityId, fileTmpPath, replicas = []}, _) -> rcvWorkerInternalError c rcvFileId rcvFileEntityId (Just fileTmpPath) (INTERNAL "chunk has no replicas")
(fc@RcvFileChunk {userId, rcvFileId, rcvFileEntityId, digest, fileTmpPath, replicas = replica@RcvFileChunkReplica {rcvChunkReplicaId, server, delay} : _}, approvedRelays) -> do
RcvFileChunk {rcvFileId, rcvFileEntityId, fileTmpPath, replicas = []} -> rcvWorkerInternalError c rcvFileId rcvFileEntityId (Just fileTmpPath) "chunk has no replicas"
fc@RcvFileChunk {userId, rcvFileId, rcvFileEntityId, digest, fileTmpPath, replicas = replica@RcvFileChunkReplica {rcvChunkReplicaId, server, delay} : _} -> do
let ri' = maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) delay
withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop -> do
liftIO $ waitForUserNetwork c
downloadFileChunk fc replica approvedRelays
lift $ waitForUserNetwork c
downloadFileChunk fc replica
`catchAgentError` \e -> retryOnError "XFTP rcv worker" (retryLoop loop e delay') (retryDone e) e
where
retryLoop loop e replicaDelay = do
@@ -191,10 +191,9 @@ runXFTPRcvWorker c srv Worker {doWork} = do
withStore' c $ \db -> updateRcvChunkReplicaDelay db rcvChunkReplicaId replicaDelay
atomically $ assertAgentForeground c
loop
retryDone = rcvWorkerInternalError c rcvFileId rcvFileEntityId (Just fileTmpPath)
downloadFileChunk :: RcvFileChunk -> RcvFileChunkReplica -> Bool -> AM ()
downloadFileChunk RcvFileChunk {userId, rcvFileId, rcvFileEntityId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath} replica approvedRelays = do
unlessM ((approvedRelays ||) <$> ipAddressProtected') $ throwError $ XFTP "" XFTP.NOT_APPROVED
retryDone e = rcvWorkerInternalError c rcvFileId rcvFileEntityId (Just fileTmpPath) (show e)
downloadFileChunk :: RcvFileChunk -> RcvFileChunkReplica -> AM ()
downloadFileChunk RcvFileChunk {userId, rcvFileId, rcvFileEntityId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath} replica = do
fsFileTmpPath <- lift $ toFSFilePath fileTmpPath
chunkPath <- uniqueCombine fsFileTmpPath $ show chunkNo
let chunkSpec = XFTPRcvChunkSpec chunkPath (unFileSize chunkSize) (unFileDigest digest)
@@ -215,10 +214,6 @@ runXFTPRcvWorker c srv Worker {doWork} = do
when complete . lift . void $
getXFTPRcvWorker True c Nothing
where
ipAddressProtected' :: AM Bool
ipAddressProtected' = do
cfg <- liftIO $ getNetworkConfig' c
pure $ ipAddressProtected cfg srv
receivedSize :: [RcvFileChunk] -> Int64
receivedSize = foldl' (\sz ch -> sz + receivedChunkSize ch) 0
receivedChunkSize ch@RcvFileChunk {chunkSize = s}
@@ -239,11 +234,11 @@ retryOnError name loop done e = do
then loop
else done
rcvWorkerInternalError :: AgentClient -> DBRcvFileId -> RcvFileId -> Maybe FilePath -> AgentErrorType -> AM ()
rcvWorkerInternalError c rcvFileId rcvFileEntityId tmpPath err = do
rcvWorkerInternalError :: AgentClient -> DBRcvFileId -> RcvFileId -> Maybe FilePath -> String -> AM ()
rcvWorkerInternalError c rcvFileId rcvFileEntityId tmpPath internalErrStr = do
lift $ forM_ tmpPath (removePath <=< toFSFilePath)
withStore' c $ \db -> updateRcvFileError db rcvFileId (show err)
notify c rcvFileEntityId $ RFERR err
withStore' c $ \db -> updateRcvFileError db rcvFileId internalErrStr
notify c rcvFileEntityId $ RFERR $ INTERNAL internalErrStr
runXFTPRcvLocalWorker :: AgentClient -> Worker -> AM ()
runXFTPRcvLocalWorker c Worker {doWork} = do
@@ -257,7 +252,7 @@ runXFTPRcvLocalWorker c Worker {doWork} = do
runXFTPOperation AgentConfig {rcvFilesTTL} =
withWork c doWork (`getNextRcvFileToDecrypt` rcvFilesTTL) $
\f@RcvFile {rcvFileId, rcvFileEntityId, tmpPath} ->
decryptFile f `catchAgentError` rcvWorkerInternalError c rcvFileId rcvFileEntityId tmpPath
decryptFile f `catchAgentError` (rcvWorkerInternalError c rcvFileId rcvFileEntityId tmpPath . show)
decryptFile :: RcvFile -> AM ()
decryptFile RcvFile {rcvFileId, rcvFileEntityId, size, digest, key, nonce, tmpPath, saveFile, status, chunks, redirect} = do
let CryptoFile savePath cfArgs = saveFile
@@ -267,9 +262,9 @@ runXFTPRcvLocalWorker c Worker {doWork} = do
withStore' c $ \db -> updateRcvFileStatus db rcvFileId RFSDecrypting
chunkPaths <- getChunkPaths chunks
encSize <- liftIO $ foldM (\s path -> (s +) . fromIntegral <$> getFileSize path) 0 chunkPaths
when (FileSize encSize /= size) $ throwError $ XFTP "" XFTP.SIZE
when (FileSize encSize /= size) $ throwError $ XFTP XFTP.SIZE
encDigest <- liftIO $ LC.sha512Hash <$> readChunks chunkPaths
when (FileDigest encDigest /= digest) $ throwError $ XFTP "" XFTP.DIGEST
when (FileDigest encDigest /= digest) $ throwError $ XFTP XFTP.DIGEST
let destFile = CryptoFile fsSavePath cfArgs
void $ liftError (INTERNAL . show) $ decryptChunks encSize chunkPaths key nonce $ \_ -> pure destFile
case redirect of
@@ -286,11 +281,10 @@ runXFTPRcvLocalWorker c Worker {doWork} = do
-- proceed with redirect
yaml <- liftError (INTERNAL . show) (CF.readFile $ CryptoFile fsSavePath cfArgs) `agentFinally` (lift $ toFSFilePath fsSavePath >>= removePath)
next@FileDescription {chunks = nextChunks} <- case strDecode (LB.toStrict yaml) of
-- TODO switch to another error constructor
Left _ -> throwError . XFTP "" $ XFTP.REDIRECT "decode error"
Left _ -> throwError . XFTP $ XFTP.REDIRECT "decode error"
Right (ValidFileDescription fd@FileDescription {size = dstSize, digest = dstDigest})
| dstSize /= redirectSize -> throwError . XFTP "" $ XFTP.REDIRECT "size mismatch"
| dstDigest /= redirectDigest -> throwError . XFTP "" $ XFTP.REDIRECT "digest mismatch"
| dstSize /= redirectSize -> throwError . XFTP $ XFTP.REDIRECT "size mismatch"
| dstDigest /= redirectDigest -> throwError . XFTP $ XFTP.REDIRECT "digest mismatch"
| otherwise -> pure fd
-- register and download chunks from the actual file
withStore c $ \db -> updateRcvFileRedirect db redirectDbId next
@@ -430,7 +424,7 @@ runXFTPSndPrepareWorker c Worker {doWork} = do
tryCreate = do
usedSrvs <- newTVarIO ([] :: [XFTPServer])
withRetryInterval (riFast ri) $ \_ loop -> do
liftIO $ waitForUserNetwork c
lift $ waitForUserNetwork c
createWithNextSrv usedSrvs
`catchAgentError` \e -> retryOnError "XFTP prepare worker" (retryLoop loop) (throwError e) e
where
@@ -463,7 +457,7 @@ runXFTPSndWorker c srv Worker {doWork} = do
fc@SndFileChunk {userId, sndFileId, sndFileEntityId, filePrefixPath, digest, replicas = replica@SndFileChunkReplica {sndChunkReplicaId, server, delay} : _} -> do
let ri' = maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) delay
withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop -> do
liftIO $ waitForUserNetwork c
lift $ waitForUserNetwork c
uploadFileChunk cfg fc replica
`catchAgentError` \e -> retryOnError "XFTP snd worker" (retryLoop loop e delay') (retryDone e) e
where
@@ -630,7 +624,7 @@ runXFTPDelWorker c srv Worker {doWork} = do
processDeletedReplica replica@DeletedSndChunkReplica {deletedSndChunkReplicaId, userId, server, chunkDigest, delay} = do
let ri' = maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) delay
withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop -> do
liftIO $ waitForUserNetwork c
lift $ waitForUserNetwork c
deleteChunkReplica
`catchAgentError` \e -> retryOnError "XFTP del worker" (retryLoop loop e delay') (retryDone e) e
where
+23 -32
View File
@@ -14,7 +14,6 @@ module Simplex.FileTransfer.Client where
import Control.Logger.Simple
import Control.Monad
import Control.Monad.Except
import Control.Monad.Trans.Except
import Crypto.Random (ChaChaDRG)
import Data.Bifunctor (first)
import Data.ByteString.Builder (Builder, byteString)
@@ -39,8 +38,8 @@ import Simplex.Messaging.Client
defaultNetworkConfig,
proxyUsername,
transportClientConfig,
unexpectedResponse,
)
import Simplex.Messaging.Client.Agent ()
import qualified Simplex.Messaging.Crypto as C
import qualified Simplex.Messaging.Crypto.Lazy as LC
import Simplex.Messaging.Encoding (smpDecode, smpEncode)
@@ -52,13 +51,13 @@ import Simplex.Messaging.Protocol
RecipientId,
SenderId,
)
import Simplex.Messaging.Transport (ALPN, THandleAuth (..), THandleParams (..), TransportError (..), TransportPeer (..), supportedParameters)
import Simplex.Messaging.Transport (ALPN, HandshakeError (VERSION), THandleAuth (..), THandleParams (..), TransportError (..), TransportPeer (..), supportedParameters)
import Simplex.Messaging.Transport.Client (TransportClientConfig, TransportHost, alpn)
import Simplex.Messaging.Transport.HTTP2
import Simplex.Messaging.Transport.HTTP2.Client
import Simplex.Messaging.Transport.HTTP2.File
import Simplex.Messaging.Util (liftEitherWith, liftError', tshow, whenM)
import Simplex.Messaging.Version
import Simplex.Messaging.Util (bshow, liftEitherWith, liftError', tshow, whenM)
import Simplex.Messaging.Version (compatibleVersion, pattern Compatible)
import UnliftIO
import UnliftIO.Directory
@@ -100,24 +99,22 @@ defaultXFTPClientConfig =
getXFTPClient :: TransportSession FileResponse -> XFTPClientConfig -> (XFTPClient -> IO ()) -> IO (Either XFTPClientError XFTPClient)
getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN, xftpNetworkConfig, serverVRange} disconnected = runExceptT $ do
let username = proxyUsername transportSession
let tcConfig = (transportClientConfig xftpNetworkConfig) {alpn = clientALPN}
http2Config = xftpHTTP2Config tcConfig config
username = proxyUsername transportSession
ProtocolServer _ host port keyHash = srv
useHost <- liftEither $ chooseTransportHost xftpNetworkConfig host
let tcConfig = (transportClientConfig xftpNetworkConfig useHost) {alpn = clientALPN}
http2Config = xftpHTTP2Config tcConfig config
clientVar <- newTVarIO Nothing
let usePort = if null port then "443" else port
clientDisconnected = readTVarIO clientVar >>= mapM_ disconnected
http2Client <- liftError' xftpClientError $ getVerifiedHTTP2Client (Just username) useHost usePort (Just keyHash) Nothing http2Config clientDisconnected
let HTTP2Client {sessionId, sessionALPN} = http2Client
v = VersionXFTP 1
thServerVRange = versionToRange v
thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = v, thServerVRange, thAuth = Nothing, implySessId = False, batch = True}
thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = VersionXFTP 1, thAuth = Nothing, implySessId = False, batch = True}
logDebug $ "Client negotiated handshake protocol: " <> tshow sessionALPN
thParams@THandleParams {thVersion} <- case sessionALPN of
Just "xftp/1" -> xftpClientHandshakeV1 serverVRange keyHash http2Client thParams0
Nothing -> pure thParams0
_ -> throwError $ PCETransportError TEVersion
_ -> throwError $ PCETransportError (TEHandshake VERSION)
logDebug $ "Client negotiated protocol: " <> tshow thVersion
let c = XFTPClient {http2Client, thParams, transportSession, config}
atomically $ writeTVar clientVar $ Just c
@@ -126,10 +123,9 @@ getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN,
xftpClientHandshakeV1 :: VersionRangeXFTP -> C.KeyHash -> HTTP2Client -> THandleParamsXFTP 'TClient -> ExceptT XFTPClientError IO (THandleParamsXFTP 'TClient)
xftpClientHandshakeV1 serverVRange keyHash@(C.KeyHash kh) c@HTTP2Client {sessionId, serverKey} thParams0 = do
shs@XFTPServerHandshake {authPubKey = ck} <- getServerHandshake
(vr, sk) <- processServerHandshake shs
let v = maxVersion vr
(v, sk) <- processServerHandshake shs
sendClientHandshake XFTPClientHandshake {xftpVersion = v, keyHash}
pure thParams0 {thAuth = Just THAuthClient {serverPeerPubKey = sk, serverCertKey = ck, sessSecret = Nothing}, thVersion = v, thServerVRange = vr}
pure thParams0 {thAuth = Just THAuthClient {serverPeerPubKey = sk, serverCertKey = ck, sessSecret = Nothing}, thVersion = v}
where
getServerHandshake :: ExceptT XFTPClientError IO XFTPServerHandshake
getServerHandshake = do
@@ -137,13 +133,13 @@ xftpClientHandshakeV1 serverVRange keyHash@(C.KeyHash kh) c@HTTP2Client {session
HTTP2Response {respBody = HTTP2Body {bodyHead = shsBody}} <-
liftError' (const $ PCEResponseError HANDSHAKE) $ sendRequest c helloReq Nothing
liftHS . smpDecode =<< liftHS (C.unPad shsBody)
processServerHandshake :: XFTPServerHandshake -> ExceptT XFTPClientError IO (VersionRangeXFTP, C.PublicKeyX25519)
processServerHandshake :: XFTPServerHandshake -> ExceptT XFTPClientError IO (VersionXFTP, C.PublicKeyX25519)
processServerHandshake XFTPServerHandshake {xftpVersionRange, sessionId = serverSessId, authPubKey = serverAuth} = do
unless (sessionId == serverSessId) $ throwError $ PCEResponseError SESSION
case xftpVersionRange `compatibleVRange` serverVRange of
Nothing -> throwError $ PCETransportError TEVersion
Just (Compatible vr) ->
fmap (vr,) . liftHS $ do
case xftpVersionRange `compatibleVersion` serverVRange of
Nothing -> throwError $ PCEResponseError HANDSHAKE
Just (Compatible v) ->
fmap (v,) . liftHS $ do
let (X.CertificateChain cert, exact) = serverAuth
case cert of
[_leaf, ca] | XV.Fingerprint kh == XV.getFingerprint ca X.HashSHA256 -> pure ()
@@ -216,7 +212,7 @@ sendXFTPTransmission XFTPClient {config, thParams, http2Client} t chunkSpec_ = d
forM_ chunkSpec_ $ \XFTPChunkSpec {filePath, chunkOffset, chunkSize} ->
withFile filePath ReadMode $ \h -> do
hSeek h AbsoluteSeek $ fromIntegral chunkOffset
hSendFile h send chunkSize
hSendFile h send $ fromIntegral chunkSize
done
createXFTPChunk ::
@@ -229,13 +225,13 @@ createXFTPChunk ::
createXFTPChunk c spKey file rcps auth_ =
sendXFTPCommand c spKey "" (FNEW file rcps auth_) Nothing >>= \case
(FRSndIds sId rIds, body) -> noFile body (sId, rIds)
(r, _) -> throwE $ unexpectedResponse r
(r, _) -> throwError . PCEUnexpectedResponse $ bshow r
addXFTPRecipients :: XFTPClient -> C.APrivateAuthKey -> XFTPFileId -> NonEmpty C.APublicAuthKey -> ExceptT XFTPClientError IO (NonEmpty RecipientId)
addXFTPRecipients c spKey fId rcps =
sendXFTPCommand c spKey fId (FADD rcps) Nothing >>= \case
(FRRcvIds rIds, body) -> noFile body rIds
(r, _) -> throwE $ unexpectedResponse r
(r, _) -> throwError . PCEUnexpectedResponse $ bshow r
uploadXFTPChunk :: XFTPClient -> C.APrivateAuthKey -> XFTPFileId -> XFTPChunkSpec -> ExceptT XFTPClientError IO ()
uploadXFTPChunk c spKey fId chunkSpec =
@@ -251,19 +247,14 @@ downloadXFTPChunk g c@XFTPClient {config} rpKey fId chunkSpec@XFTPRcvChunkSpec {
let dhSecret = C.dh' sDhKey rpDhKey
cbState <- liftEither . first PCECryptoError $ LC.cbInit dhSecret cbNonce
let t = chunkTimeout config chunkSize
ExceptT (sequence <$> (t `timeout` (download cbState `catches` errors))) >>= maybe (throwError PCEResponseTimeout) pure
ExceptT (sequence <$> (t `timeout` download cbState)) >>= maybe (throwError PCEResponseTimeout) pure
where
errors =
[ Handler $ \(_e :: H.HTTP2Error) -> pure $ Left PCENetworkError,
Handler $ \(e :: IOException) -> pure $ Left (PCEIOError e),
Handler $ \(_e :: SomeException) -> pure $ Left PCENetworkError
]
download cbState =
runExceptT . withExceptT PCEResponseError $
receiveEncFile chunkPart cbState chunkSpec `catchError` \e ->
whenM (doesFileExist filePath) (removeFile filePath) >> throwError e
_ -> throwError $ PCEResponseError NO_FILE
(r, _) -> throwE $ unexpectedResponse r
(r, _) -> throwError . PCEUnexpectedResponse $ bshow r
xftpReqTimeout :: XFTPClientConfig -> Maybe Word32 -> Int
xftpReqTimeout cfg@XFTPClientConfig {xftpNetworkConfig = NetworkConfig {tcpTimeout}} chunkSize_ =
@@ -287,12 +278,12 @@ pingXFTP c@XFTPClient {thParams} = do
(r, _) <- sendXFTPTransmission c t Nothing
case r of
FRPong -> pure ()
_ -> throwE $ unexpectedResponse r
_ -> throwError $ PCEUnexpectedResponse $ bshow r
okResponse :: (FileResponse, HTTP2Body) -> ExceptT XFTPClientError IO ()
okResponse = \case
(FROk, body) -> noFile body ()
(r, _) -> throwE $ unexpectedResponse r
(r, _) -> throwError . PCEUnexpectedResponse $ bshow r
-- TODO this currently does not check anything because response size is not set and bodyPart is always Just
noFile :: HTTP2Body -> a -> ExceptT XFTPClientError IO a
+1
View File
@@ -18,6 +18,7 @@ import Data.Text.Encoding (decodeUtf8)
import Simplex.FileTransfer.Client
import Simplex.Messaging.Agent.RetryInterval
import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientError (..), temporaryClientError)
import Simplex.Messaging.Client.Agent ()
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol (ProtocolServer (..), XFTPServer)
import Simplex.Messaging.TMap (TMap)
+3 -3
View File
@@ -332,7 +332,7 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re
(sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
rKeys <- atomically $ L.fromList <$> replicateM numRecipients (C.generateAuthKeyPair C.SEd25519 g)
digest <- liftIO $ getChunkDigest chunkSpec
let ch = FileInfo {sndKey, size = chunkSize, digest}
let ch = FileInfo {sndKey, size = fromIntegral chunkSize, digest}
c <- withRetry retryCount $ getXFTPServerClient a xftpServer
(sndId, rIds) <- withRetry retryCount $ createXFTPChunk c spKey ch (L.map fst rKeys) auth
withReconnect a xftpServer retryCount $ \c' -> uploadXFTPChunk c' spKey sndId chunkSpec
@@ -344,7 +344,7 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re
when verbose $ putStrLn ""
let recipients = L.toList $ L.map ChunkReplicaId rIds `L.zip` L.map snd rKeys
replicas = [SentFileChunkReplica {server = xftpServer, recipients}]
pure (chunkNo, SentFileChunk {chunkNo, sndId, sndPrivateKey = spKey, chunkSize = FileSize chunkSize, digest = FileDigest digest, replicas})
pure (chunkNo, SentFileChunk {chunkNo, sndId, sndPrivateKey = spKey, chunkSize = FileSize $ fromIntegral chunkSize, digest = FileDigest digest, replicas})
getXFTPServer :: TVar StdGen -> NonEmpty XFTPServerWithAuth -> IO XFTPServerWithAuth
getXFTPServer gen = \case
srv :| [] -> pure srv
@@ -563,7 +563,7 @@ prepareChunkSpecs filePath chunkSizes = reverse . snd $ foldl' addSpec (0, []) c
where
addSpec :: (Int64, [XFTPChunkSpec]) -> Word32 -> (Int64, [XFTPChunkSpec])
addSpec (chunkOffset, specs) sz =
let spec = XFTPChunkSpec {filePath, chunkOffset, chunkSize = sz}
let spec = XFTPChunkSpec {filePath, chunkOffset, chunkSize = fromIntegral sz}
in (chunkOffset + fromIntegral sz, spec : specs)
getEncPath :: MonadIO m => Maybe FilePath -> String -> m FilePath
+14 -19
View File
@@ -63,7 +63,7 @@ import Simplex.Messaging.Transport.HTTP2.File (fileBlockSize)
import Simplex.Messaging.Transport.HTTP2.Server
import Simplex.Messaging.Transport.Server (runTCPServer, tlsServerCredentials)
import Simplex.Messaging.Util
import Simplex.Messaging.Version
import Simplex.Messaging.Version (isCompatible)
import System.Exit (exitFailure)
import System.FilePath ((</>))
import System.IO (hPrint, hPutStrLn, universalNewlineMode)
@@ -91,10 +91,10 @@ runXFTPServerBlocking started cfg = newXFTPServerEnv cfg >>= runReaderT (xftpSer
data Handshake
= HandshakeSent C.PrivateKeyX25519
| HandshakeAccepted (THandleParams XFTPVersion 'TServer)
| HandshakeAccepted (THandleAuth 'TServer) VersionXFTP
xftpServer :: XFTPServerConfig -> TMVar Bool -> M ()
xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpiration, fileExpiration, xftpServerVRange} started = do
xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpiration, fileExpiration} started = do
mapM_ (expireServerFiles Nothing) fileExpiration
restoreServerStats
raceAny_ (runServer : expireFilesThread_ cfg <> serverStatsThread_ cfg <> controlPortThread_ cfg) `finally` stopServer
@@ -111,9 +111,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
let cleanup sessionId = atomically $ TM.delete sessionId sessions
liftIO . runHTTP2Server started xftpPort defaultHTTP2BufferSize serverParams transportConfig inactiveClientExpiration cleanup $ \sessionId sessionALPN r sendResponse -> do
reqBody <- getHTTP2Body r xftpBlockSize
let v = VersionXFTP 1
thServerVRange = versionToRange v
thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = v, thServerVRange, thAuth = Nothing, implySessId = False, batch = True}
let thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = VersionXFTP 1, thAuth = Nothing, implySessId = False, batch = True}
req0 = XFTPTransportRequest {thParams = thParams0, request = r, reqBody, sendResponse}
flip runReaderT env $ case sessionALPN of
Nothing -> processRequest req0
@@ -123,12 +121,12 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
Just thParams -> processRequest req0 {thParams} -- proceed with new version (XXX: may as well switch the request handler here)
_ -> liftIO . sendResponse $ H.responseNoBody N.ok200 [] -- shouldn't happen: means server picked handshake protocol it doesn't know about
xftpServerHandshakeV1 :: X.CertificateChain -> C.APrivateSignKey -> TMap SessionId Handshake -> XFTPTransportRequest -> M (Maybe (THandleParams XFTPVersion 'TServer))
xftpServerHandshakeV1 chain serverSignKey sessions XFTPTransportRequest {thParams = thParams0@THandleParams {sessionId}, reqBody = HTTP2Body {bodyHead}, sendResponse} = do
xftpServerHandshakeV1 chain serverSignKey sessions XFTPTransportRequest {thParams = thParams@THandleParams {sessionId}, reqBody = HTTP2Body {bodyHead}, sendResponse} = do
s <- atomically $ TM.lookup sessionId sessions
r <- runExceptT $ case s of
Nothing -> processHello
Just (HandshakeSent pk) -> processClientHandshake pk
Just (HandshakeAccepted thParams) -> pure $ Just thParams
Just (HandshakeAccepted auth v) -> pure $ Just thParams {thAuth = Just auth, thVersion = v}
either sendError pure r
where
processHello = do
@@ -136,24 +134,21 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
(k, pk) <- atomically . C.generateKeyPair =<< asks random
atomically $ TM.insert sessionId (HandshakeSent pk) sessions
let authPubKey = (chain, C.signX509 serverSignKey $ C.publicToX509 k)
let hs = XFTPServerHandshake {xftpVersionRange = xftpServerVRange, sessionId, authPubKey}
let hs = XFTPServerHandshake {xftpVersionRange = supportedFileServerVRange, sessionId, authPubKey}
shs <- encodeXftp hs
liftIO . sendResponse $ H.responseBuilder N.ok200 [] shs
pure Nothing
processClientHandshake pk = do
unless (B.length bodyHead == xftpBlockSize) $ throwError HANDSHAKE
body <- liftHS $ C.unPad bodyHead
XFTPClientHandshake {xftpVersion = v, keyHash} <- liftHS $ smpDecode body
XFTPClientHandshake {xftpVersion, keyHash} <- liftHS $ smpDecode body
kh <- asks serverIdentity
unless (keyHash == kh) $ throwError HANDSHAKE
case compatibleVRange' xftpServerVRange v of
Just (Compatible vr) -> do
let auth = THAuthServer {serverPrivKey = pk, sessSecret' = Nothing}
thParams = thParams0 {thAuth = Just auth, thVersion = v, thServerVRange = vr}
atomically $ TM.insert sessionId (HandshakeAccepted thParams) sessions
liftIO . sendResponse $ H.responseNoBody N.ok200 []
pure Nothing
Nothing -> throwError HANDSHAKE
unless (xftpVersion `isCompatible` supportedFileServerVRange) $ throwError HANDSHAKE
let auth = THAuthServer {serverPrivKey = pk, sessSecret' = Nothing}
atomically $ TM.insert sessionId (HandshakeAccepted auth xftpVersion) sessions
liftIO . sendResponse $ H.responseNoBody N.ok200 []
pure Nothing
sendError :: XFTPErrorType -> M (Maybe (THandleParams XFTPVersion 'TServer))
sendError err = do
runExceptT (encodeXftp err) >>= \case
@@ -326,7 +321,7 @@ processRequest XFTPTransportRequest {thParams, reqBody = body@HTTP2Body {bodyHea
send $ byteString t
-- timeout sending file in the same way as receiving
forM_ serverFile_ $ \ServerFile {filePath, fileSize, sbState} -> do
withFile filePath ReadMode $ \h -> sendEncFile h send sbState fileSize
withFile filePath ReadMode $ \h -> sendEncFile h send sbState (fromIntegral fileSize)
done
data VerificationResult = VRVerified XFTPRequest | VRFailed
+15 -5
View File
@@ -13,9 +13,12 @@ import Control.Logger.Simple
import Control.Monad
import Control.Monad.IO.Unlift
import Crypto.Random
import Data.Default (def)
import Data.Int (Int64)
import Data.List (find)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe)
import Data.Time.Clock (getCurrentTime)
import Data.Word (Word32)
import Data.X509.Validation (Fingerprint (..))
@@ -25,7 +28,6 @@ import Simplex.FileTransfer.Protocol (FileCmd, FileInfo (..), XFTPFileId)
import Simplex.FileTransfer.Server.Stats
import Simplex.FileTransfer.Server.Store
import Simplex.FileTransfer.Server.StoreLog
import Simplex.FileTransfer.Transport (VersionRangeXFTP)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Protocol (BasicAuth, RcvPublicAuthKey)
import Simplex.Messaging.Server.Expiration
@@ -62,8 +64,6 @@ data XFTPServerConfig = XFTPServerConfig
caCertificateFile :: FilePath,
privateKeyFile :: FilePath,
certificateFile :: FilePath,
-- | XFTP client-server protocol version range
xftpServerVRange :: VersionRangeXFTP,
-- stats config - see SMP server config
logStatsInterval :: Maybe Int64,
logStatsStartTime :: Int64,
@@ -103,7 +103,7 @@ supportedXFTPhandshakes :: [ALPN]
supportedXFTPhandshakes = ["xftp/1"]
newXFTPServerEnv :: XFTPServerConfig -> IO XFTPEnv
newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, caCertificateFile, certificateFile, privateKeyFile, transportConfig} = do
newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, caCertificateFile, certificateFile, privateKeyFile} = do
random <- liftIO C.newRandom
store <- atomically newFileStore
storeLog <- liftIO $ mapM (`readWriteFileStore` store) storeLogFile
@@ -112,7 +112,17 @@ newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, caCertifi
forM_ fileSizeQuota $ \quota -> do
logInfo $ "Total / available storage: " <> tshow quota <> " / " <> tshow (quota - used)
when (quota < used) $ logInfo "WARNING: storage quota is less than used storage, no files can be uploaded!"
tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile (alpn transportConfig)
tlsServerParams' <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile
let TransportServerConfig {alpn} = transportConfig config
let tlsServerParams = case alpn of
Nothing -> tlsServerParams'
Just supported ->
tlsServerParams'
{ T.serverHooks =
def
{ T.onALPNClientSuggest = Just $ pure . fromMaybe "" . find (`elem` supported)
}
}
Fingerprint fp <- liftIO $ loadFingerprint caCertificateFile
serverStats <- atomically . newFileServerStats =<< liftIO getCurrentTime
pure XFTPEnv {config, store, storeLog, random, tlsServerParams, serverIdentity = C.KeyHash fp, serverStats}
+2 -5
View File
@@ -19,8 +19,7 @@ import Options.Applicative
import Simplex.FileTransfer.Chunks
import Simplex.FileTransfer.Description (FileSize (..))
import Simplex.FileTransfer.Server (runXFTPServer)
import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defFileExpirationHours, defaultFileExpiration, defaultInactiveClientExpiration, supportedXFTPhandshakes)
import Simplex.FileTransfer.Transport (supportedFileServerVRange)
import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defFileExpirationHours, defaultFileExpiration, defaultInactiveClientExpiration)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern XFTPServer)
@@ -175,15 +174,13 @@ xftpServerCLI cfgPath logPath = do
caCertificateFile = c caCrtFile,
privateKeyFile = c serverKeyFile,
certificateFile = c serverCrtFile,
xftpServerVRange = supportedFileServerVRange,
logStatsInterval = logStats $> 86400, -- seconds
logStatsStartTime = 0, -- seconds from 00:00 UTC
serverStatsLogFile = combine logPath "file-server-stats.daily.log",
serverStatsBackupFile = logStats $> combine logPath "file-server-stats.log",
transportConfig =
defaultTransportServerConfig
{ logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini,
alpn = Just supportedXFTPhandshakes
{ logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini
}
}
+2 -7
View File
@@ -37,7 +37,6 @@ import qualified Control.Exception as E
import Control.Monad
import Control.Monad.Except
import Control.Monad.IO.Class
import Control.Monad.Trans.Except
import qualified Data.Aeson.TH as J
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.Bifunctor (bimap, first)
@@ -54,7 +53,7 @@ import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers
import Simplex.Messaging.Protocol (CommandError)
import Simplex.Messaging.Transport (SessionId, THandle (..), THandleParams (..), TransportError (..), TransportPeer (..))
import Simplex.Messaging.Transport (HandshakeError (..), SessionId, THandle (..), THandleParams (..), TransportError (..), TransportPeer (..))
import Simplex.Messaging.Transport.HTTP2.File
import Simplex.Messaging.Util (bshow)
import Simplex.Messaging.Version
@@ -96,7 +95,7 @@ supportedFileServerVRange = mkVersionRange initialXFTPVersion currentXFTPVersion
-- XFTP protocol does not use this handshake method
xftpClientHandshakeStub :: c -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRangeXFTP -> ExceptT TransportError IO (THandle XFTPVersion c 'TClient)
xftpClientHandshakeStub _c _ks _keyHash _xftpVRange = throwE TEVersion
xftpClientHandshakeStub _c _ks _keyHash _xftpVRange = throwError $ TEHandshake VERSION
data XFTPServerHandshake = XFTPServerHandshake
{ xftpVersionRange :: VersionRangeXFTP,
@@ -217,8 +216,6 @@ data XFTPErrorType
TIMEOUT
| -- | bad redirect data
REDIRECT {redirectError :: String}
| -- | cannot proceed with download from not approved relays without proxy
NOT_APPROVED
| -- | internal server error
INTERNAL
| -- | used internally, never returned by the server (to be removed)
@@ -251,7 +248,6 @@ instance Encoding XFTPErrorType where
FILE_IO -> "FILE_IO"
TIMEOUT -> "TIMEOUT"
REDIRECT err -> "REDIRECT " <> smpEncode err
NOT_APPROVED -> "NOT_APPROVED"
INTERNAL -> "INTERNAL"
DUPLICATE_ -> "DUPLICATE_"
@@ -271,7 +267,6 @@ instance Encoding XFTPErrorType where
"FILE_IO" -> pure FILE_IO
"TIMEOUT" -> pure TIMEOUT
"REDIRECT" -> REDIRECT <$> _smpP
"NOT_APPROVED" -> pure NOT_APPROVED
"INTERNAL" -> pure INTERNAL
"DUPLICATE_" -> pure DUPLICATE_
_ -> fail "bad error type"
File diff suppressed because it is too large Load Diff
File diff suppressed because it is too large Load Diff
+18 -9
View File
@@ -54,8 +54,9 @@ import Simplex.Messaging.Agent.RetryInterval
import Simplex.Messaging.Agent.Store.SQLite
import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
import Simplex.Messaging.Client
import Simplex.Messaging.Client.Agent ()
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.Ratchet (VersionRangeE2E, supportedE2EEncryptVRange)
import Simplex.Messaging.Crypto.Ratchet (PQSupport, VersionRangeE2E, supportedE2EEncryptVRange)
import Simplex.Messaging.Notifications.Client (defaultNTFClientConfig)
import Simplex.Messaging.Notifications.Transport (NTFVersion)
import Simplex.Messaging.Notifications.Types
@@ -91,17 +92,16 @@ data AgentConfig = AgentConfig
xftpCfg :: XFTPClientConfig,
reconnectInterval :: RetryInterval,
messageRetryInterval :: RetryInterval2,
userNetworkInterval :: Int,
userOfflineDelay :: NominalDiffTime,
userNetworkInterval :: RetryInterval,
messageTimeout :: NominalDiffTime,
connDeleteDeliveryTimeout :: NominalDiffTime,
helloTimeout :: NominalDiffTime,
quotaExceededTimeout :: NominalDiffTime,
persistErrorInterval :: NominalDiffTime,
initialCleanupDelay :: Int64,
cleanupInterval :: Int64,
cleanupStepInterval :: Int,
maxWorkerRestartsPerMin :: Int,
maxSubscriptionTimeouts :: Int,
storedMsgDataTTL :: NominalDiffTime,
rcvFilesTTL :: NominalDiffTime,
sndFilesTTL :: NominalDiffTime,
@@ -117,8 +117,8 @@ data AgentConfig = AgentConfig
caCertificateFile :: FilePath,
privateKeyFile :: FilePath,
certificateFile :: FilePath,
e2eEncryptVRange :: VersionRangeE2E,
smpAgentVRange :: VersionRangeSMPA,
e2eEncryptVRange :: PQSupport -> VersionRangeE2E,
smpAgentVRange :: PQSupport -> VersionRangeSMPA,
smpClientVRange :: VersionRangeSMPC
}
@@ -147,6 +147,14 @@ defaultMessageRetryInterval =
}
}
defaultUserNetworkInterval :: RetryInterval
defaultUserNetworkInterval =
RetryInterval
{ initialInterval = 1200_000000, -- 20 minutes
increaseAfter = 0,
maxInterval = 7200_000000 -- 2 hours
}
defaultAgentConfig :: AgentConfig
defaultAgentConfig =
AgentConfig
@@ -162,17 +170,18 @@ defaultAgentConfig =
xftpCfg = defaultXFTPClientConfig,
reconnectInterval = defaultReconnectInterval,
messageRetryInterval = defaultMessageRetryInterval,
userNetworkInterval = 1800_000000, -- 30 minutes, should be less than Int32 max value
userOfflineDelay = 2, -- if network offline event happens in less than 2 seconds after it was set online, it is ignored
userNetworkInterval = defaultUserNetworkInterval,
messageTimeout = 2 * nominalDay,
connDeleteDeliveryTimeout = 2 * nominalDay,
helloTimeout = 2 * nominalDay,
quotaExceededTimeout = 7 * nominalDay,
persistErrorInterval = 3, -- seconds
initialCleanupDelay = 30 * 1000000, -- 30 seconds
cleanupInterval = 30 * 60 * 1000000, -- 30 minutes
cleanupStepInterval = 200000, -- 200ms
maxWorkerRestartsPerMin = 5,
-- 3 consecutive subscription timeouts will result in alert to the user
-- this is a fallback, as the timeout set to 3x of expected timeout, to avoid potential locking.
maxSubscriptionTimeouts = 3,
storedMsgDataTTL = 21 * nominalDay,
rcvFilesTTL = 2 * nominalDay,
sndFilesTTL = nominalDay,
+5 -5
View File
@@ -12,8 +12,6 @@ import Control.Monad (void)
import Control.Monad.Except (ExceptT (..), runExceptT)
import Control.Monad.IO.Unlift
import Data.Functor (($>))
import Data.Set (Set)
import qualified Data.Set as S
import UnliftIO.Async (forConcurrently)
import qualified UnliftIO.Exception as E
import UnliftIO.STM
@@ -41,11 +39,13 @@ withGetLock getLock key name a =
(atomically . takeTMVar)
(const a)
withGetLocks :: MonadUnliftIO m => (k -> STM Lock) -> Set k -> String -> m a -> m a
withGetLocks :: MonadUnliftIO m => (k -> STM Lock) -> [k] -> String -> m a -> m a
withGetLocks getLock keys name = E.bracket holdLocks releaseLocks . const
where
holdLocks = forConcurrently (S.toList keys) $ \key -> atomically $ getPutLock getLock key name
releaseLocks = mapM_ (atomically . takeTMVar)
holdLocks = forConcurrently keys $ \key -> atomically $ getPutLock getLock key name
-- only this withGetLocks would be holding the locks,
-- so it's safe to combine all lock releases into one transaction
releaseLocks = atomically . mapM_ takeTMVar
-- getLock and putTMVar can be in one transaction on the assumption that getLock doesn't write in case the lock already exists,
-- and in case it is created and added to some shared resource (we use TMap) it also helps avoid contention for the newly created lock.
@@ -33,6 +33,7 @@ import Simplex.Messaging.Agent.Protocol (ACommand (..), APartyCmd (..), AgentErr
import Simplex.Messaging.Agent.RetryInterval
import Simplex.Messaging.Agent.Store
import Simplex.Messaging.Agent.Store.SQLite
import Simplex.Messaging.Client.Agent ()
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Notifications.Protocol (NtfSubStatus (..), NtfTknStatus (..), SMPQueueNtf (..))
import Simplex.Messaging.Notifications.Types
@@ -160,7 +161,7 @@ runNtfWorker c srv Worker {doWork} = do
logInfo $ "runNtfWorker, nextSub " <> tshow nextSub
ri <- asks $ reconnectInterval . config
withRetryInterval ri $ \_ loop -> do
liftIO $ waitForUserNetwork c
lift $ waitForUserNetwork c
processSub nextSub
`catchAgentError` retryOnError c "NtfWorker" loop (workerInternalError c connId . show)
processSub :: (NtfSubscription, NtfSubNTFAction, NtfActionTs) -> AM ()
@@ -244,7 +245,7 @@ runNtfSMPWorker c srv Worker {doWork} = do
logInfo $ "runNtfSMPWorker, nextSub " <> tshow nextSub
ri <- asks $ reconnectInterval . config
withRetryInterval ri $ \_ loop -> do
liftIO $ waitForUserNetwork c
lift $ waitForUserNetwork c
processSub nextSub
`catchAgentError` retryOnError c "NtfSMPWorker" loop (workerInternalError c connId . show)
processSub :: (NtfSubscription, NtfSubSMPAction, NtfActionTs) -> AM ()
+90 -100
View File
@@ -44,7 +44,7 @@ module Simplex.Messaging.Agent.Protocol
currentSMPAgentVersion,
supportedSMPAgentVRange,
e2eEncConnInfoLength,
e2eEncAgentMsgLength,
e2eEncUserMsgLength,
-- * SMP agent protocol types
ConnInfo,
@@ -157,8 +157,8 @@ where
import Control.Applicative (optional, (<|>))
import Control.Monad (unless)
import Control.Monad.Except (runExceptT, throwError)
import Control.Monad.IO.Class
import Control.Monad.Trans.Except
import Data.Aeson (FromJSON (..), ToJSON (..))
import qualified Data.Aeson.TH as J
import Data.Attoparsec.ByteString.Char8 (Parser)
@@ -189,25 +189,23 @@ import Simplex.FileTransfer.Description
import Simplex.FileTransfer.Protocol (FileParty (..))
import Simplex.FileTransfer.Transport (XFTPErrorType)
import Simplex.Messaging.Agent.QueryString
import Simplex.Messaging.Client (ProxyClientError)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.Ratchet
( InitialKeys (..),
PQEncryption (..),
pattern PQEncOff,
PQSupport,
pattern PQSupportOn,
pattern PQSupportOff,
RcvE2ERatchetParams,
RcvE2ERatchetParamsUri,
SndE2ERatchetParams,
pattern PQEncOff,
pattern PQSupportOff,
pattern PQSupportOn,
SndE2ERatchetParams
)
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers
import Simplex.Messaging.Protocol
( AProtocolType,
BrokerErrorType (..),
EntityId,
ErrorType,
MsgBody,
@@ -215,14 +213,14 @@ import Simplex.Messaging.Protocol
MsgId,
NMsgMeta,
ProtocolServer (..),
SMPClientVersion,
SMPMsgMeta,
SMPServer,
SMPServerWithAuth,
SndPublicAuthKey,
SubscriptionMode,
VersionRangeSMPC,
SMPClientVersion,
VersionSMPC,
VersionRangeSMPC,
initialSMPClientVersion,
legacyEncodeServer,
legacyServerP,
@@ -235,7 +233,7 @@ import Simplex.Messaging.Protocol
)
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.ServiceScheme
import Simplex.Messaging.Transport (Transport (..))
import Simplex.Messaging.Transport (Transport (..), TransportError, serializeTransportError, transportErrorP)
import Simplex.Messaging.Transport.Client (TransportHost, TransportHosts_ (..))
import Simplex.Messaging.Util
import Simplex.Messaging.Version
@@ -274,11 +272,16 @@ deliveryRcptsSMPAgentVersion = VersionSMPA 4
pqdrSMPAgentVersion :: VersionSMPA
pqdrSMPAgentVersion = VersionSMPA 5
-- TODO v5.7 increase to 5
currentSMPAgentVersion :: VersionSMPA
currentSMPAgentVersion = VersionSMPA 5
currentSMPAgentVersion = VersionSMPA 4
supportedSMPAgentVRange :: VersionRangeSMPA
supportedSMPAgentVRange = mkVersionRange duplexHandshakeSMPAgentVersion currentSMPAgentVersion
-- TODO v5.7 remove dependency of version range on whether PQ support is needed
supportedSMPAgentVRange :: PQSupport -> VersionRangeSMPA
supportedSMPAgentVRange pq =
mkVersionRange duplexHandshakeSMPAgentVersion $ case pq of
PQSupportOn -> pqdrSMPAgentVersion
PQSupportOff -> currentSMPAgentVersion
-- it is shorter to allow all handshake headers,
-- including E2E (double-ratchet) parameters and
@@ -289,8 +292,8 @@ e2eEncConnInfoLength v = \case
PQSupportOn | v >= pqdrSMPAgentVersion -> 11122
_ -> 14848
e2eEncAgentMsgLength :: VersionSMPA -> PQSupport -> Int
e2eEncAgentMsgLength v = \case
e2eEncUserMsgLength :: VersionSMPA -> PQSupport -> Int
e2eEncUserMsgLength v = \case
-- reduced by 2222 (the increase of message ratchet header size)
PQSupportOn | v >= pqdrSMPAgentVersion -> 13634
_ -> 15856
@@ -395,8 +398,7 @@ data ACommand (p :: AParty) (e :: AEntity) where
RSYNC :: RatchetSyncState -> Maybe AgentCryptoError -> ConnectionStats -> ACommand Agent AEConn
SEND :: PQEncryption -> MsgFlags -> MsgBody -> ACommand Client AEConn
MID :: AgentMsgId -> PQEncryption -> ACommand Agent AEConn
SENT :: AgentMsgId -> Maybe SMPServer -> ACommand Agent AEConn
MWARN :: AgentMsgId -> AgentErrorType -> ACommand Agent AEConn
SENT :: AgentMsgId -> ACommand Agent AEConn
MERR :: AgentMsgId -> AgentErrorType -> ACommand Agent AEConn
MERRS :: NonEmpty AgentMsgId -> AgentErrorType -> ACommand Agent AEConn
MSG :: MsgMeta -> MsgFlags -> MsgBody -> ACommand Agent AEConn
@@ -460,7 +462,6 @@ data ACommandTag (p :: AParty) (e :: AEntity) where
SEND_ :: ACommandTag Client AEConn
MID_ :: ACommandTag Agent AEConn
SENT_ :: ACommandTag Agent AEConn
MWARN_ :: ACommandTag Agent AEConn
MERR_ :: ACommandTag Agent AEConn
MERRS_ :: ACommandTag Agent AEConn
MSG_ :: ACommandTag Agent AEConn
@@ -516,8 +517,7 @@ aCommandTag = \case
RSYNC {} -> RSYNC_
SEND {} -> SEND_
MID {} -> MID_
SENT {} -> SENT_
MWARN {} -> MWARN_
SENT _ -> SENT_
MERR {} -> MERR_
MERRS {} -> MERRS_
MSG {} -> MSG_
@@ -913,7 +913,7 @@ instance Encoding AgentMsgEnvelope where
-- AgentRatchetInfo is not encrypted with double ratchet, but with per-queue E2E encryption
data AgentMessage
= -- used by the initiating party when confirming reply queue
AgentConnInfo ConnInfo
AgentConnInfo ConnInfo
| -- AgentConnInfoReply is used by accepting party in duplexHandshake mode (v2), allowing to include reply queue(s) in the initial confirmation.
-- It made removed REPLY message unnecessary.
AgentConnInfoReply (NonEmpty SMPQueueInfo) ConnInfo
@@ -1305,7 +1305,6 @@ instance VersionRangeI SMPClientVersion SMPQueueUri where
type VersionT SMPClientVersion SMPQueueUri = SMPQueueInfo
versionRange = clientVRange
toVersionT (SMPQueueUri _vr addr) v = SMPQueueInfo v addr
toVersionRange (SMPQueueUri _vr addr) vr = SMPQueueUri vr addr
-- | SMP queue information sent out-of-band.
--
@@ -1388,9 +1387,9 @@ deriving instance Show (ConnectionRequestUri m)
data AConnectionRequestUri = forall m. ConnectionModeI m => ACR (SConnectionMode m) (ConnectionRequestUri m)
instance Eq AConnectionRequestUri where
ACR m cr == ACR m' cr' = case testEquality m m' of
Just Refl -> cr == cr'
_ -> False
ACR m cr == ACR m' cr' = case testEquality m m' of
Just Refl -> cr == cr'
_ -> False
deriving instance Show AConnectionRequestUri
@@ -1471,17 +1470,15 @@ instance StrEncoding MsgErrorType where
-- | Error type used in errors sent to agent clients.
data AgentErrorType
= -- | command or response error
CMD {cmdErr :: CommandErrorType, errContext :: String}
CMD {cmdErr :: CommandErrorType}
| -- | connection errors
CONN {connErr :: ConnectionErrorType}
| -- | SMP protocol errors forwarded to agent clients
SMP {serverAddress :: String, smpErr :: ErrorType}
SMP {smpErr :: ErrorType}
| -- | NTF protocol errors forwarded to agent clients
NTF {serverAddress :: String, ntfErr :: ErrorType}
NTF {ntfErr :: ErrorType}
| -- | XFTP protocol errors forwarded to agent clients
XFTP {serverAddress :: String, xftpErr :: XFTPErrorType}
| -- | SMP proxy errors
PROXY {proxyServer :: String, relayServer :: String, proxyErr :: ProxyClientError}
XFTP {xftpErr :: XFTPErrorType}
| -- | XRCP protocol errors forwarded to agent clients
RCP {rcpErr :: RCErrorType}
| -- | SMP server errors
@@ -1524,12 +1521,28 @@ data ConnectionErrorType
NOT_AVAILABLE
deriving (Eq, Read, Show, Exception)
-- | SMP server errors.
data BrokerErrorType
= -- | invalid server response (failed to parse)
RESPONSE {smpErr :: String}
| -- | unexpected response
UNEXPECTED
| -- | network error
NETWORK
| -- | no compatible server host (e.g. onion when public is required, or vice versa)
HOST
| -- | handshake or other transport error
TRANSPORT {transportErr :: TransportError}
| -- | command response timeout
TIMEOUT
deriving (Eq, Read, Show, Exception)
-- | Errors of another SMP agent.
data SMPAgentError
= -- | client or agent message that failed to parse
A_MESSAGE
| -- | prohibited SMP/agent message
A_PROHIBITED {prohibitedErr :: String}
A_PROHIBITED
| -- | incompatible version of SMP client, agent or encryption protocols
A_VERSION
| -- | cannot decrypt message
@@ -1558,14 +1571,12 @@ data AgentCryptoError
instance StrEncoding AgentCryptoError where
strP =
A.takeTill (== ' ') >>= \case
"DECRYPT_AES" -> pure DECRYPT_AES
"DECRYPT_CB" -> pure DECRYPT_CB
"RATCHET_HEADER" -> pure RATCHET_HEADER
"RATCHET_EARLIER" -> RATCHET_EARLIER <$> _strP
"RATCHET_SKIPPED" -> RATCHET_SKIPPED <$> _strP
"RATCHET_SYNC" -> pure RATCHET_SYNC
_ -> fail "AgentCryptoError"
"DECRYPT_AES" $> DECRYPT_AES
<|> "DECRYPT_CB" $> DECRYPT_CB
<|> "RATCHET_HEADER" $> RATCHET_HEADER
<|> "RATCHET_EARLIER " *> (RATCHET_EARLIER <$> strP)
<|> "RATCHET_SKIPPED " *> (RATCHET_SKIPPED <$> strP)
<|> "RATCHET_SYNC" $> RATCHET_SYNC
strEncode = \case
DECRYPT_AES -> "DECRYPT_AES"
DECRYPT_CB -> "DECRYPT_CB"
@@ -1576,61 +1587,42 @@ instance StrEncoding AgentCryptoError where
instance StrEncoding AgentErrorType where
strP =
A.takeTill (== ' ')
>>= \case
"CMD" -> CMD <$> (A.space *> parseRead1) <*> (A.space *> textP)
"CONN" -> CONN <$> (A.space *> parseRead1)
"SMP" -> SMP <$> (A.space *> srvP) <*> _strP
"NTF" -> NTF <$> (A.space *> srvP) <*> _strP
"XFTP" -> XFTP <$> (A.space *> srvP) <*> _strP
"PROXY" -> PROXY <$> (A.space *> srvP) <* A.space <*> srvP <*> _strP
"RCP" -> RCP <$> _strP
"BROKER" -> BROKER <$> (A.space *> srvP) <*> _strP
"AGENT" -> AGENT <$> _strP
"INTERNAL" -> INTERNAL <$> (A.space *> textP)
"CRITICAL" -> CRITICAL <$> (A.space *> parseRead1) <*> (A.space *> textP)
"INACTIVE" -> pure INACTIVE
_ -> fail "bad AgentErrorType"
"CMD " *> (CMD <$> parseRead1)
<|> "CONN " *> (CONN <$> parseRead1)
<|> "SMP " *> (SMP <$> strP)
<|> "NTF " *> (NTF <$> strP)
<|> "XFTP " *> (XFTP <$> strP)
<|> "RCP " *> (RCP <$> strP)
<|> "BROKER " *> (BROKER <$> textP <* " RESPONSE " <*> (RESPONSE <$> textP))
<|> "BROKER " *> (BROKER <$> textP <* " TRANSPORT " <*> (TRANSPORT <$> transportErrorP))
<|> "BROKER " *> (BROKER <$> textP <* A.space <*> parseRead1)
<|> "AGENT CRYPTO " *> (AGENT . A_CRYPTO <$> parseRead A.takeByteString)
<|> "AGENT QUEUE " *> (AGENT . A_QUEUE <$> parseRead A.takeByteString)
<|> "AGENT " *> (AGENT <$> parseRead1)
<|> "INTERNAL " *> (INTERNAL <$> parseRead A.takeByteString)
<|> "CRITICAL " *> (CRITICAL <$> parseRead1 <* A.space <*> parseRead A.takeByteString)
<|> "INACTIVE" $> INACTIVE
where
srvP = T.unpack . safeDecodeUtf8 <$> A.takeTill (== ' ')
textP = T.unpack . safeDecodeUtf8 <$> A.takeTill (== ' ')
strEncode = \case
CMD e cxt -> "CMD " <> bshow e <> " " <> text cxt
CMD e -> "CMD " <> bshow e
CONN e -> "CONN " <> bshow e
SMP srv e -> "SMP " <> text srv <> " " <> strEncode e
NTF srv e -> "NTF " <> text srv <> " " <> strEncode e
XFTP srv e -> "XFTP " <> text srv <> " " <> strEncode e
PROXY pxy srv e -> B.unwords ["PROXY", text pxy, text srv, strEncode e]
SMP e -> "SMP " <> strEncode e
NTF e -> "NTF " <> strEncode e
XFTP e -> "XFTP " <> strEncode e
RCP e -> "RCP " <> strEncode e
BROKER srv e -> B.unwords ["BROKER", text srv, strEncode e]
AGENT e -> "AGENT " <> strEncode e
INTERNAL e -> "INTERNAL " <> encodeUtf8 (T.pack e)
CRITICAL restart e -> "CRITICAL " <> bshow restart <> " " <> encodeUtf8 (T.pack e)
BROKER srv (RESPONSE e) -> "BROKER " <> text srv <> " RESPONSE " <> text e
BROKER srv (TRANSPORT e) -> "BROKER " <> text srv <> " TRANSPORT " <> serializeTransportError e
BROKER srv e -> "BROKER " <> text srv <> " " <> bshow e
AGENT (A_CRYPTO e) -> "AGENT CRYPTO " <> bshow e
AGENT (A_QUEUE e) -> "AGENT QUEUE " <> bshow e
AGENT e -> "AGENT " <> bshow e
INTERNAL e -> "INTERNAL " <> bshow e
CRITICAL restart e -> "CRITICAL " <> bshow restart <> " " <> bshow e
INACTIVE -> "INACTIVE"
where
text = encodeUtf8 . T.pack
instance StrEncoding SMPAgentError where
strP =
A.takeTill (== ' ')
>>= \case
"MESSAGE" -> pure A_MESSAGE
"PROHIBITED" -> A_PROHIBITED <$> (A.space *> textP)
"VERSION" -> pure A_VERSION
"CRYPTO" -> A_CRYPTO <$> _strP
"DUPLICATE" -> pure A_DUPLICATE
"QUEUE" -> A_QUEUE <$> (A.space *> textP)
_ -> fail "bad SMPAgentError"
strEncode = \case
A_MESSAGE -> "MESSAGE"
A_PROHIBITED e -> "PROHIBITED " <> encodeUtf8 (T.pack e)
A_VERSION -> "VERSION"
A_CRYPTO e -> "CRYPTO " <> strEncode e
A_DUPLICATE -> "DUPLICATE"
A_QUEUE e -> "QUEUE " <> encodeUtf8 (T.pack e)
textP :: Parser String
textP = T.unpack . safeDecodeUtf8 <$> A.takeByteString
cryptoErrToSyncState :: AgentCryptoError -> RatchetSyncState
cryptoErrToSyncState = \case
DECRYPT_AES -> RSAllowed
@@ -1673,7 +1665,6 @@ instance StrEncoding ACmdTag where
"SEND" -> t SEND_
"MID" -> ct MID_
"SENT" -> ct SENT_
"MWARN" -> ct MWARN_
"MERR" -> ct MERR_
"MERRS" -> ct MERRS_
"MSG" -> ct MSG_
@@ -1732,7 +1723,6 @@ instance (APartyI p, AEntityI e) => StrEncoding (ACommandTag p e) where
SEND_ -> "SEND"
MID_ -> "MID"
SENT_ -> "SENT"
MWARN_ -> "MWARN"
MERR_ -> "MERR"
MERRS_ -> "MERRS"
MSG_ -> "MSG"
@@ -1803,8 +1793,7 @@ commandP binaryP =
SWITCH_ -> s (SWITCH <$> strP_ <*> strP_ <*> strP)
RSYNC_ -> s (RSYNC <$> strP_ <*> strP <*> strP)
MID_ -> s (MID <$> A.decimal <*> _strP)
SENT_ -> s (SENT <$> A.decimal <*> _strP)
MWARN_ -> s (MWARN <$> A.decimal <* A.space <*> strP)
SENT_ -> s (SENT <$> A.decimal)
MERR_ -> s (MERR <$> A.decimal <* A.space <*> strP)
MERRS_ -> s (MERRS <$> strP_ <*> strP)
MSG_ -> s (MSG <$> strP <* A.space <*> smpP <* A.space <*> binaryP)
@@ -1843,7 +1832,7 @@ commandP binaryP =
sd : rds -> SFDONE <$> strDecode (encodeUtf8 sd) <*> mapM (strDecode . encodeUtf8) rds
parseCommand :: ByteString -> Either AgentErrorType ACmd
parseCommand = parse (commandP A.takeByteString) $ CMD SYNTAX "parseCommand"
parseCommand = parse (commandP A.takeByteString) $ CMD SYNTAX
-- | Serialize SMP agent command.
serializeCommand :: ACommand p e -> ByteString
@@ -1867,8 +1856,7 @@ serializeCommand = \case
RSYNC rrState cryptoErr cstats -> s (RSYNC_, rrState, cryptoErr, cstats)
SEND pqEnc msgFlags msgBody -> B.unwords [s SEND_, s pqEnc, smpEncode msgFlags, serializeBinary msgBody]
MID mId pqEnc -> s (MID_, mId, pqEnc)
SENT mId proxySrv_ -> s (SENT_, mId, proxySrv_)
MWARN mId e -> s (MWARN_, mId, e)
SENT mId -> s (SENT_, mId)
MERR mId e -> s (MERR_, mId, e)
MERRS mIds e -> s (MERRS_, mIds, e)
MSG msgMeta msgFlags msgBody -> B.unwords [s MSG_, s msgMeta, smpEncode msgFlags, serializeBinary msgBody]
@@ -1933,7 +1921,7 @@ tGet party h = liftIO (tGetRaw h) >>= tParseLoadBody
fromParty :: ACmd -> Either AgentErrorType (APartyCmd p)
fromParty (ACmd (p :: p1) e cmd) = case testEquality party p of
Just Refl -> Right $ APC e cmd
_ -> Left $ CMD PROHIBITED "fromParty"
_ -> Left $ CMD PROHIBITED
tConnId :: ARawTransmission -> APartyCmd p -> Either AgentErrorType (APartyCmd p)
tConnId (_, entId, _) (APC e cmd) =
@@ -1951,7 +1939,7 @@ tGet party h = liftIO (tGetRaw h) >>= tParseLoadBody
SUSPENDED {} -> Right cmd
-- other responses must have connection ID
_
| B.null entId -> Left $ CMD NO_CONN "tConnId"
| B.null entId -> Left $ CMD NO_CONN
| otherwise -> Right cmd
cmdWithMsgBody :: APartyCmd p -> IO (Either AgentErrorType (APartyCmd p))
@@ -1974,11 +1962,11 @@ tGet party h = liftIO (tGetRaw h) >>= tParseLoadBody
str -> case readMaybe str :: Maybe Int of
Just size -> runExceptT $ do
body <- liftIO $ cGet h size
unless (B.length body == size) $ throwE $ CMD SIZE "getBody"
unless (B.length body == size) $ throwError $ CMD SIZE
s <- liftIO $ getLn h
unless (B.null s) $ throwE $ CMD SIZE "getBody"
unless (B.null s) $ throwError $ CMD SIZE
pure body
Nothing -> pure . Left $ CMD SYNTAX "getBody"
Nothing -> return . Left $ CMD SYNTAX
$(J.deriveJSON defaultJSON ''RcvQueueInfo)
@@ -1994,6 +1982,8 @@ $(J.deriveJSON (sumTypeJSON id) ''CommandErrorType)
$(J.deriveJSON (sumTypeJSON id) ''ConnectionErrorType)
$(J.deriveJSON (sumTypeJSON id) ''BrokerErrorType)
$(J.deriveJSON (sumTypeJSON id) ''AgentCryptoError)
$(J.deriveJSON (sumTypeJSON id) ''SMPAgentError)
+1 -1
View File
@@ -49,7 +49,7 @@ runSMPAgentBlocking (ATransport t) cfg@AgentConfig {tcpPort, caCertificateFile,
smpAgent :: forall c. Transport c => TProxy c -> ServiceName -> Env -> IO ()
smpAgent _ port env = do
-- tlsServerParams is not in Env to avoid breaking functional API w/t key and certificate generation
tlsServerParams <- loadTLSServerParams caCertificateFile certificateFile privateKeyFile Nothing
tlsServerParams <- loadTLSServerParams caCertificateFile certificateFile privateKeyFile
clientId <- newTVarIO initClientId
runTransportServer started port tlsServerParams defaultTransportServerConfig $ \(h :: c) -> do
putLn h $ "Welcome to SMP agent v" <> B.pack simplexMQVersion
+1 -3
View File
@@ -30,7 +30,7 @@ import Data.Type.Equality
import Simplex.Messaging.Agent.Protocol
import Simplex.Messaging.Agent.RetryInterval (RI2State)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.Ratchet (PQEncryption, PQSupport, RatchetX448)
import Simplex.Messaging.Crypto.Ratchet (RatchetX448, PQEncryption, PQSupport)
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol
( MsgBody,
@@ -593,8 +593,6 @@ type AsyncCmdId = Int64
data StoreError
= -- | IO exceptions in store actions.
SEInternal ByteString
| -- | Database busy
SEDatabaseBusy ByteString
| -- | Failed to generate unique random ID
SEUniqueID
| -- | User ID not found
+37 -46
View File
@@ -221,7 +221,6 @@ module Simplex.Messaging.Agent.Store.SQLite
)
where
import Control.Logger.Simple
import Control.Monad
import Control.Monad.Except
import Control.Monad.IO.Class
@@ -269,7 +268,7 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations (DownMigration (..), MTRE
import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
import Simplex.Messaging.Crypto.Ratchet (PQEncryption (..), PQSupport (..), RatchetX448, SkippedMsgDiff (..), SkippedMsgKeys)
import Simplex.Messaging.Crypto.Ratchet (RatchetX448, SkippedMsgDiff (..), SkippedMsgKeys, PQEncryption (..), PQSupport (..))
import qualified Simplex.Messaging.Crypto.Ratchet as CR
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
@@ -279,7 +278,7 @@ import Simplex.Messaging.Parsers (blobFieldParser, defaultJSON, dropPrefix, from
import Simplex.Messaging.Protocol
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Transport.Client (TransportHost)
import Simplex.Messaging.Util (bshow, catchAllErrors, eitherToMaybe, ifM, safeDecodeUtf8, tshow, ($>>=), (<$$>))
import Simplex.Messaging.Util (bshow, catchAllErrors, eitherToMaybe, ifM, safeDecodeUtf8, ($>>=), (<$$>))
import Simplex.Messaging.Version.Internal
import System.Directory (copyFile, createDirectoryIfMissing, doesFileExist)
import System.Exit (exitFailure)
@@ -287,7 +286,6 @@ import System.FilePath (takeDirectory)
import System.IO (hFlush, stdout)
import UnliftIO.Exception (bracketOnError, onException)
import qualified UnliftIO.Exception as E
import UnliftIO.MVar
import UnliftIO.STM
-- * SQLite Store implementation
@@ -383,8 +381,8 @@ connectSQLiteStore :: FilePath -> ScrubbedBytes -> Bool -> IO SQLiteStore
connectSQLiteStore dbFilePath key keepKey = do
dbNew <- not <$> doesFileExist dbFilePath
dbConn <- dbBusyLoop (connectDB dbFilePath key)
dbConnection <- newMVar dbConn
atomically $ do
dbConnection <- newTMVar dbConn
dbKey <- newTVar $! storeKey key keepKey
dbClosed <- newTVar False
pure SQLiteStore {dbFilePath, dbKey, dbConnection, dbNew, dbClosed}
@@ -422,14 +420,14 @@ openSQLiteStore st@SQLiteStore {dbClosed} key keepKey =
openSQLiteStore_ :: SQLiteStore -> ScrubbedBytes -> Bool -> IO ()
openSQLiteStore_ SQLiteStore {dbConnection, dbFilePath, dbKey, dbClosed} key keepKey =
bracketOnError
(takeMVar dbConnection)
(tryPutMVar dbConnection)
(atomically $ takeTMVar dbConnection)
(atomically . tryPutTMVar dbConnection)
$ \DB.Connection {slow} -> do
DB.Connection {conn} <- connectDB dbFilePath key
atomically $ do
putTMVar dbConnection DB.Connection {conn, slow}
writeTVar dbClosed False
writeTVar dbKey $! storeKey key keepKey
putMVar dbConnection DB.Connection {conn, slow}
reopenSQLiteStore :: SQLiteStore -> IO ()
reopenSQLiteStore st@SQLiteStore {dbKey, dbClosed} =
@@ -1274,16 +1272,12 @@ createCommand :: DB.Connection -> ACorrId -> ConnId -> Maybe SMPServer -> AgentC
createCommand db corrId connId srv_ cmd = runExceptT $ do
(host_, port_, serverKeyHash_) <- serverFields
createdAt <- liftIO getCurrentTime
liftIO . E.handle handleErr $
liftIO $
DB.execute
db
"INSERT INTO commands (host, port, corr_id, conn_id, command_tag, command, server_key_hash, created_at) VALUES (?,?,?,?,?,?,?,?)"
(host_, port_, corrId, connId, cmdTag, cmd, serverKeyHash_, createdAt)
(host_, port_, corrId, connId, agentCommandTag cmd, cmd, serverKeyHash_, createdAt)
where
cmdTag = agentCommandTag cmd
handleErr e
| SQL.sqlError e == SQL.ErrorConstraint = logError $ "tried to create command " <> tshow cmdTag <> " for deleted connection"
| otherwise = E.throwIO e
serverFields :: ExceptT StoreError IO (Maybe (NonEmpty TransportHost), Maybe ServiceName, Maybe C.KeyHash)
serverFields = case srv_ of
Just srv@(SMPServer host port _) ->
@@ -2275,20 +2269,20 @@ getXFTPServerId_ db ProtocolServer {host, port, keyHash} = do
firstRow fromOnly SEXFTPServerNotFound $
DB.query db "SELECT xftp_server_id FROM xftp_servers WHERE xftp_host = ? AND xftp_port = ? AND xftp_key_hash = ?" (host, port, keyHash)
createRcvFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> FileDescription 'FRecipient -> FilePath -> FilePath -> CryptoFile -> Bool -> IO (Either StoreError RcvFileId)
createRcvFile db gVar userId fd@FileDescription {chunks} prefixPath tmpPath file approvedRelays = runExceptT $ do
(rcvFileEntityId, rcvFileId) <- ExceptT $ insertRcvFile db gVar userId fd prefixPath tmpPath file Nothing Nothing approvedRelays
createRcvFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> FileDescription 'FRecipient -> FilePath -> FilePath -> CryptoFile -> IO (Either StoreError RcvFileId)
createRcvFile db gVar userId fd@FileDescription {chunks} prefixPath tmpPath file = runExceptT $ do
(rcvFileEntityId, rcvFileId) <- ExceptT $ insertRcvFile db gVar userId fd prefixPath tmpPath file Nothing Nothing
liftIO $
forM_ chunks $ \fc@FileChunk {replicas} -> do
chunkId <- insertRcvFileChunk db fc rcvFileId
forM_ (zip [1 ..] replicas) $ \(rno, replica) -> insertRcvFileChunkReplica db rno replica chunkId
pure rcvFileEntityId
createRcvFileRedirect :: DB.Connection -> TVar ChaChaDRG -> UserId -> FileDescription 'FRecipient -> FilePath -> FilePath -> CryptoFile -> FilePath -> CryptoFile -> Bool -> IO (Either StoreError RcvFileId)
createRcvFileRedirect _ _ _ FileDescription {redirect = Nothing} _ _ _ _ _ _ = pure $ Left $ SEInternal "createRcvFileRedirect called without redirect"
createRcvFileRedirect db gVar userId redirectFd@FileDescription {chunks = redirectChunks, redirect = Just RedirectFileInfo {size, digest}} prefixPath redirectPath redirectFile dstPath dstFile approvedRelays = runExceptT $ do
(dstEntityId, dstId) <- ExceptT $ insertRcvFile db gVar userId dummyDst prefixPath dstPath dstFile Nothing Nothing approvedRelays
(_, redirectId) <- ExceptT $ insertRcvFile db gVar userId redirectFd prefixPath redirectPath redirectFile (Just dstId) (Just dstEntityId) approvedRelays
createRcvFileRedirect :: DB.Connection -> TVar ChaChaDRG -> UserId -> FileDescription FRecipient -> FilePath -> FilePath -> CryptoFile -> FilePath -> CryptoFile -> IO (Either StoreError RcvFileId)
createRcvFileRedirect _ _ _ FileDescription {redirect = Nothing} _ _ _ _ _ = pure $ Left $ SEInternal "createRcvFileRedirect called without redirect"
createRcvFileRedirect db gVar userId redirectFd@FileDescription {chunks = redirectChunks, redirect = Just RedirectFileInfo {size, digest}} prefixPath redirectPath redirectFile dstPath dstFile = runExceptT $ do
(dstEntityId, dstId) <- ExceptT $ insertRcvFile db gVar userId dummyDst prefixPath dstPath dstFile Nothing Nothing
(_, redirectId) <- ExceptT $ insertRcvFile db gVar userId redirectFd prefixPath redirectPath redirectFile (Just dstId) (Just dstEntityId)
liftIO $
forM_ redirectChunks $ \fc@FileChunk {replicas} -> do
chunkId <- insertRcvFileChunk db fc redirectId
@@ -2308,8 +2302,8 @@ createRcvFileRedirect db gVar userId redirectFd@FileDescription {chunks = redire
chunks = []
}
insertRcvFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> FileDescription 'FRecipient -> FilePath -> FilePath -> CryptoFile -> Maybe DBRcvFileId -> Maybe RcvFileId -> Bool -> IO (Either StoreError (RcvFileId, DBRcvFileId))
insertRcvFile db gVar userId FileDescription {size, digest, key, nonce, chunkSize, redirect} prefixPath tmpPath (CryptoFile savePath cfArgs) redirectId_ redirectEntityId_ approvedRelays = runExceptT $ do
insertRcvFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> FileDescription 'FRecipient -> FilePath -> FilePath -> CryptoFile -> Maybe DBRcvFileId -> Maybe RcvFileId -> IO (Either StoreError (RcvFileId, DBRcvFileId))
insertRcvFile db gVar userId FileDescription {size, digest, key, nonce, chunkSize, redirect} prefixPath tmpPath (CryptoFile savePath cfArgs) redirectId_ redirectEntityId_ = runExceptT $ do
let (redirectDigest_, redirectSize_) = case redirect of
Just RedirectFileInfo {digest = d, size = s} -> (Just d, Just s)
Nothing -> (Nothing, Nothing)
@@ -2317,8 +2311,8 @@ insertRcvFile db gVar userId FileDescription {size, digest, key, nonce, chunkSiz
createWithRandomId gVar $ \rcvFileEntityId ->
DB.execute
db
"INSERT INTO rcv_files (rcv_file_entity_id, user_id, size, digest, key, nonce, chunk_size, prefix_path, tmp_path, save_path, save_file_key, save_file_nonce, status, redirect_id, redirect_entity_id, redirect_digest, redirect_size, approved_relays) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)"
((rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, prefixPath, tmpPath) :. (savePath, fileKey <$> cfArgs, fileNonce <$> cfArgs, RFSReceiving, redirectId_, redirectEntityId_, redirectDigest_, redirectSize_, approvedRelays))
"INSERT INTO rcv_files (rcv_file_entity_id, user_id, size, digest, key, nonce, chunk_size, prefix_path, tmp_path, save_path, save_file_key, save_file_nonce, status, redirect_id, redirect_entity_id, redirect_digest, redirect_size) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)"
((rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, prefixPath, tmpPath) :. (savePath, fileKey <$> cfArgs, fileNonce <$> cfArgs, RFSReceiving, redirectId_, redirectEntityId_, redirectDigest_, redirectSize_))
rcvFileId <- liftIO $ insertedRowId db
pure (rcvFileEntityId, rcvFileId)
@@ -2468,7 +2462,7 @@ deleteRcvFile' :: DB.Connection -> DBRcvFileId -> IO ()
deleteRcvFile' db rcvFileId =
DB.execute db "DELETE FROM rcv_files WHERE rcv_file_id = ?" (Only rcvFileId)
getNextRcvChunkToDownload :: DB.Connection -> XFTPServer -> NominalDiffTime -> IO (Either StoreError (Maybe (RcvFileChunk, Bool)))
getNextRcvChunkToDownload :: DB.Connection -> XFTPServer -> NominalDiffTime -> IO (Either StoreError (Maybe RcvFileChunk))
getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} ttl = do
getWorkItem "rcv_file_download" getReplicaId getChunkData (markRcvFileFailed db . snd)
where
@@ -2492,7 +2486,7 @@ getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} ttl = d
LIMIT 1
|]
(host, port, keyHash, RFSReceiving, cutoffTs)
getChunkData :: (Int64, DBRcvFileId) -> IO (Either StoreError (RcvFileChunk, Bool))
getChunkData :: (Int64, DBRcvFileId) -> IO (Either StoreError RcvFileChunk)
getChunkData (rcvFileChunkReplicaId, _fileId) =
firstRow toChunk SEFileNotFound $
DB.query
@@ -2500,8 +2494,7 @@ getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} ttl = d
[sql|
SELECT
f.rcv_file_id, f.rcv_file_entity_id, f.user_id, c.rcv_file_chunk_id, c.chunk_no, c.chunk_size, c.digest, f.tmp_path, c.tmp_path,
r.rcv_file_chunk_replica_id, r.replica_id, r.replica_key, r.received, r.delay, r.retries,
f.approved_relays
r.rcv_file_chunk_replica_id, r.replica_id, r.replica_key, r.received, r.delay, r.retries
FROM rcv_file_chunk_replicas r
JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id
JOIN rcv_file_chunks c ON c.rcv_file_chunk_id = r.rcv_file_chunk_id
@@ -2510,22 +2503,20 @@ getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} ttl = d
|]
(Only rcvFileChunkReplicaId)
where
toChunk :: ((DBRcvFileId, RcvFileId, UserId, Int64, Int, FileSize Word32, FileDigest, FilePath, Maybe FilePath) :. (Int64, ChunkReplicaId, C.APrivateAuthKey, Bool, Maybe Int64, Int) :. Only Bool) -> (RcvFileChunk, Bool)
toChunk ((rcvFileId, rcvFileEntityId, userId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath, chunkTmpPath) :. (rcvChunkReplicaId, replicaId, replicaKey, received, delay, retries) :. (Only approvedRelays)) =
( RcvFileChunk
{ rcvFileId,
rcvFileEntityId,
userId,
rcvChunkId,
chunkNo,
chunkSize,
digest,
fileTmpPath,
chunkTmpPath,
replicas = [RcvFileChunkReplica {rcvChunkReplicaId, server, replicaId, replicaKey, received, delay, retries}]
},
approvedRelays
)
toChunk :: ((DBRcvFileId, RcvFileId, UserId, Int64, Int, FileSize Word32, FileDigest, FilePath, Maybe FilePath) :. (Int64, ChunkReplicaId, C.APrivateAuthKey, Bool, Maybe Int64, Int)) -> RcvFileChunk
toChunk ((rcvFileId, rcvFileEntityId, userId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath, chunkTmpPath) :. (rcvChunkReplicaId, replicaId, replicaKey, received, delay, retries)) =
RcvFileChunk
{ rcvFileId,
rcvFileEntityId,
userId,
rcvChunkId,
chunkNo,
chunkSize,
digest,
fileTmpPath,
chunkTmpPath,
replicas = [RcvFileChunkReplica {rcvChunkReplicaId, server, replicaId, replicaKey, received, delay, retries}]
}
getNextRcvFileToDecrypt :: DB.Connection -> NominalDiffTime -> IO (Either StoreError (Maybe RcvFile))
getNextRcvFileToDecrypt db ttl =
@@ -22,8 +22,8 @@ import Database.SQLite.Simple (SQLError)
import qualified Database.SQLite.Simple as SQL
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
import Simplex.Messaging.Util (diffToMilliseconds)
import UnliftIO.Exception (bracket)
import qualified UnliftIO.Exception as E
import UnliftIO.MVar
import UnliftIO.STM
storeKey :: ScrubbedBytes -> Bool -> Maybe ScrubbedBytes
@@ -32,13 +32,16 @@ storeKey key keepKey = if keepKey || BA.null key then Just key else Nothing
data SQLiteStore = SQLiteStore
{ dbFilePath :: FilePath,
dbKey :: TVar (Maybe ScrubbedBytes),
dbConnection :: MVar DB.Connection,
dbConnection :: TMVar DB.Connection,
dbClosed :: TVar Bool,
dbNew :: Bool
}
withConnection :: SQLiteStore -> (DB.Connection -> IO a) -> IO a
withConnection SQLiteStore {dbConnection} = withMVar dbConnection
withConnection SQLiteStore {dbConnection} =
bracket
(atomically $ takeTMVar dbConnection)
(atomically . putTMVar dbConnection)
withConnection' :: SQLiteStore -> (SQL.Connection -> IO a) -> IO a
withConnection' st action = withConnection st $ action . DB.conn
@@ -68,9 +71,9 @@ dbBusyLoop action = loop 500 3000000
loop :: Int -> Int -> IO a
loop t tLim =
action `E.catch` \(e :: SQLError) ->
let se = SQL.sqlError e
in if tLim > t && (se == SQL.ErrorBusy || se == SQL.ErrorLocked)
then do
threadDelay t
loop (t * 9 `div` 8) (tLim - t)
else E.throwIO e
let se = SQL.sqlError e in
if tLim > t && (se == SQL.ErrorBusy || se == SQL.ErrorLocked)
then do
threadDelay t
loop (t * 9 `div` 8) (tLim - t)
else E.throwIO e
@@ -71,7 +71,6 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240121_message_deliver
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240124_file_redirect
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240223_connections_wait_delivery
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240225_ratchet_kem
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240417_rcv_files_approved_relays
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
import Simplex.Messaging.Transport.Client (TransportHost)
@@ -111,8 +110,7 @@ schemaMigrations =
("m20240121_message_delivery_indexes", m20240121_message_delivery_indexes, Just down_m20240121_message_delivery_indexes),
("m20240124_file_redirect", m20240124_file_redirect, Just down_m20240124_file_redirect),
("m20240223_connections_wait_delivery", m20240223_connections_wait_delivery, Just down_m20240223_connections_wait_delivery),
("m20240225_ratchet_kem", m20240225_ratchet_kem, Just down_m20240225_ratchet_kem),
("m20240417_rcv_files_approved_relays", m20240417_rcv_files_approved_relays, Just down_m20240417_rcv_files_approved_relays)
("m20240225_ratchet_kem", m20240225_ratchet_kem, Just down_m20240225_ratchet_kem)
]
-- | The list of migrations in ascending order by date
@@ -1,18 +0,0 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240417_rcv_files_approved_relays where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20240417_rcv_files_approved_relays :: Query
m20240417_rcv_files_approved_relays =
[sql|
ALTER TABLE rcv_files ADD COLUMN approved_relays INTEGER NOT NULL DEFAULT 0;
|]
down_m20240417_rcv_files_approved_relays :: Query
down_m20240417_rcv_files_approved_relays =
[sql|
ALTER TABLE rcv_files DROP COLUMN approved_relays;
|]
@@ -287,7 +287,6 @@ CREATE TABLE rcv_files(
redirect_entity_id BLOB,
redirect_size INTEGER,
redirect_digest BLOB,
approved_relays INTEGER NOT NULL DEFAULT 0,
UNIQUE(rcv_file_entity_id)
);
CREATE TABLE rcv_file_chunks(
+158 -349
View File
@@ -30,11 +30,9 @@ module Simplex.Messaging.Client
TransportSession,
ProtocolClient (thParams, sessionTs),
SMPClient,
ProxiedRelay (..),
getProtocolClient,
closeProtocolClient,
protocolClientServer,
protocolClientServer',
transportHost',
transportSession',
@@ -56,7 +54,7 @@ module Simplex.Messaging.Client
suspendSMPQueue,
deleteSMPQueue,
deleteSMPQueues,
connectSMPProxiedRelay,
createSMPProxySession,
proxySMPMessage,
forwardSMPMessage,
sendProtocolCommand,
@@ -64,15 +62,9 @@ module Simplex.Messaging.Client
-- * Supporting types and client configuration
ProtocolClientError (..),
SMPClientError,
ProxyClientError (..),
unexpectedResponse,
ProtocolClientConfig (..),
NetworkConfig (..),
TransportSessionMode (..),
HostMode (..),
SocksMode (..),
SMPProxyMode (..),
SMPProxyFallback (..),
defaultClientConfig,
defaultSMPClientConfig,
defaultNetworkConfig,
@@ -81,8 +73,7 @@ module Simplex.Messaging.Client
proxyUsername,
temporaryClientError,
smpProxyError,
ServerTransmissionBatch,
ServerTransmission (..),
ServerTransmission,
ClientCommand,
-- * For testing
@@ -93,18 +84,15 @@ module Simplex.Messaging.Client
)
where
import Control.Applicative ((<|>))
import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Exception
import Control.Logger.Simple
import Control.Monad
import Control.Monad.Except
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Except
import Crypto.Random (ChaChaDRG)
import qualified Data.Aeson.TH as J
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Functor (($>))
@@ -112,8 +100,8 @@ import Data.Int (Int64)
import Data.List (find)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as L
import Data.Maybe (catMaybes, fromMaybe)
import Data.Time.Clock (UTCTime (..), diffUTCTime, getCurrentTime)
import Data.Maybe (fromMaybe)
import Data.Time.Clock (UTCTime (..), getCurrentTime)
import qualified Data.X509 as X
import qualified Data.X509.Validation as XV
import Network.Socket (ServiceName)
@@ -126,10 +114,10 @@ import Simplex.Messaging.Protocol
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport
import Simplex.Messaging.Transport.Client (SocksProxy, TransportClientConfig (..), TransportHost (..), defaultTcpConnectTimeout, runTransportClient)
import Simplex.Messaging.Transport.Client (SocksProxy, TransportClientConfig (..), TransportHost (..), runTransportClient)
import Simplex.Messaging.Transport.KeepAlive
import Simplex.Messaging.Transport.WebSockets (WS)
import Simplex.Messaging.Util (bshow, diffToMicroseconds, ifM, liftEitherWith, raceAny_, threadDelay', tshow, whenM)
import Simplex.Messaging.Util (bshow, liftEitherWith, raceAny_, threadDelay')
import Simplex.Messaging.Version
import System.Timeout (timeout)
@@ -147,27 +135,21 @@ data PClient v err msg = PClient
{ connected :: TVar Bool,
transportSession :: TransportSession msg,
transportHost :: TransportHost,
tcpConnectTimeout :: Int,
tcpTimeout :: Int,
sendPings :: TVar Bool,
lastReceived :: TVar UTCTime,
timeoutErrorCount :: TVar Int,
pingErrorCount :: TVar Int,
clientCorrId :: TVar ChaChaDRG,
sentCommands :: TMap CorrId (Request err msg),
sndQ :: TBQueue ByteString,
rcvQ :: TBQueue (NonEmpty (SignedTransmission err msg)),
msgQ :: Maybe (TBQueue (ServerTransmissionBatch v err msg))
msgQ :: Maybe (TBQueue (ServerTransmission v msg))
}
smpClientStub :: TVar ChaChaDRG -> ByteString -> VersionSMP -> Maybe (THandleAuth 'TClient) -> STM SMPClient
smpClientStub g sessionId thVersion thAuth = do
let ts = UTCTime (read "2024-03-31") 0
connected <- newTVar False
clientCorrId <- C.newRandomDRG g
sentCommands <- TM.empty
sendPings <- newTVar False
lastReceived <- newTVar ts
timeoutErrorCount <- newTVar 0
pingErrorCount <- newTVar 0
sndQ <- newTBQueue 100
rcvQ <- newTBQueue 100
return
@@ -177,23 +159,19 @@ smpClientStub g sessionId thVersion thAuth = do
THandleParams
{ sessionId,
thVersion,
thServerVRange = supportedServerSMPRelayVRange,
thAuth,
blockSize = smpBlockSize,
implySessId = thVersion >= authCmdsSMPVersion,
batch = True
},
sessionTs = ts,
sessionTs = UTCTime (read "2024-03-31") 0,
client_ =
PClient
{ connected,
transportSession = (1, "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5001", Nothing),
transportHost = "localhost",
tcpConnectTimeout = 20_000_000,
tcpTimeout = 15_000_000,
sendPings,
lastReceived,
timeoutErrorCount,
pingErrorCount,
clientCorrId,
sentCommands,
sndQ,
@@ -207,14 +185,8 @@ type SMPClient = ProtocolClient SMPVersion ErrorType BrokerMsg
-- | Type for client command data
type ClientCommand msg = (Maybe C.APrivateAuthKey, EntityId, ProtoCommand msg)
-- | Type synonym for transmission from SPM servers.
-- Batch response is presented as a single `ServerTransmissionBatch` tuple.
type ServerTransmissionBatch v err msg = (TransportSession msg, Version v, SessionId, NonEmpty (EntityId, ServerTransmission err msg))
data ServerTransmission err msg
= STEvent (Either (ProtocolClientError err) msg)
| STResponse (ProtoCommand msg) (Either (ProtocolClientError err) msg)
| STUnexpectedError (ProtocolClientError err)
-- | Type synonym for transmission from some SPM server queue.
type ServerTransmission v msg = (TransportSession msg, Version v, SessionId, EntityId, msg)
data HostMode
= -- | prefer (or require) onion hosts when connecting via SOCKS proxy
@@ -225,43 +197,27 @@ data HostMode
HMPublic
deriving (Eq, Show)
data SocksMode
= -- | always use SOCKS proxy when enabled
SMAlways
| -- | use SOCKS proxy only for .onion hosts when no public host is available
-- This mode is used in SMP proxy to minimize SOCKS proxy usage.
SMOnion
deriving (Eq, Show)
-- | network configuration for the client
data NetworkConfig = NetworkConfig
{ -- | use SOCKS5 proxy
socksProxy :: Maybe SocksProxy,
-- | when to use SOCKS proxy
socksMode :: SocksMode,
-- | determines critera which host is chosen from the list
hostMode :: HostMode,
-- | if above criteria is not met, if the below setting is True return error, otherwise use the first host
requiredHostMode :: Bool,
-- | transport sessions are created per user or per entity
sessionMode :: TransportSessionMode,
-- | SMP proxy mode
smpProxyMode :: SMPProxyMode,
-- | Fallback to direct connection when destination SMP relay does not support SMP proxy protocol extensions
smpProxyFallback :: SMPProxyFallback,
-- | timeout for the initial client TCP/TLS connection (microseconds)
tcpConnectTimeout :: Int,
-- | timeout of protocol commands (microseconds)
tcpTimeout :: Int,
-- | additional timeout per kilobyte (1024 bytes) to be sent
tcpTimeoutPerKb :: Int64,
-- | break response timeouts into groups, so later responses get later deadlines
rcvConcurrency :: Int,
-- | TCP keep-alive options, Nothing to skip enabling keep-alive
tcpKeepAlive :: Maybe KeepAliveOpts,
-- | period for SMP ping commands (microseconds, 0 to disable)
smpPingInterval :: Int64,
-- | the count of timeout errors after which SMP client terminates (and will be reconnected), 0 to disable
-- | the count of PING errors after which SMP client terminates (and will be reconnected), 0 to disable
smpPingCount :: Int,
logTLSErrors :: Bool
}
@@ -270,48 +226,25 @@ data NetworkConfig = NetworkConfig
data TransportSessionMode = TSMUser | TSMEntity
deriving (Eq, Show)
-- SMP proxy mode for sending messages
data SMPProxyMode
= SPMAlways
| SPMUnknown -- use with unknown relays
| SPMUnprotected -- use with unknown relays when IP address is not protected (i.e., when neither SOCKS proxy nor .onion address is used)
| SPMNever
deriving (Eq, Show)
data SMPProxyFallback
= SPFAllow -- connect directly when chosen proxy or destination relay do not support proxy protocol.
| SPFAllowProtected -- connect directly only when IP address is protected (SOCKS proxy or .onion address is used).
| SPFProhibit -- prohibit direct connection to destination relay.
deriving (Eq, Show)
defaultNetworkConfig :: NetworkConfig
defaultNetworkConfig =
NetworkConfig
{ socksProxy = Nothing,
socksMode = SMAlways,
hostMode = HMOnionViaSocks,
requiredHostMode = False,
sessionMode = TSMUser,
smpProxyMode = SPMNever,
smpProxyFallback = SPFAllow,
tcpConnectTimeout = defaultTcpConnectTimeout,
tcpConnectTimeout = 20_000_000,
tcpTimeout = 15_000_000,
tcpTimeoutPerKb = 5_000,
rcvConcurrency = 8,
tcpKeepAlive = Just defaultKeepAliveOpts,
smpPingInterval = 600_000_000, -- 10min
smpPingCount = 3,
logTLSErrors = False
}
transportClientConfig :: NetworkConfig -> TransportHost -> TransportClientConfig
transportClientConfig NetworkConfig {socksProxy, socksMode, tcpConnectTimeout, tcpKeepAlive, logTLSErrors} host =
TransportClientConfig {socksProxy = useSocksProxy socksMode, tcpConnectTimeout, tcpKeepAlive, logTLSErrors, clientCredentials = Nothing, alpn = Nothing}
where
useSocksProxy SMAlways = socksProxy
useSocksProxy SMOnion = case host of
THOnionHost _ -> socksProxy
_ -> Nothing
transportClientConfig :: NetworkConfig -> TransportClientConfig
transportClientConfig NetworkConfig {socksProxy, tcpKeepAlive, logTLSErrors} =
TransportClientConfig {socksProxy, tcpKeepAlive, logTLSErrors, clientCredentials = Nothing, alpn = Nothing}
{-# INLINE transportClientConfig #-}
-- | protocol client configuration.
@@ -322,35 +255,30 @@ data ProtocolClientConfig v = ProtocolClientConfig
defaultTransport :: (ServiceName, ATransport),
-- | network configuration
networkConfig :: NetworkConfig,
clientALPN :: Maybe [ALPN],
-- | client-server protocol version range
serverVRange :: VersionRange v,
-- | agree shared session secret (used in SMP proxy for additional encryption layer)
-- | agree shared session secret (used in SMP proxy)
agreeSecret :: Bool
}
-- | Default protocol client configuration.
defaultClientConfig :: Maybe [ALPN] -> VersionRange v -> ProtocolClientConfig v
defaultClientConfig clientALPN serverVRange =
defaultClientConfig :: VersionRange v -> ProtocolClientConfig v
defaultClientConfig serverVRange =
ProtocolClientConfig
{ qSize = 64,
defaultTransport = ("443", transport @TLS),
networkConfig = defaultNetworkConfig,
clientALPN,
serverVRange,
agreeSecret = False
}
{-# INLINE defaultClientConfig #-}
defaultSMPClientConfig :: ProtocolClientConfig SMPVersion
defaultSMPClientConfig = defaultClientConfig (Just supportedSMPHandshakes) supportedClientSMPRelayVRange
defaultSMPClientConfig = defaultClientConfig supportedClientSMPRelayVRange
{-# INLINE defaultSMPClientConfig #-}
data Request err msg = Request
{ corrId :: CorrId,
entityId :: EntityId,
command :: ProtoCommand msg,
pending :: TVar Bool,
{ entityId :: EntityId,
responseVar :: TMVar (Either (ProtocolClientError err) msg)
}
@@ -374,14 +302,10 @@ chooseTransportHost NetworkConfig {socksProxy, hostMode, requiredHostMode} hosts
publicHost = find (not . isOnionHost) hosts
protocolClientServer :: ProtocolTypeI (ProtoType msg) => ProtocolClient v err msg -> String
protocolClientServer = B.unpack . strEncode . protocolClientServer'
{-# INLINE protocolClientServer #-}
protocolClientServer' :: ProtocolClient v err msg -> ProtoServer msg
protocolClientServer' = snd3 . transportSession . client_
protocolClientServer = B.unpack . strEncode . snd3 . transportSession . client_
where
snd3 (_, s, _) = s
{-# INLINE protocolClientServer' #-}
{-# INLINE protocolClientServer #-}
transportHost' :: ProtocolClient v err msg -> TransportHost
transportHost' = transportHost . client_
@@ -401,21 +325,19 @@ type TransportSession msg = (UserId, ProtoServer msg, Maybe EntityId)
--
-- 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 -> Maybe (TBQueue (ServerTransmissionBatch v err msg)) -> (ProtocolClient v err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, clientALPN, serverVRange, agreeSecret} msgQ disconnected = do
getProtocolClient :: forall v err msg. Protocol v err msg => TVar ChaChaDRG -> TransportSession msg -> ProtocolClientConfig v -> Maybe (TBQueue (ServerTransmission v msg)) -> (ProtocolClient v err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, serverVRange, agreeSecret} msgQ disconnected = do
case chooseTransportHost networkConfig (host srv) of
Right useHost ->
(getCurrentTime >>= atomically . mkProtocolClient useHost >>= runClient useTransport useHost)
(atomically (mkProtocolClient useHost) >>= runClient useTransport useHost)
`catch` \(e :: IOException) -> pure . Left $ PCEIOError e
Left e -> pure $ Left e
where
NetworkConfig {tcpConnectTimeout, tcpTimeout, smpPingInterval} = networkConfig
mkProtocolClient :: TransportHost -> UTCTime -> STM (PClient v err msg)
mkProtocolClient transportHost ts = do
mkProtocolClient :: TransportHost -> STM (PClient v err msg)
mkProtocolClient transportHost = do
connected <- newTVar False
sendPings <- newTVar False
lastReceived <- newTVar ts
timeoutErrorCount <- newTVar 0
pingErrorCount <- newTVar 0
clientCorrId <- C.newRandomDRG g
sentCommands <- TM.empty
sndQ <- newTBQueue qSize
@@ -425,11 +347,8 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
{ connected,
transportSession,
transportHost,
tcpConnectTimeout,
tcpTimeout,
sendPings,
lastReceived,
timeoutErrorCount,
pingErrorCount,
clientCorrId,
sentCommands,
sndQ,
@@ -440,7 +359,7 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
runClient :: (ServiceName, ATransport) -> 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) {alpn = clientALPN}
let tcConfig = transportClientConfig networkConfig
username = proxyUsername transportSession
action <-
async $
@@ -466,85 +385,55 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
Right th@THandle {params} -> do
sessionTs <- getCurrentTime
let c' = ProtocolClient {action = Nothing, client_ = c, thParams = params, sessionTs}
atomically $ writeTVar (lastReceived c) sessionTs
atomically $ do
writeTVar (connected c) True
putTMVar cVar $ Right c'
raceAny_ ([send c' th, process c', receive c' th] <> [monitor c' | smpPingInterval > 0])
raceAny_ ([send c' th, process c', receive c' th] <> [ping c' | smpPingInterval > 0])
`finally` disconnected c'
send :: Transport c => ProtocolClient v err msg -> THandle v c 'TClient -> IO ()
send ProtocolClient {client_ = PClient {sndQ}} h = forever $ atomically (readTBQueue sndQ) >>= void . tPutLog h
send ProtocolClient {client_ = PClient {sndQ}} h = forever $ atomically (readTBQueue sndQ) >>= tPutLog h
receive :: Transport c => ProtocolClient v err msg -> THandle v c 'TClient -> IO ()
receive ProtocolClient {client_ = PClient {rcvQ, lastReceived, timeoutErrorCount}} h = forever $ do
tGet h >>= atomically . writeTBQueue rcvQ
getCurrentTime >>= atomically . writeTVar lastReceived
atomically $ writeTVar timeoutErrorCount 0
receive ProtocolClient {client_ = PClient {rcvQ}} h = forever $ tGet h >>= atomically . writeTBQueue rcvQ
monitor :: ProtocolClient v err msg -> IO ()
monitor c@ProtocolClient {client_ = PClient {sendPings, lastReceived, timeoutErrorCount}} = loop smpPingInterval
ping :: ProtocolClient v err msg -> IO ()
ping c@ProtocolClient {client_ = PClient {pingErrorCount}} = do
threadDelay' smpPingInterval
runExceptT (sendProtocolCommand c Nothing "" $ protocolPing @v @err @msg) >>= \case
Left PCEResponseTimeout -> do
cnt <- atomically $ stateTVar pingErrorCount $ \cnt -> (cnt + 1, cnt + 1)
when (maxCnt == 0 || cnt < maxCnt) $ ping c
_ -> ping c -- sendProtocolCommand resets pingErrorCount
where
loop :: Int64 -> IO ()
loop delay = do
threadDelay' delay
diff <- diffUTCTime <$> getCurrentTime <*> readTVarIO lastReceived
let idle = diffToMicroseconds diff
remaining = smpPingInterval - idle
if remaining > 1_000_000 -- delay pings only for significant time
then loop remaining
else do
whenM (readTVarIO sendPings) $ void . runExceptT $ sendProtocolCommand c Nothing "" (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
when (maxCnt == 0 || cnt < maxCnt || diff < recoverWindow) $ loop smpPingInterval
recoverWindow = 15 * 60 -- seconds
maxCnt = smpPingCount networkConfig
process :: ProtocolClient v err msg -> IO ()
process c = forever $ atomically (readTBQueue $ rcvQ $ client_ c) >>= processMsgs c
process c = forever $ atomically (readTBQueue $ rcvQ $ client_ c) >>= mapM_ (processMsg c)
processMsgs :: ProtocolClient v err msg -> NonEmpty (SignedTransmission err msg) -> IO ()
processMsgs c ts = do
ts' <- catMaybes <$> mapM (processMsg c) (L.toList ts)
forM_ msgQ $ \q ->
mapM_ (atomically . writeTBQueue q . serverTransmission c) (L.nonEmpty ts')
processMsg :: ProtocolClient v err msg -> SignedTransmission err msg -> IO (Maybe (EntityId, ServerTransmission err msg))
processMsg ProtocolClient {client_ = PClient {sentCommands}} (_, _, (corrId, entId, respOrErr))
| B.null $ bs corrId = sendMsg $ STEvent clientResp
| otherwise =
processMsg :: ProtocolClient v err msg -> SignedTransmission err msg -> IO ()
processMsg c@ProtocolClient {client_ = PClient {sentCommands}} (_, _, (corrId, entId, respOrErr)) =
if B.null $ bs corrId
then sendMsg respOrErr
else do
atomically (TM.lookup corrId sentCommands) >>= \case
Nothing -> sendMsg $ STUnexpectedError unexpected
Just Request {entityId, command, pending, responseVar} -> do
wasPending <-
atomically $ do
TM.delete corrId sentCommands
ifM
(swapTVar pending False)
(True <$ tryPutTMVar responseVar (if entityId == entId then clientResp else Left unexpected))
(pure False)
if wasPending
then pure Nothing
else sendMsg $ if entityId == entId then STResponse command clientResp else STUnexpectedError unexpected
Nothing -> sendMsg respOrErr
Just Request {entityId, responseVar} -> atomically $ do
TM.delete corrId sentCommands
putTMVar responseVar $ response entityId
where
unexpected = unexpectedResponse respOrErr
clientResp = case respOrErr of
Left e -> Left $ PCEResponseError e
Right r -> case protocolError r of
Just e -> Left $ PCEProtocolError e
_ -> Right r
sendMsg :: ServerTransmission err msg -> IO (Maybe (EntityId, ServerTransmission err msg))
sendMsg t = case msgQ of
Just _ -> pure $ Just (entId, t)
Nothing ->
Nothing <$ case clientResp of
Left e -> logError $ "SMP client error: " <> tshow e
Right _ -> logWarn "SMP client unprocessed event"
unexpectedResponse :: Show r => r -> ProtocolClientError err
unexpectedResponse = PCEUnexpectedResponse . B.pack . take 32 . show
response entityId
| entityId == entId =
case respOrErr of
Left e -> Left $ PCEResponseError e
Right r -> case protocolError r of
Just e -> Left $ PCEProtocolError e
_ -> Right r
| otherwise = Left . PCEUnexpectedResponse $ bshow respOrErr
sendMsg :: Either err msg -> IO ()
sendMsg = \case
Right msg -> atomically $ mapM_ (`writeTBQueue` serverTransmission c entId msg) msgQ
Left e -> putStrLn $ "SMP client error: " <> show e
proxyUsername :: TransportSession msg -> ByteString
proxyUsername (userId, _, entityId_) = C.sha256Hash $ bshow userId <> maybe "" (":" <>) entityId_
@@ -595,17 +484,16 @@ temporaryClientError = \case
_ -> False
{-# INLINE temporaryClientError #-}
-- converts error of client running on proxy to the error sent to client connected to proxy
smpProxyError :: SMPClientError -> ErrorType
smpProxyError = \case
PCEProtocolError e -> PROXY $ PROTOCOL e
PCEResponseError e -> PROXY $ BROKER $ RESPONSE $ B.unpack $ strEncode e
PCEUnexpectedResponse e -> PROXY $ BROKER $ UNEXPECTED $ B.unpack e
PCEResponseTimeout -> PROXY $ BROKER TIMEOUT
PCENetworkError -> PROXY $ BROKER NETWORK
PCEIncompatibleHost -> PROXY $ BROKER HOST
PCETransportError t -> PROXY $ BROKER $ TRANSPORT t
PCECryptoError _ -> CRYPTO
PCEProtocolError et -> PROXY (PROTOCOL et)
PCEResponseError et -> PROXY (RESPONSE et)
PCEUnexpectedResponse bs -> PROXY (UNEXPECTED $ B.unpack $ B.take 32 bs)
PCEResponseTimeout -> PROXY TIMEOUT
PCENetworkError -> PROXY NETWORK
PCEIncompatibleHost -> PROXY BAD_HOST
PCETransportError t -> PROXY (TRANSPORT t)
PCECryptoError _ -> INTERNAL
PCEIOError _ -> INTERNAL
-- | Create a new SMP queue.
@@ -621,24 +509,21 @@ createSMPQueue ::
createSMPQueue c (rKey, rpKey) dhKey auth subMode =
sendSMPCommand c (Just rpKey) "" (NEW rKey dhKey auth subMode) >>= \case
IDS qik -> pure qik
r -> throwE $ unexpectedResponse r
r -> throwE . PCEUnexpectedResponse $ bshow r
-- | Subscribe to the SMP queue.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#subscribe-to-queue
subscribeSMPQueue :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO ()
subscribeSMPQueue c@ProtocolClient {client_ = PClient {sendPings}} rpKey rId = do
liftIO . atomically $ writeTVar sendPings True
subscribeSMPQueue c rpKey rId =
sendSMPCommand c (Just rpKey) rId SUB >>= \case
OK -> pure ()
OK -> return ()
cmd@MSG {} -> liftIO $ writeSMPMessage c rId cmd
r -> throwE $ unexpectedResponse r
r -> throwE . PCEUnexpectedResponse $ bshow r
-- | Subscribe to multiple SMP queues batching commands if supported.
subscribeSMPQueues :: SMPClient -> NonEmpty (RcvPrivateAuthKey, RecipientId) -> IO (NonEmpty (Either SMPClientError ()))
subscribeSMPQueues c@ProtocolClient {client_ = PClient {sendPings}} qs = do
atomically $ writeTVar sendPings True
sendProtocolCommands c cs >>= mapM (processSUBResponse c)
subscribeSMPQueues c qs = sendProtocolCommands c cs >>= mapM (processSUBResponse c)
where
cs = L.map (\(rpKey, rId) -> (Just rpKey, rId, Cmd SRecipient SUB)) qs
@@ -652,15 +537,15 @@ processSUBResponse :: SMPClient -> Response ErrorType BrokerMsg -> IO (Either SM
processSUBResponse c (Response rId r) = case r of
Right OK -> pure $ Right ()
Right cmd@MSG {} -> writeSMPMessage c rId cmd $> Right ()
Right r' -> pure . Left $ unexpectedResponse r'
Right r' -> pure . Left . PCEUnexpectedResponse $ bshow r'
Left e -> pure $ Left e
writeSMPMessage :: SMPClient -> RecipientId -> BrokerMsg -> IO ()
writeSMPMessage c rId msg = atomically $ mapM_ (`writeTBQueue` serverTransmission c [(rId, STEvent (Right msg))]) (msgQ $ client_ c)
writeSMPMessage c rId msg = atomically $ mapM_ (`writeTBQueue` serverTransmission c rId msg) (msgQ $ client_ c)
serverTransmission :: ProtocolClient v err msg -> NonEmpty (RecipientId, ServerTransmission err msg) -> ServerTransmissionBatch v err msg
serverTransmission ProtocolClient {thParams = THandleParams {thVersion, sessionId}, client_ = PClient {transportSession}} ts =
(transportSession, thVersion, sessionId, ts)
serverTransmission :: ProtocolClient v err msg -> RecipientId -> msg -> ServerTransmission v msg
serverTransmission ProtocolClient {thParams = THandleParams {thVersion, sessionId}, client_ = PClient {transportSession}} entityId message =
(transportSession, thVersion, sessionId, entityId, message)
-- | 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
--
@@ -670,7 +555,7 @@ getSMPMessage c rpKey rId =
sendSMPCommand c (Just rpKey) rId GET >>= \case
OK -> pure Nothing
cmd@(MSG msg) -> liftIO (writeSMPMessage c rId cmd) $> Just msg
r -> throwE $ unexpectedResponse r
r -> throwE . PCEUnexpectedResponse $ bshow r
-- | Subscribe to the SMP queue notifications.
--
@@ -698,7 +583,7 @@ enableSMPQueueNotifications :: SMPClient -> RcvPrivateAuthKey -> RecipientId ->
enableSMPQueueNotifications c rpKey rId notifierKey rcvNtfPublicDhKey =
sendSMPCommand c (Just rpKey) rId (NKEY notifierKey rcvNtfPublicDhKey) >>= \case
NID nId rcvNtfSrvPublicDhKey -> pure (nId, rcvNtfSrvPublicDhKey)
r -> throwE $ unexpectedResponse r
r -> throwE . PCEUnexpectedResponse $ bshow r
-- | Enable notifications for the multiple queues for push notifications server.
enableSMPQueuesNtfs :: SMPClient -> NonEmpty (RcvPrivateAuthKey, RecipientId, NtfPublicAuthKey, RcvNtfPublicDhKey) -> IO (NonEmpty (Either SMPClientError (NotifierId, RcvNtfPublicDhKey)))
@@ -707,7 +592,7 @@ enableSMPQueuesNtfs c qs = L.map process <$> sendProtocolCommands c cs
cs = L.map (\(rpKey, rId, notifierKey, rcvNtfPublicDhKey) -> (Just rpKey, rId, Cmd SRecipient $ NKEY notifierKey rcvNtfPublicDhKey)) qs
process (Response _ r) = case r of
Right (NID nId rcvNtfSrvPublicDhKey) -> Right (nId, rcvNtfSrvPublicDhKey)
Right r' -> Left $ unexpectedResponse r'
Right r' -> Left . PCEUnexpectedResponse $ bshow r'
Left e -> Left e
-- | Disable notifications for the queue for push notifications server.
@@ -729,7 +614,7 @@ sendSMPMessage :: SMPClient -> Maybe SndPrivateAuthKey -> SenderId -> MsgFlags -
sendSMPMessage c spKey sId flags msg =
sendSMPCommand c spKey sId (SEND flags msg) >>= \case
OK -> pure ()
r -> throwE $ unexpectedResponse r
r -> throwE . PCEUnexpectedResponse $ bshow r
-- | Acknowledge message delivery (server deletes the message).
--
@@ -739,7 +624,7 @@ ackSMPMessage c rpKey rId msgId =
sendSMPCommand c (Just rpKey) rId (ACK msgId) >>= \case
OK -> return ()
cmd@MSG {} -> liftIO $ writeSMPMessage c rId cmd
r -> throwE $ unexpectedResponse r
r -> throwE . PCEUnexpectedResponse $ bshow r
-- | Irreversibly suspend SMP queue.
-- The existing messages from the queue will still be delivered.
@@ -761,21 +646,22 @@ deleteSMPQueues :: SMPClient -> NonEmpty (RcvPrivateAuthKey, RecipientId) -> IO
deleteSMPQueues = okSMPCommands DEL
{-# INLINE deleteSMPQueues #-}
-- TODO picture
-- 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
| thVersion (thParams c) >= sendingProxySMPVersion =
sendProtocolCommand_ c Nothing tOut Nothing "" (Cmd SProxiedClient (PRXY relayServ proxyAuth)) >>= \case
PKEY sId vr (chain, key) ->
case supportedClientSMPRelayVRange `compatibleVersion` vr of
Nothing -> throwE $ transportErr TEVersion
Just (Compatible v) -> liftEitherWith (const $ transportErr $ TEHandshake IDENTITY) $ ProxiedRelay sId v <$> validateRelay chain key
r -> throwE $ unexpectedResponse r
| otherwise = throwE $ PCETransportError TEVersion
createSMPProxySession :: SMPClient -> SMPServer -> Maybe BasicAuth -> ExceptT SMPClientError IO (SessionId, VersionSMP, C.PublicKeyX25519)
createSMPProxySession c relayServ@ProtocolServer {keyHash = C.KeyHash kh} proxyAuth =
sendSMPCommand c Nothing "" (PRXY relayServ proxyAuth) >>= \case
-- XXX: rfc says sessionId should be in the entityId of response
PKEY sId vr (chain, key) -> do
case supportedClientSMPRelayVRange `compatibleVersion` vr of
Nothing -> throwE PCEIncompatibleHost -- TODO different error
Just (Compatible v) -> liftEitherWith x509Error $ (sId,v,) <$> validateRelay chain key
r -> throwE . PCEUnexpectedResponse $ bshow r
where
tOut = Just $ tcpConnectTimeout + tcpTimeout
transportErr = PCEProtocolError . PROXY . BROKER . TRANSPORT
x509Error :: String -> SMPClientError
x509Error _msg = PCEResponseError $ error "TODO: x509 error" -- TODO different error
validateRelay :: X.CertificateChain -> X.SignedExact X.PubKey -> Either String C.PublicKeyX25519
validateRelay (X.CertificateChain cert) exact = do
serverKey <- case cert of
@@ -786,136 +672,81 @@ connectSMPProxiedRelay c@ProtocolClient {client_ = PClient {tcpConnectTimeout, t
pubKey <- C.verifyX509 serverKey exact
C.x509ToPublic (pubKey, []) >>= C.pubKey
data ProxiedRelay = ProxiedRelay
{ prSessionId :: SessionId,
prVersion :: VersionSMP,
prServerKey :: C.PublicKeyX25519
}
data ProxyClientError
= -- | protocol error response from proxy
ProxyProtocolError ErrorType
| -- | unexpexted response
ProxyUnexpectedResponse String
| -- | error between proxy and server
ProxyResponseError ErrorType
deriving (Eq, Show, Exception)
instance StrEncoding ProxyClientError where
strEncode = \case
ProxyProtocolError e -> "PROTOCOL " <> strEncode e
ProxyUnexpectedResponse s -> "UNEXPECTED " <> B.pack s
ProxyResponseError e -> "SYNTAX " <> strEncode e
strP =
A.takeTill (== ' ') >>= \case
"PROTOCOL" -> ProxyProtocolError <$> _strP
"UNEXPECTED" -> ProxyUnexpectedResponse . B.unpack <$> (A.space *> A.takeByteString)
"SYNTAX" -> ProxyResponseError <$> _strP
_ -> fail "bad ProxyClientError"
-- consider how to process slow responses - is it handled somehow locally or delegated to the caller
-- this method is used in the client
-- sends PFWD :: C.PublicKeyX25519 -> EncTransmission -> Command Sender
-- receives PRES :: EncResponse -> BrokerMsg -- proxy to client
-- When client sends message via proxy, there may be one successful scenario and 9 error scenarios
-- as shown below (WTF stands for unexpected response, ??? for response that failed to parse).
-- client proxy relay proxy client
-- 0) PFWD(SEND) -> RFWD -> RRES -> PRES(OK) -> ok
-- 1) PFWD(SEND) -> RFWD -> RRES -> PRES(ERR) -> PCEProtocolError - business logic error for client
-- 2) PFWD(SEND) -> RFWD -> RRES -> PRES(WTF) -> PCEUnexpectedReponse - relay/client protocol logic error
-- 3) PFWD(SEND) -> RFWD -> RRES -> PRES(???) -> PCEResponseError - relay/client syntax error
-- 4) PFWD(SEND) -> RFWD -> ERR -> ERR PROXY PROTOCOL -> ProxyProtocolError - proxy/relay business logic error
-- 5) PFWD(SEND) -> RFWD -> WTF -> ERR PROXY $ BROKER (UNEXPECTED s) -> ProxyProtocolError - proxy/relay protocol logic
-- 6) PFWD(SEND) -> RFWD -> ??? -> ERR PROXY $ BROKER (RESPONSE s) -> ProxyProtocolError - - proxy/relay syntax
-- 7) PFWD(SEND) -> ERR -> ProxyProtocolError - client/proxy business logic
-- 8) PFWD(SEND) -> WTF -> ProxyUnexpectedResponse - client/proxy protocol logic
-- 9) PFWD(SEND) -> ??? -> ProxyResponseError - client/proxy syntax
--
-- We report as proxySMPMessage error (ExceptT error) the errors of two kinds:
-- - protocol errors from the destination relay wrapped in PRES - to simplify processing of AUTH and QUOTA errors, in this case proxy is "transparent" for such errors (PCEProtocolError, PCEUnexpectedResponse, PCEResponseError)
-- - other response/transport/connection errors from the client connected to proxy itself
-- Other errors are reported in the function result as `Either ProxiedRelayError ()`, including
-- - protocol errors from the client connected to proxy in ProxyClientError (PCEProtocolError, PCEUnexpectedResponse, PCEResponseError)
-- - other errors from the client running on proxy and connected to relay in PREProxiedRelayError
proxySMPMessage ::
SMPClient ->
-- proxy session from PKEY
ProxiedRelay ->
SessionId ->
VersionSMP ->
C.PublicKeyX25519 ->
-- message to deliver
Maybe SndPrivateAuthKey ->
SenderId ->
MsgFlags ->
MsgBody ->
ExceptT SMPClientError IO (Either ProxyClientError ())
proxySMPMessage c@ProtocolClient {thParams = proxyThParams, client_ = PClient {clientCorrId = g, tcpTimeout}} (ProxiedRelay sessionId v serverKey) spKey sId flags msg = do
ExceptT SMPClientError IO ()
-- TODO use version
proxySMPMessage c@ProtocolClient {thParams = proxyThParams, client_ = PClient {clientCorrId = g}} sessionId _v serverKey spKey sId flags msg = do
-- prepare params
let serverThAuth = (\ta -> ta {serverPeerPubKey = serverKey}) <$> thAuth proxyThParams
serverThParams = smpTHParamsSetVersion v proxyThParams {sessionId, thAuth = serverThAuth}
serverThParams = proxyThParams {sessionId, thAuth = serverThAuth}
(cmdPubKey, cmdPrivKey) <- liftIO . atomically $ C.generateKeyPair @'C.X25519 g
let cmdSecret = C.dh' serverKey cmdPrivKey
nonce@(C.CbNonce corrId) <- liftIO . atomically $ C.randomCbNonce g
-- encode
let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth serverThParams (CorrId corrId, sId, Cmd SSender (SEND flags msg))
let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth serverThParams (CorrId corrId, sId, Cmd SSender $ SEND flags msg)
auth <- liftEitherWith PCETransportError $ authTransmission serverThAuth spKey nonce tForAuth
b <- case batchTransmissions (batch serverThParams) (blockSize serverThParams) [Right (auth, tToSend)] of
[] -> throwE $ PCETransportError TELargeMsg
TBError e _ : _ -> throwE $ PCETransportError e
[] -> throwE $ PCETransportError TELargeMsg -- some other error. Internal?
TBError e _ : _ -> throwE $ PCETransportError e -- large message error?
TBTransmission s _ : _ -> pure s
TBTransmissions s _ _ : _ -> pure s
et <- liftEitherWith PCECryptoError $ EncTransmission <$> C.cbEncrypt cmdSecret nonce b paddedProxiedMsgLength
-- proxy interaction errors are wrapped
let tOut = Just $ 2 * tcpTimeout
tryE (sendProtocolCommand_ c (Just nonce) tOut Nothing sessionId (Cmd SProxiedClient (PFWD v cmdPubKey et))) >>= \case
Right r -> case r of
PRES (EncResponse er) -> do
-- server interaction errors are thrown directly
t' <- liftEitherWith PCECryptoError $ C.cbDecrypt cmdSecret (C.reverseNonce nonce) er
case tParse serverThParams t' of
t'' :| [] -> case tDecodeParseValidate serverThParams t'' of
(_auth, _signed, (_c, _e, cmd)) -> case cmd of
Right OK -> pure $ Right ()
Right (ERR e) -> throwE $ PCEProtocolError e -- this is the error from the destination relay
Right r' -> throwE $ unexpectedResponse r'
Left e -> throwE $ PCEResponseError e
_ -> throwE $ PCETransportError TEBadBlock
ERR e -> pure . Left $ ProxyProtocolError e -- this will not happen, this error is returned via Left
_ -> pure . Left $ ProxyUnexpectedResponse $ take 32 $ show r
Left e -> case e of
PCEProtocolError e' -> pure . Left $ ProxyProtocolError e'
PCEUnexpectedResponse e' -> pure . Left $ ProxyUnexpectedResponse $ B.unpack e'
PCEResponseError e' -> pure . Left $ ProxyResponseError e'
_ -> throwE e
sendProtocolCommand_ c (Just nonce) Nothing sessionId (Cmd SProxiedClient (PFWD cmdPubKey et)) >>= \case
-- TODO support PKEY + resend?
PRES (EncResponse er) -> do
t' <- liftEitherWith PCECryptoError $ C.cbDecrypt cmdSecret (C.reverseNonce nonce) er
case tParse proxyThParams t' of
t'' :| [] -> case tDecodeParseValidate proxyThParams t'' of
(_auth, _signed, (_c, _e, r)) -> case r of -- TODO: verify
Left e -> throwE $ PCEResponseError e
Right OK -> pure ()
Right (ERR e) -> throwE $ PCEProtocolError e
Right u -> throwE . PCEUnexpectedResponse $ bshow u -- possibly differentiate unexpected response from server/proxy
_ -> throwE $ PCETransportError TEBadBlock
r -> throwE . PCEUnexpectedResponse $ bshow r -- from proxy
-- this method is used in the proxy
-- sends RFWD :: EncFwdTransmission -> Command Sender
-- receives RRES :: EncFwdResponse -> BrokerMsg
-- proxy should send PRES to the client with EncResponse
forwardSMPMessage :: SMPClient -> CorrId -> VersionSMP -> C.PublicKeyX25519 -> EncTransmission -> ExceptT SMPClientError IO EncResponse
forwardSMPMessage c@ProtocolClient {thParams, client_ = PClient {clientCorrId = g}} fwdCorrId fwdVersion fwdKey fwdTransmission = do
forwardSMPMessage :: SMPClient -> CorrId -> C.PublicKeyX25519 -> EncTransmission -> ExceptT SMPClientError IO EncResponse
forwardSMPMessage c@ProtocolClient {thParams, client_ = PClient {clientCorrId = g}} fwdCorrId fwdKey fwdTransmission = do
-- prepare params
sessSecret <- case thAuth thParams of
Nothing -> throwError $ PCETransportError TENoServerAuth
Just THAuthClient {sessSecret} -> maybe (throwError $ PCETransportError TENoServerAuth) pure sessSecret
Nothing -> throwError $ PCEProtocolError INTERNAL -- different error - proxy didn't pass key?
Just THAuthClient {sessSecret} -> maybe (throwError $ PCEProtocolError INTERNAL) pure sessSecret
nonce <- liftIO . atomically $ C.randomCbNonce g
-- wrap
let fwdT = FwdTransmission {fwdCorrId, fwdVersion, fwdKey, fwdTransmission}
eft = EncFwdTransmission $ C.cbEncryptNoPad sessSecret nonce (smpEncode fwdT)
let fwdT = FwdTransmission {fwdCorrId, fwdKey, fwdTransmission}
eft <- liftEitherWith PCECryptoError $ EncFwdTransmission <$> C.cbEncrypt sessSecret nonce (smpEncode fwdT) paddedForwardedMsgLength
-- send
sendProtocolCommand_ c (Just nonce) Nothing Nothing "" (Cmd SSender (RFWD eft)) >>= \case
sendProtocolCommand_ c (Just nonce) Nothing "" (Cmd SSender (RFWD eft)) >>= \case
RRES (EncFwdResponse efr) -> do
-- unwrap
r' <- liftEitherWith PCECryptoError $ C.cbDecryptNoPad sessSecret (C.reverseNonce nonce) efr
r' <- liftEitherWith PCECryptoError $ C.cbDecrypt sessSecret (C.reverseNonce nonce) efr
FwdResponse {fwdCorrId = _, fwdResponse} <- liftEitherWith (const $ PCEResponseError BLOCK) $ smpDecode r'
pure fwdResponse
r -> throwE $ unexpectedResponse r
r -> throwE . PCEUnexpectedResponse $ bshow 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
OK -> return ()
r -> throwE $ unexpectedResponse r
r -> throwE . PCEUnexpectedResponse $ bshow r
okSMPCommands :: PartyI p => Command p -> SMPClient -> NonEmpty (C.APrivateAuthKey, QueueId) -> IO (NonEmpty (Either SMPClientError ()))
okSMPCommands cmd c qs = L.map process <$> sendProtocolCommands c cs
@@ -924,7 +755,7 @@ okSMPCommands cmd c qs = L.map process <$> sendProtocolCommands c cs
cs = L.map (\(pKey, qId) -> (Just pKey, qId, aCmd)) qs
process (Response _ r) = case r of
Right OK -> Right ()
Right r' -> Left $ unexpectedResponse r'
Right r' -> Left . PCEUnexpectedResponse $ bshow r'
Left e -> Left e
-- | Send SMP command
@@ -935,7 +766,7 @@ sendSMPCommand c pKey qId cmd = sendProtocolCommand c pKey qId (Cmd sParty cmd)
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 :: forall v err msg. ProtocolEncoding v err (ProtoCommand msg) => ProtocolClient v err msg -> NonEmpty (ClientCommand msg) -> IO (NonEmpty (Response err msg))
sendProtocolCommands c@ProtocolClient {thParams = THandleParams {batch, blockSize}} cs = do
bs <- batchTransmissions' batch blockSize <$> mapM (mkTransmission c) cs
validate . concat =<< mapM (sendBatch c) bs
@@ -952,7 +783,7 @@ sendProtocolCommands c@ProtocolClient {thParams = THandleParams {batch, blockSiz
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 :: forall v err msg. ProtocolEncoding v err (ProtoCommand msg) => ProtocolClient v err msg -> NonEmpty (ClientCommand msg) -> ([Response err msg] -> IO ()) -> IO ()
streamProtocolCommands c@ProtocolClient {thParams = THandleParams {batch, blockSize}} cs cb = do
bs <- batchTransmissions' batch blockSize <$> mapM (mkTransmission c) cs
mapM_ (cb <=< sendBatch c) bs
@@ -966,18 +797,18 @@ sendBatch c@ProtocolClient {client_ = PClient {sndQ}} b = do
TBTransmissions s n rs
| n > 0 -> do
atomically $ writeTBQueue sndQ s
mapConcurrently (getResponse c Nothing) rs
mapConcurrently (getResponse c) rs
| otherwise -> pure []
TBTransmission s r -> do
atomically $ writeTBQueue sndQ s
(: []) <$> getResponse c Nothing r
(: []) <$> getResponse c 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. ProtocolEncoding v err (ProtoCommand msg) => ProtocolClient v err msg -> Maybe C.APrivateAuthKey -> EntityId -> ProtoCommand msg -> ExceptT (ProtocolClientError err) IO msg
sendProtocolCommand c = sendProtocolCommand_ c Nothing
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}} nonce_ tOut pKey entId cmd =
sendProtocolCommand_ :: forall v err msg. ProtocolEncoding v err (ProtoCommand msg) => ProtocolClient v err msg -> Maybe C.CbNonce -> Maybe C.APrivateAuthKey -> EntityId -> ProtoCommand msg -> ExceptT (ProtocolClientError err) IO msg
sendProtocolCommand_ c@ProtocolClient {client_ = PClient {sndQ}, thParams = THandleParams {batch, blockSize}} nonce_ pKey entId cmd =
ExceptT $ uncurry sendRecv =<< mkTransmission_ c nonce_ (pKey, entId, cmd)
where
-- two separate "atomically" needed to avoid blocking
@@ -986,50 +817,36 @@ sendProtocolCommand_ c@ProtocolClient {client_ = PClient {sndQ}, thParams = THan
Left e -> pure . Left $ PCETransportError e
Right t
| B.length s > blockSize - 2 -> pure . Left $ PCETransportError TELargeMsg
| otherwise -> do
atomically $ writeTBQueue sndQ s
response <$> getResponse c tOut r
| otherwise -> atomically (writeTBQueue sndQ s) >> response <$> getResponse c r
where
s
| batch = tEncodeBatch1 t
| otherwise = tEncode t
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)
response <- atomically $ do
writeTVar pending False
-- Try to read response again in case it arrived after timeout expired
-- but before `pending` was set to False above.
-- See `processMsg`.
((r <|>) <$> tryTakeTMVar responseVar) >>= \case
Just r' -> writeTVar timeoutErrorCount 0 $> r'
Nothing -> modifyTVar' timeoutErrorCount (+ 1) $> Left PCEResponseTimeout
-- TODO switch to timeout or TimeManager that supports Int64
getResponse :: ProtocolClient v err msg -> Request err msg -> IO (Response err msg)
getResponse ProtocolClient {client_ = PClient {tcpTimeout, pingErrorCount}} Request {entityId, responseVar} = do
response <-
timeout tcpTimeout (atomically (takeTMVar responseVar)) >>= \case
-- BTW: another registerDelay candidate. Also, crashes caller with BlockedIndef.
Just r -> atomically (writeTVar pingErrorCount 0) $> r
Nothing -> pure $ Left PCEResponseTimeout
pure Response {entityId, response}
mkTransmission :: Protocol v err msg => ProtocolClient v err msg -> ClientCommand msg -> IO (PCTransmission err msg)
mkTransmission :: ProtocolEncoding v err (ProtoCommand msg) => ProtocolClient v err msg -> ClientCommand msg -> IO (PCTransmission err msg)
mkTransmission c = mkTransmission_ c Nothing
mkTransmission_ :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> Maybe C.CbNonce -> ClientCommand msg -> IO (PCTransmission err msg)
mkTransmission_ ProtocolClient {thParams, client_ = PClient {clientCorrId, sentCommands}} nonce_ (pKey_, entityId, command) = do
mkTransmission_ :: forall v err msg. ProtocolEncoding v err (ProtoCommand msg) => ProtocolClient v err msg -> Maybe C.CbNonce -> ClientCommand msg -> IO (PCTransmission err msg)
mkTransmission_ ProtocolClient {thParams, client_ = PClient {clientCorrId, sentCommands}} nonce_ (pKey_, entId, cmd) = do
nonce@(C.CbNonce corrId) <- maybe (atomically $ C.randomCbNonce clientCorrId) pure nonce_
let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (CorrId corrId, entityId, command)
let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (CorrId corrId, entId, cmd)
auth = authTransmission (thAuth thParams) pKey_ nonce tForAuth
r <- atomically $ mkRequest (CorrId corrId)
pure ((,tToSend) <$> auth, r)
where
mkRequest :: CorrId -> STM (Request err msg)
mkRequest corrId = do
pending <- newTVar True
responseVar <- newEmptyTMVar
let r =
Request
{ corrId,
entityId,
command,
pending,
responseVar
}
r <- Request entId <$> newEmptyTMVar
TM.insert corrId r sentCommands
pure r
@@ -1048,14 +865,6 @@ authTransmission thAuth pKey_ nonce t = traverse authenticate pKey_
$(J.deriveJSON (enumJSON $ dropPrefix "HM") ''HostMode)
$(J.deriveJSON (enumJSON $ dropPrefix "SM") ''SocksMode)
$(J.deriveJSON (enumJSON $ dropPrefix "TSM") ''TransportSessionMode)
$(J.deriveJSON (enumJSON $ dropPrefix "SPM") ''SMPProxyMode)
$(J.deriveJSON (enumJSON $ dropPrefix "SPF") ''SMPProxyFallback)
$(J.deriveJSON defaultJSON ''NetworkConfig)
$(J.deriveJSON (enumJSON $ dropPrefix "Proxy") ''ProxyClientError)
+130 -143
View File
@@ -2,24 +2,24 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Simplex.Messaging.Client.Agent where
import Control.Concurrent (forkIO)
import Control.Concurrent.Async (Async, uninterruptibleCancel)
import Control.Concurrent.STM (retry)
import Control.Logger.Simple
import Control.Monad
import Control.Monad.Except
import Control.Monad.IO.Unlift
import Control.Monad.Trans.Except
import Control.Monad.Trans.Reader
import Crypto.Random (ChaChaDRG)
import Data.Bifunctor (bimap, first)
import Data.ByteString.Char8 (ByteString)
@@ -33,29 +33,30 @@ import qualified Data.Map.Strict as M
import Data.Maybe (listToMaybe)
import Data.Set (Set)
import Data.Text.Encoding
import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime)
import Data.Tuple (swap)
import Numeric.Natural
import Simplex.Messaging.Agent.RetryInterval
import Simplex.Messaging.Client
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol (BrokerMsg, ErrorType, NotifierId, NtfPrivateAuthKey, ProtocolServer (..), QueueId, RcvPrivateAuthKey, RecipientId, SMPServer)
import Simplex.Messaging.Protocol (BrokerMsg, NotifierId, NtfPrivateAuthKey, ProtocolServer (..), QueueId, RcvPrivateAuthKey, RecipientId, SMPServer)
import Simplex.Messaging.Session
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport
import Simplex.Messaging.Util (catchAll_, ifM, toChunks, whenM, ($>>=))
import Simplex.Messaging.Util (catchAll_, toChunks, ($>>=))
import System.Timeout (timeout)
import UnliftIO (async)
import UnliftIO.Exception (Exception)
import qualified UnliftIO.Exception as E
import UnliftIO.STM
type SMPClientVar = SessionVar (Either (SMPClientError, Maybe UTCTime) (OwnServer, SMPClient))
type SMPClientVar = SessionVar (Either SMPClientError SMPClient)
data SMPClientAgentEvent
= CAConnected SMPServer
| CADisconnected SMPServer (Set SMPSub)
| CAReconnected SMPServer
| CAResubscribed SMPServer (NonEmpty SMPSub)
| CASubError SMPServer (NonEmpty (SMPSub, SMPClientError))
@@ -69,11 +70,9 @@ type SMPSub = (SMPSubParty, QueueId)
data SMPClientAgentConfig = SMPClientAgentConfig
{ smpCfg :: ProtocolClientConfig SMPVersion,
reconnectInterval :: RetryInterval,
persistErrorInterval :: NominalDiffTime,
msgQSize :: Natural,
agentQSize :: Natural,
agentSubsBatchSize :: Int,
ownServerDomains :: [ByteString]
agentSubsBatchSize :: Int
}
defaultSMPClientAgentConfig :: SMPClientAgentConfig
@@ -86,46 +85,66 @@ defaultSMPClientAgentConfig =
increaseAfter = 10 * second,
maxInterval = 10 * second
},
persistErrorInterval = 30, -- seconds
msgQSize = 256,
agentQSize = 256,
agentSubsBatchSize = 900,
ownServerDomains = []
agentSubsBatchSize = 900
}
where
second = 1000000
data SMPClientAgent = SMPClientAgent
{ agentCfg :: SMPClientAgentConfig,
active :: TVar Bool,
msgQ :: TBQueue (ServerTransmissionBatch SMPVersion ErrorType BrokerMsg),
msgQ :: TBQueue (ServerTransmission SMPVersion BrokerMsg),
agentQ :: TBQueue SMPClientAgentEvent,
randomDrg :: TVar ChaChaDRG,
smpClients :: TMap SMPServer SMPClientVar,
smpSessions :: TMap SessionId (OwnServer, SMPClient),
smpSessions :: TMap SessionId SMPClient,
srvSubs :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey),
pendingSrvSubs :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey),
smpSubWorkers :: TMap SMPServer (SessionVar (Async ())),
reconnections :: TVar [Async ()],
asyncClients :: TVar [Async ()],
workerSeq :: TVar Int
}
type OwnServer = Bool
newtype InternalException e = InternalException {unInternalException :: e}
deriving (Eq, Show)
instance Exception e => Exception (InternalException e)
instance Exception e => MonadUnliftIO (ExceptT e IO) where
{-# INLINE withRunInIO #-}
withRunInIO :: ((forall a. ExceptT e IO a -> IO a) -> IO b) -> ExceptT e IO b
withRunInIO inner =
ExceptT . fmap (first unInternalException) . E.try $
withRunInIO $ \run ->
inner $ run . (either (E.throwIO . InternalException) pure <=< runExceptT)
-- as MonadUnliftIO instance for IO is `withRunInIO inner = inner id`,
-- the last two lines could be replaced with:
-- inner $ either (E.throwIO . InternalException) pure <=< runExceptT
instance Exception e => MonadUnliftIO (ExceptT e (ReaderT r IO)) where
{-# INLINE withRunInIO #-}
withRunInIO :: ((forall a. ExceptT e (ReaderT r IO) a -> IO a) -> IO b) -> ExceptT e (ReaderT r IO) b
withRunInIO inner =
withExceptT unInternalException . ExceptT . E.try $
withRunInIO $ \run ->
inner $ run . (either (E.throwIO . InternalException) pure <=< runExceptT)
newSMPClientAgent :: SMPClientAgentConfig -> TVar ChaChaDRG -> STM SMPClientAgent
newSMPClientAgent agentCfg@SMPClientAgentConfig {msgQSize, agentQSize} randomDrg = do
active <- newTVar True
msgQ <- newTBQueue msgQSize
agentQ <- newTBQueue agentQSize
smpClients <- TM.empty
smpSessions <- TM.empty
srvSubs <- TM.empty
pendingSrvSubs <- TM.empty
smpSubWorkers <- TM.empty
reconnections <- newTVar []
asyncClients <- newTVar []
workerSeq <- newTVar 0
pure
SMPClientAgent
{ agentCfg,
active,
msgQ,
agentQ,
randomDrg,
@@ -133,78 +152,65 @@ newSMPClientAgent agentCfg@SMPClientAgentConfig {msgQSize, agentQSize} randomDrg
smpSessions,
srvSubs,
pendingSrvSubs,
smpSubWorkers,
reconnections,
asyncClients,
workerSeq
}
-- | Get or create SMP client for SMPServer
getSMPServerClient' :: SMPClientAgent -> SMPServer -> ExceptT SMPClientError IO SMPClient
getSMPServerClient' ca srv = snd <$> getSMPServerClient'' ca srv
{-# INLINE getSMPServerClient' #-}
getSMPServerClient'' :: SMPClientAgent -> SMPServer -> ExceptT SMPClientError IO (OwnServer, SMPClient)
getSMPServerClient'' ca@SMPClientAgent {agentCfg, smpClients, smpSessions, workerSeq} srv =
atomically getClientVar >>= either (ExceptT . newSMPClient) waitForSMPClient
getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, smpSessions, msgQ, randomDrg, workerSeq} srv =
atomically getClientVar >>= either newSMPClient waitForSMPClient
where
getClientVar :: STM (Either SMPClientVar SMPClientVar)
getClientVar = getSessVar workerSeq srv smpClients
waitForSMPClient :: SMPClientVar -> ExceptT SMPClientError IO (OwnServer, SMPClient)
waitForSMPClient :: SMPClientVar -> ExceptT SMPClientError IO SMPClient
waitForSMPClient v = do
let ProtocolClientConfig {networkConfig = NetworkConfig {tcpConnectTimeout}} = smpCfg agentCfg
smpClient_ <- liftIO $ tcpConnectTimeout `timeout` atomically (readTMVar $ sessionVar v)
case smpClient_ of
Just (Right smpClient) -> pure smpClient
Just (Left (e, ts_)) -> case ts_ of
Nothing -> throwE e
Just ts ->
ifM
((ts <) <$> liftIO getCurrentTime)
(atomically (removeSessVar v srv smpClients) >> getSMPServerClient'' ca srv)
(throwE e)
Nothing -> throwE PCEResponseTimeout
liftEither $ case smpClient_ of
Just (Right smpClient) -> Right smpClient
Just (Left e) -> Left e
Nothing -> Left PCEResponseTimeout
newSMPClient :: SMPClientVar -> IO (Either SMPClientError (OwnServer, SMPClient))
newSMPClient v = do
r <- connectClient ca srv v `E.catch` (pure . Left . PCEIOError)
case r of
Right smp -> do
logInfo . decodeUtf8 $ "Agent connected to " <> showServer srv
let c = (isOwnServer ca srv, smp)
atomically $ do
putTMVar (sessionVar v) (Right c)
TM.insert (sessionId $ thParams smp) c smpSessions
notify ca $ CAConnected srv
pure $ Right c
Left e -> do
let ei = persistErrorInterval agentCfg
if ei == 0
then atomically $ do
putTMVar (sessionVar v) (Left (e, Nothing))
removeSessVar v srv smpClients
else do
ts <- addUTCTime ei <$> liftIO getCurrentTime
atomically $ putTMVar (sessionVar v) (Left (e, Just ts))
reconnectClient ca srv
pure $ Left e
newSMPClient :: SMPClientVar -> ExceptT SMPClientError IO SMPClient
newSMPClient v = tryConnectClient pure (liftIO tryConnectAsync)
where
tryConnectClient :: (SMPClient -> ExceptT SMPClientError IO a) -> ExceptT SMPClientError IO () -> ExceptT SMPClientError IO a
tryConnectClient successAction retryAction =
tryE (connectClient v) >>= \r -> case r of
Right smp -> do
logInfo . decodeUtf8 $ "Agent connected to " <> showServer srv
atomically $ do
putTMVar (sessionVar v) r
TM.insert (sessionId $ thParams smp) smp smpSessions
successAction smp
Left e -> do
if e == PCENetworkError || e == PCEResponseTimeout
then retryAction
else atomically $ do
putTMVar (sessionVar v) (Left e)
removeSessVar v srv smpClients
throwE e
tryConnectAsync :: IO ()
tryConnectAsync = do
a <- async $ void $ runExceptT connectAsync
atomically $ modifyTVar' (asyncClients ca) (a :)
connectAsync :: ExceptT SMPClientError IO ()
connectAsync =
withRetryInterval (reconnectInterval agentCfg) $ \_ loop ->
void $ tryConnectClient (const reconnectClient) loop
isOwnServer :: SMPClientAgent -> SMPServer -> OwnServer
isOwnServer SMPClientAgent {agentCfg} ProtocolServer {host} =
let srv = strEncode $ L.head host
in any (\s -> s == srv || (B.cons '.' s) `B.isSuffixOf` srv) (ownServerDomains agentCfg)
connectClient :: SMPClientVar -> ExceptT SMPClientError IO SMPClient
connectClient v = ExceptT $ getProtocolClient randomDrg (1, srv, Nothing) (smpCfg agentCfg) (Just msgQ) (clientDisconnected v)
-- | Run an SMP client for SMPClientVar
connectClient :: SMPClientAgent -> SMPServer -> SMPClientVar -> IO (Either SMPClientError SMPClient)
connectClient ca@SMPClientAgent {agentCfg, smpClients, smpSessions, msgQ, randomDrg} srv v =
getProtocolClient randomDrg (1, srv, Nothing) (smpCfg agentCfg) (Just msgQ) clientDisconnected
where
clientDisconnected :: SMPClient -> IO ()
clientDisconnected smp = do
removeClientAndSubs smp >>= (`forM_` serverDown)
clientDisconnected :: SMPClientVar -> SMPClient -> IO ()
clientDisconnected v smp = do
removeClientAndSubs v smp >>= (`forM_` serverDown)
logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
removeClientAndSubs :: SMPClient -> IO (Maybe (Map SMPSub C.APrivateAuthKey))
removeClientAndSubs smp = atomically $ do
removeClientAndSubs :: SMPClientVar -> SMPClient -> IO (Maybe (Map SMPSub C.APrivateAuthKey))
removeClientAndSubs v smp = atomically $ do
removeSessVar v srv smpClients
TM.delete (sessionId $ thParams smp) smpSessions
TM.lookupDelete srv (srvSubs ca) >>= mapM updateSubs
@@ -222,89 +228,70 @@ connectClient ca@SMPClientAgent {agentCfg, smpClients, smpSessions, msgQ, random
serverDown :: Map SMPSub C.APrivateAuthKey -> IO ()
serverDown ss = unless (M.null ss) $ do
notify ca . CADisconnected srv $ M.keysSet ss
reconnectClient ca srv
notify . CADisconnected srv $ M.keysSet ss
reconnectServer
-- | Spawn reconnect worker if needed
reconnectClient :: SMPClientAgent -> SMPServer -> IO ()
reconnectClient ca@SMPClientAgent {active, agentCfg, smpSubWorkers, workerSeq} srv =
whenM (readTVarIO active) $ atomically getWorkerVar >>= mapM_ (either newSubWorker (\_ -> pure ()))
where
getWorkerVar =
ifM
(null <$> getPending)
(pure Nothing) -- prevent race with cleanup and adding pending queues in another call
(Just <$> getSessVar workerSeq srv smpSubWorkers)
newSubWorker :: SessionVar (Async ()) -> IO ()
newSubWorker v = do
a <- async $ void (E.tryAny runSubWorker) >> atomically (cleanup v)
atomically $ putTMVar (sessionVar v) a
runSubWorker =
withRetryInterval (reconnectInterval agentCfg) $ \_ loop -> do
pending <- atomically getPending
forM_ pending $ \cs -> whenM (readTVarIO active) $ do
void $ tcpConnectTimeout `timeout` runExceptT (reconnectSMPClient ca srv cs)
loop
ProtocolClientConfig {networkConfig = NetworkConfig {tcpConnectTimeout}} = smpCfg agentCfg
getPending = mapM readTVar =<< TM.lookup srv (pendingSrvSubs ca)
cleanup :: SessionVar (Async ()) -> STM ()
cleanup v = do
-- Here we wait until TMVar is not empty to prevent worker cleanup happening before worker is added to TMVar.
-- Not waiting may result in terminated worker remaining in the map.
whenM (isEmptyTMVar $ sessionVar v) retry
removeSessVar v srv smpSubWorkers
reconnectServer :: IO ()
reconnectServer = do
a <- async $ void $ runExceptT tryReconnectClient
atomically $ modifyTVar' (reconnections ca) (a :)
reconnectSMPClient :: SMPClientAgent -> SMPServer -> Map SMPSub C.APrivateAuthKey -> ExceptT SMPClientError IO ()
reconnectSMPClient ca@SMPClientAgent {agentCfg} srv cs =
withSMP ca srv $ \smp -> do
subs' <- filterM (fmap not . atomically . hasSub (srvSubs ca) srv . fst) $ M.assocs cs
let (nSubs, rSubs) = partition (isNotifier . fst . fst) subs'
subscribe_ smp SPNotifier nSubs
subscribe_ smp SPRecipient rSubs
where
isNotifier = \case
SPNotifier -> True
SPRecipient -> False
subscribe_ :: SMPClient -> SMPSubParty -> [(SMPSub, C.APrivateAuthKey)] -> ExceptT SMPClientError IO ()
subscribe_ smp party = mapM_ subscribeBatch . toChunks (agentSubsBatchSize agentCfg)
tryReconnectClient :: ExceptT SMPClientError IO ()
tryReconnectClient = do
withRetryInterval (reconnectInterval agentCfg) $ \_ loop ->
reconnectClient `catchE` const loop
reconnectClient :: ExceptT SMPClientError IO ()
reconnectClient = do
withSMP ca srv $ \smp -> do
liftIO $ notify $ CAReconnected srv
cs_ <- atomically $ mapM readTVar =<< TM.lookup srv (pendingSrvSubs ca)
forM_ cs_ $ \cs -> do
subs' <- filterM (fmap not . atomically . hasSub (srvSubs ca) srv . fst) $ M.assocs cs
let (nSubs, rSubs) = partition (isNotifier . fst . fst) subs'
subscribe_ smp SPNotifier nSubs
subscribe_ smp SPRecipient rSubs
where
subscribeBatch subs' = do
let subs'' :: (NonEmpty (QueueId, C.APrivateAuthKey)) = L.map (first snd) subs'
rs <- liftIO $ smpSubscribeQueues party ca smp srv subs''
let rs' :: (NonEmpty ((SMPSub, C.APrivateAuthKey), Either SMPClientError ())) =
L.zipWith (first . const) subs' rs
rs'' :: [Either (SMPSub, SMPClientError) (SMPSub, C.APrivateAuthKey)] =
map (\(sub, r) -> bimap (fst sub,) (const sub) r) $ L.toList rs'
(errs, oks) = partitionEithers rs''
(tempErrs, finalErrs) = partition (temporaryClientError . snd) errs
mapM_ (atomically . addSubscription ca srv) oks
mapM_ (notify ca . CAResubscribed srv) $ L.nonEmpty $ map fst oks
mapM_ (atomically . removePendingSubscription ca srv . fst) finalErrs
mapM_ (notify ca . CASubError srv) $ L.nonEmpty finalErrs
mapM_ (throwE . snd) $ listToMaybe tempErrs
isNotifier = \case
SPNotifier -> True
SPRecipient -> False
notify :: MonadIO m => SMPClientAgent -> SMPClientAgentEvent -> m ()
notify ca evt = atomically $ writeTBQueue (agentQ ca) evt
{-# INLINE notify #-}
subscribe_ :: SMPClient -> SMPSubParty -> [(SMPSub, C.APrivateAuthKey)] -> ExceptT SMPClientError IO ()
subscribe_ smp party = mapM_ subscribeBatch . toChunks (agentSubsBatchSize agentCfg)
where
subscribeBatch subs' = do
let subs'' :: (NonEmpty (QueueId, C.APrivateAuthKey)) = L.map (first snd) subs'
rs <- liftIO $ smpSubscribeQueues party ca smp srv subs''
let rs' :: (NonEmpty ((SMPSub, C.APrivateAuthKey), Either SMPClientError ())) =
L.zipWith (first . const) subs' rs
rs'' :: [Either (SMPSub, SMPClientError) (SMPSub, C.APrivateAuthKey)] =
map (\(sub, r) -> bimap (fst sub,) (const sub) r) $ L.toList rs'
(errs, oks) = partitionEithers rs''
(tempErrs, finalErrs) = partition (temporaryClientError . snd) errs
mapM_ (atomically . addSubscription ca srv) oks
mapM_ (liftIO . notify . CAResubscribed srv) $ L.nonEmpty $ map fst oks
mapM_ (atomically . removePendingSubscription ca srv . fst) finalErrs
mapM_ (liftIO . notify . CASubError srv) $ L.nonEmpty finalErrs
mapM_ (throwE . snd) $ listToMaybe tempErrs
lookupSMPServerClient :: SMPClientAgent -> SessionId -> STM (Maybe (OwnServer, SMPClient))
notify :: SMPClientAgentEvent -> IO ()
notify evt = atomically $ writeTBQueue (agentQ ca) evt
lookupSMPServerClient :: SMPClientAgent -> SessionId -> STM (Maybe SMPClient)
lookupSMPServerClient SMPClientAgent {smpSessions} sessId = TM.lookup sessId smpSessions
closeSMPClientAgent :: SMPClientAgent -> IO ()
closeSMPClientAgent c = do
atomically $ writeTVar (active c) False
closeSMPServerClients c
atomically (swapTVar (smpSubWorkers c) M.empty) >>= mapM_ cancelReconnect
where
cancelReconnect :: SessionVar (Async ()) -> IO ()
cancelReconnect v = void . forkIO $ atomically (readTMVar $ sessionVar v) >>= uninterruptibleCancel
cancelActions $ reconnections c
cancelActions $ asyncClients c
closeSMPServerClients :: SMPClientAgent -> IO ()
closeSMPServerClients c = atomically (smpClients c `swapTVar` M.empty) >>= mapM_ (forkIO . closeClient)
where
closeClient v =
atomically (readTMVar $ sessionVar v) >>= \case
Right (_, smp) -> closeProtocolClient smp `catchAll_` pure ()
Right smp -> closeProtocolClient smp `catchAll_` pure ()
_ -> pure ()
cancelActions :: Foldable f => TVar (f (Async ())) -> IO ()
+52 -7
View File
@@ -4,9 +4,20 @@
module Simplex.Messaging.Compression where
import qualified Codec.Compression.Zstd as Z1
import qualified Codec.Compression.Zstd.FFI as Z
import Control.Monad (forM)
import Control.Monad.Except
import Control.Monad.IO.Class
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Unsafe as B
import Data.Either (fromRight)
import Data.List.NonEmpty (NonEmpty)
import Foreign
import Foreign.C.Types
import GHC.IO (unsafePerformIO)
import Simplex.Messaging.Encoding
import UnliftIO.Exception (bracket)
data Compressed
= -- | Short messages are left intact to skip copying and FFI festivities.
@@ -31,15 +42,49 @@ instance Encoding Compressed where
'1' -> Compressed <$> smpP
x -> fail $ "unknown Compressed tag: " <> show x
-- | Compress as single chunk using stack-allocated context.
compress1 :: ByteString -> Compressed
compress1 bs
| B.length bs <= maxLengthPassthrough = Passthrough bs
| otherwise = Compressed . Large $ Z1.compress compressionLevel bs
decompress1 :: Compressed -> Either String ByteString
decompress1 = \case
Passthrough bs -> Right bs
Compressed (Large bs) -> case Z1.decompress bs of
Z1.Error e -> Left e
Z1.Skip -> Right mempty
Z1.Decompress bs' -> Right bs'
type CompressCtx = (Ptr Z.CCtx, Ptr CChar, CSize)
withCompressCtx :: CSize -> (CompressCtx -> IO a) -> IO a
withCompressCtx scratchSize action =
bracket Z.createCCtx Z.freeCCtx $ \cctx ->
allocaBytes (fromIntegral scratchSize) $ \scratchPtr ->
action (cctx, scratchPtr, scratchSize)
-- | Compress bytes, falling back to Passthrough in case of some internal error.
compress :: CompressCtx -> ByteString -> IO Compressed
compress ctx bs = fromRight (Passthrough bs) <$> compress_ ctx bs
compress_ :: CompressCtx -> ByteString -> IO (Either String Compressed)
compress_ (cctx, scratchPtr, scratchSize) bs
| B.length bs <= maxLengthPassthrough = pure . Right $ Passthrough bs
| otherwise =
B.unsafeUseAsCStringLen bs $ \(sourcePtr, sourceSize) -> runExceptT $ do
-- should not fail, unless input buffer is too short
dstSize <- ExceptT $ Z.checkError $ Z.compressCCtx cctx scratchPtr scratchSize sourcePtr (fromIntegral sourceSize) compressionLevel
liftIO $ Compressed . Large <$> B.packCStringLen (scratchPtr, fromIntegral dstSize)
type DecompressCtx = (Ptr Z.DCtx, Ptr CChar, CSize)
withDecompressCtx :: Int -> (DecompressCtx -> IO a) -> IO a
withDecompressCtx maxUnpackedSize action =
bracket Z.createDCtx Z.freeDCtx $ \dctx ->
allocaBytes maxUnpackedSize $ \scratchPtr ->
action (dctx, scratchPtr, fromIntegral maxUnpackedSize)
decompress :: DecompressCtx -> Compressed -> IO (Either String ByteString)
decompress (dctx, scratchPtr, scratchSize) = \case
Passthrough bs -> pure $ Right bs
Compressed (Large bs) ->
B.unsafeUseAsCStringLen bs $ \(sourcePtr, sourceSize) -> do
res <- Z.checkError $ Z.decompressDCtx dctx scratchPtr scratchSize sourcePtr (fromIntegral sourceSize)
forM res $ \dstSize -> B.packCStringLen (scratchPtr, fromIntegral dstSize)
decompressBatch :: Int -> NonEmpty Compressed -> NonEmpty (Either String ByteString)
decompressBatch maxUnpackedSize items = unsafePerformIO $ withDecompressCtx maxUnpackedSize $ forM items . decompress
{-# NOINLINE decompressBatch #-} -- prevent double-evaluation under unsafePerformIO
+1
View File
@@ -31,6 +31,7 @@ import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as LB
import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe (isJust)
import Simplex.Messaging.Client.Agent ()
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.Lazy (LazyByteString)
import qualified Simplex.Messaging.Crypto.Lazy as LC
+25 -21
View File
@@ -117,7 +117,7 @@ import Simplex.Messaging.Crypto.SNTRUP761.Bindings
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (blobFieldDecoder, defaultJSON, parseE, parseE')
import Simplex.Messaging.Util (($>>=), (<$?>))
import Simplex.Messaging.Util ((<$?>), ($>>=))
import Simplex.Messaging.Version
import Simplex.Messaging.Version.Internal
import UnliftIO.STM
@@ -143,11 +143,16 @@ kdfX3DHE2EEncryptVersion = VersionE2E 2
pqRatchetE2EEncryptVersion :: VersionE2E
pqRatchetE2EEncryptVersion = VersionE2E 3
-- TODO v5.7 increase to 3
currentE2EEncryptVersion :: VersionE2E
currentE2EEncryptVersion = VersionE2E 3
currentE2EEncryptVersion = VersionE2E 2
supportedE2EEncryptVRange :: VersionRangeE2E
supportedE2EEncryptVRange = mkVersionRange kdfX3DHE2EEncryptVersion currentE2EEncryptVersion
-- TODO v5.7 remove dependency of version range on whether PQ encryption is used
supportedE2EEncryptVRange :: PQSupport -> VersionRangeE2E
supportedE2EEncryptVRange pq =
mkVersionRange kdfX3DHE2EEncryptVersion $ case pq of
PQSupportOn -> pqRatchetE2EEncryptVersion
PQSupportOff -> currentE2EEncryptVersion
data RatchetKEMState
= RKSProposed -- only KEM encapsulation key
@@ -166,9 +171,9 @@ instance TestEquality SRatchetKEMState where
class RatchetKEMStateI (s :: RatchetKEMState) where sRatchetKEMState :: SRatchetKEMState s
instance RatchetKEMStateI 'RKSProposed where sRatchetKEMState = SRKSProposed
instance RatchetKEMStateI RKSProposed where sRatchetKEMState = SRKSProposed
instance RatchetKEMStateI 'RKSAccepted where sRatchetKEMState = SRKSAccepted
instance RatchetKEMStateI RKSAccepted where sRatchetKEMState = SRKSAccepted
checkRatchetKEMState :: forall t s s' a. (RatchetKEMStateI s, RatchetKEMStateI s') => t s' a -> Either String (t s a)
checkRatchetKEMState x = case testEquality (sRatchetKEMState @s) (sRatchetKEMState @s') of
@@ -266,7 +271,6 @@ instance VersionRangeI E2EVersion (E2ERatchetParamsUri s a) where
type VersionT E2EVersion (E2ERatchetParamsUri s a) = (E2ERatchetParams s a)
versionRange (E2ERatchetParamsUri vr _ _ _) = vr
toVersionT (E2ERatchetParamsUri _ k1 k2 kem_) v = E2ERatchetParams v k1 k2 kem_
toVersionRange (E2ERatchetParamsUri _ k1 k2 kem_) vr = E2ERatchetParamsUri vr k1 k2 kem_
type RcvE2ERatchetParamsUri a = E2ERatchetParamsUri 'RKSProposed a
@@ -378,15 +382,13 @@ generateE2EParams g v useKEM_ = do
where
kemParams :: IO (Maybe (RKEMParams s, PrivRKEMParams s))
kemParams = case useKEM_ of
Just useKem
| v >= pqRatchetE2EEncryptVersion ->
Just <$> do
ks@(k, _) <- sntrup761Keypair g
case useKem of
ProposeKEM -> pure (RKParamsProposed k, PrivateRKParamsProposed ks)
AcceptKEM k' -> do
(ct, shared) <- sntrup761Enc g k'
pure (RKParamsAccepted ct k, PrivateRKParamsAccepted ct shared ks)
Just useKem | v >= pqRatchetE2EEncryptVersion -> Just <$> do
ks@(k, _) <- sntrup761Keypair g
case useKem of
ProposeKEM -> pure (RKParamsProposed k, PrivateRKParamsProposed ks)
AcceptKEM k' -> do
(ct, shared) <- sntrup761Enc g k'
pure (RKParamsAccepted ct k, PrivateRKParamsAccepted ct shared ks)
_ -> pure Nothing
-- used by party initiating connection, Bob in double-ratchet spec
@@ -459,7 +461,7 @@ pqX3dh (sk1, rk1) dh1 dh2 dh3 kemAccepted =
pq = maybe "" (\RatchetKEMAccepted {rcPQRss = KEMSharedKey ss} -> BA.convert ss) kemAccepted
(hk, nhk, sk) =
let salt = B.replicate 64 '\0'
in hkdf3 salt dhs "SimpleXX3DH"
in hkdf3 salt dhs "SimpleXX3DH"
type RatchetX448 = Ratchet 'X448
@@ -701,8 +703,8 @@ data EncMessageHeader = EncMessageHeader
-- this encoding depends on version in EncMessageHeader because it is "current" ratchet version
instance Encoding EncMessageHeader where
smpEncode EncMessageHeader {ehVersion, ehIV, ehAuthTag, ehBody} =
smpEncode (ehVersion, ehIV, ehAuthTag) <> encodeLarge ehVersion ehBody
smpEncode EncMessageHeader {ehVersion, ehIV, ehAuthTag, ehBody}
= smpEncode (ehVersion, ehIV, ehAuthTag) <> encodeLarge ehVersion ehBody
smpP = do
(ehVersion, ehIV, ehAuthTag) <- smpP
ehBody <- largeP
@@ -711,6 +713,8 @@ instance Encoding EncMessageHeader where
-- the encoder always uses 2-byte lengths for the new version, even for short headers without PQ keys.
encodeLarge :: VersionE2E -> ByteString -> ByteString
encodeLarge v s
-- the condition for length is not necessary, it's here as a fallback.
-- | v >= pqRatchetE2EEncryptVersion || B.length s > 255 = smpEncode $ Large s
| v >= pqRatchetE2EEncryptVersion = smpEncode $ Large s
| otherwise = smpEncode s
@@ -730,8 +734,8 @@ data EncRatchetMessage = EncRatchetMessage
}
encodeEncRatchetMessage :: VersionE2E -> EncRatchetMessage -> ByteString
encodeEncRatchetMessage v EncRatchetMessage {emHeader, emBody, emAuthTag} =
encodeLarge v emHeader <> smpEncode (emAuthTag, Tail emBody)
encodeEncRatchetMessage v EncRatchetMessage {emHeader, emBody, emAuthTag}
= encodeLarge v emHeader <> smpEncode (emAuthTag, Tail emBody)
encRatchetMessageP :: Parser EncRatchetMessage
encRatchetMessageP = do
@@ -10,21 +10,22 @@ import Data.Word (Word16)
import Simplex.Messaging.Client
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Notifications.Protocol
import Simplex.Messaging.Notifications.Transport (NTFVersion, supportedClientNTFVRange, supportedNTFHandshakes)
import Simplex.Messaging.Notifications.Transport (NTFVersion, supportedClientNTFVRange)
import Simplex.Messaging.Protocol (ErrorType)
import Simplex.Messaging.Util (bshow)
type NtfClient = ProtocolClient NTFVersion ErrorType NtfResponse
type NtfClientError = ProtocolClientError ErrorType
defaultNTFClientConfig :: ProtocolClientConfig NTFVersion
defaultNTFClientConfig = defaultClientConfig (Just supportedNTFHandshakes) supportedClientNTFVRange
defaultNTFClientConfig = defaultClientConfig supportedClientNTFVRange
ntfRegisterToken :: NtfClient -> C.APrivateAuthKey -> NewNtfEntity 'Token -> ExceptT NtfClientError IO (NtfTokenId, C.PublicKeyX25519)
ntfRegisterToken c pKey newTkn =
sendNtfCommand c (Just pKey) "" (TNEW newTkn) >>= \case
NRTknId tknId dhKey -> pure (tknId, dhKey)
r -> throwE $ unexpectedResponse r
r -> throwE . PCEUnexpectedResponse $ bshow r
ntfVerifyToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> NtfRegCode -> ExceptT NtfClientError IO ()
ntfVerifyToken c pKey tknId code = okNtfCommand (TVFY code) c pKey tknId
@@ -33,7 +34,7 @@ ntfCheckToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> ExceptT NtfClie
ntfCheckToken c pKey tknId =
sendNtfCommand c (Just pKey) tknId TCHK >>= \case
NRTkn stat -> pure stat
r -> throwE $ unexpectedResponse r
r -> throwE . PCEUnexpectedResponse $ bshow r
ntfReplaceToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> DeviceToken -> ExceptT NtfClientError IO ()
ntfReplaceToken c pKey tknId token = okNtfCommand (TRPL token) c pKey tknId
@@ -48,13 +49,13 @@ ntfCreateSubscription :: NtfClient -> C.APrivateAuthKey -> NewNtfEntity 'Subscri
ntfCreateSubscription c pKey newSub =
sendNtfCommand c (Just pKey) "" (SNEW newSub) >>= \case
NRSubId subId -> pure subId
r -> throwE $ unexpectedResponse r
r -> throwE . PCEUnexpectedResponse $ bshow r
ntfCheckSubscription :: NtfClient -> C.APrivateAuthKey -> NtfSubscriptionId -> ExceptT NtfClientError IO NtfSubStatus
ntfCheckSubscription c pKey subId =
sendNtfCommand c (Just pKey) subId SCHK >>= \case
NRSub stat -> pure stat
r -> throwE $ unexpectedResponse r
r -> throwE . PCEUnexpectedResponse $ bshow r
ntfDeleteSubscription :: NtfClient -> C.APrivateAuthKey -> NtfSubscriptionId -> ExceptT NtfClientError IO ()
ntfDeleteSubscription = okNtfCommand SDEL
@@ -67,4 +68,4 @@ okNtfCommand :: NtfEntityI e => NtfCommand e -> NtfClient -> C.APrivateAuthKey -
okNtfCommand cmd c pKey entId =
sendNtfCommand c (Just pKey) entId cmd >>= \case
NROk -> return ()
r -> throwE $ unexpectedResponse r
r -> throwE . PCEUnexpectedResponse $ bshow r
+20 -27
View File
@@ -31,7 +31,7 @@ import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
import Data.Time.Clock.System (getSystemTime)
import Data.Time.Format.ISO8601 (iso8601Show)
import Network.Socket (ServiceName)
import Simplex.Messaging.Client (ProtocolClientError (..), SMPClientError, ServerTransmission (..))
import Simplex.Messaging.Client (ProtocolClientError (..), SMPClientError)
import Simplex.Messaging.Client.Agent
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding.String
@@ -98,9 +98,7 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do
stopServer = do
withNtfLog closeStoreLog
saveServerStats
NtfSubscriber {smpSubscribers, smpAgent} <- asks subscriber
liftIO $ readTVarIO smpSubscribers >>= mapM_ (\SMPSubscriber {subThreadId} -> readTVarIO subThreadId >>= mapM_ (deRefWeak >=> mapM_ killThread))
liftIO $ closeSMPClientAgent smpAgent
asks (smpSubscribers . subscriber) >>= readTVarIO >>= mapM_ (\SMPSubscriber {subThreadId} -> readTVarIO subThreadId >>= mapM_ (liftIO . deRefWeak >=> mapM_ killThread))
serverStatsThread_ :: NtfServerConfig -> [M ()]
serverStatsThread_ NtfServerConfig {logStatsInterval = Just interval, logStatsStartTime, serverStatsLogFile} =
@@ -220,38 +218,33 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
receiveSMP :: M ()
receiveSMP = forever $ do
((_, srv, _), _, _, ts) <- atomically $ readTBQueue msgQ
forM ts $ \(ntfId, t) -> case t of
STUnexpectedError e -> logError $ "SMP client unexpected error: " <> tshow e -- uncorrelated response, should not happen
STResponse {} -> pure () -- it was already reported as timeout error
STEvent msgOrErr -> do
let smpQueue = SMPQueueNtf srv ntfId
case msgOrErr of
Right (SMP.NMSG nmsgNonce encNMsgMeta) -> do
ntfTs <- liftIO getSystemTime
st <- asks store
NtfPushServer {pushQ} <- asks pushServer
stats <- asks serverStats
atomically $ updatePeriodStats (activeSubs stats) ntfId
atomically $
findNtfSubscriptionToken st smpQueue
>>= mapM_ (\tkn -> writeTBQueue pushQ (tkn, PNMessage PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta}))
incNtfStat ntfReceived
Right SMP.END -> updateSubStatus smpQueue NSEnd
Right (SMP.ERR e) -> logError $ "SMP server error: " <> tshow e
Right _ -> logError $ "SMP server unexpected response"
Left e -> logError $ "SMP client error: " <> tshow e
((_, srv, _), _, _, ntfId, msg) <- atomically $ readTBQueue msgQ
let smpQueue = SMPQueueNtf srv ntfId
case msg of
SMP.NMSG nmsgNonce encNMsgMeta -> do
ntfTs <- liftIO getSystemTime
st <- asks store
NtfPushServer {pushQ} <- asks pushServer
stats <- asks serverStats
atomically $ updatePeriodStats (activeSubs stats) ntfId
atomically $
findNtfSubscriptionToken st smpQueue
>>= mapM_ (\tkn -> writeTBQueue pushQ (tkn, PNMessage PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta}))
incNtfStat ntfReceived
SMP.END -> updateSubStatus smpQueue NSEnd
_ -> pure ()
receiveAgent =
forever $
atomically (readTBQueue agentQ) >>= \case
CAConnected srv ->
logInfo $ "SMP server reconnected " <> showServer' srv
CAConnected _ -> pure ()
CADisconnected srv subs -> do
logSubStatus srv "disconnected" $ length subs
forM_ subs $ \(_, ntfId) -> do
let smpQueue = SMPQueueNtf srv ntfId
updateSubStatus smpQueue NSInactive
CAReconnected srv ->
logInfo $ "SMP server reconnected " <> showServer' srv
CAResubscribed srv subs -> do
forM_ subs $ \(_, ntfId) -> updateSubStatus (SMPQueueNtf srv ntfId) NSActive
logSubStatus srv "resubscribed" $ length subs
@@ -34,7 +34,7 @@ import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport (ATransport, THandleParams, TransportPeer (..))
import Simplex.Messaging.Transport.Server (TransportServerConfig, alpn, loadFingerprint, loadTLSServerParams)
import Simplex.Messaging.Transport.Server (TransportServerConfig, loadFingerprint, loadTLSServerParams)
import System.IO (IOMode (..))
import System.Mem.Weak (Weak)
import UnliftIO.STM
@@ -84,7 +84,7 @@ data NtfEnv = NtfEnv
}
newNtfServerEnv :: NtfServerConfig -> IO NtfEnv
newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsConfig, storeLogFile, caCertificateFile, certificateFile, privateKeyFile, transportConfig} = do
newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsConfig, storeLogFile, caCertificateFile, certificateFile, privateKeyFile} = do
random <- liftIO C.newRandom
store <- atomically newNtfStore
logInfo "restoring subscriptions..."
@@ -92,7 +92,7 @@ newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsCo
logInfo "restored subscriptions"
subscriber <- atomically $ newNtfSubscriber subQSize smpAgentCfg random
pushServer <- atomically $ newNtfPushServer pushQSize apnsConfig
tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile (alpn transportConfig)
tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile
Fingerprint fp <- liftIO $ loadFingerprint caCertificateFile
serverStats <- atomically . newNtfServerStats =<< liftIO getCurrentTime
pure NtfEnv {config, subscriber, pushServer, store, storeLog, random, tlsServerParams, serverIdentity = C.KeyHash fp, serverStats}
@@ -13,12 +13,12 @@ import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import Network.Socket (HostName)
import Options.Applicative
import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig)
import Simplex.Messaging.Client.Agent (defaultSMPClientAgentConfig)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Notifications.Server (runNtfServer)
import Simplex.Messaging.Notifications.Server.Env (NtfServerConfig (..), defaultInactiveClientExpiration)
import Simplex.Messaging.Notifications.Server.Push.APNS (defaultAPNSPushClientConfig)
import Simplex.Messaging.Notifications.Transport (supportedNTFHandshakes, supportedServerNTFVRange)
import Simplex.Messaging.Notifications.Transport (supportedServerNTFVRange)
import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern NtfServer)
import Simplex.Messaging.Server.CLI
import Simplex.Messaging.Server.Expiration
@@ -113,7 +113,7 @@ ntfServerCLI cfgPath logPath =
clientQSize = 64,
subQSize = 512,
pushQSize = 1048,
smpAgentCfg = defaultSMPClientAgentConfig {persistErrorInterval = 0},
smpAgentCfg = defaultSMPClientAgentConfig,
apnsConfig = defaultAPNSPushClientConfig,
subsBatchSize = 900,
inactiveClientExpiration =
@@ -133,8 +133,7 @@ ntfServerCLI cfgPath logPath =
ntfServerVRange = supportedServerNTFVRange,
transportConfig =
defaultTransportServerConfig
{ logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini,
alpn = Just supportedNTFHandshakes
{ logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini
}
}
@@ -11,7 +11,6 @@ module Simplex.Messaging.Notifications.Transport where
import Control.Monad (forM)
import Control.Monad.Except
import Control.Monad.Trans.Except
import Data.Attoparsec.ByteString.Char8 (Parser)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
@@ -45,23 +44,17 @@ authBatchCmdsNTFVersion :: VersionNTF
authBatchCmdsNTFVersion = VersionNTF 2
currentClientNTFVersion :: VersionNTF
currentClientNTFVersion = VersionNTF 2
currentClientNTFVersion = VersionNTF 1
currentServerNTFVersion :: VersionNTF
currentServerNTFVersion = VersionNTF 2
currentServerNTFVersion = VersionNTF 1
supportedClientNTFVRange :: VersionRangeNTF
supportedClientNTFVRange = mkVersionRange initialNTFVersion currentClientNTFVersion
legacyServerNTFVRange :: VersionRangeNTF
legacyServerNTFVRange = mkVersionRange initialNTFVersion initialNTFVersion
supportedServerNTFVRange :: VersionRangeNTF
supportedServerNTFVRange = mkVersionRange initialNTFVersion currentServerNTFVersion
supportedNTFHandshakes :: [ALPN]
supportedNTFHandshakes = ["ntf/1"]
type THandleNTF c p = THandle NTFVersion c p
data NtfServerHandshake = NtfServerHandshake
@@ -111,16 +104,14 @@ ntfServerHandshake :: forall c. Transport c => C.APrivateSignKey -> c -> C.KeyPa
ntfServerHandshake serverSignKey c (k, pk) kh ntfVRange = do
let th@THandle {params = THandleParams {sessionId}} = ntfTHandle c
let sk = C.signX509 serverSignKey $ C.publicToX509 k
let ntfVersionRange = maybe legacyServerNTFVRange (const ntfVRange) $ getSessionALPN c
sendHandshake th $ NtfServerHandshake {sessionId, ntfVersionRange, authPubKey = Just sk}
sendHandshake th $ NtfServerHandshake {sessionId, ntfVersionRange = ntfVRange, authPubKey = Just sk}
getHandshake th >>= \case
NtfClientHandshake {ntfVersion = v, keyHash}
| keyHash /= kh ->
throwError $ TEHandshake IDENTITY
| otherwise ->
case compatibleVRange' ntfVersionRange v of
Just (Compatible vr) -> pure $ ntfThHandleServer th v vr pk
Nothing -> throwE TEVersion
| v `isCompatible` ntfVRange ->
pure $ ntfThHandleServer th v pk
| otherwise -> throwError $ TEHandshake VERSION
-- | Notifcations server client transport handshake.
ntfClientHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRangeNTF -> ExceptT TransportError IO (THandleNTF c 'TClient)
@@ -129,45 +120,34 @@ ntfClientHandshake c keyHash ntfVRange = do
NtfServerHandshake {sessionId = sessId, ntfVersionRange, authPubKey = sk'} <- getHandshake th
if sessionId /= sessId
then throwError TEBadSession
else case ntfVersionRange `compatibleVRange` ntfVRange of
Just (Compatible vr) -> do
else case ntfVersionRange `compatibleVersion` ntfVRange of
Just (Compatible v) -> do
ck_ <- forM sk' $ \signedKey -> liftEitherWith (const $ TEHandshake BAD_AUTH) $ do
serverKey <- getServerVerifyKey c
pubKey <- C.verifyX509 serverKey signedKey
(,(getServerCerts c, signedKey)) <$> (C.x509ToPublic (pubKey, []) >>= C.pubKey)
let v = maxVersion vr
sendHandshake th $ NtfClientHandshake {ntfVersion = v, keyHash}
pure $ ntfThHandleClient th v vr ck_
Nothing -> throwE TEVersion
pure $ ntfThHandleClient th v ck_
Nothing -> throwError $ TEHandshake VERSION
ntfThHandleServer :: forall c. THandleNTF c 'TServer -> VersionNTF -> VersionRangeNTF -> C.PrivateKeyX25519 -> THandleNTF c 'TServer
ntfThHandleServer th v vr pk =
ntfThHandleServer :: forall c. THandleNTF c 'TServer -> VersionNTF -> C.PrivateKeyX25519 -> THandleNTF c 'TServer
ntfThHandleServer th v pk =
let thAuth = THAuthServer {serverPrivKey = pk, sessSecret' = Nothing}
in ntfThHandle_ th v vr (Just thAuth)
in ntfThHandle_ th v (Just thAuth)
ntfThHandleClient :: forall c. THandleNTF c 'TClient -> VersionNTF -> VersionRangeNTF -> Maybe (C.PublicKeyX25519, (X.CertificateChain, X.SignedExact X.PubKey)) -> THandleNTF c 'TClient
ntfThHandleClient th v vr ck_ =
ntfThHandleClient :: forall c. THandleNTF c 'TClient -> VersionNTF -> Maybe (C.PublicKeyX25519, (X.CertificateChain, X.SignedExact X.PubKey)) -> THandleNTF c 'TClient
ntfThHandleClient th v ck_ =
let thAuth = (\(k, ck) -> THAuthClient {serverPeerPubKey = k, serverCertKey = ck, sessSecret = Nothing}) <$> ck_
in ntfThHandle_ th v vr thAuth
in ntfThHandle_ th v thAuth
ntfThHandle_ :: forall c p. THandleNTF c p -> VersionNTF -> VersionRangeNTF -> Maybe (THandleAuth p) -> THandleNTF c p
ntfThHandle_ th@THandle {params} v vr thAuth =
ntfThHandle_ :: forall c p. THandleNTF c p -> VersionNTF -> Maybe (THandleAuth p) -> THandleNTF c p
ntfThHandle_ th@THandle {params} v thAuth =
-- TODO drop SMP v6: make thAuth non-optional
let v3 = v >= authBatchCmdsNTFVersion
params' = params {thVersion = v, thServerVRange = vr, thAuth, implySessId = v3, batch = v3}
params' = params {thVersion = v, thAuth, implySessId = v3, batch = v3}
in (th :: THandleNTF c p) {params = params'}
ntfTHandle :: Transport c => c -> THandleNTF c p
ntfTHandle c = THandle {connection = c, params}
where
v = VersionNTF 0
params =
THandleParams
{ sessionId = tlsUnique c,
blockSize = ntfBlockSize,
thVersion = v,
thServerVRange = versionToRange v,
thAuth = Nothing,
implySessId = False,
batch = False
}
params = THandleParams {sessionId = tlsUnique c, blockSize = ntfBlockSize, thVersion = VersionNTF 0, thAuth = Nothing, implySessId = False, batch = False}
+63 -105
View File
@@ -44,6 +44,7 @@ module Simplex.Messaging.Protocol
supportedSMPClientVRange,
maxMessageLength,
paddedProxiedMsgLength,
paddedForwardedMsgLength,
e2eEncConfirmationLength,
e2eEncMessageLength,
@@ -66,7 +67,6 @@ module Simplex.Messaging.Protocol
ErrorType (..),
CommandError (..),
ProxyError (..),
BrokerErrorType (..),
Transmission,
TransmissionAuth (..),
SignedTransmission,
@@ -177,7 +177,6 @@ module Simplex.Messaging.Protocol
where
import Control.Applicative (optional, (<|>))
import Control.Exception (Exception)
import Control.Monad
import Control.Monad.Except
import Data.Aeson (FromJSON (..), ToJSON (..))
@@ -244,16 +243,23 @@ currentSMPClientVersion = VersionSMPC 2
supportedSMPClientVRange :: VersionRangeSMPC
supportedSMPClientVRange = mkVersionRange initialSMPClientVersion currentSMPClientVersion
-- TODO v6.0 remove dependency on version
maxMessageLength :: VersionSMP -> Int
maxMessageLength v
| v >= sendingProxySMPVersion = 16064 -- max 16067
| otherwise = 16088 -- 16064 - always use this size to determine allowed ranges
maxMessageLength :: Int
maxMessageLength = 16088
-- without signature works with min 16151 (fails with 16150)
-- with Ed448: 16265 (fails with 16264)
-- with Ed25519: 16215 (fails with 16214)
-- with X25519: 16232 (fails with 16231)
paddedProxiedMsgLength :: Int
paddedProxiedMsgLength = 16242 -- 16241 .. 16243
paddedProxiedMsgLength = 16232
-- without signature works with min 16239 (fails with 16238)
-- with Ed448: 16353 (fails with 16352)
-- with Ed25519: 16303 (fails with 16302)
-- with X25519: 16320 (fails with 16319)
paddedForwardedMsgLength :: Int
paddedForwardedMsgLength = 16320
-- TODO v6.0 change to 16064
type MaxMessageLen = 16088
-- 16 extra bytes: 8 for timestamp and 8 for flags (7 flags and the space, only 1 flag is currently used)
@@ -261,10 +267,10 @@ type MaxRcvMessageLen = MaxMessageLen + 16 -- 16104, the padded size is 16106
-- it is shorter to allow per-queue e2e encryption DH key in the "public" header
e2eEncConfirmationLength :: Int
e2eEncConfirmationLength = 15920 -- 15881 .. 15976
e2eEncConfirmationLength = 15936
e2eEncMessageLength :: Int
e2eEncMessageLength = 16016 -- 16004 .. 16021
e2eEncMessageLength = 16032
-- | SMP protocol clients
data Party = Recipient | Sender | Notifier | ProxiedClient
@@ -399,7 +405,7 @@ data Command (p :: Party) where
-- - corrId: also used as a nonce to encrypt transmission to relay, corrId + 1 - from relay
-- - key (1st param in the command) is used to agree DH secret for this particular transmission and its response
-- Encrypted transmission should include session ID (tlsunique) from proxy-relay connection.
PFWD :: VersionSMP -> C.PublicKeyX25519 -> EncTransmission -> Command ProxiedClient -- use CorrId as CbNonce, client to proxy
PFWD :: C.PublicKeyX25519 -> EncTransmission -> Command ProxiedClient -- use CorrId as CbNonce, client to proxy
-- Transmission forwarded to relay:
-- - entity ID: empty
-- - corrId: unique correlation ID between proxy and relay, also used as a nonce to encrypt forwarded transmission
@@ -434,17 +440,16 @@ newtype EncTransmission = EncTransmission ByteString
data FwdTransmission = FwdTransmission
{ fwdCorrId :: CorrId,
fwdVersion :: VersionSMP,
fwdKey :: C.PublicKeyX25519,
fwdTransmission :: EncTransmission
}
instance Encoding FwdTransmission where
smpEncode FwdTransmission {fwdCorrId = CorrId corrId, fwdVersion, fwdKey, fwdTransmission = EncTransmission t} =
smpEncode (corrId, fwdVersion, fwdKey, Tail t)
smpEncode FwdTransmission {fwdCorrId = CorrId corrId, fwdKey, fwdTransmission = EncTransmission t} =
smpEncode (corrId, fwdKey, Tail t)
smpP = do
(corrId, fwdVersion, fwdKey, Tail t) <- smpP
pure FwdTransmission {fwdCorrId = CorrId corrId, fwdVersion, fwdKey, fwdTransmission = EncTransmission t}
(corrId, fwdKey, Tail t) <- smpP
pure FwdTransmission {fwdCorrId = CorrId corrId, fwdKey, fwdTransmission = EncTransmission t}
newtype EncFwdTransmission = EncFwdTransmission ByteString
deriving (Show)
@@ -1147,8 +1152,6 @@ data ErrorType
PROXY {proxyErr :: ProxyError}
| -- | command authorization error - bad signature or non-existing SMP queue
AUTH
| -- | encryption/decryption error in proxy protocol
CRYPTO
| -- | SMP queue capacity is exceeded on the server
QUOTA
| -- | ACK command is sent without message to be acknowledged
@@ -1191,32 +1194,19 @@ data CommandError
data ProxyError
= -- | Correctly parsed SMP server ERR response.
-- This error is forwarded to the agent client as AgentErrorType `ERR PROXY PROTOCOL err`.
-- This error is forwarded to the agent client as `ERR SMP err`.
PROTOCOL {protocolErr :: ErrorType}
| -- | destination server error
BROKER {brokerErr :: BrokerErrorType}
| -- | basic auth provided to proxy is invalid
BASIC_AUTH
| -- no destination server error
NO_SESSION
| -- | Invalid server response that failed to parse.
-- Forwarded to the agent client as `ERR BROKER RESPONSE`.
RESPONSE {responseErr :: ErrorType}
| UNEXPECTED {unexpectedResponse :: String} -- 'String' for using derived JSON and Arbitrary instances
| TIMEOUT
| NETWORK
| BAD_HOST
| NO_SESSION
| TRANSPORT {transportErr :: TransportError}
deriving (Eq, Read, Show)
-- | SMP server errors.
data BrokerErrorType
= -- | invalid server response (failed to parse)
RESPONSE {respErr :: String}
| -- | unexpected response
UNEXPECTED {respErr :: String}
| -- | network error
NETWORK
| -- | no compatible server host (e.g. onion when public is required, or vice versa)
HOST
| -- | handshake or other transport error
TRANSPORT {transportErr :: TransportError}
| -- | command response timeout
TIMEOUT
deriving (Eq, Read, Show, Exception)
-- | SMP transmission parser.
transmissionP :: THandleParams v p -> Parser RawTransmission
transmissionP THandleParams {sessionId, implySessId} = do
@@ -1279,7 +1269,7 @@ instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where
PING -> e PING_
NSUB -> e NSUB_
PRXY host auth_ -> e (PRXY_, ' ', host, auth_)
PFWD fwdV pubKey (EncTransmission s) -> e (PFWD_, ' ', fwdV, pubKey, Tail s)
PFWD pubKey (EncTransmission s) -> e (PFWD_, ' ', pubKey, Tail s)
RFWD (EncFwdTransmission s) -> e (RFWD_, ' ', Tail s)
where
e :: Encoding a => a -> ByteString
@@ -1347,7 +1337,7 @@ instance ProtocolEncoding SMPVersion ErrorType Cmd where
RFWD_ -> RFWD <$> (EncFwdTransmission . unTail <$> _smpP)
CT SProxiedClient tag ->
Cmd SProxiedClient <$> case tag of
PFWD_ -> PFWD <$> _smpP <*> smpP <*> (EncTransmission . unTail <$> smpP)
PFWD_ -> PFWD <$> _smpP <*> (EncTransmission . unTail <$> smpP)
PRXY_ -> PRXY <$> _smpP <*> smpP
CT SNotifier NSUB_ -> pure $ Cmd SNotifier NSUB
@@ -1441,7 +1431,6 @@ instance Encoding ErrorType where
CMD err -> "CMD " <> smpEncode err
PROXY err -> "PROXY " <> smpEncode err
AUTH -> "AUTH"
CRYPTO -> "CRYPTO"
QUOTA -> "QUOTA"
EXPIRED -> "EXPIRED"
NO_MSG -> "NO_MSG"
@@ -1456,14 +1445,13 @@ instance Encoding ErrorType where
"CMD" -> CMD <$> _smpP
"PROXY" -> PROXY <$> _smpP
"AUTH" -> pure AUTH
"CRYPTO" -> pure CRYPTO
"QUOTA" -> pure QUOTA
"EXPIRED" -> pure EXPIRED
"NO_MSG" -> pure NO_MSG
"LARGE_MSG" -> pure LARGE_MSG
"INTERNAL" -> pure INTERNAL
"DUPLICATE_" -> pure DUPLICATE_
_ -> fail "bad ErrorType"
_ -> fail "bad error type"
instance Encoding CommandError where
smpEncode e = case e of
@@ -1482,73 +1470,45 @@ instance Encoding CommandError where
"HAS_AUTH" -> pure HAS_AUTH
"NO_ENTITY" -> pure NO_ENTITY
"NO_QUEUE" -> pure NO_ENTITY -- for backward compatibility
_ -> fail "bad CommandError"
_ -> fail "bad command error type"
instance Encoding ProxyError where
smpEncode = \case
PROTOCOL e -> "PROTOCOL " <> smpEncode e
BROKER e -> "BROKER " <> smpEncode e
BASIC_AUTH -> "BASIC_AUTH"
smpEncode e = case e of
PROTOCOL et -> "PROTOCOL " <> smpEncode et
RESPONSE et -> "RESPONSE " <> smpEncode et
UNEXPECTED s -> "UNEXPECTED " <> smpEncode (encodeUtf8 $ T.pack s)
TIMEOUT -> "TIMEOUT"
NETWORK -> "NETWORK"
BAD_HOST -> "BAD_HOST"
NO_SESSION -> "NO_SESSION"
TRANSPORT t -> "TRANSPORT " <> serializeTransportError t
smpP =
A.takeTill (== ' ') >>= \case
"PROTOCOL" -> PROTOCOL <$> _smpP
"BROKER" -> BROKER <$> _smpP
"BASIC_AUTH" -> pure BASIC_AUTH
"RESPONSE" -> RESPONSE <$> _smpP
"UNEXPECTED" -> UNEXPECTED . (T.unpack . safeDecodeUtf8) <$> _smpP
"TIMEOUT" -> pure TIMEOUT
"NETWORK" -> pure NETWORK
"BAD_HOST" -> pure BAD_HOST
"NO_SESSION" -> pure NO_SESSION
_ -> fail "bad ProxyError"
"TRANSPORT" -> TRANSPORT <$> (A.space *> transportErrorP)
_ -> fail "bad command error type"
instance StrEncoding ProxyError where
strEncode = \case
PROTOCOL e -> "PROTOCOL " <> strEncode e
BROKER e -> "BROKER " <> strEncode e
BASIC_AUTH -> "BASIC_AUTH"
NO_SESSION -> "NO_SESSION"
PROTOCOL et -> "PROTOCOL " <> strEncode et
RESPONSE et -> "RESPONSE " <> strEncode et
UNEXPECTED "" -> "UNEXPECTED" -- Arbitrary instance generates empty strings which String instance can't handle
UNEXPECTED s -> "UNEXPECTED " <> strEncode s
TRANSPORT t -> "TRANSPORT " <> serializeTransportError t
e -> bshow e
strP =
A.takeTill (== ' ') >>= \case
"PROTOCOL" -> PROTOCOL <$> _strP
"BROKER" -> BROKER <$> _strP
"BASIC_AUTH" -> pure BASIC_AUTH
"NO_SESSION" -> pure NO_SESSION
_ -> fail "bad ProxyError"
instance Encoding BrokerErrorType where
smpEncode = \case
RESPONSE e -> "RESPONSE " <> smpEncode e
UNEXPECTED e -> "UNEXPECTED " <> smpEncode e
TRANSPORT e -> "TRANSPORT " <> smpEncode e
NETWORK -> "NETWORK"
TIMEOUT -> "TIMEOUT"
HOST -> "HOST"
smpP =
A.takeTill (== ' ') >>= \case
"RESPONSE" -> RESPONSE <$> _smpP
"UNEXPECTED" -> UNEXPECTED <$> _smpP
"TRANSPORT" -> TRANSPORT <$> _smpP
"NETWORK" -> pure NETWORK
"TIMEOUT" -> pure TIMEOUT
"HOST" -> pure HOST
_ -> fail "bad BrokerErrorType"
instance StrEncoding BrokerErrorType where
strEncode = \case
RESPONSE e -> "RESPONSE " <> encodeUtf8 (T.pack e)
UNEXPECTED e -> "UNEXPECTED " <> encodeUtf8 (T.pack e)
TRANSPORT e -> "TRANSPORT " <> smpEncode e
NETWORK -> "NETWORK"
TIMEOUT -> "TIMEOUT"
HOST -> "HOST"
strP =
A.takeTill (== ' ') >>= \case
"RESPONSE" -> RESPONSE <$> _textP
"UNEXPECTED" -> UNEXPECTED <$> _textP
"TRANSPORT" -> TRANSPORT <$> _smpP
"NETWORK" -> pure NETWORK
"TIMEOUT" -> pure TIMEOUT
"HOST" -> pure HOST
_ -> fail "bad BrokerErrorType"
where
_textP = A.space *> (T.unpack . safeDecodeUtf8 <$> A.takeByteString)
"PROTOCOL " *> (PROTOCOL <$> strP)
<|> "RESPONSE " *> (RESPONSE <$> strP)
<|> "UNEXPECTED " *> (UNEXPECTED <$> strP)
<|> "UNEXPECTED" $> UNEXPECTED ""
<|> "TRANSPORT " *> (TRANSPORT <$> transportErrorP)
<|> parseRead1
-- | Send signed SMP transmission to TCP transport.
tPut :: Transport c => THandle v c p -> NonEmpty (Either TransportError SentRawTransmission) -> IO [Either TransportError ()]
@@ -1687,7 +1647,5 @@ $(J.deriveJSON defaultJSON ''MsgFlags)
$(J.deriveJSON (sumTypeJSON id) ''CommandError)
$(J.deriveJSON (sumTypeJSON id) ''BrokerErrorType)
-- run deriveJSON in one TH splice to allow mutual instance
$(concat <$> mapM @[] (J.deriveJSON (sumTypeJSON id)) [''ProxyError, ''ErrorType])
+104 -206
View File
@@ -6,7 +6,6 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
@@ -45,7 +44,6 @@ import Control.Monad.IO.Unlift
import Control.Monad.Reader
import Control.Monad.Trans.Except
import Crypto.Random
import Control.Monad.STM (retry)
import Data.Bifunctor (first)
import Data.ByteString.Base64 (encode)
import Data.ByteString.Char8 (ByteString)
@@ -55,8 +53,8 @@ import Data.Either (fromRight, partitionEithers)
import Data.Functor (($>))
import Data.Int (Int64)
import qualified Data.IntMap.Strict as IM
import Data.List (intercalate, mapAccumR)
import Data.List.NonEmpty (NonEmpty (..))
import Data.List (intercalate)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as L
import qualified Data.Map.Strict as M
import Data.Maybe (isNothing)
@@ -70,8 +68,8 @@ import GHC.Stats (getRTSStats)
import GHC.TypeLits (KnownNat)
import Network.Socket (ServiceName, Socket, socketToHandle)
import Simplex.Messaging.Agent.Lock
import Simplex.Messaging.Client (ProtocolClient (thParams), ProtocolClientError (..), forwardSMPMessage, smpProxyError, temporaryClientError)
import Simplex.Messaging.Client.Agent (OwnServer, SMPClientAgent (..), SMPClientAgentEvent (..), closeSMPClientAgent, getSMPServerClient'', isOwnServer, lookupSMPServerClient)
import Simplex.Messaging.Client (ProtocolClient (thParams), ProtocolClientError (PCEIOError), forwardSMPMessage, smpProxyError)
import Simplex.Messaging.Client.Agent (SMPClientAgent (..), SMPClientAgentEvent (..), getSMPServerClient', lookupSMPServerClient)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
@@ -91,11 +89,11 @@ import Simplex.Messaging.Transport
import Simplex.Messaging.Transport.Buffer (trimCR)
import Simplex.Messaging.Transport.Server
import Simplex.Messaging.Util
import Simplex.Messaging.Version
import System.Exit (exitFailure)
import System.IO (hPrint, hPutStrLn, hSetNewlineMode, universalNewlineMode)
import System.Mem.Weak (deRefWeak)
import UnliftIO (timeout)
import UnliftIO.Async (mapConcurrently)
import UnliftIO.Concurrent
import UnliftIO.Directory (doesFileExist, renameFile)
import UnliftIO.Exception
@@ -137,7 +135,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
: receiveFromProxyAgent pa
: map runServer transports <> expireMessagesThread_ cfg <> serverStatsThread_ cfg <> controlPortThread_ cfg
)
`finally` withLock' (savingLock s) "final" (saveServer False >> closeServer)
`finally` withLock' (savingLock s) "final" (saveServer False)
where
runServer :: (ServiceName, ATransport) -> M ()
runServer (tcpPort, ATransport t) = do
@@ -151,9 +149,6 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
saveServer :: Bool -> M ()
saveServer keepMsgs = withLog closeStoreLog >> saveServerMessages keepMsgs >> saveServerStats
closeServer :: M ()
closeServer = asks (smpAgent . proxyAgent) >>= liftIO . closeSMPClientAgent
serverThread ::
forall s.
Server ->
@@ -182,8 +177,12 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
TM.lookupInsert qId clnt (subs s) $>>= clientToBeNotified
endPreviousSubscriptions :: (QueueId, Client) -> M (Maybe s)
endPreviousSubscriptions (qId, c) = do
forkClient c (label <> ".endPreviousSubscriptions") $
tId <- atomically $ stateTVar (endThreadSeq c) $ \next -> (next, next + 1)
t <- forkIO $ do
labelMyThread $ label <> ".endPreviousSubscriptions"
atomically $ writeTBQueue (sndQ c) [(CorrId "", qId, END)]
atomically $ modifyTVar' (endThreads c) $ IM.delete tId
mkWeakThreadId t >>= atomically . modifyTVar' (endThreads c) . IM.insert tId
atomically $ TM.lookupDelete qId (clientSubs c)
receiveFromProxyAgent :: ProxyAgent -> M ()
@@ -193,6 +192,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
CAConnected srv -> logInfo $ "SMP server connected " <> showServer' srv
CADisconnected srv [] -> logInfo $ "SMP server disconnected " <> showServer' srv
CADisconnected srv subs -> logError $ "SMP server disconnected " <> showServer' srv <> " / subscriptions: " <> tshow (length subs)
CAReconnected srv -> logInfo $ "SMP server reconnected " <> showServer' srv
CAResubscribed srv subs -> logError $ "SMP server resubscribed " <> showServer' srv <> " / subscriptions: " <> tshow (length subs)
CASubError srv errs -> logError $ "SMP server subscription errors " <> showServer' srv <> " / errors: " <> tshow (length errs)
where
@@ -229,7 +229,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
initialDelay <- (startAt -) . fromIntegral . (`div` 1000000_000000) . diffTimeToPicoseconds . utctDayTime <$> liftIO getCurrentTime
liftIO $ putStrLn $ "server stats log enabled: " <> statsFilePath
liftIO $ threadDelay' $ 1000000 * (initialDelay + if initialDelay < 0 then 86400 else 0)
ServerStats {fromTime, qCreated, qSecured, qDeletedAll, qDeletedNew, qDeletedSecured, msgSent, msgRecv, msgExpired, activeQueues, msgSentNtf, msgRecvNtf, activeQueuesNtf, qCount, msgCount, pRelays, pRelaysOwn, pMsgFwds, pMsgFwdsOwn, pMsgFwdsRecv} <- asks serverStats
ServerStats {fromTime, qCreated, qSecured, qDeletedAll, qDeletedNew, qDeletedSecured, msgSent, msgRecv, msgExpired, activeQueues, msgSentNtf, msgRecvNtf, activeQueuesNtf, qCount, msgCount} <- asks serverStats
let interval = 1000000 * logInterval
forever $ do
withFile statsFilePath AppendMode $ \h -> liftIO $ do
@@ -248,46 +248,32 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
msgSentNtf' <- atomically $ swapTVar msgSentNtf 0
msgRecvNtf' <- atomically $ swapTVar msgRecvNtf 0
psNtf <- atomically $ periodStatCounts activeQueuesNtf ts
pRelays' <- atomically $ getResetProxyStatsData pRelays
pRelaysOwn' <- atomically $ getResetProxyStatsData pRelaysOwn
pMsgFwds' <- atomically $ getResetProxyStatsData pMsgFwds
pMsgFwdsOwn' <- atomically $ getResetProxyStatsData pMsgFwdsOwn
pMsgFwdsRecv' <- atomically $ swapTVar pMsgFwdsRecv 0
qCount' <- readTVarIO qCount
msgCount' <- readTVarIO msgCount
hPutStrLn h $
intercalate
","
( [ iso8601Show $ utctDay fromTime',
show qCreated',
show qSecured',
show qDeletedAll',
show msgSent',
show msgRecv',
dayCount ps,
weekCount ps,
monthCount ps,
show msgSentNtf',
show msgRecvNtf',
dayCount psNtf,
weekCount psNtf,
monthCount psNtf,
show qCount',
show msgCount',
show msgExpired',
show qDeletedNew',
show qDeletedSecured'
]
<> showProxyStats pRelays'
<> showProxyStats pRelaysOwn'
<> showProxyStats pMsgFwds'
<> showProxyStats pMsgFwdsOwn'
<> [show pMsgFwdsRecv']
)
[ iso8601Show $ utctDay fromTime',
show qCreated',
show qSecured',
show qDeletedAll',
show msgSent',
show msgRecv',
dayCount ps,
weekCount ps,
monthCount ps,
show msgSentNtf',
show msgRecvNtf',
dayCount psNtf,
weekCount psNtf,
monthCount psNtf,
show qCount',
show msgCount',
show msgExpired',
show qDeletedNew',
show qDeletedSecured'
]
liftIO $ threadDelay' interval
where
showProxyStats ProxyStatsData {_pRequests, _pSuccesses, _pErrorsConnect, _pErrorsCompat, _pErrorsOther} =
[show _pRequests, show _pSuccesses, show _pErrorsConnect, show _pErrorsCompat, show _pErrorsOther]
runClient :: Transport c => C.APrivateSignKey -> TProxy c -> c -> M ()
runClient signKey tp h = do
@@ -357,13 +343,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
subscriptions' <- bshow . M.size <$> readTVarIO subscriptions
hPutStrLn h . B.unpack $ B.intercalate "," [bshow cid, encode sessionId, connected', strEncode createdAt, rcvActiveAt', sndActiveAt', bshow age, subscriptions']
CPStats -> withAdminRole $ do
ss <- unliftIO u $ asks serverStats
let putStat :: Show a => ByteString -> (ServerStats -> TVar a) -> IO ()
putStat label var = readTVarIO (var ss) >>= \v -> B.hPutStr h $ label <> ": " <> bshow v <> "\n"
putProxyStat :: ByteString -> (ServerStats -> ProxyStats) -> IO ()
putProxyStat label var = do
ProxyStatsData {_pRequests, _pSuccesses, _pErrorsConnect, _pErrorsCompat, _pErrorsOther} <- atomically $ getProxyStatsData $ var ss
B.hPutStr h $ label <> ": requests=" <> bshow _pRequests <> ", successes=" <> bshow _pSuccesses <> ", errorsConnect=" <> bshow _pErrorsConnect <> ", errorsCompat=" <> bshow _pErrorsCompat <> ", errorsOther=" <> bshow _pErrorsOther <> "\n"
ServerStats {fromTime, qCreated, qSecured, qDeletedAll, qDeletedNew, qDeletedSecured, msgSent, msgRecv, msgSentNtf, msgRecvNtf, qCount, msgCount} <- unliftIO u $ asks serverStats
putStat "fromTime" fromTime
putStat "qCreated" qCreated
putStat "qSecured" qSecured
@@ -376,11 +356,9 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
putStat "msgRecvNtf" msgRecvNtf
putStat "qCount" qCount
putStat "msgCount" msgCount
putProxyStat "pRelays" pRelays
putProxyStat "pRelaysOwn" pRelaysOwn
putProxyStat "pMsgFwds" pMsgFwds
putProxyStat "pMsgFwdsOwn" pMsgFwdsOwn
putStat "pMsgFwdsRecv" pMsgFwdsRecv
where
putStat :: Show a => String -> TVar a -> IO ()
putStat label var = readTVarIO var >>= \v -> hPutStrLn h $ label <> ": " <> show v
CPStatsRTS -> getRTSStats >>= hPrint h
CPThreads -> withAdminRole $ do
#if MIN_VERSION_base(4,18,0)
@@ -451,7 +429,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
hPutStrLn h "AUTH"
runClientTransport :: Transport c => THandleSMP c 'TServer -> M ()
runClientTransport h@THandle {params = thParams@THandleParams {thVersion, sessionId}} = do
runClientTransport th@THandle {params = thParams@THandleParams {thVersion, sessionId}} = do
q <- asks $ tbqSize . config
ts <- liftIO getSystemTime
active <- asks clients
@@ -462,12 +440,11 @@ runClientTransport h@THandle {params = thParams@THandleParams {thVersion, sessio
pure new
s <- asks server
expCfg <- asks $ inactiveClientExpiration . config
th <- newMVar h -- put TH under a fair lock to interleave messages and command responses
labelMyThread . B.unpack $ "client $" <> encode sessionId
raceAny_ ([liftIO $ send th c, liftIO $ sendMsg th c, client thParams c s, receive h c] <> disconnectThread_ c expCfg)
raceAny_ ([liftIO $ send th c, client thParams c s, receive th c] <> disconnectThread_ c expCfg)
`finally` clientDisconnected c
where
disconnectThread_ c (Just expCfg) = [liftIO $ disconnectTransport h (rcvActiveAt c) (sndActiveAt c) expCfg (noSubscriptions c)]
disconnectThread_ c (Just expCfg) = [liftIO $ disconnectTransport th (rcvActiveAt c) (sndActiveAt c) expCfg (noSubscriptions c)]
disconnectThread_ _ _ = []
noSubscriptions c = atomically $ (&&) <$> TM.null (subscriptions c) <*> TM.null (ntfSubscriptions c)
@@ -500,10 +477,10 @@ cancelSub sub =
_ -> return ()
receive :: Transport c => THandleSMP c 'TServer -> Client -> M ()
receive h@THandle {params = THandleParams {thAuth}} Client {rcvQ, sndQ, rcvActiveAt, sessionId} = do
receive th@THandle {params = THandleParams {thAuth}} Client {rcvQ, sndQ, rcvActiveAt, sessionId} = do
labelMyThread . B.unpack $ "client $" <> encode sessionId <> " receive"
forever $ do
ts <- L.toList <$> liftIO (tGet h)
ts <- L.toList <$> liftIO (tGet th)
atomically . writeTVar rcvActiveAt =<< liftIO getSystemTime
(errs, cmds) <- partitionEithers <$> mapM cmdAction ts
write sndQ errs
@@ -520,41 +497,20 @@ receive h@THandle {params = THandleParams {thAuth}} Client {rcvQ, sndQ, rcvActiv
VRFailed -> Left (corrId, entId, ERR AUTH)
write q = mapM_ (atomically . writeTBQueue q) . L.nonEmpty
send :: Transport c => MVar (THandleSMP c 'TServer) -> Client -> IO ()
send th c@Client {sndQ, msgQ, sessionId} = do
send :: Transport c => THandleSMP c 'TServer -> Client -> IO ()
send h@THandle {params} Client {sndQ, sessionId, sndActiveAt} = do
labelMyThread . B.unpack $ "client $" <> encode sessionId <> " send"
forever $ atomically (readTBQueue sndQ) >>= sendTransmissions
forever $ do
ts <- atomically $ L.sortWith tOrder <$> readTBQueue sndQ
-- TODO we can authorize responses as well
void . liftIO . tPut h $ L.map (\t -> Right (Nothing, encodeTransmission params t)) ts
atomically . writeTVar sndActiveAt =<< liftIO getSystemTime
where
sendTransmissions :: NonEmpty (Transmission BrokerMsg) -> IO ()
sendTransmissions ts
| L.length ts <= 2 = tSend th c ts
| otherwise = do
let (msgs_, ts') = mapAccumR splitMessages [] ts
-- If the request had batched subscriptions (L.length ts > 2)
-- this will reply OK to all SUBs in the first batched transmission,
-- to reduce client timeouts.
tSend th c ts'
-- After that all messages will be sent in separate transmissions,
-- without any client response timeouts, and allowing them to interleave
-- with other requests responses.
mapM_ (atomically . writeTBQueue msgQ) $ L.nonEmpty msgs_
where
splitMessages :: [Transmission BrokerMsg] -> Transmission BrokerMsg -> ([Transmission BrokerMsg], Transmission BrokerMsg)
splitMessages msgs t@(corrId, entId, cmd) = case cmd of
-- replace MSG response with OK, accumulating MSG in a separate list.
MSG {} -> ((CorrId "", entId, cmd) : msgs, (corrId, entId, OK))
_ -> (msgs, t)
sendMsg :: Transport c => MVar (THandleSMP c 'TServer) -> Client -> IO ()
sendMsg th c@Client {msgQ, sessionId} = do
labelMyThread . B.unpack $ "client $" <> encode sessionId <> " sendMsg"
forever $ atomically (readTBQueue msgQ) >>= mapM_ (\t -> tSend th c [t])
tSend :: Transport c => MVar (THandleSMP c 'TServer) -> Client -> NonEmpty (Transmission BrokerMsg) -> IO ()
tSend th Client {sndActiveAt} ts = do
withMVar th $ \h@THandle {params} ->
void . tPut h $ L.map (\t -> Right (Nothing, encodeTransmission params t)) ts
atomically . writeTVar sndActiveAt =<< liftIO getSystemTime
tOrder :: Transmission BrokerMsg -> Int
tOrder (_, _, cmd) = case cmd of
MSG {} -> 0
NMSG {} -> 0
_ -> 1
disconnectTransport :: Transport c => THandle v c 'TServer -> TVar SystemTime -> TVar SystemTime -> ExpirationConfig -> IO Bool -> IO ()
disconnectTransport THandle {connection, params = THandleParams {sessionId}} rcvActiveAt sndActiveAt expCfg noSubscriptions = do
@@ -646,97 +602,42 @@ dummyKeyEd448 = "MEMwBQYDK2VxAzoA6ibQc9XpkSLtwrf7PLvp81qW/etiumckVFImCMRdftcG/Xo
dummyKeyX25519 :: C.PublicKey 'C.X25519
dummyKeyX25519 = "MCowBQYDK2VuAyEA4JGSMYht18H4mas/jHeBwfcM7jLwNYJNOAhi2/g4RXg="
forkClient :: Client -> String -> M () -> M ()
forkClient Client {endThreads, endThreadSeq} label action = do
tId <- atomically $ stateTVar endThreadSeq $ \next -> (next, next + 1)
t <- forkIO $ do
labelMyThread label
action `finally` atomically (modifyTVar' endThreads $ IM.delete tId)
mkWeakThreadId t >>= atomically . modifyTVar' endThreads . IM.insert tId
client :: THandleParams SMPVersion 'TServer -> Client -> Server -> M ()
client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessionId, procThreads} Server {subscribedQ, ntfSubscribedQ, notifiers} = do
client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessionId} Server {subscribedQ, ntfSubscribedQ, notifiers} = do
labelMyThread . B.unpack $ "client $" <> encode sessionId <> " commands"
forever $ do
(proxied, rs) <- partitionEithers . L.toList <$> (mapM processCommand =<< atomically (readTBQueue rcvQ))
forM_ (L.nonEmpty rs) reply
forM_ (L.nonEmpty proxied) $ \cmds -> mapM forkProxiedCmd cmds >>= mapM (atomically . takeTMVar) >>= reply
-- TODO cancel this thread if the client gets disconnected
-- TODO limit client concurrency
forM_ (L.nonEmpty proxied) $ \cmds -> forkIO $ mapConcurrently processProxiedCmd cmds >>= reply
where
reply :: MonadIO m => NonEmpty (Transmission BrokerMsg) -> m ()
reply = atomically . writeTBQueue sndQ
forkProxiedCmd :: Transmission (Command 'ProxiedClient) -> M (TMVar (Transmission BrokerMsg))
forkProxiedCmd cmd = do
res <- newEmptyTMVarIO
bracket_ wait signal . forkClient clnt (B.unpack $ "client $" <> encode sessionId <> " proxy") $
-- commands MUST be processed under a reasonable timeout or the client would halt
processProxiedCmd cmd >>= atomically . putTMVar res
pure res
where
wait = do
ServerConfig {serverClientConcurrency} <- asks config
atomically $ do
used <- readTVar procThreads
when (used >= serverClientConcurrency) retry
writeTVar procThreads $! used + 1
signal = atomically $ modifyTVar' procThreads (\t -> t - 1)
processProxiedCmd :: Transmission (Command 'ProxiedClient) -> M (Transmission BrokerMsg)
processProxiedCmd (corrId, sessId, command) = (corrId, sessId,) <$> case command of
PRXY srv auth -> ifM allowProxy getRelay (pure $ ERR $ PROXY BASIC_AUTH)
PRXY srv auth -> ifM allowProxy getRelay (pure $ ERR AUTH)
where
allowProxy = do
ServerConfig {allowSMPProxy, newQueueBasicAuth} <- asks config
pure $ allowSMPProxy && maybe True ((== auth) . Just) newQueueBasicAuth
getRelay = do
ServerStats {pRelays, pRelaysOwn} <- asks serverStats
let inc = mkIncProxyStats pRelays pRelaysOwn
ProxyAgent {smpAgent = a} <- asks proxyAgent
liftIO (runExceptT (getSMPServerClient'' a srv) `catch` (pure . Left . PCEIOError)) >>= \case
Right (own, smp) -> do
inc own pRequests
case proxyResp smp of
r@PKEY {} -> r <$ inc own pSuccesses
r -> r <$ inc own pErrorsCompat
Left e -> do
let own = isOwnServer a srv
inc own pRequests
inc own $ if temporaryClientError e then pErrorsConnect else pErrorsOther
pure . ERR $ smpProxyError e
ProxyAgent {smpAgent} <- asks proxyAgent
liftIO $ proxyResp <$> runExceptT (getSMPServerClient' smpAgent srv) `catch` (pure . Left . PCEIOError)
where
proxyResp smp =
let THandleParams {sessionId = srvSessId, thVersion, thServerVRange, thAuth} = thParams smp
in case compatibleVRange thServerVRange proxiedSMPRelayVRange of
-- Cap the destination relay version range to prevent client version fingerprinting.
-- See comment for proxiedSMPRelayVersion.
Just (Compatible vr) | thVersion >= sendingProxySMPVersion -> case thAuth of
proxyResp = \case
Right smp ->
let THandleParams {sessionId = srvSessId, thAuth} = thParams smp
vr = supportedServerSMPRelayVRange
in case thAuth of
Just THAuthClient {serverCertKey} -> PKEY srvSessId vr serverCertKey
Nothing -> ERR $ transportErr TENoServerAuth
_ -> ERR $ transportErr TEVersion
PFWD fwdV pubKey encBlock -> do
ProxyAgent {smpAgent = a} <- asks proxyAgent
ServerStats {pMsgFwds, pMsgFwdsOwn} <- asks serverStats
let inc = mkIncProxyStats pMsgFwds pMsgFwdsOwn
atomically (lookupSMPServerClient a sessId) >>= \case
Just (own, smp) -> do
inc own pRequests
if
| v >= sendingProxySMPVersion ->
liftIO (runExceptT (forwardSMPMessage smp corrId fwdV pubKey encBlock) `catch` (pure . Left . PCEIOError)) >>= \case
Right r -> PRES r <$ inc own pSuccesses
Left e -> case e of
PCEProtocolError {} -> ERR err <$ inc own pSuccesses
_ -> ERR err <$ inc own pErrorsOther
where
err = smpProxyError e
| otherwise -> ERR (transportErr TEVersion) <$ inc own pErrorsCompat
where
THandleParams {thVersion = v} = thParams smp
Nothing -> inc False pRequests >> inc False pErrorsConnect $> ERR (PROXY NO_SESSION)
transportErr :: TransportError -> ErrorType
transportErr = PROXY . BROKER . TRANSPORT
mkIncProxyStats :: MonadIO m => ProxyStats -> ProxyStats -> OwnServer -> (ProxyStats -> TVar Int) -> m ()
mkIncProxyStats ps psOwn = \own sel -> do
atomically $ modifyTVar' (sel ps) (+ 1)
when own $ atomically $ modifyTVar' (sel psOwn) (+ 1)
Nothing -> ERR $ PROXY (TRANSPORT TENoServerAuth)
Left err -> ERR $ smpProxyError err
PFWD pubKey encBlock -> do
ProxyAgent {smpAgent} <- asks proxyAgent
atomically (lookupSMPServerClient smpAgent sessId) >>= \case
Just smp -> liftIO $ either (ERR . smpProxyError) PRES <$> runExceptT (forwardSMPMessage smp corrId pubKey encBlock)
Nothing -> pure $ ERR $ PROXY NO_SESSION
processCommand :: (Maybe QueueRec, Transmission Cmd) -> M (Either (Transmission (Command 'ProxiedClient)) (Transmission BrokerMsg))
processCommand (qr_, (corrId, queueId, cmd)) = do
st <- asks queueStore
@@ -954,7 +855,7 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi
sendMessage :: QueueRec -> MsgFlags -> MsgBody -> M (Transmission BrokerMsg)
sendMessage qr msgFlags msgBody
| B.length msgBody > maxMessageLength thVersion = pure $ err LARGE_MSG
| B.length msgBody > maxMessageLength = pure $ err LARGE_MSG
| otherwise = case status qr of
QueueOff -> return $ err AUTH
QueueActive ->
@@ -978,7 +879,6 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi
atomically $ updatePeriodStats (activeQueues stats) (recipientId qr)
pure ok
where
THandleParams {thVersion} = thParams'
mkMessage :: C.MaxLenBS MaxMessageLen -> M Message
mkMessage body = do
msgId <- randomId =<< asks (msgIdBytes . config)
@@ -1014,50 +914,50 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi
pure . (cbNonce,) $ fromRight "" encNMsgMeta
processForwardedCommand :: EncFwdTransmission -> M BrokerMsg
processForwardedCommand (EncFwdTransmission s) = fmap (either ERR id) . runExceptT $ do
THAuthServer {serverPrivKey, sessSecret'} <- maybe (throwE $ transportErr TENoServerAuth) pure (thAuth thParams')
sessSecret <- maybe (throwE $ transportErr TENoServerAuth) pure sessSecret'
processForwardedCommand (EncFwdTransmission s) = fmap (either id id) . runExceptT $ do
-- TODO error
THAuthServer {serverPrivKey, sessSecret'} <- maybe (throwError $ ERR INTERNAL) pure thAuth
sessSecret <- maybe (throwError $ ERR INTERNAL) pure sessSecret'
let proxyNonce = C.cbNonce $ bs corrId
s' <- liftEitherWith (const CRYPTO) $ C.cbDecryptNoPad sessSecret proxyNonce s
FwdTransmission {fwdCorrId, fwdVersion, fwdKey, fwdTransmission = EncTransmission et} <- liftEitherWith (const $ CMD SYNTAX) $ smpDecode s'
-- TODO error
s' <- liftEitherWith internalErr $ C.cbDecrypt sessSecret proxyNonce s
-- TODO error
FwdTransmission {fwdCorrId, fwdKey, fwdTransmission = EncTransmission et} <- liftEitherWith internalErr $ smpDecode s'
-- TODO error - this error is reported to proxy, as we failed to get to client's transmission
let clientSecret = C.dh' fwdKey serverPrivKey
clientNonce = C.cbNonce $ bs fwdCorrId
b <- liftEitherWith (const CRYPTO) $ C.cbDecrypt clientSecret clientNonce et
let clntTHParams = smpTHParamsSetVersion fwdVersion thParams'
b <- liftEitherWith internalErr $ C.cbDecrypt clientSecret clientNonce et
-- only allowing single forwarded transactions
t' <- case tParse clntTHParams b of
t :| [] -> pure $ tDecodeParseValidate clntTHParams t
_ -> throwE BLOCK
let clntThAuth = Just $ THAuthServer {serverPrivKey, sessSecret' = Just clientSecret}
-- process forwarded SEND
let t' = tDecodeParseValidate thParams' $ L.head $ tParse thParams' b
clntThAuth = Just $ THAuthServer {serverPrivKey, sessSecret' = Just clientSecret}
-- TODO error
r <-
lift (rejectOrVerify clntThAuth t') >>= \case
Left r -> pure r
Right t''@(_, (corrId', entId', cmd')) -> case cmd' of
Cmd SSender SEND {} ->
-- Left will not be returned by processCommand, as only SEND command is allowed
fromRight (corrId', entId', ERR INTERNAL) <$> lift (processCommand t'')
_ ->
pure (corrId', entId', ERR $ CMD PROHIBITED)
Right t''@(_, (corrId', entId', _)) ->
-- Left will not be returned by processCommand, as only SEND command is allowed
fromRight (corrId', entId', ERR INTERNAL) <$> lift (processCommand t'')
-- encode response
r' <- case batchTransmissions (batch clntTHParams) (blockSize clntTHParams) [Right (Nothing, encodeTransmission clntTHParams r)] of
[] -> throwE INTERNAL -- at least 1 item is guaranteed from NonEmpty/Right
TBError _ _ : _ -> throwE BLOCK
r' <- case batchTransmissions (batch thParams') (blockSize thParams') [Right (Nothing, encodeTransmission thParams' r)] of
[] -> throwE $ ERR INTERNAL -- TODO error
TBError _ _ : _ -> throwE $ ERR INTERNAL -- TODO error
TBTransmission b' _ : _ -> pure b'
TBTransmissions b' _ _ : _ -> pure b'
-- encrypt to client
r2 <- liftEitherWith (const BLOCK) $ EncResponse <$> C.cbEncrypt clientSecret (C.reverseNonce clientNonce) r' paddedProxiedMsgLength
r2 <- liftEitherWith internalErr $ EncResponse <$> C.cbEncrypt clientSecret (C.reverseNonce clientNonce) r' paddedProxiedMsgLength
-- encrypt to proxy
let fr = FwdResponse {fwdCorrId, fwdResponse = r2}
r3 = EncFwdResponse $ C.cbEncryptNoPad sessSecret (C.reverseNonce proxyNonce) (smpEncode fr)
stats <- asks serverStats
atomically $ modifyTVar' (pMsgFwdsRecv stats) (+ 1)
r3 <- liftEitherWith internalErr $ EncFwdResponse <$> C.cbEncrypt sessSecret (C.reverseNonce proxyNonce) (smpEncode fr) paddedForwardedMsgLength
pure $ RRES r3
where
internalErr _ = ERR INTERNAL -- TODO errors
THandleParams {thAuth} = thParams'
rejectOrVerify :: Maybe (THandleAuth 'TServer) -> SignedTransmission ErrorType Cmd -> M (Either (Transmission BrokerMsg) (Maybe QueueRec, Transmission Cmd))
rejectOrVerify clntThAuth (tAuth, authorized, (corrId', entId', cmdOrError)) =
case cmdOrError of
Left e -> pure $ Left (corrId', entId', ERR e)
-- flags msgBody -> withQueue $ \qr -> sendMessage qr flags msgBody
Right cmd'@(Cmd SSender SEND {}) -> verified <$> verifyTransmission ((,C.cbNonce (bs corrId')) <$> clntThAuth) tAuth authorized entId' cmd'
where
verified = \case
@@ -1073,10 +973,9 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi
Just msg ->
let encMsg = encryptMsg qr msg
in atomically (setDelivered s msg) $> (corrId, rId, MSG encMsg)
_ -> forkSub $> resp
_ -> pure resp
_ -> forkSub $> ok
_ -> pure ok
where
resp = (corrId, rId, OK)
forkSub :: M ()
forkSub = do
atomically . modifyTVar' sub $ \s -> s {subThread = SubPending}
@@ -1178,10 +1077,9 @@ saveServerMessages keepMsgs = asks (storeMsgsFile . config) >>= mapM_ saveMessag
>>= mapM_ (B.hPutStrLn h . strEncode . MLRv3 rId)
restoreServerMessages :: M Int
restoreServerMessages =
asks (storeMsgsFile . config) >>= \case
Just f -> ifM (doesFileExist f) (restoreMessages f) (pure 0)
Nothing -> pure 0
restoreServerMessages = asks (storeMsgsFile . config) >>= \case
Just f -> ifM (doesFileExist f) (restoreMessages f) (pure 0)
Nothing -> pure 0
where
restoreMessages f = do
logInfo $ "restoring messages from file " <> T.pack f
+9 -15
View File
@@ -35,7 +35,7 @@ import Simplex.Messaging.Server.StoreLog
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport (ATransport, VersionRangeSMP, VersionSMP)
import Simplex.Messaging.Transport.Server (SocketState, TransportServerConfig, alpn, loadFingerprint, loadTLSServerParams, newSocketState)
import Simplex.Messaging.Transport.Server (SocketState, TransportServerConfig, loadFingerprint, loadTLSServerParams, newSocketState)
import System.IO (IOMode (..))
import System.Mem.Weak (Weak)
import UnliftIO.STM
@@ -82,8 +82,7 @@ data ServerConfig = ServerConfig
-- | run listener on control port
controlPort :: Maybe ServiceName,
smpAgentCfg :: SMPClientAgentConfig,
allowSMPProxy :: Bool, -- auth is the same with `newQueueBasicAuth`
serverClientConcurrency :: Int
allowSMPProxy :: Bool -- auth is the same with `newQueueBasicAuth`
}
defMsgExpirationDays :: Int64
@@ -103,9 +102,6 @@ defaultInactiveClientExpiration =
checkInterval = 3600 -- seconds, 1 hours
}
defaultProxyClientConcurrency :: Int
defaultProxyClientConcurrency = 16
data Env = Env
{ config :: ServerConfig,
server :: Server,
@@ -130,7 +126,7 @@ data Server = Server
savingLock :: Lock
}
newtype ProxyAgent = ProxyAgent
data ProxyAgent = ProxyAgent
{ smpAgent :: SMPClientAgent
}
@@ -142,8 +138,6 @@ data Client = Client
ntfSubscriptions :: TMap NotifierId (),
rcvQ :: TBQueue (NonEmpty (Maybe QueueRec, Transmission Cmd)),
sndQ :: TBQueue (NonEmpty (Transmission BrokerMsg)),
msgQ :: TBQueue (NonEmpty (Transmission BrokerMsg)),
procThreads :: TVar Int,
endThreads :: TVar (IntMap (Weak ThreadId)),
endThreadSeq :: TVar Int,
thVersion :: VersionSMP,
@@ -151,7 +145,8 @@ data Client = Client
connected :: TVar Bool,
createdAt :: SystemTime,
rcvActiveAt :: TVar SystemTime,
sndActiveAt :: TVar SystemTime
sndActiveAt :: TVar SystemTime,
proxyClient_ :: TVar (Maybe C.DhSecretX25519) -- this client is actually an SMP proxy
}
data SubscriptionThread = NoSub | SubPending | SubThread (Weak ThreadId) | ProhibitSub
@@ -177,14 +172,13 @@ newClient nextClientId qSize thVersion sessionId createdAt = do
ntfSubscriptions <- TM.empty
rcvQ <- newTBQueue qSize
sndQ <- newTBQueue qSize
msgQ <- newTBQueue qSize
procThreads <- newTVar 0
endThreads <- newTVar IM.empty
endThreadSeq <- newTVar 0
connected <- newTVar True
rcvActiveAt <- newTVar createdAt
sndActiveAt <- newTVar createdAt
return Client {clientId, subscriptions, ntfSubscriptions, rcvQ, sndQ, msgQ, procThreads, endThreads, endThreadSeq, thVersion, sessionId, connected, createdAt, rcvActiveAt, sndActiveAt}
proxyClient_ <- newTVar Nothing
return Client {clientId, subscriptions, ntfSubscriptions, rcvQ, sndQ, endThreads, endThreadSeq, thVersion, sessionId, connected, createdAt, rcvActiveAt, sndActiveAt, proxyClient_}
newSubscription :: SubscriptionThread -> STM Sub
newSubscription subThread = do
@@ -192,13 +186,13 @@ newSubscription subThread = do
return Sub {subThread, delivered}
newEnv :: ServerConfig -> IO Env
newEnv config@ServerConfig {caCertificateFile, certificateFile, privateKeyFile, storeLogFile, smpAgentCfg, transportConfig} = do
newEnv config@ServerConfig {caCertificateFile, certificateFile, privateKeyFile, storeLogFile, smpAgentCfg} = do
server <- atomically newServer
queueStore <- atomically newQueueStore
msgStore <- atomically newMsgStore
random <- liftIO C.newRandom
storeLog <- restoreQueues queueStore `mapM` storeLogFile
tlsServerParams <- loadTLSServerParams caCertificateFile certificateFile privateKeyFile (alpn transportConfig)
tlsServerParams <- loadTLSServerParams caCertificateFile certificateFile privateKeyFile
Fingerprint fp <- loadFingerprint caCertificateFile
let serverIdentity = KeyHash fp
serverStats <- atomically . newServerStats =<< getCurrentTime
+8 -56
View File
@@ -10,26 +10,24 @@ module Simplex.Messaging.Server.Main where
import Control.Concurrent.STM
import Control.Monad (void)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Functor (($>))
import Data.Ini (lookupValue, readIniFile)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Network.Socket (HostName)
import Options.Applicative
import Simplex.Messaging.Client (HostMode (..), NetworkConfig (..), ProtocolClientConfig (..), SocksMode (..), defaultNetworkConfig)
import Simplex.Messaging.Client (ProtocolClientConfig (..))
import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (ProtoServerWithAuth), pattern SMPServer)
import Simplex.Messaging.Server (runSMPServer)
import Simplex.Messaging.Server.CLI
import Simplex.Messaging.Server.Env.STM (ServerConfig (..), defMsgExpirationDays, defaultInactiveClientExpiration, defaultMessageExpiration, defaultProxyClientConcurrency)
import Simplex.Messaging.Server.Env.STM (ServerConfig (..), defMsgExpirationDays, defaultInactiveClientExpiration, defaultMessageExpiration)
import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.Transport (batchCmdsSMPVersion, sendingProxySMPVersion, simplexMQVersion, supportedSMPHandshakes, supportedServerSMPRelayVRange)
import Simplex.Messaging.Transport (simplexMQVersion, supportedServerSMPRelayVRange, batchCmdsSMPVersion, sendingProxySMPVersion)
import Simplex.Messaging.Transport.Client (TransportHost (..))
import Simplex.Messaging.Transport.Server (TransportServerConfig (..), defaultTransportServerConfig)
import Simplex.Messaging.Util (safeDecodeUtf8)
@@ -134,7 +132,7 @@ smpServerCLI cfgPath logPath =
)
<> "\n\n\
\# control_port_admin_password:\n\
\# control_port_user_password:\n\n\
\# control_port_user_password:\n\
\[TRANSPORT]\n\
\# host is only used to print server address on start\n"
<> ("host: " <> host <> "\n")
@@ -142,23 +140,7 @@ smpServerCLI cfgPath logPath =
<> "log_tls_errors: off\n\
\websockets: off\n\
\# control_port: 5224\n\n\
\[PROXY]\n\
\# Network configuration for SMP proxy client.\n\
\# `host_mode` can be 'public' (default) or 'onion'.\n\
\# It defines prefferred hostname for destination servers with multiple hostnames.\n\
\# host_mode: public\n\
\# required_host_mode: off\n\n\
\# The domain suffixes of the relays you operate (space-separated) to count as separate proxy statistics.\n\
\# own_server_domains: \n\n\
\# SOCKS proxy port for forwarding messages to destination servers.\n\
\# You may need a separate instance of SOCKS proxy for incoming single-hop requests.\n\
\# socks_proxy: localhost:9050\n\n\
\# `socks_mode` can be 'onion' for SOCKS proxy to be used for .onion destination hosts only (default)\n\
\# or 'always' to be used for all destination hosts (can be used if it is an .onion server).\n\
\# socks_mode: onion\n\n\
\# Limit number of threads a client can spawn to process proxy commands in parrallel.\n"
<> ("# client_concurrency: " <> show defaultProxyClientConcurrency <> "\n\n")
<> "[INACTIVE_CLIENTS]\n\
\[INACTIVE_CLIENTS]\n\
\# TTL and interval to check inactive clients\n\
\disconnect: off\n"
<> ("# ttl: " <> show (ttl defaultInactiveClientExpiration) <> "\n")
@@ -232,42 +214,12 @@ smpServerCLI cfgPath logPath =
smpServerVRange = supportedServerSMPRelayVRange,
transportConfig =
defaultTransportServerConfig
{ logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini,
alpn = Just supportedSMPHandshakes
{ logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini
},
controlPort = either (const Nothing) (Just . T.unpack) $ lookupValue "TRANSPORT" "control_port" ini,
smpAgentCfg =
defaultSMPClientAgentConfig
{ smpCfg =
(smpCfg defaultSMPClientAgentConfig)
{ serverVRange = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion,
agreeSecret = True,
networkConfig =
defaultNetworkConfig
{ socksProxy = either error id <$> strDecodeIni "PROXY" "socks_proxy" ini,
socksMode = either (const SMOnion) textToSocksMode $ lookupValue "PROXY" "socks_mode" ini,
hostMode = either (const HMPublic) textToHostMode $ lookupValue "PROXY" "host_mode" ini,
requiredHostMode = fromMaybe False $ iniOnOff "PROXY" "required_host_mode" ini
}
},
ownServerDomains = either (const []) textToOwnServers $ lookupValue "PROXY" "own_server_domains" ini,
persistErrorInterval = 30 -- seconds
},
allowSMPProxy = True,
serverClientConcurrency = readIniDefault defaultProxyClientConcurrency "PROXY" "client_concurrency" ini
smpAgentCfg = defaultSMPClientAgentConfig {smpCfg = (smpCfg defaultSMPClientAgentConfig) {serverVRange = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion, agreeSecret = True}},
allowSMPProxy = True -- TODO: "get from INI"
}
textToSocksMode :: Text -> SocksMode
textToSocksMode = \case
"always" -> SMAlways
"onion" -> SMOnion
s -> error . T.unpack $ "Invalid socks_mode: " <> s
textToHostMode :: Text -> HostMode
textToHostMode = \case
"public" -> HMPublic
"onion" -> HMOnionViaSocks
s -> error . T.unpack $ "Invalid host_mode: " <> s
textToOwnServers :: Text -> [ByteString]
textToOwnServers = map encodeUtf8 . T.words
data CliCommand
= Init InitOptions
+18 -137
View File
@@ -33,11 +33,6 @@ data ServerStats = ServerStats
msgSentNtf :: TVar Int,
msgRecvNtf :: TVar Int,
activeQueuesNtf :: PeriodStats RecipientId,
pRelays :: ProxyStats,
pRelaysOwn :: ProxyStats,
pMsgFwds :: ProxyStats,
pMsgFwdsOwn :: ProxyStats,
pMsgFwdsRecv :: TVar Int,
qCount :: TVar Int,
msgCount :: TVar Int
}
@@ -56,11 +51,6 @@ data ServerStatsData = ServerStatsData
_msgSentNtf :: Int,
_msgRecvNtf :: Int,
_activeQueuesNtf :: PeriodStatsData RecipientId,
_pRelays :: ProxyStatsData,
_pRelaysOwn :: ProxyStatsData,
_pMsgFwds :: ProxyStatsData,
_pMsgFwdsOwn :: ProxyStatsData,
_pMsgFwdsRecv :: Int,
_qCount :: Int,
_msgCount :: Int
}
@@ -81,14 +71,9 @@ newServerStats ts = do
msgSentNtf <- newTVar 0
msgRecvNtf <- newTVar 0
activeQueuesNtf <- newPeriodStats
pRelays <- newProxyStats
pRelaysOwn <- newProxyStats
pMsgFwds <- newProxyStats
pMsgFwdsOwn <- newProxyStats
pMsgFwdsRecv <- newTVar 0
qCount <- newTVar 0
msgCount <- newTVar 0
pure ServerStats {fromTime, qCreated, qSecured, qDeletedAll, qDeletedNew, qDeletedSecured, msgSent, msgRecv, msgExpired, activeQueues, msgSentNtf, msgRecvNtf, activeQueuesNtf, pRelays, pRelaysOwn, pMsgFwds, pMsgFwdsOwn, pMsgFwdsRecv, qCount, msgCount}
pure ServerStats {fromTime, qCreated, qSecured, qDeletedAll, qDeletedNew, qDeletedSecured, msgSent, msgRecv, msgExpired, activeQueues, msgSentNtf, msgRecvNtf, activeQueuesNtf, qCount, msgCount}
getServerStatsData :: ServerStats -> STM ServerStatsData
getServerStatsData s = do
@@ -105,14 +90,9 @@ getServerStatsData s = do
_msgSentNtf <- readTVar $ msgSentNtf s
_msgRecvNtf <- readTVar $ msgRecvNtf s
_activeQueuesNtf <- getPeriodStatsData $ activeQueuesNtf s
_pRelays <- getProxyStatsData $ pRelays s
_pRelaysOwn <- getProxyStatsData $ pRelaysOwn s
_pMsgFwds <- getProxyStatsData $ pMsgFwds s
_pMsgFwdsOwn <- getProxyStatsData $ pMsgFwdsOwn s
_pMsgFwdsRecv <- readTVar $ pMsgFwdsRecv s
_qCount <- readTVar $ qCount s
_msgCount <- readTVar $ msgCount s
pure ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeletedAll, _qDeletedNew, _qDeletedSecured, _msgSent, _msgRecv, _msgExpired, _activeQueues, _msgSentNtf, _msgRecvNtf, _activeQueuesNtf, _pRelays, _pRelaysOwn, _pMsgFwds, _pMsgFwdsOwn, _pMsgFwdsRecv, _qCount, _msgCount}
pure ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeletedAll, _qDeletedNew, _qDeletedSecured, _msgSent, _msgRecv, _msgExpired, _activeQueues, _msgSentNtf, _msgRecvNtf, _activeQueuesNtf, _qCount, _msgCount}
setServerStats :: ServerStats -> ServerStatsData -> STM ()
setServerStats s d = do
@@ -129,42 +109,28 @@ setServerStats s d = do
writeTVar (msgSentNtf s) $! _msgSentNtf d
writeTVar (msgRecvNtf s) $! _msgRecvNtf d
setPeriodStats (activeQueuesNtf s) (_activeQueuesNtf d)
setProxyStats (pRelays s) $! _pRelays d
setProxyStats (pRelaysOwn s) $! _pRelaysOwn d
setProxyStats (pMsgFwds s) $! _pMsgFwds d
setProxyStats (pMsgFwdsOwn s) $! _pMsgFwdsOwn d
writeTVar (pMsgFwdsRecv s) $! _pMsgFwdsRecv d
writeTVar (qCount s) $! _qCount d
writeTVar (msgCount s) $! _msgCount d
instance StrEncoding ServerStatsData where
strEncode d =
strEncode ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeletedAll, _qDeletedNew, _qDeletedSecured, _msgSent, _msgRecv, _msgExpired, _msgSentNtf, _msgRecvNtf, _activeQueues, _activeQueuesNtf, _qCount, _msgCount} =
B.unlines
[ "fromTime=" <> strEncode (_fromTime d),
"qCreated=" <> strEncode (_qCreated d),
"qSecured=" <> strEncode (_qSecured d),
"qDeletedAll=" <> strEncode (_qDeletedAll d),
"qDeletedNew=" <> strEncode (_qDeletedNew d),
"qDeletedSecured=" <> strEncode (_qDeletedSecured d),
"qCount=" <> strEncode (_qCount d),
"msgSent=" <> strEncode (_msgSent d),
"msgRecv=" <> strEncode (_msgRecv d),
"msgExpired=" <> strEncode (_msgExpired d),
"msgSentNtf=" <> strEncode (_msgSentNtf d),
"msgRecvNtf=" <> strEncode (_msgRecvNtf d),
[ "fromTime=" <> strEncode _fromTime,
"qCreated=" <> strEncode _qCreated,
"qSecured=" <> strEncode _qSecured,
"qDeletedAll=" <> strEncode _qDeletedAll,
"qDeletedNew=" <> strEncode _qDeletedNew,
"qDeletedSecured=" <> strEncode _qDeletedSecured,
"qCount=" <> strEncode _qCount,
"msgSent=" <> strEncode _msgSent,
"msgRecv=" <> strEncode _msgRecv,
"msgExpired=" <> strEncode _msgExpired,
"msgSentNtf=" <> strEncode _msgSentNtf,
"msgRecvNtf=" <> strEncode _msgRecvNtf,
"activeQueues:",
strEncode (_activeQueues d),
strEncode _activeQueues,
"activeQueuesNtf:",
strEncode (_activeQueuesNtf d),
"pRelays:",
strEncode (_pRelays d),
"pRelaysOwn:",
strEncode (_pRelaysOwn d),
"pMsgFwds:",
strEncode (_pMsgFwds d),
"pMsgFwdsOwn:",
strEncode (_pMsgFwdsOwn d),
"pMsgFwdsRecv=" <> strEncode (_pMsgFwdsRecv d)
strEncode _activeQueuesNtf
]
strP = do
_fromTime <- "fromTime=" *> strP <* A.endOfLine
@@ -191,17 +157,7 @@ instance StrEncoding ServerStatsData where
optional ("activeQueuesNtf:" <* A.endOfLine) >>= \case
Just _ -> strP <* optional A.endOfLine
_ -> pure newPeriodStatsData
_pRelays <- proxyStatsP "pRelays:"
_pRelaysOwn <- proxyStatsP "pRelaysOwn:"
_pMsgFwds <- proxyStatsP "pMsgFwds:"
_pMsgFwdsOwn <- proxyStatsP "pMsgFwdsOwn:"
_pMsgFwdsRecv <- "pMsgFwdsRecv=" *> strP <* A.endOfLine <|> pure 0
pure ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeletedAll, _qDeletedNew, _qDeletedSecured, _msgSent, _msgRecv, _msgExpired, _msgSentNtf, _msgRecvNtf, _activeQueues, _activeQueuesNtf, _pRelays, _pRelaysOwn, _pMsgFwds, _pMsgFwdsOwn, _pMsgFwdsRecv, _qCount, _msgCount = 0}
where
proxyStatsP key =
optional (A.string key >> A.endOfLine) >>= \case
Just _ -> strP <* optional A.endOfLine
_ -> pure newProxyStatsData
pure ServerStatsData {_fromTime, _qCreated, _qSecured, _qDeletedAll, _qDeletedNew, _qDeletedSecured, _msgSent, _msgRecv, _msgExpired, _msgSentNtf, _msgRecvNtf, _activeQueues, _activeQueuesNtf, _qCount, _msgCount = 0}
data PeriodStats a = PeriodStats
{ day :: TVar (Set a),
@@ -275,78 +231,3 @@ updatePeriodStats stats pId = do
updatePeriod month
where
updatePeriod pSel = modifyTVar' (pSel stats) (S.insert pId)
data ProxyStats = ProxyStats
{ pRequests :: TVar Int,
pSuccesses :: TVar Int, -- includes destination server error responses that will be forwarded to the client
pErrorsConnect :: TVar Int,
pErrorsCompat :: TVar Int,
pErrorsOther :: TVar Int
}
newProxyStats :: STM ProxyStats
newProxyStats = do
pRequests <- newTVar 0
pSuccesses <- newTVar 0
pErrorsConnect <- newTVar 0
pErrorsCompat <- newTVar 0
pErrorsOther <- newTVar 0
pure ProxyStats {pRequests, pSuccesses, pErrorsConnect, pErrorsCompat, pErrorsOther}
data ProxyStatsData = ProxyStatsData
{ _pRequests :: Int,
_pSuccesses :: Int,
_pErrorsConnect :: Int,
_pErrorsCompat :: Int,
_pErrorsOther :: Int
}
deriving (Show)
newProxyStatsData :: ProxyStatsData
newProxyStatsData = ProxyStatsData {_pRequests = 0, _pSuccesses = 0, _pErrorsConnect = 0, _pErrorsCompat = 0, _pErrorsOther = 0}
getProxyStatsData :: ProxyStats -> STM ProxyStatsData
getProxyStatsData s = do
_pRequests <- readTVar $ pRequests s
_pSuccesses <- readTVar $ pSuccesses s
_pErrorsConnect <- readTVar $ pErrorsConnect s
_pErrorsCompat <- readTVar $ pErrorsCompat s
_pErrorsOther <- readTVar $ pErrorsOther s
pure ProxyStatsData {_pRequests, _pSuccesses, _pErrorsConnect, _pErrorsCompat, _pErrorsOther}
getResetProxyStatsData :: ProxyStats -> STM ProxyStatsData
getResetProxyStatsData s = do
_pRequests <- swapTVar (pRequests s) 0
_pSuccesses <- swapTVar (pSuccesses s) 0
_pErrorsConnect <- swapTVar (pErrorsConnect s) 0
_pErrorsCompat <- swapTVar (pErrorsCompat s) 0
_pErrorsOther <- swapTVar (pErrorsOther s) 0
pure ProxyStatsData {_pRequests, _pSuccesses, _pErrorsConnect, _pErrorsCompat, _pErrorsOther}
setProxyStats :: ProxyStats -> ProxyStatsData -> STM ()
setProxyStats s d = do
writeTVar (pRequests s) $! _pRequests d
writeTVar (pSuccesses s) $! _pSuccesses d
writeTVar (pErrorsConnect s) $! _pErrorsConnect d
writeTVar (pErrorsCompat s) $! _pErrorsCompat d
writeTVar (pErrorsOther s) $! _pErrorsOther d
instance StrEncoding ProxyStatsData where
strEncode ProxyStatsData {_pRequests, _pSuccesses, _pErrorsConnect, _pErrorsCompat, _pErrorsOther} =
"requests="
<> strEncode _pRequests
<> "\nsuccesses="
<> strEncode _pSuccesses
<> "\nerrorsConnect="
<> strEncode _pErrorsConnect
<> "\nerrorsCompat="
<> strEncode _pErrorsCompat
<> "\nerrorsOther="
<> strEncode _pErrorsOther
strP = do
_pRequests <- "requests=" *> strP <* A.endOfLine
_pSuccesses <- "successes=" *> strP <* A.endOfLine
_pErrorsConnect <- "errorsConnect=" *> strP <* A.endOfLine
_pErrorsCompat <- "errorsCompat=" *> strP <* A.endOfLine
_pErrorsOther <- "errorsOther=" *> strP
pure ProxyStatsData {_pRequests, _pSuccesses, _pErrorsConnect, _pErrorsCompat, _pErrorsOther}
-4
View File
@@ -10,7 +10,6 @@ import Data.Composition ((.:.))
import Data.Functor (($>))
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Util (($>>=))
data SessionVar a = SessionVar
{ sessionVar :: TMVar a,
@@ -37,6 +36,3 @@ removeSessVar' v sessKey vs =
TM.lookup sessKey vs >>= \case
Just v' | sessionVarId v == sessionVarId v' -> TM.delete sessKey vs $> True
_ -> pure False
tryReadSessVar :: Ord k => k -> TMap k (SessionVar a) -> STM (Maybe a)
tryReadSessVar sessKey vs = TM.lookup sessKey vs $>>= (tryReadTMVar . sessionVar)
+48 -92
View File
@@ -33,13 +33,9 @@ module Simplex.Messaging.Transport
VersionSMP,
VersionRangeSMP,
THandleSMP,
supportedSMPHandshakes,
supportedClientSMPRelayVRange,
supportedServerSMPRelayVRange,
proxiedSMPRelayVRange,
legacyServerSMPRelayVRange,
currentClientSMPRelayVersion,
legacyServerSMPRelayVersion,
currentServerSMPRelayVersion,
batchCmdsSMPVersion,
basicAuthSMPVersion,
@@ -76,13 +72,14 @@ module Simplex.Messaging.Transport
smpClientHandshake,
tPutBlock,
tGetBlock,
serializeTransportError,
transportErrorP,
sendHandshake,
getHandshake,
smpTHParamsSetVersion,
)
where
import Control.Applicative (optional)
import Control.Applicative (optional, (<|>))
import Control.Monad (forM)
import Control.Monad.Except
import Control.Monad.Trans.Except (throwE)
@@ -118,6 +115,11 @@ import UnliftIO.STM
-- * Transport parameters
-- min size it works with:
-- unsigned message: 16292 (paddedProxiedMsgLength = 16151, paddedForwardedMsgLength = 16239)
-- Ed448: 16406 (16384 + 22, fails with 21)
-- Ed25519: 16356
-- X25519: 16381
smpBlockSize :: Int
smpBlockSize = 16384
@@ -128,7 +130,7 @@ smpBlockSize = 16384
-- 4 - support command batching (7/17/2022)
-- 5 - basic auth for SMP servers (11/12/2022)
-- 6 - allow creating queues without subscribing (9/10/2023)
-- 7 - support authenticated encryption to verify senders' commands, imply but do NOT send session ID in signed part (4/30/2024)
-- 7 - support authenticated encryption to verify senders' commands, imply but do NOT send session ID in signed part (2/3/2024)
data SMPVersion
@@ -157,40 +159,19 @@ sendingProxySMPVersion :: VersionSMP
sendingProxySMPVersion = VersionSMP 8
currentClientSMPRelayVersion :: VersionSMP
currentClientSMPRelayVersion = VersionSMP 8
legacyServerSMPRelayVersion :: VersionSMP
legacyServerSMPRelayVersion = VersionSMP 6
currentClientSMPRelayVersion = VersionSMP 6
currentServerSMPRelayVersion :: VersionSMP
currentServerSMPRelayVersion = VersionSMP 8
-- Max SMP protocol version to be used in e2e encrypted
-- connection between client and server, as defined by SMP proxy.
-- SMP proxy sets it to lower than its current version
-- to prevent client version fingerprinting by the
-- destination relays when clients upgrade at different times.
proxiedSMPRelayVersion :: VersionSMP
proxiedSMPRelayVersion = VersionSMP 8
currentServerSMPRelayVersion = VersionSMP 6
-- minimal supported protocol version is 4
-- TODO remove code that supports sending commands without batching
supportedClientSMPRelayVRange :: VersionRangeSMP
supportedClientSMPRelayVRange = mkVersionRange batchCmdsSMPVersion currentClientSMPRelayVersion
legacyServerSMPRelayVRange :: VersionRangeSMP
legacyServerSMPRelayVRange = mkVersionRange batchCmdsSMPVersion legacyServerSMPRelayVersion
supportedServerSMPRelayVRange :: VersionRangeSMP
supportedServerSMPRelayVRange = mkVersionRange batchCmdsSMPVersion currentServerSMPRelayVersion
-- This range initially allows only version 8 - see the comment above.
proxiedSMPRelayVRange :: VersionRangeSMP
proxiedSMPRelayVRange = mkVersionRange sendingProxySMPVersion proxiedSMPRelayVersion
supportedSMPHandshakes :: [ALPN]
supportedSMPHandshakes = ["smp/1"]
simplexMQVersion :: String
simplexMQVersion = showVersion SMQ.version
@@ -222,9 +203,6 @@ class Transport c where
-- | tls-unique channel binding per RFC5929
tlsUnique :: c -> SessionId
-- | ALPN value negotiated for the session
getSessionALPN :: c -> Maybe ALPN
-- | Close connection
closeConnection :: c -> IO ()
@@ -319,7 +297,6 @@ instance Transport TLS where
getServerConnection = getTLS TServer
getClientConnection = getTLS TClient
getServerCerts = tlsServerCerts
getSessionALPN = tlsALPN
tlsUnique = tlsUniq
closeConnection tls = closeTLS $ tlsContext tls
@@ -354,8 +331,6 @@ type THandleSMP c p = THandle SMPVersion c p
data THandleParams v p = THandleParams
{ sessionId :: SessionId,
blockSize :: Int,
-- | server protocol version range
thServerVRange :: VersionRange v,
-- | agreed server protocol version
thVersion :: Version v,
-- | peer public key for command authorization and shared secrets for entity ID encryption
@@ -440,8 +415,6 @@ authEncryptCmdsP v p = if v >= authCmdsSMPVersion then optional p else pure Noth
data TransportError
= -- | error parsing transport block
TEBadBlock
| -- | incompatible client or server version
TEVersion
| -- | message does not fit in transport block
TELargeMsg
| -- | incorrect session ID
@@ -457,29 +430,31 @@ data TransportError
data HandshakeError
= -- | parsing error
PARSE
| -- | incompatible peer version
VERSION
| -- | incorrect server identity
IDENTITY
| -- | v7 authentication failed
BAD_AUTH
deriving (Eq, Read, Show, Exception)
instance Encoding TransportError where
smpP =
A.takeTill (== ' ') >>= \case
"BLOCK" -> pure TEBadBlock
"VERSION" -> pure TEVersion
"LARGE_MSG" -> pure TELargeMsg
"SESSION" -> pure TEBadSession
"NO_AUTH" -> pure TENoServerAuth
"HANDSHAKE" -> TEHandshake <$> (A.space *> parseRead1)
_ -> fail "bad TransportError"
smpEncode = \case
TEBadBlock -> "BLOCK"
TEVersion -> "VERSION"
TELargeMsg -> "LARGE_MSG"
TEBadSession -> "SESSION"
TENoServerAuth -> "NO_AUTH"
TEHandshake e -> "HANDSHAKE " <> bshow e
-- | SMP encrypted transport error parser.
transportErrorP :: Parser TransportError
transportErrorP =
"BLOCK" $> TEBadBlock
<|> "LARGE_MSG" $> TELargeMsg
<|> "SESSION" $> TEBadSession
<|> "NO_AUTH" $> TENoServerAuth
<|> "HANDSHAKE " *> (TEHandshake <$> parseRead1)
-- | Serialize SMP encrypted transport error.
serializeTransportError :: TransportError -> ByteString
serializeTransportError = \case
TEBadBlock -> "BLOCK"
TELargeMsg -> "LARGE_MSG"
TEBadSession -> "SESSION"
TENoServerAuth -> "NO_AUTH"
TEHandshake e -> "HANDSHAKE " <> bshow e
-- | Pad and send block to SMP transport.
tPutBlock :: Transport c => THandle v c p -> ByteString -> IO (Either TransportError ())
@@ -503,16 +478,14 @@ smpServerHandshake serverSignKey c (k, pk) kh smpVRange = do
let th@THandle {params = THandleParams {sessionId}} = smpTHandle c
sk = C.signX509 serverSignKey $ C.publicToX509 k
certChain = getServerCerts c
smpVersionRange = maybe legacyServerSMPRelayVRange (const smpVRange) $ getSessionALPN c
sendHandshake th $ ServerHandshake {sessionId, smpVersionRange, authPubKey = Just (certChain, sk)}
sendHandshake th $ ServerHandshake {sessionId, smpVersionRange = smpVRange, authPubKey = Just (certChain, sk)}
getHandshake th >>= \case
ClientHandshake {smpVersion = v, keyHash, authPubKey = k'}
| keyHash /= kh ->
throwE $ TEHandshake IDENTITY
| otherwise ->
case compatibleVRange' smpVersionRange v of
Just (Compatible vr) -> pure $ smpTHandleServer th v vr pk k'
Nothing -> throwE TEVersion
| v `isCompatible` smpVRange ->
pure $ smpThHandleServer th v pk k'
| otherwise -> throwE $ TEHandshake VERSION
-- | Client SMP transport handshake.
--
@@ -523,8 +496,8 @@ smpClientHandshake c ks_ keyHash@(C.KeyHash kh) smpVRange = do
ServerHandshake {sessionId = sessId, smpVersionRange, authPubKey} <- getHandshake th
if sessionId /= sessId
then throwE TEBadSession
else case smpVersionRange `compatibleVRange` smpVRange of
Just (Compatible vr) -> do
else case smpVersionRange `compatibleVersion` smpVRange of
Just (Compatible v) -> do
ck_ <- forM authPubKey $ \certKey@(X.CertificateChain cert, exact) ->
liftEitherWith (const $ TEHandshake BAD_AUTH) $ do
case cert of
@@ -533,33 +506,26 @@ smpClientHandshake c ks_ keyHash@(C.KeyHash kh) smpVRange = do
serverKey <- getServerVerifyKey c
pubKey <- C.verifyX509 serverKey exact
(,certKey) <$> (C.x509ToPublic (pubKey, []) >>= C.pubKey)
let v = maxVersion vr
sendHandshake th $ ClientHandshake {smpVersion = v, keyHash, authPubKey = fst <$> ks_}
pure $ smpTHandleClient th v vr (snd <$> ks_) ck_
Nothing -> throwE TEVersion
pure $ smpThHandleClient th v (snd <$> ks_) ck_
Nothing -> throwE $ TEHandshake VERSION
smpTHandleServer :: forall c. THandleSMP c 'TServer -> VersionSMP -> VersionRangeSMP -> C.PrivateKeyX25519 -> Maybe C.PublicKeyX25519 -> THandleSMP c 'TServer
smpTHandleServer th v vr pk k_ =
smpThHandleServer :: forall c. THandleSMP c 'TServer -> VersionSMP -> C.PrivateKeyX25519 -> Maybe C.PublicKeyX25519 -> THandleSMP c 'TServer
smpThHandleServer th v pk k_ =
let thAuth = THAuthServer {serverPrivKey = pk, sessSecret' = (`C.dh'` pk) <$> k_}
in smpTHandle_ th v vr (Just thAuth)
in smpThHandle_ th v (Just thAuth)
smpTHandleClient :: forall c. THandleSMP c 'TClient -> VersionSMP -> VersionRangeSMP -> Maybe C.PrivateKeyX25519 -> Maybe (C.PublicKeyX25519, (X.CertificateChain, X.SignedExact X.PubKey)) -> THandleSMP c 'TClient
smpTHandleClient th v vr pk_ ck_ =
smpThHandleClient :: forall c. THandleSMP c 'TClient -> VersionSMP -> Maybe C.PrivateKeyX25519 -> Maybe (C.PublicKeyX25519, (X.CertificateChain, X.SignedExact X.PubKey)) -> THandleSMP c 'TClient
smpThHandleClient th v pk_ ck_ =
let thAuth = (\(k, ck) -> THAuthClient {serverPeerPubKey = k, serverCertKey = ck, sessSecret = C.dh' k <$> pk_}) <$> ck_
in smpTHandle_ th v vr thAuth
in smpThHandle_ th v thAuth
smpTHandle_ :: forall c p. THandleSMP c p -> VersionSMP -> VersionRangeSMP -> Maybe (THandleAuth p) -> THandleSMP c p
smpTHandle_ th@THandle {params} v vr thAuth =
smpThHandle_ :: forall c p. THandleSMP c p -> VersionSMP -> Maybe (THandleAuth p) -> THandleSMP c p
smpThHandle_ th@THandle {params} v thAuth =
-- TODO drop SMP v6: make thAuth non-optional
let params' = params {thVersion = v, thServerVRange = vr, thAuth, implySessId = v >= authCmdsSMPVersion}
let params' = params {thVersion = v, thAuth, implySessId = v >= authCmdsSMPVersion}
in (th :: THandleSMP c p) {params = params'}
-- This function is only used with v >= 8, so currently it's a simple record update.
-- It may require some parameters update in the future, to be consistent with smpTHandle_.
smpTHParamsSetVersion :: VersionSMP -> THandleParams SMPVersion p -> THandleParams SMPVersion p
smpTHParamsSetVersion v params = params {thVersion = v}
{-# INLINE smpTHParamsSetVersion #-}
sendHandshake :: (Transport c, Encoding smp) => THandle v c p -> smp -> ExceptT TransportError IO ()
sendHandshake th = ExceptT . tPutBlock th . smpEncode
@@ -570,17 +536,7 @@ getHandshake th = ExceptT $ (first (\_ -> TEHandshake PARSE) . A.parseOnly smpP
smpTHandle :: Transport c => c -> THandleSMP c p
smpTHandle c = THandle {connection = c, params}
where
v = VersionSMP 0
params =
THandleParams
{ sessionId = tlsUnique c,
blockSize = smpBlockSize,
thServerVRange = versionToRange v,
thVersion = v,
thAuth = Nothing,
implySessId = False,
batch = True
}
params = THandleParams {sessionId = tlsUnique c, blockSize = smpBlockSize, thVersion = VersionSMP 0, thAuth = Nothing, implySessId = False, batch = True}
$(J.deriveJSON (sumTypeJSON id) ''HandshakeError)
+7 -16
View File
@@ -2,7 +2,6 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -11,7 +10,6 @@ module Simplex.Messaging.Transport.Client
runTLSTransportClient,
smpClientHandshake,
defaultSMPPort,
defaultTcpConnectTimeout,
defaultTransportClientConfig,
defaultSocksProxy,
TransportClientConfig (..),
@@ -19,7 +17,7 @@ module Simplex.Messaging.Transport.Client
TransportHost (..),
TransportHosts (..),
TransportHosts_ (..),
validateCertificateChain,
validateCertificateChain
)
where
@@ -52,7 +50,7 @@ import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (parseAll, parseString)
import Simplex.Messaging.Transport
import Simplex.Messaging.Transport.KeepAlive
import Simplex.Messaging.Util (bshow, catchAll, tshow, (<$?>))
import Simplex.Messaging.Util (bshow, (<$?>), catchAll, tshow)
import System.IO.Error
import Text.Read (readMaybe)
import UnliftIO.Exception (IOException)
@@ -114,7 +112,6 @@ instance IsString (NonEmpty TransportHost) where fromString = parseString strDec
data TransportClientConfig = TransportClientConfig
{ socksProxy :: Maybe SocksProxy,
tcpConnectTimeout :: Int,
tcpKeepAlive :: Maybe KeepAliveOpts,
logTLSErrors :: Bool,
clientCredentials :: Maybe (X.CertificateChain, T.PrivKey),
@@ -122,12 +119,8 @@ data TransportClientConfig = TransportClientConfig
}
deriving (Eq, Show)
-- time to resolve host, connect socket, set up TLS
defaultTcpConnectTimeout :: Int
defaultTcpConnectTimeout = 25_000_000
defaultTransportClientConfig :: TransportClientConfig
defaultTransportClientConfig = TransportClientConfig Nothing defaultTcpConnectTimeout (Just defaultKeepAliveOpts) True Nothing Nothing
defaultTransportClientConfig = TransportClientConfig Nothing (Just defaultKeepAliveOpts) True Nothing Nothing
clientTransportConfig :: TransportClientConfig -> TransportConfig
clientTransportConfig TransportClientConfig {logTLSErrors} =
@@ -143,21 +136,19 @@ runTLSTransportClient tlsParams caStore_ cfg@TransportClientConfig {socksProxy,
let hostName = B.unpack $ strEncode host
clientParams = mkTLSClientParams tlsParams caStore_ hostName port keyHash clientCredentials alpn serverCert
connectTCP = case socksProxy of
Just proxy -> connectSocksClient proxy proxyUsername (hostAddr host)
Just proxy -> connectSocksClient proxy proxyUsername $ hostAddr host
_ -> connectTCPClient hostName
c <- do
sock <- connectTCP port
mapM_ (setSocketKeepAlive sock) tcpKeepAlive `catchAll` \e -> logError ("Error setting TCP keep-alive" <> tshow e)
let tCfg = clientTransportConfig cfg
-- No TLS timeout to avoid failing connections via SOCKS
tls <- connectTLS (Just hostName) tCfg clientParams sock
chain <-
atomically (tryTakeTMVar serverCert) >>= \case
connectTLS (Just hostName) tCfg clientParams sock >>= \tls -> do
chain <- atomically (tryTakeTMVar serverCert) >>= \case
Nothing -> do
logError "onServerCertificate didn't fire or failed to get cert chain"
closeTLS tls >> error "onServerCertificate failed"
Just c -> pure c
getClientConnection tCfg chain tls
getClientConnection tCfg chain tls
client c `E.finally` closeConnection c
where
hostAddr = \case
@@ -14,7 +14,6 @@ import Control.Monad
import Data.ByteString.Char8 (ByteString)
import Data.Functor (($>))
import Data.Time (UTCTime, getCurrentTime)
import qualified Data.X509 as X
import qualified Data.X509.CertificateStore as XS
import Network.HPACK (BufferSize)
import Network.HTTP2.Client (ClientConfig (..), Request, Response)
@@ -25,11 +24,12 @@ import Numeric.Natural (Natural)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Transport (ALPN, SessionId, TLS (tlsALPN), getServerCerts, getServerVerifyKey, tlsUniq)
import Simplex.Messaging.Transport.Client (TransportClientConfig (..), TransportHost (..), defaultTcpConnectTimeout, runTLSTransportClient)
import Simplex.Messaging.Transport.Client (TransportClientConfig (..), TransportHost (..), runTLSTransportClient)
import Simplex.Messaging.Transport.HTTP2
import Simplex.Messaging.Util (eitherToMaybe)
import UnliftIO.STM
import UnliftIO.Timeout
import qualified Data.X509 as X
data HTTP2Client = HTTP2Client
{ action :: Maybe (Async HTTP2Response),
@@ -70,16 +70,8 @@ defaultHTTP2ClientConfig :: HTTP2ClientConfig
defaultHTTP2ClientConfig =
HTTP2ClientConfig
{ qSize = 64,
connTimeout = defaultTcpConnectTimeout,
transportConfig =
TransportClientConfig
{ socksProxy = Nothing,
tcpConnectTimeout = defaultTcpConnectTimeout,
tcpKeepAlive = Nothing,
logTLSErrors = True,
clientCredentials = Nothing,
alpn = Nothing
},
connTimeout = 10000000,
transportConfig = TransportClientConfig Nothing Nothing True Nothing Nothing,
bufferSize = defaultHTTP2BufferSize,
bodyHeadSize = 16384,
suportedTLSParams = http2TLSParams
@@ -23,7 +23,7 @@ hReceiveFile getBody h size = get $ fromIntegral size
if
| chSize > sz -> pure (chSize - sz)
| chSize > 0 -> B.hPut h ch >> get (sz - chSize)
| otherwise -> pure (-sz)
| otherwise -> pure (-fromIntegral sz)
hSendFile :: Handle -> (Builder -> IO ()) -> Word32 -> IO ()
hSendFile h send = go
@@ -51,7 +51,7 @@ data HTTP2Server = HTTP2Server
-- This server is for testing only, it processes all requests in a single queue.
getHTTP2Server :: HTTP2ServerConfig -> IO HTTP2Server
getHTTP2Server HTTP2ServerConfig {qSize, http2Port, bufferSize, bodyHeadSize, serverSupported, caCertificateFile, certificateFile, privateKeyFile, transportConfig} = do
tlsServerParams <- loadSupportedTLSServerParams serverSupported caCertificateFile certificateFile privateKeyFile (alpn transportConfig)
tlsServerParams <- loadSupportedTLSServerParams serverSupported caCertificateFile certificateFile privateKeyFile
started <- newEmptyTMVarIO
reqQ <- newTBQueueIO qSize
action <- async $
+7 -9
View File
@@ -28,10 +28,10 @@ import Control.Logger.Simple
import Control.Monad
import qualified Crypto.Store.X509 as SX
import Data.Default (def)
import Data.List (find)
import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as IM
import Data.List (find)
import Data.Maybe (fromJust, fromMaybe)
import Data.Maybe (fromJust)
import qualified Data.X509 as X
import Data.X509.Validation (Fingerprint (..))
import qualified Data.X509.Validation as XV
@@ -118,7 +118,7 @@ runTCPServerSocket (accepted, gracefullyClosed, clients) started getSocket serve
let closeConn _ = do
atomically $ modifyTVar' clients $ IM.delete cId
gracefulClose conn 5000 `catchAll_` pure () -- catchAll_ is needed here in case the connection was closed earlier
atomically $ modifyTVar' gracefullyClosed (+ 1)
atomically $ modifyTVar' gracefullyClosed (+1)
tId <- mkWeakThreadId =<< server conn `forkFinally` closeConn
atomically $ modifyTVar' clients $ IM.insert cId tId
@@ -152,13 +152,12 @@ startTCPServer started port = withSocketsDo $ resolve >>= open >>= setStarted
pure sock
setStarted sock = atomically (tryPutTMVar started True) >> pure sock
loadTLSServerParams :: FilePath -> FilePath -> FilePath -> Maybe [ALPN] -> IO T.ServerParams
loadTLSServerParams :: FilePath -> FilePath -> FilePath -> IO T.ServerParams
loadTLSServerParams = loadSupportedTLSServerParams supportedParameters
loadSupportedTLSServerParams :: T.Supported -> FilePath -> FilePath -> FilePath -> Maybe [ALPN] -> IO T.ServerParams
loadSupportedTLSServerParams serverSupported caCertificateFile certificateFile privateKeyFile alpn_ = do
tlsServerParams <- fromCredential <$> loadServerCredential
pure tlsServerParams {T.serverHooks = maybe def alpnHooks alpn_}
loadSupportedTLSServerParams :: T.Supported -> FilePath -> FilePath -> FilePath -> IO T.ServerParams
loadSupportedTLSServerParams serverSupported caCertificateFile certificateFile privateKeyFile =
fromCredential <$> loadServerCredential
where
loadServerCredential :: IO T.Credential
loadServerCredential =
@@ -173,7 +172,6 @@ loadSupportedTLSServerParams serverSupported caCertificateFile certificateFile p
T.serverHooks = def,
T.serverSupported = serverSupported
}
alpnHooks supported = def {T.onALPNClientSuggest = Just $ pure . fromMaybe "" . find (`elem` supported)}
loadFingerprint :: FilePath -> IO Fingerprint
loadFingerprint certificateFile = do
@@ -14,8 +14,7 @@ import Network.WebSockets
import Network.WebSockets.Stream (Stream)
import qualified Network.WebSockets.Stream as S
import Simplex.Messaging.Transport
( ALPN,
TProxy,
( TProxy,
Transport (..),
TransportConfig (..),
TransportError (..),
@@ -29,7 +28,6 @@ import Simplex.Messaging.Transport.Buffer (trimCR)
data WS = WS
{ wsPeer :: TransportPeer,
tlsUniq :: ByteString,
wsALPN :: Maybe ALPN,
wsStream :: Stream,
wsConnection :: Connection,
wsTransportConfig :: TransportConfig,
@@ -63,9 +61,6 @@ instance Transport WS where
getServerCerts :: WS -> X.CertificateChain
getServerCerts = wsServerCerts
getSessionALPN :: WS -> Maybe ALPN
getSessionALPN = wsALPN
tlsUnique :: WS -> ByteString
tlsUnique = tlsUniq
@@ -95,8 +90,7 @@ getWS wsPeer cfg wsServerCerts cxt = withTlsUnique wsPeer cxt connectWS
connectWS tlsUniq = do
s <- makeTLSContextStream cxt
wsConnection <- connectPeer wsPeer s
wsALPN <- T.getNegotiatedProtocol cxt
pure $ WS {wsPeer, tlsUniq, wsALPN, wsStream = s, wsConnection, wsTransportConfig = cfg, wsServerCerts}
pure $ WS {wsPeer, tlsUniq, wsStream = s, wsConnection, wsTransportConfig = cfg, wsServerCerts}
connectPeer :: TransportPeer -> Stream -> IO Connection
connectPeer TServer = acceptClientRequest
connectPeer TClient = sendClientRequest
+11 -13
View File
@@ -97,15 +97,15 @@ catchAll_ :: IO a -> IO a -> IO a
catchAll_ a = catchAll a . const
{-# INLINE catchAll_ #-}
tryAllErrors :: MonadUnliftIO m => (E.SomeException -> e) -> ExceptT e m a -> ExceptT e m (Either e a)
tryAllErrors err action = ExceptT $ Right <$> runExceptT action `UE.catch` (pure . Left . err)
tryAllErrors :: (MonadUnliftIO m, MonadError e m) => (E.SomeException -> e) -> m a -> m (Either e a)
tryAllErrors err action = tryError action `UE.catch` (pure . Left . err)
{-# INLINE tryAllErrors #-}
tryAllErrors' :: MonadUnliftIO m => (E.SomeException -> e) -> ExceptT e m a -> m (Either e a)
tryAllErrors' err action = runExceptT action `UE.catch` (pure . Left . err)
{-# INLINE tryAllErrors' #-}
catchAllErrors :: MonadUnliftIO m => (E.SomeException -> e) -> ExceptT e m a -> (e -> ExceptT e m a) -> ExceptT e m a
catchAllErrors :: (MonadUnliftIO m, MonadError e m) => (E.SomeException -> e) -> m a -> (e -> m a) -> m a
catchAllErrors err action handler = tryAllErrors err action >>= either handler pure
{-# INLINE catchAllErrors #-}
@@ -113,11 +113,11 @@ catchAllErrors' :: MonadUnliftIO m => (E.SomeException -> e) -> ExceptT e m a ->
catchAllErrors' err action handler = tryAllErrors' err action >>= either handler pure
{-# INLINE catchAllErrors' #-}
catchThrow :: MonadUnliftIO m => ExceptT e m a -> (E.SomeException -> e) -> ExceptT e m a
catchThrow :: (MonadUnliftIO m, MonadError e m) => m a -> (E.SomeException -> e) -> m a
catchThrow action err = catchAllErrors err action throwError
{-# INLINE catchThrow #-}
allFinally :: MonadUnliftIO m => (E.SomeException -> e) -> ExceptT e m a -> ExceptT e m b -> ExceptT e m a
allFinally :: (MonadUnliftIO m, MonadError e m) => (E.SomeException -> e) -> m a -> m b -> m a
allFinally err action final = tryAllErrors err action >>= \r -> final >> either throwError pure r
{-# INLINE allFinally #-}
@@ -152,14 +152,12 @@ timeoutThrow :: MonadUnliftIO m => e -> Int -> ExceptT e m a -> ExceptT e m a
timeoutThrow e ms action = ExceptT (sequence <$> (ms `timeout` runExceptT action)) >>= maybe (throwError e) pure
threadDelay' :: Int64 -> IO ()
threadDelay' = loop
where
loop time
| time <= 0 = pure ()
| otherwise = do
let maxWait = min time $ fromIntegral (maxBound :: Int)
threadDelay $ fromIntegral maxWait
loop $ time - maxWait
threadDelay' time
| time <= 0 = pure ()
threadDelay' time = do
let maxWait = min time $ fromIntegral (maxBound :: Int)
threadDelay $ fromIntegral maxWait
when (maxWait /= time) $ threadDelay' (time - maxWait)
diffToMicroseconds :: NominalDiffTime -> Int64
diffToMicroseconds diff = fromIntegral ((truncate $ diff * 1000000) :: Integer)
-23
View File
@@ -23,8 +23,6 @@ module Simplex.Messaging.Version
isCompatibleRange,
proveCompatible,
compatibleVersion,
compatibleVRange,
compatibleVRange',
)
where
@@ -100,7 +98,6 @@ class VersionScope v => VersionI v a | a -> v where
class VersionScope v => VersionRangeI v a | a -> v where
type VersionT v a
versionRange :: a -> VersionRange v
toVersionRange :: a -> VersionRange v -> a
toVersionT :: a -> Version v -> VersionT v a
instance VersionScope v => VersionI v (Version v) where
@@ -111,7 +108,6 @@ instance VersionScope v => VersionI v (Version v) where
instance VersionScope v => VersionRangeI v (VersionRange v) where
type VersionT v (VersionRange v) = Version v
versionRange = id
toVersionRange _ vr = vr
toVersionT _ v = v
newtype Compatible a = Compatible_ a
@@ -139,24 +135,5 @@ compatibleVersion x vr =
max1 = maxVersion $ versionRange x
max2 = maxVersion vr
-- | intersection of version ranges
compatibleVRange :: VersionRangeI v a => a -> VersionRange v -> Maybe (Compatible a)
compatibleVRange x vr =
compatibleVRange_ x (max min1 min2) (min max1 max2)
where
VRange min1 max1 = versionRange x
VRange min2 max2 = vr
-- | version range capped by compatible version
compatibleVRange' :: VersionRangeI v a => a -> Version v -> Maybe (Compatible a)
compatibleVRange' x v
| v <= max1 = compatibleVRange_ x min1 v
| otherwise = Nothing
where
VRange min1 max1 = versionRange x
compatibleVRange_ :: VersionRangeI v a => a -> Version v -> Version v -> Maybe (Compatible a)
compatibleVRange_ x v1 v2 = Compatible_ . toVersionRange x <$> safeVersionRange v1 v2
mkCompatibleIf :: a -> Bool -> Maybe (Compatible a)
x `mkCompatibleIf` cond = if cond then Just $ Compatible_ x else Nothing
+56 -50
View File
@@ -7,12 +7,13 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
module AgentTests (agentTests) where
import AgentTests.ConnectionRequestTests
import AgentTests.DoubleRatchetTests (doubleRatchetTests)
import AgentTests.FunctionalAPITests (functionalAPITests, inAnyOrder, pattern Msg, pattern Msg', pattern SENT)
import AgentTests.FunctionalAPITests (functionalAPITests, inAnyOrder, pattern Msg, pattern Msg')
import AgentTests.MigrationTests (migrationTests)
import AgentTests.NotificationTests (notificationTests)
import AgentTests.SQLiteTests (storeTests)
@@ -26,9 +27,9 @@ import GHC.Stack (withFrozenCallStack)
import Network.HTTP.Types (urlEncode)
import SMPAgentClient
import SMPClient (testKeyHash, testPort, testPort2, testStoreLogFile, withSmpServer, withSmpServerStoreLogOn)
import Simplex.Messaging.Agent.Protocol hiding (CONF, INFO, MID, REQ, SENT)
import Simplex.Messaging.Agent.Protocol hiding (MID, CONF, INFO, REQ)
import qualified Simplex.Messaging.Agent.Protocol as A
import Simplex.Messaging.Crypto.Ratchet (InitialKeys (..), PQEncryption (..), PQSupport (..), pattern IKPQOff, pattern IKPQOn, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn)
import Simplex.Messaging.Crypto.Ratchet (InitialKeys (..), PQEncryption (..), PQSupport (..), pattern IKPQOn, pattern IKPQOff, pattern PQEncOn, pattern PQSupportOn, pattern PQSupportOff)
import qualified Simplex.Messaging.Crypto.Ratchet as CR
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol (ErrorType (..))
@@ -94,24 +95,23 @@ type AEntityTransmission p e = (ACorrId, ConnId, ACommand p e)
type AEntityTransmissionOrError p e = (ACorrId, ConnId, Either AgentErrorType (ACommand p e))
tGetAgent :: Transport c => c -> IO (AEntityTransmissionOrError 'Agent 'AEConn)
tGetAgent = tGetAgent' True
tGetAgent = tGetAgent'
tGetAgent' :: forall c e. (Transport c, AEntityI e) => Bool -> c -> IO (AEntityTransmissionOrError 'Agent e)
tGetAgent' skipErr h = do
(corrId, connId, cmdOrErr) <- pGetAgent skipErr h
tGetAgent' :: forall c e. (Transport c, AEntityI e) => c -> IO (AEntityTransmissionOrError 'Agent e)
tGetAgent' h = do
(corrId, connId, cmdOrErr) <- pGetAgent h
case cmdOrErr of
Right (APC e cmd) -> case testEquality e (sAEntity @e) of
Just Refl -> pure (corrId, connId, Right cmd)
_ -> error $ "unexpected command " <> show cmd
Left err -> pure (corrId, connId, Left err)
pGetAgent :: forall c. Transport c => Bool -> c -> IO (ATransmissionOrError 'Agent)
pGetAgent skipErr h = do
pGetAgent :: forall c. Transport c => c -> IO (ATransmissionOrError 'Agent)
pGetAgent h = do
(corrId, connId, cmdOrErr) <- tGet SAgent h
case cmdOrErr of
Right (APC _ CONNECT {}) -> pGetAgent skipErr h
Right (APC _ DISCONNECT {}) -> pGetAgent skipErr h
Right (APC _ (ERR (BROKER _ NETWORK))) | skipErr -> pGetAgent skipErr h
Right (APC _ CONNECT {}) -> pGetAgent h
Right (APC _ DISCONNECT {}) -> pGetAgent h
cmd -> pure (corrId, connId, cmd)
-- | receive message to handle `h`
@@ -119,18 +119,15 @@ pGetAgent skipErr h = do
(<#:) = tGetAgent
(<#:?) :: Transport c => c -> IO (ATransmissionOrError 'Agent)
(<#:?) = pGetAgent True
(<#:?) = pGetAgent
(<#:.) :: Transport c => c -> IO (AEntityTransmissionOrError 'Agent 'AENone)
(<#:.) = tGetAgent' True
(<#:.) = tGetAgent'
-- | send transmission `t` to handle `h` and get response
(#:) :: Transport c => c -> (ByteString, ByteString, ByteString) -> IO (AEntityTransmissionOrError 'Agent 'AEConn)
h #: t = tPutRaw h t >> (<#:) h
(#:!) :: Transport c => c -> (ByteString, ByteString, ByteString) -> IO (AEntityTransmissionOrError 'Agent 'AEConn)
h #:! t = tPutRaw h t >> tGetAgent' False h
-- | action and expected response
-- `h #:t #> r` is the test that sends `t` to `h` and validates that the response is `r`
(#>) :: IO (AEntityTransmissionOrError 'Agent 'AEConn) -> AEntityTransmission 'Agent 'AEConn -> Expectation
@@ -217,13 +214,14 @@ testDuplexConnection _ alice bob = testDuplexConnection' (alice, IKPQOn) (bob, P
testDuplexConnection' :: (HasCallStack, Transport c) => (c, InitialKeys) -> (c, PQSupport) -> IO ()
testDuplexConnection' (alice, aPQ) (bob, bPQ) = do
let pq = pqConnectionMode aPQ bPQ
pqSup = CR.pqEncToSupport pq
("1", "bob", Right (INV cReq)) <- alice #: ("1", "bob", "NEW T INV" <> pqConnModeStr aPQ <> " subscribe")
let cReq' = strEncode cReq
bob #: ("11", "alice", "JOIN T " <> cReq' <> enableKEMStr bPQ <> " subscribe 14\nbob's connInfo") #> ("11", "alice", OK)
("", "bob", Right (A.CONF confId pqSup' _ "bob's connInfo")) <- (alice <#:)
pqSup' `shouldBe` CR.connPQEncryption aPQ
pqSup' `shouldBe` pqSup
alice #: ("2", "bob", "LET " <> confId <> " 16\nalice's connInfo") #> ("2", "bob", OK)
bob <# ("", "alice", A.INFO bPQ "alice's connInfo")
bob <# ("", "alice", A.INFO pqSup "alice's connInfo")
bob <# ("", "alice", CON pq)
alice <# ("", "bob", CON pq)
-- message IDs 1 to 3 get assigned to control messages, so first MSG is assigned ID 4
@@ -245,7 +243,7 @@ testDuplexConnection' (alice, aPQ) (bob, bPQ) = do
alice #: ("4a", "bob", "ACK 7") #> ("4a", "bob", OK)
alice #: ("5", "bob", "OFF") #> ("5", "bob", OK)
bob #: ("17", "alice", "SEND F 9\nmessage 3") #> ("17", "alice", A.MID 8 pq)
bob <#= \case ("", "alice", MERR 8 (SMP _ AUTH)) -> True; _ -> False
bob <# ("", "alice", MERR 8 (SMP AUTH))
alice #: ("6", "bob", "DEL") #> ("6", "bob", OK)
alice #:# "nothing else should be delivered to alice"
@@ -255,14 +253,15 @@ testDuplexConnRandomIds _ alice bob = testDuplexConnRandomIds' (alice, IKPQOn) (
testDuplexConnRandomIds' :: (HasCallStack, Transport c) => (c, InitialKeys) -> (c, PQSupport) -> IO ()
testDuplexConnRandomIds' (alice, aPQ) (bob, bPQ) = do
let pq = pqConnectionMode aPQ bPQ
pqSup = CR.pqEncToSupport pq
("1", bobConn, Right (INV cReq)) <- alice #: ("1", "", "NEW T INV" <> pqConnModeStr aPQ <> " subscribe")
let cReq' = strEncode cReq
("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN T " <> cReq' <> enableKEMStr bPQ <> " subscribe 14\nbob's connInfo")
("", bobConn', Right (A.CONF confId pqSup' _ "bob's connInfo")) <- (alice <#:)
pqSup' `shouldBe` CR.connPQEncryption aPQ
pqSup' `shouldBe` pqSup
bobConn' `shouldBe` bobConn
alice #: ("2", bobConn, "LET " <> confId <> " 16\nalice's connInfo") =#> \case ("2", c, OK) -> c == bobConn; _ -> False
bob <# ("", aliceConn, A.INFO bPQ "alice's connInfo")
bob <# ("", aliceConn, A.INFO pqSup "alice's connInfo")
bob <# ("", aliceConn, CON pq)
alice <# ("", bobConn, CON pq)
alice #: ("2", bobConn, "SEND F :hello") #> ("2", bobConn, A.MID 4 pq)
@@ -283,7 +282,7 @@ testDuplexConnRandomIds' (alice, aPQ) (bob, bPQ) = do
alice #: ("4a", bobConn, "ACK 7") #> ("4a", bobConn, OK)
alice #: ("5", bobConn, "OFF") #> ("5", bobConn, OK)
bob #: ("17", aliceConn, "SEND F 9\nmessage 3") #> ("17", aliceConn, A.MID 8 pq)
bob <#= \case ("", cId, MERR 8 (SMP _ AUTH)) -> cId == aliceConn; _ -> False
bob <# ("", aliceConn, MERR 8 (SMP AUTH))
alice #: ("6", bobConn, "DEL") #> ("6", bobConn, OK)
alice #:# "nothing else should be delivered to alice"
@@ -292,15 +291,17 @@ testContactConnection (alice, aPQ) (bob, bPQ) (tom, tPQ) = do
("1", "alice_contact", Right (INV cReq)) <- alice #: ("1", "alice_contact", "NEW T CON" <> pqConnModeStr aPQ <> " subscribe")
let cReq' = strEncode cReq
abPQ = pqConnectionMode aPQ bPQ
abPQSup = CR.pqEncToSupport abPQ
aPQMode = CR.connPQEncryption aPQ
bob #: ("11", "alice", "JOIN T " <> cReq' <> enableKEMStr bPQ <> " subscribe 14\nbob's connInfo") #> ("11", "alice", OK)
("", "alice_contact", Right (A.REQ aInvId PQSupportOn _ "bob's connInfo")) <- (alice <#:)
("", "alice_contact", Right (A.REQ aInvId pqSup' _ "bob's connInfo")) <- (alice <#:)
pqSup' `shouldBe` bPQ
alice #: ("2", "bob", "ACPT " <> aInvId <> enableKEMStr aPQMode <> " 16\nalice's connInfo") #> ("2", "bob", OK)
("", "alice", Right (A.CONF bConfId pqSup'' _ "alice's connInfo")) <- (bob <#:)
pqSup'' `shouldBe` bPQ
pqSup'' `shouldBe` abPQSup
bob #: ("12", "alice", "LET " <> bConfId <> " 16\nbob's connInfo 2") #> ("12", "alice", OK)
alice <# ("", "bob", A.INFO (CR.connPQEncryption aPQ) "bob's connInfo 2")
alice <# ("", "bob", A.INFO abPQSup "bob's connInfo 2")
alice <# ("", "bob", CON abPQ)
bob <# ("", "alice", CON abPQ)
alice #: ("3", "bob", "SEND F :hi") #> ("3", "bob", A.MID 4 abPQ)
@@ -309,13 +310,15 @@ testContactConnection (alice, aPQ) (bob, bPQ) (tom, tPQ) = do
bob #: ("13", "alice", "ACK 4") #> ("13", "alice", OK)
let atPQ = pqConnectionMode aPQ tPQ
atPQSup = CR.pqEncToSupport atPQ
tom #: ("21", "alice", "JOIN T " <> cReq' <> enableKEMStr tPQ <> " subscribe 14\ntom's connInfo") #> ("21", "alice", OK)
("", "alice_contact", Right (A.REQ aInvId' PQSupportOn _ "tom's connInfo")) <- (alice <#:)
("", "alice_contact", Right (A.REQ aInvId' pqSup3 _ "tom's connInfo")) <- (alice <#:)
pqSup3 `shouldBe` tPQ
alice #: ("4", "tom", "ACPT " <> aInvId' <> enableKEMStr aPQMode <> " 16\nalice's connInfo") #> ("4", "tom", OK)
("", "alice", Right (A.CONF tConfId pqSup4 _ "alice's connInfo")) <- (tom <#:)
pqSup4 `shouldBe` tPQ
pqSup4 `shouldBe` atPQSup
tom #: ("22", "alice", "LET " <> tConfId <> " 16\ntom's connInfo 2") #> ("22", "alice", OK)
alice <# ("", "tom", A.INFO (CR.connPQEncryption aPQ) "tom's connInfo 2")
alice <# ("", "tom", A.INFO atPQSup "tom's connInfo 2")
alice <# ("", "tom", CON atPQ)
tom <# ("", "alice", CON atPQ)
alice #: ("5", "tom", "SEND F :hi there") #> ("5", "tom", A.MID 4 atPQ)
@@ -326,20 +329,22 @@ testContactConnection (alice, aPQ) (bob, bPQ) (tom, tPQ) = do
testContactConnRandomIds :: Transport c => (c, InitialKeys) -> (c, PQSupport) -> IO ()
testContactConnRandomIds (alice, aPQ) (bob, bPQ) = do
let pq = pqConnectionMode aPQ bPQ
pqSup = CR.pqEncToSupport pq
("1", aliceContact, Right (INV cReq)) <- alice #: ("1", "", "NEW T CON" <> pqConnModeStr aPQ <> " subscribe")
let cReq' = strEncode cReq
("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN T " <> cReq' <> enableKEMStr bPQ <> " subscribe 14\nbob's connInfo")
("", aliceContact', Right (A.REQ aInvId PQSupportOn _ "bob's connInfo")) <- (alice <#:)
("", aliceContact', Right (A.REQ aInvId pqSup' _ "bob's connInfo")) <- (alice <#:)
pqSup' `shouldBe` bPQ
aliceContact' `shouldBe` aliceContact
("2", bobConn, Right OK) <- alice #: ("2", "", "ACPT " <> aInvId <> enableKEMStr (CR.connPQEncryption aPQ) <> " 16\nalice's connInfo")
("", aliceConn', Right (A.CONF bConfId pqSup'' _ "alice's connInfo")) <- (bob <#:)
pqSup'' `shouldBe` bPQ
pqSup'' `shouldBe` pqSup
aliceConn' `shouldBe` aliceConn
bob #: ("12", aliceConn, "LET " <> bConfId <> " 16\nbob's connInfo 2") #> ("12", aliceConn, OK)
alice <# ("", bobConn, A.INFO (CR.connPQEncryption aPQ) "bob's connInfo 2")
alice <# ("", bobConn, A.INFO pqSup "bob's connInfo 2")
alice <# ("", bobConn, CON pq)
bob <# ("", aliceConn, CON pq)
@@ -353,11 +358,11 @@ testRejectContactRequest _ alice bob = do
("1", "a_contact", Right (INV cReq)) <- alice #: ("1", "a_contact", "NEW T CON subscribe")
let cReq' = strEncode cReq
bob #: ("11", "alice", "JOIN T " <> cReq' <> " subscribe 10\nbob's info") #> ("11", "alice", OK)
("", "a_contact", Right (A.REQ aInvId PQSupportOn _ "bob's info")) <- (alice <#:)
("", "a_contact", Right (A.REQ aInvId PQSupportOff _ "bob's info")) <- (alice <#:)
-- RJCT must use correct contact connection
alice #: ("2a", "bob", "RJCT " <> aInvId) #> ("2a", "bob", ERR $ CONN NOT_FOUND)
alice #: ("2b", "a_contact", "RJCT " <> aInvId) #> ("2b", "a_contact", OK)
alice #: ("3", "bob", "ACPT " <> aInvId <> " 12\nalice's info") =#> \case ("3", "bob", ERR (A.CMD PROHIBITED _)) -> True; _ -> False
alice #: ("3", "bob", "ACPT " <> aInvId <> " 12\nalice's info") #> ("3", "bob", ERR $ A.CMD PROHIBITED)
bob #:# "nothing should be delivered to bob"
testSubscription :: Transport c => TProxy c -> c -> c -> c -> IO ()
@@ -386,7 +391,7 @@ testSubscrNotification t (server, _) client = do
killThread server
client <#. ("", "", DOWN testSMPServer ["conn1"])
withSmpServer (ATransport t) $
client <#= \case ("", "conn1", ERR (SMP _ AUTH)) -> True; _ -> False -- this new server does not have the queue
client <# ("", "conn1", ERR (SMP AUTH)) -- this new server does not have the queue
testMsgDeliveryServerRestart :: forall c. Transport c => (c, InitialKeys) -> (c, PQSupport) -> IO ()
testMsgDeliveryServerRestart (alice, aPQ) (bob, bPQ) = do
@@ -429,11 +434,11 @@ testServerConnectionAfterError t _ = do
withAgent1 $ \bob -> do
withAgent2 $ \alice -> do
bob #:! ("1", "alice", "SUB") =#> \case ("1", "alice", ERR (BROKER _ e)) -> e == NETWORK || e == TIMEOUT; _ -> False
alice #:! ("1", "bob", "SUB") =#> \case ("1", "bob", ERR (BROKER _ e)) -> e == NETWORK || e == TIMEOUT; _ -> False
bob #: ("1", "alice", "SUB") =#> \("1", "alice", ERR (BROKER _ e)) -> e == NETWORK || e == TIMEOUT
alice #: ("1", "bob", "SUB") =#> \("1", "bob", ERR (BROKER _ e)) -> e == NETWORK || e == TIMEOUT
withServer $ do
alice <#=? \case ("", "bob", APC SAEConn (SENT 4)) -> True; ("", "", APC _ (UP s ["bob"])) -> s == server; _ -> False
alice <#=? \case ("", "bob", APC SAEConn (SENT 4)) -> True; ("", "", APC _ (UP s ["bob"])) -> s == server; _ -> False
alice <#=? \case ("", "bob", APC _ (SENT 4)) -> True; ("", "", APC _ (UP s ["bob"])) -> s == server; _ -> False
alice <#=? \case ("", "bob", APC _ (SENT 4)) -> True; ("", "", APC _ (UP s ["bob"])) -> s == server; _ -> False
bob <#=? \case ("", "alice", APC _ (Msg "hello")) -> True; ("", "", APC _ (UP s ["alice"])) -> s == server; _ -> False
bob <#=? \case ("", "alice", APC _ (Msg "hello")) -> True; ("", "", APC _ (UP s ["alice"])) -> s == server; _ -> False
bob #: ("2", "alice", "ACK 4") #> ("2", "alice", OK)
@@ -550,10 +555,10 @@ testResumeDeliveryQuotaExceeded _ alice bob = do
bob <#= \case ("", "alice", Msg "message 4") -> True; _ -> False
bob #: ("4", "alice", "ACK 7") #> ("4", "alice", OK)
inAnyOrder
(tGetAgent alice)
[ \case ("", c, Right (SENT 8)) -> c == "bob"; _ -> False,
\case ("", c, Right QCONT) -> c == "bob"; _ -> False
]
(tGetAgent alice)
[ \case ("", c, Right (SENT 8)) -> c == "bob"; _ -> False,
\case ("", c, Right QCONT) -> c == "bob"; _ -> False
]
bob <#= \case ("", "alice", Msg "over quota") -> True; _ -> False
-- message 8 is skipped because of alice agent sending "QCONT" message
bob #: ("5", "alice", "ACK 9") #> ("5", "alice", OK)
@@ -566,11 +571,12 @@ connect' (h1, name1, pqMode1) (h2, name2, pqMode2) = do
("c1", _, Right (INV cReq)) <- h1 #: ("c1", name2, "NEW T INV" <> pqConnModeStr pqMode1 <> " subscribe")
let cReq' = strEncode cReq
pq = pqConnectionMode pqMode1 pqMode2
pqSup = CR.pqEncToSupport pq
h2 #: ("c2", name1, "JOIN T " <> cReq' <> enableKEMStr pqMode2 <> " subscribe 5\ninfo2") #> ("c2", name1, OK)
("", _, Right (A.CONF connId pqSup' _ "info2")) <- (h1 <#:)
pqSup' `shouldBe` CR.connPQEncryption pqMode1
pqSup' `shouldBe` pqSup
h1 #: ("c3", name2, "LET " <> connId <> " 5\ninfo1") #> ("c3", name2, OK)
h2 <# ("", name1, A.INFO pqMode2 "info1")
h2 <# ("", name1, A.INFO pqSup "info1")
h2 <# ("", name1, CON pq)
h1 <# ("", name2, CON pq)
@@ -583,7 +589,7 @@ enableKEMStr _ = ""
pqConnModeStr :: InitialKeys -> ByteString
pqConnModeStr (IKNoPQ PQSupportOff) = ""
pqConnModeStr pq = " " <> strEncode pq
pqConnModeStr pq = " " <> strEncode pq
sendMessage :: Transport c => (c, ConnId) -> (c, ConnId) -> ByteString -> IO ()
sendMessage (h1, name1) (h2, name2) msg = do
@@ -612,12 +618,12 @@ sampleDhKey = "MCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o="
syntaxTests :: forall c. Transport c => TProxy c -> Spec
syntaxTests t = do
it "unknown command" $ ("1", "5678", "HELLO") >#> ("1", "5678", "ERR CMD SYNTAX parseCommand")
it "unknown command" $ ("1", "5678", "HELLO") >#> ("1", "5678", "ERR CMD SYNTAX")
describe "NEW" $ do
describe "valid" $ do
it "with correct parameter" $ ("211", "", "NEW T INV subscribe") >#>= \case ("211", _, "INV" : _) -> True; _ -> False
describe "invalid" $ do
it "with incorrect parameter" $ ("222", "", "NEW T hi subscribe") >#> ("222", "", "ERR CMD SYNTAX parseCommand")
it "with incorrect parameter" $ ("222", "", "NEW T hi subscribe") >#> ("222", "", "ERR CMD SYNTAX")
describe "JOIN" $ do
describe "valid" $ do
@@ -633,9 +639,9 @@ syntaxTests t = do
<> " subscribe "
<> "14\nbob's connInfo"
)
>#> ("311", "a", "ERR SMP smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5001 AUTH")
>#> ("311", "a", "ERR SMP AUTH")
describe "invalid" $ do
it "no parameters" $ ("321", "", "JOIN") >#> ("321", "", "ERR CMD SYNTAX parseCommand")
it "no parameters" $ ("321", "", "JOIN") >#> ("321", "", "ERR CMD SYNTAX")
where
-- simple test for one command with the expected response
(>#>) :: ARawTransmission -> ARawTransmission -> Expectation
+2 -2
View File
@@ -68,7 +68,7 @@ testE2ERatchetParams :: RcvE2ERatchetParamsUri 'C.X448
testE2ERatchetParams = E2ERatchetParamsUri (mkVersionRange (VersionE2E 1) (VersionE2E 1)) testDhPubKey testDhPubKey Nothing
testE2ERatchetParams12 :: RcvE2ERatchetParamsUri 'C.X448
testE2ERatchetParams12 = E2ERatchetParamsUri supportedE2EEncryptVRange testDhPubKey testDhPubKey Nothing
testE2ERatchetParams12 = E2ERatchetParamsUri (supportedE2EEncryptVRange PQSupportOn) testDhPubKey testDhPubKey Nothing
connectionRequest :: AConnectionRequestUri
connectionRequest =
@@ -82,7 +82,7 @@ connectionRequestCurrentRange :: AConnectionRequestUri
connectionRequestCurrentRange =
ACR SCMInvitation $
CRInvitationUri
connReqData {crAgentVRange = supportedSMPAgentVRange, crSmpQueues = [queueV1, queueV1]}
connReqData {crAgentVRange = supportedSMPAgentVRange PQSupportOn, crSmpQueues = [queueV1, queueV1]}
testE2ERatchetParams12
connectionRequestClientDataEmpty :: AConnectionRequestUri
+10 -10
View File
@@ -93,9 +93,9 @@ fullMsgLen :: Ratchet a -> Int
fullMsgLen Ratchet {rcSupportKEM, rcVersion} = headerLenLength + fullHeaderLen v rcSupportKEM + C.authTagSize + paddedMsgLen
where
v = current rcVersion
headerLenLength
| v >= pqRatchetE2EEncryptVersion = 3 -- two bytes are added because of two Large used in new encoding
| otherwise = 1
headerLenLength = case rcSupportKEM of
PQSupportOn | v >= pqRatchetE2EEncryptVersion -> 3 -- two bytes are added because of two Large used in new encoding
_ -> 1
testMessageHeader :: forall a. AlgorithmI a => VersionE2E -> C.SAlgorithm a -> Expectation
testMessageHeader v _ = do
@@ -520,7 +520,7 @@ initRatchets = do
Right paramsBob <- pure $ pqX3dhSnd pkBob1 pkBob2 Nothing e2eAlice
Right paramsAlice <- runExceptT $ pqX3dhRcv pkAlice1 pkAlice2 Nothing e2eBob
(_, pkBob3) <- atomically $ C.generateKeyPair g
let vs = testRatchetVersions
let vs = testRatchetVersions PQSupportOff
bob = initSndRatchet vs (C.publicKey pkAlice2) pkBob3 paramsBob
alice = initRcvRatchet vs pkAlice2 paramsAlice PQSupportOff
pure (alice, bob, encrypt' noSndKEM, decrypt' noRcvKEM, (\#>))
@@ -537,7 +537,7 @@ initRatchetsKEMProposed = do
Right paramsBob <- pure $ pqX3dhSnd pkBob1 pkBob2 pKemParams_ e2eAlice
Right paramsAlice <- runExceptT $ pqX3dhRcv pkAlice1 pkAlice2 Nothing e2eBob
(_, pkBob3) <- atomically $ C.generateKeyPair g
let vs = testRatchetVersions
let vs = testRatchetVersions PQSupportOn
bob = initSndRatchet vs (C.publicKey pkAlice2) pkBob3 paramsBob
alice = initRcvRatchet vs pkAlice2 paramsAlice PQSupportOn
pure (alice, bob, encrypt' hasSndKEM, decrypt' hasRcvKEM, (!#>))
@@ -555,7 +555,7 @@ initRatchetsKEMAccepted = do
Right paramsBob <- pure $ pqX3dhSnd pkBob1 pkBob2 pKemParams_ e2eAlice
Right paramsAlice <- runExceptT $ pqX3dhRcv pkAlice1 pkAlice2 pKem_ e2eBob
(_, pkBob3) <- atomically $ C.generateKeyPair g
let vs = testRatchetVersions
let vs = testRatchetVersions PQSupportOn
bob = initSndRatchet vs (C.publicKey pkAlice2) pkBob3 paramsBob
alice = initRcvRatchet vs pkAlice2 paramsAlice PQSupportOn
pure (alice, bob, encrypt' hasSndKEM, decrypt' hasRcvKEM, (!#>))
@@ -572,14 +572,14 @@ initRatchetsKEMProposedAgain = do
Right paramsBob <- pure $ pqX3dhSnd pkBob1 pkBob2 pKemParams_ e2eAlice
Right paramsAlice <- runExceptT $ pqX3dhRcv pkAlice1 pkAlice2 pKem_ e2eBob
(_, pkBob3) <- atomically $ C.generateKeyPair g
let vs = testRatchetVersions
let vs = testRatchetVersions PQSupportOn
bob = initSndRatchet vs (C.publicKey pkAlice2) pkBob3 paramsBob
alice = initRcvRatchet vs pkAlice2 paramsAlice PQSupportOn
pure (alice, bob, encrypt' hasSndKEM, decrypt' hasRcvKEM, (!#>))
testRatchetVersions :: RatchetVersions
testRatchetVersions =
let v = maxVersion supportedE2EEncryptVRange
testRatchetVersions :: PQSupport -> RatchetVersions
testRatchetVersions pq =
let v = maxVersion $ supportedE2EEncryptVRange pq
in RatchetVersions v v
encrypt_ :: AlgorithmI a => Maybe PQEncryption -> (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either CryptoError (ByteString, Ratchet a, SkippedMsgDiff))
+153 -224
View File
@@ -1,9 +1,7 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
@@ -14,6 +12,7 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
module AgentTests.FunctionalAPITests
( functionalAPITests,
@@ -46,43 +45,42 @@ module AgentTests.FunctionalAPITests
pattern REQ,
pattern Msg,
pattern Msg',
pattern SENT,
agentCfgV7,
)
where
import AgentTests.ConnectionRequestTests (connReqData, queueAddr, testE2ERatchetParams12)
import Control.Concurrent (forkIO, killThread, threadDelay)
import Control.Concurrent (killThread, threadDelay)
import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader
import Data.Bifunctor (first)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Either (isRight)
import Data.Int (Int64)
import Data.List (find, nub)
import Data.List (nub)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.Map as M
import Data.Maybe (isJust, isNothing)
import Data.Maybe (isNothing)
import qualified Data.Set as S
import Data.Time.Clock (diffUTCTime, getCurrentTime)
import Data.Time.Clock.System (SystemTime (..), getSystemTime)
import Data.Type.Equality (testEquality, (:~:) (Refl))
import Data.Type.Equality
import Data.Word (Word16)
import qualified Database.SQLite.Simple as SQL
import GHC.Stack (withFrozenCallStack)
import SMPAgentClient
import SMPClient (cfg, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerOn, withSmpServerProxy, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn, withSmpServerV7)
import SMPClient (cfg, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn, withSmpServerV7)
import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMessage)
import qualified Simplex.Messaging.Agent as A
import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), UserNetworkInfo (..), UserNetworkType (..), waitForUserNetwork)
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers (..), createAgentStore)
import Simplex.Messaging.Agent.Protocol hiding (CON, CONF, INFO, REQ, SENT)
import Simplex.Messaging.Agent.Protocol hiding (CON, CONF, INFO, REQ)
import qualified Simplex.Messaging.Agent.Protocol as A
import Simplex.Messaging.Agent.RetryInterval (RetryInterval (..))
import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), SQLiteStore (dbNew))
import Simplex.Messaging.Agent.Store.SQLite.Common (withTransaction')
import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientConfig (..), SMPProxyFallback (..), SMPProxyMode (..), TransportSessionMode (TSMEntity, TSMUser), defaultClientConfig)
import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientConfig (..), TransportSessionMode (TSMEntity, TSMUser), defaultSMPClientConfig)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.Ratchet (InitialKeys (..), PQEncryption (..), PQSupport (..), pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn)
import qualified Simplex.Messaging.Crypto.Ratchet as CR
@@ -92,7 +90,7 @@ import Simplex.Messaging.Protocol (BasicAuth, ErrorType (..), MsgBody, ProtocolS
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Server.Env.STM (ServerConfig (..))
import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.Transport (ATransport (..), SMPVersion, VersionSMP, authCmdsSMPVersion, basicAuthSMPVersion, batchCmdsSMPVersion, currentServerSMPRelayVersion, supportedSMPHandshakes)
import Simplex.Messaging.Transport (ATransport (..), SMPVersion, VersionSMP, authCmdsSMPVersion, basicAuthSMPVersion, batchCmdsSMPVersion, currentServerSMPRelayVersion)
import Simplex.Messaging.Util (diffToMicroseconds)
import Simplex.Messaging.Version (VersionRange (..))
import qualified Simplex.Messaging.Version as V
@@ -147,7 +145,6 @@ pGet c = do
case cmd of
CONNECT {} -> pGet c
DISCONNECT {} -> pGet c
ERR (BROKER _ NETWORK) -> pGet c
_ -> pure t
pattern CONF :: ConfirmationId -> [SMPServer] -> ConnInfo -> ACommand 'Agent e
@@ -174,33 +171,26 @@ pattern MsgErr msgId err msgBody <- MSG MsgMeta {recipient = (msgId, _), integri
pattern MsgErr' :: AgentMsgId -> MsgErrorType -> PQEncryption -> MsgBody -> ACommand 'Agent 'AEConn
pattern MsgErr' msgId err pq msgBody <- MSG MsgMeta {recipient = (msgId, _), integrity = MsgError err, pqEncryption = pq} _ msgBody
pattern SENT :: AgentMsgId -> ACommand 'Agent 'AEConn
pattern SENT msgId = A.SENT msgId Nothing
pattern Rcvd :: AgentMsgId -> ACommand 'Agent 'AEConn
pattern Rcvd agentMsgId <- RCVD MsgMeta {integrity = MsgOk} [MsgReceipt {agentMsgId, msgRcptStatus = MROk}]
smpCfgVPrev :: ProtocolClientConfig SMPVersion
smpCfgVPrev = (smpCfg agentCfg) {clientALPN = Nothing, serverVRange = prevRange $ serverVRange $ smpCfg agentCfg}
smpCfgVPrev = (smpCfg agentCfg) {serverVRange = prevRange $ serverVRange $ smpCfg agentCfg}
smpCfgV7 :: ProtocolClientConfig SMPVersion
smpCfgV7 = (smpCfg agentCfg) {serverVRange = V.mkVersionRange batchCmdsSMPVersion authCmdsSMPVersion}
ntfCfgVPrev :: ProtocolClientConfig NTFVersion
ntfCfgVPrev = (ntfCfg agentCfg) {clientALPN = Nothing, serverVRange = V.mkVersionRange (VersionNTF 1) (VersionNTF 1)}
ntfCfgV2 :: ProtocolClientConfig NTFVersion
ntfCfgV2 = (ntfCfg agentCfg) {serverVRange = V.mkVersionRange (VersionNTF 1) authBatchCmdsNTFVersion}
ntfCfgV2 = (smpCfg agentCfg) {serverVRange = V.mkVersionRange (VersionNTF 1) authBatchCmdsNTFVersion}
agentCfgVPrev :: AgentConfig
agentCfgVPrev =
agentCfg
{ sndAuthAlg = C.AuthAlg C.SEd25519,
smpAgentVRange = prevRange $ smpAgentVRange agentCfg,
smpAgentVRange = \_ -> prevRange $ smpAgentVRange agentCfg PQSupportOff,
smpClientVRange = prevRange $ smpClientVRange agentCfg,
e2eEncryptVRange = prevRange $ e2eEncryptVRange agentCfg,
smpCfg = smpCfgVPrev,
ntfCfg = ntfCfgVPrev
e2eEncryptVRange = \_ -> prevRange $ e2eEncryptVRange agentCfg PQSupportOff,
smpCfg = smpCfgVPrev
}
-- agent config for the next client version
@@ -208,14 +198,14 @@ agentCfgV7 :: AgentConfig
agentCfgV7 =
agentCfg
{ sndAuthAlg = C.AuthAlg C.SX25519,
smpAgentVRange = V.mkVersionRange duplexHandshakeSMPAgentVersion $ max pqdrSMPAgentVersion currentSMPAgentVersion,
e2eEncryptVRange = V.mkVersionRange CR.kdfX3DHE2EEncryptVersion $ max CR.pqRatchetE2EEncryptVersion CR.currentE2EEncryptVersion,
smpAgentVRange = \_ -> V.mkVersionRange duplexHandshakeSMPAgentVersion $ max pqdrSMPAgentVersion currentSMPAgentVersion,
e2eEncryptVRange = \_ -> V.mkVersionRange CR.kdfX3DHE2EEncryptVersion $ max CR.pqRatchetE2EEncryptVersion CR.currentE2EEncryptVersion,
smpCfg = smpCfgV7,
ntfCfg = ntfCfgV2
}
agentCfgRatchetVPrev :: AgentConfig
agentCfgRatchetVPrev = agentCfg {e2eEncryptVRange = prevRange $ e2eEncryptVRange agentCfg}
agentCfgRatchetVPrev = agentCfg {e2eEncryptVRange = \_ -> prevRange $ e2eEncryptVRange agentCfg PQSupportOff}
prevRange :: VersionRange v -> VersionRange v
prevRange vr = vr {maxVersion = max (minVersion vr) (prevVersion $ maxVersion vr)}
@@ -238,10 +228,10 @@ runRight action =
getInAnyOrder :: HasCallStack => AgentClient -> [ATransmission 'Agent -> Bool] -> Expectation
getInAnyOrder c ts = withFrozenCallStack $ inAnyOrder (pGet c) ts
inAnyOrder :: (Show a, MonadUnliftIO m, HasCallStack) => m a -> [a -> Bool] -> m ()
inAnyOrder :: (Show a, MonadIO m, HasCallStack) => m a -> [a -> Bool] -> m ()
inAnyOrder _ [] = pure ()
inAnyOrder g rs = withFrozenCallStack $ do
r <- 5000000 `timeout` g >>= maybe (error "inAnyOrder timeout") pure
r <- g
let rest = filter (not . expected r) rs
if length rest < length rs
then inAnyOrder g rest
@@ -254,7 +244,7 @@ createConnection :: AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe
createConnection c userId enableNtfs cMode clientData = A.createConnection c userId enableNtfs cMode clientData (IKNoPQ PQSupportOn)
joinConnection :: AgentClient -> UserId -> Bool -> ConnectionRequestUri c -> ConnInfo -> SubscriptionMode -> AE ConnId
joinConnection c userId enableNtfs cReq connInfo = A.joinConnection c userId Nothing enableNtfs cReq connInfo PQSupportOn
joinConnection c userId enableNtfs cReq connInfo = A.joinConnection c userId enableNtfs cReq connInfo PQSupportOn
sendMessage :: AgentClient -> ConnId -> SMP.MsgFlags -> MsgBody -> AE AgentMsgId
sendMessage c connId msgFlags msgBody = do
@@ -343,9 +333,6 @@ functionalAPITests t = do
skip "faster version of the previous test (200 subscriptions gets very slow with test coverage)" $
it "should subscribe to multiple (6) subscriptions with batching" $
testBatchedSubscriptions 6 3 t
it "should subscribe to multiple connections with pending messages" $
withSmpServer t $
testBatchedPendingMessages 10 5
describe "Async agent commands" $ do
it "should connect using async agent commands" $
withSmpServer t testAsyncCommands
@@ -428,7 +415,7 @@ functionalAPITests t = do
describe "server with password" $ do
let auth = Just "abcd"
srv = ProtoServerWithAuth testSMPServer2
authErr = Just (ProtocolTestFailure TSCreateQueue $ SMP (B.unpack $ strEncode testSMPServer2) AUTH)
authErr = Just (ProtocolTestFailure TSCreateQueue $ SMP AUTH)
it "should pass with correct password" $ testSMPServerConnectionTest t auth (srv auth) `shouldReturn` Nothing
it "should fail without password" $ testSMPServerConnectionTest t auth (srv Nothing) `shouldReturn` authErr
it "should fail with incorrect password" $ testSMPServerConnectionTest t auth (srv $ Just "wrong") `shouldReturn` authErr
@@ -441,8 +428,7 @@ functionalAPITests t = do
it "send delivery receipts concurrently with messages" $ testDeliveryReceiptsConcurrent t
describe "user network info" $ do
it "should wait for user network" testWaitForUserNetwork
it "should not reset online to offline if happens too quickly" testDoNotResetOnlineToOffline
it "should resume multiple threads" testResumeMultipleThreads
it "should not reset offline interval while offline" testDoNotResetOfflineInterval
testBasicAuth :: ATransport -> Bool -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> IO Int
testBasicAuth t allowNewQueues srv@(srvAuth, srvVersion) clnt1 clnt2 = do
@@ -462,28 +448,26 @@ canCreateQueue allowNew (srvAuth, srvVersion) (clntAuth, clntVersion) =
let v = basicAuthSMPVersion
in allowNew && (isNothing srvAuth || (srvVersion >= v && clntVersion >= v && srvAuth == clntAuth))
testMatrix2 :: ATransport -> (PQSupport -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
testMatrix2 :: ATransport -> (PQSupport -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
testMatrix2 t runTest = do
it "v8, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 agentProxyCfg agentProxyCfg (initAgentServersProxy SPMAlways SPFProhibit) 3 $ runTest PQSupportOn True
it "v7" $ withSmpServerV7 t $ runTestCfg2 agentCfgV7 agentCfgV7 3 $ runTest PQSupportOn False
it "v7 to current" $ withSmpServerV7 t $ runTestCfg2 agentCfgV7 agentCfg 3 $ runTest PQSupportOn False
it "current to v7" $ withSmpServerV7 t $ runTestCfg2 agentCfg agentCfgV7 3 $ runTest PQSupportOn False
it "current with v7 server" $ withSmpServerV7 t $ runTestCfg2 agentCfg agentCfg 3 $ runTest PQSupportOn False
it "current" $ withSmpServer t $ runTestCfg2 agentCfg agentCfg 3 $ runTest PQSupportOn False
it "prev" $ withSmpServer t $ runTestCfg2 agentCfgVPrev agentCfgVPrev 3 $ runTest PQSupportOff False
it "prev to current" $ withSmpServer t $ runTestCfg2 agentCfgVPrev agentCfg 3 $ runTest PQSupportOff False
it "current to prev" $ withSmpServer t $ runTestCfg2 agentCfg agentCfgVPrev 3 $ runTest PQSupportOff False
it "v7" $ withSmpServerV7 t $ runTestCfg2 agentCfgV7 agentCfgV7 3 $ runTest PQSupportOn
it "v7 to current" $ withSmpServerV7 t $ runTestCfg2 agentCfgV7 agentCfg 3 $ runTest PQSupportOn
it "current to v7" $ withSmpServerV7 t $ runTestCfg2 agentCfg agentCfgV7 3 $ runTest PQSupportOn
it "current with v7 server" $ withSmpServerV7 t $ runTestCfg2 agentCfg agentCfg 3 $ runTest PQSupportOn
it "current" $ withSmpServer t $ runTestCfg2 agentCfg agentCfg 3 $ runTest PQSupportOn
it "prev" $ withSmpServer t $ runTestCfg2 agentCfgVPrev agentCfgVPrev 3 $ runTest PQSupportOff
it "prev to current" $ withSmpServer t $ runTestCfg2 agentCfgVPrev agentCfg 3 $ runTest PQSupportOff
it "current to prev" $ withSmpServer t $ runTestCfg2 agentCfg agentCfgVPrev 3 $ runTest PQSupportOff
testRatchetMatrix2 :: ATransport -> (PQSupport -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
testRatchetMatrix2 :: ATransport -> (PQSupport -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
testRatchetMatrix2 t runTest = do
it "v8, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 agentProxyCfg agentProxyCfg (initAgentServersProxy SPMAlways SPFProhibit) 3 $ runTest PQSupportOn True
it "ratchet next" $ withSmpServerV7 t $ runTestCfg2 agentCfgV7 agentCfgV7 3 $ runTest PQSupportOn False
it "ratchet next to current" $ withSmpServerV7 t $ runTestCfg2 agentCfgV7 agentCfg 3 $ runTest PQSupportOn False
it "ratchet current to next" $ withSmpServerV7 t $ runTestCfg2 agentCfg agentCfgV7 3 $ runTest PQSupportOn False
it "ratchet current" $ withSmpServer t $ runTestCfg2 agentCfg agentCfg 3 $ runTest PQSupportOn False
it "ratchet prev" $ withSmpServer t $ runTestCfg2 agentCfgRatchetVPrev agentCfgRatchetVPrev 3 $ runTest PQSupportOff False
it "ratchets prev to current" $ withSmpServer t $ runTestCfg2 agentCfgRatchetVPrev agentCfg 3 $ runTest PQSupportOff False
it "ratchets current to prev" $ withSmpServer t $ runTestCfg2 agentCfg agentCfgRatchetVPrev 3 $ runTest PQSupportOff False
it "ratchet next" $ withSmpServerV7 t $ runTestCfg2 agentCfgV7 agentCfgV7 3 $ runTest PQSupportOn
it "ratchet next to current" $ withSmpServerV7 t $ runTestCfg2 agentCfgV7 agentCfg 3 $ runTest PQSupportOn
it "ratchet current to next" $ withSmpServerV7 t $ runTestCfg2 agentCfg agentCfgV7 3 $ runTest PQSupportOn
it "ratchet current" $ withSmpServer t $ runTestCfg2 agentCfg agentCfg 3 $ runTest PQSupportOn
it "ratchet prev" $ withSmpServer t $ runTestCfg2 agentCfgRatchetVPrev agentCfgRatchetVPrev 3 $ runTest PQSupportOff
it "ratchets prev to current" $ withSmpServer t $ runTestCfg2 agentCfgRatchetVPrev agentCfg 3 $ runTest PQSupportOff
it "ratchets current to prev" $ withSmpServer t $ runTestCfg2 agentCfg agentCfgRatchetVPrev 3 $ runTest PQSupportOff
testServerMatrix2 :: ATransport -> (InitialAgentServers -> IO ()) -> Spec
testServerMatrix2 t runTest = do
@@ -491,14 +475,10 @@ testServerMatrix2 t runTest = do
it "2 servers" $ withSmpServer t . withSmpServerOn t testPort2 $ runTest initAgentServers2
runTestCfg2 :: HasCallStack => AgentConfig -> AgentConfig -> AgentMsgId -> (HasCallStack => AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> IO ()
runTestCfg2 aCfg bCfg = runTestCfgServers2 aCfg bCfg initAgentServers
runTestCfg2 aCfg bCfg baseMsgId runTest =
withAgentClientsCfg2 aCfg bCfg $ \a b -> runTest a b baseMsgId
{-# INLINE runTestCfg2 #-}
runTestCfgServers2 :: HasCallStack => AgentConfig -> AgentConfig -> InitialAgentServers -> AgentMsgId -> (HasCallStack => AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> IO ()
runTestCfgServers2 aCfg bCfg servers baseMsgId runTest =
withAgentClientsCfgServers2 aCfg bCfg servers $ \a b -> runTest a b baseMsgId
{-# INLINE runTestCfgServers2 #-}
withAgentClientsCfgServers2 :: HasCallStack => AgentConfig -> AgentConfig -> InitialAgentServers -> (HasCallStack => AgentClient -> AgentClient -> IO ()) -> IO ()
withAgentClientsCfgServers2 aCfg bCfg servers runTest =
withAgent 1 aCfg servers testDB $ \a ->
@@ -519,11 +499,11 @@ withAgentClients3 runTest =
withAgent 3 agentCfg initAgentServers testDB3 $ \c ->
runTest a b c
runAgentClientTest :: HasCallStack => PQSupport -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()
runAgentClientTest pqSupport viaProxy alice@AgentClient {} bob baseId =
runAgentClientTest :: HasCallStack => PQSupport -> AgentClient -> AgentClient -> AgentMsgId -> IO ()
runAgentClientTest pqSupport alice@AgentClient {} bob baseId =
runRight_ $ do
(bobId, qInfo) <- A.createConnection alice 1 True SCMInvitation Nothing (IKNoPQ pqSupport) SMSubscribe
aliceId <- A.joinConnection bob 1 Nothing True qInfo "bob's connInfo" pqSupport SMSubscribe
aliceId <- A.joinConnection bob 1 True qInfo "bob's connInfo" pqSupport SMSubscribe
("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
liftIO $ pqSup' `shouldBe` pqSupport
allowConnection alice bobId confId "alice's connInfo"
@@ -532,26 +512,25 @@ runAgentClientTest pqSupport viaProxy alice@AgentClient {} bob baseId =
get bob ##> ("", aliceId, A.INFO pqSupport "alice's connInfo")
get bob ##> ("", aliceId, A.CON pqEnc)
-- message IDs 1 to 3 (or 1 to 4 in v1) get assigned to control messages, so first MSG is assigned ID 4
let proxySrv = if viaProxy then Just testSMPServer else Nothing
1 <- msgId <$> A.sendMessage alice bobId pqEnc SMP.noMsgFlags "hello"
get alice ##> ("", bobId, A.SENT (baseId + 1) proxySrv)
get alice ##> ("", bobId, SENT $ baseId + 1)
2 <- msgId <$> A.sendMessage alice bobId pqEnc SMP.noMsgFlags "how are you?"
get alice ##> ("", bobId, A.SENT (baseId + 2) proxySrv)
get alice ##> ("", bobId, SENT $ baseId + 2)
get bob =##> \case ("", c, Msg' _ pq "hello") -> c == aliceId && pq == pqEnc; _ -> False
ackMessage bob aliceId (baseId + 1) Nothing
get bob =##> \case ("", c, Msg' _ pq "how are you?") -> c == aliceId && pq == pqEnc; _ -> False
ackMessage bob aliceId (baseId + 2) Nothing
3 <- msgId <$> A.sendMessage bob aliceId pqEnc SMP.noMsgFlags "hello too"
get bob ##> ("", aliceId, A.SENT (baseId + 3) proxySrv)
get bob ##> ("", aliceId, SENT $ baseId + 3)
4 <- msgId <$> A.sendMessage bob aliceId pqEnc SMP.noMsgFlags "message 1"
get bob ##> ("", aliceId, A.SENT (baseId + 4) proxySrv)
get bob ##> ("", aliceId, SENT $ baseId + 4)
get alice =##> \case ("", c, Msg' _ pq "hello too") -> c == bobId && pq == pqEnc; _ -> False
ackMessage alice bobId (baseId + 3) Nothing
get alice =##> \case ("", c, Msg' _ pq "message 1") -> c == bobId && pq == pqEnc; _ -> False
ackMessage alice bobId (baseId + 4) Nothing
suspendConnection alice bobId
5 <- msgId <$> A.sendMessage bob aliceId pqEnc SMP.noMsgFlags "message 2"
get bob =##> \case ("", cId, MERR mId (SMP _ AUTH)) -> cId == aliceId && mId == (baseId + 5); _ -> False
get bob ##> ("", aliceId, MERR (baseId + 5) (SMP AUTH))
deleteConnection alice bobId
liftIO $ noMessages alice "nothing else should be delivered to alice"
where
@@ -567,27 +546,28 @@ testEnablePQEncryption =
(a, 4, "msg 1") \#>\ b
(b, 5, "msg 2") \#>\ a
-- 45 bytes is used by agent message envelope inside double ratchet message envelope
let largeMsg g' pqEnc = atomically $ C.randomBytes (e2eEncAgentMsgLength pqdrSMPAgentVersion pqEnc - 45) g'
let largeMsg g' pqEnc = atomically $ C.randomBytes (e2eEncUserMsgLength pqdrSMPAgentVersion pqEnc - 45) g'
lrg <- largeMsg g PQSupportOff
(a, 6, lrg) \#>\ b
(b, 7, lrg) \#>\ a
-- enabling PQ encryption
(a, 8, lrg) \#>! b
(b, 9, lrg) \#>! a
-- switched to smaller envelopes (before reporting PQ encryption enabled)
sml <- largeMsg g PQSupportOn
-- fail because of message size
Left (A.CMD LARGE _) <- tryError $ A.sendMessage ca bId PQEncOn SMP.noMsgFlags lrg
(9, PQEncOff) <- A.sendMessage ca bId PQEncOn SMP.noMsgFlags sml
get ca =##> \case ("", connId, SENT 9) -> connId == bId; _ -> False
get cb =##> \case ("", connId, MsgErr' 8 MsgSkipped {} PQEncOff msg') -> connId == aId && msg' == sml; _ -> False
ackMessage cb aId 8 Nothing
Left (A.CMD LARGE) <- tryError $ A.sendMessage ca bId PQEncOn SMP.noMsgFlags lrg
(11, PQEncOff) <- A.sendMessage ca bId PQEncOn SMP.noMsgFlags sml
get ca =##> \case ("", connId, SENT 11) -> connId == bId; _ -> False
get cb =##> \case ("", connId, MsgErr' 10 MsgSkipped {} PQEncOff msg') -> connId == aId && msg' == sml; _ -> False
ackMessage cb aId 10 Nothing
-- -- fail in reply to sync IDss
Left (A.CMD LARGE _) <- tryError $ A.sendMessage cb aId PQEncOn SMP.noMsgFlags lrg
(10, PQEncOff) <- A.sendMessage cb aId PQEncOn SMP.noMsgFlags sml
get cb =##> \case ("", connId, SENT 10) -> connId == aId; _ -> False
get ca =##> \case ("", connId, MsgErr' 10 MsgSkipped {} PQEncOff msg') -> connId == bId && msg' == sml; _ -> False
ackMessage ca bId 10 Nothing
(a, 11, sml) \#>! b
Left (A.CMD LARGE) <- tryError $ A.sendMessage cb aId PQEncOn SMP.noMsgFlags lrg
(12, PQEncOn) <- A.sendMessage cb aId PQEncOn SMP.noMsgFlags sml
get cb =##> \case ("", connId, SENT 12) -> connId == aId; _ -> False
get ca =##> \case ("", connId, MsgErr' 12 MsgSkipped {} PQEncOn msg') -> connId == bId && msg' == sml; _ -> False
ackMessage ca bId 12 Nothing
-- PQ encryption now enabled
(b, 12, sml) !#>! a
(a, 13, sml) !#>! b
(b, 14, sml) !#>! a
-- disabling PQ encryption
@@ -607,8 +587,8 @@ testEnablePQEncryption =
(b, 26, sml) \#>\ a
(a, 27, sml) \#>\ b
-- PQ encryption is now disabled, but support remained enabled, so we still cannot send larger messages
Left (A.CMD LARGE _) <- tryError $ A.sendMessage ca bId PQEncOff SMP.noMsgFlags (sml <> "123456")
Left (A.CMD LARGE _) <- tryError $ A.sendMessage cb aId PQEncOff SMP.noMsgFlags (sml <> "123456")
Left (A.CMD LARGE) <- tryError $ A.sendMessage ca bId PQEncOff SMP.noMsgFlags (sml <> "123456")
Left (A.CMD LARGE) <- tryError $ A.sendMessage cb aId PQEncOff SMP.noMsgFlags (sml <> "123456")
pure ()
where
(\#>\) = PQEncOff `sndRcv` PQEncOff
@@ -647,13 +627,11 @@ testAgentClient3 =
get c =##> \case ("", connId, Msg "c5") -> connId == aIdForC; _ -> False
ackMessage c aIdForC 5 Nothing
runAgentClientContactTest :: HasCallStack => PQSupport -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()
runAgentClientContactTest pqSupport viaProxy alice bob baseId =
runAgentClientContactTest :: HasCallStack => PQSupport -> AgentClient -> AgentClient -> AgentMsgId -> IO ()
runAgentClientContactTest pqSupport alice bob baseId =
runRight_ $ do
(_, qInfo) <- A.createConnection alice 1 True SCMContact Nothing (IKNoPQ pqSupport) SMSubscribe
aliceId <- A.prepareConnectionToJoin bob 1 True qInfo pqSupport
aliceId' <- A.joinConnection bob 1 (Just aliceId) True qInfo "bob's connInfo" pqSupport SMSubscribe
liftIO $ aliceId' `shouldBe` aliceId
aliceId <- A.joinConnection bob 1 True qInfo "bob's connInfo" pqSupport SMSubscribe
("", _, A.REQ invId pqSup' _ "bob's connInfo") <- get alice
liftIO $ pqSup' `shouldBe` pqSupport
bobId <- acceptContact alice True invId "alice's connInfo" PQSupportOn SMSubscribe
@@ -665,26 +643,25 @@ runAgentClientContactTest pqSupport viaProxy alice bob baseId =
get alice ##> ("", bobId, A.CON pqEnc)
get bob ##> ("", aliceId, A.CON pqEnc)
-- message IDs 1 to 3 (or 1 to 4 in v1) get assigned to control messages, so first MSG is assigned ID 4
let proxySrv = if viaProxy then Just testSMPServer else Nothing
1 <- msgId <$> A.sendMessage alice bobId pqEnc SMP.noMsgFlags "hello"
get alice ##> ("", bobId, A.SENT (baseId + 1) proxySrv)
get alice ##> ("", bobId, SENT $ baseId + 1)
2 <- msgId <$> A.sendMessage alice bobId pqEnc SMP.noMsgFlags "how are you?"
get alice ##> ("", bobId, A.SENT (baseId + 2) proxySrv)
get alice ##> ("", bobId, SENT $ baseId + 2)
get bob =##> \case ("", c, Msg' _ pq "hello") -> c == aliceId && pq == pqEnc; _ -> False
ackMessage bob aliceId (baseId + 1) Nothing
get bob =##> \case ("", c, Msg' _ pq "how are you?") -> c == aliceId && pq == pqEnc; _ -> False
ackMessage bob aliceId (baseId + 2) Nothing
3 <- msgId <$> A.sendMessage bob aliceId pqEnc SMP.noMsgFlags "hello too"
get bob ##> ("", aliceId, A.SENT (baseId + 3) proxySrv)
get bob ##> ("", aliceId, SENT $ baseId + 3)
4 <- msgId <$> A.sendMessage bob aliceId pqEnc SMP.noMsgFlags "message 1"
get bob ##> ("", aliceId, A.SENT (baseId + 4) proxySrv)
get bob ##> ("", aliceId, SENT $ baseId + 4)
get alice =##> \case ("", c, Msg' _ pq "hello too") -> c == bobId && pq == pqEnc; _ -> False
ackMessage alice bobId (baseId + 3) Nothing
get alice =##> \case ("", c, Msg' _ pq "message 1") -> c == bobId && pq == pqEnc; _ -> False
ackMessage alice bobId (baseId + 4) Nothing
suspendConnection alice bobId
5 <- msgId <$> A.sendMessage bob aliceId pqEnc SMP.noMsgFlags "message 2"
get bob =##> \case ("", cId, MERR mId (SMP _ AUTH)) -> cId == aliceId && mId == (baseId + 5); _ -> False
get bob ##> ("", aliceId, MERR (baseId + 5) (SMP AUTH))
deleteConnection alice bobId
liftIO $ noMessages alice "nothing else should be delivered to alice"
where
@@ -820,8 +797,8 @@ testAllowConnectionClientRestart t = do
testIncreaseConnAgentVersion :: HasCallStack => ATransport -> IO ()
testIncreaseConnAgentVersion t = do
alice <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB
bob <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB2
alice <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = \_ -> mkVersionRange 1 2} initAgentServers testDB
bob <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = \_ -> mkVersionRange 1 2} initAgentServers testDB2
withSmpServerStoreMsgLogOn t testPort $ \_ -> do
(aliceId, bobId) <- runRight $ do
(aliceId, bobId) <- makeConnection_ PQSupportOff alice bob
@@ -833,7 +810,7 @@ testIncreaseConnAgentVersion t = do
-- version doesn't increase if incompatible
disposeAgentClient alice
alice2 <- getSMPAgentClient' 3 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB
alice2 <- getSMPAgentClient' 3 agentCfg {smpAgentVRange = \_ -> mkVersionRange 1 3} initAgentServers testDB
runRight_ $ do
subscribeConnection alice2 bobId
@@ -844,7 +821,7 @@ testIncreaseConnAgentVersion t = do
-- version increases if compatible
disposeAgentClient bob
bob2 <- getSMPAgentClient' 4 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB2
bob2 <- getSMPAgentClient' 4 agentCfg {smpAgentVRange = \_ -> mkVersionRange 1 3} initAgentServers testDB2
runRight_ $ do
subscribeConnection bob2 aliceId
@@ -855,7 +832,7 @@ testIncreaseConnAgentVersion t = do
-- version doesn't decrease, even if incompatible
disposeAgentClient alice2
alice3 <- getSMPAgentClient' 5 agentCfg {smpAgentVRange = mkVersionRange 2 2} initAgentServers testDB
alice3 <- getSMPAgentClient' 5 agentCfg {smpAgentVRange = \_ -> mkVersionRange 2 2} initAgentServers testDB
runRight_ $ do
subscribeConnection alice3 bobId
@@ -864,7 +841,7 @@ testIncreaseConnAgentVersion t = do
checkVersion bob2 aliceId 3
disposeAgentClient bob2
bob3 <- getSMPAgentClient' 6 agentCfg {smpAgentVRange = mkVersionRange 1 1} initAgentServers testDB2
bob3 <- getSMPAgentClient' 6 agentCfg {smpAgentVRange = \_ -> mkVersionRange 1 1} initAgentServers testDB2
runRight_ $ do
subscribeConnection bob3 aliceId
@@ -881,8 +858,8 @@ checkVersion c connId v = do
testIncreaseConnAgentVersionMaxCompatible :: HasCallStack => ATransport -> IO ()
testIncreaseConnAgentVersionMaxCompatible t = do
alice <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB
bob <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB2
alice <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = \_ -> mkVersionRange 1 2} initAgentServers testDB
bob <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = \_ -> mkVersionRange 1 2} initAgentServers testDB2
withSmpServerStoreMsgLogOn t testPort $ \_ -> do
(aliceId, bobId) <- runRight $ do
(aliceId, bobId) <- makeConnection_ PQSupportOff alice bob
@@ -894,7 +871,7 @@ testIncreaseConnAgentVersionMaxCompatible t = do
-- version increases to max compatible
disposeAgentClient alice
alice2 <- getSMPAgentClient' 3 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB
alice2 <- getSMPAgentClient' 3 agentCfg {smpAgentVRange = \_ -> mkVersionRange 1 3} initAgentServers testDB
disposeAgentClient bob
bob2 <- getSMPAgentClient' 4 agentCfg {smpAgentVRange = supportedSMPAgentVRange} initAgentServers testDB2
@@ -909,8 +886,8 @@ testIncreaseConnAgentVersionMaxCompatible t = do
testIncreaseConnAgentVersionStartDifferentVersion :: HasCallStack => ATransport -> IO ()
testIncreaseConnAgentVersionStartDifferentVersion t = do
alice <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB
bob <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB2
alice <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = \_ -> mkVersionRange 1 2} initAgentServers testDB
bob <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = \_ -> mkVersionRange 1 3} initAgentServers testDB2
withSmpServerStoreMsgLogOn t testPort $ \_ -> do
(aliceId, bobId) <- runRight $ do
(aliceId, bobId) <- makeConnection_ PQSupportOff alice bob
@@ -922,7 +899,7 @@ testIncreaseConnAgentVersionStartDifferentVersion t = do
-- version increases to max compatible
disposeAgentClient alice
alice2 <- getSMPAgentClient' 3 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB
alice2 <- getSMPAgentClient' 3 agentCfg {smpAgentVRange = \_ -> mkVersionRange 1 3} initAgentServers testDB
runRight_ $ do
subscribeConnection alice2 bobId
@@ -1130,7 +1107,7 @@ testExpireMessageQuota t = withSmpServerConfigOn t cfg {msgQueueQuota = 1} testP
5 <- sendMessage a bId SMP.noMsgFlags "2"
liftIO $ threadDelay 1000000
6 <- sendMessage a bId SMP.noMsgFlags "3" -- this won't expire
get a =##> \case ("", c, MERR 5 (SMP _ QUOTA)) -> bId == c; _ -> False
get a =##> \case ("", c, MERR 5 (SMP QUOTA)) -> bId == c; _ -> False
pure (aId, bId)
withAgent 3 agentCfg initAgentServers testDB2 $ \b' -> runRight_ $ do
subscribeConnection b' aId
@@ -1158,15 +1135,15 @@ testExpireManyMessagesQuota t = withSmpServerConfigOn t cfg {msgQueueQuota = 1}
7 <- sendMessage a bId SMP.noMsgFlags "4"
liftIO $ threadDelay 1000000
8 <- sendMessage a bId SMP.noMsgFlags "5" -- this won't expire
get a =##> \case ("", c, MERR 5 (SMP _ QUOTA)) -> bId == c; _ -> False
get a =##> \case ("", c, MERR 5 (SMP QUOTA)) -> bId == c; _ -> False
get a >>= \case
("", c, MERR 6 (SMP _ QUOTA)) -> do
("", c, MERR 6 (SMP QUOTA)) -> do
liftIO $ bId `shouldBe` c
get a =##> \case ("", c', MERR 7 (SMP _ QUOTA)) -> bId == c'; ("", c', MERRS [7] (SMP _ QUOTA)) -> bId == c'; _ -> False
("", c, MERRS [6] (SMP _ QUOTA)) -> do
get a =##> \case ("", c', MERR 7 (SMP QUOTA)) -> bId == c'; ("", c', MERRS [7] (SMP QUOTA)) -> bId == c'; _ -> False
("", c, MERRS [6] (SMP QUOTA)) -> do
liftIO $ bId `shouldBe` c
get a =##> \case ("", c', MERR 7 (SMP _ QUOTA)) -> bId == c'; _ -> False
("", c, MERRS [6, 7] (SMP _ QUOTA)) -> liftIO $ bId `shouldBe` c
get a =##> \case ("", c', MERR 7 (SMP QUOTA)) -> bId == c'; _ -> False
("", c, MERRS [6, 7] (SMP QUOTA)) -> liftIO $ bId `shouldBe` c
r -> error $ show r
pure (aId, bId)
withAgent 3 agentCfg initAgentServers testDB2 $ \b' -> runRight_ $ do
@@ -1266,10 +1243,15 @@ testRatchetSyncServerOffline t = withAgentClients2 $ \alice bob -> do
liftIO $ ratchetSyncState `shouldBe` RSStarted
withSmpServerStoreMsgLogOn t testPort $ \_ -> do
concurrently_
(getInAnyOrder alice [ratchetSyncP' bobId RSAgreed, serverUpP])
(getInAnyOrder bob2 [ratchetSyncP' aliceId RSAgreed, serverUpP])
runRight_ $ do
liftIO . getInAnyOrder alice $
[ ratchetSyncP' bobId RSAgreed,
serverUpP
]
liftIO . getInAnyOrder bob2 $
[ ratchetSyncP' aliceId RSAgreed,
serverUpP
]
get alice =##> ratchetSyncP bobId RSOk
get bob2 =##> ratchetSyncP aliceId RSOk
exchangeGreetingsMsgIds alice bobId 12 bob2 aliceId 9
@@ -1323,10 +1305,15 @@ testRatchetSyncSuspendForeground t = do
foregroundAgent bob2
withSmpServerStoreMsgLogOn t testPort $ \_ -> do
concurrently_
(getInAnyOrder alice [ratchetSyncP' bobId RSAgreed, serverUpP])
(getInAnyOrder bob2 [ratchetSyncP' aliceId RSAgreed, serverUpP])
runRight_ $ do
liftIO . getInAnyOrder alice $
[ ratchetSyncP' bobId RSAgreed,
serverUpP
]
liftIO . getInAnyOrder bob2 $
[ ratchetSyncP' aliceId RSAgreed,
serverUpP
]
get alice =##> ratchetSyncP bobId RSOk
get bob2 =##> ratchetSyncP aliceId RSOk
exchangeGreetingsMsgIds alice bobId 12 bob2 aliceId 9
@@ -1351,10 +1338,15 @@ testRatchetSyncSimultaneous t = do
liftIO $ aRSS `shouldBe` RSStarted
withSmpServerStoreMsgLogOn t testPort $ \_ -> do
concurrently_
(getInAnyOrder alice [ratchetSyncP' bobId RSAgreed, serverUpP])
(getInAnyOrder bob2 [ratchetSyncP' aliceId RSAgreed, serverUpP])
runRight_ $ do
liftIO . getInAnyOrder alice $
[ ratchetSyncP' bobId RSAgreed,
serverUpP
]
liftIO . getInAnyOrder bob2 $
[ ratchetSyncP' aliceId RSAgreed,
serverUpP
]
get alice =##> ratchetSyncP bobId RSOk
get bob2 =##> ratchetSyncP aliceId RSOk
exchangeGreetingsMsgIds alice bobId 12 bob2 aliceId 9
@@ -1402,15 +1394,13 @@ makeConnection = makeConnection_ PQSupportOn
makeConnection_ :: PQSupport -> AgentClient -> AgentClient -> ExceptT AgentErrorType IO (ConnId, ConnId)
makeConnection_ pqEnc alice bob = makeConnectionForUsers_ pqEnc alice 1 bob 1
makeConnectionForUsers :: HasCallStack => AgentClient -> UserId -> AgentClient -> UserId -> ExceptT AgentErrorType IO (ConnId, ConnId)
makeConnectionForUsers :: AgentClient -> UserId -> AgentClient -> UserId -> ExceptT AgentErrorType IO (ConnId, ConnId)
makeConnectionForUsers = makeConnectionForUsers_ PQSupportOn
makeConnectionForUsers_ :: HasCallStack => PQSupport -> AgentClient -> UserId -> AgentClient -> UserId -> ExceptT AgentErrorType IO (ConnId, ConnId)
makeConnectionForUsers_ :: PQSupport -> AgentClient -> UserId -> AgentClient -> UserId -> ExceptT AgentErrorType IO (ConnId, ConnId)
makeConnectionForUsers_ pqSupport alice aliceUserId bob bobUserId = do
(bobId, qInfo) <- A.createConnection alice aliceUserId True SCMInvitation Nothing (CR.IKNoPQ pqSupport) SMSubscribe
aliceId <- A.prepareConnectionToJoin bob bobUserId True qInfo pqSupport
aliceId' <- A.joinConnection bob bobUserId (Just aliceId) True qInfo "bob's connInfo" pqSupport SMSubscribe
liftIO $ aliceId' `shouldBe` aliceId
aliceId <- A.joinConnection bob bobUserId True qInfo "bob's connInfo" pqSupport SMSubscribe
("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
liftIO $ pqSup' `shouldBe` pqSupport
allowConnection alice bobId confId "alice's connInfo"
@@ -1503,9 +1493,9 @@ testSuspendingAgentCompleteSending t = withAgentClients2 $ \a b -> do
liftIO $ suspendAgent b 5000000
withSmpServerStoreLogOn t testPort $ \_ -> runRight_ @AgentErrorType $ do
pGet b =##> \case ("", c, APC SAEConn (SENT 5)) -> c == aId; ("", "", APC _ UP {}) -> True; _ -> False
pGet b =##> \case ("", c, APC SAEConn (SENT 5)) -> c == aId; ("", "", APC _ UP {}) -> True; _ -> False
pGet b =##> \case ("", c, APC SAEConn (SENT 6)) -> c == aId; ("", "", APC _ UP {}) -> True; _ -> False
pGet b =##> \case ("", c, APC _ (SENT 5)) -> c == aId; ("", "", APC _ UP {}) -> True; _ -> False
pGet b =##> \case ("", c, APC _ (SENT 5)) -> c == aId; ("", "", APC _ UP {}) -> True; _ -> False
pGet b =##> \case ("", c, APC _ (SENT 6)) -> c == aId; ("", "", APC _ UP {}) -> True; _ -> False
("", "", SUSPENDED) <- nGet b
pGet a =##> \case ("", c, APC _ (Msg "hello too")) -> c == bId; ("", "", APC _ UP {}) -> True; _ -> False
@@ -1537,7 +1527,7 @@ testBatchedSubscriptions :: Int -> Int -> ATransport -> IO ()
testBatchedSubscriptions nCreate nDel t =
withAgentClientsCfgServers2 agentCfg agentCfg initAgentServers2 $ \a b -> do
conns <- runServers $ do
conns <- replicateM nCreate $ makeConnection_ PQSupportOff a b
conns <- replicateM (nCreate :: Int) $ makeConnection_ PQSupportOff a b
forM_ conns $ \(aId, bId) -> exchangeGreetings_ PQEncOff a bId b aId
let (aIds', bIds') = unzip $ take nDel conns
delete a bIds'
@@ -1596,25 +1586,6 @@ testBatchedSubscriptions nCreate nDel t =
killThread t1
pure res
testBatchedPendingMessages :: Int -> Int -> IO ()
testBatchedPendingMessages nCreate nMsgs =
withA $ \a -> do
conns <- withB $ \b -> runRight $ do
replicateM nCreate $ makeConnection a b
let msgConns = take nMsgs conns
runRight_ $ forM_ msgConns $ \(_, bId) -> sendMessage a bId SMP.noMsgFlags "hello"
replicateM_ nMsgs $ get a =##> \case ("", cId, SENT _) -> isJust $ find ((cId ==) . snd) msgConns; _ -> False
withB $ \b -> runRight_ $ do
r <- subscribeConnections b $ map fst conns
liftIO $ all isRight r `shouldBe` True
replicateM_ nMsgs $ do
("", cId, Msg' msgId _ "hello") <- get b
liftIO $ isJust (find ((cId ==) . fst) msgConns) `shouldBe` True
ackMessage b cId msgId Nothing
where
withA = withAgent 1 agentCfg initAgentServers testDB
withB = withAgent 2 agentCfg initAgentServers testDB2
testAsyncCommands :: IO ()
testAsyncCommands =
withAgentClients2 $ \alice bob -> runRight_ $ do
@@ -1709,7 +1680,7 @@ testAcceptContactAsync =
ackMessage alice bobId (baseId + 4) Nothing
suspendConnection alice bobId
5 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "message 2"
get bob =##> \case ("", cId, MERR mId (SMP _ AUTH)) -> cId == aliceId && mId == (baseId + 5); _ -> False
get bob ##> ("", aliceId, MERR (baseId + 5) (SMP AUTH))
deleteConnection alice bobId
liftIO $ noMessages alice "nothing else should be delivered to alice"
where
@@ -1755,7 +1726,7 @@ testWaitDeliveryNoPending t = withAgentClients2 $ \alice bob ->
get alice =##> \case ("", cId, DEL_CONN) -> cId == bobId; _ -> False
3 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "message 2"
get bob =##> \case ("", cId, MERR mId (SMP _ AUTH)) -> cId == aliceId && mId == (baseId + 3); _ -> False
get bob ##> ("", aliceId, MERR (baseId + 3) (SMP AUTH))
liftIO $ noMessages alice "nothing else should be delivered to alice"
liftIO $ noMessages bob "nothing else should be delivered to bob"
@@ -1850,8 +1821,8 @@ testWaitDeliveryAUTHErr t =
liftIO $ noMessages bob "nothing else should be delivered to bob"
withSmpServerStoreLogOn t testPort $ \_ -> do
get alice =##> \case ("", cId, MERR mId (SMP _ AUTH)) -> cId == bobId && mId == (baseId + 3); _ -> False
get alice =##> \case ("", cId, MERR mId (SMP _ AUTH)) -> cId == bobId && mId == (baseId + 4); _ -> False
get alice ##> ("", bobId, MERR (baseId + 3) (SMP AUTH))
get alice ##> ("", bobId, MERR (baseId + 4) (SMP AUTH))
get alice =##> \case ("", cId, DEL_CONN) -> cId == bobId; _ -> False
liftIO $ noMessages alice "nothing else should be delivered to alice"
@@ -2422,11 +2393,11 @@ testCreateQueueAuth srvVersion clnt1 clnt2 = do
b <- getClient 2 clnt2 testDB2
r <- runRight $ do
tryError (createConnection a 1 True SCMInvitation Nothing SMSubscribe) >>= \case
Left (SMP _ AUTH) -> pure 0
Left (SMP AUTH) -> pure 0
Left e -> throwError e
Right (bId, qInfo) ->
tryError (joinConnection b 1 True qInfo "bob's connInfo" SMSubscribe) >>= \case
Left (SMP _ AUTH) -> pure 1
Left (SMP AUTH) -> pure 1
Left e -> throwError e
Right aId -> do
("", _, CONF confId _ "bob's connInfo") <- get a
@@ -2442,8 +2413,7 @@ testCreateQueueAuth srvVersion clnt1 clnt2 = do
where
getClient clientId (clntAuth, clntVersion) db =
let servers = initAgentServers {smp = userServers [ProtoServerWithAuth testSMPServer clntAuth]}
alpn_ = if clntVersion >= authCmdsSMPVersion then Just supportedSMPHandshakes else Nothing
smpCfg = defaultClientConfig alpn_ $ V.mkVersionRange (prevVersion basicAuthSMPVersion) clntVersion
smpCfg = (defaultSMPClientConfig :: ProtocolClientConfig SMPVersion) {serverVRange = V.mkVersionRange (prevVersion basicAuthSMPVersion) clntVersion}
sndAuthAlg = if srvVersion >= authCmdsSMPVersion && clntVersion >= authCmdsSMPVersion then C.AuthAlg C.SX25519 else C.AuthAlg C.SEd25519
in getSMPAgentClient' clientId agentCfg {smpCfg, sndAuthAlg} servers db
@@ -2479,13 +2449,13 @@ testDeliveryReceipts =
get a =##> \case ("", c, Msg "hello too") -> c == bId; _ -> False
ackMessage a bId 6 $ Just ""
get b =##> \case ("", c, Rcvd 6) -> c == aId; _ -> False
ackMessage b aId 7 (Just "") `catchError` \case (A.CMD PROHIBITED _) -> pure (); e -> liftIO $ expectationFailure ("unexpected error " <> show e)
ackMessage b aId 7 (Just "") `catchError` \e -> liftIO $ e `shouldBe` A.CMD PROHIBITED
ackMessage b aId 7 Nothing
testDeliveryReceiptsVersion :: HasCallStack => ATransport -> IO ()
testDeliveryReceiptsVersion t = do
a <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB
b <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB2
a <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = \_ -> mkVersionRange 1 3} initAgentServers testDB
b <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = \_ -> mkVersionRange 1 3} initAgentServers testDB2
withSmpServerStoreMsgLogOn t testPort $ \_ -> do
(aId, bId) <- runRight $ do
(aId, bId) <- makeConnection_ PQSupportOff a b
@@ -2512,8 +2482,8 @@ testDeliveryReceiptsVersion t = do
subscribeConnection a' bId
subscribeConnection b' aId
exchangeGreetingsMsgId_ PQEncOff 6 a' bId b' aId
checkVersion a' bId 5
checkVersion b' aId 5
checkVersion a' bId 4
checkVersion b' aId 4
(8, PQEncOff) <- A.sendMessage a' bId PQEncOn SMP.noMsgFlags "hello"
get a' ##> ("", bId, SENT 8)
get b' =##> \case ("", c, Msg' 8 PQEncOff "hello") -> c == aId; _ -> False
@@ -2698,7 +2668,9 @@ testWaitForUserNetwork = do
noNetworkDelay a
setUserNetworkInfo a $ UserNetworkInfo UNNone False
networkDelay a 100000
networkDelay a 100000
networkDelay a 150000
networkDelay a 200000
networkDelay a 200000
setUserNetworkInfo a $ UserNetworkInfo UNCellular True
noNetworkDelay a
setUserNetworkInfo a $ UserNetworkInfo UNCellular False
@@ -2708,66 +2680,36 @@ testWaitForUserNetwork = do
(networkDelay a 50000)
noNetworkDelay a
where
aCfg = agentCfg {userNetworkInterval = 100000, userOfflineDelay = 0}
aCfg = agentCfg {userNetworkInterval = RetryInterval {initialInterval = 100000, increaseAfter = 0, maxInterval = 200000}}
testDoNotResetOnlineToOffline :: IO ()
testDoNotResetOnlineToOffline = do
testDoNotResetOfflineInterval :: IO ()
testDoNotResetOfflineInterval = do
a <- getSMPAgentClient' 1 aCfg initAgentServers testDB
noNetworkDelay a
setUserNetworkInfo a $ UserNetworkInfo UNWifi False
networkDelay a 100000
setUserNetworkInfo a $ UserNetworkInfo UNWifi False
setUserNetworkInfo a $ UserNetworkInfo UNWifi True
noNetworkDelay a
setUserNetworkInfo a $ UserNetworkInfo UNWifi False -- ingnored
noNetworkDelay a
threadDelay 100000
setUserNetworkInfo a $ UserNetworkInfo UNWifi False
networkDelay a 100000
networkDelay a 150000
setUserNetworkInfo a $ UserNetworkInfo UNCellular False
networkDelay a 200000
setUserNetworkInfo a $ UserNetworkInfo UNNone False
networkDelay a 100000
setUserNetworkInfo a $ UserNetworkInfo UNWifi True
setUserNetworkInfo a $ UserNetworkInfo UNNone False -- ingnored
noNetworkDelay a
where
aCfg = agentCfg {userNetworkInterval = 100000, userOfflineDelay = 0.1}
testResumeMultipleThreads :: IO ()
testResumeMultipleThreads = do
a <- getSMPAgentClient' 1 aCfg initAgentServers testDB
noNetworkDelay a
setUserNetworkInfo a $ UserNetworkInfo UNNone False
vs <-
replicateM 50000 $ do
v <- newEmptyTMVarIO
void . forkIO $ waitNetwork a >>= atomically . putTMVar v
pure v
threadDelay 1000000
networkDelay a 200000
setUserNetworkInfo a $ UserNetworkInfo UNCellular True
ts <- mapM (atomically . readTMVar) vs
-- print $ minimum ts
-- print $ maximum ts
-- print $ sum ts `div` fromIntegral (length ts)
let average = sum ts `div` fromIntegral (length ts)
average < 3000000 `shouldBe` True
maximum ts < 4000000 `shouldBe` True
noNetworkDelay a
setUserNetworkInfo a $ UserNetworkInfo UNCellular False
networkDelay a 100000
where
aCfg = agentCfg {userOfflineDelay = 0}
aCfg = agentCfg {userNetworkInterval = RetryInterval {initialInterval = 100000, increaseAfter = 0, maxInterval = 200000}}
noNetworkDelay :: AgentClient -> IO ()
noNetworkDelay a = do
d <- waitNetwork a
unless (d < 10000) $ expectationFailure $ "expected no delay, d = " <> show d
noNetworkDelay a = (10000 >) <$> waitNetwork a `shouldReturn` True
networkDelay :: AgentClient -> Int64 -> IO ()
networkDelay a d' = do
d <- waitNetwork a
unless (d' < d && d < d' + 15000) $ expectationFailure $ "expected delay " <> show d' <> ", d = " <> show d
networkDelay a d' = (\d -> d' < d && d < d' + 15000) <$> waitNetwork a `shouldReturn` True
waitNetwork :: AgentClient -> IO Int64
waitNetwork a = do
t <- getCurrentTime
waitForUserNetwork a
waitForUserNetwork a `runReaderT` agentEnv a
t' <- getCurrentTime
pure $ diffToMicroseconds $ diffUTCTime t' t
@@ -2808,16 +2750,3 @@ exchangeGreetingsMsgIds alice bobId aliceMsgId bob aliceId bobMsgId = do
get bob ##> ("", aliceId, SENT bobMsgId')
get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
ackMessage alice bobId aliceMsgId' Nothing
newtype InternalException e = InternalException {unInternalException :: e}
deriving (Eq, Show)
instance Exception e => Exception (InternalException e)
instance Exception e => MonadUnliftIO (ExceptT e IO) where
{-# INLINE withRunInIO #-}
withRunInIO :: ((forall a. ExceptT e IO a -> IO a) -> IO b) -> ExceptT e IO b
withRunInIO inner =
ExceptT . fmap (first unInternalException) . try $
withRunInIO $ \run ->
inner $ run . (either (throwIO . InternalException) pure <=< runExceptT)
+13 -15
View File
@@ -6,6 +6,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module AgentTests.NotificationTests where
@@ -16,6 +17,10 @@ import AgentTests.FunctionalAPITests
createConnection,
exchangeGreetingsMsgId,
get,
withAgent,
withAgentClients2,
withAgentClientsCfgServers2,
withAgentClients3,
joinConnection,
makeConnection,
nGet,
@@ -24,18 +29,13 @@ import AgentTests.FunctionalAPITests
sendMessage,
switchComplete,
testServerMatrix2,
withAgent,
withAgentClients2,
withAgentClients3,
withAgentClientsCfg2,
withAgentClientsCfgServers2,
(##>),
(=##>),
pattern CON,
pattern CONF,
pattern INFO,
pattern Msg,
pattern SENT,
)
import Control.Concurrent (ThreadId, killThread, threadDelay)
import Control.Monad
@@ -55,12 +55,12 @@ import SMPClient (cfg, cfgV7, testPort, testPort2, testStoreLogFile2, withSmpSer
import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMessage)
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)
import Simplex.Messaging.Agent.Protocol hiding (CON, CONF, INFO)
import Simplex.Messaging.Agent.Store.SQLite (getSavedNtfToken)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Notifications.Protocol
import Simplex.Messaging.Notifications.Server.Env (NtfServerConfig (..))
import Simplex.Messaging.Notifications.Protocol
import Simplex.Messaging.Notifications.Server.Push.APNS
import Simplex.Messaging.Notifications.Types (NtfToken (..))
import Simplex.Messaging.Protocol (ErrorType (AUTH), MsgFlags (MsgFlags), NtfServer, ProtocolServer (..), SMPMsgMeta (..), SubscriptionMode (..))
@@ -151,8 +151,7 @@ testNtfMatrix t runTest = do
it "next servers: SMP v7, NTF v2; curr clients: v6/v1" $ runNtfTestCfg t cfgV7 ntfServerCfgV2 agentCfg agentCfg runTest
it "curr servers: SMP v6, NTF v1; curr clients: v6/v1" $ runNtfTestCfg t cfg ntfServerCfg agentCfg agentCfg runTest
skip "this case cannot be supported - see RFC" $
it "servers: SMP v6, NTF v1; clients: v7/v2 (not supported)" $
runNtfTestCfg t cfg ntfServerCfg agentCfgV7 agentCfgV7 runTest
it "servers: SMP v6, NTF v1; clients: v7/v2 (not supported)" $ runNtfTestCfg t cfg ntfServerCfg agentCfgV7 agentCfgV7 runTest
-- servers can be migrated in any order
it "servers: next SMP v7, curr NTF v1; curr clients: v6/v1" $ runNtfTestCfg t cfgV7 ntfServerCfg agentCfg agentCfg runTest
it "servers: curr SMP v6, next NTF v2; curr clients: v6/v1" $ runNtfTestCfg t cfg ntfServerCfgV2 agentCfg agentCfg runTest
@@ -181,7 +180,7 @@ testNotificationToken APNSMockServer {apnsQ} = do
NTActive <- checkNtfToken a tkn
deleteNtfToken a tkn
-- agent deleted this token
Left (CMD PROHIBITED _) <- tryE $ checkNtfToken a tkn
Left (CMD PROHIBITED) <- tryE $ checkNtfToken a tkn
pure ()
(.->) :: J.Value -> J.Key -> ExceptT AgentErrorType IO ByteString
@@ -244,7 +243,7 @@ testNtfTokenSecondRegistration APNSMockServer {apnsQ} =
-- now the second token registration is verified
verifyNtfToken a' tkn nonce' verification'
-- the first registration is removed
Left (NTF _ AUTH) <- tryE $ checkNtfToken a tkn
Left (NTF AUTH) <- tryE $ checkNtfToken a tkn
-- and the second is active
NTActive <- checkNtfToken a' tkn
pure ()
@@ -259,7 +258,7 @@ testNtfTokenServerRestart t APNSMockServer {apnsQ} = do
atomically $ readTBQueue apnsQ
liftIO $ sendApnsResponse APNSRespOk
pure ntfData
-- the new agent is created as otherwise when running the tests in CI the old agent was keeping the connection to the server
-- the new agent is created as otherwise when running the tests in CI the old agent was keeping the connection to the server
threadDelay 1000000
withAgent 2 agentCfg initAgentServers testDB $ \a' ->
-- server stopped before token is verified, so now the attempt to verify it will return AUTH error but re-register token,
@@ -267,7 +266,7 @@ testNtfTokenServerRestart t APNSMockServer {apnsQ} = do
withNtfServer t . runRight_ $ do
verification <- ntfData .-> "verification"
nonce <- C.cbNonce <$> ntfData .-> "nonce"
Left (NTF _ AUTH) <- tryE $ verifyNtfToken a' tkn nonce verification
Left (NTF AUTH) <- tryE $ verifyNtfToken a' tkn nonce verification
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}, sendApnsResponse = sendApnsResponse'} <-
atomically $ readTBQueue apnsQ
verification' <- ntfData' .-> "verification"
@@ -334,7 +333,6 @@ testNtfTokenChangeServers t APNSMockServer {apnsQ} =
getTestNtfTokenPort a >>= \port2 -> liftIO $ port2 `shouldBe` ntfTestPort2 -- but the token got updated
killThread ntf
withNtfServerOn t ntfTestPort2 $ runRight_ $ do
liftIO $ threadDelay 1000000 -- for notification server to reconnect
tkn <- registerTestToken a "qwer" NMInstant apnsQ
checkNtfToken a tkn >>= \r -> liftIO $ r `shouldBe` NTActive
@@ -374,7 +372,7 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} alice@Agen
pure (bobId, aliceId, nonce, message)
-- alice client already has subscription for the connection
Left (CMD PROHIBITED _) <- runExceptT $ getNotificationMessage alice nonce message
Left (CMD PROHIBITED) <- runExceptT $ getNotificationMessage alice nonce message
-- aliceNtf client doesn't have subscription and is allowed to get notification message
withAgent 3 aliceCfg initAgentServers testDB $ \aliceNtf -> runRight_ $ do
+8 -9
View File
@@ -5,8 +5,8 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
@@ -17,7 +17,6 @@ module AgentTests.SQLiteTests (storeTests) where
import AgentTests.EqInstances ()
import Control.Concurrent.Async (concurrently_)
import Control.Concurrent.MVar
import Control.Concurrent.STM
import Control.Exception (SomeException)
import Control.Monad (replicateM_)
@@ -46,9 +45,9 @@ import Simplex.Messaging.Agent.Store.SQLite.Common (withTransaction')
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile (..))
import Simplex.Messaging.Crypto.Ratchet (InitialKeys (..), pattern PQSupportOn)
import qualified Simplex.Messaging.Crypto.Ratchet as CR
import Simplex.Messaging.Crypto.File (CryptoFile (..))
import Simplex.Messaging.Encoding.String (StrEncoding (..))
import Simplex.Messaging.Protocol (SubscriptionMode (..), pattern VersionSMPC)
import qualified Simplex.Messaging.Protocol as SMP
@@ -89,7 +88,7 @@ removeStore db = do
removeFile $ dbFilePath db
where
close :: SQLiteStore -> IO ()
close st = mapM_ DB.close =<< tryTakeMVar (dbConnection st)
close st = mapM_ DB.close =<< atomically (tryTakeTMVar $ dbConnection st)
storeTests :: Spec
storeTests = do
@@ -709,15 +708,15 @@ testGetNextRcvChunkToDownload st = do
withTransaction st $ \db -> do
Right Nothing <- getNextRcvChunkToDownload db xftpServer1 86400
Right _ <- createRcvFile db g 1 rcvFileDescr1 "filepath" "filepath" (CryptoFile "filepath" Nothing) True
Right _ <- createRcvFile db g 1 rcvFileDescr1 "filepath" "filepath" (CryptoFile "filepath" Nothing)
DB.execute_ db "UPDATE rcv_file_chunk_replicas SET replica_key = cast('bad' as blob) WHERE rcv_file_chunk_replica_id = 1"
Right fId2 <- createRcvFile db g 1 rcvFileDescr1 "filepath" "filepath" (CryptoFile "filepath" Nothing) True
Right fId2 <- createRcvFile db g 1 rcvFileDescr1 "filepath" "filepath" (CryptoFile "filepath" Nothing)
Left e <- getNextRcvChunkToDownload db xftpServer1 86400
show e `shouldContain` "ConversionFailed"
DB.query_ db "SELECT rcv_file_id FROM rcv_files WHERE failed = 1" `shouldReturn` [Only (1 :: Int)]
Right (Just (RcvFileChunk {rcvFileEntityId}, _)) <- getNextRcvChunkToDownload db xftpServer1 86400
Right (Just RcvFileChunk {rcvFileEntityId}) <- getNextRcvChunkToDownload db xftpServer1 86400
rcvFileEntityId `shouldBe` fId2
testGetNextRcvFileToDecrypt :: SQLiteStore -> Expectation
@@ -726,10 +725,10 @@ testGetNextRcvFileToDecrypt st = do
withTransaction st $ \db -> do
Right Nothing <- getNextRcvFileToDecrypt db 86400
Right _ <- createRcvFile db g 1 rcvFileDescr1 "filepath" "filepath" (CryptoFile "filepath" Nothing) True
Right _ <- createRcvFile db g 1 rcvFileDescr1 "filepath" "filepath" (CryptoFile "filepath" Nothing)
DB.execute_ db "UPDATE rcv_files SET status = 'received' WHERE rcv_file_id = 1"
DB.execute_ db "UPDATE rcv_file_chunk_replicas SET replica_key = cast('bad' as blob) WHERE rcv_file_chunk_replica_id = 1"
Right fId2 <- createRcvFile db g 1 rcvFileDescr1 "filepath" "filepath" (CryptoFile "filepath" Nothing) True
Right fId2 <- createRcvFile db g 1 rcvFileDescr1 "filepath" "filepath" (CryptoFile "filepath" Nothing)
DB.execute_ db "UPDATE rcv_files SET status = 'received' WHERE rcv_file_id = 2"
Left e <- getNextRcvFileToDecrypt db 86400
-1
View File
@@ -325,7 +325,6 @@ testTHandleParams v sessionId =
{ sessionId,
blockSize = smpBlockSize,
thVersion = v,
thServerVRange = supportedServerSMPRelayVRange,
thAuth = Nothing,
implySessId = v >= authCmdsSMPVersion,
batch = True
+14 -29
View File
@@ -6,15 +6,17 @@
module CoreTests.ProtocolErrorTests where
import qualified Data.ByteString.Char8 as B
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import GHC.Generics (Generic)
import Generic.Random (genericArbitraryU)
import Simplex.FileTransfer.Transport (XFTPErrorType (..))
import Simplex.Messaging.Agent.Protocol
import qualified Simplex.Messaging.Agent.Protocol as Agent
import Simplex.Messaging.Client (ProxyClientError (..))
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol (CommandError (..), ErrorType (..))
import Simplex.Messaging.Protocol (CommandError (..), ErrorType (..), ProxyError (..))
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Transport (HandshakeError (..), TransportError (..))
import Simplex.RemoteControl.Types (RCErrorType (..))
@@ -25,34 +27,21 @@ import Test.QuickCheck
protocolErrorTests :: Spec
protocolErrorTests = modifyMaxSuccess (const 1000) $ do
describe "errors parsing / serializing" $ do
it "should parse SMP protocol errors" . property . forAll possibleErrorType $ \err ->
it "should parse SMP protocol errors" . property $ \(err :: ErrorType) ->
smpDecode (smpEncode err) == Right err
it "should parse SMP agent errors" . property . forAll possibleAgentErrorType $ \err ->
it "should parse SMP agent errors" . property . forAll possible $ \err ->
strDecode (strEncode err) == Right err
where
possibleErrorType :: Gen ErrorType
possibleErrorType = arbitrary >>= \e -> if skipErrorType e then discard else pure e
possibleAgentErrorType :: Gen AgentErrorType
possibleAgentErrorType =
possible :: Gen AgentErrorType
possible =
arbitrary >>= \case
BROKER srv (Agent.RESPONSE e) | hasSpaces srv || hasSpaces e -> discard
BROKER srv _ | hasSpaces srv -> discard
SMP srv e | hasSpaces srv || skipErrorType e -> discard
NTF srv e | hasSpaces srv || skipErrorType e -> discard
XFTP srv _ | hasSpaces srv -> discard
Agent.PROXY pxy srv _ | hasSpaces pxy || hasSpaces srv -> discard
Agent.PROXY _ _ (ProxyProtocolError e) | skipErrorType e -> discard
Agent.PROXY _ _ (ProxyUnexpectedResponse e) | hasUnicode e -> discard
Agent.PROXY _ _ (ProxyResponseError e) | skipErrorType e -> discard
SMP (PROXY (SMP.UNEXPECTED s)) | hasUnicode s -> discard
NTF (PROXY (SMP.UNEXPECTED s)) | hasUnicode s -> discard
ok -> pure ok
hasSpaces :: String -> Bool
hasSpaces = any (== ' ')
hasUnicode :: String -> Bool
hasSpaces s = ' ' `B.elem` encodeUtf8 (T.pack s)
hasUnicode = any (>= '\255')
skipErrorType = \case
SMP.PROXY (SMP.PROTOCOL e) -> skipErrorType e
SMP.PROXY (SMP.BROKER (UNEXPECTED s)) -> hasUnicode s
SMP.PROXY (SMP.BROKER (RESPONSE s)) -> hasUnicode s
_ -> False
deriving instance Generic AgentErrorType
@@ -60,8 +49,6 @@ deriving instance Generic CommandErrorType
deriving instance Generic ConnectionErrorType
deriving instance Generic ProxyClientError
deriving instance Generic BrokerErrorType
deriving instance Generic SMPAgentError
@@ -72,7 +59,7 @@ deriving instance Generic ErrorType
deriving instance Generic CommandError
deriving instance Generic SMP.ProxyError
deriving instance Generic ProxyError
deriving instance Generic TransportError
@@ -88,8 +75,6 @@ instance Arbitrary CommandErrorType where arbitrary = genericArbitraryU
instance Arbitrary ConnectionErrorType where arbitrary = genericArbitraryU
instance Arbitrary ProxyClientError where arbitrary = genericArbitraryU
instance Arbitrary BrokerErrorType where arbitrary = genericArbitraryU
instance Arbitrary SMPAgentError where arbitrary = genericArbitraryU
@@ -100,7 +85,7 @@ instance Arbitrary ErrorType where arbitrary = genericArbitraryU
instance Arbitrary CommandError where arbitrary = genericArbitraryU
instance Arbitrary SMP.ProxyError where arbitrary = genericArbitraryU
instance Arbitrary ProxyError where arbitrary = genericArbitraryU
instance Arbitrary TransportError where arbitrary = genericArbitraryU
-50
View File
@@ -22,13 +22,10 @@ tRcvQueuesTests = do
describe "connection API" $ do
it "hasConn" hasConnTest
it "hasConn, batch add" hasConnTestBatch
it "hasConn, batch idempotent" batchIdempotentTest
it "deleteConn" deleteConnTest
describe "session API" $ do
it "getSessQueues" getSessQueuesTest
it "getDelSessQueues" getDelSessQueuesTest
describe "queue transfer" $ do
it "getDelSessQueues-batchAddQueues preserves total length" removeSubsTest
checkDataInvariant :: RQ.TRcvQueues -> IO Bool
checkDataInvariant trq = atomically $ do
@@ -65,19 +62,6 @@ hasConnTestBatch = do
atomically (RQ.hasConn "c3" trq) `shouldReturn` True
atomically (RQ.hasConn "nope" trq) `shouldReturn` False
batchIdempotentTest :: IO ()
batchIdempotentTest = do
trq <- atomically RQ.empty
let qs = [dummyRQ 0 "smp://1234-w==@alpha" "c1", dummyRQ 0 "smp://1234-w==@alpha" "c2", dummyRQ 0 "smp://1234-w==@beta" "c3"]
atomically $ RQ.batchAddQueues trq qs
checkDataInvariant trq `shouldReturn` True
qs' <- readTVarIO $ RQ.getRcvQueues trq
cs' <- readTVarIO $ RQ.getConnections trq
atomically $ RQ.batchAddQueues trq qs
checkDataInvariant trq `shouldReturn` True
readTVarIO (RQ.getRcvQueues trq) `shouldReturn` qs'
fmap L.nub <$> readTVarIO (RQ.getConnections trq) `shouldReturn`cs' -- connections get duplicated, but that doesn't appear to affect anybody
deleteConnTest :: IO ()
deleteConnTest = do
trq <- atomically RQ.empty
@@ -137,40 +121,6 @@ getDelSessQueuesTest = do
atomically (RQ.hasConn "c3" trq) `shouldReturn` True
atomically (RQ.hasConn "c4" trq) `shouldReturn` True
removeSubsTest :: IO ()
removeSubsTest = do
aq <- atomically RQ.empty
let qs =
[ dummyRQ 0 "smp://1234-w==@alpha" "c1",
dummyRQ 0 "smp://1234-w==@alpha" "c2",
dummyRQ 0 "smp://1234-w==@beta" "c3",
dummyRQ 1 "smp://1234-w==@beta" "c4"
]
atomically $ RQ.batchAddQueues aq qs
pq <- atomically RQ.empty
atomically (totalSize aq pq) `shouldReturn` (4, 4)
atomically $ RQ.getDelSessQueues (0, "smp://1234-w==@alpha", Nothing) aq >>= RQ.batchAddQueues pq . fst
atomically (totalSize aq pq) `shouldReturn` (4, 4)
atomically $ RQ.getDelSessQueues (0, "smp://1234-w==@beta", Just "non-existent") aq >>= RQ.batchAddQueues pq . fst
atomically (totalSize aq pq) `shouldReturn` (4, 4)
atomically $ RQ.getDelSessQueues (0, "smp://1234-w==@localhost", Nothing) aq >>= RQ.batchAddQueues pq . fst
atomically (totalSize aq pq) `shouldReturn` (4, 4)
atomically $ RQ.getDelSessQueues (0, "smp://1234-w==@beta", Just "c3") aq >>= RQ.batchAddQueues pq . fst
atomically (totalSize aq pq) `shouldReturn` (4, 4)
totalSize :: RQ.TRcvQueues -> RQ.TRcvQueues -> STM (Int, Int)
totalSize a b = do
qsizeA <- M.size <$> readTVar (RQ.getRcvQueues a)
qsizeB <- M.size <$> readTVar (RQ.getRcvQueues b)
csizeA <- M.size <$> readTVar (RQ.getConnections a)
csizeB <- M.size <$> readTVar (RQ.getConnections b)
pure (qsizeA + qsizeB, csizeA + csizeB)
dummyRQ :: UserId -> SMPServer -> ConnId -> RcvQueue
dummyRQ userId server connId =
RcvQueue
+1 -1
View File
@@ -2,11 +2,11 @@
module CoreTests.UtilTests where
import AgentTests.FunctionalAPITests ()
import Control.Exception (Exception, SomeException, throwIO)
import Control.Monad.Except
import Control.Monad.IO.Class
import Data.IORef
import Simplex.Messaging.Client.Agent ()
import Simplex.Messaging.Util
import Test.Hspec
import qualified UnliftIO.Exception as UE
-36
View File
@@ -6,7 +6,6 @@
module CoreTests.VersionRangeTests where
import Data.Word (Word16)
import GHC.Generics (Generic)
import Generic.Random (genericArbitraryU)
import Simplex.Messaging.Version
@@ -39,28 +38,6 @@ versionRangeTests = modifyMaxSuccess (const 1000) $ do
(vr 1 3, vr 2 3) `compatible` Just (Version 3)
(vr 1 3, vr 2 4) `compatible` Just (Version 3)
(vr 1 2, vr 3 4) `compatible` Nothing
it "should choose mutually compatible version range (range intersection)" $ do
(vr 1 1, vr 1 1) `compatibleVR` Just (vr 1 1)
(vr 1 1, vr 1 2) `compatibleVR` Just (vr 1 1)
(vr 1 2, vr 1 2) `compatibleVR` Just (vr 1 2)
(vr 1 2, vr 2 3) `compatibleVR` Just (vr 2 2)
(vr 1 3, vr 2 3) `compatibleVR` Just (vr 2 3)
(vr 1 3, vr 2 4) `compatibleVR` Just (vr 2 3)
(vr 1 2, vr 3 4) `compatibleVR` Nothing
it "should choose compatible version range with changed max version (capped range)" $ do
(vr 1 1, 1) `compatibleVR'` Just (vr 1 1)
(vr 1 1, 2) `compatibleVR'` Nothing
(vr 1 2, 2) `compatibleVR'` Just (vr 1 2)
(vr 1 2, 3) `compatibleVR'` Nothing
(vr 1 3, 2) `compatibleVR'` Just (vr 1 2)
(vr 1 3, 3) `compatibleVR'` Just (vr 1 3)
(vr 1 3, 4) `compatibleVR'` Nothing
(vr 2 3, 1) `compatibleVR'` Nothing
(vr 2 3, 2) `compatibleVR'` Just (vr 2 2)
(vr 2 3, 3) `compatibleVR'` Just (vr 2 3)
(vr 2 4, 1) `compatibleVR'` Nothing
(vr 2 4, 3) `compatibleVR'` Just (vr 2 3)
(vr 2 4, 4) `compatibleVR'` Just (vr 2 4)
it "should check if version is compatible" $ do
isCompatible @T (Version 1) (vr 1 2) `shouldBe` True
isCompatible @T (Version 2) (vr 1 2) `shouldBe` True
@@ -86,16 +63,3 @@ versionRangeTests = modifyMaxSuccess (const 1000) $ do
case compatibleVersion vr1 vr2 of
Just (Compatible v') -> Just v' `shouldBe` v
Nothing -> Nothing `shouldBe` v
compatibleVR :: (VersionRange T, VersionRange T) -> Maybe (VersionRange T) -> Expectation
(vr1, vr2) `compatibleVR` vr' = do
(vr1, vr2) `checkCompatibleVR` vr'
(vr2, vr1) `checkCompatibleVR` vr'
(vr1, vr2) `checkCompatibleVR` vr' =
case compatibleVRange vr1 vr2 of
Just (Compatible vr'') -> Just vr'' `shouldBe` vr'
Nothing -> Nothing `shouldBe` vr'
compatibleVR' :: (VersionRange T, Word16) -> Maybe (VersionRange T) -> Expectation
(vr1, v2) `compatibleVR'` vr' =
case compatibleVRange' vr1 (Version v2) of
Just (Compatible vr'') -> Just vr'' `shouldBe` vr'
Nothing -> Nothing `shouldBe` vr'
+2 -7
View File
@@ -36,7 +36,6 @@ import Simplex.Messaging.Encoding
import Simplex.Messaging.Notifications.Protocol (NtfResponse)
import Simplex.Messaging.Notifications.Server (runNtfServerBlocking)
import Simplex.Messaging.Notifications.Server.Env
import qualified Simplex.Messaging.Notifications.Server.Env as Env
import Simplex.Messaging.Notifications.Server.Push.APNS
import Simplex.Messaging.Notifications.Server.Push.APNS.Internal
import Simplex.Messaging.Notifications.Transport
@@ -46,7 +45,6 @@ import Simplex.Messaging.Transport.Client
import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..), http2TLSParams)
import Simplex.Messaging.Transport.HTTP2.Server
import Simplex.Messaging.Transport.Server
import qualified Simplex.Messaging.Transport.Server as Server
import Simplex.Messaging.Version (mkVersionRange)
import Test.Hspec
import UnliftIO.Async
@@ -89,7 +87,7 @@ ntfServerCfg =
clientQSize = 1,
subQSize = 1,
pushQSize = 1,
smpAgentCfg = defaultSMPClientAgentConfig {persistErrorInterval = 0},
smpAgentCfg = defaultSMPClientAgentConfig,
apnsConfig =
defaultAPNSPushClientConfig
{ apnsPort = apnsTestPort,
@@ -115,11 +113,8 @@ ntfServerCfgV2 :: NtfServerConfig
ntfServerCfgV2 =
ntfServerCfg
{ ntfServerVRange = mkVersionRange initialNTFVersion authBatchCmdsNTFVersion,
smpAgentCfg = smpAgentCfg' {smpCfg = (smpCfg smpAgentCfg') {serverVRange = mkVersionRange batchCmdsSMPVersion authCmdsSMPVersion}},
Env.transportConfig = defaultTransportServerConfig {Server.alpn = Just supportedNTFHandshakes}
smpAgentCfg = defaultSMPClientAgentConfig {smpCfg = (smpCfg defaultSMPClientAgentConfig) {serverVRange = mkVersionRange batchCmdsSMPVersion authCmdsSMPVersion}}
}
where
smpAgentCfg' = smpAgentCfg ntfServerCfg
withNtfServerStoreLog :: ATransport -> (ThreadId -> IO a) -> IO a
withNtfServerStoreLog t = withNtfServerCfg ntfServerCfg {storeLogFile = Just ntfTestStoreLogFile, transports = [(ntfTestPort, t)]}
+3 -12
View File
@@ -20,8 +20,7 @@ import qualified Database.SQLite.Simple as SQL
import Network.Socket (ServiceName)
import NtfClient (ntfTestPort)
import SMPClient
( proxyVRange,
serverBracket,
( serverBracket,
testKeyHash,
testPort,
testPort2,
@@ -35,7 +34,7 @@ import Simplex.Messaging.Agent.RetryInterval
import Simplex.Messaging.Agent.Server (runSMPAgentBlocking)
import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), SQLiteStore (dbNew))
import Simplex.Messaging.Agent.Store.SQLite.Common (withTransaction')
import Simplex.Messaging.Client (ProtocolClientConfig (..), SMPProxyFallback, SMPProxyMode, chooseTransportHost, defaultNetworkConfig, defaultSMPClientConfig)
import Simplex.Messaging.Client (ProtocolClientConfig (..), chooseTransportHost, defaultSMPClientConfig, defaultNetworkConfig)
import Simplex.Messaging.Notifications.Client (defaultNTFClientConfig)
import Simplex.Messaging.Parsers (parseAll)
import Simplex.Messaging.Protocol (NtfServer, ProtoServerWithAuth)
@@ -199,10 +198,6 @@ initAgentServers =
initAgentServers2 :: InitialAgentServers
initAgentServers2 = initAgentServers {smp = userServers [noAuthSrv testSMPServer, noAuthSrv testSMPServer2]}
initAgentServersProxy :: SMPProxyMode -> SMPProxyFallback -> InitialAgentServers
initAgentServersProxy smpProxyMode smpProxyFallback =
initAgentServers {netCfg = (netCfg initAgentServers) {smpProxyMode, smpProxyFallback}}
agentCfg :: AgentConfig
agentCfg =
defaultAgentConfig
@@ -212,7 +207,6 @@ agentCfg =
smpCfg = defaultSMPClientConfig {qSize = 1, defaultTransport = (testPort, transport @TLS), networkConfig},
ntfCfg = defaultNTFClientConfig {qSize = 1, defaultTransport = (ntfTestPort, transport @TLS), networkConfig},
reconnectInterval = fastRetryInterval,
persistErrorInterval = 1,
xftpNotifyErrsOnRetry = False,
ntfWorkerDelay = 100,
ntfSMPWorkerDelay = 100,
@@ -221,10 +215,7 @@ agentCfg =
certificateFile = "tests/fixtures/server.crt"
}
where
networkConfig = defaultNetworkConfig {tcpConnectTimeout = 1_000_000, tcpTimeout = 2_000_000}
agentProxyCfg :: AgentConfig
agentProxyCfg = agentCfg {smpCfg = (smpCfg agentCfg) {serverVRange = proxyVRange}}
networkConfig = defaultNetworkConfig {tcpConnectTimeout = 3_000_000, tcpTimeout = 2_000_000}
fastRetryInterval :: RetryInterval
fastRetryInterval = defaultReconnectInterval {initialInterval = 50_000}
+7 -26
View File
@@ -25,10 +25,8 @@ import Simplex.Messaging.Server (runSMPServerBlocking)
import Simplex.Messaging.Server.Env.STM
import Simplex.Messaging.Transport
import Simplex.Messaging.Transport.Client
import qualified Simplex.Messaging.Transport.Client as Client
import Simplex.Messaging.Transport.Server
import qualified Simplex.Messaging.Transport.Server as Server
import Simplex.Messaging.Version
import Simplex.Messaging.Version (mkVersionRange)
import System.Environment (lookupEnv)
import System.Info (os)
import Test.Hspec
@@ -80,15 +78,10 @@ testSMPClientVR vr client = do
testSMPClient_ :: Transport c => TransportHost -> ServiceName -> VersionRangeSMP -> (THandleSMP c 'TClient -> IO a) -> IO a
testSMPClient_ host port vr client = do
let tcConfig = defaultTransportClientConfig {Client.alpn = clientALPN}
runTransportClient tcConfig Nothing host port (Just testKeyHash) $ \h ->
runTransportClient defaultTransportClientConfig Nothing host port (Just testKeyHash) $ \h ->
runExceptT (smpClientHandshake h Nothing testKeyHash vr) >>= \case
Right th -> client th
Left e -> error $ show e
where
clientALPN
| authCmdsSMPVersion `isCompatible` vr = Just supportedSMPHandshakes
| otherwise = Nothing
cfg :: ServerConfig
cfg =
@@ -116,31 +109,22 @@ cfg =
privateKeyFile = "tests/fixtures/server.key",
certificateFile = "tests/fixtures/server.crt",
smpServerVRange = supportedServerSMPRelayVRange,
transportConfig = defaultTransportServerConfig {Server.alpn = Just supportedSMPHandshakes},
transportConfig = defaultTransportServerConfig,
controlPort = Nothing,
smpAgentCfg = defaultSMPClientAgentConfig {persistErrorInterval = 1}, -- seconds
allowSMPProxy = False,
serverClientConcurrency = 2
smpAgentCfg = defaultSMPClientAgentConfig,
allowSMPProxy = False
}
cfgV7 :: ServerConfig
cfgV7 = cfg {smpServerVRange = mkVersionRange batchCmdsSMPVersion authCmdsSMPVersion}
cfgV8 :: ServerConfig
cfgV8 = cfg {smpServerVRange = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion}
proxyCfg :: ServerConfig
proxyCfg =
cfgV7
{ allowSMPProxy = True,
{ allowSMPProxy = True,
smpServerVRange = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion,
smpAgentCfg = smpAgentCfg' {smpCfg = (smpCfg smpAgentCfg') {serverVRange = proxyVRange, agreeSecret = True}}
smpAgentCfg = defaultSMPClientAgentConfig {smpCfg = (smpCfg defaultSMPClientAgentConfig) {serverVRange = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion, agreeSecret = True}}
}
where
smpAgentCfg' = smpAgentCfg cfgV7
proxyVRange :: VersionRangeSMP
proxyVRange = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion
withSmpServerStoreMsgLogOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
withSmpServerStoreMsgLogOn t = withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile, serverStatsBackupFile = Just testServerStatsBackupFile}
@@ -179,9 +163,6 @@ withSmpServer t = withSmpServerOn t testPort
withSmpServerV7 :: HasCallStack => ATransport -> IO a -> IO a
withSmpServerV7 t = withSmpServerConfigOn t cfgV7 testPort . const
withSmpServerProxy :: HasCallStack => ATransport -> IO a -> IO a
withSmpServerProxy t = withSmpServerConfigOn t proxyCfg testPort . const
runSmpTest :: forall c a. (HasCallStack, Transport c) => (HasCallStack => THandleSMP c 'TClient -> IO a) -> IO a
runSmpTest test = withSmpServer (transport @c) $ testSMPClient test
+76 -256
View File
@@ -1,45 +1,29 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
module SMPProxyTests where
import AgentTests.FunctionalAPITests
import Control.Logger.Simple
import Control.Monad (forM, forM_, forever)
import Control.Monad.Trans.Except (ExceptT, runExceptT)
import AgentTests.FunctionalAPITests (runRight_)
import Data.ByteString.Char8 (ByteString)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as L
import SMPAgentClient
import SMPAgentClient (testSMPServer, testSMPServer2)
import SMPClient
import qualified SMPClient as SMP
import ServerTests (decryptMsgV3, sendRecv)
import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMessage)
import qualified Simplex.Messaging.Agent as A
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers (..))
import Simplex.Messaging.Agent.Protocol hiding (CON, CONF, INFO, REQ)
import qualified Simplex.Messaging.Agent.Protocol as A
import Simplex.Messaging.Client
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.Ratchet (pattern PQSupportOn)
import qualified Simplex.Messaging.Crypto.Ratchet as CR
import Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Protocol
import Simplex.Messaging.Server.Env.STM (ServerConfig (..))
import Simplex.Messaging.Transport
import Simplex.Messaging.Util (bshow, tshow)
import Simplex.Messaging.Version (mkVersionRange)
import System.FilePath (splitExtensions)
import Test.Hspec
import UnliftIO
import Util
smpProxyTests :: Spec
smpProxyTests = do
@@ -53,265 +37,101 @@ smpProxyTests = do
xit "no SMP service at host/port" todo
xit "bad SMP fingerprint" todo
xit "batching proxy requests" todo
describe "deliver message via SMP proxy" $ do
let srv1 = SMPServer testHost testPort testKeyHash
srv2 = SMPServer testHost testPort2 testKeyHash
describe "client API" $ do
let maxLen = maxMessageLength sendingProxySMPVersion
describe "one server" $ do
it "deliver via proxy" . oneServer $ do
deliverMessageViaProxy srv1 srv1 C.SEd448 "hello 1" "hello 2"
describe "two servers" $ do
let proxyServ = srv1
relayServ = srv2
(msg1, msg2) <- runIO $ do
g <- C.newRandom
atomically $ (,) <$> C.randomBytes maxLen g <*> C.randomBytes maxLen g
it "deliver via proxy" . twoServersFirstProxy $
describe "forwarding requests" $ do
describe "deliver message via SMP proxy" $ do
it "same server" $
withSmpServerConfigOn (transport @TLS) proxyCfg testPort $ \_ -> do
let proxyServ = SMPServer SMP.testHost SMP.testPort SMP.testKeyHash
let relayServ = proxyServ
deliverMessageViaProxy proxyServ relayServ C.SEd448 "hello 1" "hello 2"
it "max message size, Ed448 keys" . twoServersFirstProxy $
deliverMessageViaProxy proxyServ relayServ C.SEd448 msg1 msg2
it "max message size, Ed25519 keys" . twoServersFirstProxy $
deliverMessageViaProxy proxyServ relayServ C.SEd25519 msg1 msg2
it "max message size, X25519 keys" . twoServersFirstProxy $
deliverMessageViaProxy proxyServ relayServ C.SX25519 msg1 msg2
describe "stress test 1k" $ do
let deliver n = deliverMessagesViaProxy srv1 srv2 C.SEd448 [] (map bshow [1 :: Int .. n])
it "1x1000" . twoServersFirstProxy $ deliver 1000
it "5x200" . twoServersFirstProxy $ 5 `inParrallel` deliver 200
it "10x100" . twoServersFirstProxy $ 10 `inParrallel` deliver 100
xdescribe "stress test 10k" $ do
let deliver n = deliverMessagesViaProxy srv1 srv2 C.SEd448 [] (map bshow [1 :: Int .. n])
it "1x10000" . twoServersFirstProxy $ deliver 10000
it "5x2000" . twoServersFirstProxy $ 5 `inParrallel` deliver 2000
it "10x1000" . twoServersFirstProxy $ 10 `inParrallel` deliver 1000
it "100x100 N1" . twoServersFirstProxy $ withNumCapabilities 1 $ 100 `inParrallel` deliver 100
it "100x100 N4 C1" . twoServersNoConc $ withNumCapabilities 4 $ 100 `inParrallel` deliver 100
it "100x100 N4 C2" . twoServersFirstProxy $ withNumCapabilities 4 $ 100 `inParrallel` deliver 100
it "100x100 N4 C16" . twoServersMoreConc $ withNumCapabilities 4 $ 100 `inParrallel` deliver 100
it "100x100 N" . twoServersFirstProxy $ withNCPUCapabilities $ 100 `inParrallel` deliver 100
it "500x20" . twoServersFirstProxy $ 500 `inParrallel` deliver 20
describe "agent API" $ do
describe "one server" $ do
it "always via proxy" . oneServer $
agentDeliverMessageViaProxy ([srv1], SPMAlways, True) ([srv1], SPMAlways, True) C.SEd448 "hello 1" "hello 2"
it "without proxy" . oneServer $
agentDeliverMessageViaProxy ([srv1], SPMNever, False) ([srv1], SPMNever, False) C.SEd448 "hello 1" "hello 2"
describe "two servers" $ do
it "always via proxy" . twoServers $
agentDeliverMessageViaProxy ([srv1], SPMAlways, True) ([srv2], SPMAlways, True) C.SEd448 "hello 1" "hello 2"
it "both via proxy" . twoServers $
agentDeliverMessageViaProxy ([srv1], SPMUnknown, True) ([srv2], SPMUnknown, True) C.SEd448 "hello 1" "hello 2"
it "first via proxy" . twoServers $
agentDeliverMessageViaProxy ([srv1], SPMUnknown, True) ([srv2], SPMNever, False) C.SEd448 "hello 1" "hello 2"
it "without proxy" . twoServers $
agentDeliverMessageViaProxy ([srv1], SPMNever, False) ([srv2], SPMNever, False) C.SEd448 "hello 1" "hello 2"
it "first via proxy for unknown" . twoServers $
agentDeliverMessageViaProxy ([srv1], SPMUnknown, True) ([srv1, srv2], SPMUnknown, False) C.SEd448 "hello 1" "hello 2"
it "without proxy with fallback" . twoServers_ proxyCfg cfgV7 $
agentDeliverMessageViaProxy ([srv1], SPMUnknown, False) ([srv2], SPMUnknown, False) C.SEd448 "hello 1" "hello 2"
it "fails when fallback is prohibited" . twoServers_ proxyCfg cfgV7 $
agentViaProxyVersionError
describe "stress test 1k" $ do
let deliver nAgents nMsgs = agentDeliverMessagesViaProxyConc (replicate nAgents [srv1]) (map bshow [1 :: Int .. nMsgs])
it "2 agents, 250 messages" . oneServer $ deliver 2 250
it "5 agents, 10 pairs, 50 messages, N1" . oneServer . withNumCapabilities 1 $ deliver 5 50
it "5 agents, 10 pairs, 50 messages. N4" . oneServer . withNumCapabilities 4 $ deliver 5 50
xdescribe "stress test 10k" $ do
let deliver nAgents nMsgs = agentDeliverMessagesViaProxyConc (replicate nAgents [srv1]) (map bshow [1 :: Int .. nMsgs])
it "25 agents, 300 pairs, 17 messages" . oneServer . withNumCapabilities 4 $ deliver 25 17
where
oneServer = withSmpServerConfigOn (transport @TLS) proxyCfg {msgQueueQuota = 128} testPort . const
twoServers = twoServers_ proxyCfg proxyCfg
twoServersFirstProxy = twoServers_ proxyCfg cfgV8 {msgQueueQuota = 128}
twoServersMoreConc = twoServers_ proxyCfg {serverClientConcurrency = 128} cfgV8 {msgQueueQuota = 128}
twoServersNoConc = twoServers_ proxyCfg {serverClientConcurrency = 1} cfgV8 {msgQueueQuota = 128}
twoServers_ cfg1 cfg2 runTest =
withSmpServerConfigOn (transport @TLS) cfg1 testPort $ \_ ->
withSmpServerConfigOn (transport @TLS) cfg2 testPort2 $ const runTest
it "different servers" $
withSmpServerConfigOn (transport @TLS) proxyCfg testPort $ \_ ->
withSmpServerConfigOn (transport @TLS) cfgV7 testPort2 $ \_ -> do
let proxyServ = SMPServer SMP.testHost SMP.testPort SMP.testKeyHash
let relayServ = SMPServer SMP.testHost SMP.testPort2 SMP.testKeyHash
deliverMessageViaProxy proxyServ relayServ C.SEd448 "hello 1" "hello 2"
xit "max message size, Ed448 keys" $
withSmpServerConfigOn (transport @TLS) proxyCfg testPort $ \_ ->
withSmpServerConfigOn (transport @TLS) cfgV7 testPort2 $ \_ -> do
g <- C.newRandom
msg <- atomically $ C.randomBytes maxMessageLength g
msg' <- atomically $ C.randomBytes maxMessageLength g
let proxyServ = SMPServer SMP.testHost SMP.testPort SMP.testKeyHash
let relayServ = SMPServer SMP.testHost SMP.testPort2 SMP.testKeyHash
deliverMessageViaProxy proxyServ relayServ C.SEd448 msg msg'
it "max message size, Ed25519 keys" $
withSmpServerConfigOn (transport @TLS) proxyCfg testPort $ \_ ->
withSmpServerConfigOn (transport @TLS) cfgV7 testPort2 $ \_ -> do
g <- C.newRandom
msg <- atomically $ C.randomBytes maxMessageLength g
msg' <- atomically $ C.randomBytes maxMessageLength g
let proxyServ = SMPServer SMP.testHost SMP.testPort SMP.testKeyHash
let relayServ = SMPServer SMP.testHost SMP.testPort2 SMP.testKeyHash
deliverMessageViaProxy proxyServ relayServ C.SEd25519 msg msg'
it "max message size, X25519 keys" $
withSmpServerConfigOn (transport @TLS) proxyCfg testPort $ \_ ->
withSmpServerConfigOn (transport @TLS) cfgV7 testPort2 $ \_ -> do
g <- C.newRandom
msg <- atomically $ C.randomBytes maxMessageLength g
msg' <- atomically $ C.randomBytes maxMessageLength g
let proxyServ = SMPServer SMP.testHost SMP.testPort SMP.testKeyHash
let relayServ = SMPServer SMP.testHost SMP.testPort2 SMP.testKeyHash
deliverMessageViaProxy proxyServ relayServ C.SX25519 msg msg'
xit "sender-proxy-relay-recipient works" todo
xit "similar timing for proxied and direct sends" todo
deliverMessageViaProxy :: (C.AlgorithmI a, C.AuthAlgorithm a) => SMPServer -> SMPServer -> C.SAlgorithm a -> ByteString -> ByteString -> IO ()
deliverMessageViaProxy proxyServ relayServ alg msg msg' = deliverMessagesViaProxy proxyServ relayServ alg [msg] [msg']
deliverMessagesViaProxy :: (C.AlgorithmI a, C.AuthAlgorithm a) => SMPServer -> SMPServer -> C.SAlgorithm a -> [ByteString] -> [ByteString] -> IO ()
deliverMessagesViaProxy proxyServ relayServ alg unsecuredMsgs securedMsgs = do
deliverMessageViaProxy proxyServ relayServ alg msg msg' = do
g <- C.newRandom
-- set up proxy
pc' <- getProtocolClient g (1, proxyServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion} Nothing (\_ -> pure ())
pc <- either (fail . show) pure pc'
Right pc <- getProtocolClient g (1, proxyServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion} Nothing (\_ -> pure ())
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 batchCmdsSMPVersion authCmdsSMPVersion} (Just msgQ) (\_ -> 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
QIK {rcvId, sndId, rcvPublicDhKey = srvDh} <- runExceptT' $ createSMPQueue rc (rPub, rPriv) rdhPub (Just "correct") SMSubscribe
let dec = decryptMsgV3 $ C.dh' srvDh rdhPriv
-- get proxy session
sess <- runExceptT' $ connectSMPProxiedRelay pc relayServ (Just "correct")
-- send via proxy to unsecured queue
forM_ unsecuredMsgs $ \msg -> do
runExceptT' (proxySMPMessage pc sess Nothing sndId noMsgFlags msg) `shouldReturn` Right ()
msgQ <- newTBQueueIO 4
Right rc <- getProtocolClient g (2, relayServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange batchCmdsSMPVersion authCmdsSMPVersion} (Just msgQ) (\_ -> pure ())
runRight_ $ do
-- prepare receiving queue
(rPub, rPriv) <- atomically $ C.generateAuthKeyPair alg g
(rdhPub, rdhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
QIK {rcvId, sndId, rcvPublicDhKey = srvDh} <- createSMPQueue rc (rPub, rPriv) rdhPub (Just "correct") SMSubscribe
let dec = decryptMsgV3 $ C.dh' srvDh rdhPriv
-- get proxy session
(sessId, v, relayKey) <- createSMPProxySession pc relayServ (Just "correct")
-- send via proxy to unsecured queue
proxySMPMessage pc sessId v relayKey Nothing sndId noMsgFlags msg
-- 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
-- send via proxy to secured queue
waitSendRecv
( forM_ securedMsgs $ \msg' ->
runExceptT' (proxySMPMessage pc 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
dec msgId' encBody' `shouldBe` Right msg'
runExceptT' $ ackSMPMessage rc rPriv rcvId msgId'
)
(_tSess, _v, _sid, _ety, MSG RcvMessage {msgId, msgBody = EncRcvMsgBody encBody}) <- atomically $ readTBQueue msgQ
liftIO $ dec msgId encBody `shouldBe` Right msg
ackSMPMessage rc rPriv rcvId msgId
-- secure queue
(sPub, sPriv) <- atomically $ C.generateAuthKeyPair alg g
secureSMPQueue rc rPriv rcvId sPub
-- send via proxy to secured queue
proxySMPMessage pc sessId v relayKey (Just sPriv) sndId noMsgFlags msg'
-- receive 2
(_tSess, _v, _sid, _ety, MSG RcvMessage {msgId = msgId', msgBody = EncRcvMsgBody encBody'}) <- atomically $ readTBQueue msgQ
liftIO $ dec msgId' encBody' `shouldBe` Right msg'
ackSMPMessage rc rPriv rcvId msgId'
agentDeliverMessageViaProxy :: (C.AlgorithmI a, C.AuthAlgorithm a) => (NonEmpty SMPServer, SMPProxyMode, Bool) -> (NonEmpty SMPServer, SMPProxyMode, Bool) -> C.SAlgorithm a -> ByteString -> ByteString -> IO ()
agentDeliverMessageViaProxy aTestCfg@(aSrvs, _, aViaProxy) bTestCfg@(bSrvs, _, bViaProxy) alg msg1 msg2 =
withAgent 1 aCfg (servers aTestCfg) testDB $ \alice ->
withAgent 2 aCfg (servers bTestCfg) testDB2 $ \bob -> runRight_ $ do
(bobId, qInfo) <- A.createConnection alice 1 True SCMInvitation Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe
aliceId <- A.joinConnection bob 1 Nothing True qInfo "bob's connInfo" PQSupportOn SMSubscribe
("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
liftIO $ pqSup' `shouldBe` PQSupportOn
allowConnection alice bobId confId "alice's connInfo"
let pqEnc = CR.PQEncOn
get alice ##> ("", bobId, A.CON pqEnc)
get bob ##> ("", aliceId, A.INFO PQSupportOn "alice's connInfo")
get bob ##> ("", aliceId, A.CON pqEnc)
-- message IDs 1 to 3 (or 1 to 4 in v1) get assigned to control messages, so first MSG is assigned ID 4
let aProxySrv = if aViaProxy then Just $ L.head aSrvs else Nothing
1 <- msgId <$> A.sendMessage alice bobId pqEnc noMsgFlags msg1
get alice ##> ("", bobId, A.SENT (baseId + 1) aProxySrv)
2 <- msgId <$> A.sendMessage alice bobId pqEnc noMsgFlags msg2
get alice ##> ("", bobId, A.SENT (baseId + 2) aProxySrv)
get bob =##> \case ("", c, Msg' _ pq msg1') -> c == aliceId && pq == pqEnc && msg1 == msg1'; _ -> False
ackMessage bob aliceId (baseId + 1) Nothing
get bob =##> \case ("", c, Msg' _ pq msg2') -> c == aliceId && pq == pqEnc && msg2 == msg2'; _ -> False
ackMessage bob aliceId (baseId + 2) Nothing
let bProxySrv = if bViaProxy then Just $ L.head bSrvs else Nothing
3 <- msgId <$> A.sendMessage bob aliceId pqEnc noMsgFlags msg1
get bob ##> ("", aliceId, A.SENT (baseId + 3) bProxySrv)
4 <- msgId <$> A.sendMessage bob aliceId pqEnc noMsgFlags msg2
get bob ##> ("", aliceId, A.SENT (baseId + 4) bProxySrv)
get alice =##> \case ("", c, Msg' _ pq msg1') -> c == bobId && pq == pqEnc && msg1 == msg1'; _ -> False
ackMessage alice bobId (baseId + 3) Nothing
get alice =##> \case ("", c, Msg' _ pq msg2') -> c == bobId && pq == pqEnc && msg2 == msg2'; _ -> False
ackMessage alice bobId (baseId + 4) Nothing
where
baseId = 3
msgId = subtract baseId . fst
aCfg = agentProxyCfg {sndAuthAlg = C.AuthAlg alg, rcvAuthAlg = C.AuthAlg alg}
servers (srvs, smpProxyMode, _) = (initAgentServersProxy smpProxyMode SPFAllow) {smp = userServers $ L.map noAuthSrv srvs}
agentDeliverMessagesViaProxyConc :: [NonEmpty SMPServer] -> [MsgBody] -> IO ()
agentDeliverMessagesViaProxyConc agentServers msgs =
withAgents $ \agents -> do
let pairs = combinations 2 agents
logNote $ "Pairing " <> tshow (length agents) <> " agents into " <> tshow (length pairs) <> " connections"
connections <- forM pairs $ \case
[a, b] -> prePair a b
_ -> error "agents must be paired"
logNote "Running..."
mapConcurrently_ run connections
where
withAgents :: ([AgentClient] -> IO ()) -> IO ()
withAgents action = go [] (zip [1 :: Int ..] agentServers)
where
go agents = \case
[] -> action agents
(aId, aSrvs) : next -> withAgent aId aCfg (servers aSrvs) (dbPrefix <> show aId <> dbSuffix) $ \a -> (a : agents) `go` next
(dbPrefix, dbSuffix) = splitExtensions testDB
-- agent connections have to be set up in advance
-- otherwise the CONF messages would get mixed with MSG
prePair alice bob = do
(bobId, qInfo) <- runExceptT' $ A.createConnection alice 1 True SCMInvitation Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe
aliceId <- runExceptT' $ A.joinConnection bob 1 Nothing True qInfo "bob's connInfo" PQSupportOn SMSubscribe
confId <-
get alice >>= \case
("", _, A.CONF confId pqSup' _ "bob's connInfo") -> do
pqSup' `shouldBe` PQSupportOn
pure confId
huh -> fail $ show huh
runExceptT' $ allowConnection alice bobId confId "alice's connInfo"
get alice ##> ("", bobId, A.CON pqEnc)
get bob ##> ("", aliceId, A.INFO PQSupportOn "alice's connInfo")
get bob ##> ("", aliceId, A.CON pqEnc)
pure (alice, bobId, bob, aliceId)
-- stream messages in opposite directions, while getting deliveries and sending ACKs
run (alice, bobId, bob, aliceId) = do
aSender <- async $ forM_ msgs $ runExceptT' . A.sendMessage alice bobId pqEnc noMsgFlags
bRecipient <-
async $
forever $
get bob >>= \case
("", _, A.SENT _ _) -> pure ()
("", _, Msg' mId' _ _) -> runExceptT' $ ackMessage alice bobId mId' Nothing
huh -> fail (show huh)
bSender <- async $ forM_ msgs $ runExceptT' . A.sendMessage bob aliceId pqEnc noMsgFlags
aRecipient <-
async $
forever $
get alice >>= \case
("", _, A.SENT _ _) -> pure ()
("", _, Msg' mId' _ _) -> runExceptT' $ ackMessage alice bobId mId' Nothing
huh -> fail (show huh)
logDebug "run waiting..."
a2b <- async $ (waitCatch aSender >>= either throwIO pure) `finally` cancel bRecipient -- stopped sender cancels paired recipient loop
b2a <- async $ (waitCatch bSender >>= either throwIO pure) `finally` cancel aRecipient
waitEitherCatch a2b b2a >>= \case
Right (Right ()) -> wait b2a
Right (Left e) -> cancel bSender >> throwIO e
Left (Right ()) -> wait a2b
Left (Left e) -> cancel aSender >> throwIO e
logDebug "run finished"
pqEnc = CR.PQEncOn
aCfg = agentProxyCfg {sndAuthAlg = C.AuthAlg C.SEd448, rcvAuthAlg = C.AuthAlg C.SEd448}
servers srvs = (initAgentServersProxy SPMAlways SPFAllow) {smp = userServers $ L.map noAuthSrv srvs}
agentViaProxyVersionError :: IO ()
agentViaProxyVersionError =
withAgent 1 agentProxyCfg (servers [SMPServer testHost testPort testKeyHash]) testDB $ \alice -> do
Left (A.BROKER _ (TRANSPORT TEVersion)) <-
withAgent 2 agentProxyCfg (servers [SMPServer testHost testPort2 testKeyHash]) testDB2 $ \bob -> runExceptT $ do
(_bobId, qInfo) <- A.createConnection alice 1 True SCMInvitation Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe
A.joinConnection bob 1 Nothing True qInfo "bob's connInfo" PQSupportOn SMSubscribe
pure ()
where
servers srvs = (initAgentServersProxy SPMUnknown SPFProhibit) {smp = userServers $ L.map noAuthSrv srvs}
proxyVRange :: VersionRangeSMP
proxyVRange = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion
testNoProxy :: IO ()
testNoProxy = do
withSmpServerConfigOn (transport @TLS) cfg testPort2 $ \_ -> do
testSMPClient_ "127.0.0.1" testPort2 proxyVRange $ \(th :: THandleSMP TLS 'TClient) -> do
(_, _, (_corrId, _entityId, reply)) <- sendRecv th (Nothing, "0", "", PRXY testSMPServer Nothing)
reply `shouldBe` Right (SMP.ERR $ SMP.PROXY SMP.BASIC_AUTH)
reply `shouldBe` Right (ERR AUTH)
testProxyAuth :: IO ()
testProxyAuth = do
withSmpServerConfigOn (transport @TLS) proxyCfgAuth testPort $ \_ -> do
testSMPClient_ "127.0.0.1" testPort proxyVRange $ \(th :: THandleSMP TLS 'TClient) -> do
(_, _s, (_corrId, _entityId, reply)) <- sendRecv th (Nothing, "0", "", PRXY testSMPServer2 $ Just "wrong")
reply `shouldBe` Right (SMP.ERR $ SMP.PROXY SMP.BASIC_AUTH)
reply `shouldBe` Right (ERR AUTH)
where
proxyCfgAuth = proxyCfg {newQueueBasicAuth = Just "correct"}
todo :: IO ()
todo = do
fail "TODO"
runExceptT' :: Exception e => ExceptT e IO a -> IO a
runExceptT' a = runExceptT a >>= either throwIO pure
waitSendRecv :: IO () -> IO () -> IO ()
waitSendRecv s r = do
s' <- async s
r' <- async r
waitCatch s' >>= either (\e -> cancel r' >> fail (show e)) pure
waitCatch r' >>= either (\e -> cancel s' >> fail (show e)) pure
+5 -5
View File
@@ -183,12 +183,12 @@ testCreateSecure (ATransport t) =
Resp "dabc" _ err5 <- sendRecv s ("", "dabc", sId, _SEND "hello")
(err5, ERR AUTH) #== "rejects unsigned SEND"
let maxAllowedMessage = B.replicate (maxMessageLength currentClientSMPRelayVersion) '-'
let maxAllowedMessage = B.replicate maxMessageLength '-'
Resp "bcda" _ OK <- signSendRecv s sKey ("bcda", sId, _SEND maxAllowedMessage)
Resp "" _ (Msg mId3 msg3) <- tGet1 r
(dec mId3 msg3, Right maxAllowedMessage) #== "delivers message of max size"
let biggerMessage = B.replicate (maxMessageLength currentClientSMPRelayVersion + 1) '-'
let biggerMessage = B.replicate (maxMessageLength + 1) '-'
Resp "bcda" _ (ERR LARGE_MSG) <- signSendRecv s sKey ("bcda", sId, _SEND biggerMessage)
pure ()
@@ -608,7 +608,7 @@ testRestoreMessages at@(ATransport t) =
logSize testStoreLogFile `shouldReturn` 2
logSize testStoreMsgsFile `shouldReturn` 5
logSize testServerStatsBackupFile `shouldReturn` 45
logSize testServerStatsBackupFile `shouldReturn` 20
Right stats1 <- strDecode <$> B.readFile testServerStatsBackupFile
checkStats stats1 [rId] 5 1
@@ -626,7 +626,7 @@ testRestoreMessages at@(ATransport t) =
logSize testStoreLogFile `shouldReturn` 1
-- the last message is not removed because it was not ACK'd
logSize testStoreMsgsFile `shouldReturn` 3
logSize testServerStatsBackupFile `shouldReturn` 45
logSize testServerStatsBackupFile `shouldReturn` 20
Right stats2 <- strDecode <$> B.readFile testServerStatsBackupFile
checkStats stats2 [rId] 5 3
@@ -645,7 +645,7 @@ testRestoreMessages at@(ATransport t) =
logSize testStoreLogFile `shouldReturn` 1
logSize testStoreMsgsFile `shouldReturn` 0
logSize testServerStatsBackupFile `shouldReturn` 45
logSize testServerStatsBackupFile `shouldReturn` 20
Right stats3 <- strDecode <$> B.readFile testServerStatsBackupFile
checkStats stats3 [rId] 5 5
+1 -1
View File
@@ -47,7 +47,7 @@ main = do
$ do
describe "Agent SQLite schema dump" schemaDumpTest
describe "Core tests" $ do
describe "Batching tests" batchingTests
xdescribe "Batching tests" batchingTests
describe "Encoding tests" encodingTests
describe "Protocol error tests" protocolErrorTests
describe "Version range" versionRangeTests
-22
View File
@@ -1,28 +1,6 @@
module Util where
import Control.Monad (replicateM)
import Data.Either (partitionEithers)
import Data.List (tails)
import GHC.Conc (getNumCapabilities, getNumProcessors, setNumCapabilities)
import Test.Hspec
import UnliftIO
skip :: String -> SpecWith a -> SpecWith a
skip = before_ . pendingWith
withNumCapabilities :: Int -> IO a -> IO a
withNumCapabilities new a = getNumCapabilities >>= \old -> bracket_ (setNumCapabilities new) (setNumCapabilities old) a
withNCPUCapabilities :: IO a -> IO a
withNCPUCapabilities a = getNumProcessors >>= \p -> withNumCapabilities p a
inParrallel :: Int -> IO () -> IO ()
inParrallel n action = do
streams <- replicateM n $ async action
(es, rs) <- partitionEithers <$> mapM waitCatch streams
map show es `shouldBe` []
length rs `shouldBe` n
combinations :: Int -> [a] -> [[a]]
combinations 0 _ = [[]]
combinations k xs = [y : ys | y : xs' <- tails xs, ys <- combinations (k - 1) xs']
+17 -22
View File
@@ -54,7 +54,7 @@ xftpAgentTests = around_ testBracket . describe "agent XFTP API" $ do
it "should resume receiving file after restart" testXFTPAgentReceiveRestore
it "should cleanup rcv tmp path after permanent error" testXFTPAgentReceiveCleanup
it "should resume sending file after restart" testXFTPAgentSendRestore
xit "should cleanup snd prefix path after permanent error" testXFTPAgentSendCleanup
it "should cleanup snd prefix path after permanent error" testXFTPAgentSendCleanup
it "should delete sent file on server" testXFTPAgentDelete
it "should resume deleting file after restart" testXFTPAgentDeleteRestore
-- TODO when server is fixed to correctly send AUTH error, this test has to be modified to expect AUTH error
@@ -69,7 +69,7 @@ xftpAgentTests = around_ testBracket . describe "agent XFTP API" $ do
describe "server with password" $ do
let auth = Just "abcd"
srv = ProtoServerWithAuth testXFTPServer2
authErr = Just (ProtocolTestFailure TSCreateFile $ XFTP (B.unpack $ strEncode testXFTPServer2) AUTH)
authErr = Just (ProtocolTestFailure TSCreateFile $ XFTP AUTH)
it "should pass with correct password" $ testXFTPServerTest auth (srv auth) `shouldReturn` Nothing
it "should fail without password" $ testXFTPServerTest auth (srv Nothing) `shouldReturn` authErr
it "should fail with incorrect password" $ testXFTPServerTest auth (srv $ Just "wrong") `shouldReturn` authErr
@@ -179,7 +179,7 @@ testXFTPAgentSendReceiveRedirect = withXFTPServer $ do
withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> do
FileDescriptionURI {description} <- either fail pure $ strDecode uri
rcvFileId <- runRight $ xftpReceiveFile rcp 1 description Nothing True
rcvFileId <- runRight $ xftpReceiveFile rcp 1 description Nothing
rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 65536 totalSize) -- extra RFPROG before switching to real file
rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 4194304 totalSize)
rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 8388608 totalSize)
@@ -223,7 +223,7 @@ testXFTPAgentSendReceiveNoRedirect = withXFTPServer $ do
FileDescriptionURI {description} <- either fail pure $ strDecode uri
let ValidFileDescription FileDescription {redirect} = description
redirect `shouldBe` Nothing
rcvFileId <- runRight $ xftpReceiveFile rcp 1 description Nothing True
rcvFileId <- runRight $ xftpReceiveFile rcp 1 description Nothing
-- NO extra "RFPROG 65k 65k" before switching to real file
rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 4194304 totalSize)
rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 5242880 totalSize)
@@ -311,7 +311,7 @@ testReceive' rcp rfd originalFilePath = testReceiveCF' rcp rfd Nothing originalF
testReceiveCF' :: HasCallStack => AgentClient -> ValidFileDescription 'FRecipient -> Maybe CryptoFileArgs -> FilePath -> Int64 -> ExceptT AgentErrorType IO RcvFileId
testReceiveCF' rcp rfd cfArgs originalFilePath size = do
rfId <- xftpReceiveFile rcp 1 rfd cfArgs True
rfId <- xftpReceiveFile rcp 1 rfd cfArgs
rfProgress rcp size
("", rfId', RFDONE path) <- rfGet rcp
liftIO $ do
@@ -336,7 +336,7 @@ testXFTPAgentReceiveRestore = do
-- receive file - should not succeed with server down
rfId <- withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> runRight $ do
xftpStartWorkers rcp (Just recipientFiles)
rfId <- xftpReceiveFile rcp 1 rfd Nothing True
rfId <- xftpReceiveFile rcp 1 rfd Nothing
liftIO $ timeout 300000 (get rcp) `shouldReturn` Nothing -- wait for worker attempt
pure rfId
@@ -380,7 +380,7 @@ testXFTPAgentReceiveCleanup = withGlobalLogging logCfgNoLogs $ do
-- receive file - should not succeed with server down
rfId <- withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> runRight $ do
xftpStartWorkers rcp (Just recipientFiles)
rfId <- xftpReceiveFile rcp 1 rfd Nothing True
rfId <- xftpReceiveFile rcp 1 rfd Nothing
liftIO $ timeout 300000 (get rcp) `shouldReturn` Nothing -- wait for worker attempt
pure rfId
@@ -392,7 +392,7 @@ testXFTPAgentReceiveCleanup = withGlobalLogging logCfgNoLogs $ do
-- receive file - should fail with AUTH error
withAgent 3 agentCfg initAgentServers testDB2 $ \rcp' -> do
runRight_ $ xftpStartWorkers rcp' (Just recipientFiles)
("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7000" AUTH)) <- rfGet rcp'
("", rfId', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp'
rfId' `shouldBe` rfId
-- tmp path should be removed after permanent error
@@ -471,8 +471,7 @@ testXFTPAgentSendCleanup = withGlobalLogging logCfgNoLogs $ do
-- send file - should fail with AUTH error
withAgent 2 agentCfg initAgentServers testDB $ \sndr' -> do
runRight_ $ xftpStartWorkers sndr' (Just senderFiles)
("", sfId', SFERR (INTERNAL "XFTP {serverAddress = \"xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7000\", xftpErr = AUTH}")) <-
sfGet sndr'
("", sfId', SFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- sfGet sndr'
sfId' `shouldBe` sfId
-- prefix path should be removed after permanent error
@@ -506,9 +505,8 @@ testXFTPAgentDelete = withGlobalLogging logCfgNoLogs $
-- receive file - should fail with AUTH error
withAgent 3 agentCfg initAgentServers testDB2 $ \rcp2 -> runRight $ do
xftpStartWorkers rcp2 (Just recipientFiles)
rfId <- xftpReceiveFile rcp2 1 rfd2 Nothing True
("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7000" AUTH)) <-
rfGet rcp2
rfId <- xftpReceiveFile rcp2 1 rfd2 Nothing
("", rfId', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp2
liftIO $ rfId' `shouldBe` rfId
testXFTPAgentDeleteRestore :: HasCallStack => IO ()
@@ -544,9 +542,8 @@ testXFTPAgentDeleteRestore = withGlobalLogging logCfgNoLogs $ do
-- receive file - should fail with AUTH error
withAgent 5 agentCfg initAgentServers testDB3 $ \rcp2 -> runRight $ do
xftpStartWorkers rcp2 (Just recipientFiles)
rfId <- xftpReceiveFile rcp2 1 rfd2 Nothing True
("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7000" AUTH)) <-
rfGet rcp2
rfId <- xftpReceiveFile rcp2 1 rfd2 Nothing
("", rfId', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp2
liftIO $ rfId' `shouldBe` rfId
testXFTPAgentDeleteOnServer :: HasCallStack => IO ()
@@ -579,9 +576,8 @@ testXFTPAgentDeleteOnServer = withGlobalLogging logCfgNoLogs $
runRight_ . void $ do
-- receive file 1 again
rfId1 <- xftpReceiveFile rcp 1 rfd1_2 Nothing True
("", rfId1', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7000" AUTH)) <-
rfGet rcp
rfId1 <- xftpReceiveFile rcp 1 rfd1_2 Nothing
("", rfId1', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp
liftIO $ rfId1 `shouldBe` rfId1'
-- receive file 2
@@ -612,9 +608,8 @@ testXFTPAgentExpiredOnServer = withGlobalLogging logCfgNoLogs $ do
-- receive file 1 again - should fail with AUTH error
runRight $ do
rfId <- xftpReceiveFile rcp 1 rfd1_2 Nothing True
("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7000" AUTH)) <-
rfGet rcp
rfId <- xftpReceiveFile rcp 1 rfd1_2 Nothing
("", rfId', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp
liftIO $ rfId' `shouldBe` rfId
-- create and send file 2
-2
View File
@@ -14,7 +14,6 @@ import Simplex.FileTransfer.Client
import Simplex.FileTransfer.Description
import Simplex.FileTransfer.Server (runXFTPServerBlocking)
import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defaultFileExpiration, defaultInactiveClientExpiration, supportedXFTPhandshakes)
import Simplex.FileTransfer.Transport (supportedFileServerVRange)
import Simplex.Messaging.Protocol (XFTPServer)
import Simplex.Messaging.Transport (ALPN)
import Simplex.Messaging.Transport.Server
@@ -119,7 +118,6 @@ testXFTPServerConfig_ alpn =
caCertificateFile = "tests/fixtures/ca.crt",
privateKeyFile = "tests/fixtures/server.key",
certificateFile = "tests/fixtures/server.crt",
xftpServerVRange = supportedFileServerVRange,
logStatsInterval = Nothing,
logStatsStartTime = 0,
serverStatsLogFile = "tests/tmp/xftp-server-stats.daily.log",