From 52966e7e3dcec8bcf39b86a3f227eea4bef8eb74 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Wed, 20 Sep 2023 13:05:09 +0100 Subject: [PATCH] core: optionally encrypt SMP files (#3082) * core: optionally encrypt SMP files * encrypt to temp file and rename or remove encryption args if it fails * fix file encryption error handling --- src/Simplex/Chat.hs | 75 +++++++++++++++++++-------------- src/Simplex/Chat/Mobile/File.hs | 15 +------ src/Simplex/Chat/Store/Files.hs | 18 +++++--- src/Simplex/Chat/Types.hs | 8 ++-- src/Simplex/Chat/Util.hs | 28 +++++++++++- src/Simplex/Chat/View.hs | 4 +- tests/ChatTests/Files.hs | 32 ++++++++++++++ 7 files changed, 124 insertions(+), 56 deletions(-) diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 34981fa56..abf7c8f3c 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -73,6 +73,7 @@ import Simplex.Chat.Store.Shared import Simplex.Chat.Types import Simplex.Chat.Types.Preferences import Simplex.Chat.Types.Util +import Simplex.Chat.Util (encryptFile) import Simplex.FileTransfer.Client.Main (maxFileSize) import Simplex.FileTransfer.Client.Presets (defaultXFTPServers) import Simplex.FileTransfer.Description (ValidFileDescription, gb, kb, mb) @@ -1734,22 +1735,15 @@ processChatCommand = \case ft' <- if encrypted then encryptLocalFile ft else pure ft receiveFile' user ft' rcvInline_ filePath_ where - encryptLocalFile ft@RcvFileTransfer {xftpRcvFile} = case xftpRcvFile of - Nothing -> throwChatError $ CEFileInternal "locally encrypted files can't be received via SMP" - Just f -> do - cfArgs <- liftIO $ CF.randomArgs - withStore' $ \db -> setFileCryptoArgs db fileId cfArgs - pure ft {xftpRcvFile = Just ((f :: XFTPRcvFile) {cryptoArgs = Just cfArgs})} + encryptLocalFile ft = do + cfArgs <- liftIO $ CF.randomArgs + withStore' $ \db -> setFileCryptoArgs db fileId cfArgs + pure (ft :: RcvFileTransfer) {cryptoArgs = Just cfArgs} SetFileToReceive fileId encrypted -> withUser $ \_ -> do withChatLock "setFileToReceive" . procCmd $ do - cfArgs <- if encrypted then fileCryptoArgs else pure Nothing + cfArgs <- if encrypted then Just <$> liftIO CF.randomArgs else pure Nothing withStore' $ \db -> setRcvFileToReceive db fileId cfArgs ok_ - where - fileCryptoArgs = do - (_, RcvFileTransfer {xftpRcvFile = f}) <- withStore (`getRcvFileTransferById` fileId) - unless (isJust f) $ throwChatError $ CEFileInternal "locally encrypted files can't be received via SMP" - liftIO $ Just <$> CF.randomArgs CancelFile fileId -> withUser $ \user@User {userId} -> withChatLock "cancelFile" . procCmd $ withStore (\db -> getFileTransfer db user fileId) >>= \case @@ -2319,7 +2313,7 @@ receiveFile' user ft rcvInline_ filePath_ = do e -> throwError e acceptFileReceive :: forall m. ChatMonad m => User -> RcvFileTransfer -> Maybe Bool -> Maybe FilePath -> m AChatItem -acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = FileInvitation {fileName = fName, fileConnReq, fileInline, fileSize}, fileStatus, grpMemberId} rcvInline_ filePath_ = do +acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = FileInvitation {fileName = fName, fileConnReq, fileInline, fileSize}, fileStatus, grpMemberId, cryptoArgs} rcvInline_ filePath_ = do unless (fileStatus == RFSNew) $ case fileStatus of RFSCancelled _ -> throwChatError $ CEFileCancelled fName _ -> throwChatError $ CEFileAlreadyReceiving fName @@ -2332,7 +2326,7 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI filePath <- getRcvFilePath fileId filePath_ fName True withStoreCtx (Just "acceptFileReceive, acceptRcvFileTransfer") $ \db -> acceptRcvFileTransfer db user fileId connIds ConnJoined filePath subMode -- XFTP - (Just XFTPRcvFile {cryptoArgs}, _) -> do + (Just XFTPRcvFile {}, _) -> do filePath <- getRcvFilePath fileId filePath_ fName False (ci, rfd) <- withStoreCtx (Just "acceptFileReceive, xftpAcceptRcvFT ...") $ \db -> do -- marking file as accepted and reading description in the same transaction @@ -2406,7 +2400,7 @@ getRcvFilePath fileId fPath_ fn keepHandle = case fPath_ of asks filesFolder >>= readTVarIO >>= \case Nothing -> do dir <- (`combine` "Downloads") <$> getHomeDirectory - ifM (doesDirectoryExist dir) (pure dir) getTemporaryDirectory + ifM (doesDirectoryExist dir) (pure dir) getChatTempDirectory >>= (`uniqueCombine` fn) >>= createEmptyFile Just filesFolder -> @@ -2434,14 +2428,18 @@ getRcvFilePath fileId fPath_ fn keepHandle = case fPath_ of pure fPath getTmpHandle :: FilePath -> m Handle getTmpHandle fPath = openFile fPath AppendMode `catchThrow` (ChatError . CEFileInternal . show) - uniqueCombine :: FilePath -> String -> m FilePath - uniqueCombine filePath fileName = tryCombine (0 :: Int) - where - tryCombine n = - let (name, ext) = splitExtensions fileName - suffix = if n == 0 then "" else "_" <> show n - f = filePath `combine` (name <> suffix <> ext) - in ifM (doesFileExist f) (tryCombine $ n + 1) (pure f) + +uniqueCombine :: MonadIO m => FilePath -> String -> m FilePath +uniqueCombine filePath fileName = tryCombine (0 :: Int) + where + tryCombine n = + let (name, ext) = splitExtensions fileName + suffix = if n == 0 then "" else "_" <> show n + f = filePath `combine` (name <> suffix <> ext) + in ifM (doesFileExist f) (tryCombine $ n + 1) (pure f) + +getChatTempDirectory :: ChatMonad m => m FilePath +getChatTempDirectory = chatReadVar tempDirectory >>= maybe getTemporaryDirectory pure acceptContactRequest :: ChatMonad m => User -> UserContactRequest -> Maybe IncognitoProfile -> m Contact acceptContactRequest user UserContactRequest {agentInvitationId = AgentInvId invId, cReqChatVRange, localDisplayName = cName, profileId, profile = cp, userContactLinkId, xContactId} incognitoProfile = do @@ -3513,12 +3511,12 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do RcvChunkOk -> if B.length chunk /= fromInteger chunkSize then badRcvFileChunk ft "incorrect chunk size" - else ack $ appendFileChunk ft chunkNo chunk + else ack $ appendFileChunk ft chunkNo chunk False RcvChunkFinal -> if B.length chunk > fromInteger chunkSize then badRcvFileChunk ft "incorrect chunk size" else do - appendFileChunk ft chunkNo chunk + appendFileChunk ft chunkNo chunk True ci <- withStore $ \db -> do liftIO $ do updateRcvFileStatus db fileId FSComplete @@ -3526,7 +3524,6 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do deleteRcvFileChunks db ft getChatItemByFileId db user fileId toView $ CRRcvFileComplete user ci - closeFileHandle fileId rcvFiles forM_ conn_ $ \conn -> deleteAgentConnectionAsync user (aConnId conn) RcvChunkDuplicate -> ack $ pure () RcvChunkError -> badRcvFileChunk ft $ "incorrect chunk number " <> show chunkNo @@ -3772,14 +3769,14 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do processFDMessage fileId fileDescr = do ft <- withStore $ \db -> getRcvFileTransfer db user fileId unless (rcvFileCompleteOrCancelled ft) $ do - (rfd, RcvFileTransfer {fileStatus, xftpRcvFile}) <- withStore $ \db -> do + (rfd, RcvFileTransfer {fileStatus, xftpRcvFile, cryptoArgs}) <- withStore $ \db -> do rfd <- appendRcvFD db userId fileId fileDescr -- reading second time in the same transaction as appending description -- to prevent race condition with accept ft' <- getRcvFileTransfer db user fileId pure (rfd, ft') case (fileStatus, xftpRcvFile) of - (RFSAccepted _, Just XFTPRcvFile {cryptoArgs}) -> receiveViaCompleteFD user fileId rfd cryptoArgs + (RFSAccepted _, Just XFTPRcvFile {}) -> receiveViaCompleteFD user fileId rfd cryptoArgs _ -> pure () cancelMessageFile :: Contact -> SharedMsgId -> MsgMeta -> m () @@ -4787,8 +4784,8 @@ readFileChunk SndFileTransfer {fileId, filePath, chunkSize} chunkNo = do parseFileChunk :: ChatMonad m => ByteString -> m FileChunk parseFileChunk = liftEither . first (ChatError . CEFileRcvChunk) . smpDecode -appendFileChunk :: ChatMonad m => RcvFileTransfer -> Integer -> ByteString -> m () -appendFileChunk ft@RcvFileTransfer {fileId, fileStatus} chunkNo chunk = +appendFileChunk :: forall m. ChatMonad m => RcvFileTransfer -> Integer -> ByteString -> Bool -> m () +appendFileChunk ft@RcvFileTransfer {fileId, fileStatus, cryptoArgs} chunkNo chunk final = case fileStatus of RFSConnected RcvFileInfo {filePath} -> append_ filePath -- sometimes update of file transfer status to FSConnected @@ -4797,11 +4794,27 @@ appendFileChunk ft@RcvFileTransfer {fileId, fileStatus} chunkNo chunk = RFSCancelled _ -> pure () _ -> throwChatError $ CEFileInternal "receiving file transfer not in progress" where + append_ :: FilePath -> m () append_ filePath = do fsFilePath <- toFSFilePath filePath h <- getFileHandle fileId fsFilePath rcvFiles AppendMode - liftIO (B.hPut h chunk >> hFlush h) `catchThrow` (ChatError . CEFileWrite filePath . show) + liftIO (B.hPut h chunk >> hFlush h) `catchThrow` (fileErr . show) withStore' $ \db -> updatedRcvFileChunkStored db ft chunkNo + when final $ do + closeFileHandle fileId rcvFiles + forM_ cryptoArgs $ \cfArgs -> do + tmpFile <- getChatTempDirectory >>= (`uniqueCombine` ft.fileInvitation.fileName) + tryChatError (liftError encryptErr $ encryptFile fsFilePath tmpFile cfArgs) >>= \case + Right () -> do + removeFile fsFilePath `catchChatError` \_ -> pure () + renameFile tmpFile fsFilePath + Left e -> do + toView $ CRChatError Nothing e + removeFile tmpFile `catchChatError` \_ -> pure () + withStore' (`removeFileCryptoArgs` fileId) + where + encryptErr e = fileErr $ e <> ", received file not encrypted" + fileErr = ChatError . CEFileWrite filePath getFileHandle :: ChatMonad m => Int64 -> FilePath -> (ChatController -> TVar (Map Int64 Handle)) -> IOMode -> m Handle getFileHandle fileId filePath files ioMode = do diff --git a/src/Simplex/Chat/Mobile/File.hs b/src/Simplex/Chat/Mobile/File.hs index 9dc4b5c98..e30b899f1 100644 --- a/src/Simplex/Chat/Mobile/File.hs +++ b/src/Simplex/Chat/Mobile/File.hs @@ -34,6 +34,7 @@ import Foreign.Ptr import Foreign.Storable (poke) import GHC.Generics (Generic) import Simplex.Chat.Mobile.Shared +import Simplex.Chat.Util (chunkSize, encryptFile) import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..), CryptoFileHandle, FTCryptoError (..)) import qualified Simplex.Messaging.Crypto.File as CF import Simplex.Messaging.Encoding.String @@ -105,16 +106,8 @@ chatEncryptFile fromPath toPath = where encrypt = do cfArgs <- liftIO $ CF.randomArgs - let toFile = CryptoFile toPath $ Just cfArgs - withExceptT show $ - withFile fromPath ReadMode $ \r -> CF.withFile toFile WriteMode $ \w -> do - encryptChunks r w - liftIO $ CF.hPutTag w + encryptFile fromPath toPath cfArgs pure cfArgs - encryptChunks r w = do - ch <- liftIO $ LB.hGet r chunkSize - unless (LB.null ch) $ liftIO $ CF.hPut w ch - unless (LB.length ch < chunkSize) $ encryptChunks r w cChatDecryptFile :: CString -> CString -> CString -> CString -> IO CString cChatDecryptFile cFromPath cKey cNonce cToPath = do @@ -149,7 +142,3 @@ chatDecryptFile fromPath keyStr nonceStr toPath = fromLeft "" <$> runCatchExcept runCatchExceptT :: ExceptT String IO a -> IO (Either String a) runCatchExceptT action = runExceptT action `catchAll` (pure . Left . show) - -chunkSize :: Num a => a -chunkSize = 65536 -{-# INLINE chunkSize #-} diff --git a/src/Simplex/Chat/Store/Files.hs b/src/Simplex/Chat/Store/Files.hs index 001c41d2d..a710696da 100644 --- a/src/Simplex/Chat/Store/Files.hs +++ b/src/Simplex/Chat/Store/Files.hs @@ -57,6 +57,7 @@ module Simplex.Chat.Store.Files xftpAcceptRcvFT, setRcvFileToReceive, setFileCryptoArgs, + removeFileCryptoArgs, getRcvFilesToReceive, setRcvFTAgentDeleted, updateRcvFileStatus, @@ -487,7 +488,7 @@ createRcvFileTransfer db userId Contact {contactId, localDisplayName = c} f@File rfd_ <- mapM (createRcvFD_ db userId currentTs) fileDescr let rfdId = (\RcvFileDescr {fileDescrId} -> fileDescrId) <$> rfd_ -- cryptoArgs = Nothing here, the decision to encrypt is made when receiving it - xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId = Nothing, agentRcvFileDeleted = False, cryptoArgs = Nothing}) <$> rfd_ + xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId = Nothing, agentRcvFileDeleted = False}) <$> rfd_ fileProtocol = if isJust rfd_ then FPXFTP else FPSMP fileId <- liftIO $ do DB.execute @@ -500,7 +501,7 @@ createRcvFileTransfer db userId Contact {contactId, localDisplayName = c} f@File db "INSERT INTO rcv_files (file_id, file_status, file_queue_info, file_inline, rcv_file_inline, file_descr_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)" (fileId, FSNew, fileConnReq, fileInline, rcvFileInline, rfdId, currentTs, currentTs) - pure RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = f, fileStatus = RFSNew, rcvFileInline, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Nothing} + pure RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = f, fileStatus = RFSNew, rcvFileInline, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Nothing, cryptoArgs = Nothing} createRcvGroupFileTransfer :: DB.Connection -> UserId -> GroupMember -> FileInvitation -> Maybe InlineFileMode -> Integer -> ExceptT StoreError IO RcvFileTransfer createRcvGroupFileTransfer db userId GroupMember {groupId, groupMemberId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileConnReq, fileInline, fileDescr} rcvFileInline chunkSize = do @@ -508,7 +509,7 @@ createRcvGroupFileTransfer db userId GroupMember {groupId, groupMemberId, localD rfd_ <- mapM (createRcvFD_ db userId currentTs) fileDescr let rfdId = (\RcvFileDescr {fileDescrId} -> fileDescrId) <$> rfd_ -- cryptoArgs = Nothing here, the decision to encrypt is made when receiving it - xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId = Nothing, agentRcvFileDeleted = False, cryptoArgs = Nothing}) <$> rfd_ + xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId = Nothing, agentRcvFileDeleted = False}) <$> rfd_ fileProtocol = if isJust rfd_ then FPXFTP else FPSMP fileId <- liftIO $ do DB.execute @@ -521,7 +522,7 @@ createRcvGroupFileTransfer db userId GroupMember {groupId, groupMemberId, localD db "INSERT INTO rcv_files (file_id, file_status, file_queue_info, file_inline, rcv_file_inline, group_member_id, file_descr_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)" (fileId, FSNew, fileConnReq, fileInline, rcvFileInline, groupMemberId, rfdId, currentTs, currentTs) - pure RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = f, fileStatus = RFSNew, rcvFileInline, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Just groupMemberId} + pure RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = f, fileStatus = RFSNew, rcvFileInline, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Just groupMemberId, cryptoArgs = Nothing} createRcvFD_ :: DB.Connection -> UserId -> UTCTime -> FileDescr -> ExceptT StoreError IO RcvFileDescr createRcvFD_ db userId currentTs FileDescr {fileDescrText, fileDescrPartNo, fileDescrComplete} = do @@ -639,8 +640,8 @@ getRcvFileTransfer db User {userId} fileId = do ft senderDisplayName fileStatus = let fileInvitation = FileInvitation {fileName, fileSize, fileDigest = Nothing, fileConnReq, fileInline, fileDescr = Nothing} cryptoArgs = CFArgs <$> fileKey <*> fileNonce - xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId, agentRcvFileDeleted, cryptoArgs}) <$> rfd_ - in RcvFileTransfer {fileId, xftpRcvFile, fileInvitation, fileStatus, rcvFileInline, senderDisplayName, chunkSize, cancelled, grpMemberId} + xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId, agentRcvFileDeleted}) <$> rfd_ + in RcvFileTransfer {fileId, xftpRcvFile, fileInvitation, fileStatus, rcvFileInline, senderDisplayName, chunkSize, cancelled, grpMemberId, cryptoArgs} rfi = maybe (throwError $ SERcvFileInvalid fileId) pure =<< rfi_ rfi_ = case (filePath_, connId_, agentConnId_) of (Just filePath, connId, agentConnId) -> pure $ Just RcvFileInfo {filePath, connId, agentConnId} @@ -709,6 +710,11 @@ setFileCryptoArgs_ db fileId (CFArgs key nonce) currentTs = "UPDATE files SET file_crypto_key = ?, file_crypto_nonce = ?, updated_at = ? WHERE file_id = ?" (key, nonce, currentTs, fileId) +removeFileCryptoArgs :: DB.Connection -> FileTransferId -> IO () +removeFileCryptoArgs db fileId = do + currentTs <- getCurrentTime + DB.execute db "UPDATE files SET file_crypto_key = NULL, file_crypto_nonce = NULL, updated_at = ? WHERE file_id = ?" (currentTs, fileId) + getRcvFilesToReceive :: DB.Connection -> User -> IO [RcvFileTransfer] getRcvFilesToReceive db user@User {userId} = do cutoffTs <- addUTCTime (- (2 * nominalDay)) <$> getCurrentTime diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index ac2c55735..ecae9eb09 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -986,7 +986,10 @@ data RcvFileTransfer = RcvFileTransfer senderDisplayName :: ContactName, chunkSize :: Integer, cancelled :: Bool, - grpMemberId :: Maybe Int64 + grpMemberId :: Maybe Int64, + -- XFTP files are encrypted as they are received, they are never stored unecrypted + -- SMP files are encrypted after all chunks are received + cryptoArgs :: Maybe CryptoFileArgs } deriving (Eq, Show, Generic) @@ -995,8 +998,7 @@ instance ToJSON RcvFileTransfer where toEncoding = J.genericToEncoding J.default data XFTPRcvFile = XFTPRcvFile { rcvFileDescription :: RcvFileDescr, agentRcvFileId :: Maybe AgentRcvFileId, - agentRcvFileDeleted :: Bool, - cryptoArgs :: Maybe CryptoFileArgs + agentRcvFileDeleted :: Bool } deriving (Eq, Show, Generic) diff --git a/src/Simplex/Chat/Util.hs b/src/Simplex/Chat/Util.hs index 7a350705f..46b5be28b 100644 --- a/src/Simplex/Chat/Util.hs +++ b/src/Simplex/Chat/Util.hs @@ -1,6 +1,32 @@ -module Simplex.Chat.Util (week) where +module Simplex.Chat.Util (week, encryptFile, chunkSize) where +import Control.Monad +import Control.Monad.Except +import Control.Monad.IO.Class +import qualified Data.ByteString.Lazy as LB import Data.Time (NominalDiffTime) +import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..)) +import qualified Simplex.Messaging.Crypto.File as CF +import UnliftIO.IO (IOMode (..), withFile) week :: NominalDiffTime week = 7 * 86400 + +encryptFile :: FilePath -> FilePath -> CryptoFileArgs -> ExceptT String IO () +encryptFile fromPath toPath cfArgs = do + let toFile = CryptoFile toPath $ Just cfArgs + -- uncomment to test encryption error in runTestFileTransferEncrypted + -- throwError "test error" + withExceptT show $ + withFile fromPath ReadMode $ \r -> CF.withFile toFile WriteMode $ \w -> do + encryptChunks r w + liftIO $ CF.hPutTag w + where + encryptChunks r w = do + ch <- liftIO $ LB.hGet r chunkSize + unless (LB.null ch) $ liftIO $ CF.hPut w ch + unless (LB.length ch < chunkSize) $ encryptChunks r w + +chunkSize :: Num a => a +chunkSize = 65536 +{-# INLINE chunkSize #-} diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 3607bbda5..5db0c317e 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -1592,8 +1592,8 @@ viewChatError logLevel = \case CEFileCancelled f -> ["file cancelled: " <> plain f] CEFileCancel fileId e -> ["error cancelling file " <> sShow fileId <> ": " <> sShow e] CEFileAlreadyExists f -> ["file already exists: " <> plain f] - CEFileRead f e -> ["cannot read file " <> plain f, sShow e] - CEFileWrite f e -> ["cannot write file " <> plain f, sShow e] + CEFileRead f e -> ["cannot read file " <> plain f <> ": " <> plain e] + CEFileWrite f e -> ["cannot write file " <> plain f <> ": " <> plain e] CEFileSend fileId e -> ["error sending file " <> sShow fileId <> ": " <> sShow e] CEFileRcvChunk e -> ["error receiving file: " <> plain e] CEFileInternal e -> ["file error: " <> plain e] diff --git a/tests/ChatTests/Files.hs b/tests/ChatTests/Files.hs index 386b917f8..f84d4dcb4 100644 --- a/tests/ChatTests/Files.hs +++ b/tests/ChatTests/Files.hs @@ -31,6 +31,7 @@ chatFileTests :: SpecWith FilePath chatFileTests = do describe "sending and receiving files" $ do describe "send and receive file" $ fileTestMatrix2 runTestFileTransfer + describe "send file, receive and locally encrypt file" $ fileTestMatrix2 runTestFileTransferEncrypted it "send and receive file inline (without accepting)" testInlineFileTransfer xit'' "accept inline file transfer, sender cancels during transfer" testAcceptInlineFileSndCancelDuringTransfer it "send and receive small file inline (default config)" testSmallInlineFileTransfer @@ -97,6 +98,37 @@ runTestFileTransfer alice bob = do dest <- B.readFile "./tests/tmp/test.pdf" dest `shouldBe` src +runTestFileTransferEncrypted :: HasCallStack => TestCC -> TestCC -> IO () +runTestFileTransferEncrypted alice bob = do + connectUsers alice bob + alice #> "/f @bob ./tests/fixtures/test.pdf" + alice <## "use /fc 1 to cancel sending" + bob <# "alice> sends file test.pdf (266.0 KiB / 272376 bytes)" + bob <## "use /fr 1 [/ | ] to receive it" + bob ##> "/fr 1 encrypt=on ./tests/tmp" + bob <## "saving file 1 from alice to ./tests/tmp/test.pdf" + Just (CFArgs key nonce) <- J.decode . LB.pack <$> getTermLine bob + concurrently_ + (bob <## "started receiving file 1 (test.pdf) from alice") + (alice <## "started sending file 1 (test.pdf) to bob") + + concurrentlyN_ + [ do + bob #> "@alice receiving here..." + -- uncomment this and below to test encryption error in encryptFile + -- bob <## "cannot write file ./tests/tmp/test.pdf: test error, received file not encrypted" + bob <## "completed receiving file 1 (test.pdf) from alice", + alice + <### [ WithTime "bob> receiving here...", + "completed sending file 1 (test.pdf) to bob" + ] + ] + src <- B.readFile "./tests/fixtures/test.pdf" + -- dest <- B.readFile "./tests/tmp/test.pdf" + -- dest `shouldBe` src + Right dest <- chatReadFile "./tests/tmp/test.pdf" (strEncode key) (strEncode nonce) + LB.toStrict dest `shouldBe` src + testInlineFileTransfer :: HasCallStack => FilePath -> IO () testInlineFileTransfer = testChatCfg2 cfg aliceProfile bobProfile $ \alice bob -> do