diff --git a/cabal.project b/cabal.project index 27811ed5e..43afe30ea 100644 --- a/cabal.project +++ b/cabal.project @@ -14,12 +14,6 @@ source-repository-package location: https://github.com/simplex-chat/aeson.git tag: aab7b5a14d6c5ea64c64dcaee418de1bb00dcc2b --- old bs/text compat for 8.10 -source-repository-package - type: git - location: https://github.com/simplex-chat/base64.git - tag: 2d77b6dbcaffc00570a70be8694049f3710e7c94 - source-repository-package type: git location: https://github.com/simplex-chat/hs-socks.git diff --git a/package.yaml b/package.yaml index d6a821fc0..7bdba1b4d 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: simplexmq -version: 5.6.1.0 +version: 5.6.2.1 synopsis: SimpleXMQ message broker description: | This package includes <./docs/Simplex-Messaging-Server.html server>, @@ -31,7 +31,7 @@ dependencies: - async == 2.2.* - attoparsec == 0.14.* - base >= 4.14 && < 5 - - base64 == 1.0.* + - base64-bytestring >= 1.0 && < 1.3 - case-insensitive == 1.2.* - composition == 1.0.* - constraints >= 0.12 && < 0.14 @@ -169,6 +169,11 @@ tests: - silently == 1.2.* - main-tester == 0.2.* - timeit == 2.0.* + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-A64M + - -with-rtsopts=-N1 benchmarks: simplexmq-bench: diff --git a/rfcs/2024-03-28-xftp-version.md b/rfcs/2024-03-28-xftp-version.md new file mode 100644 index 000000000..c46810bb9 --- /dev/null +++ b/rfcs/2024-03-28-xftp-version.md @@ -0,0 +1,120 @@ +# XFTP version agreement + +## Problem + +XFTP is using HTTP2 protocol for encoding requests and responses. +Unlike SMP which has a connection handshake initiated by a server and signals available versions XFTP/HTTP2 is almost entirely client-driven. +So, a client can only try to guess which protocol versions are supported by a server by sending a probe/hello request first. +Determining the endpoint for such a request is an implicit version agreement by itself. +Sending such a request to an old server would error out and requiring it from old clients would break them. + +## Solution + +The TLS layer used by the XFTP server has an optional [ALPN](https://datatracker.ietf.org/doc/html/rfc7301) extension which allows the client and server to negotiate protocols and store the decision in TLS session context. +Unless a client and a server run ALPN-aware versions, they would default to the old "unversioned" protocol. + +TLS extension content is a 65kb chunk, but ALPN standard breaks it into 254b-sized chunks making it unusable for things like key exchange. +The exchange is still client-driven: the client proposes a list, and then a server callback picks one. +In effect, this makes it usable only to signal that some application-level handshake is desired and supported. + +## Implementation + +ALPN can be used to negotiate for any TLS-based protocol, but the description will focus on XFTP. + +TransportClientConfig gets a new `alpn :: Maybe [ALPN]` field so a TLS transport can use it during TLS client creation. +XFTP client sets it to `Just ["xftp/1"]`. +The exact value is not important as long it is in agreement with the server side, but ALPN RFC insists on it being an IANA-registered identifier. + +XFTP server sets `onALPNClientSuggest` TLS hook to pick the protocol when it is provided. +The `tls` library treats SHOULD from the RFC as MUST and does a client-side check that the server responded with one of the client-proposed protocols. + +Upon connection, transport implementation invokes `getNegotiatedProtocol` and stores it in `tlsALPN :: Maybe ALPN` field of transport context. +HTTP2 transport implementation using `withHTTP2` passes negotiated "protocol" to client and server setup callbacks where they store it in their respective wrappers along with TLS session ID. +A server request handler then knows by looking at the `sessionALPN` if it should require a "handshake" request first. +A client code that got HTTP2Client with `sessionALPN` set knows if it has to proceed with handshake request. +A handshake request still has to be initiated by a client, so it should be kept minimal, just enough data to pass the initiative to a server. +A reply to that initial request should contain a server version range for the client to pick. +A client then commits to a version, sending its part of a handshake. + +In the future ALPN negotiation can be dropped in favor of mandatory handshakes or used to signal further handshake schemes. + +The XFTP handshake data types and validation code are cloned from SMP. +Currently they carry version information and session authentication parameters. +Authentication parameters made mandatory as this exchange is guarded by the handshake version. + +### Server side + +`runHTTP2Server` callback used by `xftpServer` should get access to the session state to track handshakes. +A local `TMap SessionId Handshake` is enough to switch request handlers. +The HTTP2 server framework is extended with a way to signal client disconnection to remove sessions from this map. + +The `Handshake` type mimics implicit state in stream based handshakes of SMP and NTF. + +```haskell +data Handshake + = HandshakeSent C.PrivateKeyX25519 -- server private key that will be merged with client public in `THandleAuth` + | HandshakeAccepted THandleAuth VersionXFTP -- session steady state after handshakes +``` + +An HTTP2 request without ALPN is treated as legacy and requires no session entry. +Its `Request`s are marked with `THandleParams {thVersion = VersionXFTP 1, ..}`. + +An HTTP2 request with ALPN requires a session lookup. +- A lack of entry indicates that a client must send an empty request, to which the server replies with its "server handshake" block and stores its private state in `HandshakeSent`. +- If the session entry contains `HandshakeSent`, then the only valid request content is the "client handshake" block. + The server validates client handshake (in the same way as SMP) and stores authentication and version in `HandshakeAccepted` +- If the session entry contains `HandshakeAccepted`, then the server just passes it to `THandleParams`. + +### Client side + +`getXFTPClient` tweaks its transport config to include the ALPN marker and then checks if the client got its `sessionALPN` value. +If there's a value set, it then sends an initial block and checks out the server handshake in response. +After validation, it sends "client handshake" request to finish version negotiation. + +```haskell +let tcConfig = (transportClientConfig xftpNetworkConfig) {alpn = Just ["xftp/1"]} +-- ... +http2Client <- liftEitherError xftpClientError $ getVerifiedHTTP2Client -- ... +thVersion <- case sessionALPN http2Client of + Nothing -> pure $ VersionXFTP 1 + Just proto -> negotiate http2Client proto +``` + +The resulting `XFTPClient` then contains a negotiated version and can be used to send transmissions with a more recent encoding. + +## Block encoding + +### Client Hello (request) + +A request with an empty body and no padding. + +### Server handshake (response) + +SMP-encoded and padded to `xftpBlockSize` (~16kb). + +```haskell +data XFTPServerHandshake = XFTPServerHandshake + { xftpVersionRange :: VersionRangeXFTP, + sessionId :: SessionId, -- validated by client against TLS unique + authPubKey :: + ( X.CertificateChain, -- fingerprint validated by client against pre-shared hash + X.SignedExact X.PubKey -- signature validated by client against server key from TLS + ) + } +``` + +### Client handshake (request) + +SMP-encoded and padded to `xftpBlockSize` (~16kb). + +```haskell +data XFTPClientHandshake = XFTPClientHandshake + { xftpVersion :: VersionXFTP, + keyHash :: C.KeyHash, -- validated by server against its own cert fingerprint + authPubKey :: C.PublicKeyX25519 + } +``` + +### Server confirmation (response) + +A response with an empty body and no padding. diff --git a/simplexmq.cabal b/simplexmq.cabal index 99a61cf3f..2b1ee4477 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -5,7 +5,7 @@ cabal-version: 1.12 -- see: https://github.com/sol/hpack name: simplexmq -version: 5.6.1.0 +version: 5.6.2.1 synopsis: SimpleXMQ message broker description: This package includes <./docs/Simplex-Messaging-Server.html server>, <./docs/Simplex-Messaging-Client.html client> and @@ -119,8 +119,6 @@ library Simplex.Messaging.Crypto.SNTRUP761.Bindings.FFI Simplex.Messaging.Crypto.SNTRUP761.Bindings.RNG Simplex.Messaging.Encoding - Simplex.Messaging.Encoding.Base64 - Simplex.Messaging.Encoding.Base64.URL Simplex.Messaging.Encoding.String Simplex.Messaging.Notifications.Client Simplex.Messaging.Notifications.Protocol @@ -191,7 +189,7 @@ library , async ==2.2.* , attoparsec ==0.14.* , base >=4.14 && <5 - , base64 ==1.0.* + , base64-bytestring >=1.0 && <1.3 , case-insensitive ==1.2.* , composition ==1.0.* , constraints >=0.12 && <0.14 @@ -266,7 +264,7 @@ executable ntf-server , async ==2.2.* , attoparsec ==0.14.* , base >=4.14 && <5 - , base64 ==1.0.* + , base64-bytestring >=1.0 && <1.3 , case-insensitive ==1.2.* , composition ==1.0.* , constraints >=0.12 && <0.14 @@ -342,7 +340,7 @@ executable smp-agent , async ==2.2.* , attoparsec ==0.14.* , base >=4.14 && <5 - , base64 ==1.0.* + , base64-bytestring >=1.0 && <1.3 , case-insensitive ==1.2.* , composition ==1.0.* , constraints >=0.12 && <0.14 @@ -418,7 +416,7 @@ executable smp-server , async ==2.2.* , attoparsec ==0.14.* , base >=4.14 && <5 - , base64 ==1.0.* + , base64-bytestring >=1.0 && <1.3 , case-insensitive ==1.2.* , composition ==1.0.* , constraints >=0.12 && <0.14 @@ -494,7 +492,7 @@ executable xftp , async ==2.2.* , attoparsec ==0.14.* , base >=4.14 && <5 - , base64 ==1.0.* + , base64-bytestring >=1.0 && <1.3 , case-insensitive ==1.2.* , composition ==1.0.* , constraints >=0.12 && <0.14 @@ -570,7 +568,7 @@ executable xftp-server , async ==2.2.* , attoparsec ==0.14.* , base >=4.14 && <5 - , base64 ==1.0.* + , base64-bytestring >=1.0 && <1.3 , case-insensitive ==1.2.* , composition ==1.0.* , constraints >=0.12 && <0.14 @@ -669,7 +667,7 @@ test-suite simplexmq-test tests default-extensions: StrictData - ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -O2 + 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.* @@ -680,7 +678,7 @@ test-suite simplexmq-test , async ==2.2.* , attoparsec ==0.14.* , base >=4.14 && <5 - , base64 ==1.0.* + , base64-bytestring >=1.0 && <1.3 , case-insensitive ==1.2.* , composition ==1.0.* , constraints >=0.12 && <0.14 diff --git a/src/Simplex/FileTransfer/Agent.hs b/src/Simplex/FileTransfer/Agent.hs index bae008e58..d04117942 100644 --- a/src/Simplex/FileTransfer/Agent.hs +++ b/src/Simplex/FileTransfer/Agent.hs @@ -179,7 +179,8 @@ runXFTPRcvWorker c srv Worker {doWork} = 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 -> + withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop -> do + lift $ waitForUserNetwork c downloadFileChunk fc replica `catchAgentError` \e -> retryOnError "XFTP rcv worker" (retryLoop loop e delay') (retryDone e) e where @@ -389,7 +390,7 @@ runXFTPSndPrepareWorker c Worker {doWork} = do let numRecipients' = min numRecipients maxRecipients -- concurrently? -- separate worker to create chunks? record retries and delay on snd_file_chunks? - forM_ (filter (not . chunkCreated) chunks) $ createChunk numRecipients' + forM_ (filter (\SndFileChunk {replicas} -> null replicas) chunks) $ createChunk numRecipients' withStore' c $ \db -> updateSndFileStatus db sndFileId SFSUploading where AgentConfig {xftpMaxRecipientsPerRequest = maxRecipients, messageRetryInterval = ri} = cfg @@ -413,9 +414,6 @@ runXFTPSndPrepareWorker c Worker {doWork} = do let chunkSpecs = prepareChunkSpecs fsEncPath chunkSizes chunkDigests <- liftIO $ mapM getChunkDigest chunkSpecs pure (FileDigest digest, zip chunkSpecs $ coerce chunkDigests) - chunkCreated :: SndFileChunk -> Bool - chunkCreated SndFileChunk {replicas} = - any (\SndFileChunkReplica {replicaStatus} -> replicaStatus == SFRSCreated) replicas createChunk :: Int -> SndFileChunk -> AM () createChunk numRecipients' ch = do atomically $ assertAgentForeground c @@ -425,7 +423,8 @@ runXFTPSndPrepareWorker c Worker {doWork} = do where tryCreate = do usedSrvs <- newTVarIO ([] :: [XFTPServer]) - withRetryInterval (riFast ri) $ \_ loop -> + withRetryInterval (riFast ri) $ \_ loop -> do + lift $ waitForUserNetwork c createWithNextSrv usedSrvs `catchAgentError` \e -> retryOnError "XFTP prepare worker" (retryLoop loop) (throwError e) e where @@ -457,7 +456,8 @@ runXFTPSndWorker c srv Worker {doWork} = do SndFileChunk {sndFileId, sndFileEntityId, filePrefixPath, replicas = []} -> sndWorkerInternalError c sndFileId sndFileEntityId (Just filePrefixPath) "chunk has no replicas" 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 -> + withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop -> do + lift $ waitForUserNetwork c uploadFileChunk cfg fc replica `catchAgentError` \e -> retryOnError "XFTP snd worker" (retryLoop loop e delay') (retryDone e) e where @@ -623,7 +623,8 @@ runXFTPDelWorker c srv Worker {doWork} = do where 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 -> + withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop -> do + lift $ waitForUserNetwork c deleteChunkReplica `catchAgentError` \e -> retryOnError "XFTP del worker" (retryLoop loop e delay') (retryDone e) e where diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs index ea0c351ca..642a3e73b 100644 --- a/src/Simplex/FileTransfer/Client.hs +++ b/src/Simplex/FileTransfer/Client.hs @@ -4,11 +4,14 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} module Simplex.FileTransfer.Client where +import Control.Logger.Simple import Control.Monad import Control.Monad.Except import Crypto.Random (ChaChaDRG) @@ -20,9 +23,10 @@ import Data.Int (Int64) import Data.List.NonEmpty (NonEmpty (..)) import Data.Time (UTCTime) import Data.Word (Word32) +import qualified Data.X509 as X +import qualified Data.X509.Validation as XV import qualified Network.HTTP.Types as N import qualified Network.HTTP2.Client as H -import Simplex.FileTransfer.Description (mb) import Simplex.FileTransfer.Protocol import Simplex.FileTransfer.Transport import Simplex.Messaging.Client @@ -37,6 +41,7 @@ import Simplex.Messaging.Client 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) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol ( BasicAuth, @@ -45,12 +50,13 @@ import Simplex.Messaging.Protocol RecipientId, SenderId, ) -import Simplex.Messaging.Transport (THandleParams (..), supportedParameters) -import Simplex.Messaging.Transport.Client (TransportClientConfig, TransportHost) +import Simplex.Messaging.Transport (HandshakeError (VERSION), THandleAuth (..), THandleParams (..), TransportError (..), 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 (bshow, whenM) +import Simplex.Messaging.Util (bshow, liftEitherWith, liftError', tshow, whenM) +import Simplex.Messaging.Version (compatibleVersion, pattern Compatible) import UnliftIO import UnliftIO.Directory @@ -63,7 +69,7 @@ data XFTPClient = XFTPClient data XFTPClientConfig = XFTPClientConfig { xftpNetworkConfig :: NetworkConfig, - uploadTimeoutPerMb :: Int64 + serverVRange :: VersionRangeXFTP } data XFTPChunkBody = XFTPChunkBody @@ -85,12 +91,12 @@ defaultXFTPClientConfig :: XFTPClientConfig defaultXFTPClientConfig = XFTPClientConfig { xftpNetworkConfig = defaultNetworkConfig, - uploadTimeoutPerMb = 10000000 -- 10 seconds + serverVRange = supportedFileServerVRange } -getXFTPClient :: TransportSession FileResponse -> XFTPClientConfig -> (XFTPClient -> IO ()) -> IO (Either XFTPClientError XFTPClient) -getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {xftpNetworkConfig} disconnected = runExceptT $ do - let tcConfig = transportClientConfig xftpNetworkConfig +getXFTPClient :: TVar ChaChaDRG -> TransportSession FileResponse -> XFTPClientConfig -> (XFTPClient -> IO ()) -> IO (Either XFTPClientError XFTPClient) +getXFTPClient g transportSession@(_, srv, _) config@XFTPClientConfig {xftpNetworkConfig, serverVRange} disconnected = runExceptT $ do + let tcConfig = (transportClientConfig xftpNetworkConfig) {alpn = Just ["xftp/1"]} http2Config = xftpHTTP2Config tcConfig config username = proxyUsername transportSession ProtocolServer _ host port keyHash = srv @@ -98,13 +104,50 @@ getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {xftpNetworkC clientVar <- newTVarIO Nothing let usePort = if null port then "443" else port clientDisconnected = readTVarIO clientVar >>= mapM_ disconnected - http2Client <- withExceptT xftpClientError . ExceptT $ getVerifiedHTTP2Client (Just username) useHost usePort (Just keyHash) Nothing http2Config clientDisconnected - let HTTP2Client {sessionId} = http2Client - thParams = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = currentXFTPVersion, thAuth = Nothing, implySessId = False, batch = True} - c = XFTPClient {http2Client, thParams, transportSession, config} + http2Client <- liftError' xftpClientError $ getVerifiedHTTP2Client (Just username) useHost usePort (Just keyHash) Nothing http2Config clientDisconnected + let HTTP2Client {sessionId, sessionALPN} = http2Client + thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = VersionXFTP 1, thAuth = Nothing, implySessId = False, batch = True} + logDebug $ "Client negotiated handshake protocol: " <> tshow sessionALPN + thParams <- case sessionALPN of + Just "xftp/1" -> xftpClientHandshakeV1 g serverVRange keyHash http2Client thParams0 + Nothing -> pure thParams0 + _ -> throwError $ PCETransportError (TEHandshake VERSION) + let c = XFTPClient {http2Client, thParams, transportSession, config} atomically $ writeTVar clientVar $ Just c pure c +xftpClientHandshakeV1 :: TVar ChaChaDRG -> VersionRangeXFTP -> C.KeyHash -> HTTP2Client -> THandleParamsXFTP -> ExceptT XFTPClientError IO THandleParamsXFTP +xftpClientHandshakeV1 g serverVRange keyHash@(C.KeyHash kh) c@HTTP2Client {sessionId, serverKey} thParams0 = do + shs <- getServerHandshake + (v, sk) <- processServerHandshake shs + (k, pk) <- atomically $ C.generateKeyPair g + sendClientHandshake XFTPClientHandshake {xftpVersion = v, keyHash, authPubKey = k} + pure thParams0 {thAuth = Just THandleAuth {peerPubKey = sk, privKey = pk}, thVersion = v} + where + getServerHandshake = do + let helloReq = H.requestNoBody "POST" "/" [] + HTTP2Response {respBody = HTTP2Body {bodyHead = shsBody}} <- + liftError' (const $ PCEResponseError HANDSHAKE) $ sendRequest c helloReq Nothing + liftHS . smpDecode =<< liftHS (C.unPad shsBody) + processServerHandshake XFTPServerHandshake {xftpVersionRange, sessionId = serverSessId, authPubKey = serverAuth} = do + unless (sessionId == serverSessId) $ throwError $ PCEResponseError SESSION + 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 () + _ -> throwError "bad certificate" + pubKey <- maybe (throwError "bad server key type") (`C.verifyX509` exact) serverKey + C.x509ToPublic (pubKey, []) >>= C.pubKey + sendClientHandshake chs = do + chs' <- liftHS $ C.pad (smpEncode chs) xftpBlockSize + let chsReq = H.requestBuilder "POST" "/" [] $ byteString chs' + HTTP2Response {respBody = HTTP2Body {bodyHead}} <- liftError' (const $ PCEResponseError HANDSHAKE) $ sendRequest c chsReq Nothing + unless (B.null bodyHead) $ throwError $ PCEResponseError HANDSHAKE + liftHS = liftEitherWith (const $ PCEResponseError HANDSHAKE) + closeXFTPClient :: XFTPClient -> IO () closeXFTPClient XFTPClient {http2Client} = closeHTTP2Client http2Client @@ -144,8 +187,8 @@ sendXFTPCommand c@XFTPClient {thParams} pKey fId cmd chunkSpec_ = do sendXFTPTransmission :: XFTPClient -> ByteString -> Maybe XFTPChunkSpec -> ExceptT XFTPClientError IO (FileResponse, HTTP2Body) sendXFTPTransmission XFTPClient {config, thParams, http2Client} t chunkSpec_ = do let req = H.requestStreaming N.methodPost "/" [] streamBody - reqTimeout = (\XFTPChunkSpec {chunkSize} -> chunkTimeout config chunkSize) <$> chunkSpec_ - HTTP2Response {respBody = body@HTTP2Body {bodyHead}} <- withExceptT xftpClientError . ExceptT $ sendRequest http2Client req reqTimeout + reqTimeout = xftpReqTimeout config $ (\XFTPChunkSpec {chunkSize} -> chunkSize) <$> chunkSpec_ + HTTP2Response {respBody = body@HTTP2Body {bodyHead}} <- withExceptT xftpClientError . ExceptT $ sendRequest http2Client req (Just reqTimeout) when (B.length bodyHead /= xftpBlockSize) $ throwError $ PCEResponseError BLOCK -- TODO validate that the file ID is the same as in the request? (_, _, (_, _fId, respOrErr)) <- liftEither . first PCEResponseError $ xftpDecodeTransmission thParams bodyHead @@ -198,15 +241,20 @@ downloadXFTPChunk g c@XFTPClient {config} rpKey fId chunkSpec@XFTPRcvChunkSpec { let t = chunkTimeout config chunkSize ExceptT (sequence <$> (t `timeout` download cbState)) >>= maybe (throwError PCEResponseTimeout) pure where - download cbState = runExceptT $ - withExceptT PCEResponseError $ + download cbState = + runExceptT . withExceptT PCEResponseError $ receiveEncFile chunkPart cbState chunkSpec `catchError` \e -> whenM (doesFileExist filePath) (removeFile filePath) >> throwError e _ -> throwError $ PCEResponseError NO_FILE (r, _) -> throwError . PCEUnexpectedResponse $ bshow r +xftpReqTimeout :: XFTPClientConfig -> Maybe Word32 -> Int +xftpReqTimeout cfg@XFTPClientConfig {xftpNetworkConfig = NetworkConfig {tcpTimeout}} chunkSize_ = + maybe tcpTimeout (chunkTimeout cfg) chunkSize_ + chunkTimeout :: XFTPClientConfig -> Word32 -> Int -chunkTimeout config chunkSize = fromIntegral $ (fromIntegral chunkSize * uploadTimeoutPerMb config) `div` mb 1 +chunkTimeout XFTPClientConfig {xftpNetworkConfig = NetworkConfig {tcpTimeout, tcpTimeoutPerKb}} sz = + tcpTimeout + fromIntegral (min ((fromIntegral sz `div` 1024) * tcpTimeoutPerKb) (fromIntegral (maxBound :: Int))) deleteXFTPChunk :: XFTPClient -> C.APrivateAuthKey -> SenderId -> ExceptT XFTPClientError IO () deleteXFTPChunk c spKey sId = sendXFTPCommand c spKey sId FDEL Nothing >>= okResponse diff --git a/src/Simplex/FileTransfer/Client/Agent.hs b/src/Simplex/FileTransfer/Client/Agent.hs index 1dafc8108..f86de9afb 100644 --- a/src/Simplex/FileTransfer/Client/Agent.hs +++ b/src/Simplex/FileTransfer/Client/Agent.hs @@ -11,6 +11,7 @@ import Control.Logger.Simple (logInfo) import Control.Monad import Control.Monad.Except import Control.Monad.Trans (lift) +import Crypto.Random (ChaChaDRG) import Data.Bifunctor (first) import qualified Data.ByteString.Char8 as B import Data.Text (Text) @@ -60,15 +61,15 @@ newXFTPAgent config = do type ME a = ExceptT XFTPClientAgentError IO a -getXFTPServerClient :: XFTPClientAgent -> XFTPServer -> ME XFTPClient -getXFTPServerClient XFTPClientAgent {xftpClients, config} srv = do +getXFTPServerClient :: TVar ChaChaDRG -> XFTPClientAgent -> XFTPServer -> ME XFTPClient +getXFTPServerClient g XFTPClientAgent {xftpClients, config} srv = do atomically getClientVar >>= either newXFTPClient waitForXFTPClient where connectClient :: ME XFTPClient connectClient = ExceptT $ first (XFTPClientAgentError srv) - <$> getXFTPClient (1, srv, Nothing) (xftpConfig config) clientDisconnected + <$> getXFTPClient g (1, srv, Nothing) (xftpConfig config) clientDisconnected clientDisconnected :: XFTPClient -> IO () clientDisconnected _ = do diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs index b3fa494ed..3320e0a26 100644 --- a/src/Simplex/FileTransfer/Client/Main.hs +++ b/src/Simplex/FileTransfer/Client/Main.hs @@ -333,9 +333,9 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re rKeys <- atomically $ L.fromList <$> replicateM numRecipients (C.generateAuthKeyPair C.SEd25519 g) digest <- liftIO $ getChunkDigest chunkSpec let ch = FileInfo {sndKey, size = fromIntegral chunkSize, digest} - c <- withRetry retryCount $ getXFTPServerClient a xftpServer + c <- withRetry retryCount $ getXFTPServerClient g 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 + withReconnect g a xftpServer retryCount $ \c' -> uploadXFTPChunk c' spKey sndId chunkSpec logInfo $ "uploaded chunk " <> tshow chunkNo uploaded <- atomically . stateTVar uploadedChunks $ \cs -> let cs' = fromIntegral chunkSize : cs in (sum cs', cs') @@ -445,7 +445,7 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath, when (FileSize encSize /= size) $ throwError $ CLIError "File size mismatch" liftIO $ printNoNewLine "Decrypting file..." CryptoFile path _ <- withExceptT cliCryptoError $ decryptChunks encSize chunkPaths key nonce $ fmap CF.plain . getFilePath - forM_ chunks $ acknowledgeFileChunk a + forM_ chunks $ acknowledgeFileChunk g a whenM (doesPathExist encPath) $ removeDirectoryRecursive encPath liftIO $ do printNoNewLine $ "File downloaded: " <> path @@ -456,7 +456,7 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath, logInfo $ "downloading chunk " <> tshow chunkNo <> " from " <> showServer server <> "..." chunkPath <- uniqueCombine encPath $ show chunkNo let chunkSpec = XFTPRcvChunkSpec chunkPath (unFileSize chunkSize) (unFileDigest digest) - withReconnect a server retryCount $ \c -> downloadXFTPChunk g c replicaKey (unChunkReplicaId replicaId) chunkSpec + withReconnect g a server retryCount $ \c -> downloadXFTPChunk g c replicaKey (unChunkReplicaId replicaId) chunkSpec logInfo $ "downloaded chunk " <> tshow chunkNo <> " to " <> T.pack chunkPath downloaded <- atomically . stateTVar downloadedChunks $ \cs -> let cs' = fromIntegral (unFileSize chunkSize) : cs in (sum cs', cs') @@ -472,12 +472,12 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath, ifM (doesDirectoryExist path) (uniqueCombine path name) $ ifM (doesFileExist path) (throwError "File already exists") (pure path) _ -> (`uniqueCombine` name) . ( "Downloads") =<< getHomeDirectory - acknowledgeFileChunk :: XFTPClientAgent -> FileChunk -> ExceptT CLIError IO () - acknowledgeFileChunk a FileChunk {replicas = replica : _} = do + acknowledgeFileChunk :: TVar ChaChaDRG -> XFTPClientAgent -> FileChunk -> ExceptT CLIError IO () + acknowledgeFileChunk g a FileChunk {replicas = replica : _} = do let FileChunkReplica {server, replicaId, replicaKey} = replica - c <- withRetry retryCount $ getXFTPServerClient a server + c <- withRetry retryCount $ getXFTPServerClient g a server withRetry retryCount $ ackXFTPChunk c replicaKey (unChunkReplicaId replicaId) - acknowledgeFileChunk _ _ = throwError $ CLIError "chunk has no replicas" + acknowledgeFileChunk _ _ _ = throwError $ CLIError "chunk has no replicas" printProgress :: String -> Int64 -> Int64 -> IO () printProgress s part total = printNoNewLine $ s <> " " <> show ((part * 100) `div` total) <> "%" @@ -501,7 +501,8 @@ cliDeleteFile DeleteOptions {fileDescription, retryCount, yes} = do deleteFileChunk :: XFTPClientAgent -> FileChunk -> ExceptT CLIError IO () deleteFileChunk a FileChunk {chunkNo, replicas = replica : _} = do let FileChunkReplica {server, replicaId, replicaKey} = replica - withReconnect a server retryCount $ \c -> deleteXFTPChunk c replicaKey (unChunkReplicaId replicaId) + g <- liftIO C.newRandom + withReconnect g a server retryCount $ \c -> deleteXFTPChunk c replicaKey (unChunkReplicaId replicaId) logInfo $ "deleted chunk " <> tshow chunkNo <> " from " <> showServer server deleteFileChunk _ _ = throwError $ CLIError "chunk has no replicas" @@ -569,9 +570,9 @@ prepareChunkSpecs filePath chunkSizes = reverse . snd $ foldl' addSpec (0, []) c getEncPath :: MonadIO m => Maybe FilePath -> String -> m FilePath getEncPath path name = (`uniqueCombine` (name <> ".encrypted")) =<< maybe (liftIO getCanonicalTemporaryDirectory) pure path -withReconnect :: Show e => XFTPClientAgent -> XFTPServer -> Int -> (XFTPClient -> ExceptT e IO a) -> ExceptT CLIError IO a -withReconnect a srv n run = withRetry n $ do - c <- withRetry n $ getXFTPServerClient a srv +withReconnect :: Show e => TVar ChaChaDRG -> XFTPClientAgent -> XFTPServer -> Int -> (XFTPClient -> ExceptT e IO a) -> ExceptT CLIError IO a +withReconnect g a srv n run = withRetry n $ do + c <- withRetry n $ getXFTPServerClient g a srv withExceptT (CLIError . show) (run c) `catchError` \e -> do liftIO $ closeXFTPServerClient a srv throwError e diff --git a/src/Simplex/FileTransfer/Protocol.hs b/src/Simplex/FileTransfer/Protocol.hs index 2ba75f027..dcd9f2c52 100644 --- a/src/Simplex/FileTransfer/Protocol.hs +++ b/src/Simplex/FileTransfer/Protocol.hs @@ -25,7 +25,7 @@ import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (isNothing) import Data.Type.Equality import Data.Word (Word32) -import Simplex.FileTransfer.Transport (VersionXFTP, XFTPErrorType (..), XFTPVersion, pattern VersionXFTP, xftpClientHandshake) +import Simplex.FileTransfer.Transport (VersionXFTP, XFTPErrorType (..), XFTPVersion, xftpClientHandshakeStub, pattern VersionXFTP) import Simplex.Messaging.Client (authTransmission) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding @@ -144,7 +144,7 @@ instance FilePartyI p => ProtocolMsgTag (FileCommandTag p) where instance Protocol XFTPVersion XFTPErrorType FileResponse where type ProtoCommand FileResponse = FileCmd type ProtoType FileResponse = 'PXFTP - protocolClientHandshake = xftpClientHandshake + protocolClientHandshake = xftpClientHandshakeStub protocolPing = FileCmd SFRecipient PING protocolError = \case FRErr e -> Just e @@ -329,9 +329,9 @@ checkParty' c = case testEquality (sFileParty @p) (sFileParty @p') of _ -> Nothing xftpEncodeAuthTransmission :: ProtocolEncoding XFTPVersion e c => THandleParams XFTPVersion -> C.APrivateAuthKey -> Transmission c -> Either TransportError ByteString -xftpEncodeAuthTransmission thParams pKey (corrId, fId, msg) = do +xftpEncodeAuthTransmission thParams@THandleParams {thAuth} pKey (corrId, fId, msg) = do let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (corrId, fId, msg) - xftpEncodeBatch1 . (,tToSend) =<< authTransmission Nothing (Just pKey) corrId tForAuth + xftpEncodeBatch1 . (,tToSend) =<< authTransmission thAuth (Just pKey) corrId tForAuth xftpEncodeTransmission :: ProtocolEncoding XFTPVersion e c => THandleParams XFTPVersion -> Transmission c -> Either TransportError ByteString xftpEncodeTransmission thParams (corrId, fId, msg) = do diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs index dd74a975d..b426360ea 100644 --- a/src/Simplex/FileTransfer/Server.hs +++ b/src/Simplex/FileTransfer/Server.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} @@ -10,6 +9,7 @@ {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} module Simplex.FileTransfer.Server where @@ -18,7 +18,8 @@ import Control.Monad import Control.Monad.Except import Control.Monad.Reader import Data.Bifunctor (first) -import Data.ByteString.Builder (byteString) +import qualified Data.ByteString.Base64.URL as B64 +import Data.ByteString.Builder (Builder, byteString) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Int (Int64) @@ -32,6 +33,7 @@ import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime) import Data.Time.Clock.System (SystemTime (..), getSystemTime) import Data.Time.Format.ISO8601 (iso8601Show) import Data.Word (Word32) +import qualified Data.X509 as X import GHC.IO.Handle (hSetNewlineMode) import GHC.Stats (getRTSStats) import qualified Network.HTTP.Types as N @@ -46,19 +48,22 @@ import Simplex.FileTransfer.Server.StoreLog import Simplex.FileTransfer.Transport import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto.Lazy as LC -import qualified Simplex.Messaging.Encoding.Base64.URL as U +import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Protocol (CorrId, RcvPublicAuthKey, RcvPublicDhKey, RecipientId, TransmissionAuth) +import Simplex.Messaging.Protocol (CorrId (..), RcvPublicAuthKey, RcvPublicDhKey, RecipientId, TransmissionAuth) import Simplex.Messaging.Server (dummyVerifyCmd, verifyCmdAuthorization) import Simplex.Messaging.Server.Expiration import Simplex.Messaging.Server.Stats -import Simplex.Messaging.Transport (THandleParams (..)) +import Simplex.Messaging.TMap (TMap) +import qualified Simplex.Messaging.TMap as TM +import Simplex.Messaging.Transport (SessionId, THandleAuth (..), THandleParams (..)) import Simplex.Messaging.Transport.Buffer (trimCR) import Simplex.Messaging.Transport.HTTP2 import Simplex.Messaging.Transport.HTTP2.File (fileBlockSize) import Simplex.Messaging.Transport.HTTP2.Server -import Simplex.Messaging.Transport.Server (runTCPServer) +import Simplex.Messaging.Transport.Server (runTCPServer, tlsServerCredentials) import Simplex.Messaging.Util +import Simplex.Messaging.Version (isCompatible) import System.Exit (exitFailure) import System.FilePath (()) import System.IO (hPrint, hPutStrLn, universalNewlineMode) @@ -70,7 +75,7 @@ import qualified UnliftIO.Exception as E type M a = ReaderT XFTPEnv IO a data XFTPTransportRequest = XFTPTransportRequest - { thParams :: THandleParams XFTPVersion, + { thParams :: THandleParamsXFTP, reqBody :: HTTP2Body, request :: H.Request, sendResponse :: H.Response -> IO () @@ -84,20 +89,75 @@ runXFTPServer cfg = do runXFTPServerBlocking :: TMVar Bool -> XFTPServerConfig -> IO () runXFTPServerBlocking started cfg = newXFTPServerEnv cfg >>= runReaderT (xftpServer cfg started) +data Handshake + = HandshakeSent C.PrivateKeyX25519 + | HandshakeAccepted THandleAuth VersionXFTP + xftpServer :: XFTPServerConfig -> TMVar Bool -> M () -xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpiration} 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 where runServer :: M () runServer = do serverParams <- asks tlsServerParams + let (chain, pk) = tlsServerCredentials serverParams + signKey <- liftIO $ case C.x509ToPrivate (pk, []) >>= C.privKey of + Right pk' -> pure pk' + Left e -> putStrLn ("servers has no valid key: " <> show e) >> exitFailure env <- ask - liftIO $ - runHTTP2Server started xftpPort defaultHTTP2BufferSize serverParams transportConfig inactiveClientExpiration $ \sessionId r sendResponse -> do - reqBody <- getHTTP2Body r xftpBlockSize - let thParams = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = currentXFTPVersion, thAuth = Nothing, implySessId = False, batch = True} - processRequest XFTPTransportRequest {thParams, request = r, reqBody, sendResponse} `runReaderT` env + sessions <- atomically TM.empty + 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 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 + Just "xftp/1" -> + xftpServerHandshakeV1 chain signKey sessions req0 >>= \case + Nothing -> pure () -- handshake response sent + 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)) + 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 auth v) -> pure $ Just thParams {thAuth = Just auth, thVersion = v} + either sendError pure r + where + processHello = do + unless (B.null bodyHead) $ throwError HANDSHAKE + (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 = supportedFileServerVRange, sessionId, authPubKey} + shs <- encodeXftp hs + liftIO . sendResponse $ H.responseBuilder N.ok200 [] shs + pure Nothing + processClientHandshake privKey = do + unless (B.length bodyHead == xftpBlockSize) $ throwError HANDSHAKE + body <- liftHS $ C.unPad bodyHead + XFTPClientHandshake {xftpVersion, keyHash, authPubKey} <- liftHS $ smpDecode body + kh <- asks serverIdentity + unless (keyHash == kh) $ throwError HANDSHAKE + unless (xftpVersion `isCompatible` supportedFileServerVRange) $ throwError HANDSHAKE + let auth = THandleAuth {peerPubKey = authPubKey, privKey} + atomically $ TM.insert sessionId (HandshakeAccepted auth xftpVersion) sessions + liftIO . sendResponse $ H.responseNoBody N.ok200 [] + pure Nothing + sendError :: XFTPErrorType -> M (Maybe (THandleParams XFTPVersion)) + sendError err = do + runExceptT (encodeXftp err) >>= \case + Right bs -> liftIO . sendResponse $ H.responseBuilder N.ok200 [] bs + Left _ -> logError $ "Error encoding handshake error: " <> tshow err + pure Nothing + encodeXftp :: Encoding a => a -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) Builder + encodeXftp a = byteString <$> liftHS (C.pad (smpEncode a) xftpBlockSize) + liftHS = liftEitherWith (const HANDSHAKE) stopServer :: M () stopServer = do @@ -110,28 +170,10 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira expireFiles :: ExpirationConfig -> M () expireFiles expCfg = do - st <- asks store let interval = checkInterval expCfg * 1000000 forever $ do liftIO $ threadDelay' interval - old <- liftIO $ expireBeforeEpoch expCfg - sIds <- M.keysSet <$> readTVarIO (files st) - forM_ sIds $ \sId -> do - threadDelay 100000 - atomically (expiredFilePath st sId old) - >>= mapM_ (maybeRemove $ delete st sId) - where - maybeRemove del = maybe del (remove del) - remove del filePath = - ifM - (doesFileExist filePath) - ((removeFile filePath >> del) `catch` \(e :: SomeException) -> logError $ "failed to remove expired file " <> tshow filePath <> ": " <> tshow e) - del - delete st sId = do - withFileLog (`logDeleteFile` sId) - void $ atomically $ deleteFile st sId - FileServerStats {filesExpired} <- asks serverStats - atomically $ modifyTVar' filesExpired (+ 1) + expireServerFiles (Just 100000) expCfg serverStatsThread_ :: XFTPServerConfig -> [M ()] serverStatsThread_ XFTPServerConfig {logStatsInterval = Just interval, logStatsStartTime, serverStatsLogFile} = @@ -201,7 +243,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira role <- newTVarIO CPRNone cpLoop h role where - cpLoop h role = do + cpLoop h role = do s <- trimCR <$> B.hGetLine h case strDecode s of Right CPQuit -> hClose h @@ -235,12 +277,13 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira CPQuit -> pure () CPSkip -> pure () where - withUserRole action = readTVarIO role >>= \case - CPRAdmin -> action - CPRUser -> action - _ -> do - logError "Unauthorized control port command" - hPutStrLn h "AUTH" + withUserRole action = + readTVarIO role >>= \case + CPRAdmin -> action + CPRUser -> action + _ -> do + logError "Unauthorized control port command" + hPutStrLn h "AUTH" data ServerFile = ServerFile { filePath :: FilePath, @@ -253,10 +296,11 @@ processRequest XFTPTransportRequest {thParams, reqBody = body@HTTP2Body {bodyHea | B.length bodyHead /= xftpBlockSize = sendXFTPResponse ("", "", FRErr BLOCK) Nothing | otherwise = do case xftpDecodeTransmission thParams bodyHead of - Right (sig_, signed, (corrId, fId, cmdOrErr)) -> do + Right (sig_, signed, (corrId, fId, cmdOrErr)) -> case cmdOrErr of Right cmd -> do - verifyXFTPTransmission sig_ signed fId cmd >>= \case + let THandleParams {thAuth} = thParams + verifyXFTPTransmission ((,C.cbNonce (bs corrId)) <$> thAuth) sig_ signed fId cmd >>= \case VRVerified req -> uncurry send =<< processXFTPRequest body req VRFailed -> send (FRErr AUTH) Nothing Left e -> send (FRErr e) Nothing @@ -264,7 +308,6 @@ processRequest XFTPTransportRequest {thParams, reqBody = body@HTTP2Body {bodyHea send resp = sendXFTPResponse (corrId, fId, resp) Left e -> sendXFTPResponse ("", "", FRErr e) Nothing where - sendXFTPResponse :: (CorrId, XFTPFileId, FileResponse) -> Maybe ServerFile -> M () sendXFTPResponse (corrId, fId, resp) serverFile_ = do let t_ = xftpEncodeTransmission thParams (corrId, fId, resp) liftIO $ sendResponse $ H.responseStreaming N.ok200 [] $ streamBody t_ @@ -283,8 +326,8 @@ processRequest XFTPTransportRequest {thParams, reqBody = body@HTTP2Body {bodyHea data VerificationResult = VRVerified XFTPRequest | VRFailed -verifyXFTPTransmission :: Maybe TransmissionAuth -> ByteString -> XFTPFileId -> FileCmd -> M VerificationResult -verifyXFTPTransmission tAuth authorized fId cmd = +verifyXFTPTransmission :: Maybe (THandleAuth, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> XFTPFileId -> FileCmd -> M VerificationResult +verifyXFTPTransmission auth_ tAuth authorized fId cmd = case cmd of FileCmd SFSender (FNEW file rcps auth') -> pure $ XFTPReqNew file rcps auth' `verifyWith` sndKey file FileCmd SFRecipient PING -> pure $ VRVerified XFTPReqPing @@ -299,7 +342,7 @@ verifyXFTPTransmission tAuth authorized fId cmd = Right (fr, k) -> XFTPReqCmd fId fr cmd `verifyWith` k _ -> maybe False (dummyVerifyCmd Nothing authorized) tAuth `seq` VRFailed -- TODO verify with DH authorization - req `verifyWith` k = if verifyCmdAuthorization Nothing tAuth authorized k then VRVerified req else VRFailed + req `verifyWith` k = if verifyCmdAuthorization auth_ tAuth authorized k then VRVerified req else VRFailed processXFTPRequest :: HTTP2Body -> XFTPRequest -> M (FileResponse, Maybe ServerFile) processXFTPRequest HTTP2Body {bodyPart} = \case @@ -392,7 +435,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case \used -> let used' = used + fromIntegral size in if used' <= quota then (True, used') else (False, used) receive = do path <- asks $ filesPath . config - let fPath = path B.unpack (U.encode senderId) + let fPath = path B.unpack (B64.encode senderId) receiveChunk (XFTPRcvChunkSpec fPath size digest) >>= \case Right () -> do stats <- asks serverStats @@ -413,18 +456,20 @@ processXFTPRequest HTTP2Body {bodyPart} = \case sendServerFile :: FileRec -> RcvPublicDhKey -> M (FileResponse, Maybe ServerFile) sendServerFile FileRec {senderId, filePath, fileInfo = FileInfo {size}} rDhKey = do readTVarIO filePath >>= \case - Just path -> do - g <- asks random - (sDhKey, spDhKey) <- atomically $ C.generateKeyPair g - let dhSecret = C.dh' rDhKey spDhKey - cbNonce <- atomically $ C.randomCbNonce g - case LC.cbInit dhSecret cbNonce of - Right sbState -> do - stats <- asks serverStats - atomically $ modifyTVar' (fileDownloads stats) (+ 1) - atomically $ updatePeriodStats (filesDownloaded stats) senderId - pure (FRFile sDhKey cbNonce, Just ServerFile {filePath = path, fileSize = size, sbState}) - _ -> pure (FRErr INTERNAL, Nothing) + Just path -> ifM (doesFileExist path) sendFile (pure (FRErr AUTH, Nothing)) + where + sendFile = do + g <- asks random + (sDhKey, spDhKey) <- atomically $ C.generateKeyPair g + let dhSecret = C.dh' rDhKey spDhKey + cbNonce <- atomically $ C.randomCbNonce g + case LC.cbInit dhSecret cbNonce of + Right sbState -> do + stats <- asks serverStats + atomically $ modifyTVar' (fileDownloads stats) (+ 1) + atomically $ updatePeriodStats (filesDownloaded stats) senderId + pure (FRFile sDhKey cbNonce, Just ServerFile {filePath = path, fileSize = size, sbState}) + _ -> pure (FRErr INTERNAL, Nothing) _ -> pure (FRErr NO_FILE, Nothing) deleteServerFile :: FileRec -> M FileResponse @@ -457,6 +502,33 @@ deleteServerFile_ FileRec {senderId, fileInfo, filePath} = do atomically $ modifyTVar' (filesCount stats) (subtract 1) atomically $ modifyTVar' (filesSize stats) (subtract $ fromIntegral $ size fileInfo) +expireServerFiles :: Maybe Int -> ExpirationConfig -> M () +expireServerFiles itemDelay expCfg = do + st <- asks store + usedStart <- readTVarIO $ usedStorage st + old <- liftIO $ expireBeforeEpoch expCfg + files' <- readTVarIO (files st) + logInfo $ "Expiration check: " <> tshow (M.size files') <> " files" + forM_ (M.keys files') $ \sId -> do + mapM_ threadDelay itemDelay + atomically (expiredFilePath st sId old) + >>= mapM_ (maybeRemove $ delete st sId) + usedEnd <- readTVarIO $ usedStorage st + logInfo $ "Used " <> mbs usedStart <> " -> " <> mbs usedEnd <> ", " <> mbs (usedStart - usedEnd) <> " reclaimed." + where + mbs bs = tshow (bs `div` 1048576) <> "mb" + maybeRemove del = maybe del (remove del) + remove del filePath = + ifM + (doesFileExist filePath) + ((removeFile filePath >> del) `catch` \(e :: SomeException) -> logError $ "failed to remove expired file " <> tshow filePath <> ": " <> tshow e) + del + delete st sId = do + withFileLog (`logDeleteFile` sId) + void . atomically $ deleteFile st sId -- will not update usedStorage if sId isn't in store + FileServerStats {filesExpired} <- asks serverStats + atomically $ modifyTVar' filesExpired (+ 1) + randomId :: Int -> M ByteString randomId n = atomically . C.randomBytes n =<< asks random diff --git a/src/Simplex/FileTransfer/Server/Env.hs b/src/Simplex/FileTransfer/Server/Env.hs index a3afe0f60..789a3dc20 100644 --- a/src/Simplex/FileTransfer/Server/Env.hs +++ b/src/Simplex/FileTransfer/Server/Env.hs @@ -2,19 +2,23 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StrictData #-} module Simplex.FileTransfer.Server.Env where -import Control.Logger.Simple (logInfo) +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 (..)) @@ -27,6 +31,7 @@ import Simplex.FileTransfer.Server.StoreLog import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Protocol (BasicAuth, RcvPublicAuthKey) import Simplex.Messaging.Server.Expiration +import Simplex.Messaging.Transport (ALPN) import Simplex.Messaging.Transport.Server (TransportServerConfig, loadFingerprint, loadTLSServerParams) import Simplex.Messaging.Util (tshow) import System.IO (IOMode (..)) @@ -94,6 +99,9 @@ defaultFileExpiration = checkInterval = 2 * 3600 -- seconds, 2 hours } +supportedXFTPhandshakes :: [ALPN] +supportedXFTPhandshakes = ["xftp/1"] + newXFTPServerEnv :: XFTPServerConfig -> IO XFTPEnv newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, caCertificateFile, certificateFile, privateKeyFile} = do random <- liftIO C.newRandom @@ -104,7 +112,14 @@ 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 + tlsServerParams' <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile + let tlsServerParams = + tlsServerParams' + { T.serverHooks = + def + { T.onALPNClientSuggest = Just $ pure . fromMaybe "" . find (`elem` supportedXFTPhandshakes) + } + } Fingerprint fp <- liftIO $ loadFingerprint caCertificateFile serverStats <- atomically . newFileServerStats =<< liftIO getCurrentTime pure XFTPEnv {config, store, storeLog, random, tlsServerParams, serverIdentity = C.KeyHash fp, serverStats} diff --git a/src/Simplex/FileTransfer/Server/StoreLog.hs b/src/Simplex/FileTransfer/Server/StoreLog.hs index f2ee311b7..8e8add3d6 100644 --- a/src/Simplex/FileTransfer/Server/StoreLog.hs +++ b/src/Simplex/FileTransfer/Server/StoreLog.hs @@ -22,6 +22,7 @@ import Control.Concurrent.STM import Control.Monad.Except import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as LB import Data.Composition ((.:), (.:.)) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as L @@ -88,7 +89,7 @@ readWriteFileStore f st = do pure s readFileStore :: FilePath -> FileStore -> IO () -readFileStore f st = mapM_ addFileLogRecord . B.lines =<< B.readFile f +readFileStore f st = mapM_ (addFileLogRecord . LB.toStrict) . LB.lines =<< LB.readFile f where addFileLogRecord s = case strDecode s of Left e -> B.putStrLn $ "Log parsing error (" <> B.pack e <> "): " <> B.take 100 s diff --git a/src/Simplex/FileTransfer/Transport.hs b/src/Simplex/FileTransfer/Transport.hs index 54baf57ac..49b809bf1 100644 --- a/src/Simplex/FileTransfer/Transport.hs +++ b/src/Simplex/FileTransfer/Transport.hs @@ -9,9 +9,16 @@ module Simplex.FileTransfer.Transport ( supportedFileServerVRange, - xftpClientHandshake, -- stub - XFTPVersion, + xftpClientHandshakeStub, + XFTPClientHandshake (..), + -- xftpClientHandshake, + XFTPServerHandshake (..), + -- xftpServerHandshake, + THandleXFTP, + THandleParamsXFTP, VersionXFTP, + VersionRangeXFTP, + XFTPVersion, pattern VersionXFTP, XFTPErrorType (..), XFTPRcvChunkSpec (..), @@ -30,20 +37,21 @@ import Control.Monad.Except import Control.Monad.IO.Class import qualified Data.Aeson.TH as J import qualified Data.Attoparsec.ByteString.Char8 as A -import Data.Bifunctor (first) +import Data.Bifunctor (bimap, first) import qualified Data.ByteArray as BA import Data.ByteString.Builder (Builder, byteString) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB import Data.Word (Word16, Word32) +import qualified Data.X509 as X import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto.Lazy as LC import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers import Simplex.Messaging.Protocol (CommandError) -import Simplex.Messaging.Transport (HandshakeError (..), THandle, TransportError (..)) +import Simplex.Messaging.Transport (HandshakeError (..), SessionId, THandle (..), THandleParams (..), TransportError (..)) import Simplex.Messaging.Transport.HTTP2.File import Simplex.Messaging.Util (bshow) import Simplex.Messaging.Version @@ -68,6 +76,9 @@ type VersionRangeXFTP = VersionRange XFTPVersion pattern VersionXFTP :: Word16 -> VersionXFTP pattern VersionXFTP v = Version v +type THandleXFTP c = THandle XFTPVersion c +type THandleParamsXFTP = THandleParams XFTPVersion + initialXFTPVersion :: VersionXFTP initialXFTPVersion = VersionXFTP 1 @@ -75,8 +86,45 @@ supportedFileServerVRange :: VersionRangeXFTP supportedFileServerVRange = mkVersionRange initialXFTPVersion initialXFTPVersion -- XFTP protocol does not support handshake -xftpClientHandshake :: c -> C.KeyPairX25519 -> C.KeyHash -> VersionRangeXFTP -> ExceptT TransportError IO (THandle XFTPVersion c) -xftpClientHandshake _c _ks _keyHash _xftpVRange = throwError $ TEHandshake VERSION +xftpClientHandshakeStub :: c -> C.KeyPairX25519 -> C.KeyHash -> VersionRangeXFTP -> ExceptT TransportError IO (THandle XFTPVersion c) +xftpClientHandshakeStub _c _ks _keyHash _xftpVRange = throwError $ TEHandshake VERSION + +data XFTPServerHandshake = XFTPServerHandshake + { xftpVersionRange :: VersionRangeXFTP, + sessionId :: SessionId, + -- | pub key to agree shared secrets for command authorization and entity ID encryption. + authPubKey :: (X.CertificateChain, X.SignedExact X.PubKey) + } + +data XFTPClientHandshake = XFTPClientHandshake + { -- | agreed XFTP server protocol version + xftpVersion :: VersionXFTP, + -- | server identity - CA certificate fingerprint + keyHash :: C.KeyHash, + -- | pub key to agree shared secret for entity ID encryption, shared secret for command authorization is agreed using per-queue keys. + authPubKey :: C.PublicKeyX25519 + } + +instance Encoding XFTPClientHandshake where + smpEncode XFTPClientHandshake {xftpVersion, keyHash, authPubKey} = + smpEncode (xftpVersion, keyHash, authPubKey) + smpP = do + (xftpVersion, keyHash) <- smpP + authPubKey <- smpP + Tail _compat <- smpP + pure XFTPClientHandshake {xftpVersion, keyHash, authPubKey} + +instance Encoding XFTPServerHandshake where + smpEncode XFTPServerHandshake {xftpVersionRange, sessionId, authPubKey} = + smpEncode (xftpVersionRange, sessionId, auth) + where + auth = bimap C.encodeCertChain C.SignedObject authPubKey + smpP = do + (xftpVersionRange, sessionId) <- smpP + cert <- C.certChainP + C.SignedObject key <- smpP + Tail _compat <- smpP + pure XFTPServerHandshake {xftpVersionRange, sessionId, authPubKey = (cert, key)} sendEncFile :: Handle -> (Builder -> IO ()) -> LC.SbState -> Word32 -> IO () sendEncFile h send = go @@ -139,6 +187,8 @@ data XFTPErrorType BLOCK | -- | incorrect SMP session ID (TLS Finished message / tls-unique binding RFC5929) SESSION + | -- | incorrect handshake command + HANDSHAKE | -- | SMP command is unknown or has invalid syntax CMD {cmdErr :: CommandError} | -- | command authorization error - bad signature or non-existing SMP queue @@ -181,6 +231,7 @@ instance Encoding XFTPErrorType where smpEncode = \case BLOCK -> "BLOCK" SESSION -> "SESSION" + HANDSHAKE -> "HANDSHAKE" CMD err -> "CMD " <> smpEncode err AUTH -> "AUTH" SIZE -> "SIZE" @@ -199,6 +250,7 @@ instance Encoding XFTPErrorType where A.takeTill (== ' ') >>= \case "BLOCK" -> pure BLOCK "SESSION" -> pure SESSION + "HANDSHAKE" -> pure HANDSHAKE "CMD" -> CMD <$> _smpP "AUTH" -> pure AUTH "SIZE" -> pure SIZE diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 7330e823f..3f7ed0d90 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -82,6 +82,7 @@ module Simplex.Messaging.Agent setNtfServers, setNetworkConfig, getNetworkConfig, + setUserNetworkInfo, reconnectAllServers, registerNtfToken, verifyNtfToken, @@ -402,17 +403,32 @@ testProtocolServer c userId srv = withAgentEnv' c $ case protocolTypeI @p of SPXFTP -> runXFTPServerTest c userId srv SPNTF -> runNTFServerTest c userId srv --- | set SOCKS5 proxy on/off and optionally set TCP timeout +-- | set SOCKS5 proxy on/off and optionally set TCP timeouts for fast network setNetworkConfig :: AgentClient -> NetworkConfig -> IO () -setNetworkConfig c cfg' = do - cfg <- atomically $ do - swapTVar (useNetworkConfig c) cfg' - when (cfg /= cfg') $ reconnectAllServers c +setNetworkConfig c@AgentClient {useNetworkConfig} cfg' = do + changed <- atomically $ do + (_, cfg) <- readTVar useNetworkConfig + if cfg == cfg' + then pure False + else True <$ (writeTVar useNetworkConfig $! (slowNetworkConfig cfg', cfg')) + when changed $ reconnectAllServers c +-- returns fast network config getNetworkConfig :: AgentClient -> IO NetworkConfig -getNetworkConfig = readTVarIO . useNetworkConfig +getNetworkConfig = fmap snd . readTVarIO . useNetworkConfig {-# INLINE getNetworkConfig #-} +setUserNetworkInfo :: AgentClient -> UserNetworkInfo -> IO () +setUserNetworkInfo c@AgentClient {userNetworkState} UserNetworkInfo {networkType = nt'} = withAgentEnv' c $ do + d <- asks $ initialInterval . userNetworkInterval . config + ts <- liftIO getCurrentTime + atomically $ do + ns@UserNetworkState {networkType = nt} <- readTVar userNetworkState + when (nt' /= nt) $ + writeTVar userNetworkState $! case nt' of + UNNone -> ns {networkType = nt', offline = Just UNSOffline {offlineDelay = d, offlineFrom = ts}} + _ -> ns {networkType = nt', offline = Nothing} + reconnectAllServers :: AgentClient -> IO () reconnectAllServers c = do reconnectServerClients c smpClients @@ -1267,6 +1283,7 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} ConnData {connId} sq (Worker {doWork let mId = unId msgId ri' = maybe id updateRetryInterval2 msgRetryState ri withRetryLock2 ri' qLock $ \riState loop -> do + lift $ waitForUserNetwork c resp <- tryError $ case msgType of AM_CONN_INFO -> sendConfirmation c sq msgBody AM_CONN_INFO_REPLY -> sendConfirmation c sq msgBody @@ -2047,7 +2064,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v, pure ack' where queueDrained = case conn of - DuplexConnection _ _ sqs -> void $ enqueueMessages c cData sqs SMP.noMsgFlags $ QCONT (sndAddress rq) + DuplexConnection _ _ sqs -> void $ enqueueMessages c cData sqs SMP.noMsgFlags $ A_QCONT (sndAddress rq) _ -> pure () processClientMsg srvTs msgFlags msgBody = do clientMsg@SMP.ClientMsgEnvelope {cmHeader = SMP.PubHeader phVer e2ePubKey_} <- @@ -2096,7 +2113,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v, notify $ MSG msgMeta msgFlags body pure ACKPending A_RCVD rcpts -> qDuplex conn'' "RCVD" $ messagesRcvd rcpts msgMeta - QCONT addr -> qDuplexAckDel conn'' "QCONT" $ continueSending srvMsgId addr + A_QCONT addr -> qDuplexAckDel conn'' "QCONT" $ continueSending srvMsgId addr QADD qs -> qDuplexAckDel conn'' "QADD" $ qAddMsg srvMsgId qs QKEY qs -> qDuplexAckDel conn'' "QKEY" $ qKeyMsg srvMsgId qs QUSE qs -> qDuplexAckDel conn'' "QUSE" $ qUseMsg srvMsgId qs @@ -2310,6 +2327,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v, atomically $ TM.lookup (qAddress sq) (smpDeliveryWorkers c) >>= mapM_ (\(_, retryLock) -> tryPutTMVar retryLock ()) + notify QCONT Nothing -> qError "QCONT: queue address not found" messagesRcvd :: NonEmpty AMessageReceipt -> MsgMeta -> Connection 'CDuplex -> AM ACKd @@ -2351,10 +2369,10 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v, case L.nonEmpty keepSqs of Just sqs' -> do -- move inside case? - withStore' c $ \db -> mapM_ (deleteConnSndQueue db connId) delSqs sq_@SndQueue {sndPublicKey, e2ePubKey} <- lift $ newSndQueue userId connId qInfo - let sq'' = (sq_ :: NewSndQueue) {primary = True, dbReplaceQueueId = Just dbQueueId} - sq2 <- withStore c $ \db -> addConnSndQueue db connId sq'' + sq2 <- withStore c $ \db -> do + liftIO $ mapM_ (deleteConnSndQueue db connId) delSqs + addConnSndQueue db connId (sq_ :: NewSndQueue) {primary = True, dbReplaceQueueId = Just dbQueueId} case (sndPublicKey, e2ePubKey) of (Just sndPubKey, Just dhPublicKey) -> do logServer "<--" c srv rId $ "MSG :" <> logSecret srvMsgId <> " " <> logSecret (senderId queueAddress) diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 7798fcadd..3091fba87 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -27,6 +27,7 @@ module Simplex.Messaging.Agent.Client withConnLock, withConnLocks, withInvLock, + withLockMap, closeAgentClient, closeProtocolServerClients, reconnectServerClients, @@ -80,6 +81,7 @@ module Simplex.Messaging.Agent.Client agentClientStore, agentDRG, getAgentSubscriptions, + slowNetworkConfig, Worker (..), SessionVar (..), SubscriptionsInfo (..), @@ -99,6 +101,11 @@ module Simplex.Messaging.Agent.Client agentOperations, agentOperationBracket, waitUntilActive, + UserNetworkInfo (..), + UserNetworkType (..), + UserNetworkState (..), + UNSOffline (..), + waitForUserNetwork, throwWhenInactive, throwWhenNoDelivery, beginAgentOperation, @@ -132,7 +139,7 @@ import Control.Applicative ((<|>)) import Control.Concurrent (ThreadId, forkIO, threadDelay) import Control.Concurrent.Async (Async, uninterruptibleCancel) import Control.Concurrent.STM (retry, throwSTM) -import Control.Exception (AsyncException (..)) +import Control.Exception (AsyncException (..), BlockedIndefinitelyOnSTM (..)) import Control.Logger.Simple import Control.Monad import Control.Monad.Except @@ -142,11 +149,13 @@ import Crypto.Random (ChaChaDRG) import qualified Data.Aeson as J import qualified Data.Aeson.TH as J import Data.Bifunctor (bimap, first, second) +import Data.ByteString.Base64 import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Composition ((.:.)) import Data.Either (lefts, partitionEithers) import Data.Functor (($>)) +import Data.Int (Int64) import Data.List (deleteFirstsBy, foldl', partition, (\\)) import Data.List.NonEmpty (NonEmpty (..), (<|)) import qualified Data.List.NonEmpty as L @@ -157,7 +166,7 @@ import Data.Set (Set) import qualified Data.Set as S import Data.Text (Text) import Data.Text.Encoding -import Data.Time (UTCTime, defaultTimeLocale, formatTime, getCurrentTime) +import Data.Time (UTCTime, defaultTimeLocale, diffUTCTime, formatTime, getCurrentTime) import Data.Time.Clock.System (getSystemTime) import Data.Word (Word16) import Network.Socket (HostName) @@ -165,7 +174,7 @@ import Simplex.FileTransfer.Client (XFTPChunkSpec (..), XFTPClient, XFTPClientCo import qualified Simplex.FileTransfer.Client as X import Simplex.FileTransfer.Description (ChunkReplicaId (..), FileDigest (..), kb) import Simplex.FileTransfer.Protocol (FileInfo (..), FileResponse) -import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec (..), XFTPErrorType (DIGEST), XFTPVersion) +import Simplex.FileTransfer.Transport (XFTPErrorType (DIGEST), XFTPRcvChunkSpec (..), XFTPVersion) import Simplex.FileTransfer.Types (DeletedSndChunkReplica (..), NewSndChunkReplica (..), RcvFileChunkReplica (..), SndFileChunk (..), SndFileChunkReplica (..)) import Simplex.FileTransfer.Util (uniqueCombine) import Simplex.Messaging.Agent.Env.SQLite @@ -181,7 +190,6 @@ import Simplex.Messaging.Client import Simplex.Messaging.Client.Agent () import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding -import Simplex.Messaging.Encoding.Base64 (encode) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Notifications.Client import Simplex.Messaging.Notifications.Protocol @@ -195,6 +203,7 @@ import Simplex.Messaging.Protocol ErrorType, MsgFlags (..), MsgId, + NtfPublicAuthKey, NtfServer, NtfServerWithAuth, ProtoServer, @@ -206,22 +215,21 @@ import Simplex.Messaging.Protocol QueueIdsKeys (..), RcvMessage (..), RcvNtfPublicDhKey, - NtfPublicAuthKey, SMPMsgMeta (..), SProtocolType (..), SndPublicAuthKey, SubscriptionMode (..), UserProtocol, + VersionRangeSMPC, + VersionSMPC, XFTPServer, XFTPServerWithAuth, - VersionSMPC, - VersionRangeSMPC, sameSrvAddr', ) import qualified Simplex.Messaging.Protocol as SMP -import Simplex.Messaging.Transport (SMPVersion) import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM +import Simplex.Messaging.Transport (SMPVersion) import Simplex.Messaging.Transport.Client (TransportHost) import Simplex.Messaging.Util import Simplex.Messaging.Version @@ -264,7 +272,8 @@ data AgentClient = AgentClient ntfClients :: TMap NtfTransportSession NtfClientVar, xftpServers :: TMap UserId (NonEmpty XFTPServerWithAuth), xftpClients :: TMap XFTPTransportSession XFTPClientVar, - useNetworkConfig :: TVar NetworkConfig, + useNetworkConfig :: TVar (NetworkConfig, NetworkConfig), -- (slow, fast) networks + userNetworkState :: TVar UserNetworkState, subscrConns :: TVar (Set ConnId), activeSubs :: TRcvQueues, pendingSubs :: TRcvQueues, @@ -395,6 +404,23 @@ data AgentStatsKey = AgentStatsKey } deriving (Eq, Ord, Show) +data UserNetworkInfo = UserNetworkInfo + { networkType :: UserNetworkType + } + deriving (Show) + +data UserNetworkType = UNNone | UNCellular | UNWifi | UNEthernet | UNOther + deriving (Eq, Show) + +data UserNetworkState = UserNetworkState + { networkType :: UserNetworkType, + offline :: Maybe UNSOffline + } + deriving (Show) + +data UNSOffline = UNSOffline {offlineDelay :: Int64, offlineFrom :: UTCTime} + deriving (Show) + -- | Creates an SMP agent client instance that receives commands and sends responses via 'TBQueue's. newAgentClient :: Int -> InitialAgentServers -> Env -> STM AgentClient newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} agentEnv = do @@ -410,7 +436,8 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} agentEnv = ntfClients <- TM.empty xftpServers <- newTVar xftp xftpClients <- TM.empty - useNetworkConfig <- newTVar netCfg + useNetworkConfig <- newTVar (slowNetworkConfig netCfg, netCfg) + userNetworkState <- newTVar $ UserNetworkState UNOther Nothing subscrConns <- newTVar S.empty activeSubs <- RQ.empty pendingSubs <- RQ.empty @@ -445,6 +472,7 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} agentEnv = xftpServers, xftpClients, useNetworkConfig, + userNetworkState, subscrConns, activeSubs, pendingSubs, @@ -469,6 +497,13 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} agentEnv = agentEnv } +slowNetworkConfig :: NetworkConfig -> NetworkConfig +slowNetworkConfig cfg@NetworkConfig {tcpConnectTimeout, tcpTimeout, tcpTimeoutPerKb} = + cfg {tcpConnectTimeout = slow tcpConnectTimeout, tcpTimeout = slow tcpTimeout, tcpTimeoutPerKb = slow tcpTimeoutPerKb} + where + slow :: Integral a => a -> a + slow t = (t * 3) `div` 2 + agentClientStore :: AgentClient -> SQLiteStore agentClientStore AgentClient {agentEnv = Env {store}} = store {-# INLINE agentClientStore #-} @@ -531,7 +566,8 @@ getSMPServerClient c@AgentClient {active, smpClients, msgQ} tSess@(userId, srv, g <- asks random env <- ask liftError' (protocolClientError SMP $ B.unpack $ strEncode srv) $ - getProtocolClient g tSess cfg (Just msgQ) $ clientDisconnected env v + getProtocolClient g tSess cfg (Just msgQ) $ + clientDisconnected env v clientDisconnected :: Env -> SMPClientVar -> SMPClient -> IO () clientDisconnected env v client = do @@ -580,6 +616,7 @@ resubscribeSMPSession c@AgentClient {smpSubWorkers} tSess = withRetryInterval ri $ \_ loop -> do pending <- atomically getPending forM_ (L.nonEmpty pending) $ \qs -> do + waitForUserNetwork c void . tryAgentError' $ reconnectSMPClient timeoutCounts c tSess qs loop getPending = RQ.getSessQueues tSess $ pendingSubs c @@ -592,7 +629,7 @@ resubscribeSMPSession c@AgentClient {smpSubWorkers} tSess = reconnectSMPClient :: TVar Int -> AgentClient -> SMPTransportSession -> NonEmpty RcvQueue -> AM () reconnectSMPClient tc c tSess@(_, srv, _) qs = do - NetworkConfig {tcpTimeout} <- readTVarIO $ useNetworkConfig c + NetworkConfig {tcpTimeout} <- atomically $ getNetworkConfig c -- this allows 3x of timeout per batch of subscription (90 queues per batch empirically) let t = (length qs `div` 90 + 1) * tcpTimeout * 3 ExceptT (sequence <$> (t `timeout` runExceptT resubscribe)) >>= \case @@ -634,7 +671,8 @@ getNtfServerClient c@AgentClient {active, ntfClients} tSess@(userId, srv, _) = d cfg <- lift $ getClientConfig c ntfCfg g <- asks random liftError' (protocolClientError NTF $ B.unpack $ strEncode srv) $ - getProtocolClient g tSess cfg Nothing $ clientDisconnected v + getProtocolClient g tSess cfg Nothing $ + clientDisconnected v clientDisconnected :: NtfClientVar -> NtfClient -> IO () clientDisconnected v client = do @@ -644,7 +682,7 @@ getNtfServerClient c@AgentClient {active, ntfClients} tSess@(userId, srv, _) = d logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv getXFTPServerClient :: AgentClient -> XFTPTransportSession -> AM XFTPClient -getXFTPServerClient c@AgentClient {active, xftpClients, useNetworkConfig} tSess@(userId, srv, _) = do +getXFTPServerClient c@AgentClient {active, xftpClients} tSess@(userId, srv, _) = do unlessM (readTVarIO active) . throwError $ INACTIVE atomically (getTSessVar c tSess xftpClients) >>= either @@ -654,9 +692,11 @@ getXFTPServerClient c@AgentClient {active, xftpClients, useNetworkConfig} tSess@ connectClient :: XFTPClientVar -> AM XFTPClient connectClient v = do cfg <- asks $ xftpCfg . config - xftpNetworkConfig <- readTVarIO useNetworkConfig + g <- asks random + xftpNetworkConfig <- atomically $ getNetworkConfig c liftError' (protocolClientError XFTP $ B.unpack $ strEncode srv) $ - X.getXFTPClient tSess cfg {xftpNetworkConfig} $ clientDisconnected v + X.getXFTPClient g tSess cfg {xftpNetworkConfig} $ + clientDisconnected v clientDisconnected :: XFTPClientVar -> XFTPClient -> IO () clientDisconnected v client = do @@ -688,7 +728,7 @@ removeTSessVar' v tSess vs = waitForProtocolClient :: ProtocolTypeI (ProtoType msg) => AgentClient -> TransportSession msg -> ClientVar msg -> AM (Client msg) waitForProtocolClient c (_, srv, _) v = do - NetworkConfig {tcpConnectTimeout} <- readTVarIO $ useNetworkConfig c + NetworkConfig {tcpConnectTimeout} <- atomically $ getNetworkConfig c client_ <- liftIO $ tcpConnectTimeout `timeout` atomically (readTMVar $ sessionVar v) liftEither $ case client_ of Just (Right smpClient) -> Right smpClient @@ -724,11 +764,51 @@ hostEvent :: forall v err msg. (ProtocolTypeI (ProtoType msg), ProtocolServerCli hostEvent event = event (AProtocolType $ protocolTypeI @(ProtoType msg)) . clientTransportHost getClientConfig :: AgentClient -> (AgentConfig -> ProtocolClientConfig v) -> AM' (ProtocolClientConfig v) -getClientConfig AgentClient {useNetworkConfig} cfgSel = do +getClientConfig c cfgSel = do cfg <- asks $ cfgSel . config - networkConfig <- readTVarIO useNetworkConfig + networkConfig <- atomically $ getNetworkConfig c pure cfg {networkConfig} +getNetworkConfig :: AgentClient -> STM NetworkConfig +getNetworkConfig c = do + (slowCfg, fastCfg) <- readTVar (useNetworkConfig c) + UserNetworkState {networkType} <- readTVar (userNetworkState c) + pure $ case networkType of + UNCellular -> slowCfg + UNNone -> slowCfg + _ -> fastCfg + +waitForUserNetwork :: AgentClient -> AM' () +waitForUserNetwork AgentClient {userNetworkState} = + (offline <$> readTVarIO userNetworkState) >>= mapM_ waitWhileOffline + where + waitWhileOffline UNSOffline {offlineDelay = d} = + unlessM (liftIO $ waitOnline d False) $ do -- network delay reached, increase delay + ts' <- liftIO getCurrentTime + ni <- asks $ userNetworkInterval . config + atomically $ do + ns@UserNetworkState {offline} <- readTVar userNetworkState + forM_ offline $ \UNSOffline {offlineDelay = d', offlineFrom = ts} -> + -- Using `min` to avoid multiple updates in a short period of time + -- and to reset `offlineDelay` if network went `on` and `off` again. + writeTVar userNetworkState $! + let d'' = nextRetryDelay (diffToMicroseconds $ diffUTCTime ts' ts) (min d d') ni + in ns {offline = Just UNSOffline {offlineDelay = d'', offlineFrom = ts}} + waitOnline :: Int64 -> Bool -> IO Bool + waitOnline t online' + | t <= 0 = pure online' + | otherwise = + registerDelay (fromIntegral maxWait) + >>= atomically . onlineOrDelay + >>= waitOnline (t - maxWait) + where + maxWait = min t $ fromIntegral (maxBound :: Int) + onlineOrDelay delay = do + online <- isNothing . offline <$> readTVar userNetworkState + expired <- readTVar delay + unless (online || expired) retry + pure online + closeAgentClient :: AgentClient -> IO () closeAgentClient c = do atomically $ writeTVar (active c) False @@ -784,8 +864,8 @@ closeClient c clientSel tSess = closeClient_ :: ProtocolServerClient v err msg => AgentClient -> ClientVar msg -> IO () closeClient_ c v = do - NetworkConfig {tcpConnectTimeout} <- readTVarIO $ useNetworkConfig c - tcpConnectTimeout `timeout` atomically (readTMVar $ sessionVar v) >>= \case + NetworkConfig {tcpConnectTimeout} <- atomically $ getNetworkConfig c + E.handle (\BlockedIndefinitelyOnSTM -> pure ()) $ tcpConnectTimeout `timeout` atomically (readTMVar $ sessionVar v) >>= \case Just (Right client) -> closeProtocolServerClient client `catchAll_` pure () _ -> pure () @@ -799,7 +879,7 @@ withConnLock c connId name = ExceptT . withConnLock' c connId name . runExceptT withConnLock' :: AgentClient -> ConnId -> String -> AM' a -> AM' a withConnLock' _ "" _ = id -withConnLock' AgentClient {connLocks} connId name = withLockMap_ connLocks connId name +withConnLock' AgentClient {connLocks} connId name = withLockMap connLocks connId name {-# INLINE withConnLock' #-} withInvLock :: AgentClient -> ByteString -> String -> AM a -> AM a @@ -807,16 +887,16 @@ withInvLock c key name = ExceptT . withInvLock' c key name . runExceptT {-# INLINE withInvLock #-} withInvLock' :: AgentClient -> ByteString -> String -> AM' a -> AM' a -withInvLock' AgentClient {invLocks} = withLockMap_ invLocks +withInvLock' AgentClient {invLocks} = withLockMap invLocks {-# INLINE withInvLock' #-} withConnLocks :: AgentClient -> [ConnId] -> String -> AM' a -> AM' a withConnLocks AgentClient {connLocks} = withLocksMap_ connLocks . filter (not . B.null) {-# INLINE withConnLocks #-} -withLockMap_ :: (Ord k, MonadUnliftIO m) => TMap k Lock -> k -> String -> m a -> m a -withLockMap_ = withGetLock . getMapLock -{-# INLINE withLockMap_ #-} +withLockMap :: (Ord k, MonadUnliftIO m) => TMap k Lock -> k -> String -> m a -> m a +withLockMap = withGetLock . getMapLock +{-# INLINE withLockMap #-} withLocksMap_ :: (Ord k, MonadUnliftIO m) => TMap k Lock -> [k] -> String -> m a -> m a withLocksMap_ = withGetLocks . getMapLock @@ -945,13 +1025,13 @@ runXFTPServerTest :: AgentClient -> UserId -> XFTPServerWithAuth -> AM' (Maybe P runXFTPServerTest c userId (ProtoServerWithAuth srv auth) = do cfg <- asks $ xftpCfg . config g <- asks random - xftpNetworkConfig <- readTVarIO $ useNetworkConfig c + xftpNetworkConfig <- atomically $ getNetworkConfig c workDir <- getXFTPWorkPath filePath <- getTempFilePath workDir rcvPath <- getTempFilePath workDir liftIO $ do let tSess = (userId, srv, Nothing) - X.getXFTPClient tSess cfg {xftpNetworkConfig} (\_ -> pure ()) >>= \case + X.getXFTPClient g tSess cfg {xftpNetworkConfig} (\_ -> pure ()) >>= \case Right xftp -> withTestChunk filePath $ do (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g @@ -1035,7 +1115,7 @@ mkSMPTSession q = mkTSession (qUserId q) (qServer q) (qConnId q) {-# INLINE mkSMPTSession #-} getSessionMode :: AgentClient -> IO TransportSessionMode -getSessionMode = fmap sessionMode . readTVarIO . useNetworkConfig +getSessionMode = atomically . fmap sessionMode . getNetworkConfig {-# INLINE getSessionMode #-} newRcvQueue :: AgentClient -> UserId -> ConnId -> SMPServerWithAuth -> VersionRangeSMPC -> SubscriptionMode -> AM (NewRcvQueue, SMPQueueUri) @@ -1127,7 +1207,7 @@ sendTSessionBatches statCmd statBatchSize toRQ action c qs = where batchQueues :: AM' [(SMPTransportSession, NonEmpty q)] batchQueues = do - mode <- sessionMode <$> readTVarIO (useNetworkConfig c) + mode <- atomically $ sessionMode <$> getNetworkConfig c pure . M.assocs $ foldl' (batch mode) M.empty qs where batch mode m q = @@ -1770,3 +1850,7 @@ $(J.deriveJSON defaultJSON ''WorkersSummary) $(J.deriveJSON defaultJSON {J.fieldLabelModifier = takeWhile (/= '_')} ''AgentWorkersDetails) $(J.deriveJSON defaultJSON ''AgentWorkersSummary) + +$(J.deriveJSON (enumJSON $ dropPrefix "UN") ''UserNetworkType) + +$(J.deriveJSON defaultJSON ''UserNetworkInfo) diff --git a/src/Simplex/Messaging/Agent/Env/SQLite.hs b/src/Simplex/Messaging/Agent/Env/SQLite.hs index a1d060586..02a28ba95 100644 --- a/src/Simplex/Messaging/Agent/Env/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Env/SQLite.hs @@ -92,6 +92,7 @@ data AgentConfig = AgentConfig xftpCfg :: XFTPClientConfig, reconnectInterval :: RetryInterval, messageRetryInterval :: RetryInterval2, + userNetworkInterval :: RetryInterval, messageTimeout :: NominalDiffTime, connDeleteDeliveryTimeout :: NominalDiffTime, helloTimeout :: NominalDiffTime, @@ -126,7 +127,7 @@ defaultReconnectInterval = RetryInterval { initialInterval = 2_000000, increaseAfter = 10_000000, - maxInterval = 180_000000 + maxInterval = 60_000000 } defaultMessageRetryInterval :: RetryInterval2 @@ -134,18 +135,26 @@ defaultMessageRetryInterval = RetryInterval2 { riFast = RetryInterval - { initialInterval = 1_000000, + { initialInterval = 2_000000, increaseAfter = 10_000000, maxInterval = 60_000000 }, riSlow = RetryInterval - { initialInterval = 180_000000, -- 3 minutes + { initialInterval = 300_000000, -- 5 minutes increaseAfter = 60_000000, - maxInterval = 3 * 3600_000000 -- 3 hours + maxInterval = 6 * 3600_000000 -- 6 hours } } +defaultUserNetworkInterval :: RetryInterval +defaultUserNetworkInterval = + RetryInterval + { initialInterval = 1200_000000, -- 20 minutes + increaseAfter = 0, + maxInterval = 7200_000000 -- 2 hours + } + defaultAgentConfig :: AgentConfig defaultAgentConfig = AgentConfig @@ -161,6 +170,7 @@ defaultAgentConfig = xftpCfg = defaultXFTPClientConfig, reconnectInterval = defaultReconnectInterval, messageRetryInterval = defaultMessageRetryInterval, + userNetworkInterval = defaultUserNetworkInterval, messageTimeout = 2 * nominalDay, connDeleteDeliveryTimeout = 2 * nominalDay, helloTimeout = 2 * nominalDay, diff --git a/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs b/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs index 7e47b5ba6..ae0066328 100644 --- a/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs +++ b/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs @@ -160,7 +160,8 @@ runNtfWorker c srv Worker {doWork} = do \nextSub@(NtfSubscription {connId}, _, _) -> do logInfo $ "runNtfWorker, nextSub " <> tshow nextSub ri <- asks $ reconnectInterval . config - withRetryInterval ri $ \_ loop -> + withRetryInterval ri $ \_ loop -> do + lift $ waitForUserNetwork c processSub nextSub `catchAgentError` retryOnError c "NtfWorker" loop (workerInternalError c connId . show) processSub :: (NtfSubscription, NtfSubNTFAction, NtfActionTs) -> AM () @@ -243,7 +244,8 @@ runNtfSMPWorker c srv Worker {doWork} = do \nextSub@(NtfSubscription {connId}, _, _) -> do logInfo $ "runNtfSMPWorker, nextSub " <> tshow nextSub ri <- asks $ reconnectInterval . config - withRetryInterval ri $ \_ loop -> + withRetryInterval ri $ \_ loop -> do + lift $ waitForUserNetwork c processSub nextSub `catchAgentError` retryOnError c "NtfSMPWorker" loop (workerInternalError c connId . show) processSub :: (NtfSubscription, NtfSubSMPAction, NtfActionTs) -> AM () diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index 9c24646e3..4ee8d373f 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -163,6 +163,7 @@ import Data.Aeson (FromJSON (..), ToJSON (..)) import qualified Data.Aeson.TH as J import Data.Attoparsec.ByteString.Char8 (Parser) import qualified Data.Attoparsec.ByteString.Char8 as A +import Data.ByteString.Base64 import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Functor (($>)) @@ -201,7 +202,6 @@ import Simplex.Messaging.Crypto.Ratchet SndE2ERatchetParams ) import Simplex.Messaging.Encoding -import Simplex.Messaging.Encoding.Base64 (base64P, encode) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers import Simplex.Messaging.Protocol @@ -405,6 +405,7 @@ data ACommand (p :: AParty) (e :: AEntity) where MSGNTF :: SMPMsgMeta -> ACommand Agent AEConn ACK :: AgentMsgId -> Maybe MsgReceiptInfo -> ACommand Client AEConn RCVD :: MsgMeta -> NonEmpty MsgReceipt -> ACommand Agent AEConn + QCONT :: ACommand Agent AEConn SWCH :: ACommand Client AEConn OFF :: ACommand Client AEConn DEL :: ACommand Client AEConn @@ -467,6 +468,7 @@ data ACommandTag (p :: AParty) (e :: AEntity) where MSGNTF_ :: ACommandTag Agent AEConn ACK_ :: ACommandTag Client AEConn RCVD_ :: ACommandTag Agent AEConn + QCONT_ :: ACommandTag Agent AEConn SWCH_ :: ACommandTag Client AEConn OFF_ :: ACommandTag Client AEConn DEL_ :: ACommandTag Client AEConn @@ -522,6 +524,7 @@ aCommandTag = \case MSGNTF {} -> MSGNTF_ ACK {} -> ACK_ RCVD {} -> RCVD_ + QCONT -> QCONT_ SWCH -> SWCH_ OFF -> OFF_ DEL -> DEL_ @@ -996,7 +999,7 @@ agentMessageType = \case HELLO -> AM_HELLO_ A_MSG _ -> AM_A_MSG_ A_RCVD {} -> AM_A_RCVD_ - QCONT _ -> AM_QCONT_ + A_QCONT _ -> AM_QCONT_ QADD _ -> AM_QADD_ QKEY _ -> AM_QKEY_ QUSE _ -> AM_QUSE_ @@ -1020,7 +1023,7 @@ data AMsgType = HELLO_ | A_MSG_ | A_RCVD_ - | QCONT_ + | A_QCONT_ | QADD_ | QKEY_ | QUSE_ @@ -1033,7 +1036,7 @@ instance Encoding AMsgType where HELLO_ -> "H" A_MSG_ -> "M" A_RCVD_ -> "V" - QCONT_ -> "QC" + A_QCONT_ -> "QC" QADD_ -> "QA" QKEY_ -> "QK" QUSE_ -> "QU" @@ -1046,7 +1049,7 @@ instance Encoding AMsgType where 'V' -> pure A_RCVD_ 'Q' -> A.anyChar >>= \case - 'C' -> pure QCONT_ + 'C' -> pure A_QCONT_ 'A' -> pure QADD_ 'K' -> pure QKEY_ 'U' -> pure QUSE_ @@ -1066,7 +1069,7 @@ data AMessage | -- | agent envelope for delivery receipt A_RCVD (NonEmpty AMessageReceipt) | -- | the message instructing the client to continue sending messages (after ERR QUOTA) - QCONT SndQAddr + A_QCONT SndQAddr | -- add queue to connection (sent by recipient), with optional address of the replaced queue QADD (NonEmpty (SMPQueueUri, Maybe SndQAddr)) | -- key to secure the added queues and agree e2e encryption key (sent by sender) @@ -1124,7 +1127,7 @@ instance Encoding AMessage where HELLO -> smpEncode HELLO_ A_MSG body -> smpEncode (A_MSG_, Tail body) A_RCVD mrs -> smpEncode (A_RCVD_, mrs) - QCONT addr -> smpEncode (QCONT_, addr) + A_QCONT addr -> smpEncode (A_QCONT_, addr) QADD qs -> smpEncode (QADD_, qs) QKEY qs -> smpEncode (QKEY_, qs) QUSE qs -> smpEncode (QUSE_, qs) @@ -1136,7 +1139,7 @@ instance Encoding AMessage where HELLO_ -> pure HELLO A_MSG_ -> A_MSG . unTail <$> smpP A_RCVD_ -> A_RCVD <$> smpP - QCONT_ -> QCONT <$> smpP + A_QCONT_ -> A_QCONT <$> smpP QADD_ -> QADD <$> smpP QKEY_ -> QKEY <$> smpP QUSE_ -> QUSE <$> smpP @@ -1668,6 +1671,7 @@ instance StrEncoding ACmdTag where "MSGNTF" -> ct MSGNTF_ "ACK" -> t ACK_ "RCVD" -> ct RCVD_ + "QCONT" -> ct QCONT_ "SWCH" -> t SWCH_ "OFF" -> t OFF_ "DEL" -> t DEL_ @@ -1725,6 +1729,7 @@ instance (APartyI p, AEntityI e) => StrEncoding (ACommandTag p e) where MSGNTF_ -> "MSGNTF" ACK_ -> "ACK" RCVD_ -> "RCVD" + QCONT_ -> "QCONT" SWCH_ -> "SWCH" OFF_ -> "OFF" DEL_ -> "DEL" @@ -1794,6 +1799,7 @@ commandP binaryP = MSG_ -> s (MSG <$> strP <* A.space <*> smpP <* A.space <*> binaryP) MSGNTF_ -> s (MSGNTF <$> strP) RCVD_ -> s (RCVD <$> strP <* A.space <*> strP) + QCONT_ -> pure QCONT DEL_RCVQ_ -> s (DEL_RCVQ <$> strP_ <*> strP_ <*> strP) DEL_CONN_ -> pure DEL_CONN DEL_USER_ -> s (DEL_USER <$> strP) @@ -1857,6 +1863,7 @@ serializeCommand = \case MSGNTF smpMsgMeta -> s (MSGNTF_, smpMsgMeta) ACK mId rcptInfo_ -> s (ACK_, mId) <> maybe "" (B.cons ' ' . serializeBinary) rcptInfo_ RCVD msgMeta rcpts -> s (RCVD_, msgMeta, rcpts) + QCONT -> s QCONT_ SWCH -> s SWCH_ OFF -> s OFF_ DEL -> s DEL_ diff --git a/src/Simplex/Messaging/Agent/RetryInterval.hs b/src/Simplex/Messaging/Agent/RetryInterval.hs index b75fd9a60..00fe4039e 100644 --- a/src/Simplex/Messaging/Agent/RetryInterval.hs +++ b/src/Simplex/Messaging/Agent/RetryInterval.hs @@ -11,6 +11,7 @@ module Simplex.Messaging.Agent.RetryInterval withRetryIntervalCount, withRetryLock2, updateRetryInterval2, + nextRetryDelay, ) where @@ -60,7 +61,7 @@ withRetryIntervalCount ri action = callAction 0 0 $ initialInterval ri loop = do liftIO $ threadDelay' delay let elapsed' = elapsed + delay - callAction (n + 1) elapsed' $ nextDelay elapsed' delay ri + callAction (n + 1) elapsed' $ nextRetryDelay elapsed' delay ri -- This function allows action to toggle between slow and fast retry intervals. withRetryLock2 :: forall m. MonadIO m => RetryInterval2 -> TMVar () -> (RI2State -> (RetryIntervalMode -> m ()) -> m ()) -> m () @@ -76,7 +77,7 @@ withRetryLock2 RetryInterval2 {riSlow, riFast} lock action = run (elapsed, delay) ri call = do wait delay let elapsed' = elapsed + delay - delay' = nextDelay elapsed' delay ri + delay' = nextRetryDelay elapsed' delay ri call (elapsed', delay') wait delay = do waiting <- newTVarIO True @@ -87,8 +88,8 @@ withRetryLock2 RetryInterval2 {riSlow, riFast} lock action = takeTMVar lock writeTVar waiting False -nextDelay :: Int64 -> Int64 -> RetryInterval -> Int64 -nextDelay elapsed delay RetryInterval {increaseAfter, maxInterval} = +nextRetryDelay :: Int64 -> Int64 -> RetryInterval -> Int64 +nextRetryDelay elapsed delay RetryInterval {increaseAfter, maxInterval} = if elapsed < increaseAfter || delay == maxInterval then delay else min (delay * 3 `div` 2) maxInterval diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index 4f5c1573b..b8b1c7c52 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -231,6 +231,7 @@ import Data.Bifunctor (first, second) import Data.ByteArray (ScrubbedBytes) import qualified Data.ByteArray as BA import Data.ByteString (ByteString) +import qualified Data.ByteString.Base64.URL as U import qualified Data.ByteString.Char8 as B import Data.Char (toLower) import Data.Functor (($>)) @@ -270,7 +271,6 @@ import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..)) import Simplex.Messaging.Crypto.Ratchet (RatchetX448, SkippedMsgDiff (..), SkippedMsgKeys, PQEncryption (..), PQSupport (..)) import qualified Simplex.Messaging.Crypto.Ratchet as CR import Simplex.Messaging.Encoding -import qualified Simplex.Messaging.Encoding.Base64.URL as U import Simplex.Messaging.Encoding.String import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfSubscriptionId, NtfTknStatus (..), NtfTokenId, SMPQueueNtf (..)) import Simplex.Messaging.Notifications.Types @@ -1214,7 +1214,7 @@ setRatchetX3dhKeys db connId x3dhPrivKey1 x3dhPrivKey2 pqPrivKem = db [sql| UPDATE ratchets - SET x3dh_priv_key_1 = ?, x3dh_priv_key_2 = ?, x3dh_pub_key_1 = ?, x3dh_pub_key_2 = ?, pq_priv_kem = ? + SET x3dh_priv_key_1 = ?, x3dh_priv_key_2 = ?, x3dh_pub_key_1 = ?, x3dh_pub_key_2 = ?, pq_priv_kem = ? WHERE conn_id = ? |] (x3dhPrivKey1, x3dhPrivKey2, C.publicKey x3dhPrivKey1, C.publicKey x3dhPrivKey2, pqPrivKem, connId) diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index b7613f4dc..e0591b14d 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -207,7 +207,7 @@ data NetworkConfig = NetworkConfig -- | timeout of protocol commands (microseconds) tcpTimeout :: Int, -- | additional timeout per kilobyte (1024 bytes) to be sent - tcpTimeoutPerKb :: Int, + tcpTimeoutPerKb :: Int64, -- | TCP keep-alive options, Nothing to skip enabling keep-alive tcpKeepAlive :: Maybe KeepAliveOpts, -- | period for SMP ping commands (microseconds, 0 to disable) @@ -230,7 +230,7 @@ defaultNetworkConfig = sessionMode = TSMUser, tcpConnectTimeout = 20_000_000, tcpTimeout = 15_000_000, - tcpTimeoutPerKb = 45_000, -- 45ms, should be less than 130ms to avoid Int overflow on 32 bit systems + tcpTimeoutPerKb = 5_000, tcpKeepAlive = Just defaultKeepAliveOpts, smpPingInterval = 600_000_000, -- 10min smpPingCount = 3, @@ -239,7 +239,7 @@ defaultNetworkConfig = transportClientConfig :: NetworkConfig -> TransportClientConfig transportClientConfig NetworkConfig {socksProxy, tcpKeepAlive, logTLSErrors} = - TransportClientConfig {socksProxy, tcpKeepAlive, logTLSErrors, clientCredentials = Nothing} + TransportClientConfig {socksProxy, tcpKeepAlive, logTLSErrors, clientCredentials = Nothing, alpn = Nothing} {-# INLINE transportClientConfig #-} -- | protocol client configuration. diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs index 84d1882fa..28183a1fc 100644 --- a/src/Simplex/Messaging/Crypto.hs +++ b/src/Simplex/Messaging/Crypto.hs @@ -211,6 +211,8 @@ import qualified Data.Attoparsec.ByteString.Char8 as A import Data.Bifunctor (bimap, first) import Data.ByteArray (ByteArrayAccess) import qualified Data.ByteArray as BA +import Data.ByteString.Base64 (decode, encode) +import qualified Data.ByteString.Base64.URL as U import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.ByteString.Lazy (fromStrict, toStrict) @@ -228,8 +230,6 @@ import Database.SQLite.Simple.ToField (ToField (..)) import GHC.TypeLits (ErrorMessage (..), KnownNat, Nat, TypeError, natVal, type (+)) import Network.Transport.Internal (decodeWord16, encodeWord16) import Simplex.Messaging.Encoding -import Simplex.Messaging.Encoding.Base64 (decode, encode) -import qualified Simplex.Messaging.Encoding.Base64.URL as U import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (blobFieldDecoder, parseAll, parseString) import Simplex.Messaging.Util ((<$?>)) diff --git a/src/Simplex/Messaging/Encoding/Base64.hs b/src/Simplex/Messaging/Encoding/Base64.hs deleted file mode 100644 index 951250abc..000000000 --- a/src/Simplex/Messaging/Encoding/Base64.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | Compatibility wrappers for base64 package, Base64 (padded) variant. -module Simplex.Messaging.Encoding.Base64 where - -import qualified Data.Attoparsec.ByteString.Char8 as A -import Data.Base64.Types (extractBase64) -import Data.Bifunctor (first) -import Data.ByteString.Base64 (decodeBase64Untyped, encodeBase64') -import Data.ByteString.Char8 (ByteString) -import qualified Data.ByteString.Char8 as B -import qualified Data.Text as T - -encode :: ByteString -> ByteString -encode = extractBase64 . encodeBase64' -{-# INLINE encode #-} - -decode :: ByteString -> Either String ByteString -decode = first T.unpack . decodeBase64Untyped -{-# INLINE decode #-} - -base64P :: A.Parser ByteString -base64P = do - str <- A.takeWhile1 (`B.elem` base64Alphabet) - pad <- A.takeWhile (== '=') -- correct amount of padding can be derived from str length - either (fail . T.unpack) pure $ decodeBase64Untyped (str <> pad) - -base64Alphabet :: ByteString -base64Alphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" diff --git a/src/Simplex/Messaging/Encoding/Base64/URL.hs b/src/Simplex/Messaging/Encoding/Base64/URL.hs deleted file mode 100644 index 247002376..000000000 --- a/src/Simplex/Messaging/Encoding/Base64/URL.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | Compatibility wrappers for base64 package, Base64URL-padded variant. -module Simplex.Messaging.Encoding.Base64.URL where - -import qualified Data.Attoparsec.ByteString.Char8 as A -import Data.Base64.Types (extractBase64) -import Data.Bifunctor (first) -import Data.ByteString.Base64.URL (decodeBase64Lenient, decodeBase64UnpaddedUntyped, decodeBase64Untyped, encodeBase64') -import Data.ByteString.Char8 (ByteString) -import qualified Data.ByteString.Char8 as B -import qualified Data.Text as T - -encode :: ByteString -> ByteString -encode = extractBase64 . encodeBase64' -{-# INLINE encode #-} - -decode :: ByteString -> Either String ByteString -decode = first T.unpack . decodeBase64Untyped -{-# INLINE decode #-} - -decodeLenient :: ByteString -> ByteString -decodeLenient = decodeBase64Lenient -{-# INLINE decodeLenient #-} - -base64urlP :: A.Parser ByteString -base64urlP = do - str <- A.takeWhile1 (`B.elem` base64AlphabetURL) - _pad <- A.takeWhile (== '=') -- correct amount of padding can be derived from str length - either (fail . T.unpack) pure $ decodeBase64UnpaddedUntyped str - -base64AlphabetURL :: ByteString -base64AlphabetURL = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_" diff --git a/src/Simplex/Messaging/Encoding/String.hs b/src/Simplex/Messaging/Encoding/String.hs index 46dc659a9..fcefdc73d 100644 --- a/src/Simplex/Messaging/Encoding/String.hs +++ b/src/Simplex/Messaging/Encoding/String.hs @@ -10,6 +10,7 @@ module Simplex.Messaging.Encoding.String strToJSON, strToJEncoding, strParseJSON, + base64urlP, strEncodeList, strListP, ) @@ -22,8 +23,10 @@ import qualified Data.Aeson.Encoding as JE import qualified Data.Aeson.Types as JT import Data.Attoparsec.ByteString.Char8 (Parser) import qualified Data.Attoparsec.ByteString.Char8 as A +import qualified Data.ByteString.Base64.URL as U import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B +import Data.Char (isAlphaNum) import Data.Int (Int64) import qualified Data.List.NonEmpty as L import Data.Set (Set) @@ -35,7 +38,6 @@ import Data.Time.Clock.System (SystemTime (..)) import Data.Time.Format.ISO8601 import Data.Word (Word16, Word32) import Simplex.Messaging.Encoding -import qualified Simplex.Messaging.Encoding.Base64.URL as U import Simplex.Messaging.Parsers (parseAll) import Simplex.Messaging.Util ((<$?>)) @@ -52,16 +54,19 @@ class StrEncoding a where strDecode :: ByteString -> Either String a strDecode = parseAll strP strP :: Parser a - strP = strDecode <$?> U.base64urlP + strP = strDecode <$?> base64urlP -- base64url encoding/decoding of ByteStrings - the parser only allows non-empty strings instance StrEncoding ByteString where strEncode = U.encode - {-# INLINE strEncode #-} strDecode = U.decode - {-# INLINE strDecode #-} - strP = U.base64urlP - {-# INLINE strP #-} + strP = base64urlP + +base64urlP :: Parser ByteString +base64urlP = do + str <- A.takeWhile1 (\c -> isAlphaNum c || c == '-' || c == '_') + pad <- A.takeWhile (== '=') + either fail pure $ U.decode (str <> pad) newtype Str = Str {unStr :: ByteString} deriving (Eq, Show) diff --git a/src/Simplex/Messaging/Notifications/Protocol.hs b/src/Simplex/Messaging/Notifications/Protocol.hs index 943c30c5a..2c3d2e4df 100644 --- a/src/Simplex/Messaging/Notifications/Protocol.hs +++ b/src/Simplex/Messaging/Notifications/Protocol.hs @@ -11,12 +11,14 @@ module Simplex.Messaging.Notifications.Protocol where +import Control.Applicative ((<|>)) import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.=)) import qualified Data.Aeson as J import qualified Data.Aeson.Encoding as JE import qualified Data.Attoparsec.ByteString.Char8 as A import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B +import Data.Functor (($>)) import Data.Kind import Data.Maybe (isNothing) import Data.Text.Encoding (decodeLatin1, encodeUtf8) @@ -406,10 +408,12 @@ instance Encoding DeviceToken where instance StrEncoding DeviceToken where strEncode (DeviceToken p t) = strEncode p <> " " <> t - strP = DeviceToken <$> strP <* A.space <*> hexStringP + strP = nullToken <|> hexToken where + nullToken = "apns_null test_ntf_token" $> DeviceToken PPApnsNull "test_ntf_token" + hexToken = DeviceToken <$> strP <* A.space <*> hexStringP hexStringP = - A.takeWhile (\c -> A.isDigit c || (c >= 'a' && c <= 'f')) >>= \s -> + A.takeWhile (`B.elem` "0123456789abcdef") >>= \s -> if even (B.length s) then pure s else fail "odd number of hex characters" instance ToJSON DeviceToken where diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs index 2580e58fd..55ab40718 100644 --- a/src/Simplex/Messaging/Notifications/Server.hs +++ b/src/Simplex/Messaging/Notifications/Server.hs @@ -108,7 +108,7 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do logServerStats :: Int64 -> Int64 -> FilePath -> M () logServerStats startAt logInterval statsFilePath = do initialDelay <- (startAt -) . fromIntegral . (`div` 1000000_000000) . diffTimeToPicoseconds . utctDayTime <$> liftIO getCurrentTime - liftIO $ putStrLn $ "server stats log enabled: " <> statsFilePath + logInfo $ "server stats log enabled: " <> T.pack statsFilePath liftIO $ threadDelay' $ 1000000 * (initialDelay + if initialDelay < 0 then 86400 else 0) NtfServerStats {fromTime, tknCreated, tknVerified, tknDeleted, subCreated, subDeleted, ntfReceived, ntfDelivered, activeTokens, activeSubs} <- asks serverStats let interval = 1000000 * logInterval @@ -442,7 +442,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu where processCommand :: NtfRequest -> M (Transmission NtfResponse) processCommand = \case - NtfReqNew corrId (ANE SToken newTkn@(NewNtfTkn _ _ dhPubKey)) -> do + NtfReqNew corrId (ANE SToken newTkn@(NewNtfTkn token _ dhPubKey)) -> do logDebug "TNEW - new token" st <- asks store ks@(srvDhPubKey, srvDhPrivKey) <- atomically . C.generateKeyPair =<< asks random @@ -453,9 +453,9 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu atomically $ addNtfToken st tknId tkn atomically $ writeTBQueue pushQ (tkn, PNVerification regCode) withNtfLog (`logCreateToken` tkn) - incNtfStat tknCreated + incNtfStatT token tknCreated pure (corrId, "", NRTknId tknId srvDhPubKey) - NtfReqCmd SToken (NtfTkn tkn@NtfTknData {ntfTknId, tknStatus, tknRegCode, tknDhSecret, tknDhKeys = (srvDhPubKey, srvDhPrivKey), tknCronInterval}) (corrId, tknId, cmd) -> do + NtfReqCmd SToken (NtfTkn tkn@NtfTknData {token, ntfTknId, tknStatus, tknRegCode, tknDhSecret, tknDhKeys = (srvDhPubKey, srvDhPrivKey), tknCronInterval}) (corrId, tknId, cmd) -> do status <- readTVarIO tknStatus (corrId,tknId,) <$> case cmd of TNEW (NewNtfTkn _ _ dhPubKey) -> do @@ -474,7 +474,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu updateTknStatus tkn NTActive tIds <- atomically $ removeInactiveTokenRegistrations st tkn forM_ tIds cancelInvervalNotifications - incNtfStat tknVerified + incNtfStatT token tknVerified pure NROk | otherwise -> do logDebug "TVFY - incorrect code or token status" @@ -493,8 +493,8 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu addNtfToken st tknId tkn' writeTBQueue pushQ (tkn', PNVerification regCode) withNtfLog $ \s -> logUpdateToken s tknId token' regCode - incNtfStat tknDeleted - incNtfStat tknCreated + incNtfStatT token tknDeleted + incNtfStatT token tknCreated pure NROk TDEL -> do logDebug "TDEL" @@ -504,7 +504,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu atomically $ removeSubscription ca smpServer (SPNotifier, notifierId) cancelInvervalNotifications tknId withNtfLog (`logDeleteToken` tknId) - incNtfStat tknDeleted + incNtfStatT token tknDeleted pure NROk TCRN 0 -> do logDebug "TCRN 0" @@ -583,6 +583,10 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu withNtfLog :: (StoreLog 'WriteMode -> IO a) -> M () withNtfLog action = liftIO . mapM_ action =<< asks storeLog +incNtfStatT :: DeviceToken -> (NtfServerStats -> TVar Int) -> M () +incNtfStatT (DeviceToken PPApnsNull _) _ = pure () +incNtfStatT _ statSel = incNtfStat statSel + incNtfStat :: (NtfServerStats -> TVar Int) -> M () incNtfStat statSel = do stats <- asks serverStats diff --git a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs index 45f6bf637..151f5e044 100644 --- a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs +++ b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs @@ -27,9 +27,8 @@ import Data.Aeson (ToJSON, (.=)) import qualified Data.Aeson as J import qualified Data.Aeson.Encoding as JE import qualified Data.Aeson.TH as JQ -import Data.Base64.Types (extractBase64) import Data.Bifunctor (first) -import qualified Data.ByteString.Base64.URL as UP +import qualified Data.ByteString.Base64.URL as U import Data.ByteString.Builder (lazyByteString) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Lazy.Char8 as LB @@ -47,7 +46,6 @@ import Network.HTTP2.Client (Request) import qualified Network.HTTP2.Client as H import Network.Socket (HostName, ServiceName) import qualified Simplex.Messaging.Crypto as C -import qualified Simplex.Messaging.Encoding.Base64.URL as U import Simplex.Messaging.Encoding.String import Simplex.Messaging.Notifications.Protocol import Simplex.Messaging.Notifications.Server.Push.APNS.Internal @@ -56,7 +54,7 @@ import Simplex.Messaging.Parsers (defaultJSON) import Simplex.Messaging.Protocol (EncNMsgMeta) import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..)) import Simplex.Messaging.Transport.HTTP2.Client -import Simplex.Messaging.Util (safeDecodeUtf8) +import Simplex.Messaging.Util (safeDecodeUtf8, tshow) import System.Environment (getEnv) import UnliftIO.STM @@ -93,8 +91,8 @@ signedJWTToken pk (JWTToken hdr claims) = do pure $ hc <> "." <> serialize sig where jwtEncode :: ToJSON a => a -> ByteString - jwtEncode = extractBase64 . UP.encodeBase64Unpadded' . LB.toStrict . J.encode - serialize sig = extractBase64 . UP.encodeBase64Unpadded' $ encodeASN1' DER [Start Sequence, IntVal (EC.sign_r sig), IntVal (EC.sign_s sig), End Sequence] + jwtEncode = U.encodeUnpadded . LB.toStrict . J.encode + serialize sig = U.encodeUnpadded $ encodeASN1' DER [Start Sequence, IntVal (EC.sign_r sig), IntVal (EC.sign_s sig), End Sequence] readECPrivateKey :: FilePath -> IO EC.PrivateKey readECPrivateKey f = do @@ -260,11 +258,11 @@ mkApnsJWTToken appTeamId jwtHeader privateKey = do connectHTTPS2 :: HostName -> APNSPushClientConfig -> TVar (Maybe HTTP2Client) -> IO (Either HTTP2ClientError HTTP2Client) connectHTTPS2 apnsHost APNSPushClientConfig {apnsPort, http2cfg, caStoreFile} https2Client = do caStore_ <- XS.readCertificateStore caStoreFile - when (isNothing caStore_) $ putStrLn $ "Error loading CertificateStore from " <> caStoreFile + when (isNothing caStore_) $ logError $ "Error loading CertificateStore from " <> T.pack caStoreFile r <- getHTTP2Client apnsHost apnsPort caStore_ http2cfg disconnected case r of Right client -> atomically . writeTVar https2Client $ Just client - Left e -> putStrLn $ "Error connecting to APNS: " <> show e + Left e -> logError $ "Error connecting to APNS: " <> tshow e pure r where disconnected = atomically $ writeTVar https2Client Nothing diff --git a/src/Simplex/Messaging/Notifications/Server/StoreLog.hs b/src/Simplex/Messaging/Notifications/Server/StoreLog.hs index cc2a1802e..d43700ad3 100644 --- a/src/Simplex/Messaging/Notifications/Server/StoreLog.hs +++ b/src/Simplex/Messaging/Notifications/Server/StoreLog.hs @@ -24,9 +24,12 @@ module Simplex.Messaging.Notifications.Server.StoreLog where import Control.Concurrent.STM +import Control.Logger.Simple import Control.Monad import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as LB +import qualified Data.Text as T import Data.Word (Word16) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String @@ -34,7 +37,7 @@ import Simplex.Messaging.Notifications.Protocol import Simplex.Messaging.Notifications.Server.Store import Simplex.Messaging.Protocol (NtfPrivateAuthKey) import Simplex.Messaging.Server.StoreLog -import Simplex.Messaging.Util (whenM) +import Simplex.Messaging.Util (safeDecodeUtf8, whenM) import System.Directory (doesFileExist, renameFile) import System.IO @@ -189,10 +192,10 @@ readWriteNtfStore f st = do pure s readNtfStore :: FilePath -> NtfStore -> IO () -readNtfStore f st = mapM_ addNtfLogRecord . B.lines =<< B.readFile f +readNtfStore f st = mapM_ (addNtfLogRecord . LB.toStrict) . LB.lines =<< LB.readFile f where addNtfLogRecord s = case strDecode s of - Left e -> B.putStrLn $ "Log parsing error (" <> B.pack e <> "): " <> B.take 100 s + Left e -> logError $ "Log parsing error (" <> T.pack e <> "): " <> safeDecodeUtf8 (B.take 100 s) Right lr -> atomically $ case lr of CreateToken r@NtfTknRec {ntfTknId} -> do tkn <- mkTknData r diff --git a/src/Simplex/Messaging/Parsers.hs b/src/Simplex/Messaging/Parsers.hs index 17486ab9c..39cb0383c 100644 --- a/src/Simplex/Messaging/Parsers.hs +++ b/src/Simplex/Messaging/Parsers.hs @@ -10,9 +10,10 @@ import qualified Data.Aeson as J import Data.Attoparsec.ByteString.Char8 (Parser) import qualified Data.Attoparsec.ByteString.Char8 as A import Data.Bifunctor (first) +import Data.ByteString.Base64 import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B -import Data.Char (toLower) +import Data.Char (isAlphaNum, toLower) import Data.String import Data.Text (Text) import qualified Data.Text as T @@ -23,8 +24,23 @@ import Database.SQLite.Simple (ResultError (..), SQLData (..)) import Database.SQLite.Simple.FromField (FieldParser, returnError) import Database.SQLite.Simple.Internal (Field (..)) import Database.SQLite.Simple.Ok (Ok (Ok)) +import Simplex.Messaging.Util ((<$?>)) import Text.Read (readMaybe) +base64P :: Parser ByteString +base64P = decode <$?> paddedBase64 rawBase64P + +paddedBase64 :: Parser ByteString -> Parser ByteString +paddedBase64 raw = (<>) <$> raw <*> pad + where + pad = A.takeWhile (== '=') + +rawBase64P :: Parser ByteString +rawBase64P = A.takeWhile1 (\c -> isAlphaNum c || c == '+' || c == '/') + +-- rawBase64UriP :: Parser ByteString +-- rawBase64UriP = A.takeWhile1 (\c -> isAlphaNum c || c == '-' || c == '_') + tsISO8601P :: Parser UTCTime tsISO8601P = maybe (fail "timestamp") pure . parseISO8601 . B.unpack =<< A.takeTill wordEnd diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index 5643fdf4b..dcf48fa16 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -176,6 +176,7 @@ import qualified Data.Aeson.TH as J import Data.Attoparsec.ByteString.Char8 (Parser, ()) import qualified Data.Attoparsec.ByteString.Char8 as A import Data.Bifunctor (first) +import qualified Data.ByteString.Base64 as B64 import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Char (isPrint, isSpace) @@ -193,7 +194,6 @@ import GHC.TypeLits (ErrorMessage (..), TypeError, type (+)) import Network.Socket (ServiceName) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding -import qualified Simplex.Messaging.Encoding.Base64 as B64 import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers import Simplex.Messaging.ServiceScheme diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 0299bebfc..4535c7bd5 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -45,8 +45,10 @@ import Control.Monad.IO.Unlift import Control.Monad.Reader import Crypto.Random import Data.Bifunctor (first) +import Data.ByteString.Base64 (encode) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as LB import Data.Either (fromRight, partitionEithers) import Data.Functor (($>)) import Data.Int (Int64) @@ -67,7 +69,6 @@ import Network.Socket (ServiceName, Socket, socketToHandle) import Simplex.Messaging.Agent.Lock import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding (Encoding (smpEncode)) -import Simplex.Messaging.Encoding.Base64 (encode) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol import Simplex.Messaging.Server.Control @@ -983,7 +984,7 @@ restoreServerMessages = asks (storeMsgsFile . config) >>= \case ms <- asks msgStore quota <- asks $ msgQueueQuota . config old_ <- asks (messageExpiration . config) $>>= (liftIO . fmap Just . expireBeforeEpoch) - runExceptT (liftIO (B.readFile f) >>= foldM (\expired -> restoreMsg expired ms quota old_) 0 . B.lines) >>= \case + runExceptT (liftIO (LB.readFile f) >>= foldM (\expired -> restoreMsg expired ms quota old_) 0 . LB.lines) >>= \case Left e -> do logError . T.pack $ "error restoring messages: " <> e liftIO exitFailure @@ -992,10 +993,11 @@ restoreServerMessages = asks (storeMsgsFile . config) >>= \case logInfo "messages restored" pure expired where - restoreMsg !expired ms quota old_ s = do + restoreMsg !expired ms quota old_ s' = do MLRv3 rId msg <- liftEither . first (msgErr "parsing") $ strDecode s addToMsgQueue rId msg where + s = LB.toStrict s' addToMsgQueue rId msg = do (isExpired, logFull) <- atomically $ do q <- getMsgQueue ms rId quota diff --git a/src/Simplex/Messaging/Server/StoreLog.hs b/src/Simplex/Messaging/Server/StoreLog.hs index b3f5486b8..b1011c404 100644 --- a/src/Simplex/Messaging/Server/StoreLog.hs +++ b/src/Simplex/Messaging/Server/StoreLog.hs @@ -25,8 +25,8 @@ where import Control.Applicative (optional, (<|>)) import Control.Monad (foldM, unless, when) -import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as LB import Data.Functor (($>)) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M @@ -148,13 +148,14 @@ writeQueues s = mapM_ $ \q -> when (active q) $ logCreateQueue s q active QueueRec {status} = status == QueueActive readQueues :: FilePath -> IO (Map RecipientId QueueRec) -readQueues f = foldM processLine M.empty . B.lines =<< B.readFile f +readQueues f = foldM processLine M.empty . LB.lines =<< LB.readFile f where - processLine :: Map RecipientId QueueRec -> ByteString -> IO (Map RecipientId QueueRec) - processLine m s = case strDecode $ trimCR s of + processLine :: Map RecipientId QueueRec -> LB.ByteString -> IO (Map RecipientId QueueRec) + processLine m s' = case strDecode $ trimCR s of Right r -> pure $ procLogRecord r Left e -> printError e $> m where + s = LB.toStrict s' procLogRecord :: StoreLogRecord -> Map RecipientId QueueRec procLogRecord = \case CreateQueue q -> M.insert (recipientId q) q m diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs index 775400260..6898af15d 100644 --- a/src/Simplex/Messaging/Transport.hs +++ b/src/Simplex/Messaging/Transport.hs @@ -54,6 +54,7 @@ module Simplex.Messaging.Transport -- * TLS Transport TLS (..), SessionId, + ALPN, connectTLS, closeTLS, supportedParameters, @@ -228,10 +229,13 @@ data TLS = TLS tlsPeer :: TransportPeer, tlsUniq :: ByteString, tlsBuffer :: TBuffer, + tlsALPN :: Maybe ALPN, tlsServerCerts :: X.CertificateChain, tlsTransportConfig :: TransportConfig } +type ALPN = ByteString + connectTLS :: T.TLSParams p => Maybe HostName -> TransportConfig -> p -> Socket -> IO T.Context connectTLS host_ TransportConfig {logTLSErrors} params sock = E.bracketOnError (T.contextNew sock params) closeTLS $ \ctx -> @@ -246,7 +250,8 @@ getTLS tlsPeer cfg tlsServerCerts cxt = withTlsUnique tlsPeer cxt newTLS where newTLS tlsUniq = do tlsBuffer <- atomically newTBuffer - pure TLS {tlsContext = cxt, tlsTransportConfig = cfg, tlsServerCerts, tlsPeer, tlsUniq, tlsBuffer} + tlsALPN <- T.getNegotiatedProtocol cxt + pure TLS {tlsContext = cxt, tlsALPN, tlsTransportConfig = cfg, tlsServerCerts, tlsPeer, tlsUniq, tlsBuffer} withTlsUnique :: TransportPeer -> T.Context -> (ByteString -> IO c) -> IO c withTlsUnique peer cxt f = diff --git a/src/Simplex/Messaging/Transport/Client.hs b/src/Simplex/Messaging/Transport/Client.hs index 8cca76043..daea3982e 100644 --- a/src/Simplex/Messaging/Transport/Client.hs +++ b/src/Simplex/Messaging/Transport/Client.hs @@ -17,6 +17,7 @@ module Simplex.Messaging.Transport.Client TransportHost (..), TransportHosts (..), TransportHosts_ (..), + validateCertificateChain ) where @@ -113,12 +114,13 @@ data TransportClientConfig = TransportClientConfig { socksProxy :: Maybe SocksProxy, tcpKeepAlive :: Maybe KeepAliveOpts, logTLSErrors :: Bool, - clientCredentials :: Maybe (X.CertificateChain, T.PrivKey) + clientCredentials :: Maybe (X.CertificateChain, T.PrivKey), + alpn :: Maybe [ALPN] } deriving (Eq, Show) defaultTransportClientConfig :: TransportClientConfig -defaultTransportClientConfig = TransportClientConfig Nothing (Just defaultKeepAliveOpts) True Nothing +defaultTransportClientConfig = TransportClientConfig Nothing (Just defaultKeepAliveOpts) True Nothing Nothing clientTransportConfig :: TransportClientConfig -> TransportConfig clientTransportConfig TransportClientConfig {logTLSErrors} = @@ -129,10 +131,10 @@ runTransportClient :: Transport c => TransportClientConfig -> Maybe ByteString - runTransportClient = runTLSTransportClient supportedParameters Nothing runTLSTransportClient :: Transport c => T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> Maybe ByteString -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c -> IO a) -> IO a -runTLSTransportClient tlsParams caStore_ cfg@TransportClientConfig {socksProxy, tcpKeepAlive, clientCredentials} proxyUsername host port keyHash client = do +runTLSTransportClient tlsParams caStore_ cfg@TransportClientConfig {socksProxy, tcpKeepAlive, clientCredentials, alpn} proxyUsername host port keyHash client = do serverCert <- newEmptyTMVarIO let hostName = B.unpack $ strEncode host - clientParams = mkTLSClientParams tlsParams caStore_ hostName port keyHash clientCredentials serverCert + clientParams = mkTLSClientParams tlsParams caStore_ hostName port keyHash clientCredentials alpn serverCert connectTCP = case socksProxy of Just proxy -> connectSocksClient proxy proxyUsername $ hostAddr host _ -> connectTCPClient hostName @@ -215,14 +217,15 @@ instance ToJSON SocksProxy where instance FromJSON SocksProxy where parseJSON = strParseJSON "SocksProxy" -mkTLSClientParams :: T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe C.KeyHash -> Maybe (X.CertificateChain, T.PrivKey) -> TMVar X.CertificateChain -> T.ClientParams -mkTLSClientParams supported caStore_ host port cafp_ clientCreds_ serverCerts = +mkTLSClientParams :: T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe C.KeyHash -> Maybe (X.CertificateChain, T.PrivKey) -> Maybe [ALPN] -> TMVar X.CertificateChain -> T.ClientParams +mkTLSClientParams supported caStore_ host port cafp_ clientCreds_ alpn_ serverCerts = (T.defaultParamsClient host p) { T.clientShared = def {T.sharedCAStore = fromMaybe (T.sharedCAStore def) caStore_}, T.clientHooks = def { T.onServerCertificate = onServerCert, - T.onCertificateRequest = maybe def (const . pure . Just) clientCreds_ + T.onCertificateRequest = maybe def (const . pure . Just) clientCreds_, + T.onSuggestALPN = pure alpn_ }, T.clientSupported = supported } @@ -237,7 +240,7 @@ mkTLSClientParams supported caStore_ host port cafp_ clientCreds_ serverCerts = validateCertificateChain :: C.KeyHash -> HostName -> ByteString -> X.CertificateChain -> IO [XV.FailedReason] validateCertificateChain _ _ _ (X.CertificateChain []) = pure [XV.EmptyChain] validateCertificateChain _ _ _ (X.CertificateChain [_]) = pure [XV.EmptyChain] -validateCertificateChain (C.KeyHash kh) host port cc@(X.CertificateChain sc@[_, caCert]) = +validateCertificateChain (C.KeyHash kh) host port cc@(X.CertificateChain [_, caCert]) = if Fingerprint kh == XV.getFingerprint caCert X.HashSHA256 then x509validate else pure [XV.UnknownCA] @@ -247,7 +250,7 @@ validateCertificateChain (C.KeyHash kh) host port cc@(X.CertificateChain sc@[_, where hooks = XV.defaultHooks checks = XV.defaultChecks {XV.checkFQHN = False} - certStore = XS.makeCertificateStore sc + certStore = XS.makeCertificateStore [caCert] cache = XV.exceptionValidationCache [] -- we manually check fingerprint only of the identity certificate (ca.crt) serviceID = (host, port) validateCertificateChain _ _ _ _ = pure [XV.AuthorityTooDeep] diff --git a/src/Simplex/Messaging/Transport/HTTP2.hs b/src/Simplex/Messaging/Transport/HTTP2.hs index 511f5d322..9c6cd7abc 100644 --- a/src/Simplex/Messaging/Transport/HTTP2.hs +++ b/src/Simplex/Messaging/Transport/HTTP2.hs @@ -16,15 +16,15 @@ import qualified Network.HTTP2.Server as HS import Network.Socket (SockAddr (..)) import qualified Network.TLS as T import qualified Network.TLS.Extra as TE -import Simplex.Messaging.Transport (SessionId, TLS (tlsUniq), Transport (cGet, cPut)) +import Simplex.Messaging.Transport (TLS, Transport (cGet, cPut)) import Simplex.Messaging.Transport.Buffer import qualified System.TimeManager as TI defaultHTTP2BufferSize :: BufferSize defaultHTTP2BufferSize = 32768 -withHTTP2 :: BufferSize -> (Config -> SessionId -> IO a) -> TLS -> IO a -withHTTP2 sz run c = E.bracket (allocHTTP2Config c sz) freeSimpleConfig (`run` tlsUniq c) +withHTTP2 :: BufferSize -> (Config -> IO a) -> IO () -> TLS -> IO a +withHTTP2 sz run fin c = E.bracket (allocHTTP2Config c sz) (\cfg -> freeSimpleConfig cfg `E.finally` fin) run allocHTTP2Config :: TLS -> BufferSize -> IO Config allocHTTP2Config c sz = do diff --git a/src/Simplex/Messaging/Transport/HTTP2/Client.hs b/src/Simplex/Messaging/Transport/HTTP2/Client.hs index 17ddb9807..b279c1805 100644 --- a/src/Simplex/Messaging/Transport/HTTP2/Client.hs +++ b/src/Simplex/Messaging/Transport/HTTP2/Client.hs @@ -23,15 +23,20 @@ import qualified Network.TLS as T import Numeric.Natural (Natural) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Transport (SessionId, TLS) +import Simplex.Messaging.Transport (ALPN, SessionId, TLS (tlsALPN), getServerCerts, getServerVerifyKey, tlsUniq) 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), sessionId :: SessionId, + sessionALPN :: Maybe ALPN, + serverKey :: Maybe C.APublicVerifyKey, -- may not always be a key we control (i.e. APNS with apple-mandated key types) + serverCerts :: X.CertificateChain, sessionTs :: UTCTime, sendReq :: Request -> (Response -> IO HTTP2Response) -> IO HTTP2Response, client_ :: HClient @@ -66,7 +71,7 @@ defaultHTTP2ClientConfig = HTTP2ClientConfig { qSize = 64, connTimeout = 10000000, - transportConfig = TransportClientConfig Nothing Nothing True Nothing, + transportConfig = TransportClientConfig Nothing Nothing True Nothing Nothing, bufferSize = defaultHTTP2BufferSize, bodyHeadSize = 16384, suportedTLSParams = http2TLSParams @@ -86,9 +91,10 @@ getVerifiedHTTP2Client proxyUsername host port keyHash caStore config disconnect attachHTTP2Client :: HTTP2ClientConfig -> TransportHost -> ServiceName -> IO () -> Int -> TLS -> IO (Either HTTP2ClientError HTTP2Client) attachHTTP2Client config host port disconnected bufferSize tls = getVerifiedHTTP2ClientWith config host port disconnected setup where + setup :: (TLS -> H.Client HTTP2Response) -> IO HTTP2Response setup = runHTTP2ClientWith bufferSize host ($ tls) -getVerifiedHTTP2ClientWith :: HTTP2ClientConfig -> TransportHost -> ServiceName -> IO () -> ((SessionId -> H.Client HTTP2Response) -> IO HTTP2Response) -> IO (Either HTTP2ClientError HTTP2Client) +getVerifiedHTTP2ClientWith :: HTTP2ClientConfig -> TransportHost -> ServiceName -> IO () -> ((TLS -> H.Client HTTP2Response) -> IO HTTP2Response) -> IO (Either HTTP2ClientError HTTP2Client) getVerifiedHTTP2ClientWith config host port disconnected setup = (atomically mkHTTPS2Client >>= runClient) `E.catch` \(e :: IOException) -> pure . Left $ HCIOError e @@ -104,15 +110,25 @@ getVerifiedHTTP2ClientWith config host port disconnected setup = cVar <- newEmptyTMVarIO action <- async $ setup (client c cVar) `E.finally` atomically (putTMVar cVar $ Left HCNetworkError) c_ <- connTimeout config `timeout` atomically (takeTMVar cVar) - pure $ case c_ of - Just (Right c') -> Right c' {action = Just action} - Just (Left e) -> Left e - Nothing -> Left HCNetworkError + case c_ of + Just (Right c') -> pure $ Right c' {action = Just action} + Just (Left e) -> pure $ Left e + Nothing -> cancel action $> Left HCNetworkError - client :: HClient -> TMVar (Either HTTP2ClientError HTTP2Client) -> SessionId -> H.Client HTTP2Response - client c cVar sessionId sendReq = do + client :: HClient -> TMVar (Either HTTP2ClientError HTTP2Client) -> TLS -> H.Client HTTP2Response + client c cVar tls sendReq = do sessionTs <- getCurrentTime - let c' = HTTP2Client {action = Nothing, client_ = c, sendReq, sessionId, sessionTs} + let c' = + HTTP2Client + { action = Nothing, + client_ = c, + serverKey = eitherToMaybe $ getServerVerifyKey tls, + serverCerts = getServerCerts tls, + sendReq, + sessionTs, + sessionId = tlsUniq tls, + sessionALPN = tlsALPN tls + } atomically $ do writeTVar (connected c) True putTMVar cVar (Right c') @@ -154,13 +170,14 @@ sendRequestDirect HTTP2Client {client_ = HClient {config, disconnected}, sendReq http2RequestTimeout :: HTTP2ClientConfig -> Maybe Int -> Int http2RequestTimeout HTTP2ClientConfig {connTimeout} = maybe connTimeout (connTimeout +) -runHTTP2Client :: forall a. T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> BufferSize -> Maybe ByteString -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (SessionId -> H.Client a) -> IO a +runHTTP2Client :: forall a. T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> BufferSize -> Maybe ByteString -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (TLS -> H.Client a) -> IO a runHTTP2Client tlsParams caStore tcConfig bufferSize proxyUsername host port keyHash = runHTTP2ClientWith bufferSize host setup where + setup :: (TLS -> IO a) -> IO a setup = runTLSTransportClient tlsParams caStore tcConfig proxyUsername host port keyHash -runHTTP2ClientWith :: forall a. BufferSize -> TransportHost -> ((TLS -> IO a) -> IO a) -> (SessionId -> H.Client a) -> IO a -runHTTP2ClientWith bufferSize host setup client = setup $ withHTTP2 bufferSize run +runHTTP2ClientWith :: forall a. BufferSize -> TransportHost -> ((TLS -> IO a) -> IO a) -> (TLS -> H.Client a) -> IO a +runHTTP2ClientWith bufferSize host setup client = setup $ \tls -> withHTTP2 bufferSize (run tls) (pure ()) tls where - run :: H.Config -> SessionId -> IO a - run cfg sessId = H.run (ClientConfig "https" (strEncode host) 20) cfg $ client sessId + run :: TLS -> H.Config -> IO a + run tls cfg = H.run (ClientConfig "https" (strEncode host) 20) cfg $ client tls diff --git a/src/Simplex/Messaging/Transport/HTTP2/Server.hs b/src/Simplex/Messaging/Transport/HTTP2/Server.hs index e6dda40a1..c75d8fa31 100644 --- a/src/Simplex/Messaging/Transport/HTTP2/Server.hs +++ b/src/Simplex/Messaging/Transport/HTTP2/Server.hs @@ -13,14 +13,14 @@ import Network.Socket import qualified Network.TLS as T import Numeric.Natural (Natural) import Simplex.Messaging.Server.Expiration -import Simplex.Messaging.Transport (SessionId, TLS, closeConnection) +import Simplex.Messaging.Transport (ALPN, SessionId, TLS, closeConnection, tlsALPN, tlsUniq) import Simplex.Messaging.Transport.HTTP2 import Simplex.Messaging.Transport.Server (TransportServerConfig (..), loadSupportedTLSServerParams, runTransportServer) import Simplex.Messaging.Util (threadDelay') import UnliftIO (finally) import UnliftIO.Concurrent (forkIO, killThread) -type HTTP2ServerFunc = SessionId -> Request -> (Response -> IO ()) -> IO () +type HTTP2ServerFunc = SessionId -> Maybe ALPN -> Request -> (Response -> IO ()) -> IO () data HTTP2ServerConfig = HTTP2ServerConfig { qSize :: Natural, @@ -37,6 +37,7 @@ data HTTP2ServerConfig = HTTP2ServerConfig data HTTP2Request = HTTP2Request { sessionId :: SessionId, + sessionALPN :: Maybe ALPN, request :: Request, reqBody :: HTTP2Body, sendResponse :: Response -> IO () @@ -54,32 +55,32 @@ getHTTP2Server HTTP2ServerConfig {qSize, http2Port, bufferSize, bodyHeadSize, se started <- newEmptyTMVarIO reqQ <- newTBQueueIO qSize action <- async $ - runHTTP2Server started http2Port bufferSize tlsServerParams transportConfig Nothing $ \sessionId r sendResponse -> do + runHTTP2Server started http2Port bufferSize tlsServerParams transportConfig Nothing (const $ pure ()) $ \sessionId sessionALPN r sendResponse -> do reqBody <- getHTTP2Body r bodyHeadSize - atomically $ writeTBQueue reqQ HTTP2Request {sessionId, request = r, reqBody, sendResponse} + atomically $ writeTBQueue reqQ HTTP2Request {sessionId, sessionALPN, request = r, reqBody, sendResponse} void . atomically $ takeTMVar started pure HTTP2Server {action, reqQ} closeHTTP2Server :: HTTP2Server -> IO () closeHTTP2Server = uninterruptibleCancel . action -runHTTP2Server :: TMVar Bool -> ServiceName -> BufferSize -> T.ServerParams -> TransportServerConfig -> Maybe ExpirationConfig -> HTTP2ServerFunc -> IO () -runHTTP2Server started port bufferSize serverParams transportConfig expCfg_ = runHTTP2ServerWith_ expCfg_ bufferSize setup +runHTTP2Server :: TMVar Bool -> ServiceName -> BufferSize -> T.ServerParams -> TransportServerConfig -> Maybe ExpirationConfig -> (SessionId -> IO ()) -> HTTP2ServerFunc -> IO () +runHTTP2Server started port bufferSize serverParams transportConfig expCfg_ clientFinished = runHTTP2ServerWith_ expCfg_ clientFinished bufferSize setup where setup = runTransportServer started port serverParams transportConfig runHTTP2ServerWith :: BufferSize -> ((TLS -> IO ()) -> a) -> HTTP2ServerFunc -> a -runHTTP2ServerWith = runHTTP2ServerWith_ Nothing +runHTTP2ServerWith = runHTTP2ServerWith_ Nothing (\_sessId -> pure ()) -runHTTP2ServerWith_ :: Maybe ExpirationConfig -> BufferSize -> ((TLS -> IO ()) -> a) -> HTTP2ServerFunc -> a -runHTTP2ServerWith_ expCfg_ bufferSize setup http2Server = setup $ \tls -> do +runHTTP2ServerWith_ :: Maybe ExpirationConfig -> (SessionId -> IO ()) -> BufferSize -> ((TLS -> IO ()) -> a) -> HTTP2ServerFunc -> a +runHTTP2ServerWith_ expCfg_ clientFinished bufferSize setup http2Server = setup $ \tls -> do activeAt <- newTVarIO =<< getSystemTime tid_ <- mapM (forkIO . expireInactiveClient tls activeAt) expCfg_ - withHTTP2 bufferSize (run activeAt) tls `finally` mapM_ killThread tid_ + withHTTP2 bufferSize (run tls activeAt) (clientFinished $ tlsUniq tls) tls `finally` mapM_ killThread tid_ where - run activeAt cfg sessId = H.run cfg $ \req _aux sendResp -> do + run tls activeAt cfg = H.run cfg $ \req _aux sendResp -> do getSystemTime >>= atomically . writeTVar activeAt - http2Server sessId req (`sendResp` []) + http2Server (tlsUniq tls) (tlsALPN tls) req (`sendResp` []) expireInactiveClient tls activeAt expCfg = loop where loop = do diff --git a/tests/AgentTests.hs b/tests/AgentTests.hs index 34719e803..8083ef988 100644 --- a/tests/AgentTests.hs +++ b/tests/AgentTests.hs @@ -13,7 +13,7 @@ module AgentTests (agentTests) where import AgentTests.ConnectionRequestTests import AgentTests.DoubleRatchetTests (doubleRatchetTests) -import AgentTests.FunctionalAPITests (functionalAPITests, pattern Msg, pattern Msg') +import AgentTests.FunctionalAPITests (functionalAPITests, inAnyOrder, pattern Msg, pattern Msg') import AgentTests.MigrationTests (migrationTests) import AgentTests.NotificationTests (notificationTests) import AgentTests.SQLiteTests (storeTests) @@ -194,8 +194,8 @@ pqMatrix2_ pqInv _ smpTest test = do pqMatrix3 :: HasCallStack => - TProxy c -> - (HasCallStack => (c -> c -> c -> IO ()) -> Expectation) -> + TProxy c -> + (HasCallStack => (c -> c -> c -> IO ()) -> Expectation) -> (HasCallStack => (c, InitialKeys) -> (c, PQSupport) -> (c, PQSupport) -> IO ()) -> Spec pqMatrix3 _ smpTest test = do @@ -452,7 +452,7 @@ testServerConnectionAfterError t _ = do where server = SMPServer "localhost" testPort2 testKeyHash withServer test' = withSmpServerStoreLogOn (ATransport t) testPort2 (const test') `shouldReturn` () - withAgent1 = withAgent agentTestPort testDB 0 + withAgent1 = withAgent agentTestPort testDB 0 withAgent2 = withAgent agentTestPort2 testDB2 10 withAgent :: String -> FilePath -> Int -> (c -> IO a) -> IO a withAgent agentPort agentDB initClientId = withSmpAgentThreadOn_ (ATransport t) (agentPort, testPort2, agentDB) initClientId (pure ()) . const . testSMPAgentClientOn agentPort @@ -554,7 +554,11 @@ testResumeDeliveryQuotaExceeded _ alice bob = do alice #:# "the last message not sent" bob <#= \case ("", "alice", Msg "message 4") -> True; _ -> False bob #: ("4", "alice", "ACK 7") #> ("4", "alice", OK) - alice <# ("", "bob", SENT 8) + inAnyOrder + (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) diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 3fa8becdf..7d6884b27 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -10,7 +10,6 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} @@ -19,7 +18,11 @@ module AgentTests.FunctionalAPITests ( functionalAPITests, testServerMatrix2, withAgentClientsCfg2, + withAgentClientsCfgServers2, getSMPAgentClient', + withAgent, + withAgentClients2, + withAgentClients3, makeConnection, exchangeGreetingsMsgId, switchComplete, @@ -28,6 +31,7 @@ module AgentTests.FunctionalAPITests sendMessage, runRight, runRight_, + inAnyOrder, get, get', rfGet, @@ -64,27 +68,30 @@ import Data.Time.Clock.System (SystemTime (..), getSystemTime) 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, 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 (..)) +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) 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 (..), TransportSessionMode (TSMEntity, TSMUser), defaultSMPClientConfig) import qualified Simplex.Messaging.Crypto as C -import Simplex.Messaging.Crypto.Ratchet (InitialKeys (..), PQEncryption (..), PQSupport (..), pattern PQEncOn, pattern PQEncOff, pattern PQSupportOn, pattern PQSupportOff) +import Simplex.Messaging.Crypto.Ratchet (InitialKeys (..), PQEncryption (..), PQSupport (..), pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn) import qualified Simplex.Messaging.Crypto.Ratchet as CR import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Notifications.Transport (NTFVersion, pattern VersionNTF, authBatchCmdsNTFVersion) +import Simplex.Messaging.Notifications.Transport (NTFVersion, authBatchCmdsNTFVersion, pattern VersionNTF) import Simplex.Messaging.Protocol (BasicAuth, ErrorType (..), MsgBody, ProtocolServer (..), SubscriptionMode (..), supportedSMPClientVRange) 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, batchCmdsSMPVersion, basicAuthSMPVersion, currentServerSMPRelayVersion) +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 import Simplex.Messaging.Version.Internal (Version (..)) @@ -101,32 +108,32 @@ type AEntityTransmission e = (ACorrId, ConnId, ACommand 'Agent e) (##>) :: (HasCallStack, MonadUnliftIO m) => m (AEntityTransmission e) -> AEntityTransmission e -> m () a ##> t = withTimeout a (`shouldBe` t) -(=##>) :: (Show a, HasCallStack, MonadUnliftIO m) => m a -> (a -> Bool) -> m () +(=##>) :: (Show a, HasCallStack, MonadUnliftIO m) => m a -> (HasCallStack => a -> Bool) -> m () a =##> p = withTimeout a $ \r -> do unless (p r) $ liftIO $ putStrLn $ "value failed predicate: " <> show r r `shouldSatisfy` p -withTimeout :: (HasCallStack, MonadUnliftIO m) => m a -> (a -> Expectation) -> m () +withTimeout :: (HasCallStack, MonadUnliftIO m) => m a -> (HasCallStack => a -> Expectation) -> m () withTimeout a test = timeout 10_000000 a >>= \case Nothing -> error "operation timed out" Just t -> liftIO $ test t -get :: MonadIO m => AgentClient -> m (AEntityTransmission 'AEConn) -get = get' @'AEConn +get :: (MonadIO m, HasCallStack) => AgentClient -> m (AEntityTransmission 'AEConn) +get c = withFrozenCallStack $ get' @'AEConn c -rfGet :: MonadIO m => AgentClient -> m (AEntityTransmission 'AERcvFile) -rfGet = get' @'AERcvFile +rfGet :: (MonadIO m, HasCallStack) => AgentClient -> m (AEntityTransmission 'AERcvFile) +rfGet c = withFrozenCallStack $ get' @'AERcvFile c -sfGet :: MonadIO m => AgentClient -> m (AEntityTransmission 'AESndFile) -sfGet = get' @'AESndFile +sfGet :: (MonadIO m, HasCallStack) => AgentClient -> m (AEntityTransmission 'AESndFile) +sfGet c = withFrozenCallStack $ get' @'AESndFile c -nGet :: MonadIO m => AgentClient -> m (AEntityTransmission 'AENone) -nGet = get' @'AENone +nGet :: (MonadIO m, HasCallStack) => AgentClient -> m (AEntityTransmission 'AENone) +nGet c = withFrozenCallStack $ get' @'AENone c -get' :: forall e m. (MonadIO m, AEntityI e) => AgentClient -> m (AEntityTransmission e) -get' c = do +get' :: forall e m. (MonadIO m, AEntityI e, HasCallStack) => AgentClient -> m (AEntityTransmission e) +get' c = withFrozenCallStack $ do (corrId, connId, APC e cmd) <- pGet c case testEquality e (sAEntity @e) of Just Refl -> pure (corrId, connId, cmd) @@ -219,11 +226,11 @@ runRight action = Left e -> error $ "Unexpected error: " <> show e getInAnyOrder :: HasCallStack => AgentClient -> [ATransmission 'Agent -> Bool] -> Expectation -getInAnyOrder c = inAnyOrder (pGet c) +getInAnyOrder c ts = withFrozenCallStack $ inAnyOrder (pGet c) ts inAnyOrder :: (Show a, MonadIO m, HasCallStack) => m a -> [a -> Bool] -> m () inAnyOrder _ [] = pure () -inAnyOrder g rs = do +inAnyOrder g rs = withFrozenCallStack $ do r <- g let rest = filter (not . expected r) rs if length rest < length rs @@ -280,7 +287,7 @@ functionalAPITests t = do testIncreaseConnAgentVersionMaxCompatible t it "should increase when connection was negotiated on different versions" $ testIncreaseConnAgentVersionStartDifferentVersion t - -- TODO PQ tests for upgrading connection to PQ encryption + -- TODO PQ tests for upgrading connection to PQ encryption it "should deliver message after client restart" $ testDeliverClientRestart t it "should deliver messages to the user once, even if repeat delivery is made by the server (no ACK)" $ @@ -419,6 +426,8 @@ functionalAPITests t = do it "should send and receive delivery receipt" $ withSmpServer t testDeliveryReceipts it "should send delivery receipt only in connection v3+" $ testDeliveryReceiptsVersion t it "send delivery receipts concurrently with messages" $ testDeliveryReceiptsConcurrent t + describe "user network info" $ do + it "should wait for user network" testWaitForUserNetwork testBasicAuth :: ATransport -> Bool -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> IO Int testBasicAuth t allowNewQueues srv@(srvAuth, srvVersion) clnt1 clnt2 = do @@ -440,7 +449,7 @@ canCreateQueue allowNew (srvAuth, srvVersion) (clntAuth, clntVersion) = testMatrix2 :: ATransport -> (PQSupport -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec testMatrix2 t runTest = do - it "v7" $ withSmpServerV7 t $ runTestCfg2 agentCfgV7 agentCfgV7 3 $ runTest PQSupportOn + 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 @@ -451,10 +460,10 @@ testMatrix2 t runTest = do testRatchetMatrix2 :: ATransport -> (PQSupport -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec testRatchetMatrix2 t runTest = do - 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 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 @@ -464,20 +473,30 @@ testServerMatrix2 t runTest = do it "1 server" $ withSmpServer t $ runTest initAgentServers it "2 servers" $ withSmpServer t . withSmpServerOn t testPort2 $ runTest initAgentServers2 -runTestCfg2 :: AgentConfig -> AgentConfig -> AgentMsgId -> (AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> IO () +runTestCfg2 :: HasCallStack => AgentConfig -> AgentConfig -> AgentMsgId -> (HasCallStack => AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> IO () runTestCfg2 aCfg bCfg baseMsgId runTest = withAgentClientsCfg2 aCfg bCfg $ \a b -> runTest a b baseMsgId +{-# INLINE runTestCfg2 #-} -withAgentClientsCfg2 :: AgentConfig -> AgentConfig -> (AgentClient -> AgentClient -> IO ()) -> IO () -withAgentClientsCfg2 aCfg bCfg runTest = do - a <- getSMPAgentClient' 1 aCfg initAgentServers testDB - b <- getSMPAgentClient' 2 bCfg initAgentServers testDB2 - runTest a b - disposeAgentClient a - disposeAgentClient b +withAgentClientsCfgServers2 :: HasCallStack => AgentConfig -> AgentConfig -> InitialAgentServers -> (HasCallStack => AgentClient -> AgentClient -> IO ()) -> IO () +withAgentClientsCfgServers2 aCfg bCfg servers runTest = + withAgent 1 aCfg servers testDB $ \a -> + withAgent 2 bCfg servers testDB2 $ \b -> + runTest a b -withAgentClients2 :: (AgentClient -> AgentClient -> IO ()) -> IO () +withAgentClientsCfg2 :: HasCallStack => AgentConfig -> AgentConfig -> (HasCallStack => AgentClient -> AgentClient -> IO ()) -> IO () +withAgentClientsCfg2 aCfg bCfg = withAgentClientsCfgServers2 aCfg bCfg initAgentServers +{-# INLINE withAgentClientsCfg2 #-} + +withAgentClients2 :: HasCallStack => (HasCallStack => AgentClient -> AgentClient -> IO ()) -> IO () withAgentClients2 = withAgentClientsCfg2 agentCfg agentCfg +{-# INLINE withAgentClients2 #-} + +withAgentClients3 :: HasCallStack => (HasCallStack => AgentClient -> AgentClient -> AgentClient -> IO ()) -> IO () +withAgentClients3 runTest = + withAgentClients2 $ \a b -> + withAgent 3 agentCfg initAgentServers testDB3 $ \c -> + runTest a b c runAgentClientTest :: HasCallStack => PQSupport -> AgentClient -> AgentClient -> AgentMsgId -> IO () runAgentClientTest pqSupport alice@AgentClient {} bob baseId = @@ -517,11 +536,9 @@ runAgentClientTest pqSupport alice@AgentClient {} bob baseId = msgId = subtract baseId . fst testEnablePQEncryption :: HasCallStack => IO () -testEnablePQEncryption = do - ca <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - cb <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - g <- C.newRandom - runRight_ $ do +testEnablePQEncryption = + withAgentClients2 $ \ca cb -> runRight_ $ do + g <- liftIO C.newRandom (aId, bId) <- makeConnection_ PQSupportOff ca cb let a = (ca, aId) b = (cb, bId) @@ -587,11 +604,8 @@ sndRcv pqEnc pqEnc' ((c1, id1), mId, msg) (c2, id2) = do ackMessage c2 id1 mId Nothing testAgentClient3 :: HasCallStack => IO () -testAgentClient3 = do - a <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - b <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - c <- getSMPAgentClient' 3 agentCfg initAgentServers testDB3 - runRight_ $ do +testAgentClient3 = + withAgentClients3 $ \a b c -> runRight_ $ do (aIdForB, bId) <- makeConnection a b (aIdForC, cId) <- makeConnection a c @@ -662,7 +676,8 @@ noMessages c err = tryGet `shouldReturn` () testAsyncInitiatingOffline :: HasCallStack => IO () testAsyncInitiatingOffline = - withAgentClients2 $ \alice bob -> runRight_ $ do + withAgent 2 agentCfg initAgentServers testDB2 $ \bob -> runRight_ $ do + alice <- liftIO $ getSMPAgentClient' 1 agentCfg initAgentServers testDB (bobId, cReq) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe liftIO $ disposeAgentClient alice aliceId <- joinConnection bob 1 True cReq "bob's connInfo" SMSubscribe @@ -674,10 +689,12 @@ testAsyncInitiatingOffline = get bob ##> ("", aliceId, INFO "alice's connInfo") get bob ##> ("", aliceId, CON) exchangeGreetings alice' bobId bob aliceId + liftIO $ disposeAgentClient alice' testAsyncJoiningOfflineBeforeActivation :: HasCallStack => IO () testAsyncJoiningOfflineBeforeActivation = - withAgentClients2 $ \alice bob -> runRight_ $ do + withAgent 1 agentCfg initAgentServers testDB $ \alice -> runRight_ $ do + bob <- liftIO $ getSMPAgentClient' 2 agentCfg initAgentServers testDB2 (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe liftIO $ disposeAgentClient bob @@ -689,10 +706,13 @@ testAsyncJoiningOfflineBeforeActivation = get bob' ##> ("", aliceId, INFO "alice's connInfo") get bob' ##> ("", aliceId, CON) exchangeGreetings alice bobId bob' aliceId + liftIO $ disposeAgentClient bob' testAsyncBothOffline :: HasCallStack => IO () -testAsyncBothOffline = - withAgentClients2 $ \alice bob -> runRight_ $ do +testAsyncBothOffline = do + alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB + bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 + runRight_ $ do (bobId, cReq) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe liftIO $ disposeAgentClient alice aliceId <- joinConnection bob 1 True cReq "bob's connInfo" SMSubscribe @@ -707,6 +727,8 @@ testAsyncBothOffline = get bob' ##> ("", aliceId, INFO "alice's connInfo") get bob' ##> ("", aliceId, CON) exchangeGreetings alice' bobId bob' aliceId + liftIO $ disposeAgentClient alice' + liftIO $ disposeAgentClient bob' testAsyncServerOffline :: HasCallStack => ATransport -> IO () testAsyncServerOffline t = withAgentClients2 $ \alice bob -> do @@ -1017,40 +1039,51 @@ testSkippedMessages t = do disposeAgentClient bob2 testExpireMessage :: HasCallStack => ATransport -> IO () -testExpireMessage t = do - a <- getSMPAgentClient' 1 agentCfg {messageTimeout = 1, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB - b <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ makeConnection a b - nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False - nGet b =##> \case ("", "", DOWN _ [c]) -> c == aId; _ -> False - 4 <- runRight $ sendMessage a bId SMP.noMsgFlags "1" - threadDelay 1000000 - 5 <- runRight $ sendMessage a bId SMP.noMsgFlags "2" -- this won't expire - get a =##> \case ("", c, MERR 4 (BROKER _ e)) -> bId == c && (e == TIMEOUT || e == NETWORK); _ -> False - withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do - withUP a bId $ \case ("", _, SENT 5) -> True; _ -> False - withUP b aId $ \case ("", _, MsgErr 4 (MsgSkipped 3 3) "2") -> True; _ -> False - ackMessage b aId 4 Nothing +testExpireMessage t = + withAgent 1 agentCfg {messageTimeout = 1, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB $ \a -> + withAgent 2 agentCfg initAgentServers testDB2 $ \b -> do + (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ makeConnection a b + nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False + nGet b =##> \case ("", "", DOWN _ [c]) -> c == aId; _ -> False + 4 <- runRight $ sendMessage a bId SMP.noMsgFlags "1" + threadDelay 1000000 + 5 <- runRight $ sendMessage a bId SMP.noMsgFlags "2" -- this won't expire + get a =##> \case ("", c, MERR 4 (BROKER _ e)) -> bId == c && (e == TIMEOUT || e == NETWORK); _ -> False + withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do + withUP a bId $ \case ("", _, SENT 5) -> True; _ -> False + withUP b aId $ \case ("", _, MsgErr 4 (MsgSkipped 3 3) "2") -> True; _ -> False + ackMessage b aId 4 Nothing testExpireManyMessages :: HasCallStack => ATransport -> IO () -testExpireManyMessages t = do - a <- getSMPAgentClient' 1 agentCfg {messageTimeout = 1, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB - b <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ makeConnection a b - runRight_ $ do - nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False - nGet b =##> \case ("", "", DOWN _ [c]) -> c == aId; _ -> False - 4 <- sendMessage a bId SMP.noMsgFlags "1" - 5 <- sendMessage a bId SMP.noMsgFlags "2" - 6 <- sendMessage a bId SMP.noMsgFlags "3" - liftIO $ threadDelay 1000000 - 7 <- sendMessage a bId SMP.noMsgFlags "4" -- this won't expire - get a =##> \case ("", c, MERR 4 (BROKER _ e)) -> bId == c && (e == TIMEOUT || e == NETWORK); _ -> False - get a =##> \case ("", c, MERRS [5, 6] (BROKER _ e)) -> bId == c && (e == TIMEOUT || e == NETWORK); _ -> False - withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do - withUP a bId $ \case ("", _, SENT 7) -> True; _ -> False - withUP b aId $ \case ("", _, MsgErr 4 (MsgSkipped 3 5) "4") -> True; _ -> False - ackMessage b aId 4 Nothing +testExpireManyMessages t = + withAgent 1 agentCfg {messageTimeout = 1, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB $ \a -> + withAgent 2 agentCfg initAgentServers testDB2 $ \b -> do + (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ makeConnection a b + runRight_ $ do + nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False + nGet b =##> \case ("", "", DOWN _ [c]) -> c == aId; _ -> False + 4 <- sendMessage a bId SMP.noMsgFlags "1" + 5 <- sendMessage a bId SMP.noMsgFlags "2" + 6 <- sendMessage a bId SMP.noMsgFlags "3" + liftIO $ threadDelay 1000000 + 7 <- sendMessage a bId SMP.noMsgFlags "4" -- this won't expire + get a =##> \case ("", c, MERR 4 (BROKER _ e)) -> bId == c && (e == TIMEOUT || e == NETWORK); _ -> False + -- get a =##> \case ("", c, MERRS [5, 6] (BROKER _ e)) -> bId == c && (e == TIMEOUT || e == NETWORK); _ -> False + let expected c e = bId == c && (e == TIMEOUT || e == NETWORK) + get a >>= \case + ("", c, MERR 5 (BROKER _ e)) -> do + liftIO $ expected c e `shouldBe` True + get a =##> \case ("", c', MERR 6 (BROKER _ e')) -> expected c' e'; ("", c', MERRS [6] (BROKER _ e')) -> expected c' e'; _ -> False + ("", c, MERRS [5] (BROKER _ e)) -> do + liftIO $ expected c e `shouldBe` True + get a =##> \case ("", c', MERR 6 (BROKER _ e')) -> expected c' e'; _ -> False + ("", c, MERRS [5, 6] (BROKER _ e)) -> + liftIO $ expected c e `shouldBe` True + r -> error $ show r + withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do + withUP a bId $ \case ("", _, SENT 7) -> True; _ -> False + withUP b aId $ \case ("", _, MsgErr 4 (MsgSkipped 3 5) "4") -> True; _ -> False + ackMessage b aId 4 Nothing withUP :: AgentClient -> ConnId -> (AEntityTransmission 'AEConn -> Bool) -> ExceptT AgentErrorType IO () withUP a bId p = @@ -1075,16 +1108,19 @@ testExpireMessageQuota t = withSmpServerConfigOn t cfg {msgQueueQuota = 1} testP 6 <- sendMessage a bId SMP.noMsgFlags "3" -- this won't expire get a =##> \case ("", c, MERR 5 (SMP QUOTA)) -> bId == c; _ -> False pure (aId, bId) - b' <- getSMPAgentClient' 3 agentCfg initAgentServers testDB2 - runRight_ $ do + withAgent 3 agentCfg initAgentServers testDB2 $ \b' -> runRight_ $ do subscribeConnection b' aId get b' =##> \case ("", c, Msg "1") -> c == aId; _ -> False ackMessage b' aId 4 Nothing - get a ##> ("", bId, SENT 6) + liftIO . getInAnyOrder a $ + [ \case ("", c, APC SAEConn (SENT 6)) -> c == bId; _ -> False, + \case ("", c, APC SAEConn QCONT) -> c == bId; _ -> False + ] get b' =##> \case ("", c, MsgErr 6 (MsgSkipped 4 4) "3") -> c == aId; _ -> False ackMessage b' aId 6 Nothing + disposeAgentClient a -testExpireManyMessagesQuota :: HasCallStack => ATransport -> IO () +testExpireManyMessagesQuota :: ATransport -> IO () testExpireManyMessagesQuota t = withSmpServerConfigOn t cfg {msgQueueQuota = 1} testPort $ \_ -> do a <- getSMPAgentClient' 1 agentCfg {quotaExceededTimeout = 1, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB b <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 @@ -1099,16 +1135,27 @@ testExpireManyMessagesQuota t = withSmpServerConfigOn t cfg {msgQueueQuota = 1} 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, MERRS [6, 7] (SMP QUOTA)) -> bId == c; _ -> False + get a >>= \case + ("", 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 + 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) - b' <- getSMPAgentClient' 3 agentCfg initAgentServers testDB2 - runRight_ $ do + withAgent 3 agentCfg initAgentServers testDB2 $ \b' -> runRight_ $ do subscribeConnection b' aId get b' =##> \case ("", c, Msg "1") -> c == aId; _ -> False ackMessage b' aId 4 Nothing - get a ##> ("", bId, SENT 8) + liftIO . getInAnyOrder a $ + [ \case ("", c, APC SAEConn (SENT 8)) -> c == bId; _ -> False, + \case ("", c, APC SAEConn QCONT) -> c == bId; _ -> False + ] get b' =##> \case ("", c, MsgErr 6 (MsgSkipped 4 6) "5") -> c == aId; _ -> False ackMessage b' aId 6 Nothing + disposeAgentClient a testRatchetSync :: HasCallStack => ATransport -> IO () testRatchetSync t = withAgentClients2 $ \alice bob -> @@ -1122,6 +1169,7 @@ testRatchetSync t = withAgentClients2 $ \alice bob -> get alice =##> ratchetSyncP bobId RSOk get bob2 =##> ratchetSyncP aliceId RSOk exchangeGreetingsMsgIds alice bobId 12 bob2 aliceId 9 + disposeAgentClient bob2 setupDesynchronizedRatchet :: HasCallStack => AgentClient -> AgentClient -> IO (ConnId, ConnId, AgentClient) setupDesynchronizedRatchet alice bob = do @@ -1206,6 +1254,7 @@ testRatchetSyncServerOffline t = withAgentClients2 $ \alice bob -> do get alice =##> ratchetSyncP bobId RSOk get bob2 =##> ratchetSyncP aliceId RSOk exchangeGreetingsMsgIds alice bobId 12 bob2 aliceId 9 + disposeAgentClient bob2 serverUpP :: ATransmission 'Agent -> Bool serverUpP = \case @@ -1221,8 +1270,8 @@ testRatchetSyncClientRestart t = do ("", "", DOWN _ _) <- nGet alice ("", "", DOWN _ _) <- nGet bob2 ConnectionStats {ratchetSyncState} <- runRight $ synchronizeRatchet bob2 aliceId PQSupportOn False - liftIO $ ratchetSyncState `shouldBe` RSStarted - liftIO $ disposeAgentClient bob2 + ratchetSyncState `shouldBe` RSStarted + disposeAgentClient bob2 bob3 <- getSMPAgentClient' 3 agentCfg initAgentServers testDB2 withSmpServerStoreMsgLogOn t testPort $ \_ -> do runRight_ $ do @@ -1363,35 +1412,33 @@ makeConnectionForUsers_ pqSupport alice aliceUserId bob bobUserId = do testInactiveNoSubs :: ATransport -> IO () testInactiveNoSubs t = do let cfg' = cfg {inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}} - withSmpServerConfigOn t cfg' testPort $ \_ -> do - alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - runRight_ . void $ createConnection alice 1 True SCMInvitation Nothing SMOnlyCreate -- do not subscribe to pass noSubscriptions check - Just (_, _, APC SAENone (CONNECT _ _)) <- timeout 2000000 $ atomically (readTBQueue $ subQ alice) - Just (_, _, APC SAENone (DISCONNECT _ _)) <- timeout 5000000 $ atomically (readTBQueue $ subQ alice) - disposeAgentClient alice + withSmpServerConfigOn t cfg' testPort $ \_ -> + withAgent 1 agentCfg initAgentServers testDB $ \alice -> do + runRight_ . void $ createConnection alice 1 True SCMInvitation Nothing SMOnlyCreate -- do not subscribe to pass noSubscriptions check + Just (_, _, APC SAENone (CONNECT _ _)) <- timeout 2000000 $ atomically (readTBQueue $ subQ alice) + Just (_, _, APC SAENone (DISCONNECT _ _)) <- timeout 5000000 $ atomically (readTBQueue $ subQ alice) + pure () testInactiveWithSubs :: ATransport -> IO () testInactiveWithSubs t = do let cfg' = cfg {inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}} - withSmpServerConfigOn t cfg' testPort $ \_ -> do - alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - runRight_ . void $ createConnection alice 1 True SCMInvitation Nothing SMSubscribe - Nothing <- 800000 `timeout` get alice - liftIO $ threadDelay 1200000 - -- and after 2 sec of inactivity no DOWN is sent as we have a live subscription - liftIO $ timeout 1200000 (get alice) `shouldReturn` Nothing - disposeAgentClient alice + withSmpServerConfigOn t cfg' testPort $ \_ -> + withAgent 1 agentCfg initAgentServers testDB $ \alice -> do + runRight_ . void $ createConnection alice 1 True SCMInvitation Nothing SMSubscribe + Nothing <- 800000 `timeout` get alice + liftIO $ threadDelay 1200000 + -- and after 2 sec of inactivity no DOWN is sent as we have a live subscription + liftIO $ timeout 1200000 (get alice) `shouldReturn` Nothing testActiveClientNotDisconnected :: ATransport -> IO () testActiveClientNotDisconnected t = do let cfg' = cfg {inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}} - withSmpServerConfigOn t cfg' testPort $ \_ -> do - alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - ts <- getSystemTime - runRight_ $ do - (connId, _cReq) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe - keepSubscribing alice connId ts - disposeAgentClient alice + withSmpServerConfigOn t cfg' testPort $ \_ -> + withAgent 1 agentCfg initAgentServers testDB $ \alice -> do + ts <- getSystemTime + runRight_ $ do + (connId, _cReq) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe + keepSubscribing alice connId ts where keepSubscribing :: AgentClient -> ConnId -> SystemTime -> ExceptT AgentErrorType IO () keepSubscribing alice connId ts = do @@ -1476,42 +1523,39 @@ testSuspendingAgentTimeout t = withAgentClients2 $ \a b -> do pure () testBatchedSubscriptions :: Int -> Int -> ATransport -> IO () -testBatchedSubscriptions nCreate nDel t = do - a <- getSMPAgentClient' 1 agentCfg initAgentServers2 testDB - b <- getSMPAgentClient' 2 agentCfg initAgentServers2 testDB2 - conns <- runServers $ do - 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' - delete b aIds' - liftIO $ threadDelay 1000000 - pure conns - ("", "", DOWN {}) <- nGet a - ("", "", DOWN {}) <- nGet a - ("", "", DOWN {}) <- nGet b - ("", "", DOWN {}) <- nGet b - runServers $ do - ("", "", UP {}) <- nGet a - ("", "", UP {}) <- nGet a - ("", "", UP {}) <- nGet b - ("", "", UP {}) <- nGet b - liftIO $ threadDelay 1000000 - let (aIds, bIds) = unzip conns - conns' = drop nDel conns - (aIds', bIds') = unzip conns' - subscribe a bIds - subscribe b aIds - forM_ conns' $ \(aId, bId) -> exchangeGreetingsMsgId_ PQEncOff 6 a bId b aId - void $ resubscribeConnections a bIds - void $ resubscribeConnections b aIds - forM_ conns' $ \(aId, bId) -> exchangeGreetingsMsgId_ PQEncOff 8 a bId b aId - delete a bIds' - delete b aIds' - deleteFail a bIds' - deleteFail b aIds' - disposeAgentClient a - disposeAgentClient b +testBatchedSubscriptions nCreate nDel t = + withAgentClientsCfgServers2 agentCfg agentCfg initAgentServers2 $ \a b -> do + conns <- runServers $ do + 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' + delete b aIds' + liftIO $ threadDelay 1000000 + pure conns + ("", "", DOWN {}) <- nGet a + ("", "", DOWN {}) <- nGet a + ("", "", DOWN {}) <- nGet b + ("", "", DOWN {}) <- nGet b + runServers $ do + ("", "", UP {}) <- nGet a + ("", "", UP {}) <- nGet a + ("", "", UP {}) <- nGet b + ("", "", UP {}) <- nGet b + liftIO $ threadDelay 1000000 + let (aIds, bIds) = unzip conns + conns' = drop nDel conns + (aIds', bIds') = unzip conns' + subscribe a bIds + subscribe b aIds + forM_ conns' $ \(aId, bId) -> exchangeGreetingsMsgId_ PQEncOff 6 a bId b aId + void $ resubscribeConnections a bIds + void $ resubscribeConnections b aIds + forM_ conns' $ \(aId, bId) -> exchangeGreetingsMsgId_ PQEncOff 8 a bId b aId + delete a bIds' + delete b aIds' + deleteFail a bIds' + deleteFail b aIds' where subscribe :: AgentClient -> [ConnId] -> ExceptT AgentErrorType IO () subscribe c cs = do @@ -1597,13 +1641,11 @@ testAsyncCommandsRestore t = do bobId <- runRight $ createConnectionAsync alice 1 "1" True SCMInvitation (IKNoPQ PQSupportOn) SMSubscribe liftIO $ noMessages alice "alice doesn't receive INV because server is down" disposeAgentClient alice - alice' <- liftIO $ getSMPAgentClient' 2 agentCfg initAgentServers testDB - withSmpServerStoreLogOn t testPort $ \_ -> do - runRight_ $ do + withAgent 2 agentCfg initAgentServers testDB $ \alice' -> + withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do subscribeConnection alice' bobId get alice' =##> \case ("1", _, INV _) -> True; _ -> False pure () - disposeAgentClient alice' testAcceptContactAsync :: IO () testAcceptContactAsync = @@ -1645,28 +1687,26 @@ testAcceptContactAsync = msgId = subtract baseId testDeleteConnectionAsync :: ATransport -> IO () -testDeleteConnectionAsync t = do - a <- getSMPAgentClient' 1 agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB - connIds <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do - (bId1, _inv) <- createConnection a 1 True SCMInvitation Nothing SMSubscribe - (bId2, _inv) <- createConnection a 1 True SCMInvitation Nothing SMSubscribe - (bId3, _inv) <- createConnection a 1 True SCMInvitation Nothing SMSubscribe - pure ([bId1, bId2, bId3] :: [ConnId]) - runRight_ $ do - deleteConnectionsAsync a False connIds - get a =##> \case ("", c, DEL_RCVQ _ _ (Just (BROKER _ e))) -> c `elem` connIds && (e == TIMEOUT || e == NETWORK); _ -> False - get a =##> \case ("", c, DEL_RCVQ _ _ (Just (BROKER _ e))) -> c `elem` connIds && (e == TIMEOUT || e == NETWORK); _ -> False - get a =##> \case ("", c, DEL_RCVQ _ _ (Just (BROKER _ e))) -> c `elem` connIds && (e == TIMEOUT || e == NETWORK); _ -> False - get a =##> \case ("", c, DEL_CONN) -> c `elem` connIds; _ -> False - get a =##> \case ("", c, DEL_CONN) -> c `elem` connIds; _ -> False - get a =##> \case ("", c, DEL_CONN) -> c `elem` connIds; _ -> False - liftIO $ noMessages a "nothing else should be delivered to alice" - disposeAgentClient a +testDeleteConnectionAsync t = + withAgent 1 agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB $ \a -> do + connIds <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do + (bId1, _inv) <- createConnection a 1 True SCMInvitation Nothing SMSubscribe + (bId2, _inv) <- createConnection a 1 True SCMInvitation Nothing SMSubscribe + (bId3, _inv) <- createConnection a 1 True SCMInvitation Nothing SMSubscribe + pure ([bId1, bId2, bId3] :: [ConnId]) + runRight_ $ do + deleteConnectionsAsync a False connIds + nGet a =##> \case ("", "", DOWN {}) -> True; _ -> False + get a =##> \case ("", c, DEL_RCVQ _ _ (Just (BROKER _ e))) -> c `elem` connIds && (e == TIMEOUT || e == NETWORK); _ -> False + get a =##> \case ("", c, DEL_RCVQ _ _ (Just (BROKER _ e))) -> c `elem` connIds && (e == TIMEOUT || e == NETWORK); _ -> False + get a =##> \case ("", c, DEL_RCVQ _ _ (Just (BROKER _ e))) -> c `elem` connIds && (e == TIMEOUT || e == NETWORK); _ -> False + get a =##> \case ("", c, DEL_CONN) -> c `elem` connIds; _ -> False + get a =##> \case ("", c, DEL_CONN) -> c `elem` connIds; _ -> False + get a =##> \case ("", c, DEL_CONN) -> c `elem` connIds; _ -> False + liftIO $ noMessages a "nothing else should be delivered to alice" testWaitDeliveryNoPending :: ATransport -> IO () -testWaitDeliveryNoPending t = do - alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 +testWaitDeliveryNoPending t = withAgentClients2 $ \alice bob -> withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do (aliceId, bobId) <- makeConnection alice bob @@ -1689,204 +1729,189 @@ testWaitDeliveryNoPending t = do liftIO $ noMessages alice "nothing else should be delivered to alice" liftIO $ noMessages bob "nothing else should be delivered to bob" - - disposeAgentClient alice - disposeAgentClient bob where baseId = 3 msgId = subtract baseId testWaitDelivery :: ATransport -> IO () -testWaitDelivery t = do - alice <- getSMPAgentClient' 1 agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB - bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - (aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do - (aliceId, bobId) <- makeConnection alice bob +testWaitDelivery t = + withAgent 1 agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB $ \alice -> + withAgent 2 agentCfg initAgentServers testDB2 $ \bob -> do + (aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do + (aliceId, bobId) <- makeConnection alice bob - 1 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "hello" - get alice ##> ("", bobId, SENT $ baseId + 1) - get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False - ackMessage bob aliceId (baseId + 1) Nothing + 1 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "hello" + get alice ##> ("", bobId, SENT $ baseId + 1) + get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False + ackMessage bob aliceId (baseId + 1) Nothing - 2 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "hello too" - get bob ##> ("", aliceId, SENT $ baseId + 2) - get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False - ackMessage alice bobId (baseId + 2) Nothing + 2 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "hello too" + get bob ##> ("", aliceId, SENT $ baseId + 2) + get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False + ackMessage alice bobId (baseId + 2) Nothing - pure (aliceId, bobId) + pure (aliceId, bobId) - runRight_ $ do - ("", "", DOWN _ _) <- nGet alice - ("", "", DOWN _ _) <- nGet bob - 3 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?" - 4 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "message 1" - deleteConnectionsAsync alice True [bobId] - get alice =##> \case ("", cId, DEL_RCVQ _ _ (Just (BROKER _ e))) -> cId == bobId && (e == TIMEOUT || e == NETWORK); _ -> False - liftIO $ noMessages alice "nothing else should be delivered to alice" - liftIO $ noMessages bob "nothing else should be delivered to bob" + runRight_ $ do + ("", "", DOWN _ _) <- nGet alice + ("", "", DOWN _ _) <- nGet bob + 3 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?" + 4 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "message 1" + deleteConnectionsAsync alice True [bobId] + get alice =##> \case ("", cId, DEL_RCVQ _ _ (Just (BROKER _ e))) -> cId == bobId && (e == TIMEOUT || e == NETWORK); _ -> False + liftIO $ noMessages alice "nothing else should be delivered to alice" + liftIO $ noMessages bob "nothing else should be delivered to bob" - withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do - get alice ##> ("", bobId, SENT $ baseId + 3) - get alice ##> ("", bobId, SENT $ baseId + 4) - get alice =##> \case ("", cId, DEL_CONN) -> cId == bobId; _ -> False + withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do + get alice ##> ("", bobId, SENT $ baseId + 3) + get alice ##> ("", bobId, SENT $ baseId + 4) + get alice =##> \case ("", cId, DEL_CONN) -> cId == bobId; _ -> False - liftIO $ - getInAnyOrder - bob - [ \case ("", "", APC SAENone (UP _ [cId])) -> cId == aliceId; _ -> False, - \case ("", cId, APC SAEConn (Msg "how are you?")) -> cId == aliceId; _ -> False - ] - ackMessage bob aliceId (baseId + 3) Nothing - get bob =##> \case ("", c, Msg "message 1") -> c == aliceId; _ -> False - ackMessage bob aliceId (baseId + 4) Nothing + liftIO $ + getInAnyOrder + bob + [ \case ("", "", APC SAENone (UP _ [cId])) -> cId == aliceId; _ -> False, + \case ("", cId, APC SAEConn (Msg "how are you?")) -> cId == aliceId; _ -> False + ] + ackMessage bob aliceId (baseId + 3) Nothing + get bob =##> \case ("", c, Msg "message 1") -> c == aliceId; _ -> False + ackMessage bob aliceId (baseId + 4) Nothing - -- queue wasn't deleted (DEL never reached server, see DEL_RCVQ with error), so bob can send message - 5 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "message 2" - get bob ##> ("", aliceId, SENT $ baseId + 5) + -- queue wasn't deleted (DEL never reached server, see DEL_RCVQ with error), so bob can send message + 5 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "message 2" + get bob ##> ("", aliceId, SENT $ baseId + 5) - liftIO $ noMessages alice "nothing else should be delivered to alice" - liftIO $ noMessages bob "nothing else should be delivered to bob" - - disposeAgentClient alice - disposeAgentClient bob + liftIO $ noMessages alice "nothing else should be delivered to alice" + liftIO $ noMessages bob "nothing else should be delivered to bob" where baseId = 3 msgId = subtract baseId testWaitDeliveryAUTHErr :: ATransport -> IO () -testWaitDeliveryAUTHErr t = do - alice <- getSMPAgentClient' 1 agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB - bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - (_aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do - (aliceId, bobId) <- makeConnection alice bob +testWaitDeliveryAUTHErr t = + withAgent 1 agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB $ \alice -> + withAgent 2 agentCfg initAgentServers testDB2 $ \bob -> do + (_aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do + (aliceId, bobId) <- makeConnection alice bob - 1 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "hello" - get alice ##> ("", bobId, SENT $ baseId + 1) - get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False - ackMessage bob aliceId (baseId + 1) Nothing + 1 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "hello" + get alice ##> ("", bobId, SENT $ baseId + 1) + get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False + ackMessage bob aliceId (baseId + 1) Nothing - 2 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "hello too" - get bob ##> ("", aliceId, SENT $ baseId + 2) - get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False - ackMessage alice bobId (baseId + 2) Nothing + 2 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "hello too" + get bob ##> ("", aliceId, SENT $ baseId + 2) + get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False + ackMessage alice bobId (baseId + 2) Nothing - deleteConnectionsAsync bob False [aliceId] - get bob =##> \case ("", cId, DEL_RCVQ _ _ Nothing) -> cId == aliceId; _ -> False - get bob =##> \case ("", cId, DEL_CONN) -> cId == aliceId; _ -> False + deleteConnectionsAsync bob False [aliceId] + get bob =##> \case ("", cId, DEL_RCVQ _ _ Nothing) -> cId == aliceId; _ -> False + get bob =##> \case ("", cId, DEL_CONN) -> cId == aliceId; _ -> False - pure (aliceId, bobId) + pure (aliceId, bobId) - runRight_ $ do - ("", "", DOWN _ _) <- nGet alice - 3 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?" - 4 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "message 1" - deleteConnectionsAsync alice True [bobId] - get alice =##> \case ("", cId, DEL_RCVQ _ _ (Just (BROKER _ e))) -> cId == bobId && (e == TIMEOUT || e == NETWORK); _ -> False - liftIO $ noMessages alice "nothing else should be delivered to alice" - liftIO $ noMessages bob "nothing else should be delivered to bob" + runRight_ $ do + ("", "", DOWN _ _) <- nGet alice + 3 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?" + 4 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "message 1" + deleteConnectionsAsync alice True [bobId] + get alice =##> \case ("", cId, DEL_RCVQ _ _ (Just (BROKER _ e))) -> cId == bobId && (e == TIMEOUT || e == NETWORK); _ -> False + liftIO $ noMessages alice "nothing else should be delivered to alice" + liftIO $ noMessages bob "nothing else should be delivered to bob" - withSmpServerStoreLogOn t testPort $ \_ -> do - 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 + withSmpServerStoreLogOn t testPort $ \_ -> do + 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" - liftIO $ noMessages bob "nothing else should be delivered to bob" - - disposeAgentClient alice - disposeAgentClient bob + liftIO $ noMessages alice "nothing else should be delivered to alice" + liftIO $ noMessages bob "nothing else should be delivered to bob" where baseId = 3 msgId = subtract baseId testWaitDeliveryTimeout :: ATransport -> IO () -testWaitDeliveryTimeout t = do - alice <- getSMPAgentClient' 1 agentCfg {connDeleteDeliveryTimeout = 1, initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB - bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - (aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do - (aliceId, bobId) <- makeConnection alice bob +testWaitDeliveryTimeout t = + withAgent 1 agentCfg {connDeleteDeliveryTimeout = 1, initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB $ \alice -> + withAgent 2 agentCfg initAgentServers testDB2 $ \bob -> do + (aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do + (aliceId, bobId) <- makeConnection alice bob - 1 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "hello" - get alice ##> ("", bobId, SENT $ baseId + 1) - get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False - ackMessage bob aliceId (baseId + 1) Nothing + 1 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "hello" + get alice ##> ("", bobId, SENT $ baseId + 1) + get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False + ackMessage bob aliceId (baseId + 1) Nothing - 2 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "hello too" - get bob ##> ("", aliceId, SENT $ baseId + 2) - get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False - ackMessage alice bobId (baseId + 2) Nothing + 2 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "hello too" + get bob ##> ("", aliceId, SENT $ baseId + 2) + get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False + ackMessage alice bobId (baseId + 2) Nothing - pure (aliceId, bobId) + pure (aliceId, bobId) - runRight_ $ do - ("", "", DOWN _ _) <- nGet alice - ("", "", DOWN _ _) <- nGet bob - 3 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?" - 4 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "message 1" - deleteConnectionsAsync alice True [bobId] - get alice =##> \case ("", cId, DEL_RCVQ _ _ (Just (BROKER _ e))) -> cId == bobId && (e == TIMEOUT || e == NETWORK); _ -> False - get alice =##> \case ("", cId, DEL_CONN) -> cId == bobId; _ -> False - liftIO $ noMessages alice "nothing else should be delivered to alice" - liftIO $ noMessages bob "nothing else should be delivered to bob" + runRight_ $ do + ("", "", DOWN _ _) <- nGet alice + ("", "", DOWN _ _) <- nGet bob + 3 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?" + 4 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "message 1" + deleteConnectionsAsync alice True [bobId] + get alice =##> \case ("", cId, DEL_RCVQ _ _ (Just (BROKER _ e))) -> cId == bobId && (e == TIMEOUT || e == NETWORK); _ -> False + get alice =##> \case ("", cId, DEL_CONN) -> cId == bobId; _ -> False + liftIO $ noMessages alice "nothing else should be delivered to alice" + liftIO $ noMessages bob "nothing else should be delivered to bob" - liftIO $ threadDelay 100000 + liftIO $ threadDelay 100000 - withSmpServerStoreLogOn t testPort $ \_ -> do - nGet bob =##> \case ("", "", UP _ [cId]) -> cId == aliceId; _ -> False - liftIO $ noMessages alice "nothing else should be delivered to alice" - liftIO $ noMessages bob "nothing else should be delivered to bob" - - disposeAgentClient alice - disposeAgentClient bob + withSmpServerStoreLogOn t testPort $ \_ -> do + nGet bob =##> \case ("", "", UP _ [cId]) -> cId == aliceId; _ -> False + liftIO $ noMessages alice "nothing else should be delivered to alice" + liftIO $ noMessages bob "nothing else should be delivered to bob" where baseId = 3 msgId = subtract baseId testWaitDeliveryTimeout2 :: ATransport -> IO () -testWaitDeliveryTimeout2 t = do - alice <- getSMPAgentClient' 1 agentCfg {connDeleteDeliveryTimeout = 2, messageRetryInterval = fastMessageRetryInterval, initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB - bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - (aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do - (aliceId, bobId) <- makeConnection alice bob +testWaitDeliveryTimeout2 t = + withAgent 1 agentCfg {connDeleteDeliveryTimeout = 2, messageRetryInterval = fastMessageRetryInterval, initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB $ \alice -> + withAgent 2 agentCfg initAgentServers testDB2 $ \bob -> do + (aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do + (aliceId, bobId) <- makeConnection alice bob - 1 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "hello" - get alice ##> ("", bobId, SENT $ baseId + 1) - get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False - ackMessage bob aliceId (baseId + 1) Nothing + 1 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "hello" + get alice ##> ("", bobId, SENT $ baseId + 1) + get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False + ackMessage bob aliceId (baseId + 1) Nothing - 2 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "hello too" - get bob ##> ("", aliceId, SENT $ baseId + 2) - get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False - ackMessage alice bobId (baseId + 2) Nothing + 2 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "hello too" + get bob ##> ("", aliceId, SENT $ baseId + 2) + get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False + ackMessage alice bobId (baseId + 2) Nothing - pure (aliceId, bobId) + pure (aliceId, bobId) - runRight_ $ do - ("", "", DOWN _ _) <- nGet alice - ("", "", DOWN _ _) <- nGet bob - 3 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?" - 4 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "message 1" - deleteConnectionsAsync alice True [bobId] - get alice =##> \case ("", cId, DEL_RCVQ _ _ (Just (BROKER _ e))) -> cId == bobId && (e == TIMEOUT || e == NETWORK); _ -> False - get alice =##> \case ("", cId, DEL_CONN) -> cId == bobId; _ -> False - liftIO $ noMessages alice "nothing else should be delivered to alice" - liftIO $ noMessages bob "nothing else should be delivered to bob" + runRight_ $ do + ("", "", DOWN _ _) <- nGet alice + ("", "", DOWN _ _) <- nGet bob + 3 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?" + 4 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "message 1" + deleteConnectionsAsync alice True [bobId] + get alice =##> \case ("", cId, DEL_RCVQ _ _ (Just (BROKER _ e))) -> cId == bobId && (e == TIMEOUT || e == NETWORK); _ -> False + get alice =##> \case ("", cId, DEL_CONN) -> cId == bobId; _ -> False + liftIO $ noMessages alice "nothing else should be delivered to alice" + liftIO $ noMessages bob "nothing else should be delivered to bob" - withSmpServerStoreLogOn t testPort $ \_ -> do - get alice ##> ("", bobId, SENT $ baseId + 3) - -- "message 1" not delivered + withSmpServerStoreLogOn t testPort $ \_ -> do + get alice ##> ("", bobId, SENT $ baseId + 3) + -- "message 1" not delivered - liftIO $ - getInAnyOrder - bob - [ \case ("", "", APC SAENone (UP _ [cId])) -> cId == aliceId; _ -> False, - \case ("", cId, APC SAEConn (Msg "how are you?")) -> cId == aliceId; _ -> False - ] - liftIO $ noMessages alice "nothing else should be delivered to alice" - liftIO $ noMessages bob "nothing else should be delivered to bob" - - disposeAgentClient alice - disposeAgentClient bob + liftIO $ + getInAnyOrder + bob + [ \case ("", "", APC SAENone (UP _ [cId])) -> cId == aliceId; _ -> False, + \case ("", cId, APC SAEConn (Msg "how are you?")) -> cId == aliceId; _ -> False + ] + liftIO $ noMessages alice "nothing else should be delivered to alice" + liftIO $ noMessages bob "nothing else should be delivered to bob" where baseId = 3 msgId = subtract baseId @@ -1894,43 +1919,41 @@ testWaitDeliveryTimeout2 t = do testJoinConnectionAsyncReplyError :: HasCallStack => ATransport -> IO () testJoinConnectionAsyncReplyError t = do let initAgentServersSrv2 = initAgentServers {smp = userServers [noAuthSrv testSMPServer2]} - a <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - b <- getSMPAgentClient' 2 agentCfg initAgentServersSrv2 testDB2 - (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do - bId <- createConnectionAsync a 1 "1" True SCMInvitation (IKNoPQ PQSupportOn) SMSubscribe - ("1", bId', INV (ACR _ qInfo)) <- get a - liftIO $ bId' `shouldBe` bId - aId <- joinConnectionAsync b 1 "2" True qInfo "bob's connInfo" PQSupportOn SMSubscribe - liftIO $ threadDelay 500000 - ConnectionStats {rcvQueuesInfo = [], sndQueuesInfo = [SndQueueInfo {}]} <- getConnectionServers b aId - pure (aId, bId) - nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False - withSmpServerOn t testPort2 $ do - get b =##> \case ("2", c, OK) -> c == aId; _ -> False - confId <- withSmpServerStoreLogOn t testPort $ \_ -> do - pGet a >>= \case - ("", "", APC _ (UP _ [_])) -> do - ("", _, CONF confId _ "bob's connInfo") <- get a - pure confId - ("", _, APC _ (CONF confId _ "bob's connInfo")) -> do - ("", "", UP _ [_]) <- nGet a - pure confId - r -> error $ "unexpected response " <> show r - nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False - runRight_ $ do - allowConnectionAsync a "3" bId confId "alice's connInfo" - liftIO $ threadDelay 500000 - ConnectionStats {rcvQueuesInfo = [RcvQueueInfo {}], sndQueuesInfo = [SndQueueInfo {}]} <- getConnectionServers b aId - pure () - withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do - pGet a =##> \case ("3", c, APC _ OK) -> c == bId; ("", "", APC _ (UP _ [c])) -> c == bId; _ -> False - pGet a =##> \case ("3", c, APC _ OK) -> c == bId; ("", "", APC _ (UP _ [c])) -> c == bId; _ -> False - get a ##> ("", bId, CON) - get b ##> ("", aId, INFO "alice's connInfo") - get b ##> ("", aId, CON) - exchangeGreetings a bId b aId - disposeAgentClient a - disposeAgentClient b + withAgent 1 agentCfg initAgentServers testDB $ \a -> + withAgent 2 agentCfg initAgentServersSrv2 testDB2 $ \b -> do + (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do + bId <- createConnectionAsync a 1 "1" True SCMInvitation (IKNoPQ PQSupportOn) SMSubscribe + ("1", bId', INV (ACR _ qInfo)) <- get a + liftIO $ bId' `shouldBe` bId + aId <- joinConnectionAsync b 1 "2" True qInfo "bob's connInfo" PQSupportOn SMSubscribe + liftIO $ threadDelay 500000 + ConnectionStats {rcvQueuesInfo = [], sndQueuesInfo = [SndQueueInfo {}]} <- getConnectionServers b aId + pure (aId, bId) + nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False + withSmpServerOn t testPort2 $ do + get b =##> \case ("2", c, OK) -> c == aId; _ -> False + confId <- withSmpServerStoreLogOn t testPort $ \_ -> do + pGet a >>= \case + ("", "", APC _ (UP _ [_])) -> do + ("", _, CONF confId _ "bob's connInfo") <- get a + pure confId + ("", _, APC _ (CONF confId _ "bob's connInfo")) -> do + ("", "", UP _ [_]) <- nGet a + pure confId + r -> error $ "unexpected response " <> show r + nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False + runRight_ $ do + allowConnectionAsync a "3" bId confId "alice's connInfo" + liftIO $ threadDelay 500000 + ConnectionStats {rcvQueuesInfo = [RcvQueueInfo {}], sndQueuesInfo = [SndQueueInfo {}]} <- getConnectionServers b aId + pure () + withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do + pGet a =##> \case ("3", c, APC _ OK) -> c == bId; ("", "", APC _ (UP _ [c])) -> c == bId; _ -> False + pGet a =##> \case ("3", c, APC _ OK) -> c == bId; ("", "", APC _ (UP _ [c])) -> c == bId; _ -> False + get a ##> ("", bId, CON) + get b ##> ("", aId, INFO "alice's connInfo") + get b ##> ("", aId, CON) + exchangeGreetings a bId b aId testUsers :: IO () testUsers = @@ -1985,16 +2008,12 @@ testUsersNoServer t = withAgentClientsCfg2 aCfg agentCfg $ \a b -> do aCfg = agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} testSwitchConnection :: InitialAgentServers -> IO () -testSwitchConnection servers = do - a <- getSMPAgentClient' 1 agentCfg servers testDB - b <- getSMPAgentClient' 2 agentCfg servers testDB2 - runRight_ $ do +testSwitchConnection servers = + withAgentClientsCfgServers2 agentCfg agentCfg servers $ \a b -> runRight_ $ do (aId, bId) <- makeConnection a b exchangeGreetingsMsgId 4 a bId b aId testFullSwitch a bId b aId 10 testFullSwitch a bId b aId 16 - disposeAgentClient a - disposeAgentClient b testFullSwitch :: AgentClient -> ByteString -> AgentClient -> ByteString -> Int64 -> ExceptT AgentErrorType IO () testFullSwitch a bId b aId msgId = do @@ -2074,7 +2093,7 @@ testSwitchAsync servers = do withB :: (AgentClient -> IO a) -> IO a withB = withAgent 2 agentCfg servers testDB2 -withAgent :: Int -> AgentConfig -> InitialAgentServers -> FilePath -> (AgentClient -> IO a) -> IO a +withAgent :: HasCallStack => Int -> AgentConfig -> InitialAgentServers -> FilePath -> (HasCallStack => AgentClient -> IO a) -> IO a withAgent clientId cfg' servers dbPath = bracket (getSMPAgentClient' clientId cfg' servers dbPath) disposeAgentClient sessionSubscribe :: (forall a. (AgentClient -> IO a) -> IO a) -> [ConnId] -> (AgentClient -> ExceptT AgentErrorType IO ()) -> IO () @@ -2087,10 +2106,8 @@ sessionSubscribe withC connIds a = pure r testSwitchDelete :: InitialAgentServers -> IO () -testSwitchDelete servers = do - a <- getSMPAgentClient' 1 agentCfg servers testDB - b <- getSMPAgentClient' 2 agentCfg servers testDB2 - runRight_ $ do +testSwitchDelete servers = + withAgentClientsCfgServers2 agentCfg agentCfg servers $ \a b -> runRight_ $ do (aId, bId) <- makeConnection a b exchangeGreetingsMsgId 4 a bId b aId liftIO $ disposeAgentClient b @@ -2102,8 +2119,6 @@ testSwitchDelete servers = do get a =##> \case ("", c, DEL_RCVQ _ _ Nothing) -> c == bId; _ -> False get a =##> \case ("", c, DEL_CONN) -> c == bId; _ -> False liftIO $ noMessages a "nothing else should be delivered to alice" - disposeAgentClient a - disposeAgentClient b testAbortSwitchStarted :: HasCallStack => InitialAgentServers -> IO () testAbortSwitchStarted servers = do @@ -2404,8 +2419,9 @@ testCreateQueueAuth srvVersion clnt1 clnt2 = do testSMPServerConnectionTest :: ATransport -> Maybe BasicAuth -> SMPServerWithAuth -> IO (Maybe ProtocolTestFailure) testSMPServerConnectionTest t newQueueBasicAuth srv = withSmpServerConfigOn t cfg {newQueueBasicAuth} testPort2 $ \_ -> do - a <- getSMPAgentClient' 1 agentCfg initAgentServers testDB -- initially passed server is not running - testProtocolServer a 1 srv + -- initially passed server is not running + withAgent 1 agentCfg initAgentServers testDB $ \a -> + testProtocolServer a 1 srv testRatchetAdHash :: HasCallStack => IO () testRatchetAdHash = @@ -2490,7 +2506,7 @@ testDeliveryReceiptsVersion t = do testDeliveryReceiptsConcurrent :: HasCallStack => ATransport -> IO () testDeliveryReceiptsConcurrent t = - withSmpServerConfigOn t cfg {msgQueueQuota = 128} testPort $ \_ -> do + withSmpServerConfigOn t cfg {msgQueueQuota = 256} testPort $ \_ -> do withAgentClients2 $ \a b -> do (aId, bId) <- runRight $ makeConnection a b t1 <- liftIO getCurrentTime @@ -2629,6 +2645,7 @@ testServerMultipleIdentities = getSMPAgentClient' 3 agentCfg initAgentServers testDB2 subscribeConnection bob' aliceId exchangeGreetingsMsgId 6 alice bobId bob' aliceId + liftIO $ disposeAgentClient bob' where secondIdentityCReq :: ConnectionRequestUri 'CMInvitation secondIdentityCReq = @@ -2644,6 +2661,33 @@ testServerMultipleIdentities = } testE2ERatchetParams12 +testWaitForUserNetwork :: HasCallStack => IO () +testWaitForUserNetwork = do + a <- getSMPAgentClient' 1 aCfg initAgentServers testDB + noNetworkDelay a + setUserNetworkInfo a $ UserNetworkInfo UNNone + networkDelay a 100000 + networkDelay a 150000 + networkDelay a 200000 + networkDelay a 200000 + setUserNetworkInfo a $ UserNetworkInfo UNCellular + noNetworkDelay a + setUserNetworkInfo a $ UserNetworkInfo UNNone + networkDelay a 100000 + concurrently_ + (threadDelay 50000 >> setUserNetworkInfo a (UserNetworkInfo UNCellular)) + (networkDelay a 50000) + noNetworkDelay a + where + aCfg = agentCfg {userNetworkInterval = RetryInterval {initialInterval = 100000, increaseAfter = 0, maxInterval = 200000}} + noNetworkDelay a = (10000 >) <$> waitNetwork a `shouldReturn` True + networkDelay a d' = (\d -> d' < d && d < d' + 15000) <$> waitNetwork a `shouldReturn` True + waitNetwork a = do + t <- getCurrentTime + waitForUserNetwork a `runReaderT` agentEnv a + t' <- getCurrentTime + pure $ diffToMicroseconds $ diffUTCTime t' t + exchangeGreetings :: HasCallStack => AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO () exchangeGreetings = exchangeGreetings_ PQEncOn diff --git a/tests/AgentTests/NotificationTests.hs b/tests/AgentTests/NotificationTests.hs index 722e48d02..2c1045791 100644 --- a/tests/AgentTests/NotificationTests.hs +++ b/tests/AgentTests/NotificationTests.hs @@ -17,7 +17,10 @@ import AgentTests.FunctionalAPITests createConnection, exchangeGreetingsMsgId, get, - getSMPAgentClient', + withAgent, + withAgentClients2, + withAgentClientsCfgServers2, + withAgentClients3, joinConnection, makeConnection, nGet, @@ -42,15 +45,15 @@ import Control.Monad.Trans.Except import qualified Data.Aeson as J import qualified Data.Aeson.Types as JT import Data.Bifunctor (bimap, first) +import qualified Data.ByteString.Base64.URL as U import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Text.Encoding (encodeUtf8) import NtfClient -import SMPAgentClient (agentCfg, initAgentServers, initAgentServers2, testDB, testDB2, testDB3, testNtfServer, testNtfServer2) +import SMPAgentClient (agentCfg, initAgentServers, initAgentServers2, testDB, testDB2, testNtfServer, testNtfServer2) import SMPClient (cfg, cfgV7, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn) import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMessage) import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), withStore') -import qualified Simplex.Messaging.Encoding.Base64.URL as U import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, Env (..), InitialAgentServers) import Simplex.Messaging.Agent.Protocol hiding (CON, CONF, INFO) import Simplex.Messaging.Agent.Store.SQLite (getSavedNtfToken) @@ -165,8 +168,7 @@ runNtfTestCfg t smpCfg ntfCfg aCfg bCfg runTest = testNotificationToken :: APNSMockServer -> IO () testNotificationToken APNSMockServer {apnsQ} = do - a <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - runRight_ $ do + withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight_ $ do let tkn = DeviceToken PPApnsTest "abcd" NTRegistered <- registerNtfToken a tkn NMPeriodic APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <- @@ -179,7 +181,7 @@ testNotificationToken APNSMockServer {apnsQ} = do deleteNtfToken a tkn -- agent deleted this token Left (CMD PROHIBITED) <- tryE $ checkNtfToken a tkn - liftIO $ disposeAgentClient a + pure () (.->) :: J.Value -> J.Key -> ExceptT AgentErrorType IO ByteString v .-> key = do @@ -193,8 +195,7 @@ testNtfTokenRepeatRegistration :: APNSMockServer -> IO () testNtfTokenRepeatRegistration APNSMockServer {apnsQ} = do -- setLogLevel LogError -- LogDebug -- withGlobalLogging logCfg $ do - a <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - runRight_ $ do + withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight_ $ do let tkn = DeviceToken PPApnsTest "abcd" NTRegistered <- registerNtfToken a tkn NMPeriodic APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <- @@ -211,15 +212,13 @@ testNtfTokenRepeatRegistration APNSMockServer {apnsQ} = do -- can still use the first verification code, it is the same after decryption verifyNtfToken a tkn nonce verification NTActive <- checkNtfToken a tkn - liftIO $ disposeAgentClient a + pure () testNtfTokenSecondRegistration :: APNSMockServer -> IO () -testNtfTokenSecondRegistration APNSMockServer {apnsQ} = do +testNtfTokenSecondRegistration APNSMockServer {apnsQ} = -- setLogLevel LogError -- LogDebug -- withGlobalLogging logCfg $ do - a <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - a' <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - runRight_ $ do + withAgentClients2 $ \a a' -> runRight_ $ do let tkn = DeviceToken PPApnsTest "abcd" NTRegistered <- registerNtfToken a tkn NMPeriodic APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <- @@ -248,37 +247,34 @@ testNtfTokenSecondRegistration APNSMockServer {apnsQ} = do -- and the second is active NTActive <- checkNtfToken a' tkn pure () - disposeAgentClient a - disposeAgentClient a' testNtfTokenServerRestart :: ATransport -> APNSMockServer -> IO () testNtfTokenServerRestart t APNSMockServer {apnsQ} = do - a <- getSMPAgentClient' 1 agentCfg initAgentServers testDB let tkn = DeviceToken PPApnsTest "abcd" - ntfData <- withNtfServer t . runRight $ do - NTRegistered <- registerNtfToken a tkn NMPeriodic - APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <- - 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 + ntfData <- withAgent 1 agentCfg initAgentServers testDB $ \a -> + withNtfServer t . runRight $ do + NTRegistered <- registerNtfToken a tkn NMPeriodic + APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <- + 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 threadDelay 1000000 - disposeAgentClient a - a' <- getSMPAgentClient' 2 agentCfg initAgentServers testDB - -- server stopped before token is verified, so now the attempt to verify it will return AUTH error but re-register token, - -- so that repeat verification happens without restarting the clients, when notification arrives - withNtfServer t . runRight_ $ do - verification <- ntfData .-> "verification" - nonce <- C.cbNonce <$> ntfData .-> "nonce" - 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" - nonce' <- C.cbNonce <$> ntfData' .-> "nonce" - liftIO $ sendApnsResponse' APNSRespOk - verifyNtfToken a' tkn nonce' verification' - NTActive <- checkNtfToken a' tkn - liftIO $ disposeAgentClient a' + 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, + -- so that repeat verification happens without restarting the clients, when notification arrives + withNtfServer t . runRight_ $ do + verification <- ntfData .-> "verification" + nonce <- C.cbNonce <$> ntfData .-> "nonce" + 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" + nonce' <- C.cbNonce <$> ntfData' .-> "nonce" + liftIO $ sendApnsResponse' APNSRespOk + verifyNtfToken a' tkn nonce' verification' + NTActive <- checkNtfToken a' tkn + pure () getTestNtfTokenPort :: AgentClient -> AE String getTestNtfTokenPort a = @@ -289,66 +285,62 @@ getTestNtfTokenPort a = testNtfTokenMultipleServers :: ATransport -> APNSMockServer -> IO () testNtfTokenMultipleServers t APNSMockServer {apnsQ} = do let tkn = DeviceToken PPApnsTest "abcd" - a <- getSMPAgentClient' 1 agentCfg initAgentServers2 testDB - withNtfServerThreadOn t ntfTestPort $ \ntf -> - withNtfServerThreadOn t ntfTestPort2 $ \ntf2 -> runRight_ $ do - -- register a new token, the agent picks a server and stores its choice - NTRegistered <- registerNtfToken a tkn NMPeriodic - APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <- - atomically $ readTBQueue apnsQ - verification <- ntfData .-> "verification" - nonce <- C.cbNonce <$> ntfData .-> "nonce" - liftIO $ sendApnsResponse APNSRespOk - verifyNtfToken a tkn nonce verification - NTActive <- checkNtfToken a tkn - -- shut down the "other" server - port <- getTestNtfTokenPort a - liftIO . killThread $ if port == ntfTestPort then ntf2 else ntf - -- still works - NTActive <- checkNtfToken a tkn - liftIO . killThread $ if port == ntfTestPort then ntf else ntf2 - -- negative test, the correct server is now gone - Left _ <- tryError (checkNtfToken a tkn) - pure () + withAgent 1 agentCfg initAgentServers2 testDB $ \a -> + withNtfServerThreadOn t ntfTestPort $ \ntf -> + withNtfServerThreadOn t ntfTestPort2 $ \ntf2 -> runRight_ $ do + -- register a new token, the agent picks a server and stores its choice + NTRegistered <- registerNtfToken a tkn NMPeriodic + APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <- + atomically $ readTBQueue apnsQ + verification <- ntfData .-> "verification" + nonce <- C.cbNonce <$> ntfData .-> "nonce" + liftIO $ sendApnsResponse APNSRespOk + verifyNtfToken a tkn nonce verification + NTActive <- checkNtfToken a tkn + -- shut down the "other" server + port <- getTestNtfTokenPort a + liftIO . killThread $ if port == ntfTestPort then ntf2 else ntf + -- still works + NTActive <- checkNtfToken a tkn + liftIO . killThread $ if port == ntfTestPort then ntf else ntf2 + -- negative test, the correct server is now gone + Left _ <- tryError (checkNtfToken a tkn) + pure () testNtfTokenChangeServers :: ATransport -> APNSMockServer -> IO () testNtfTokenChangeServers t APNSMockServer {apnsQ} = withNtfServerThreadOn t ntfTestPort $ \ntf -> do - tkn1 <- runRight $ do - a <- liftIO $ getSMPAgentClient' 1 agentCfg initAgentServers testDB + tkn1 <- withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight $ do tkn <- registerTestToken a "abcd" NMInstant apnsQ NTActive <- checkNtfToken a tkn liftIO $ setNtfServers a [testNtfServer2] NTActive <- checkNtfToken a tkn -- still works on old server - liftIO $ disposeAgentClient a pure tkn threadDelay 1000000 - a <- getSMPAgentClient' 2 agentCfg initAgentServers testDB - runRight_ $ do - getTestNtfTokenPort a >>= \port -> liftIO $ port `shouldBe` ntfTestPort - NTActive <- checkNtfToken a tkn1 - liftIO $ setNtfServers a [testNtfServer2] -- just change configured server list - getTestNtfTokenPort a >>= \port -> liftIO $ port `shouldBe` ntfTestPort -- not yet changed - -- trigger token replace - tkn2 <- registerTestToken a "xyzw" NMInstant apnsQ - getTestNtfTokenPort a >>= \port -> liftIO $ port `shouldBe` ntfTestPort -- not yet changed - deleteNtfToken a tkn2 -- force server switch - Left BROKER {brokerErr = NETWORK} <- tryError $ registerTestToken a "qwer" NMInstant apnsQ -- ok, it's down for now - getTestNtfTokenPort a >>= \port2 -> liftIO $ port2 `shouldBe` ntfTestPort2 -- but the token got updated - killThread ntf - withNtfServerOn t ntfTestPort2 $ runRight_ $ do - tkn <- registerTestToken a "qwer" NMInstant apnsQ - checkNtfToken a tkn >>= \r -> liftIO $ r `shouldBe` NTActive + withAgent 2 agentCfg initAgentServers testDB $ \a -> do + runRight_ $ do + getTestNtfTokenPort a >>= \port -> liftIO $ port `shouldBe` ntfTestPort + NTActive <- checkNtfToken a tkn1 + liftIO $ setNtfServers a [testNtfServer2] -- just change configured server list + getTestNtfTokenPort a >>= \port -> liftIO $ port `shouldBe` ntfTestPort -- not yet changed + -- trigger token replace + tkn2 <- registerTestToken a "xyzw" NMInstant apnsQ + getTestNtfTokenPort a >>= \port -> liftIO $ port `shouldBe` ntfTestPort -- not yet changed + deleteNtfToken a tkn2 -- force server switch + Left BROKER {brokerErr = NETWORK} <- tryError $ registerTestToken a "qwer" NMInstant apnsQ -- ok, it's down for now + getTestNtfTokenPort a >>= \port2 -> liftIO $ port2 `shouldBe` ntfTestPort2 -- but the token got updated + killThread ntf + withNtfServerOn t ntfTestPort2 $ runRight_ $ do + tkn <- registerTestToken a "qwer" NMInstant apnsQ + checkNtfToken a tkn >>= \r -> liftIO $ r `shouldBe` NTActive testRunNTFServerTests :: ATransport -> NtfServer -> IO (Maybe ProtocolTestFailure) testRunNTFServerTests t srv = - withNtfServerThreadOn t ntfTestPort $ \ntf -> do - a <- liftIO $ getSMPAgentClient' 1 agentCfg initAgentServers testDB - r <- testProtocolServer a 1 $ ProtoServerWithAuth srv Nothing - killThread ntf - pure r + withNtfServerOn t ntfTestPort $ + withAgent 1 agentCfg initAgentServers testDB $ \a -> + testProtocolServer a 1 $ ProtoServerWithAuth srv Nothing testNotificationSubscriptionExistingConnection :: APNSMockServer -> AgentClient -> AgentClient -> IO () testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} alice@AgentClient {agentEnv = Env {config = aliceCfg}} bob = do @@ -383,11 +375,9 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} alice@Agen Left (CMD PROHIBITED) <- runExceptT $ getNotificationMessage alice nonce message -- aliceNtf client doesn't have subscription and is allowed to get notification message - aliceNtf <- getSMPAgentClient' 3 aliceCfg initAgentServers testDB - runRight_ $ do + withAgent 3 aliceCfg initAgentServers testDB $ \aliceNtf -> runRight_ $ do (_, [SMPMsgMeta {msgFlags = MsgFlags True}]) <- getNotificationMessage aliceNtf nonce message pure () - disposeAgentClient aliceNtf runRight_ $ do get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False @@ -459,10 +449,8 @@ registerTestToken a token mode apnsQ = do pure tkn testChangeNotificationsMode :: APNSMockServer -> IO () -testChangeNotificationsMode APNSMockServer {apnsQ} = do - alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - runRight_ $ do +testChangeNotificationsMode APNSMockServer {apnsQ} = + withAgentClients2 $ \alice bob -> runRight_ $ do -- establish connection (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe @@ -518,17 +506,13 @@ testChangeNotificationsMode APNSMockServer {apnsQ} = do ackMessage alice bobId (baseId + 5) Nothing -- no notifications should follow noNotification apnsQ - disposeAgentClient alice - disposeAgentClient bob where baseId = 3 msgId = subtract baseId testChangeToken :: APNSMockServer -> IO () -testChangeToken APNSMockServer {apnsQ} = do - alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - (aliceId, bobId) <- runRight $ do +testChangeToken APNSMockServer {apnsQ} = withAgent 1 agentCfg initAgentServers testDB2 $ \bob -> do + (aliceId, bobId) <- withAgent 2 agentCfg initAgentServers testDB $ \alice -> runRight $ do -- establish connection (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe @@ -547,10 +531,8 @@ testChangeToken APNSMockServer {apnsQ} = do get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False ackMessage alice bobId (baseId + 1) Nothing pure (aliceId, bobId) - disposeAgentClient alice - alice1 <- getSMPAgentClient' 3 agentCfg initAgentServers testDB - runRight_ $ do + withAgent 3 agentCfg initAgentServers testDB $ \alice1 -> runRight_ $ do subscribeConnection alice1 bobId -- change notification token void $ registerTestToken alice1 "bcde" NMInstant apnsQ @@ -563,16 +545,12 @@ testChangeToken APNSMockServer {apnsQ} = do ackMessage alice1 bobId (baseId + 2) Nothing -- no notifications should follow noNotification apnsQ - disposeAgentClient alice1 - disposeAgentClient bob where baseId = 3 msgId = subtract baseId testNotificationsStoreLog :: ATransport -> APNSMockServer -> IO () -testNotificationsStoreLog t APNSMockServer {apnsQ} = do - alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 +testNotificationsStoreLog t APNSMockServer {apnsQ} = withAgentClients2 $ \alice bob -> do (aliceId, bobId) <- withNtfServerStoreLog t $ \threadId -> runRight $ do (aliceId, bobId) <- makeConnection alice bob _ <- registerTestToken alice "abcd" NMInstant apnsQ @@ -594,13 +572,9 @@ testNotificationsStoreLog t APNSMockServer {apnsQ} = do void $ messageNotificationData alice apnsQ get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False liftIO $ killThread threadId - disposeAgentClient alice - disposeAgentClient bob testNotificationsSMPRestart :: ATransport -> APNSMockServer -> IO () -testNotificationsSMPRestart t APNSMockServer {apnsQ} = do - alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 +testNotificationsSMPRestart t APNSMockServer {apnsQ} = withAgentClients2 $ \alice bob -> do (aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \threadId -> runRight $ do (aliceId, bobId) <- makeConnection alice bob _ <- registerTestToken alice "abcd" NMInstant apnsQ @@ -626,49 +600,44 @@ testNotificationsSMPRestart t APNSMockServer {apnsQ} = do _ <- messageNotificationData alice apnsQ get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False liftIO $ killThread threadId - disposeAgentClient alice - disposeAgentClient bob testNotificationsSMPRestartBatch :: Int -> ATransport -> APNSMockServer -> IO () -testNotificationsSMPRestartBatch n t APNSMockServer {apnsQ} = do - a <- getSMPAgentClient' 1 agentCfg initAgentServers2 testDB - b <- getSMPAgentClient' 2 agentCfg initAgentServers2 testDB2 - threadDelay 1000000 - conns <- runServers $ do - conns <- replicateM (n :: Int) $ makeConnection a b - _ <- registerTestToken a "abcd" NMInstant apnsQ - liftIO $ threadDelay 5000000 - forM_ conns $ \(aliceId, bobId) -> do - msgId <- sendMessage b aliceId (SMP.MsgFlags True) "hello" - get b ##> ("", aliceId, SENT msgId) - void $ messageNotificationData a apnsQ - get a =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False - ackMessage a bobId msgId Nothing - pure conns +testNotificationsSMPRestartBatch n t APNSMockServer {apnsQ} = + withAgentClientsCfgServers2 agentCfg agentCfg initAgentServers2 $ \a b -> do + threadDelay 1000000 + conns <- runServers $ do + conns <- replicateM (n :: Int) $ makeConnection a b + _ <- registerTestToken a "abcd" NMInstant apnsQ + liftIO $ threadDelay 5000000 + forM_ conns $ \(aliceId, bobId) -> do + msgId <- sendMessage b aliceId (SMP.MsgFlags True) "hello" + get b ##> ("", aliceId, SENT msgId) + void $ messageNotificationData a apnsQ + get a =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False + ackMessage a bobId msgId Nothing + pure conns - runRight_ @AgentErrorType $ do - ("", "", DOWN _ bcs1) <- nGet a - ("", "", DOWN _ bcs2) <- nGet a - liftIO $ length (bcs1 <> bcs2) `shouldBe` length conns - ("", "", DOWN _ acs1) <- nGet b - ("", "", DOWN _ acs2) <- nGet b - liftIO $ length (acs1 <> acs2) `shouldBe` length conns + runRight_ @AgentErrorType $ do + ("", "", DOWN _ bcs1) <- nGet a + ("", "", DOWN _ bcs2) <- nGet a + liftIO $ length (bcs1 <> bcs2) `shouldBe` length conns + ("", "", DOWN _ acs1) <- nGet b + ("", "", DOWN _ acs2) <- nGet b + liftIO $ length (acs1 <> acs2) `shouldBe` length conns - runServers $ do - ("", "", UP _ bcs1) <- nGet a - ("", "", UP _ bcs2) <- nGet a - liftIO $ length (bcs1 <> bcs2) `shouldBe` length conns - ("", "", UP _ acs1) <- nGet b - ("", "", UP _ acs2) <- nGet b - liftIO $ length (acs1 <> acs2) `shouldBe` length conns - liftIO $ threadDelay 1500000 - forM_ conns $ \(aliceId, bobId) -> do - msgId <- sendMessage b aliceId (SMP.MsgFlags True) "hello again" - get b ##> ("", aliceId, SENT msgId) - _ <- messageNotificationData a apnsQ - get a =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False - disposeAgentClient a - disposeAgentClient b + runServers $ do + ("", "", UP _ bcs1) <- nGet a + ("", "", UP _ bcs2) <- nGet a + liftIO $ length (bcs1 <> bcs2) `shouldBe` length conns + ("", "", UP _ acs1) <- nGet b + ("", "", UP _ acs2) <- nGet b + liftIO $ length (acs1 <> acs2) `shouldBe` length conns + liftIO $ threadDelay 1500000 + forM_ conns $ \(aliceId, bobId) -> do + msgId <- sendMessage b aliceId (SMP.MsgFlags True) "hello again" + get b ##> ("", aliceId, SENT msgId) + _ <- messageNotificationData a apnsQ + get a =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False where runServers :: ExceptT AgentErrorType IO a -> IO a runServers a = do @@ -679,10 +648,8 @@ testNotificationsSMPRestartBatch n t APNSMockServer {apnsQ} = do pure res testSwitchNotifications :: InitialAgentServers -> APNSMockServer -> IO () -testSwitchNotifications servers APNSMockServer {apnsQ} = do - a <- getSMPAgentClient' 1 agentCfg servers testDB - b <- getSMPAgentClient' 2 agentCfg servers testDB2 - runRight_ $ do +testSwitchNotifications servers APNSMockServer {apnsQ} = + withAgentClientsCfgServers2 agentCfg agentCfg servers $ \a b -> runRight_ $ do (aId, bId) <- makeConnection a b exchangeGreetingsMsgId 4 a bId b aId _ <- registerTestToken a "abcd" NMInstant apnsQ @@ -698,15 +665,10 @@ testSwitchNotifications servers APNSMockServer {apnsQ} = do switchComplete a bId b aId liftIO $ threadDelay 500000 testMessage "hello again" - disposeAgentClient a - disposeAgentClient b testNotificationsOldToken :: APNSMockServer -> IO () -testNotificationsOldToken APNSMockServer {apnsQ} = do - a <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - b <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - c <- getSMPAgentClient' 3 agentCfg initAgentServers testDB3 - runRight_ $ do +testNotificationsOldToken APNSMockServer {apnsQ} = + withAgentClients3 $ \a b c -> runRight_ $ do (abId, baId) <- makeConnection a b let testMessageAB = testMessage_ apnsQ a abId b baId _ <- registerTestToken a "abcd" NMInstant apnsQ @@ -722,16 +684,10 @@ testNotificationsOldToken APNSMockServer {apnsQ} = do (acId, caId) <- makeConnection a c let testMessageAC = testMessage_ apnsQ a acId c caId testMessageAC "greetings" - disposeAgentClient a - disposeAgentClient b - disposeAgentClient c testNotificationsNewToken :: APNSMockServer -> ThreadId -> IO () -testNotificationsNewToken APNSMockServer {apnsQ} oldNtf = do - a <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - b <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - c <- getSMPAgentClient' 3 agentCfg initAgentServers testDB3 - runRight_ $ do +testNotificationsNewToken APNSMockServer {apnsQ} oldNtf = + withAgentClients3 $ \a b c -> runRight_ $ do (abId, baId) <- makeConnection a b let testMessageAB = testMessage_ apnsQ a abId b baId tkn <- registerTestToken a "abcd" NMInstant apnsQ @@ -750,9 +706,6 @@ testNotificationsNewToken APNSMockServer {apnsQ} oldNtf = do (acId, caId) <- makeConnection a c let testMessageAC = testMessage_ apnsQ a acId c caId testMessageAC "greetings" - disposeAgentClient a - disposeAgentClient b - disposeAgentClient c testMessage_ :: HasCallStack => TBQueue APNSMockRequest -> AgentClient -> ConnId -> AgentClient -> ConnId -> SMP.MsgBody -> ExceptT AgentErrorType IO () testMessage_ apnsQ a aId b bId msg = do diff --git a/tests/CoreTests/CryptoTests.hs b/tests/CoreTests/CryptoTests.hs index 35e82d6d2..0a6ca90db 100644 --- a/tests/CoreTests/CryptoTests.hs +++ b/tests/CoreTests/CryptoTests.hs @@ -16,9 +16,14 @@ import Data.Text.Encoding (encodeUtf8) import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Encoding as LE import Data.Type.Equality +import qualified Data.X509 as X +import qualified Data.X509.CertificateStore as XS +import qualified Data.X509.Validation as XV +import qualified SMPClient import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto.Lazy as LC import Simplex.Messaging.Crypto.SNTRUP761.Bindings +import Simplex.Messaging.Transport.Client import Test.Hspec import Test.Hspec.QuickCheck (modifyMaxSuccess) import Test.QuickCheck @@ -91,6 +96,8 @@ cryptoTests = do describe "Ed448" $ testEncoding C.SEd448 describe "X25519" $ testEncoding C.SX25519 describe "X448" $ testEncoding C.SX448 + describe "X509 chains" $ do + it "should validate certificates" testValidateX509 describe "sntrup761" $ it "should enc/dec key" testSNTRUP761 @@ -223,6 +230,39 @@ testEncoding alg = it "should encode / decode key" . ioProperty $ do C.decodePubKey (C.encodePubKey k) == Right k && C.decodePrivKey (C.encodePrivKey pk) == Right pk +testValidateX509 :: IO () +testValidateX509 = do + let checkChain = validateCertificateChain SMPClient.testKeyHash "localhost" "5223" . X.CertificateChain + checkChain [] `shouldReturn` [XV.EmptyChain] + + caCreds <- XS.readCertificates "tests/fixtures/ca.crt" + caCreds `shouldNotBe` [] + let ca = head caCreds + + serverCreds <- XS.readCertificates "tests/fixtures/server.crt" + serverCreds `shouldNotBe` [] + let server = head serverCreds + checkChain [server, ca] `shouldReturn` [] + + ca2Creds <- XS.readCertificates "tests/fixtures/ca2.crt" + ca2Creds `shouldNotBe` [] + let ca2 = head ca2Creds + + -- signed by another CA + server2Creds <- XS.readCertificates "tests/fixtures/server2.crt" + server2Creds `shouldNotBe` [] + let server2 = head server2Creds + checkChain [server2, ca2] `shouldReturn` [XV.UnknownCA] + + -- messed up key rotation or other configuration problems + checkChain [server2, ca] `shouldReturn` [XV.InvalidSignature XV.SignatureInvalid] + + -- self-signed, unrelated to CA + ssCreds <- XS.readCertificates "tests/fixtures/ss.crt" + ssCreds `shouldNotBe` [] + let ss = head ssCreds + checkChain [ss, ca] `shouldReturn` [XV.SelfSigned] + testSNTRUP761 :: IO () testSNTRUP761 = do drg <- C.newRandom diff --git a/tests/NtfServerTests.hs b/tests/NtfServerTests.hs index 027675aeb..e7e2018c2 100644 --- a/tests/NtfServerTests.hs +++ b/tests/NtfServerTests.hs @@ -15,6 +15,7 @@ import Control.Concurrent (threadDelay) import qualified Data.Aeson as J import qualified Data.Aeson.Types as JT import Data.Bifunctor (first) +import qualified Data.ByteString.Base64.URL as U import Data.ByteString.Char8 (ByteString) import Data.Text.Encoding (encodeUtf8) import NtfClient @@ -34,7 +35,6 @@ import ServerTests import qualified Simplex.Messaging.Agent.Protocol as AP import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding -import qualified Simplex.Messaging.Encoding.Base64.URL as U import Simplex.Messaging.Encoding.String import Simplex.Messaging.Notifications.Protocol import Simplex.Messaging.Notifications.Server.Push.APNS diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index 330a3f14c..3e5e9d2ce 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -123,7 +123,7 @@ withSmpServerConfigOn :: HasCallStack => ATransport -> ServerConfig -> ServiceNa withSmpServerConfigOn t cfg' port' = serverBracket (\started -> runSMPServerBlocking started cfg' {transports = [(port', t)]}) - (pure ()) + (threadDelay 10000) withSmpServerThreadOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a withSmpServerThreadOn t = withSmpServerConfigOn t cfg diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index 951a69771..09cf975c1 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -22,6 +22,7 @@ import Control.Exception (SomeException, try) import Control.Monad import Control.Monad.IO.Class import Data.Bifunctor (first) +import Data.ByteString.Base64 import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import qualified Data.Set as S @@ -30,7 +31,6 @@ import GHC.Stack (withFrozenCallStack) import SMPClient import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding -import Simplex.Messaging.Encoding.Base64 (encode) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (parseAll) import Simplex.Messaging.Protocol @@ -769,7 +769,7 @@ testTiming (ATransport t) = (C.AuthAlg C.SX25519, C.AuthAlg C.SX25519, 200) -- correct key type ] timeRepeat n = fmap fst . timeItT . forM_ (replicate n ()) . const - similarTime t1 t2 = abs (t2 / t1 - 1) < 0.15 -- normally the difference between "no queue" and "wrong key" is less than 5% + similarTime t1 t2 = abs (t2 / t1 - 1) < 0.2 -- normally the difference between "no queue" and "wrong key" is less than 5% testSameTiming :: forall c. Transport c => THandleSMP c -> THandleSMP c -> (C.AuthAlg, C.AuthAlg, Int) -> Expectation testSameTiming rh sh (C.AuthAlg goodKeyAlg, C.AuthAlg badKeyAlg, n) = do g <- C.newRandom diff --git a/tests/XFTPAgent.hs b/tests/XFTPAgent.hs index 2befdcc76..2d865f140 100644 --- a/tests/XFTPAgent.hs +++ b/tests/XFTPAgent.hs @@ -8,7 +8,7 @@ module XFTPAgent where -import AgentTests.FunctionalAPITests (get, getSMPAgentClient', rfGet, runRight, runRight_, sfGet) +import AgentTests.FunctionalAPITests (get, rfGet, runRight, runRight_, sfGet, withAgent) import Control.Logger.Simple import Control.Monad @@ -20,11 +20,11 @@ import Data.Int (Int64) import Data.List (find, isSuffixOf) import Data.Maybe (fromJust) import SMPAgentClient (agentCfg, initAgentServers, testDB, testDB2, testDB3) -import Simplex.FileTransfer.Description (FileDescription (..), FileDescriptionURI (..), ValidFileDescription, fileDescriptionURI, mb, qrSizeLimit, pattern ValidFileDescription) +import Simplex.FileTransfer.Description (FileChunk (..), FileDescription (..), FileDescriptionURI (..), ValidFileDescription, fileDescriptionURI, mb, qrSizeLimit, pattern ValidFileDescription) import Simplex.FileTransfer.Protocol (FileParty (..)) -import Simplex.FileTransfer.Transport (XFTPErrorType (AUTH)) import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..)) -import Simplex.Messaging.Agent (AgentClient, disposeAgentClient, testProtocolServer, xftpDeleteRcvFile, xftpDeleteSndFileInternal, xftpDeleteSndFileRemote, xftpReceiveFile, xftpSendDescription, xftpSendFile, xftpStartWorkers) +import Simplex.FileTransfer.Transport (XFTPErrorType (AUTH)) +import Simplex.Messaging.Agent (AgentClient, testProtocolServer, xftpDeleteRcvFile, xftpDeleteSndFileInternal, xftpDeleteSndFileRemote, xftpReceiveFile, xftpSendDescription, xftpSendFile, xftpStartWorkers) import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..)) import Simplex.Messaging.Agent.Protocol (ACommand (..), AgentErrorType (..), BrokerErrorType (..), RcvFileId, SndFileId, noAuthSrv) import qualified Simplex.Messaging.Crypto as C @@ -100,21 +100,18 @@ testXFTPAgentSendReceive :: HasCallStack => IO () testXFTPAgentSendReceive = withXFTPServer $ do filePath <- createRandomFile -- send file, delete snd file internally - sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - (rfd1, rfd2) <- runRight $ do + (rfd1, rfd2) <- withAgent 1 agentCfg initAgentServers testDB $ \sndr -> runRight $ do (sfId, _, rfd1, rfd2) <- testSend sndr filePath liftIO $ xftpDeleteSndFileInternal sndr sfId pure (rfd1, rfd2) - -- receive file, delete rcv file testReceiveDelete 2 rfd1 filePath testReceiveDelete 3 rfd2 filePath where - testReceiveDelete clientId rfd originalFilePath = do - rcp <- getSMPAgentClient' clientId agentCfg initAgentServers testDB2 - rfId <- runRight $ testReceive rcp rfd originalFilePath - xftpDeleteRcvFile rcp rfId - disposeAgentClient rcp + testReceiveDelete clientId rfd originalFilePath = + withAgent clientId agentCfg initAgentServers testDB2 $ \rcp -> do + rfId <- runRight $ testReceive rcp rfd originalFilePath + xftpDeleteRcvFile rcp rfId testXFTPAgentSendReceiveEncrypted :: HasCallStack => IO () testXFTPAgentSendReceiveEncrypted = withXFTPServer $ do @@ -123,8 +120,7 @@ testXFTPAgentSendReceiveEncrypted = withXFTPServer $ do s <- LB.readFile filePath file <- atomically $ CryptoFile (senderFiles "encrypted_testfile") . Just <$> CF.randomArgs g runRight_ $ CF.writeFile file s - sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - (rfd1, rfd2) <- runRight $ do + (rfd1, rfd2) <- withAgent 1 agentCfg initAgentServers testDB $ \sndr -> runRight $ do (sfId, _, rfd1, rfd2) <- testSendCF sndr file liftIO $ xftpDeleteSndFileInternal sndr sfId pure (rfd1, rfd2) @@ -132,12 +128,11 @@ testXFTPAgentSendReceiveEncrypted = withXFTPServer $ do testReceiveDelete 2 rfd1 filePath g testReceiveDelete 3 rfd2 filePath g where - testReceiveDelete clientId rfd originalFilePath g = do - rcp <- getSMPAgentClient' clientId agentCfg initAgentServers testDB2 - cfArgs <- atomically $ Just <$> CF.randomArgs g - rfId <- runRight $ testReceiveCF rcp rfd cfArgs originalFilePath - xftpDeleteRcvFile rcp rfId - disposeAgentClient rcp + testReceiveDelete clientId rfd originalFilePath g = + withAgent clientId agentCfg initAgentServers testDB2 $ \rcp -> do + cfArgs <- atomically $ Just <$> CF.randomArgs g + rfId <- runRight $ testReceiveCF rcp rfd cfArgs originalFilePath + xftpDeleteRcvFile rcp rfId testXFTPAgentSendReceiveRedirect :: HasCallStack => IO () testXFTPAgentSendReceiveRedirect = withXFTPServer $ do @@ -145,93 +140,98 @@ testXFTPAgentSendReceiveRedirect = withXFTPServer $ do filePathIn <- createRandomFile let fileSize = mb 17 totalSize = fileSize + mb 1 - sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - directFileId <- runRight $ xftpSendFile sndr 1 (CryptoFile filePathIn Nothing) 1 - sfGet sndr `shouldReturn` ("", directFileId, SFPROG 4194304 totalSize) - sfGet sndr `shouldReturn` ("", directFileId, SFPROG 8388608 totalSize) - sfGet sndr `shouldReturn` ("", directFileId, SFPROG 12582912 totalSize) - sfGet sndr `shouldReturn` ("", directFileId, SFPROG 16777216 totalSize) - sfGet sndr `shouldReturn` ("", directFileId, SFPROG 17825792 totalSize) - sfGet sndr `shouldReturn` ("", directFileId, SFPROG totalSize totalSize) - vfdDirect <- - sfGet sndr >>= \case - (_, _, SFDONE _snd (vfd : _)) -> pure vfd - r -> error $ "Expected SFDONE, got " <> show r - redirectFileId <- runRight $ xftpSendDescription sndr 1 vfdDirect 1 - logInfo $ "File sent, sending redirect: " <> tshow redirectFileId - sfGet sndr `shouldReturn` ("", redirectFileId, SFPROG 65536 65536) - vfdRedirect@(ValidFileDescription fdRedirect) <- - sfGet sndr >>= \case - (_, _, SFDONE _snd (vfd : _)) -> pure vfd - r -> error $ "Expected SFDONE, got " <> show r - case fdRedirect of - FileDescription {redirect = Just _} -> pure () - _ -> error "missing RedirectFileInfo" - let uri = strEncode $ fileDescriptionURI vfdRedirect - case strDecode uri of - Left err -> fail err - Right ok -> ok `shouldBe` fileDescriptionURI vfdRedirect - disposeAgentClient sndr - --- recipient - rcp <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - FileDescriptionURI {description} <- either fail pure $ strDecode uri + withAgent 1 agentCfg initAgentServers testDB $ \sndr -> do + directFileId <- runRight $ xftpSendFile sndr 1 (CryptoFile filePathIn Nothing) 1 + sfGet sndr `shouldReturn` ("", directFileId, SFPROG 4194304 totalSize) + sfGet sndr `shouldReturn` ("", directFileId, SFPROG 8388608 totalSize) + sfGet sndr `shouldReturn` ("", directFileId, SFPROG 12582912 totalSize) + sfGet sndr `shouldReturn` ("", directFileId, SFPROG 16777216 totalSize) + sfGet sndr `shouldReturn` ("", directFileId, SFPROG 17825792 totalSize) + sfGet sndr `shouldReturn` ("", directFileId, SFPROG totalSize totalSize) + vfdDirect <- + sfGet sndr >>= \case + (_, _, SFDONE _snd (vfd : _)) -> pure vfd + r -> error $ "Expected SFDONE, got " <> show r - 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) - rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 12582912 totalSize) - rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 16777216 totalSize) - rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 17825792 totalSize) - rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG totalSize totalSize) - out <- - rfGet rcp >>= \case - (_, _, RFDONE out) -> pure out - r -> error $ "Expected RFDONE, got " <> show r - disposeAgentClient rcp + testNoRedundancy vfdDirect - inBytes <- B.readFile filePathIn - B.readFile out `shouldReturn` inBytes + redirectFileId <- runRight $ xftpSendDescription sndr 1 vfdDirect 1 + logInfo $ "File sent, sending redirect: " <> tshow redirectFileId + sfGet sndr `shouldReturn` ("", redirectFileId, SFPROG 65536 65536) + vfdRedirect@(ValidFileDescription fdRedirect) <- + sfGet sndr >>= \case + (_, _, SFDONE _snd (vfd : _)) -> pure vfd + r -> error $ "Expected SFDONE, got " <> show r + + testNoRedundancy vfdRedirect + + case fdRedirect of + FileDescription {redirect = Just _} -> pure () + _ -> error "missing RedirectFileInfo" + let uri = strEncode $ fileDescriptionURI vfdRedirect + case strDecode uri of + Left err -> fail err + Right ok -> ok `shouldBe` fileDescriptionURI vfdRedirect + --- recipient + withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> do + FileDescriptionURI {description} <- either fail pure $ strDecode uri + + 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) + rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 12582912 totalSize) + rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 16777216 totalSize) + rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 17825792 totalSize) + rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG totalSize totalSize) + out <- + rfGet rcp >>= \case + (_, _, RFDONE out) -> pure out + r -> error $ "Expected RFDONE, got " <> show r + + inBytes <- B.readFile filePathIn + B.readFile out `shouldReturn` inBytes testXFTPAgentSendReceiveNoRedirect :: HasCallStack => IO () testXFTPAgentSendReceiveNoRedirect = withXFTPServer $ do --- sender let fileSize = mb 5 filePathIn <- createRandomFile_ fileSize "testfile" - sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - directFileId <- runRight $ xftpSendFile sndr 1 (CryptoFile filePathIn Nothing) 1 - let totalSize = fileSize + mb 1 - sfGet sndr `shouldReturn` ("", directFileId, SFPROG 4194304 totalSize) - sfGet sndr `shouldReturn` ("", directFileId, SFPROG 5242880 totalSize) - sfGet sndr `shouldReturn` ("", directFileId, SFPROG totalSize totalSize) - vfdDirect <- - sfGet sndr >>= \case - (_, _, SFDONE _snd (vfd : _)) -> pure vfd - r -> error $ "Expected SFDONE, got " <> show r - let uri = strEncode $ fileDescriptionURI vfdDirect - B.length uri `shouldSatisfy` (< qrSizeLimit) - case strDecode uri of - Left err -> fail err - Right ok -> ok `shouldBe` fileDescriptionURI vfdDirect - disposeAgentClient sndr - --- recipient - rcp <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - FileDescriptionURI {description} <- either fail pure $ strDecode uri - let ValidFileDescription FileDescription {redirect} = description - redirect `shouldBe` Nothing - 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) - rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG totalSize totalSize) - out <- - rfGet rcp >>= \case - (_, _, RFDONE out) -> pure out - r -> error $ "Expected RFDONE, got " <> show r - disposeAgentClient rcp + withAgent 1 agentCfg initAgentServers testDB $ \sndr -> do + directFileId <- runRight $ xftpSendFile sndr 1 (CryptoFile filePathIn Nothing) 1 + let totalSize = fileSize + mb 1 + sfGet sndr `shouldReturn` ("", directFileId, SFPROG 4194304 totalSize) + sfGet sndr `shouldReturn` ("", directFileId, SFPROG 5242880 totalSize) + sfGet sndr `shouldReturn` ("", directFileId, SFPROG totalSize totalSize) + vfdDirect <- + sfGet sndr >>= \case + (_, _, SFDONE _snd (vfd : _)) -> pure vfd + r -> error $ "Expected SFDONE, got " <> show r - inBytes <- B.readFile filePathIn - B.readFile out `shouldReturn` inBytes + testNoRedundancy vfdDirect + + let uri = strEncode $ fileDescriptionURI vfdDirect + B.length uri `shouldSatisfy` (< qrSizeLimit) + case strDecode uri of + Left err -> fail err + Right ok -> ok `shouldBe` fileDescriptionURI vfdDirect + --- recipient + withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> do + FileDescriptionURI {description} <- either fail pure $ strDecode uri + let ValidFileDescription FileDescription {redirect} = description + redirect `shouldBe` Nothing + 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) + rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG totalSize totalSize) + out <- + rfGet rcp >>= \case + (_, _, RFDONE out) -> pure out + r -> error $ "Expected RFDONE, got " <> show r + + inBytes <- B.readFile filePathIn + B.readFile out `shouldReturn` inBytes createRandomFile :: HasCallStack => IO FilePath createRandomFile = createRandomFile' "testfile" @@ -255,9 +255,15 @@ testSendCF sndr file = do sfId <- xftpSendFile sndr 1 file 2 sfProgress sndr $ mb 18 ("", sfId', SFDONE sndDescr [rfd1, rfd2]) <- sfGet sndr + liftIO $ testNoRedundancy rfd1 + liftIO $ testNoRedundancy rfd2 liftIO $ sfId' `shouldBe` sfId pure (sfId, sndDescr, rfd1, rfd2) +testNoRedundancy :: HasCallStack => ValidFileDescription 'FRecipient -> IO () +testNoRedundancy (ValidFileDescription FileDescription {chunks}) = + all (\FileChunk {replicas} -> length replicas == 1) chunks `shouldBe` True + testReceive :: HasCallStack => AgentClient -> ValidFileDescription 'FRecipient -> FilePath -> ExceptT AgentErrorType IO RcvFileId testReceive rcp rfd = testReceiveCF rcp rfd Nothing @@ -284,52 +290,48 @@ logCfgNoLogs :: LogConfig logCfgNoLogs = LogConfig {lc_file = Nothing, lc_stderr = False} testXFTPAgentReceiveRestore :: HasCallStack => IO () -testXFTPAgentReceiveRestore = withGlobalLogging logCfgNoLogs $ do +testXFTPAgentReceiveRestore = do filePath <- createRandomFile - rfd <- withXFTPServerStoreLogOn $ \_ -> do + rfd <- withXFTPServerStoreLogOn $ \_ -> -- send file - sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - runRight $ do + withAgent 1 agentCfg initAgentServers testDB $ \sndr -> runRight $ do (_, _, rfd, _) <- testSend sndr filePath pure rfd -- receive file - should not succeed with server down - rcp <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - rfId <- runRight $ do + rfId <- withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> runRight $ do xftpStartWorkers rcp (Just recipientFiles) rfId <- xftpReceiveFile rcp 1 rfd Nothing liftIO $ timeout 300000 (get rcp) `shouldReturn` Nothing -- wait for worker attempt pure rfId - disposeAgentClient rcp [prefixDir] <- listDirectory recipientFiles let tmpPath = recipientFiles prefixDir "xftp.encrypted" doesDirectoryExist tmpPath `shouldReturn` True - withXFTPServerStoreLogOn $ \_ -> do + withXFTPServerStoreLogOn $ \_ -> -- receive file - should start downloading with server up - rcp' <- getSMPAgentClient' 3 agentCfg initAgentServers testDB2 - runRight_ $ xftpStartWorkers rcp' (Just recipientFiles) - ("", rfId', RFPROG _ _) <- rfGet rcp' - liftIO $ rfId' `shouldBe` rfId - disposeAgentClient rcp' - + withAgent 3 agentCfg initAgentServers testDB2 $ \rcp' -> do + runRight_ $ xftpStartWorkers rcp' (Just recipientFiles) + ("", rfId', RFPROG _ _) <- rfGet rcp' + liftIO $ rfId' `shouldBe` rfId threadDelay 100000 - withXFTPServerStoreLogOn $ \_ -> do + withXFTPServerStoreLogOn $ \_ -> -- receive file - should continue downloading with server up - rcp' <- getSMPAgentClient' 4 agentCfg initAgentServers testDB2 - runRight_ $ xftpStartWorkers rcp' (Just recipientFiles) - rfProgress rcp' $ mb 18 - ("", rfId', RFDONE path) <- rfGet rcp' - liftIO $ do - rfId' `shouldBe` rfId - file <- B.readFile filePath - B.readFile path `shouldReturn` file + withAgent 4 agentCfg initAgentServers testDB2 $ \rcp' -> do + runRight_ $ xftpStartWorkers rcp' (Just recipientFiles) + rfProgress rcp' $ mb 18 + ("", rfId', RFDONE path) <- rfGet rcp' + liftIO $ do + rfId' `shouldBe` rfId + file <- B.readFile filePath + B.readFile path `shouldReturn` file - -- tmp path should be removed after receiving file - doesDirectoryExist tmpPath `shouldReturn` False + threadDelay 100000 + -- tmp path should be removed after receiving file + doesDirectoryExist tmpPath `shouldReturn` False testXFTPAgentReceiveCleanup :: HasCallStack => IO () testXFTPAgentReceiveCleanup = withGlobalLogging logCfgNoLogs $ do @@ -337,30 +339,27 @@ testXFTPAgentReceiveCleanup = withGlobalLogging logCfgNoLogs $ do rfd <- withXFTPServerStoreLogOn $ \_ -> do -- send file - sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - runRight $ do + withAgent 1 agentCfg initAgentServers testDB $ \sndr -> runRight $ do (_, _, rfd, _) <- testSend sndr filePath pure rfd -- receive file - should not succeed with server down - rcp <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - rfId <- runRight $ do + rfId <- withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> runRight $ do xftpStartWorkers rcp (Just recipientFiles) rfId <- xftpReceiveFile rcp 1 rfd Nothing liftIO $ timeout 300000 (get rcp) `shouldReturn` Nothing -- wait for worker attempt pure rfId - disposeAgentClient rcp [prefixDir] <- listDirectory recipientFiles let tmpPath = recipientFiles prefixDir "xftp.encrypted" doesDirectoryExist tmpPath `shouldReturn` True - withXFTPServerThreadOn $ \_ -> do + withXFTPServerThreadOn $ \_ -> -- receive file - should fail with AUTH error - rcp' <- getSMPAgentClient' 3 agentCfg initAgentServers testDB2 - runRight_ $ xftpStartWorkers rcp' (Just recipientFiles) - ("", rfId', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp' - rfId' `shouldBe` rfId + withAgent 3 agentCfg initAgentServers testDB2 $ \rcp' -> do + runRight_ $ xftpStartWorkers rcp' (Just recipientFiles) + ("", rfId', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp' + rfId' `shouldBe` rfId -- tmp path should be removed after permanent error doesDirectoryExist tmpPath `shouldReturn` False @@ -370,13 +369,11 @@ testXFTPAgentSendRestore = withGlobalLogging logCfgNoLogs $ do filePath <- createRandomFile -- send file - should not succeed with server down - sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - sfId <- runRight $ do + sfId <- withAgent 1 agentCfg initAgentServers testDB $ \sndr -> runRight $ do xftpStartWorkers sndr (Just senderFiles) sfId <- xftpSendFile sndr 1 (CF.plain filePath) 2 liftIO $ timeout 1000000 (get sndr) `shouldReturn` Nothing -- wait for worker to encrypt and attempt to create file pure sfId - disposeAgentClient sndr dirEntries <- listDirectory senderFiles let prefixDir = fromJust $ find (isSuffixOf "_snd.xftp") dirEntries @@ -385,23 +382,25 @@ testXFTPAgentSendRestore = withGlobalLogging logCfgNoLogs $ do doesDirectoryExist prefixPath `shouldReturn` True doesFileExist encPath `shouldReturn` True - withXFTPServerStoreLogOn $ \_ -> do + withXFTPServerStoreLogOn $ \_ -> -- send file - should start uploading with server up - sndr' <- getSMPAgentClient' 2 agentCfg initAgentServers testDB - runRight_ $ xftpStartWorkers sndr' (Just senderFiles) - ("", sfId', SFPROG _ _) <- sfGet sndr' - liftIO $ sfId' `shouldBe` sfId - disposeAgentClient sndr' + withAgent 2 agentCfg initAgentServers testDB $ \sndr' -> do + runRight_ $ xftpStartWorkers sndr' (Just senderFiles) + ("", sfId', SFPROG _ _) <- sfGet sndr' + liftIO $ sfId' `shouldBe` sfId threadDelay 100000 withXFTPServerStoreLogOn $ \_ -> do -- send file - should continue uploading with server up - sndr' <- getSMPAgentClient' 3 agentCfg initAgentServers testDB - runRight_ $ xftpStartWorkers sndr' (Just senderFiles) - sfProgress sndr' $ mb 18 - ("", sfId', SFDONE _sndDescr [rfd1, _rfd2]) <- sfGet sndr' - liftIO $ sfId' `shouldBe` sfId + rfd1 <- withAgent 3 agentCfg initAgentServers testDB $ \sndr' -> do + runRight_ $ xftpStartWorkers sndr' (Just senderFiles) + sfProgress sndr' $ mb 18 + ("", sfId', SFDONE _sndDescr [rfd1, rfd2]) <- sfGet sndr' + liftIO $ testNoRedundancy rfd1 + liftIO $ testNoRedundancy rfd2 + liftIO $ sfId' `shouldBe` sfId + pure rfd1 -- prefix path should be removed after sending file threadDelay 100000 @@ -409,18 +408,16 @@ testXFTPAgentSendRestore = withGlobalLogging logCfgNoLogs $ do doesFileExist encPath `shouldReturn` False -- receive file - rcp <- getSMPAgentClient' 4 agentCfg initAgentServers testDB2 - runRight_ . void $ - testReceive rcp rfd1 filePath + withAgent 4 agentCfg initAgentServers testDB2 $ \rcp -> + runRight_ . void $ testReceive rcp rfd1 filePath testXFTPAgentSendCleanup :: HasCallStack => IO () testXFTPAgentSendCleanup = withGlobalLogging logCfgNoLogs $ do filePath <- createRandomFile - sfId <- withXFTPServerStoreLogOn $ \_ -> do + sfId <- withXFTPServerStoreLogOn $ \_ -> -- send file - sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - sfId <- runRight $ do + withAgent 1 agentCfg initAgentServers testDB $ \sndr -> runRight $ do xftpStartWorkers sndr (Just senderFiles) sfId <- xftpSendFile sndr 1 (CF.plain filePath) 2 -- wait for progress events for 5 out of 6 chunks - at this point all chunks should be created on the server @@ -428,8 +425,6 @@ testXFTPAgentSendCleanup = withGlobalLogging logCfgNoLogs $ do (_, _, SFPROG _ _) <- sfGet sndr pure () pure sfId - disposeAgentClient sndr - pure sfId dirEntries <- listDirectory senderFiles let prefixDir = fromJust $ find (isSuffixOf "_snd.xftp") dirEntries @@ -438,16 +433,16 @@ testXFTPAgentSendCleanup = withGlobalLogging logCfgNoLogs $ do doesDirectoryExist prefixPath `shouldReturn` True doesFileExist encPath `shouldReturn` True - withXFTPServerThreadOn $ \_ -> do + withXFTPServerThreadOn $ \_ -> -- send file - should fail with AUTH error - sndr' <- getSMPAgentClient' 2 agentCfg initAgentServers testDB - runRight_ $ xftpStartWorkers sndr' (Just senderFiles) - ("", sfId', SFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- sfGet sndr' - sfId' `shouldBe` sfId + withAgent 2 agentCfg initAgentServers testDB $ \sndr' -> do + runRight_ $ xftpStartWorkers sndr' (Just senderFiles) + ("", sfId', SFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- sfGet sndr' + sfId' `shouldBe` sfId - -- prefix path should be removed after permanent error - doesDirectoryExist prefixPath `shouldReturn` False - doesFileExist encPath `shouldReturn` False + -- prefix path should be removed after permanent error + doesDirectoryExist prefixPath `shouldReturn` False + doesFileExist encPath `shouldReturn` False testXFTPAgentDelete :: HasCallStack => IO () testXFTPAgentDelete = withGlobalLogging logCfgNoLogs $ @@ -455,32 +450,30 @@ testXFTPAgentDelete = withGlobalLogging logCfgNoLogs $ filePath <- createRandomFile -- send file - sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - (sfId, sndDescr, rfd1, rfd2) <- runRight $ testSend sndr filePath + withAgent 1 agentCfg initAgentServers testDB $ \sndr -> do + (sfId, sndDescr, rfd1, rfd2) <- runRight $ testSend sndr filePath - -- receive file - rcp1 <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - runRight_ . void $ - testReceive rcp1 rfd1 filePath + -- receive file + withAgent 2 agentCfg initAgentServers testDB2 $ \rcp1 -> do + runRight_ . void $ testReceive rcp1 rfd1 filePath - length <$> listDirectory xftpServerFiles `shouldReturn` 6 + length <$> listDirectory xftpServerFiles `shouldReturn` 6 - -- delete file - runRight_ $ xftpStartWorkers sndr (Just senderFiles) - xftpDeleteSndFileRemote sndr 1 sfId sndDescr - Nothing <- 100000 `timeout` sfGet sndr - disposeAgentClient rcp1 + -- delete file + runRight_ $ xftpStartWorkers sndr (Just senderFiles) + xftpDeleteSndFileRemote sndr 1 sfId sndDescr + Nothing <- 100000 `timeout` sfGet sndr + pure () - threadDelay 1000000 - length <$> listDirectory xftpServerFiles `shouldReturn` 0 + threadDelay 1000000 + length <$> listDirectory xftpServerFiles `shouldReturn` 0 - -- receive file - should fail with AUTH error - rcp2 <- getSMPAgentClient' 3 agentCfg initAgentServers testDB2 - runRight $ do - xftpStartWorkers rcp2 (Just recipientFiles) - rfId <- xftpReceiveFile rcp2 1 rfd2 Nothing - ("", rfId', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp2 - liftIO $ rfId' `shouldBe` rfId + -- 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 + ("", rfId', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp2 + liftIO $ rfId' `shouldBe` rfId testXFTPAgentDeleteRestore :: HasCallStack => IO () testXFTPAgentDeleteRestore = withGlobalLogging logCfgNoLogs $ do @@ -488,42 +481,37 @@ testXFTPAgentDeleteRestore = withGlobalLogging logCfgNoLogs $ do (sfId, sndDescr, rfd2) <- withXFTPServerStoreLogOn $ \_ -> do -- send file - sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - (sfId, sndDescr, rfd1, rfd2) <- runRight $ testSend sndr filePath + withAgent 1 agentCfg initAgentServers testDB $ \sndr -> do + (sfId, sndDescr, rfd1, rfd2) <- runRight $ testSend sndr filePath - -- receive file - rcp1 <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - runRight_ . void $ - testReceive rcp1 rfd1 filePath - disposeAgentClient rcp1 - disposeAgentClient sndr - pure (sfId, sndDescr, rfd2) + -- receive file + withAgent 2 agentCfg initAgentServers testDB2 $ \rcp1 -> + runRight_ . void $ testReceive rcp1 rfd1 filePath + pure (sfId, sndDescr, rfd2) -- delete file - should not succeed with server down - sndr <- getSMPAgentClient' 3 agentCfg initAgentServers testDB - runRight_ $ xftpStartWorkers sndr (Just senderFiles) - xftpDeleteSndFileRemote sndr 1 sfId sndDescr - timeout 300000 (get sndr) `shouldReturn` Nothing -- wait for worker attempt - disposeAgentClient sndr + withAgent 3 agentCfg initAgentServers testDB $ \sndr -> do + runRight_ $ xftpStartWorkers sndr (Just senderFiles) + xftpDeleteSndFileRemote sndr 1 sfId sndDescr + timeout 300000 (get sndr) `shouldReturn` Nothing -- wait for worker attempt threadDelay 300000 length <$> listDirectory xftpServerFiles `shouldReturn` 6 withXFTPServerStoreLogOn $ \_ -> do -- delete file - should succeed with server up - sndr' <- getSMPAgentClient' 4 agentCfg initAgentServers testDB - runRight_ $ xftpStartWorkers sndr' (Just senderFiles) + withAgent 4 agentCfg initAgentServers testDB $ \sndr' -> do + runRight_ $ xftpStartWorkers sndr' (Just senderFiles) - threadDelay 1000000 - length <$> listDirectory xftpServerFiles `shouldReturn` 0 + threadDelay 1000000 + length <$> listDirectory xftpServerFiles `shouldReturn` 0 - -- receive file - should fail with AUTH error - rcp2 <- getSMPAgentClient' 5 agentCfg initAgentServers testDB3 - runRight $ do - xftpStartWorkers rcp2 (Just recipientFiles) - rfId <- xftpReceiveFile rcp2 1 rfd2 Nothing - ("", rfId', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp2 - liftIO $ rfId' `shouldBe` rfId + -- 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 + ("", rfId', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp2 + liftIO $ rfId' `shouldBe` rfId testXFTPAgentDeleteOnServer :: HasCallStack => IO () testXFTPAgentDeleteOnServer = withGlobalLogging logCfgNoLogs $ @@ -531,36 +519,36 @@ testXFTPAgentDeleteOnServer = withGlobalLogging logCfgNoLogs $ filePath1 <- createRandomFile' "testfile1" -- send file 1 - sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - (_, _, rfd1_1, rfd1_2) <- runRight $ testSend sndr filePath1 + withAgent 1 agentCfg initAgentServers testDB $ \sndr -> do + (_, _, rfd1_1, rfd1_2) <- runRight $ testSend sndr filePath1 - -- receive file 1 successfully - rcp <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - runRight_ . void $ - testReceive rcp rfd1_1 filePath1 + -- receive file 1 successfully + withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> do + runRight_ . void $ testReceive rcp rfd1_1 filePath1 - serverFiles <- listDirectory xftpServerFiles - length serverFiles `shouldBe` 6 + serverFiles <- listDirectory xftpServerFiles + length serverFiles `shouldBe` 6 - -- delete file 1 on server from file system - forM_ serverFiles (\file -> removeFile (xftpServerFiles file)) + -- delete file 1 on server from file system + forM_ serverFiles (\file -> removeFile (xftpServerFiles file)) - threadDelay 1000000 - length <$> listDirectory xftpServerFiles `shouldReturn` 0 + threadDelay 1000000 + length <$> listDirectory xftpServerFiles `shouldReturn` 0 - -- create and send file 2 - filePath2 <- createRandomFile' "testfile2" - (_, _, rfd2, _) <- runRight $ testSend sndr filePath2 + -- create and send file 2 + filePath2 <- createRandomFile' "testfile2" + (_, _, rfd2, _) <- runRight $ testSend sndr filePath2 - length <$> listDirectory xftpServerFiles `shouldReturn` 6 + length <$> listDirectory xftpServerFiles `shouldReturn` 6 - runRight_ . void $ do - -- receive file 1 again - -- TODO should fail with AUTH error - _rfId1 <- xftpReceiveFile rcp 1 rfd1_2 Nothing + runRight_ . void $ do + -- receive file 1 again + rfId1 <- xftpReceiveFile rcp 1 rfd1_2 Nothing + ("", rfId1', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp + liftIO $ rfId1 `shouldBe` rfId1' - -- receive file 2 - testReceive' rcp rfd2 filePath2 + -- receive file 2 + testReceive' rcp rfd2 filePath2 testXFTPAgentExpiredOnServer :: HasCallStack => IO () testXFTPAgentExpiredOnServer = withGlobalLogging logCfgNoLogs $ do @@ -569,46 +557,43 @@ testXFTPAgentExpiredOnServer = withGlobalLogging logCfgNoLogs $ do filePath1 <- createRandomFile' "testfile1" -- send file 1 - sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - (_, _, rfd1_1, rfd1_2) <- runRight $ testSend sndr filePath1 + withAgent 1 agentCfg initAgentServers testDB $ \sndr -> do + (_, _, rfd1_1, rfd1_2) <- runRight $ testSend sndr filePath1 - -- receive file 1 successfully - rcp <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - runRight_ . void $ - testReceive rcp rfd1_1 filePath1 + -- receive file 1 successfully + withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> do + runRight_ . void $ testReceive rcp rfd1_1 filePath1 - serverFiles <- listDirectory xftpServerFiles - length serverFiles `shouldBe` 6 + serverFiles <- listDirectory xftpServerFiles + length serverFiles `shouldBe` 6 - -- wait until file 1 expires on server - forM_ serverFiles (\file -> removeFile (xftpServerFiles file)) + -- wait until file 1 expires on server + forM_ serverFiles (\file -> removeFile (xftpServerFiles file)) - threadDelay 3500000 - length <$> listDirectory xftpServerFiles `shouldReturn` 0 + threadDelay 3500000 + length <$> listDirectory xftpServerFiles `shouldReturn` 0 - -- receive file 1 again - should fail with AUTH error - runRight $ do - rfId <- xftpReceiveFile rcp 1 rfd1_2 Nothing - ("", rfId', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp - liftIO $ rfId' `shouldBe` rfId + -- receive file 1 again - should fail with AUTH error + runRight $ do + rfId <- xftpReceiveFile rcp 1 rfd1_2 Nothing + ("", rfId', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp + liftIO $ rfId' `shouldBe` rfId - -- create and send file 2 - filePath2 <- createRandomFile' "testfile2" - (_, _, rfd2, _) <- runRight $ testSend sndr filePath2 + -- create and send file 2 + filePath2 <- createRandomFile' "testfile2" + (_, _, rfd2, _) <- runRight $ testSend sndr filePath2 - length <$> listDirectory xftpServerFiles `shouldReturn` 6 + length <$> listDirectory xftpServerFiles `shouldReturn` 6 - -- receive file 2 successfully - runRight_ . void $ - testReceive' rcp rfd2 filePath2 + -- receive file 2 successfully + runRight_ . void $ testReceive' rcp rfd2 filePath2 testXFTPAgentRequestAdditionalRecipientIDs :: HasCallStack => IO () testXFTPAgentRequestAdditionalRecipientIDs = withXFTPServer $ do filePath <- createRandomFile -- send file - sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - rfds <- runRight $ do + rfds <- withAgent 1 agentCfg initAgentServers testDB $ \sndr -> runRight $ do xftpStartWorkers sndr (Just senderFiles) sfId <- xftpSendFile sndr 1 (CF.plain filePath) 500 sfProgress sndr $ mb 18 @@ -618,10 +603,11 @@ testXFTPAgentRequestAdditionalRecipientIDs = withXFTPServer $ do length rfds `shouldBe` 500 pure rfds + forM_ rfds testNoRedundancy + -- receive file using different descriptions -- ! revise number of recipients and indexes if xftpMaxRecipientsPerRequest is changed - rcp <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 - runRight_ $ do + withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> runRight_ $ do void $ testReceive rcp (head rfds) filePath void $ testReceive rcp (rfds !! 99) filePath void $ testReceive rcp (rfds !! 299) filePath @@ -629,6 +615,7 @@ testXFTPAgentRequestAdditionalRecipientIDs = withXFTPServer $ do testXFTPServerTest :: HasCallStack => Maybe BasicAuth -> XFTPServerWithAuth -> IO (Maybe ProtocolTestFailure) testXFTPServerTest newFileBasicAuth srv = - withXFTPServerCfg testXFTPServerConfig {newFileBasicAuth, xftpPort = xftpTestPort2} $ \_ -> do - a <- getSMPAgentClient' 1 agentCfg initAgentServers testDB -- initially passed server is not running - testProtocolServer a 1 srv + withXFTPServerCfg testXFTPServerConfig {newFileBasicAuth, xftpPort = xftpTestPort2} $ \_ -> + -- initially passed server is not running + withAgent 1 agentCfg initAgentServers testDB $ \a -> + testProtocolServer a 1 srv diff --git a/tests/XFTPClient.hs b/tests/XFTPClient.hs index 113f314a7..d42ee7d06 100644 --- a/tests/XFTPClient.hs +++ b/tests/XFTPClient.hs @@ -5,7 +5,7 @@ module XFTPClient where -import Control.Concurrent (ThreadId) +import Control.Concurrent (ThreadId, threadDelay) import Data.String (fromString) import Network.Socket (ServiceName) import SMPClient (serverBracket) @@ -13,6 +13,7 @@ import Simplex.FileTransfer.Client import Simplex.FileTransfer.Description import Simplex.FileTransfer.Server (runXFTPServerBlocking) import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defaultFileExpiration, defaultInactiveClientExpiration) +import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Protocol (XFTPServer) import Simplex.Messaging.Transport.Server import Test.Hspec @@ -52,7 +53,7 @@ withXFTPServerCfg :: HasCallStack => XFTPServerConfig -> (HasCallStack => Thread withXFTPServerCfg cfg = serverBracket (`runXFTPServerBlocking` cfg) - (pure ()) + (threadDelay 10000) withXFTPServerThreadOn :: HasCallStack => (HasCallStack => ThreadId -> IO a) -> IO a withXFTPServerThreadOn = withXFTPServerCfg testXFTPServerConfig @@ -124,7 +125,8 @@ testXFTPClientConfig :: XFTPClientConfig testXFTPClientConfig = defaultXFTPClientConfig testXFTPClient :: HasCallStack => (HasCallStack => XFTPClient -> IO a) -> IO a -testXFTPClient client = - getXFTPClient (1, testXFTPServer, Nothing) testXFTPClientConfig (\_ -> pure ()) >>= \case +testXFTPClient client = do + g <- C.newRandom + getXFTPClient g (1, testXFTPServer, Nothing) testXFTPClientConfig (\_ -> pure ()) >>= \case Right c -> client c Left e -> error $ show e diff --git a/tests/XFTPServerTests.hs b/tests/XFTPServerTests.hs index e2d447274..494f624fd 100644 --- a/tests/XFTPServerTests.hs +++ b/tests/XFTPServerTests.hs @@ -12,6 +12,7 @@ import Control.Exception (SomeException) import Control.Monad import Control.Monad.Except import Control.Monad.IO.Unlift +import qualified Data.ByteString.Base64.URL as B64 import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB @@ -21,11 +22,10 @@ import Simplex.FileTransfer.Client import Simplex.FileTransfer.Description (kb) import Simplex.FileTransfer.Protocol (FileInfo (..)) import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..)) -import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec (..), XFTPErrorType (..)) +import Simplex.FileTransfer.Transport (XFTPErrorType (..), XFTPRcvChunkSpec (..)) import Simplex.Messaging.Client (ProtocolClientError (..)) import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto.Lazy as LC -import qualified Simplex.Messaging.Encoding.Base64.URL as U import Simplex.Messaging.Protocol (BasicAuth, SenderId) import Simplex.Messaging.Server.Expiration (ExpirationConfig (..)) import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive, removeFile) @@ -75,7 +75,7 @@ createTestChunk fp = do pure bytes readChunk :: SenderId -> IO ByteString -readChunk sId = B.readFile (xftpServerFiles B.unpack (U.encode sId)) +readChunk sId = B.readFile (xftpServerFiles B.unpack (B64.encode sId)) testFileChunkDelivery :: Expectation testFileChunkDelivery = xftpTest $ \c -> runRight_ $ runTestFileChunkDelivery c c @@ -219,7 +219,8 @@ testFileChunkExpiration = withXFTPServerCfg testXFTPServerConfig {fileExpiration testInactiveClientExpiration :: Expectation testInactiveClientExpiration = withXFTPServerCfg testXFTPServerConfig {inactiveClientExpiration} $ \_ -> runRight_ $ do disconnected <- newEmptyTMVarIO - c <- ExceptT $ getXFTPClient (1, testXFTPServer, Nothing) testXFTPClientConfig (\_ -> atomically $ putTMVar disconnected ()) + g <- liftIO C.newRandom + c <- ExceptT $ getXFTPClient g (1, testXFTPServer, Nothing) testXFTPClientConfig (\_ -> atomically $ putTMVar disconnected ()) pingXFTP c liftIO $ do threadDelay 100000 diff --git a/tests/fixtures/ca2.crt b/tests/fixtures/ca2.crt new file mode 100644 index 000000000..698f09917 --- /dev/null +++ b/tests/fixtures/ca2.crt @@ -0,0 +1,12 @@ +-----BEGIN CERTIFICATE----- +MIIBtjCCATagAwIBAgIUDJc0ixVBYPdcL5W7zE8dhm0UMpswBQYDK2VxMCoxFjAU +BgNVBAMMDVNNUCBzZXJ2ZXIgQ0ExEDAOBgNVBAoMB1NpbXBsZVgwIBcNMjQwNDA4 +MTg0ODIwWhgPNDc2MjAzMDUxODQ4MjBaMCoxFjAUBgNVBAMMDVNNUCBzZXJ2ZXIg +Q0ExEDAOBgNVBAoMB1NpbXBsZVgwQzAFBgMrZXEDOgAST4assVdIwL/kbtWmbyJm +X/CNGUQFkArvgvcRTZOwJPu9ypmv0mSz2I6acsw6gr8LHq8mlv7iPICjUzBRMB0G +A1UdDgQWBBTBsA6VVhkO61ixwlel+g7D08shnjAfBgNVHSMEGDAWgBTBsA6VVhkO +61ixwlel+g7D08shnjAPBgNVHRMBAf8EBTADAQH/MAUGAytlcQNzAKAfQ0EEQtnR +HvNiKBajo77prZX680apmxBxSZuLNORQMvKBLDm2qaGv5S/c9gmvLjLz2Avrspow +ANBF71DKcvgb25D2LLDp0CQOBt/dP41Cgd/ZigyHyOq2/Oj15Skbu0TdXYuIxf/k +MZ0XUvYwG6IKAA== +-----END CERTIFICATE----- diff --git a/tests/fixtures/ca2.key b/tests/fixtures/ca2.key new file mode 100644 index 000000000..414eb5934 --- /dev/null +++ b/tests/fixtures/ca2.key @@ -0,0 +1,4 @@ +-----BEGIN PRIVATE KEY----- +MEcCAQAwBQYDK2VxBDsEOcBpozc2TnAf6lQaxN5bA6JdbKWuxUecsW9P2dzncCnB +/alBtYXqW6SprBj1DqzeZyU4rQ7OqFrgBw== +-----END PRIVATE KEY----- diff --git a/tests/fixtures/server2.crt b/tests/fixtures/server2.crt new file mode 100644 index 000000000..aa0a722c1 --- /dev/null +++ b/tests/fixtures/server2.crt @@ -0,0 +1,12 @@ +-----BEGIN CERTIFICATE----- +MIIBvDCCATygAwIBAgIUbx6kKw7PGGxhTPutroJFZbOcVk0wBQYDK2VxMCoxFjAU +BgNVBAMMDVNNUCBzZXJ2ZXIgQ0ExEDAOBgNVBAoMB1NpbXBsZVgwIBcNMjQwNDA4 +MTg0ODI2WhgPNDc2MjAzMDUxODQ4MjZaMBQxEjAQBgNVBAMMCWxvY2FsaG9zdDBD +MAUGAytlcQM6ACKox7DzkUjK6ZN0pCzABv5vcqk5Tu+zaLWEWlHFnpIN/f/AcBI1 +GbZCmD/zb6OG49vsAKPnMAyIgKNvMG0wCQYDVR0TBAIwADALBgNVHQ8EBAMCA8gw +EwYDVR0lBAwwCgYIKwYBBQUHAwEwHQYDVR0OBBYEFGFx/ISB2xEW2tGhVYVncWTd +lwkrMB8GA1UdIwQYMBaAFMGwDpVWGQ7rWLHCV6X6DsPTyyGeMAUGAytlcQNzAMp9 +EL+22OkeGG6s7LxpXJgVG6dxbcNn6aTgTX2pDYt8n+cRQTeTZ1MLDYVIe289pIQK +tbKmI+HIgHExuNurJw6f6FknVmEeJpOXLV5lybL4f/fZGKrAE5rbhtNnQAp1mw0c +ngt8dhyISxv/zoQLSkIcAA== +-----END CERTIFICATE----- diff --git a/tests/fixtures/server2.key b/tests/fixtures/server2.key new file mode 100644 index 000000000..4f5f333e6 --- /dev/null +++ b/tests/fixtures/server2.key @@ -0,0 +1,4 @@ +-----BEGIN PRIVATE KEY----- +MEcCAQAwBQYDK2VxBDsEObrN+1gIRcwmahmitb6ltVoZjjnVoHj0/1waYkjmMtQl +PiGhWP5/B6Y1fLH/YiO/tfX2YPGCOJJSJQ== +-----END PRIVATE KEY----- diff --git a/tests/fixtures/ss.crt b/tests/fixtures/ss.crt new file mode 100644 index 000000000..27968c2cd --- /dev/null +++ b/tests/fixtures/ss.crt @@ -0,0 +1,13 @@ +-----BEGIN CERTIFICATE----- +MIIB6zCCAXKgAwIBAgIUbLI6PjnyP24ukjmIE3LsjFqn/LYwCgYIKoZIzj0EAwIw +FjEUMBIGA1UEAwwLZXhhbXBsZS5jb20wHhcNMjQwNDA4MTg1OTA2WhcNMzQwNDA2 +MTg1OTA2WjAWMRQwEgYDVQQDDAtleGFtcGxlLmNvbTB2MBAGByqGSM49AgEGBSuB +BAAiA2IABMIrmyP4FDY+P8Tulv8Bcp5U7QlHigoOW6JPRPTETTFBl2e7t9UApa/E +AYl805mkaIdrDJzdtAqkttHmPm4vXdCCualxVRZ/thtpvdNocxyJOD9BVv3QKqiu +SGuCGHp+m6OBgDB+MB0GA1UdDgQWBBR5D79SM77XfY/bii0NJ1OllAWw1TAfBgNV +HSMEGDAWgBR5D79SM77XfY/bii0NJ1OllAWw1TAPBgNVHRMBAf8EBTADAQH/MCsG +A1UdEQQkMCKCC2V4YW1wbGUuY29tgg0qLmV4YW1wbGUuY29thwQKAAABMAoGCCqG +SM49BAMCA2cAMGQCMDuIOZBcKI/OXOWx75o5xgwIDio4P7zK9kJt7D4YJMxPvTV6 +vVajYSuJwiIF3/GwoQIwPUbNndNNnf1tYJdPhEJ3e8bA2a3bDbb2dgfiUfj6amaS +RcSkYms1WDLMFP0LHo/Z +-----END CERTIFICATE----- diff --git a/tests/fixtures/ss.key b/tests/fixtures/ss.key new file mode 100644 index 000000000..1b72aff70 --- /dev/null +++ b/tests/fixtures/ss.key @@ -0,0 +1,6 @@ +-----BEGIN PRIVATE KEY----- +MIG2AgEAMBAGByqGSM49AgEGBSuBBAAiBIGeMIGbAgEBBDBH/6IpMqcKFrXNU8Nb +QFvdzQOJtfoAEEDRBmMqbihPrCgbtCJ3FIVnxqGlFIXADaqhZANiAATCK5sj+BQ2 +Pj/E7pb/AXKeVO0JR4oKDluiT0T0xE0xQZdnu7fVAKWvxAGJfNOZpGiHawyc3bQK +pLbR5j5uL13QgrmpcVUWf7Ybab3TaHMciTg/QVb90Cqorkhrghh6fps= +-----END PRIVATE KEY-----