From bbf9e28696515a8e3269319ee32fbba0f0fec853 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Wed, 22 Feb 2023 09:03:18 +0000 Subject: [PATCH] xftp: add server to client encryption layer with cryptobox (#646) * xftp: add server to client encryption layer with cryptobox * workarounds for http2 * update http2 commit * remove TODOs --- cabal.project | 2 +- src/Simplex/FileTransfer/Client.hs | 19 ++--- src/Simplex/FileTransfer/Client/Main.hs | 5 +- src/Simplex/FileTransfer/Protocol.hs | 8 +-- src/Simplex/FileTransfer/Server.hs | 28 ++++---- src/Simplex/FileTransfer/Transport.hs | 71 ++++++++++++++++--- src/Simplex/Messaging/Agent/Client.hs | 2 +- src/Simplex/Messaging/Client.hs | 4 +- src/Simplex/Messaging/Crypto/Lazy.hs | 18 +++-- src/Simplex/Messaging/Notifications/Server.hs | 2 +- .../Notifications/Server/Push/APNS.hs | 2 +- tests/AgentTests.hs | 2 - tests/AgentTests/SQLiteTests.hs | 4 -- tests/XFTPCLI.hs | 11 ++- tests/XFTPServerTests.hs | 7 +- 15 files changed, 124 insertions(+), 61 deletions(-) diff --git a/cabal.project b/cabal.project index 9ec665d9f..1b036aa86 100644 --- a/cabal.project +++ b/cabal.project @@ -15,7 +15,7 @@ source-repository-package source-repository-package type: git location: https://github.com/kazu-yamamoto/http2.git - tag: 1136bb126636789cec197e5d0bae39aa63c6f9e5 + tag: aa56ded3494dd4f0efb0bbcb5378879ce785a647 source-repository-package type: git diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs index 6de183aa9..38916aa31 100644 --- a/src/Simplex/FileTransfer/Client.hs +++ b/src/Simplex/FileTransfer/Client.hs @@ -31,10 +31,10 @@ import Simplex.Messaging.Client transportClientConfig, ) import qualified Simplex.Messaging.Crypto as C +import qualified Simplex.Messaging.Crypto.Lazy as LC import Simplex.Messaging.Protocol ( Protocol (..), ProtocolServer (..), - RcvPublicDhKey, RecipientId, SenderId, ) @@ -142,16 +142,17 @@ uploadXFTPChunk c spKey fId chunkSpec = (FROk, _body) -> pure () (r, _) -> throwError . PCEUnexpectedResponse $ bshow r -downloadXFTPChunk :: XFTPClient -> C.APrivateSignKey -> XFTPFileId -> RcvPublicDhKey -> XFTPRcvChunkSpec -> ExceptT XFTPClientError IO () -downloadXFTPChunk c rpKey fId rKey chunkSpec@XFTPRcvChunkSpec {filePath} = - sendXFTPCommand c rpKey fId (FGET rKey) Nothing >>= \case - (FRFile sKey, HTTP2Body {bodyHead, bodySize, bodyPart}) -> case bodyPart of +downloadXFTPChunk :: XFTPClient -> C.APrivateSignKey -> XFTPFileId -> XFTPRcvChunkSpec -> ExceptT XFTPClientError IO () +downloadXFTPChunk c rpKey fId chunkSpec@XFTPRcvChunkSpec {filePath} = do + (rDhKey, rpDhKey) <- liftIO C.generateKeyPair' + sendXFTPCommand c rpKey fId (FGET rDhKey) Nothing >>= \case + (FRFile sDhKey cbNonce, HTTP2Body {bodyHead, bodySize, bodyPart}) -> case bodyPart of -- TODO atm bodySize is set to 0, so chunkSize will be incorrect - validate once set Just chunkPart -> do - -- let chunk = XFTPChunkBody {chunkSize = bodySize - B.length bodyHead, chunkPart, http2Body} - withExceptT PCEResponseError $ do - -- TODO chunk decryption - receiveFile chunkPart chunkSpec `catchError` \e -> + let dhSecret = C.dh' sDhKey rpDhKey + cbState <- liftEither . first PCECryptoError $ LC.cbInit dhSecret cbNonce + withExceptT PCEResponseError $ + receiveEncFile chunkPart cbState chunkSpec `catchError` \e -> whenM (doesFileExist filePath) (removeFile filePath) >> throwError e _ -> throwError $ PCEResponseError NO_FILE (r, _) -> throwError . PCEUnexpectedResponse $ bshow r diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs index a5681ffa5..4e74a5659 100644 --- a/src/Simplex/FileTransfer/Client/Main.hs +++ b/src/Simplex/FileTransfer/Client/Main.hs @@ -332,7 +332,7 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath} encPath <- getEncPath tempPath "xftp" createDirectory encPath a <- atomically $ newXFTPAgent defaultXFTPClientAgentConfig - chunkPaths <- pooledForConcurrentlyN 32 chunks $ downloadFileChunk a encPath + chunkPaths <- forM chunks $ downloadFileChunk a encPath encDigest <- liftIO $ LC.sha512Hash <$> readChunks chunkPaths when (encDigest /= unFileDigest digest) $ throwError $ CLIError "File digest mismatch" path <- decryptFile chunkPaths key nonce @@ -346,9 +346,8 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath} let FileChunkReplica {server, rcvId, rcvKey} = replica chunkPath <- uniqueCombine encPath $ show chunkNo c <- retries $ getXFTPServerClient a server - (rKey, rpKey) <- liftIO C.generateKeyPair' let chunkSpec = XFTPRcvChunkSpec chunkPath (unFileSize chunkSize) (unFileDigest digest) - retries $ downloadXFTPChunk c rcvKey (unChunkReplicaId rcvId) rKey chunkSpec + retries $ downloadXFTPChunk c rcvKey (unChunkReplicaId rcvId) chunkSpec pure chunkPath downloadFileChunk _ _ _ = throwError $ CLIError "chunk has no replicas" decryptFile :: [FilePath] -> C.SbKey -> C.CbNonce -> ExceptT CLIError IO FilePath diff --git a/src/Simplex/FileTransfer/Protocol.hs b/src/Simplex/FileTransfer/Protocol.hs index 3353e0e26..0fe36d41f 100644 --- a/src/Simplex/FileTransfer/Protocol.hs +++ b/src/Simplex/FileTransfer/Protocol.hs @@ -251,7 +251,7 @@ instance ProtocolMsgTag FileResponseTag where data FileResponse = FRSndIds SenderId (NonEmpty RecipientId) | FRRcvIds (NonEmpty RecipientId) - | FRFile RcvPublicDhKey + | FRFile RcvPublicDhKey C.CbNonce | FROk | FRErr XFTPErrorType | FRPong @@ -262,7 +262,7 @@ instance ProtocolEncoding XFTPErrorType FileResponse where encodeProtocol _v = \case FRSndIds fId rIds -> e (FRSndIds_, ' ', fId, rIds) FRRcvIds rIds -> e (FRRcvIds_, ' ', rIds) - FRFile rKey -> e (FRFile_, ' ', rKey) + FRFile rDhKey nonce -> e (FRFile_, ' ', rDhKey, nonce) FROk -> e FROk_ FRErr err -> e (FRErr_, ' ', err) FRPong -> e FRPong_ @@ -273,7 +273,7 @@ instance ProtocolEncoding XFTPErrorType FileResponse where protocolP _v = \case FRSndIds_ -> FRSndIds <$> _smpP <*> smpP FRRcvIds_ -> FRRcvIds <$> _smpP - FRFile_ -> FRFile <$> _smpP + FRFile_ -> FRFile <$> _smpP <*> smpP FROk_ -> pure FROk FRErr_ -> FRErr <$> _smpP FRPong_ -> pure FRPong @@ -313,7 +313,7 @@ data XFTPErrorType SIZE | -- | incorrent file digest DIGEST - | -- | no file body + | -- | no expected file body in request/response or no file on the server NO_FILE | -- | unexpected file body HAS_FILE diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs index 9e9085450..4c1291a21 100644 --- a/src/Simplex/FileTransfer/Server.hs +++ b/src/Simplex/FileTransfer/Server.hs @@ -36,6 +36,7 @@ import Simplex.FileTransfer.Server.Stats import Simplex.FileTransfer.Server.Store import Simplex.FileTransfer.Transport import qualified Simplex.Messaging.Crypto as C +import qualified Simplex.Messaging.Crypto.Lazy as LC import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol (CorrId, RcvPublicDhKey) import Simplex.Messaging.Server (dummyVerifyCmd, verifyCmdSignature) @@ -122,11 +123,10 @@ xftpServer cfg@XFTPServerConfig {xftpPort, logTLSErrors} started = do ] threadDelay interval --- TODO add client DH secret data ServerFile = ServerFile { filePath :: FilePath, fileSize :: Word32, - fileDhSecret :: C.DhSecretX25519 + sbState :: LC.SbState } processRequest :: HTTP2Request -> M () @@ -152,12 +152,13 @@ processRequest HTTP2Request {sessionId, reqBody = body@HTTP2Body {bodyHead}, sen where streamBody t_ send done = do case t_ of - Left _ -> send "padding error" -- TODO respond with BLOCK error? + Left _ -> do + send "padding error" -- TODO respond with BLOCK error? + done Right t -> do send $ byteString t - -- TODO chunk encryption - forM_ serverFile_ $ \ServerFile {filePath, fileSize, fileDhSecret} -> - withFile filePath ReadMode $ \h -> sendFile h send $ fromIntegral fileSize + forM_ serverFile_ $ \ServerFile {filePath, fileSize, sbState} -> do + withFile filePath ReadMode $ \h -> sendEncFile h send sbState (fromIntegral fileSize) done data VerificationResult = VRVerified XFTPRequest | VRFailed @@ -196,7 +197,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case FADD _rcps -> noFile FROk FPUT -> (,Nothing) <$> receiveServerFile fr FDEL -> noFile FROk - FGET dhKey -> sendServerFile fr dhKey + FGET rDhKey -> sendServerFile fr rDhKey FACK -> noFile FROk -- it should never get to the options below, they are passed in other constructors of XFTPRequest FNEW _ _ -> noFile $ FRErr INTERNAL @@ -219,13 +220,16 @@ processXFTPRequest HTTP2Body {bodyPart} = \case Left e -> whenM (doesFileExist fPath) (removeFile fPath) $> FRErr e sendServerFile :: FileRec -> RcvPublicDhKey -> M (FileResponse, Maybe ServerFile) - sendServerFile FileRec {filePath, fileInfo = FileInfo {size}} rKey = do + sendServerFile FileRec {filePath, fileInfo = FileInfo {size}} rDhKey = do readTVarIO filePath >>= \case Just path -> do - (sKey, spKey) <- liftIO C.generateKeyPair' - let fileDhSecret = C.dh' rKey spKey - pure (FRFile sKey, Just ServerFile {filePath = path, fileSize = size, fileDhSecret}) - _ -> pure (FRErr AUTH, Nothing) -- TODO file-specific errors? + (sDhKey, spDhKey) <- liftIO C.generateKeyPair' + let dhSecret = C.dh' rDhKey spDhKey + cbNonce <- liftIO C.randomCbNonce + pure $ case LC.cbInit dhSecret cbNonce of + Right sbState -> (FRFile sDhKey cbNonce, Just ServerFile {filePath = path, fileSize = size, sbState}) + _ -> (FRErr INTERNAL, Nothing) + _ -> pure (FRErr NO_FILE, Nothing) randomId :: (MonadUnliftIO m, MonadReader XFTPEnv m) => Int -> m ByteString randomId n = do diff --git a/src/Simplex/FileTransfer/Transport.hs b/src/Simplex/FileTransfer/Transport.hs index e6f4fbdd3..a57848d62 100644 --- a/src/Simplex/FileTransfer/Transport.hs +++ b/src/Simplex/FileTransfer/Transport.hs @@ -10,10 +10,15 @@ module Simplex.FileTransfer.Transport XFTPRcvChunkSpec (..), sendFile, receiveFile, + sendEncFile, + receiveEncFile, ) where +import Control.Concurrent (threadDelay) +import qualified Control.Exception as E import Control.Monad.Except +import qualified Data.ByteArray as BA import Data.ByteString.Builder (Builder, byteString) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B @@ -21,6 +26,7 @@ import qualified Data.ByteString.Lazy.Char8 as LB import Data.Word (Word32) import GHC.IO.Handle.Internals (ioe_EOF) import Simplex.FileTransfer.Protocol (XFTPErrorType (..), xftpBlockSize) +import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto.Lazy as LC import Simplex.Messaging.Version import System.IO (Handle, IOMode (..), withFile) @@ -40,18 +46,33 @@ sendFile h send = go where go 0 = pure () go sz = - B.hGet h xftpBlockSize >>= \case - "" -> ioe_EOF - ch -> do - let ch' = B.take (fromIntegral sz) ch -- sz >= xftpBlockSize - send $ byteString ch' - go $ sz - fromIntegral (B.length ch') + getFileChunk h sz >>= \ch -> do + send $ byteString ch + go $ sz - fromIntegral (B.length ch) + +sendEncFile :: Handle -> (Builder -> IO ()) -> LC.SbState -> Word32 -> IO () +sendEncFile h send = go + where + go sbState 0 = do + -- TODO remove padding when HTTP2 issue is fixed + let authTag = BA.convert (LC.sbAuth sbState) <> B.replicate (xftpBlockSize - C.authTagSize) '#' + send $ byteString authTag + go sbState sz = + getFileChunk h sz >>= \ch -> do + let (encCh, sbState') = LC.sbEncryptChunk sbState ch + send (byteString encCh) `E.catch` \(e :: E.SomeException) -> print e >> E.throwIO e + -- TODO remove delay when HTTP2 issue is fixed + threadDelay 500 + go sbState' $ sz - fromIntegral (B.length ch) + +getFileChunk :: Handle -> Word32 -> IO ByteString +getFileChunk h sz = + B.hGet h xftpBlockSize >>= \case + "" -> ioe_EOF + ch -> pure $ B.take (fromIntegral sz) ch -- sz >= xftpBlockSize receiveFile :: (Int -> IO ByteString) -> XFTPRcvChunkSpec -> ExceptT XFTPErrorType IO () -receiveFile getBody XFTPRcvChunkSpec {filePath, chunkSize, chunkDigest} = do - ExceptT $ withFile filePath WriteMode (`receive` chunkSize) - digest' <- liftIO $ LC.sha512Hash <$> LB.readFile filePath - when (digest' /= chunkDigest) $ throwError DIGEST +receiveFile getBody = receiveFile_ receive where receive h sz = do ch <- getBody xftpBlockSize @@ -61,3 +82,33 @@ receiveFile getBody XFTPRcvChunkSpec {filePath, chunkSize, chunkDigest} = do | chSize > 0 -> B.hPut h ch >> receive h (sz - chSize) | sz == 0 -> pure $ Right () | otherwise -> pure $ Left SIZE + +receiveEncFile :: (Int -> IO ByteString) -> LC.SbState -> XFTPRcvChunkSpec -> ExceptT XFTPErrorType IO () +receiveEncFile getBody = receiveFile_ . receive + where + receive sbState h sz = do + ch <- getBody xftpBlockSize + let chSize = fromIntegral $ B.length ch + if + | chSize > sz + authSz -> pure $ Left SIZE + | chSize > 0 -> do + let (ch', rest) = B.splitAt (fromIntegral sz) ch + (decCh, sbState') = LC.sbDecryptChunk sbState ch' + sz' = sz - fromIntegral (B.length ch') + B.hPut h decCh + if sz' > 0 + then receive sbState' h sz' + else do + let tag' = B.take C.authTagSize rest + tagSz = B.length tag' + tag = LC.sbAuth sbState' + tag'' <- if tagSz == C.authTagSize then pure tag' else (tag' <>) <$> getBody (C.authTagSize - tagSz) + pure $ if BA.constEq tag'' tag then Right () else Left DIGEST + | otherwise -> pure $ Left SIZE + authSz = fromIntegral C.authTagSize + +receiveFile_ :: (Handle -> Word32 -> IO (Either XFTPErrorType ())) -> XFTPRcvChunkSpec -> ExceptT XFTPErrorType IO () +receiveFile_ receive XFTPRcvChunkSpec {filePath, chunkSize, chunkDigest} = do + ExceptT $ withFile filePath WriteMode (`receive` chunkSize) + digest' <- liftIO $ LC.sha512Hash <$> LB.readFile filePath + when (digest' /= chunkDigest) $ throwError DIGEST diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 2332d0fc9..dbc22684d 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -592,7 +592,7 @@ protocolClientError protocolError_ host = \case PCENetworkError -> BROKER host NETWORK PCEIncompatibleHost -> BROKER host HOST PCETransportError e -> BROKER host $ TRANSPORT e - e@PCESignatureError {} -> INTERNAL $ show e + e@PCECryptoError {} -> INTERNAL $ show e PCEIOError {} -> BROKER host NETWORK data SMPTestStep = TSConnect | TSCreateQueue | TSSecureQueue | TSDeleteQueue | TSDisconnect diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index f4f39db39..b4d633860 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -414,8 +414,8 @@ data ProtocolClientError err | -- | TCP transport handshake or some other transport error. -- Forwarded to the agent client as `ERR BROKER TRANSPORT e`. PCETransportError TransportError - | -- | Error when cryptographically "signing" the command. - PCESignatureError C.CryptoError + | -- | Error when cryptographically "signing" the command or when initializing crypto_box. + PCECryptoError C.CryptoError | -- | IO Error PCEIOError IOException deriving (Eq, Show, Exception) diff --git a/src/Simplex/Messaging/Crypto/Lazy.hs b/src/Simplex/Messaging/Crypto/Lazy.hs index 68f3326e4..cb1d40aac 100644 --- a/src/Simplex/Messaging/Crypto/Lazy.hs +++ b/src/Simplex/Messaging/Crypto/Lazy.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -11,6 +12,11 @@ module Simplex.Messaging.Crypto.Lazy sbEncrypt, sbDecrypt, fastReplicate, + SbState, + cbInit, + sbEncryptChunk, + sbDecryptChunk, + sbAuth, ) where @@ -29,7 +35,7 @@ import qualified Data.ByteString.Lazy.Internal as LB import Data.Int (Int64) import Data.List.NonEmpty (NonEmpty (..)) import Foreign (sizeOf) -import Simplex.Messaging.Crypto (CbNonce, CryptoError (..), SbKey, pattern CbNonce, pattern SbKey) +import Simplex.Messaging.Crypto (CbNonce, CryptoError (..), DhSecret (..), DhSecretX25519, SbKey, pattern CbNonce, pattern SbKey) import Simplex.Messaging.Encoding type LazyByteString = LB.ByteString @@ -92,7 +98,7 @@ sbDecrypt (SbKey key) (CbNonce nonce) packet (tag', c) = LB.splitAt 16 packet secretBox :: ByteArrayAccess key => (SbState -> ByteString -> (ByteString, SbState)) -> key -> ByteString -> LazyByteString -> Either CryptoError (NonEmpty ByteString) -secretBox sbProcess secret nonce msg = run <$> sbInit secret nonce +secretBox sbProcess secret nonce msg = run <$> sbInit_ secret nonce where process state = foldlChunks update ([], state) msg update (cs, st) chunk = let (c, st') = sbProcess st chunk in (c : cs, st') @@ -100,8 +106,12 @@ secretBox sbProcess secret nonce msg = run <$> sbInit secret nonce type SbState = (XSalsa.State, Poly1305.State) -sbInit :: ByteArrayAccess key => key -> ByteString -> Either CryptoError SbState -sbInit secret nonce = (state2,) <$> cryptoPassed (Poly1305.initialize rs) +cbInit :: DhSecretX25519 -> CbNonce -> Either CryptoError SbState +cbInit (DhSecretX25519 secret) (CbNonce nonce) = sbInit_ secret nonce +{-# INLINE cbInit #-} + +sbInit_ :: ByteArrayAccess key => key -> ByteString -> Either CryptoError SbState +sbInit_ secret nonce = (state2,) <$> cryptoPassed (Poly1305.initialize rs) where zero = B.replicate 16 $ toEnum 0 (iv0, iv1) = B.splitAt 8 nonce diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs index bbc7e3d43..1f230883b 100644 --- a/src/Simplex/Messaging/Notifications/Server.hs +++ b/src/Simplex/Messaging/Notifications/Server.hs @@ -235,7 +235,7 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge PCEResponseError e -> updateErr "ResponseError " e PCEUnexpectedResponse r -> updateErr "UnexpectedResponse " r PCETransportError e -> updateErr "TransportError " e - PCESignatureError e -> updateErr "SignatureError " e + PCECryptoError e -> updateErr "CryptoError " e PCEIncompatibleHost -> updateSubStatus smpQueue $ NSErr "IncompatibleHost" PCEResponseTimeout -> pure () PCENetworkError -> pure () diff --git a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs index 32f92c6aa..ae4e3453d 100644 --- a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs +++ b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs @@ -343,7 +343,7 @@ apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknData {toke nonce <- atomically $ C.pseudoRandomCbNonce nonceDrg apnsNtf <- liftEither $ first PPCryptoError $ apnsNotification tkn nonce (paddedNtfLength apnsCfg) pn req <- liftIO $ apnsRequest c tknStr apnsNtf - -- TODO if HTTP2 client is thread-safe, we can use sendRequestDirect (the tests pass) + -- TODO when HTTP2 client is thread-safe, we can use sendRequestDirect HTTP2Response {response, respBody = HTTP2Body {bodyHead}} <- liftHTTPS2 $ sendRequest http2 req let status = H.responseStatus response reason' = maybe "" reason $ J.decodeStrict' bodyHead diff --git a/tests/AgentTests.hs b/tests/AgentTests.hs index 705bf4550..77c61004e 100644 --- a/tests/AgentTests.hs +++ b/tests/AgentTests.hs @@ -499,10 +499,8 @@ syntaxTests t = do it "unknown command" $ ("1", "5678", "HELLO") >#> ("1", "5678", "ERR CMD SYNTAX") describe "NEW" $ do describe "valid" $ do - -- TODO: add tests with defined connection id it "with correct parameter" $ ("211", "", "NEW T INV") >#>= \case ("211", _, "INV" : _) -> True; _ -> False describe "invalid" $ do - -- TODO: add tests with defined connection id it "with incorrect parameter" $ ("222", "", "NEW T hi") >#> ("222", "", "ERR CMD SYNTAX") describe "JOIN" $ do diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index a43196148..6c3d6c80b 100644 --- a/tests/AgentTests/SQLiteTests.hs +++ b/tests/AgentTests/SQLiteTests.hs @@ -62,7 +62,6 @@ removeStore db = do close :: SQLiteStore -> IO () close st = mapM_ DB.close =<< atomically (tryTakeTMVar $ dbConnection st) --- TODO add null port tests storeTests :: Spec storeTests = do withStore2 $ do @@ -279,7 +278,6 @@ testDeleteRcvConn = `shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 rcvQueue1)) deleteConn db "conn1" `shouldReturn` () - -- TODO check queues are deleted as well getConn db "conn1" `shouldReturn` Left SEConnNotFound @@ -292,7 +290,6 @@ testDeleteSndConn = `shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 sndQueue1)) deleteConn db "conn1" `shouldReturn` () - -- TODO check queues are deleted as well getConn db "conn1" `shouldReturn` Left SEConnNotFound @@ -306,7 +303,6 @@ testDeleteDuplexConn = `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 [rcvQueue1] [sndQueue1])) deleteConn db "conn1" `shouldReturn` () - -- TODO check queues are deleted as well getConn db "conn1" `shouldReturn` Left SEConnNotFound diff --git a/tests/XFTPCLI.hs b/tests/XFTPCLI.hs index 57737aaf9..5897c4b0b 100644 --- a/tests/XFTPCLI.hs +++ b/tests/XFTPCLI.hs @@ -2,6 +2,7 @@ module XFTPCLI where import Control.Exception (bracket_) import qualified Data.ByteString as LB +import Data.List (isInfixOf) import Simplex.FileTransfer.Client.Main (xftpClientCLI) import System.Directory (createDirectoryIfMissing, getFileSize, removeDirectoryRecursive) import System.Environment (withArgs) @@ -68,11 +69,15 @@ testXFTPCLISendReceive2servers = withXFTPServer . withXFTPServer2 $ do where xftp params = lines <$> capture_ (withArgs params xftpClientCLI) testReceiveFile fd fileName file = do - [sizeStr, srvStr, srv1Str, srv2Str] <- xftp ["info", fd] + sizeStr : srvStr : srvs <- xftp ["info", fd] sizeStr `shouldBe` "File download size: 20mb" srvStr `shouldBe` "File server(s):" - srv1Str `shouldContain` testXFTPServerStr - srv2Str `shouldContain` testXFTPServerStr2 + case srvs of + [srv1] -> any (`isInfixOf` srv1) [testXFTPServerStr, testXFTPServerStr2] `shouldBe` True + [srv1, srv2] -> do + srv1 `shouldContain` testXFTPServerStr + srv2 `shouldContain` testXFTPServerStr2 + _ -> print srvs >> error "more than 2 servers returned" xftp ["recv", fd, recipientFiles, "--tmp=tests/tmp"] `shouldReturn` ["File received: " <> recipientFiles fileName] LB.readFile (recipientFiles fileName) `shouldReturn` file \ No newline at end of file diff --git a/tests/XFTPServerTests.hs b/tests/XFTPServerTests.hs index 42fdd28b1..429973c7b 100644 --- a/tests/XFTPServerTests.hs +++ b/tests/XFTPServerTests.hs @@ -34,7 +34,7 @@ xftpServerTests = it "should create, upload and receive file chunk (2 clients)" testFileChunkDelivery2 chSize :: Num n => n -chSize = 256 * 1024 +chSize = 128 * 1024 testChunkPath :: FilePath testChunkPath = "tests/tmp/chunk1" @@ -58,7 +58,6 @@ runTestFileChunkDelivery :: XFTPClient -> XFTPClient -> ExceptT XFTPClientError runTestFileChunkDelivery s r = do (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519 (rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519 - (rDhKey, _rpDhKey) <- liftIO C.generateKeyPair' bytes <- liftIO $ createTestChunk testChunkPath digest <- liftIO $ LC.sha512Hash <$> LB.readFile testChunkPath let file = FileInfo {sndKey, size = chSize, digest} @@ -69,7 +68,7 @@ runTestFileChunkDelivery s r = do uploadXFTPChunk s spKey sId' chunkSpec `catchError` (liftIO . (`shouldBe` PCEProtocolError DIGEST)) liftIO $ readChunk sId `shouldReturn` bytes - downloadXFTPChunk r rpKey rId rDhKey (XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize (digest <> "_wrong")) + downloadXFTPChunk r rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize (digest <> "_wrong")) `catchError` (liftIO . (`shouldBe` PCEResponseError DIGEST)) - downloadXFTPChunk r rpKey rId rDhKey $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest + downloadXFTPChunk r rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes