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
This commit is contained in:
Evgeny Poberezkin
GitHub
parent
f19fae615d
commit
52966e7e3d
@ -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
|
||||
|
||||
@ -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 #-}
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
@ -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 #-}
|
||||
|
||||
@ -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]
|
||||
|
||||
@ -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 [<dir>/ | <path>] 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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user