core: support encrypted local files (#2989)

* core: support encrypted local files

* add migration

* update agent api, chat api

* fix query, exported functions to read/write files

* update simplexmq

* remove formatting changes

* test, fix file size

* reduce diff

Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>

* fail when receiving SMP files with local encryption

* update simplexmq

* remove style changes

---------

Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
This commit is contained in:
Evgeny Poberezkin 2023-09-01 19:43:27 +01:00 committed by GitHub
parent 1c90eb0a2e
commit 0b214acf97
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
22 changed files with 390 additions and 147 deletions

View file

@ -9,7 +9,7 @@ constraints: zip +disable-bzip2 +disable-zstd
source-repository-package source-repository-package
type: git type: git
location: https://github.com/simplex-chat/simplexmq.git location: https://github.com/simplex-chat/simplexmq.git
tag: 4c0b8a31d20870a23e120e243359901d8240f922 tag: 5dc3d739b206edc2b4706ba0eef64ad4492e68e6
source-repository-package source-repository-package
type: git type: git

View file

@ -1,5 +1,5 @@
{ {
"https://github.com/simplex-chat/simplexmq.git"."4c0b8a31d20870a23e120e243359901d8240f922" = "0lrgfm8di0x4rmidqp7k2fw29yaal6467nmb85lwk95yz602906z"; "https://github.com/simplex-chat/simplexmq.git"."5dc3d739b206edc2b4706ba0eef64ad4492e68e6" = "0nzp0ijmw7ppmzjj72hf0b8jkyg8lwwy92hc1649xk3hnrj48wfz";
"https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38"; "https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38";
"https://github.com/kazu-yamamoto/http2.git"."b5a1b7200cf5bc7044af34ba325284271f6dff25" = "0dqb50j57an64nf4qcf5vcz4xkd1vzvghvf8bk529c1k30r9nfzb"; "https://github.com/kazu-yamamoto/http2.git"."b5a1b7200cf5bc7044af34ba325284271f6dff25" = "0dqb50j57an64nf4qcf5vcz4xkd1vzvghvf8bk529c1k30r9nfzb";
"https://github.com/simplex-chat/direct-sqlcipher.git"."34309410eb2069b029b8fc1872deb1e0db123294" = "0kwkmhyfsn2lixdlgl15smgr1h5gjk7fky6abzh8rng2h5ymnffd"; "https://github.com/simplex-chat/direct-sqlcipher.git"."34309410eb2069b029b8fc1872deb1e0db123294" = "0kwkmhyfsn2lixdlgl15smgr1h5gjk7fky6abzh8rng2h5ymnffd";

View file

@ -1,6 +1,6 @@
cabal-version: 1.12 cabal-version: 1.12
-- This file has been generated from package.yaml by hpack version 0.35.0. -- This file has been generated from package.yaml by hpack version 0.35.2.
-- --
-- see: https://github.com/sol/hpack -- see: https://github.com/sol/hpack
@ -10,7 +10,7 @@ category: Web, System, Services, Cryptography
homepage: https://github.com/simplex-chat/simplex-chat#readme homepage: https://github.com/simplex-chat/simplex-chat#readme
author: simplex.chat author: simplex.chat
maintainer: chat@simplex.chat maintainer: chat@simplex.chat
copyright: 2020-23 simplex.chat copyright: 2020-22 simplex.chat
license: AGPL-3 license: AGPL-3
license-file: LICENSE license-file: LICENSE
build-type: Simple build-type: Simple
@ -108,7 +108,10 @@ library
Simplex.Chat.Migrations.M20230705_delivery_receipts Simplex.Chat.Migrations.M20230705_delivery_receipts
Simplex.Chat.Migrations.M20230721_group_snd_item_statuses Simplex.Chat.Migrations.M20230721_group_snd_item_statuses
Simplex.Chat.Migrations.M20230814_indexes Simplex.Chat.Migrations.M20230814_indexes
Simplex.Chat.Migrations.M20230827_file_encryption
Simplex.Chat.Mobile Simplex.Chat.Mobile
Simplex.Chat.Mobile.File
Simplex.Chat.Mobile.Shared
Simplex.Chat.Mobile.WebRTC Simplex.Chat.Mobile.WebRTC
Simplex.Chat.Options Simplex.Chat.Options
Simplex.Chat.ProfileGenerator Simplex.Chat.ProfileGenerator

View file

@ -1,4 +1,3 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
@ -86,6 +85,8 @@ import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
import Simplex.Messaging.Client (defaultNetworkConfig) import Simplex.Messaging.Client (defaultNetworkConfig)
import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
import qualified Simplex.Messaging.Crypto.File as CF
import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (base64P) import Simplex.Messaging.Parsers (base64P)
@ -562,8 +563,9 @@ processChatCommand = \case
SendFileSMP fileInline -> smpSndFileTransfer file fileSize fileInline SendFileSMP fileInline -> smpSndFileTransfer file fileSize fileInline
SendFileXFTP -> xftpSndFileTransfer user file fileSize 1 $ CGContact ct SendFileXFTP -> xftpSndFileTransfer user file fileSize 1 $ CGContact ct
where where
smpSndFileTransfer :: FilePath -> Integer -> Maybe InlineFileMode -> m (FileInvitation, CIFile 'MDSnd, FileTransferMeta) smpSndFileTransfer :: CryptoFile -> Integer -> Maybe InlineFileMode -> m (FileInvitation, CIFile 'MDSnd, FileTransferMeta)
smpSndFileTransfer file fileSize fileInline = do smpSndFileTransfer (CryptoFile _ (Just _)) _ _ = throwChatError $ CEFileInternal "locally encrypted files can't be sent via SMP" -- can only happen if XFTP is disabled
smpSndFileTransfer (CryptoFile file Nothing) fileSize fileInline = do
(agentConnId_, fileConnReq) <- (agentConnId_, fileConnReq) <-
if isJust fileInline if isJust fileInline
then pure (Nothing, Nothing) then pure (Nothing, Nothing)
@ -576,7 +578,8 @@ processChatCommand = \case
fileStatus <- case fileInline of fileStatus <- case fileInline of
Just IFMSent -> createSndDirectInlineFT db ct ft $> CIFSSndTransfer 0 1 Just IFMSent -> createSndDirectInlineFT db ct ft $> CIFSSndTransfer 0 1
_ -> pure CIFSSndStored _ -> pure CIFSSndStored
let ciFile = CIFile {fileId, fileName, fileSize, filePath = Just file, fileStatus, fileProtocol = FPSMP} let fileSource = Just $ CF.plain file
ciFile = CIFile {fileId, fileName, fileSize, fileSource, fileStatus, fileProtocol = FPSMP}
pure (fileInvitation, ciFile, ft) pure (fileInvitation, ciFile, ft)
prepareMsg :: Maybe FileInvitation -> Maybe CITimed -> m (MsgContainer, Maybe (CIQuote 'CTDirect)) prepareMsg :: Maybe FileInvitation -> Maybe CITimed -> m (MsgContainer, Maybe (CIQuote 'CTDirect))
prepareMsg fInv_ timed_ = case quotedItemId_ of prepareMsg fInv_ timed_ = case quotedItemId_ of
@ -625,15 +628,17 @@ processChatCommand = \case
SendFileSMP fileInline -> smpSndFileTransfer file fileSize fileInline SendFileSMP fileInline -> smpSndFileTransfer file fileSize fileInline
SendFileXFTP -> xftpSndFileTransfer user file fileSize n $ CGGroup g SendFileXFTP -> xftpSndFileTransfer user file fileSize n $ CGGroup g
where where
smpSndFileTransfer :: FilePath -> Integer -> Maybe InlineFileMode -> m (FileInvitation, CIFile 'MDSnd, FileTransferMeta) smpSndFileTransfer :: CryptoFile -> Integer -> Maybe InlineFileMode -> m (FileInvitation, CIFile 'MDSnd, FileTransferMeta)
smpSndFileTransfer file fileSize fileInline = do smpSndFileTransfer (CryptoFile _ (Just _)) _ _ = throwChatError $ CEFileInternal "locally encrypted files can't be sent via SMP" -- can only happen if XFTP is disabled
smpSndFileTransfer (CryptoFile file Nothing) fileSize fileInline = do
let fileName = takeFileName file let fileName = takeFileName file
fileInvitation = FileInvitation {fileName, fileSize, fileDigest = Nothing, fileConnReq = Nothing, fileInline, fileDescr = Nothing} fileInvitation = FileInvitation {fileName, fileSize, fileDigest = Nothing, fileConnReq = Nothing, fileInline, fileDescr = Nothing}
fileStatus = if fileInline == Just IFMSent then CIFSSndTransfer 0 1 else CIFSSndStored fileStatus = if fileInline == Just IFMSent then CIFSSndTransfer 0 1 else CIFSSndStored
chSize <- asks $ fileChunkSize . config chSize <- asks $ fileChunkSize . config
withStore' $ \db -> do withStore' $ \db -> do
ft@FileTransferMeta {fileId} <- createSndGroupFileTransfer db userId gInfo file fileInvitation chSize ft@FileTransferMeta {fileId} <- createSndGroupFileTransfer db userId gInfo file fileInvitation chSize
let ciFile = CIFile {fileId, fileName, fileSize, filePath = Just file, fileStatus, fileProtocol = FPSMP} let fileSource = Just $ CF.plain file
ciFile = CIFile {fileId, fileName, fileSize, fileSource, fileStatus, fileProtocol = FPSMP}
pure (fileInvitation, ciFile, ft) pure (fileInvitation, ciFile, ft)
sendGroupFileInline :: [GroupMember] -> SharedMsgId -> FileTransferMeta -> m () sendGroupFileInline :: [GroupMember] -> SharedMsgId -> FileTransferMeta -> m ()
sendGroupFileInline ms sharedMsgId ft@FileTransferMeta {fileInline} = sendGroupFileInline ms sharedMsgId ft@FileTransferMeta {fileInline} =
@ -688,17 +693,19 @@ processChatCommand = \case
qText = msgContentText qmc qText = msgContentText qmc
qFileName = maybe qText (T.pack . (fileName :: CIFile d -> String)) ciFile_ qFileName = maybe qText (T.pack . (fileName :: CIFile d -> String)) ciFile_
qTextOrFile = if T.null qText then qFileName else qText qTextOrFile = if T.null qText then qFileName else qText
xftpSndFileTransfer :: User -> FilePath -> Integer -> Int -> ContactOrGroup -> m (FileInvitation, CIFile 'MDSnd, FileTransferMeta) xftpSndFileTransfer :: User -> CryptoFile -> Integer -> Int -> ContactOrGroup -> m (FileInvitation, CIFile 'MDSnd, FileTransferMeta)
xftpSndFileTransfer user file fileSize n contactOrGroup = do xftpSndFileTransfer user file@(CryptoFile filePath cfArgs) fileSize n contactOrGroup = do
let fileName = takeFileName file let fileName = takeFileName filePath
fileDescr = FileDescr {fileDescrText = "", fileDescrPartNo = 0, fileDescrComplete = False} fileDescr = FileDescr {fileDescrText = "", fileDescrPartNo = 0, fileDescrComplete = False}
fInv = xftpFileInvitation fileName fileSize fileDescr fInv = xftpFileInvitation fileName fileSize fileDescr
fsFilePath <- toFSFilePath file fsFilePath <- toFSFilePath filePath
aFileId <- withAgent $ \a -> xftpSendFile a (aUserId user) fsFilePath (roundedFDCount n) let srcFile = CryptoFile fsFilePath cfArgs
aFileId <- withAgent $ \a -> xftpSendFile a (aUserId user) srcFile (roundedFDCount n)
-- TODO CRSndFileStart event for XFTP -- TODO CRSndFileStart event for XFTP
chSize <- asks $ fileChunkSize . config chSize <- asks $ fileChunkSize . config
ft@FileTransferMeta {fileId} <- withStore' $ \db -> createSndFileTransferXFTP db user contactOrGroup file fInv (AgentSndFileId aFileId) chSize ft@FileTransferMeta {fileId} <- withStore' $ \db -> createSndFileTransferXFTP db user contactOrGroup file fInv (AgentSndFileId aFileId) chSize
let ciFile = CIFile {fileId, fileName, fileSize, filePath = Just file, fileStatus = CIFSSndStored, fileProtocol = FPXFTP} let fileSource = Just $ CryptoFile filePath cfArgs
ciFile = CIFile {fileId, fileName, fileSize, fileSource, fileStatus = CIFSSndStored, fileProtocol = FPXFTP}
case contactOrGroup of case contactOrGroup of
CGContact Contact {activeConn} -> withStore' $ \db -> createSndFTDescrXFTP db user Nothing activeConn ft fileDescr CGContact Contact {activeConn} -> withStore' $ \db -> createSndFTDescrXFTP db user Nothing activeConn ft fileDescr
CGGroup (Group _ ms) -> forM_ ms $ \m -> saveMemberFD m `catchChatError` (toView . CRChatError (Just user)) CGGroup (Group _ ms) -> forM_ ms $ \m -> saveMemberFD m `catchChatError` (toView . CRChatError (Just user))
@ -1613,26 +1620,40 @@ processChatCommand = \case
asks showLiveItems >>= atomically . (`writeTVar` on) >> ok_ asks showLiveItems >>= atomically . (`writeTVar` on) >> ok_
SendFile chatName f -> withUser $ \user -> do SendFile chatName f -> withUser $ \user -> do
chatRef <- getChatRef user chatName chatRef <- getChatRef user chatName
processChatCommand . APISendMessage chatRef False Nothing $ ComposedMessage (Just f) Nothing (MCFile "") processChatCommand . APISendMessage chatRef False Nothing $ ComposedMessage (Just $ CF.plain f) Nothing (MCFile "")
SendImage chatName f -> withUser $ \user -> do SendImage chatName f -> withUser $ \user -> do
chatRef <- getChatRef user chatName chatRef <- getChatRef user chatName
filePath <- toFSFilePath f filePath <- toFSFilePath f
unless (any ((`isSuffixOf` map toLower f)) imageExtensions) $ throwChatError CEFileImageType {filePath} unless (any (`isSuffixOf` map toLower f) imageExtensions) $ throwChatError CEFileImageType {filePath}
fileSize <- getFileSize filePath fileSize <- getFileSize filePath
unless (fileSize <= maxImageSize) $ throwChatError CEFileImageSize {filePath} unless (fileSize <= maxImageSize) $ throwChatError CEFileImageSize {filePath}
-- TODO include file description for preview -- TODO include file description for preview
processChatCommand . APISendMessage chatRef False Nothing $ ComposedMessage (Just f) Nothing (MCImage "" fixedImagePreview) processChatCommand . APISendMessage chatRef False Nothing $ ComposedMessage (Just $ CF.plain f) Nothing (MCImage "" fixedImagePreview)
ForwardFile chatName fileId -> forwardFile chatName fileId SendFile ForwardFile chatName fileId -> forwardFile chatName fileId SendFile
ForwardImage chatName fileId -> forwardFile chatName fileId SendImage ForwardImage chatName fileId -> forwardFile chatName fileId SendImage
SendFileDescription _chatName _f -> pure $ chatCmdError Nothing "TODO" SendFileDescription _chatName _f -> pure $ chatCmdError Nothing "TODO"
ReceiveFile fileId rcvInline_ filePath_ -> withUser $ \_ -> ReceiveFile fileId encrypted rcvInline_ filePath_ -> withUser $ \_ ->
withChatLock "receiveFile" . procCmd $ do withChatLock "receiveFile" . procCmd $ do
(user, ft) <- withStore $ \db -> getRcvFileTransferById db fileId (user, ft) <- withStore (`getRcvFileTransferById` fileId)
receiveFile' user ft rcvInline_ filePath_ ft' <- if encrypted then encryptLocalFile ft else pure ft
SetFileToReceive fileId -> withUser $ \_ -> do 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})}
SetFileToReceive fileId encrypted -> withUser $ \_ -> do
withChatLock "setFileToReceive" . procCmd $ do withChatLock "setFileToReceive" . procCmd $ do
withStore' (`setRcvFileToReceive` fileId) cfArgs <- if encrypted then fileCryptoArgs else pure Nothing
withStore' $ \db -> setRcvFileToReceive db fileId cfArgs
ok_ 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} -> CancelFile fileId -> withUser $ \user@User {userId} ->
withChatLock "cancelFile" . procCmd $ withChatLock "cancelFile" . procCmd $
withStore (\db -> getFileTransfer db user fileId) >>= \case withStore (\db -> getFileTransfer db user fileId) >>= \case
@ -1829,18 +1850,19 @@ processChatCommand = \case
contactMember Contact {contactId} = contactMember Contact {contactId} =
find $ \GroupMember {memberContactId = cId, memberStatus = s} -> find $ \GroupMember {memberContactId = cId, memberStatus = s} ->
cId == Just contactId && s /= GSMemRemoved && s /= GSMemLeft cId == Just contactId && s /= GSMemRemoved && s /= GSMemLeft
checkSndFile :: MsgContent -> FilePath -> Integer -> m (Integer, SendFileMode) checkSndFile :: MsgContent -> CryptoFile -> Integer -> m (Integer, SendFileMode)
checkSndFile mc f n = do checkSndFile mc (CryptoFile f cfArgs) n = do
fsFilePath <- toFSFilePath f fsFilePath <- toFSFilePath f
unlessM (doesFileExist fsFilePath) . throwChatError $ CEFileNotFound f unlessM (doesFileExist fsFilePath) . throwChatError $ CEFileNotFound f
ChatConfig {fileChunkSize, inlineFiles} <- asks config ChatConfig {fileChunkSize, inlineFiles} <- asks config
xftpCfg <- readTVarIO =<< asks userXFTPFileConfig xftpCfg <- readTVarIO =<< asks userXFTPFileConfig
fileSize <- getFileSize fsFilePath fileSize <- liftIO $ CF.getFileContentsSize $ CryptoFile fsFilePath cfArgs
when (fromInteger fileSize > maxFileSize) $ throwChatError $ CEFileSize f when (fromInteger fileSize > maxFileSize) $ throwChatError $ CEFileSize f
let chunks = - ((- fileSize) `div` fileChunkSize) let chunks = -((-fileSize) `div` fileChunkSize)
fileInline = inlineFileMode mc inlineFiles chunks n fileInline = inlineFileMode mc inlineFiles chunks n
fileMode = case xftpCfg of fileMode = case xftpCfg of
Just cfg Just cfg
| isJust cfArgs -> SendFileXFTP
| fileInline == Just IFMSent || fileSize < minFileSize cfg || n <= 0 -> SendFileSMP fileInline | fileInline == Just IFMSent || fileSize < minFileSize cfg || n <= 0 -> SendFileSMP fileInline
| otherwise -> SendFileXFTP | otherwise -> SendFileXFTP
_ -> SendFileSMP fileInline _ -> SendFileSMP fileInline
@ -1867,17 +1889,17 @@ processChatCommand = \case
summary <- foldM (processAndCount user' logLevel) (UserProfileUpdateSummary 0 0 0 []) contacts summary <- foldM (processAndCount user' logLevel) (UserProfileUpdateSummary 0 0 0 []) contacts
pure $ CRUserProfileUpdated user' (fromLocalProfile p) p' summary pure $ CRUserProfileUpdated user' (fromLocalProfile p) p' summary
where where
processAndCount user' ll (!s@UserProfileUpdateSummary {notChanged, updateSuccesses, updateFailures, changedContacts = cts}) ct = do processAndCount user' ll s@UserProfileUpdateSummary {notChanged, updateSuccesses, updateFailures, changedContacts = cts} ct = do
let mergedProfile = userProfileToSend user Nothing $ Just ct let mergedProfile = userProfileToSend user Nothing $ Just ct
ct' = updateMergedPreferences user' ct ct' = updateMergedPreferences user' ct
mergedProfile' = userProfileToSend user' Nothing $ Just ct' mergedProfile' = userProfileToSend user' Nothing $ Just ct'
if mergedProfile' == mergedProfile if mergedProfile' == mergedProfile
then pure s {notChanged = notChanged + 1} then pure s {notChanged = notChanged + 1}
else else
let cts' = if mergedPreferences ct == mergedPreferences ct' then cts else ct' : cts let cts' = if mergedPreferences ct == mergedPreferences ct' then cts else ct' : cts
in (notifyContact mergedProfile' ct' $> s {updateSuccesses = updateSuccesses + 1, changedContacts = cts'}) in (notifyContact mergedProfile' ct' $> s {updateSuccesses = updateSuccesses + 1, changedContacts = cts'})
`catchChatError` \e -> when (ll <= CLLInfo) (toView $ CRChatError (Just user) e) $> s {updateFailures = updateFailures + 1, changedContacts = cts'} `catchChatError` \e -> when (ll <= CLLInfo) (toView $ CRChatError (Just user) e) $> s {updateFailures = updateFailures + 1, changedContacts = cts'}
where where
notifyContact mergedProfile' ct' = do notifyContact mergedProfile' ct' = do
void $ sendDirectContactMessage ct' (XInfo mergedProfile') void $ sendDirectContactMessage ct' (XInfo mergedProfile')
when (directOrUsed ct') $ createSndFeatureItems user' ct ct' when (directOrUsed ct') $ createSndFeatureItems user' ct ct'
@ -2214,7 +2236,7 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI
filePath <- getRcvFilePath fileId filePath_ fName True filePath <- getRcvFilePath fileId filePath_ fName True
withStoreCtx (Just "acceptFileReceive, acceptRcvFileTransfer") $ \db -> acceptRcvFileTransfer db user fileId connIds ConnJoined filePath withStoreCtx (Just "acceptFileReceive, acceptRcvFileTransfer") $ \db -> acceptRcvFileTransfer db user fileId connIds ConnJoined filePath
-- XFTP -- XFTP
(Just _xftpRcvFile, _) -> do (Just XFTPRcvFile {cryptoArgs}, _) -> do
filePath <- getRcvFilePath fileId filePath_ fName False filePath <- getRcvFilePath fileId filePath_ fName False
(ci, rfd) <- withStoreCtx (Just "acceptFileReceive, xftpAcceptRcvFT ...") $ \db -> do (ci, rfd) <- withStoreCtx (Just "acceptFileReceive, xftpAcceptRcvFT ...") $ \db -> do
-- marking file as accepted and reading description in the same transaction -- marking file as accepted and reading description in the same transaction
@ -2222,7 +2244,7 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI
ci <- xftpAcceptRcvFT db user fileId filePath ci <- xftpAcceptRcvFT db user fileId filePath
rfd <- getRcvFileDescrByFileId db fileId rfd <- getRcvFileDescrByFileId db fileId
pure (ci, rfd) pure (ci, rfd)
receiveViaCompleteFD user fileId rfd receiveViaCompleteFD user fileId rfd cryptoArgs
pure ci pure ci
-- group & direct file protocol -- group & direct file protocol
_ -> do _ -> do
@ -2265,11 +2287,11 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI
|| (rcvInline_ == Just True && fileSize <= fileChunkSize * offerChunks) || (rcvInline_ == Just True && fileSize <= fileChunkSize * offerChunks)
) )
receiveViaCompleteFD :: ChatMonad m => User -> FileTransferId -> RcvFileDescr -> m () receiveViaCompleteFD :: ChatMonad m => User -> FileTransferId -> RcvFileDescr -> Maybe CryptoFileArgs -> m ()
receiveViaCompleteFD user fileId RcvFileDescr {fileDescrText, fileDescrComplete} = receiveViaCompleteFD user fileId RcvFileDescr {fileDescrText, fileDescrComplete} cfArgs =
when fileDescrComplete $ do when fileDescrComplete $ do
rd <- parseFileDescription fileDescrText rd <- parseFileDescription fileDescrText
aFileId <- withAgent $ \a -> xftpReceiveFile a (aUserId user) rd aFileId <- withAgent $ \a -> xftpReceiveFile a (aUserId user) rd cfArgs
startReceivingFile user fileId startReceivingFile user fileId
withStoreCtx' (Just "receiveViaCompleteFD, updateRcvFileAgentId") $ \db -> updateRcvFileAgentId db fileId (Just $ AgentRcvFileId aFileId) withStoreCtx' (Just "receiveViaCompleteFD, updateRcvFileAgentId") $ \db -> updateRcvFileAgentId db fileId (Just $ AgentRcvFileId aFileId)
@ -2535,7 +2557,7 @@ cleanupManager = do
`catchChatError` (toView . CRChatError (Just user)) `catchChatError` (toView . CRChatError (Just user))
cleanupMessages = do cleanupMessages = do
ts <- liftIO getCurrentTime ts <- liftIO getCurrentTime
let cutoffTs = addUTCTime (- (30 * nominalDay)) ts let cutoffTs = addUTCTime (-(30 * nominalDay)) ts
withStoreCtx' (Just "cleanupManager, deleteOldMessages") (`deleteOldMessages` cutoffTs) withStoreCtx' (Just "cleanupManager, deleteOldMessages") (`deleteOldMessages` cutoffTs)
startProximateTimedItemThread :: ChatMonad m => User -> (ChatRef, ChatItemId) -> UTCTime -> m () startProximateTimedItemThread :: ChatMonad m => User -> (ChatRef, ChatItemId) -> UTCTime -> m ()
@ -3567,14 +3589,14 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
processFDMessage fileId fileDescr = do processFDMessage fileId fileDescr = do
ft <- withStore $ \db -> getRcvFileTransfer db user fileId ft <- withStore $ \db -> getRcvFileTransfer db user fileId
unless (rcvFileCompleteOrCancelled ft) $ do unless (rcvFileCompleteOrCancelled ft) $ do
(rfd, RcvFileTransfer {fileStatus}) <- withStore $ \db -> do (rfd, RcvFileTransfer {fileStatus, xftpRcvFile}) <- withStore $ \db -> do
rfd <- appendRcvFD db userId fileId fileDescr rfd <- appendRcvFD db userId fileId fileDescr
-- reading second time in the same transaction as appending description -- reading second time in the same transaction as appending description
-- to prevent race condition with accept -- to prevent race condition with accept
ft' <- getRcvFileTransfer db user fileId ft' <- getRcvFileTransfer db user fileId
pure (rfd, ft') pure (rfd, ft')
case fileStatus of case (fileStatus, xftpRcvFile) of
RFSAccepted _ -> receiveViaCompleteFD user fileId rfd (RFSAccepted _, Just XFTPRcvFile {cryptoArgs}) -> receiveViaCompleteFD user fileId rfd cryptoArgs
_ -> pure () _ -> pure ()
cancelMessageFile :: Contact -> SharedMsgId -> MsgMeta -> m () cancelMessageFile :: Contact -> SharedMsgId -> MsgMeta -> m ()
@ -3600,7 +3622,8 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
withStore' $ \db -> startRcvInlineFT db user ft fPath inline withStore' $ \db -> startRcvInlineFT db user ft fPath inline
pure (Just fPath, CIFSRcvAccepted) pure (Just fPath, CIFSRcvAccepted)
_ -> pure (Nothing, CIFSRcvInvitation) _ -> pure (Nothing, CIFSRcvInvitation)
pure (ft, CIFile {fileId, fileName, fileSize, filePath, fileStatus, fileProtocol}) let fileSource = CF.plain <$> filePath
pure (ft, CIFile {fileId, fileName, fileSize, fileSource, fileStatus, fileProtocol})
messageUpdate :: Contact -> SharedMsgId -> MsgContent -> RcvMessage -> MsgMeta -> Maybe Int -> Maybe Bool -> m () messageUpdate :: Contact -> SharedMsgId -> MsgContent -> RcvMessage -> MsgMeta -> Maybe Int -> Maybe Bool -> m ()
messageUpdate ct@Contact {contactId, localDisplayName = c} sharedMsgId mc msg@RcvMessage {msgId} msgMeta ttl live_ = do messageUpdate ct@Contact {contactId, localDisplayName = c} sharedMsgId mc msg@RcvMessage {msgId} msgMeta ttl live_ = do
@ -3817,7 +3840,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
inline <- receiveInlineMode fInv Nothing fileChunkSize inline <- receiveInlineMode fInv Nothing fileChunkSize
RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvFileTransfer db userId ct fInv inline fileChunkSize RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvFileTransfer db userId ct fInv inline fileChunkSize
let fileProtocol = if isJust xftpRcvFile then FPXFTP else FPSMP let fileProtocol = if isJust xftpRcvFile then FPXFTP else FPSMP
ciFile = Just $ CIFile {fileId, fileName, fileSize, filePath = Nothing, fileStatus = CIFSRcvInvitation, fileProtocol} ciFile = Just $ CIFile {fileId, fileName, fileSize, fileSource = Nothing, fileStatus = CIFSRcvInvitation, fileProtocol}
ci <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ msgMeta (CIRcvMsgContent $ MCFile "") ciFile Nothing False ci <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ msgMeta (CIRcvMsgContent $ MCFile "") ciFile Nothing False
toView $ CRNewChatItem user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci) toView $ CRNewChatItem user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci)
whenContactNtfs user ct $ do whenContactNtfs user ct $ do
@ -3831,7 +3854,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
inline <- receiveInlineMode fInv Nothing fileChunkSize inline <- receiveInlineMode fInv Nothing fileChunkSize
RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvGroupFileTransfer db userId m fInv inline fileChunkSize RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvGroupFileTransfer db userId m fInv inline fileChunkSize
let fileProtocol = if isJust xftpRcvFile then FPXFTP else FPSMP let fileProtocol = if isJust xftpRcvFile then FPXFTP else FPSMP
ciFile = Just $ CIFile {fileId, fileName, fileSize, filePath = Nothing, fileStatus = CIFSRcvInvitation, fileProtocol} ciFile = Just $ CIFile {fileId, fileName, fileSize, fileSource = Nothing, fileStatus = CIFSRcvInvitation, fileProtocol}
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ msgMeta (CIRcvMsgContent $ MCFile "") ciFile Nothing False ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ msgMeta (CIRcvMsgContent $ MCFile "") ciFile Nothing False
groupMsgToView gInfo m ci msgMeta groupMsgToView gInfo m ci msgMeta
let g = groupName' gInfo let g = groupName' gInfo
@ -4737,10 +4760,9 @@ deleteGroupCI user gInfo ci@(CChatItem msgDir deletedItem@ChatItem {file}) byUse
pure $ CRChatItemDeleted user (AChatItem SCTGroup msgDir (GroupChat gInfo) deletedItem) toCi byUser timed pure $ CRChatItemDeleted user (AChatItem SCTGroup msgDir (GroupChat gInfo) deletedItem) toCi byUser timed
deleteCIFile :: (ChatMonad m, MsgDirectionI d) => User -> Maybe (CIFile d) -> m () deleteCIFile :: (ChatMonad m, MsgDirectionI d) => User -> Maybe (CIFile d) -> m ()
deleteCIFile user file = deleteCIFile user file_ =
forM_ file $ \CIFile {fileId, filePath, fileStatus} -> do forM_ file_ $ \file -> do
let fileInfo = CIFileInfo {fileId, fileStatus = Just $ AFS msgDirection fileStatus, filePath} fileAgentConnIds <- deleteFile' user (mkCIFileInfo file) True
fileAgentConnIds <- deleteFile' user fileInfo True
deleteAgentConnectionsAsync user fileAgentConnIds deleteAgentConnectionsAsync user fileAgentConnIds
markDirectCIDeleted :: ChatMonad m => User -> Contact -> CChatItem 'CTDirect -> MessageId -> Bool -> UTCTime -> m ChatResponse markDirectCIDeleted :: ChatMonad m => User -> Contact -> CChatItem 'CTDirect -> MessageId -> Bool -> UTCTime -> m ChatResponse
@ -4764,10 +4786,9 @@ markGroupCIDeleted user gInfo@GroupInfo {groupId} ci@(CChatItem _ ChatItem {file
gItem (CChatItem msgDir ci') = AChatItem SCTGroup msgDir (GroupChat gInfo) ci' gItem (CChatItem msgDir ci') = AChatItem SCTGroup msgDir (GroupChat gInfo) ci'
cancelCIFile :: (ChatMonad m, MsgDirectionI d) => User -> Maybe (CIFile d) -> m () cancelCIFile :: (ChatMonad m, MsgDirectionI d) => User -> Maybe (CIFile d) -> m ()
cancelCIFile user file = cancelCIFile user file_ =
forM_ file $ \CIFile {fileId, filePath, fileStatus} -> do forM_ file_ $ \file -> do
let fileInfo = CIFileInfo {fileId, fileStatus = Just $ AFS msgDirection fileStatus, filePath} fileAgentConnIds <- cancelFile' user (mkCIFileInfo file) True
fileAgentConnIds <- cancelFile' user fileInfo True
deleteAgentConnectionsAsync user fileAgentConnIds deleteAgentConnectionsAsync user fileAgentConnIds
createAgentConnectionAsync :: forall m c. (ChatMonad m, ConnectionModeI c) => User -> CommandFunction -> Bool -> SConnectionMode c -> m (CommandId, ConnId) createAgentConnectionAsync :: forall m c. (ChatMonad m, ConnectionModeI c) => User -> CommandFunction -> Bool -> SConnectionMode c -> m (CommandId, ConnId)
@ -5000,7 +5021,7 @@ withAgent :: ChatMonad m => (AgentClient -> ExceptT AgentErrorType m a) -> m a
withAgent action = withAgent action =
asks smpAgent asks smpAgent
>>= runExceptT . action >>= runExceptT . action
>>= liftEither . first (\e -> ChatErrorAgent e Nothing) >>= liftEither . first (`ChatErrorAgent` Nothing)
withStore' :: ChatMonad m => (DB.Connection -> IO a) -> m a withStore' :: ChatMonad m => (DB.Connection -> IO a) -> m a
withStore' action = withStore $ liftIO . action withStore' action = withStore $ liftIO . action
@ -5235,8 +5256,8 @@ chatCommandP =
("/fforward " <|> "/ff ") *> (ForwardFile <$> chatNameP' <* A.space <*> A.decimal), ("/fforward " <|> "/ff ") *> (ForwardFile <$> chatNameP' <* A.space <*> A.decimal),
("/image_forward " <|> "/imgf ") *> (ForwardImage <$> chatNameP' <* A.space <*> A.decimal), ("/image_forward " <|> "/imgf ") *> (ForwardImage <$> chatNameP' <* A.space <*> A.decimal),
("/fdescription " <|> "/fd") *> (SendFileDescription <$> chatNameP' <* A.space <*> filePath), ("/fdescription " <|> "/fd") *> (SendFileDescription <$> chatNameP' <* A.space <*> filePath),
("/freceive " <|> "/fr ") *> (ReceiveFile <$> A.decimal <*> optional (" inline=" *> onOffP) <*> optional (A.space *> filePath)), ("/freceive " <|> "/fr ") *> (ReceiveFile <$> A.decimal <*> (" encrypt=" *> onOffP <|> pure False) <*> optional (" inline=" *> onOffP) <*> optional (A.space *> filePath)),
"/_set_file_to_receive " *> (SetFileToReceive <$> A.decimal), "/_set_file_to_receive " *> (SetFileToReceive <$> A.decimal <*> (" encrypt=" *> onOffP <|> pure False)),
("/fcancel " <|> "/fc ") *> (CancelFile <$> A.decimal), ("/fcancel " <|> "/fc ") *> (CancelFile <$> A.decimal),
("/fstatus " <|> "/fs ") *> (FileStatus <$> A.decimal), ("/fstatus " <|> "/fs ") *> (FileStatus <$> A.decimal),
"/simplex" *> (ConnectSimplex <$> incognitoP), "/simplex" *> (ConnectSimplex <$> incognitoP),

View file

@ -66,7 +66,7 @@ sendComposedMessage cc = sendComposedMessage' cc . contactId'
sendComposedMessage' :: ChatController -> ContactId -> Maybe ChatItemId -> MsgContent -> IO () sendComposedMessage' :: ChatController -> ContactId -> Maybe ChatItemId -> MsgContent -> IO ()
sendComposedMessage' cc ctId quotedItemId msgContent = do sendComposedMessage' cc ctId quotedItemId msgContent = do
let cm = ComposedMessage {filePath = Nothing, quotedItemId, msgContent} let cm = ComposedMessage {fileSource = Nothing, quotedItemId, msgContent}
sendChatCmd cc (APISendMessage (ChatRef CTDirect ctId) False Nothing cm) >>= \case sendChatCmd cc (APISendMessage (ChatRef CTDirect ctId) False Nothing cm) >>= \case
CRNewChatItem {} -> printLog cc CLLInfo $ "sent message to contact ID " <> show ctId CRNewChatItem {} -> printLog cc CLLInfo $ "sent message to contact ID " <> show ctId
r -> putStrLn $ "unexpected send message response: " <> show r r -> putStrLn $ "unexpected send message response: " <> show r

View file

@ -22,8 +22,9 @@ import Control.Monad.Except
import Control.Monad.IO.Unlift import Control.Monad.IO.Unlift
import Control.Monad.Reader import Control.Monad.Reader
import Crypto.Random (ChaChaDRG) import Crypto.Random (ChaChaDRG)
import Data.Aeson (FromJSON (..), ToJSON (..)) import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.:?))
import qualified Data.Aeson as J import qualified Data.Aeson as J
import qualified Data.Aeson.Types as JT
import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.ByteString.Char8 (ByteString) import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Char8 as B
@ -54,16 +55,18 @@ import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, NetworkConfig)
import Simplex.Messaging.Agent.Lock import Simplex.Messaging.Agent.Lock
import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.Protocol
import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation, SQLiteStore, UpMigration) import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation, SQLiteStore, UpMigration)
import Simplex.Messaging.Agent.Store.SQLite.DB (SlowQueryStats (..))
import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile (..))
import qualified Simplex.Messaging.Crypto.File as CF
import Simplex.Messaging.Encoding.String import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfTknStatus) import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfTknStatus)
import Simplex.Messaging.Parsers (dropPrefix, enumJSON, parseAll, parseString, sumTypeJSON) import Simplex.Messaging.Parsers (dropPrefix, enumJSON, parseAll, parseString, sumTypeJSON)
import Simplex.Messaging.Protocol (AProtoServerWithAuth, AProtocolType, CorrId, MsgFlags, NtfServer, ProtoServerWithAuth, ProtocolTypeI, QueueId, SProtocolType, UserProtocol, XFTPServerWithAuth) import Simplex.Messaging.Protocol (AProtoServerWithAuth, AProtocolType, CorrId, MsgFlags, NtfServer, ProtoServerWithAuth, ProtocolTypeI, QueueId, SProtocolType, UserProtocol, XFTPServerWithAuth)
import Simplex.Messaging.TMap (TMap) import Simplex.Messaging.TMap (TMap)
import Simplex.Messaging.Agent.Store.SQLite.DB (SlowQueryStats (..))
import Simplex.Messaging.Transport (simplexMQVersion) import Simplex.Messaging.Transport (simplexMQVersion)
import Simplex.Messaging.Transport.Client (TransportHost) import Simplex.Messaging.Transport.Client (TransportHost)
import Simplex.Messaging.Util (allFinally, catchAllErrors, tryAllErrors) import Simplex.Messaging.Util (allFinally, catchAllErrors, tryAllErrors, (<$$>))
import System.IO (Handle) import System.IO (Handle)
import System.Mem.Weak (Weak) import System.Mem.Weak (Weak)
import UnliftIO.STM import UnliftIO.STM
@ -387,8 +390,8 @@ data ChatCommand
| ForwardFile ChatName FileTransferId | ForwardFile ChatName FileTransferId
| ForwardImage ChatName FileTransferId | ForwardImage ChatName FileTransferId
| SendFileDescription ChatName FilePath | SendFileDescription ChatName FilePath
| ReceiveFile {fileId :: FileTransferId, fileInline :: Maybe Bool, filePath :: Maybe FilePath} | ReceiveFile {fileId :: FileTransferId, storeEncrypted :: Bool, fileInline :: Maybe Bool, filePath :: Maybe FilePath}
| SetFileToReceive FileTransferId | SetFileToReceive {fileId :: FileTransferId, storeEncrypted :: Bool}
| CancelFile FileTransferId | CancelFile FileTransferId
| FileStatus FileTransferId | FileStatus FileTransferId
| ShowProfile -- UserId (not used in UI) | ShowProfile -- UserId (not used in UI)
@ -723,11 +726,24 @@ data UserProfileUpdateSummary = UserProfileUpdateSummary
instance ToJSON UserProfileUpdateSummary where toEncoding = J.genericToEncoding J.defaultOptions instance ToJSON UserProfileUpdateSummary where toEncoding = J.genericToEncoding J.defaultOptions
data ComposedMessage = ComposedMessage data ComposedMessage = ComposedMessage
{ filePath :: Maybe FilePath, { fileSource :: Maybe CryptoFile,
quotedItemId :: Maybe ChatItemId, quotedItemId :: Maybe ChatItemId,
msgContent :: MsgContent msgContent :: MsgContent
} }
deriving (Show, Generic, FromJSON) deriving (Show, Generic)
-- This instance is needed for backward compatibility, can be removed in v6.0
instance FromJSON ComposedMessage where
parseJSON (J.Object v) = do
fileSource <-
(v .:? "fileSource") >>= \case
Nothing -> CF.plain <$$> (v .:? "filePath")
f -> pure f
quotedItemId <- v .:? "quotedItemId"
msgContent <- v .: "msgContent"
pure ComposedMessage {fileSource, quotedItemId, msgContent}
parseJSON invalid =
JT.prependFailure "bad ComposedMessage, " (JT.typeMismatch "Object" invalid)
instance ToJSON ComposedMessage where instance ToJSON ComposedMessage where
toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}

View file

@ -37,6 +37,8 @@ import Simplex.Chat.Protocol
import Simplex.Chat.Types import Simplex.Chat.Types
import Simplex.Chat.Types.Preferences import Simplex.Chat.Types.Preferences
import Simplex.Messaging.Agent.Protocol (AgentMsgId, MsgMeta (..), MsgReceiptStatus (..)) import Simplex.Messaging.Agent.Protocol (AgentMsgId, MsgMeta (..), MsgReceiptStatus (..))
import Simplex.Messaging.Crypto.File (CryptoFile (..))
import qualified Simplex.Messaging.Crypto.File as CF
import Simplex.Messaging.Encoding.String import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (dropPrefix, enumJSON, fromTextField_, parseAll, sumTypeJSON) import Simplex.Messaging.Parsers (dropPrefix, enumJSON, fromTextField_, parseAll, sumTypeJSON)
import Simplex.Messaging.Protocol (MsgBody) import Simplex.Messaging.Protocol (MsgBody)
@ -459,7 +461,7 @@ data CIFile (d :: MsgDirection) = CIFile
{ fileId :: Int64, { fileId :: Int64,
fileName :: String, fileName :: String,
fileSize :: Integer, fileSize :: Integer,
filePath :: Maybe FilePath, -- local file path fileSource :: Maybe CryptoFile, -- local file path with optional key and nonce
fileStatus :: CIFileStatus d, fileStatus :: CIFileStatus d,
fileProtocol :: FileProtocol fileProtocol :: FileProtocol
} }
@ -631,6 +633,14 @@ data CIFileInfo = CIFileInfo
} }
deriving (Show) deriving (Show)
mkCIFileInfo :: MsgDirectionI d => CIFile d -> CIFileInfo
mkCIFileInfo CIFile {fileId, fileStatus, fileSource} =
CIFileInfo
{ fileId,
fileStatus = Just $ AFS msgDirection fileStatus,
filePath = CF.filePath <$> fileSource
}
data CIStatus (d :: MsgDirection) where data CIStatus (d :: MsgDirection) where
CISSndNew :: CIStatus 'MDSnd CISSndNew :: CIStatus 'MDSnd
CISSndSent :: SndCIStatusProgress -> CIStatus 'MDSnd CISSndSent :: SndCIStatusProgress -> CIStatus 'MDSnd

View file

@ -50,7 +50,7 @@ instance FromField AMsgDirection where fromField = fromIntField_ $ fmap fromMsgD
instance ToField MsgDirection where toField = toField . msgDirectionInt instance ToField MsgDirection where toField = toField . msgDirectionInt
fromIntField_ :: (Typeable a) => (Int64 -> Maybe a) -> Field -> Ok a fromIntField_ :: Typeable a => (Int64 -> Maybe a) -> Field -> Ok a
fromIntField_ fromInt = \case fromIntField_ fromInt = \case
f@(Field (SQLInteger i) _) -> f@(Field (SQLInteger i) _) ->
case fromInt i of case fromInt i of

View file

@ -0,0 +1,20 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Chat.Migrations.M20230827_file_encryption where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20230827_file_encryption :: Query
m20230827_file_encryption =
[sql|
ALTER TABLE files ADD COLUMN file_crypto_key BLOB;
ALTER TABLE files ADD COLUMN file_crypto_nonce BLOB;
|]
down_m20230827_file_encryption :: Query
down_m20230827_file_encryption =
[sql|
ALTER TABLE files DROP COLUMN file_crypto_key;
ALTER TABLE files DROP COLUMN file_crypto_nonce;
|]

View file

@ -204,7 +204,9 @@ CREATE TABLE files(
agent_snd_file_id BLOB NULL, agent_snd_file_id BLOB NULL,
private_snd_file_descr TEXT NULL, private_snd_file_descr TEXT NULL,
agent_snd_file_deleted INTEGER DEFAULT 0 CHECK(agent_snd_file_deleted NOT NULL), agent_snd_file_deleted INTEGER DEFAULT 0 CHECK(agent_snd_file_deleted NOT NULL),
protocol TEXT NOT NULL DEFAULT 'smp' protocol TEXT NOT NULL DEFAULT 'smp',
file_crypto_key BLOB,
file_crypto_nonce BLOB
); );
CREATE TABLE snd_files( CREATE TABLE snd_files(
file_id INTEGER NOT NULL REFERENCES files ON DELETE CASCADE, file_id INTEGER NOT NULL REFERENCES files ON DELETE CASCADE,

View file

@ -35,6 +35,8 @@ import GHC.Generics (Generic)
import Simplex.Chat import Simplex.Chat
import Simplex.Chat.Controller import Simplex.Chat.Controller
import Simplex.Chat.Markdown (ParsedMarkdown (..), parseMaybeMarkdownList) import Simplex.Chat.Markdown (ParsedMarkdown (..), parseMaybeMarkdownList)
import Simplex.Chat.Mobile.File
import Simplex.Chat.Mobile.Shared
import Simplex.Chat.Mobile.WebRTC import Simplex.Chat.Mobile.WebRTC
import Simplex.Chat.Options import Simplex.Chat.Options
import Simplex.Chat.Store import Simplex.Chat.Store
@ -69,6 +71,10 @@ foreign export ccall "chat_encrypt_media" cChatEncryptMedia :: CString -> Ptr Wo
foreign export ccall "chat_decrypt_media" cChatDecryptMedia :: CString -> Ptr Word8 -> CInt -> IO CString foreign export ccall "chat_decrypt_media" cChatDecryptMedia :: CString -> Ptr Word8 -> CInt -> IO CString
foreign export ccall "chat_write_file" cChatWriteFile :: CString -> Ptr Word8 -> CInt -> IO CJSONString
foreign export ccall "chat_read_file" cChatReadFile :: CString -> CString -> CString -> IO (Ptr Word8)
-- | check / migrate database and initialize chat controller on success -- | check / migrate database and initialize chat controller on success
cChatMigrateInit :: CString -> CString -> CString -> Ptr (StablePtr ChatController) -> IO CJSONString cChatMigrateInit :: CString -> CString -> CString -> Ptr (StablePtr ChatController) -> IO CJSONString
cChatMigrateInit fp key conf ctrl = do cChatMigrateInit fp key conf ctrl = do
@ -151,8 +157,6 @@ defaultMobileConfig =
logLevel = CLLError logLevel = CLLError
} }
type CJSONString = CString
getActiveUser_ :: SQLiteStore -> IO (Maybe User) getActiveUser_ :: SQLiteStore -> IO (Maybe User)
getActiveUser_ st = find activeUser <$> withTransaction st getUsers getActiveUser_ st = find activeUser <$> withTransaction st getUsers

View file

@ -0,0 +1,83 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module Simplex.Chat.Mobile.File
( cChatWriteFile,
cChatReadFile,
WriteFileResult (..),
ReadFileResult (..),
chatWriteFile,
chatReadFile,
)
where
import Control.Monad.Except
import Data.Aeson (ToJSON)
import qualified Data.Aeson as J
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as LB
import qualified Data.ByteString.Lazy.Char8 as LB'
import Data.Int (Int64)
import Data.Word (Word8)
import Foreign.C
import Foreign.Marshal.Alloc (mallocBytes)
import Foreign.Ptr
import GHC.Generics (Generic)
import Simplex.Chat.Mobile.Shared
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
import qualified Simplex.Messaging.Crypto.File as CF
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
data WriteFileResult
= WFResult {cryptoArgs :: CryptoFileArgs}
| WFError {writeError :: String}
deriving (Generic)
instance ToJSON WriteFileResult where toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "WF"
cChatWriteFile :: CString -> Ptr Word8 -> CInt -> IO CJSONString
cChatWriteFile cPath ptr len = do
path <- peekCAString cPath
s <- getByteString ptr len
r <- chatWriteFile path s
newCAString $ LB'.unpack $ J.encode r
chatWriteFile :: FilePath -> ByteString -> IO WriteFileResult
chatWriteFile path s = do
cfArgs <- CF.randomArgs
let file = CryptoFile path $ Just cfArgs
either (WFError . show) (\_ -> WFResult cfArgs)
<$> runExceptT (CF.writeFile file $ LB.fromStrict s)
data ReadFileResult
= RFResult {fileSize :: Int64}
| RFError {readError :: String}
deriving (Generic)
instance ToJSON ReadFileResult where toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "RF"
cChatReadFile :: CString -> CString -> CString -> IO (Ptr Word8)
cChatReadFile cPath cKey cNonce = do
path <- peekCAString cPath
key <- B.packCString cKey
nonce <- B.packCString cNonce
(r, s) <- chatReadFile path key nonce
let r' = LB.toStrict (J.encode r) <> "\NUL"
ptr <- mallocBytes $ B.length r' + B.length s
putByteString ptr r'
unless (B.null s) $ putByteString (ptr `plusPtr` B.length r') s
pure ptr
chatReadFile :: FilePath -> ByteString -> ByteString -> IO (ReadFileResult, ByteString)
chatReadFile path keyStr nonceStr = do
either ((,"") . RFError) (\s -> (RFResult $ LB.length s, LB.toStrict s)) <$> runExceptT readFile_
where
readFile_ :: ExceptT String IO LB.ByteString
readFile_ = do
key <- liftEither $ strDecode keyStr
nonce <- liftEither $ strDecode nonceStr
let file = CryptoFile path $ Just $ CFArgs key nonce
withExceptT show $ CF.readFile file

View file

@ -0,0 +1,19 @@
module Simplex.Chat.Mobile.Shared where
import qualified Data.ByteString as B
import Data.ByteString.Internal (ByteString (PS), memcpy)
import Foreign.C (CInt, CString)
import Foreign (Ptr, Word8, newForeignPtr_, plusPtr)
import Foreign.ForeignPtr.Unsafe
type CJSONString = CString
getByteString :: Ptr Word8 -> CInt -> IO ByteString
getByteString ptr len = do
fp <- newForeignPtr_ ptr
pure $ PS fp 0 $ fromIntegral len
putByteString :: Ptr Word8 -> ByteString -> IO ()
putByteString ptr bs@(PS fp offset _) = do
let p = unsafeForeignPtrToPtr fp `plusPtr` offset
memcpy ptr p $ B.length bs

View file

@ -12,16 +12,15 @@ import Control.Monad.Except
import qualified Crypto.Cipher.Types as AES import qualified Crypto.Cipher.Types as AES
import Data.Bifunctor (bimap) import Data.Bifunctor (bimap)
import qualified Data.ByteArray as BA import qualified Data.ByteArray as BA
import Data.ByteString (ByteString)
import qualified Data.ByteString as B import qualified Data.ByteString as B
import qualified Data.ByteString.Base64.URL as U import qualified Data.ByteString.Base64.URL as U
import Data.ByteString.Internal (ByteString (PS), memcpy)
import Data.Either (fromLeft) import Data.Either (fromLeft)
import Data.Word (Word8) import Data.Word (Word8)
import Foreign.C (CInt, CString, newCAString) import Foreign.C (CInt, CString, newCAString)
import Foreign.ForeignPtr (newForeignPtr_) import Foreign.Ptr (Ptr)
import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
import Foreign.Ptr (Ptr, plusPtr)
import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto as C
import Simplex.Chat.Mobile.Shared
cChatEncryptMedia :: CString -> Ptr Word8 -> CInt -> IO CString cChatEncryptMedia :: CString -> Ptr Word8 -> CInt -> IO CString
cChatEncryptMedia = cTransformMedia chatEncryptMedia cChatEncryptMedia = cTransformMedia chatEncryptMedia
@ -32,16 +31,10 @@ cChatDecryptMedia = cTransformMedia chatDecryptMedia
cTransformMedia :: (ByteString -> ByteString -> ExceptT String IO ByteString) -> CString -> Ptr Word8 -> CInt -> IO CString cTransformMedia :: (ByteString -> ByteString -> ExceptT String IO ByteString) -> CString -> Ptr Word8 -> CInt -> IO CString
cTransformMedia f cKey cFrame cFrameLen = do cTransformMedia f cKey cFrame cFrameLen = do
key <- B.packCString cKey key <- B.packCString cKey
frame <- getFrame frame <- getByteString cFrame cFrameLen
runExceptT (f key frame >>= liftIO . putFrame) >>= newCAString . fromLeft "" runExceptT (f key frame >>= liftIO . putFrame) >>= newCAString . fromLeft ""
where where
getFrame = do putFrame s = when (B.length s < fromIntegral cFrameLen) $ putByteString cFrame s
fp <- newForeignPtr_ cFrame
pure $ PS fp 0 $ fromIntegral cFrameLen
putFrame bs@(PS fp offset _) = do
let len = B.length bs
p = unsafeForeignPtrToPtr fp `plusPtr` offset
when (len <= fromIntegral cFrameLen) $ memcpy cFrame p len
{-# INLINE cTransformMedia #-} {-# INLINE cTransformMedia #-}
chatEncryptMedia :: ByteString -> ByteString -> ExceptT String IO ByteString chatEncryptMedia :: ByteString -> ByteString -> ExceptT String IO ByteString

View file

@ -56,6 +56,7 @@ module Simplex.Chat.Store.Files
startRcvInlineFT, startRcvInlineFT,
xftpAcceptRcvFT, xftpAcceptRcvFT,
setRcvFileToReceive, setRcvFileToReceive,
setFileCryptoArgs,
getRcvFilesToReceive, getRcvFilesToReceive,
setRcvFTAgentDeleted, setRcvFTAgentDeleted,
updateRcvFileStatus, updateRcvFileStatus,
@ -84,18 +85,21 @@ import Data.Time.Clock (UTCTime (..), getCurrentTime, nominalDay)
import Data.Type.Equality import Data.Type.Equality
import Database.SQLite.Simple (Only (..), (:.) (..)) import Database.SQLite.Simple (Only (..), (:.) (..))
import Database.SQLite.Simple.QQ (sql) import Database.SQLite.Simple.QQ (sql)
import Simplex.Chat.Messages
import Simplex.Chat.Messages.CIContent
import Simplex.Chat.Protocol
import Simplex.Chat.Store.Direct import Simplex.Chat.Store.Direct
import Simplex.Chat.Store.Messages import Simplex.Chat.Store.Messages
import Simplex.Chat.Store.Profiles import Simplex.Chat.Store.Profiles
import Simplex.Chat.Store.Shared import Simplex.Chat.Store.Shared
import Simplex.Chat.Messages
import Simplex.Chat.Messages.CIContent
import Simplex.Chat.Protocol
import Simplex.Chat.Types import Simplex.Chat.Types
import Simplex.Chat.Util (week) import Simplex.Chat.Util (week)
import Simplex.Messaging.Agent.Protocol (AgentMsgId, ConnId, UserId) import Simplex.Messaging.Agent.Protocol (AgentMsgId, ConnId, UserId)
import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow) import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow)
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
import qualified Simplex.Messaging.Crypto.File as CF
getLiveSndFileTransfers :: DB.Connection -> User -> IO [SndFileTransfer] getLiveSndFileTransfers :: DB.Connection -> User -> IO [SndFileTransfer]
getLiveSndFileTransfers db User {userId} = do getLiveSndFileTransfers db User {userId} = do
@ -257,14 +261,14 @@ getSndFTViaMsgDelivery db User {userId} Connection {connId, agentConnId} agentMs
(\n -> SndFileTransfer {fileId, fileStatus, fileName, fileSize, chunkSize, filePath, fileDescrId, fileInline, groupMemberId, recipientDisplayName = n, connId, agentConnId}) (\n -> SndFileTransfer {fileId, fileStatus, fileName, fileSize, chunkSize, filePath, fileDescrId, fileInline, groupMemberId, recipientDisplayName = n, connId, agentConnId})
<$> (contactName_ <|> memberName_) <$> (contactName_ <|> memberName_)
createSndFileTransferXFTP :: DB.Connection -> User -> ContactOrGroup -> FilePath -> FileInvitation -> AgentSndFileId -> Integer -> IO FileTransferMeta createSndFileTransferXFTP :: DB.Connection -> User -> ContactOrGroup -> CryptoFile -> FileInvitation -> AgentSndFileId -> Integer -> IO FileTransferMeta
createSndFileTransferXFTP db User {userId} contactOrGroup filePath FileInvitation {fileName, fileSize} agentSndFileId chunkSize = do createSndFileTransferXFTP db User {userId} contactOrGroup (CryptoFile filePath cryptoArgs) FileInvitation {fileName, fileSize} agentSndFileId chunkSize = do
currentTs <- getCurrentTime currentTs <- getCurrentTime
let xftpSndFile = Just XFTPSndFile {agentSndFileId, privateSndFileDescr = Nothing, agentSndFileDeleted = False} let xftpSndFile = Just XFTPSndFile {agentSndFileId, privateSndFileDescr = Nothing, agentSndFileDeleted = False, cryptoArgs}
DB.execute DB.execute
db db
"INSERT INTO files (contact_id, group_id, user_id, file_name, file_path, file_size, chunk_size, agent_snd_file_id, ci_file_status, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?,?)" "INSERT INTO files (contact_id, group_id, user_id, file_name, file_path, file_crypto_key, file_crypto_nonce, file_size, chunk_size, agent_snd_file_id, ci_file_status, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?)"
(contactAndGroupIds contactOrGroup :. (userId, fileName, filePath, fileSize, chunkSize, agentSndFileId, CIFSSndStored, FPXFTP, currentTs, currentTs)) (contactAndGroupIds contactOrGroup :. (userId, fileName, filePath, CF.fileKey <$> cryptoArgs, CF.fileNonce <$> cryptoArgs, fileSize, chunkSize, agentSndFileId, CIFSSndStored, FPXFTP, currentTs, currentTs))
fileId <- insertedRowId db fileId <- insertedRowId db
pure FileTransferMeta {fileId, xftpSndFile, fileName, filePath, fileSize, fileInline = Nothing, chunkSize, cancelled = False} pure FileTransferMeta {fileId, xftpSndFile, fileName, filePath, fileSize, fileInline = Nothing, chunkSize, cancelled = False}
@ -479,7 +483,8 @@ createRcvFileTransfer db userId Contact {contactId, localDisplayName = c} f@File
currentTs <- liftIO getCurrentTime currentTs <- liftIO getCurrentTime
rfd_ <- mapM (createRcvFD_ db userId currentTs) fileDescr rfd_ <- mapM (createRcvFD_ db userId currentTs) fileDescr
let rfdId = (fileDescrId :: RcvFileDescr -> Int64) <$> rfd_ let rfdId = (fileDescrId :: RcvFileDescr -> Int64) <$> rfd_
xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId = Nothing, agentRcvFileDeleted = False}) <$> 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_
fileProtocol = if isJust rfd_ then FPXFTP else FPSMP fileProtocol = if isJust rfd_ then FPXFTP else FPSMP
fileId <- liftIO $ do fileId <- liftIO $ do
DB.execute DB.execute
@ -499,7 +504,8 @@ createRcvGroupFileTransfer db userId GroupMember {groupId, groupMemberId, localD
currentTs <- liftIO getCurrentTime currentTs <- liftIO getCurrentTime
rfd_ <- mapM (createRcvFD_ db userId currentTs) fileDescr rfd_ <- mapM (createRcvFD_ db userId currentTs) fileDescr
let rfdId = (fileDescrId :: RcvFileDescr -> Int64) <$> rfd_ let rfdId = (fileDescrId :: RcvFileDescr -> Int64) <$> rfd_
xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId = Nothing, agentRcvFileDeleted = False}) <$> 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_
fileProtocol = if isJust rfd_ then FPXFTP else FPSMP fileProtocol = if isJust rfd_ then FPXFTP else FPSMP
fileId <- liftIO $ do fileId <- liftIO $ do
DB.execute DB.execute
@ -600,7 +606,7 @@ getRcvFileTransfer db User {userId} fileId = do
[sql| [sql|
SELECT r.file_status, r.file_queue_info, r.group_member_id, f.file_name, SELECT r.file_status, r.file_queue_info, r.group_member_id, f.file_name,
f.file_size, f.chunk_size, f.cancelled, cs.local_display_name, m.local_display_name, f.file_size, f.chunk_size, f.cancelled, cs.local_display_name, m.local_display_name,
f.file_path, r.file_inline, r.rcv_file_inline, r.agent_rcv_file_id, r.agent_rcv_file_deleted, c.connection_id, c.agent_conn_id f.file_path, f.file_crypto_key, f.file_crypto_nonce, r.file_inline, r.rcv_file_inline, r.agent_rcv_file_id, r.agent_rcv_file_deleted, c.connection_id, c.agent_conn_id
FROM rcv_files r FROM rcv_files r
JOIN files f USING (file_id) JOIN files f USING (file_id)
LEFT JOIN connections c ON r.file_id = c.rcv_file_id LEFT JOIN connections c ON r.file_id = c.rcv_file_id
@ -614,9 +620,9 @@ getRcvFileTransfer db User {userId} fileId = do
where where
rcvFileTransfer :: rcvFileTransfer ::
Maybe RcvFileDescr -> Maybe RcvFileDescr ->
(FileStatus, Maybe ConnReqInvitation, Maybe Int64, String, Integer, Integer, Maybe Bool) :. (Maybe ContactName, Maybe ContactName, Maybe FilePath, Maybe InlineFileMode, Maybe InlineFileMode, Maybe AgentRcvFileId, Bool) :. (Maybe Int64, Maybe AgentConnId) -> (FileStatus, Maybe ConnReqInvitation, Maybe Int64, String, Integer, Integer, Maybe Bool) :. (Maybe ContactName, Maybe ContactName, Maybe FilePath, Maybe C.SbKey, Maybe C.CbNonce, Maybe InlineFileMode, Maybe InlineFileMode, Maybe AgentRcvFileId, Bool) :. (Maybe Int64, Maybe AgentConnId) ->
ExceptT StoreError IO RcvFileTransfer ExceptT StoreError IO RcvFileTransfer
rcvFileTransfer rfd_ ((fileStatus', fileConnReq, grpMemberId, fileName, fileSize, chunkSize, cancelled_) :. (contactName_, memberName_, filePath_, fileInline, rcvFileInline, agentRcvFileId, agentRcvFileDeleted) :. (connId_, agentConnId_)) = rcvFileTransfer rfd_ ((fileStatus', fileConnReq, grpMemberId, fileName, fileSize, chunkSize, cancelled_) :. (contactName_, memberName_, filePath_, fileKey, fileNonce, fileInline, rcvFileInline, agentRcvFileId, agentRcvFileDeleted) :. (connId_, agentConnId_)) =
case contactName_ <|> memberName_ of case contactName_ <|> memberName_ of
Nothing -> throwError $ SERcvFileInvalid fileId Nothing -> throwError $ SERcvFileInvalid fileId
Just name -> do Just name -> do
@ -629,7 +635,8 @@ getRcvFileTransfer db User {userId} fileId = do
where where
ft senderDisplayName fileStatus = ft senderDisplayName fileStatus =
let fileInvitation = FileInvitation {fileName, fileSize, fileDigest = Nothing, fileConnReq, fileInline, fileDescr = Nothing} let fileInvitation = FileInvitation {fileName, fileSize, fileDigest = Nothing, fileConnReq, fileInline, fileDescr = Nothing}
xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId, agentRcvFileDeleted}) <$> rfd_ cryptoArgs = CFArgs <$> fileKey <*> fileNonce
xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId, agentRcvFileDeleted, cryptoArgs}) <$> rfd_
in RcvFileTransfer {fileId, xftpRcvFile, fileInvitation, fileStatus, rcvFileInline, senderDisplayName, chunkSize, cancelled, grpMemberId} in RcvFileTransfer {fileId, xftpRcvFile, fileInvitation, fileStatus, rcvFileInline, senderDisplayName, chunkSize, cancelled, grpMemberId}
rfi = maybe (throwError $ SERcvFileInvalid fileId) pure =<< rfi_ rfi = maybe (throwError $ SERcvFileInvalid fileId) pure =<< rfi_
rfi_ = case (filePath_, connId_, agentConnId_) of rfi_ = case (filePath_, connId_, agentConnId_) of
@ -683,13 +690,21 @@ acceptRcvFT_ db User {userId} fileId filePath rcvFileInline currentTs = do
"UPDATE rcv_files SET rcv_file_inline = ?, file_status = ?, updated_at = ? WHERE file_id = ?" "UPDATE rcv_files SET rcv_file_inline = ?, file_status = ?, updated_at = ? WHERE file_id = ?"
(rcvFileInline, FSAccepted, currentTs, fileId) (rcvFileInline, FSAccepted, currentTs, fileId)
setRcvFileToReceive :: DB.Connection -> FileTransferId -> IO () setRcvFileToReceive :: DB.Connection -> FileTransferId -> Maybe CryptoFileArgs -> IO ()
setRcvFileToReceive db fileId = do setRcvFileToReceive db fileId cfArgs_ = do
currentTs <- getCurrentTime currentTs <- getCurrentTime
DB.execute db "UPDATE rcv_files SET to_receive = 1, updated_at = ? WHERE file_id = ?" (currentTs, fileId)
forM_ cfArgs_ $ \cfArgs -> setFileCryptoArgs_ db fileId cfArgs currentTs
setFileCryptoArgs :: DB.Connection -> FileTransferId -> CryptoFileArgs -> IO ()
setFileCryptoArgs db fileId cfArgs = setFileCryptoArgs_ db fileId cfArgs =<< getCurrentTime
setFileCryptoArgs_ :: DB.Connection -> FileTransferId -> CryptoFileArgs -> UTCTime -> IO ()
setFileCryptoArgs_ db fileId (CFArgs key nonce) currentTs =
DB.execute DB.execute
db db
"UPDATE rcv_files SET to_receive = 1, updated_at = ? WHERE file_id = ?" "UPDATE files SET file_crypto_key = ?, file_crypto_nonce = ?, updated_at = ? WHERE file_id = ?"
(currentTs, fileId) (key, nonce, currentTs, fileId)
getRcvFilesToReceive :: DB.Connection -> User -> IO [RcvFileTransfer] getRcvFilesToReceive :: DB.Connection -> User -> IO [RcvFileTransfer]
getRcvFilesToReceive db user@User {userId} = do getRcvFilesToReceive db user@User {userId} = do
@ -842,15 +857,16 @@ getFileTransferMeta db User {userId} fileId =
DB.query DB.query
db db
[sql| [sql|
SELECT file_name, file_size, chunk_size, file_path, file_inline, agent_snd_file_id, agent_snd_file_deleted, private_snd_file_descr, cancelled SELECT file_name, file_size, chunk_size, file_path, file_crypto_key, file_crypto_nonce, file_inline, agent_snd_file_id, agent_snd_file_deleted, private_snd_file_descr, cancelled
FROM files FROM files
WHERE user_id = ? AND file_id = ? WHERE user_id = ? AND file_id = ?
|] |]
(userId, fileId) (userId, fileId)
where where
fileTransferMeta :: (String, Integer, Integer, FilePath, Maybe InlineFileMode, Maybe AgentSndFileId, Bool, Maybe Text, Maybe Bool) -> FileTransferMeta fileTransferMeta :: (String, Integer, Integer, FilePath, Maybe C.SbKey, Maybe C.CbNonce, Maybe InlineFileMode, Maybe AgentSndFileId, Bool, Maybe Text, Maybe Bool) -> FileTransferMeta
fileTransferMeta (fileName, fileSize, chunkSize, filePath, fileInline, aSndFileId_, agentSndFileDeleted, privateSndFileDescr, cancelled_) = fileTransferMeta (fileName, fileSize, chunkSize, filePath, fileKey, fileNonce, fileInline, aSndFileId_, agentSndFileDeleted, privateSndFileDescr, cancelled_) =
let xftpSndFile = (\fId -> XFTPSndFile {agentSndFileId = fId, privateSndFileDescr, agentSndFileDeleted}) <$> aSndFileId_ let cryptoArgs = CFArgs <$> fileKey <*> fileNonce
xftpSndFile = (\fId -> XFTPSndFile {agentSndFileId = fId, privateSndFileDescr, agentSndFileDeleted, cryptoArgs}) <$> aSndFileId_
in FileTransferMeta {fileId, xftpSndFile, fileName, fileSize, chunkSize, filePath, fileInline, cancelled = fromMaybe False cancelled_} in FileTransferMeta {fileId, xftpSndFile, fileName, fileSize, chunkSize, filePath, fileInline, cancelled = fromMaybe False cancelled_}
getContactFileInfo :: DB.Connection -> User -> Contact -> IO [CIFileInfo] getContactFileInfo :: DB.Connection -> User -> Contact -> IO [CIFileInfo]

View file

@ -13,7 +13,6 @@
module Simplex.Chat.Store.Messages module Simplex.Chat.Store.Messages
( getContactConnIds_, ( getContactConnIds_,
getDirectChatReactions_, getDirectChatReactions_,
toDirectChatItem,
-- * Message and chat item functions -- * Message and chat item functions
deleteContactCIs, deleteContactCIs,
@ -122,6 +121,8 @@ import Simplex.Chat.Types
import Simplex.Messaging.Agent.Protocol (AgentMsgId, ConnId, MsgMeta (..), UserId) import Simplex.Messaging.Agent.Protocol (AgentMsgId, ConnId, MsgMeta (..), UserId)
import Simplex.Messaging.Agent.Store.SQLite (firstRow, firstRow', maybeFirstRow) import Simplex.Messaging.Agent.Store.SQLite (firstRow, firstRow', maybeFirstRow)
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
import Simplex.Messaging.Util (eitherToMaybe) import Simplex.Messaging.Util (eitherToMaybe)
import UnliftIO.STM import UnliftIO.STM
@ -483,7 +484,7 @@ getDirectChatPreviews_ db user@User {userId} = do
-- ChatItem -- ChatItem
i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live,
-- CIFile -- CIFile
f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, f.protocol, f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol,
-- DirectQuote -- DirectQuote
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent
FROM contacts ct FROM contacts ct
@ -548,7 +549,7 @@ getGroupChatPreviews_ db User {userId, userContactId} = do
-- ChatItem -- ChatItem
i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live,
-- CIFile -- CIFile
f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, f.protocol, f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol,
-- Maybe GroupMember - sender -- Maybe GroupMember - sender
m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category,
m.member_status, m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, m.member_status, m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id,
@ -669,7 +670,7 @@ getDirectChatItemsLast db User {userId} contactId count search = ExceptT $ do
-- ChatItem -- ChatItem
i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live,
-- CIFile -- CIFile
f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, f.protocol, f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol,
-- DirectQuote -- DirectQuote
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent
FROM chat_items i FROM chat_items i
@ -698,7 +699,7 @@ getDirectChatAfter_ db User {userId} ct@Contact {contactId} afterChatItemId coun
-- ChatItem -- ChatItem
i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live,
-- CIFile -- CIFile
f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, f.protocol, f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol,
-- DirectQuote -- DirectQuote
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent
FROM chat_items i FROM chat_items i
@ -728,7 +729,7 @@ getDirectChatBefore_ db User {userId} ct@Contact {contactId} beforeChatItemId co
-- ChatItem -- ChatItem
i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live,
-- CIFile -- CIFile
f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, f.protocol, f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol,
-- DirectQuote -- DirectQuote
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent
FROM chat_items i FROM chat_items i
@ -950,7 +951,7 @@ type ChatStatsRow = (Int, ChatItemId, Bool)
toChatStats :: ChatStatsRow -> ChatStats toChatStats :: ChatStatsRow -> ChatStats
toChatStats (unreadCount, minUnreadItemId, unreadChat) = ChatStats {unreadCount, minUnreadItemId, unreadChat} toChatStats (unreadCount, minUnreadItemId, unreadChat) = ChatStats {unreadCount, minUnreadItemId, unreadChat}
type MaybeCIFIleRow = (Maybe Int64, Maybe String, Maybe Integer, Maybe FilePath, Maybe ACIFileStatus, Maybe FileProtocol) type MaybeCIFIleRow = (Maybe Int64, Maybe String, Maybe Integer, Maybe FilePath, Maybe C.SbKey, Maybe C.CbNonce, Maybe ACIFileStatus, Maybe FileProtocol)
type ChatItemModeRow = (Maybe Int, Maybe UTCTime, Maybe Bool) type ChatItemModeRow = (Maybe Int, Maybe UTCTime, Maybe Bool)
@ -971,7 +972,7 @@ toQuote (quotedItemId, quotedSharedMsgId, quotedSentAt, quotedMsgContent, _) dir
-- this function can be changed so it never fails, not only avoid failure on invalid json -- this function can be changed so it never fails, not only avoid failure on invalid json
toDirectChatItem :: UTCTime -> ChatItemRow :. QuoteRow -> Either StoreError (CChatItem 'CTDirect) toDirectChatItem :: UTCTime -> ChatItemRow :. QuoteRow -> Either StoreError (CChatItem 'CTDirect)
toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. (fileId_, fileName_, fileSize_, filePath, fileStatus_, fileProtocol_)) :. quoteRow) = toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) :. quoteRow) =
chatItem $ fromRight invalid $ dbParseACIContent itemContentText chatItem $ fromRight invalid $ dbParseACIContent itemContentText
where where
invalid = ACIContent msgDir $ CIInvalidJSON itemContentText invalid = ACIContent msgDir $ CIInvalidJSON itemContentText
@ -988,7 +989,10 @@ toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentT
maybeCIFile :: CIFileStatus d -> Maybe (CIFile d) maybeCIFile :: CIFileStatus d -> Maybe (CIFile d)
maybeCIFile fileStatus = maybeCIFile fileStatus =
case (fileId_, fileName_, fileSize_, fileProtocol_) of case (fileId_, fileName_, fileSize_, fileProtocol_) of
(Just fileId, Just fileName, Just fileSize, Just fileProtocol) -> Just CIFile {fileId, fileName, fileSize, filePath, fileStatus, fileProtocol} (Just fileId, Just fileName, Just fileSize, Just fileProtocol) ->
let cfArgs = CFArgs <$> fileKey <*> fileNonce
fileSource = (`CryptoFile` cfArgs) <$> filePath
in Just CIFile {fileId, fileName, fileSize, fileSource, fileStatus, fileProtocol}
_ -> Nothing _ -> Nothing
cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTDirect d -> CIStatus d -> CIContent d -> Maybe (CIFile d) -> CChatItem 'CTDirect cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTDirect d -> CIStatus d -> CIContent d -> Maybe (CIFile d) -> CChatItem 'CTDirect
cItem d chatDir ciStatus content file = cItem d chatDir ciStatus content file =
@ -1021,7 +1025,7 @@ toGroupQuote qr@(_, _, _, _, quotedSent) quotedMember_ = toQuote qr $ direction
-- this function can be changed so it never fails, not only avoid failure on invalid json -- this function can be changed so it never fails, not only avoid failure on invalid json
toGroupChatItem :: UTCTime -> Int64 -> ChatItemRow :. MaybeGroupMemberRow :. GroupQuoteRow :. MaybeGroupMemberRow -> Either StoreError (CChatItem 'CTGroup) toGroupChatItem :: UTCTime -> Int64 -> ChatItemRow :. MaybeGroupMemberRow :. GroupQuoteRow :. MaybeGroupMemberRow -> Either StoreError (CChatItem 'CTGroup)
toGroupChatItem currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. (fileId_, fileName_, fileSize_, filePath, fileStatus_, fileProtocol_)) :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_) = do toGroupChatItem currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_) = do
chatItem $ fromRight invalid $ dbParseACIContent itemContentText chatItem $ fromRight invalid $ dbParseACIContent itemContentText
where where
member_ = toMaybeGroupMember userContactId memberRow_ member_ = toMaybeGroupMember userContactId memberRow_
@ -1041,7 +1045,10 @@ toGroupChatItem currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir,
maybeCIFile :: CIFileStatus d -> Maybe (CIFile d) maybeCIFile :: CIFileStatus d -> Maybe (CIFile d)
maybeCIFile fileStatus = maybeCIFile fileStatus =
case (fileId_, fileName_, fileSize_, fileProtocol_) of case (fileId_, fileName_, fileSize_, fileProtocol_) of
(Just fileId, Just fileName, Just fileSize, Just fileProtocol) -> Just CIFile {fileId, fileName, fileSize, filePath, fileStatus, fileProtocol} (Just fileId, Just fileName, Just fileSize, Just fileProtocol) ->
let cfArgs = CFArgs <$> fileKey <*> fileNonce
fileSource = (`CryptoFile` cfArgs) <$> filePath
in Just CIFile {fileId, fileName, fileSize, fileSource, fileStatus, fileProtocol}
_ -> Nothing _ -> Nothing
cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTGroup d -> CIStatus d -> CIContent d -> Maybe (CIFile d) -> CChatItem 'CTGroup cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTGroup d -> CIStatus d -> CIContent d -> Maybe (CIFile d) -> CChatItem 'CTGroup
cItem d chatDir ciStatus content file = cItem d chatDir ciStatus content file =
@ -1141,7 +1148,7 @@ updateDirectChatItemStatus db user@User {userId} contactId itemId itemStatus = d
correctDir :: CChatItem c -> Either StoreError (ChatItem c d) correctDir :: CChatItem c -> Either StoreError (ChatItem c d)
correctDir (CChatItem _ ci) = first SEInternalError $ checkDirection ci correctDir (CChatItem _ ci) = first SEInternalError $ checkDirection ci
updateDirectChatItem :: forall d. (MsgDirectionI d) => DB.Connection -> User -> Int64 -> ChatItemId -> CIContent d -> Bool -> Maybe MessageId -> ExceptT StoreError IO (ChatItem 'CTDirect d) updateDirectChatItem :: forall d. MsgDirectionI d => DB.Connection -> User -> Int64 -> ChatItemId -> CIContent d -> Bool -> Maybe MessageId -> ExceptT StoreError IO (ChatItem 'CTDirect d)
updateDirectChatItem db user contactId itemId newContent live msgId_ = do updateDirectChatItem db user contactId itemId newContent live msgId_ = do
ci <- liftEither . correctDir =<< getDirectChatItem db user contactId itemId ci <- liftEither . correctDir =<< getDirectChatItem db user contactId itemId
liftIO $ updateDirectChatItem' db user contactId ci newContent live msgId_ liftIO $ updateDirectChatItem' db user contactId ci newContent live msgId_
@ -1149,7 +1156,7 @@ updateDirectChatItem db user contactId itemId newContent live msgId_ = do
correctDir :: CChatItem c -> Either StoreError (ChatItem c d) correctDir :: CChatItem c -> Either StoreError (ChatItem c d)
correctDir (CChatItem _ ci) = first SEInternalError $ checkDirection ci correctDir (CChatItem _ ci) = first SEInternalError $ checkDirection ci
updateDirectChatItem' :: forall d. (MsgDirectionI d) => DB.Connection -> User -> Int64 -> ChatItem 'CTDirect d -> CIContent d -> Bool -> Maybe MessageId -> IO (ChatItem 'CTDirect d) updateDirectChatItem' :: forall d. MsgDirectionI d => DB.Connection -> User -> Int64 -> ChatItem 'CTDirect d -> CIContent d -> Bool -> Maybe MessageId -> IO (ChatItem 'CTDirect d)
updateDirectChatItem' db User {userId} contactId ci newContent live msgId_ = do updateDirectChatItem' db User {userId} contactId ci newContent live msgId_ = do
currentTs <- liftIO getCurrentTime currentTs <- liftIO getCurrentTime
let ci' = updatedChatItem ci newContent live currentTs let ci' = updatedChatItem ci newContent live currentTs
@ -1294,7 +1301,7 @@ getDirectChatItem db User {userId} contactId itemId = ExceptT $ do
-- ChatItem -- ChatItem
i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live,
-- CIFile -- CIFile
f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, f.protocol, f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol,
-- DirectQuote -- DirectQuote
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent
FROM chat_items i FROM chat_items i
@ -1469,7 +1476,7 @@ getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do
-- ChatItem -- ChatItem
i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live,
-- CIFile -- CIFile
f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, f.protocol, f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol,
-- GroupMember -- GroupMember
m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category,
m.member_status, m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, m.member_status, m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id,

View file

@ -76,6 +76,7 @@ import Simplex.Chat.Migrations.M20230621_chat_item_moderations
import Simplex.Chat.Migrations.M20230705_delivery_receipts import Simplex.Chat.Migrations.M20230705_delivery_receipts
import Simplex.Chat.Migrations.M20230721_group_snd_item_statuses import Simplex.Chat.Migrations.M20230721_group_snd_item_statuses
import Simplex.Chat.Migrations.M20230814_indexes import Simplex.Chat.Migrations.M20230814_indexes
import Simplex.Chat.Migrations.M20230827_file_encryption
import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..)) import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..))
schemaMigrations :: [(String, Query, Maybe Query)] schemaMigrations :: [(String, Query, Maybe Query)]
@ -151,7 +152,8 @@ schemaMigrations =
("20230621_chat_item_moderations", m20230621_chat_item_moderations, Just down_m20230621_chat_item_moderations), ("20230621_chat_item_moderations", m20230621_chat_item_moderations, Just down_m20230621_chat_item_moderations),
("20230705_delivery_receipts", m20230705_delivery_receipts, Just down_m20230705_delivery_receipts), ("20230705_delivery_receipts", m20230705_delivery_receipts, Just down_m20230705_delivery_receipts),
("20230721_group_snd_item_statuses", m20230721_group_snd_item_statuses, Just down_m20230721_group_snd_item_statuses), ("20230721_group_snd_item_statuses", m20230721_group_snd_item_statuses, Just down_m20230721_group_snd_item_statuses),
("20230814_indexes", m20230814_indexes, Just down_m20230814_indexes) ("20230814_indexes", m20230814_indexes, Just down_m20230814_indexes),
("20230827_file_encryption", m20230827_file_encryption, Just down_m20230827_file_encryption)
] ]
-- | The list of migrations in ascending order by date -- | The list of migrations in ascending order by date

View file

@ -42,6 +42,7 @@ import Simplex.Chat.Types.Preferences
import Simplex.Chat.Types.Util import Simplex.Chat.Types.Util
import Simplex.FileTransfer.Description (FileDigest) import Simplex.FileTransfer.Description (FileDigest)
import Simplex.Messaging.Agent.Protocol (ACommandTag (..), ACorrId, AParty (..), APartyCmdTag (..), ConnId, ConnectionMode (..), ConnectionRequestUri, InvitationId, SAEntity (..), UserId) import Simplex.Messaging.Agent.Protocol (ACommandTag (..), ACorrId, AParty (..), APartyCmdTag (..), ConnId, ConnectionMode (..), ConnectionRequestUri, InvitationId, SAEntity (..), UserId)
import Simplex.Messaging.Crypto.File (CryptoFileArgs (..))
import Simplex.Messaging.Encoding.String import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (dropPrefix, fromTextField_, sumTypeJSON, taggedObjectJSON) import Simplex.Messaging.Parsers (dropPrefix, fromTextField_, sumTypeJSON, taggedObjectJSON)
import Simplex.Messaging.Protocol (ProtoServerWithAuth, ProtocolTypeI) import Simplex.Messaging.Protocol (ProtoServerWithAuth, ProtocolTypeI)
@ -345,11 +346,12 @@ data ChatSettings = ChatSettings
instance ToJSON ChatSettings where toEncoding = J.genericToEncoding J.defaultOptions instance ToJSON ChatSettings where toEncoding = J.genericToEncoding J.defaultOptions
defaultChatSettings :: ChatSettings defaultChatSettings :: ChatSettings
defaultChatSettings = ChatSettings defaultChatSettings =
{ enableNtfs = True, ChatSettings
sendRcpts = Nothing, { enableNtfs = True,
favorite = False sendRcpts = Nothing,
} favorite = False
}
pattern DisableNtfs :: ChatSettings pattern DisableNtfs :: ChatSettings
pattern DisableNtfs <- ChatSettings {enableNtfs = False} pattern DisableNtfs <- ChatSettings {enableNtfs = False}
@ -953,7 +955,8 @@ instance ToJSON RcvFileTransfer where toEncoding = J.genericToEncoding J.default
data XFTPRcvFile = XFTPRcvFile data XFTPRcvFile = XFTPRcvFile
{ rcvFileDescription :: RcvFileDescr, { rcvFileDescription :: RcvFileDescr,
agentRcvFileId :: Maybe AgentRcvFileId, agentRcvFileId :: Maybe AgentRcvFileId,
agentRcvFileDeleted :: Bool agentRcvFileDeleted :: Bool,
cryptoArgs :: Maybe CryptoFileArgs
} }
deriving (Eq, Show, Generic) deriving (Eq, Show, Generic)
@ -1108,7 +1111,8 @@ instance ToJSON FileTransferMeta where toEncoding = J.genericToEncoding J.defaul
data XFTPSndFile = XFTPSndFile data XFTPSndFile = XFTPSndFile
{ agentSndFileId :: AgentSndFileId, { agentSndFileId :: AgentSndFileId,
privateSndFileDescr :: Maybe Text, privateSndFileDescr :: Maybe Text,
agentSndFileDeleted :: Bool agentSndFileDeleted :: Bool,
cryptoArgs :: Maybe CryptoFileArgs
} }
deriving (Eq, Show, Generic) deriving (Eq, Show, Generic)

View file

@ -50,6 +50,7 @@ import Simplex.Messaging.Agent.Env.SQLite (NetworkConfig (..))
import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.Protocol
import Simplex.Messaging.Agent.Store.SQLite.DB (SlowQueryStats (..)) import Simplex.Messaging.Agent.Store.SQLite.DB (SlowQueryStats (..))
import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (dropPrefix, taggedObjectJSON) import Simplex.Messaging.Parsers (dropPrefix, taggedObjectJSON)
@ -160,7 +161,7 @@ responseToView user_ ChatConfig {logLevel, showReactions, showReceipts, testView
CRRcvFileDescrReady _ _ -> [] CRRcvFileDescrReady _ _ -> []
CRRcvFileDescrNotReady _ _ -> [] CRRcvFileDescrNotReady _ _ -> []
CRRcvFileProgressXFTP {} -> [] CRRcvFileProgressXFTP {} -> []
CRRcvFileAccepted u ci -> ttyUser u $ savingFile' ci CRRcvFileAccepted u ci -> ttyUser u $ savingFile' testView ci
CRRcvFileAcceptedSndCancelled u ft -> ttyUser u $ viewRcvFileSndCancelled ft CRRcvFileAcceptedSndCancelled u ft -> ttyUser u $ viewRcvFileSndCancelled ft
CRSndFileCancelled u _ ftm fts -> ttyUser u $ viewSndFileCancelled ftm fts CRSndFileCancelled u _ ftm fts -> ttyUser u $ viewSndFileCancelled ftm fts
CRRcvFileCancelled u _ ft -> ttyUser u $ receivingFile_ "cancelled" ft CRRcvFileCancelled u _ ft -> ttyUser u $ receivingFile_ "cancelled" ft
@ -251,7 +252,7 @@ responseToView user_ ChatConfig {logLevel, showReactions, showReceipts, testView
CRSQLResult rows -> map plain rows CRSQLResult rows -> map plain rows
CRSlowSQLQueries {chatQueries, agentQueries} -> CRSlowSQLQueries {chatQueries, agentQueries} ->
let viewQuery SlowSQLQuery {query, queryStats = SlowQueryStats {count, timeMax, timeAvg}} = let viewQuery SlowSQLQuery {query, queryStats = SlowQueryStats {count, timeMax, timeAvg}} =
"count: " <> sShow count ("count: " <> sShow count)
<> (" :: max: " <> sShow timeMax <> " ms") <> (" :: max: " <> sShow timeMax <> " ms")
<> (" :: avg: " <> sShow timeAvg <> " ms") <> (" :: avg: " <> sShow timeAvg <> " ms")
<> (" :: " <> plain (T.unwords $ T.lines query)) <> (" :: " <> plain (T.unwords $ T.lines query))
@ -274,7 +275,7 @@ responseToView user_ ChatConfig {logLevel, showReactions, showReceipts, testView
<> ("pending subscriptions: " : map sShow pendingSubscriptions) <> ("pending subscriptions: " : map sShow pendingSubscriptions)
CRConnectionDisabled entity -> viewConnectionEntityDisabled entity CRConnectionDisabled entity -> viewConnectionEntityDisabled entity
CRAgentRcvQueueDeleted acId srv aqId err_ -> CRAgentRcvQueueDeleted acId srv aqId err_ ->
[ "completed deleting rcv queue, agent connection id: " <> sShow acId [ ("completed deleting rcv queue, agent connection id: " <> sShow acId)
<> (", server: " <> sShow srv) <> (", server: " <> sShow srv)
<> (", agent queue id: " <> sShow aqId) <> (", agent queue id: " <> sShow aqId)
<> maybe "" (\e -> ", error: " <> sShow e) err_ <> maybe "" (\e -> ", error: " <> sShow e) err_
@ -327,7 +328,7 @@ responseToView user_ ChatConfig {logLevel, showReactions, showReceipts, testView
Just CIQuote {chatDir = quoteDir, content} -> Just CIQuote {chatDir = quoteDir, content} ->
Just (msgDirectionInt $ quoteMsgDirection quoteDir, msgContentText content) Just (msgDirectionInt $ quoteMsgDirection quoteDir, msgContentText content)
fPath = case file of fPath = case file of
Just CIFile {filePath = Just fp} -> Just fp Just CIFile {fileSource = Just (CryptoFile fp _)} -> Just fp
_ -> Nothing _ -> Nothing
testViewItem :: CChatItem c -> Maybe GroupMember -> Text testViewItem :: CChatItem c -> Maybe GroupMember -> Text
testViewItem (CChatItem _ ci@ChatItem {meta = CIMeta {itemText}}) membership_ = testViewItem (CChatItem _ ci@ChatItem {meta = CIMeta {itemText}}) membership_ =
@ -950,7 +951,8 @@ viewNetworkConfig NetworkConfig {socksProxy, tcpTimeout} =
viewContactInfo :: Contact -> ConnectionStats -> Maybe Profile -> [StyledString] viewContactInfo :: Contact -> ConnectionStats -> Maybe Profile -> [StyledString]
viewContactInfo ct@Contact {contactId, profile = LocalProfile {localAlias, contactLink}} stats incognitoProfile = viewContactInfo ct@Contact {contactId, profile = LocalProfile {localAlias, contactLink}} stats incognitoProfile =
["contact ID: " <> sShow contactId] <> viewConnectionStats stats ["contact ID: " <> sShow contactId]
<> viewConnectionStats stats
<> maybe [] (\l -> ["contact address: " <> (plain . strEncode) l]) contactLink <> maybe [] (\l -> ["contact address: " <> (plain . strEncode) l]) contactLink
<> maybe <> maybe
["you've shared main profile with this contact"] ["you've shared main profile with this contact"]
@ -1269,8 +1271,8 @@ viewSentBroadcast mc s f ts tz time = prependFirst (highlight' "/feed" <> " (" <
| otherwise = "" | otherwise = ""
viewSentFileInvitation :: StyledString -> CIFile d -> CurrentTime -> TimeZone -> CIMeta c d -> [StyledString] viewSentFileInvitation :: StyledString -> CIFile d -> CurrentTime -> TimeZone -> CIMeta c d -> [StyledString]
viewSentFileInvitation to CIFile {fileId, filePath, fileStatus} ts tz = case filePath of viewSentFileInvitation to CIFile {fileId, fileSource, fileStatus} ts tz = case fileSource of
Just fPath -> sentWithTime_ ts tz $ ttySentFile fPath Just (CryptoFile fPath _) -> sentWithTime_ ts tz $ ttySentFile fPath
_ -> const [] _ -> const []
where where
ttySentFile fPath = ["/f " <> to <> ttyFilePath fPath] <> cancelSending ttySentFile fPath = ["/f " <> to <> ttyFilePath fPath] <> cancelSending
@ -1338,14 +1340,20 @@ humanReadableSize size
mB = kB * 1024 mB = kB * 1024
gB = mB * 1024 gB = mB * 1024
savingFile' :: AChatItem -> [StyledString] savingFile' :: Bool -> AChatItem -> [StyledString]
savingFile' (AChatItem _ _ (DirectChat Contact {localDisplayName = c}) ChatItem {file = Just CIFile {fileId, filePath = Just filePath}, chatDir = CIDirectRcv}) = savingFile' testView (AChatItem _ _ chat ChatItem {file = Just CIFile {fileId, fileSource = Just (CryptoFile filePath cfArgs_)}, chatDir}) =
["saving file " <> sShow fileId <> " from " <> ttyContact c <> " to " <> plain filePath] let from = case (chat, chatDir) of
savingFile' (AChatItem _ _ _ ChatItem {file = Just CIFile {fileId, filePath = Just filePath}, chatDir = CIGroupRcv GroupMember {localDisplayName = m}}) = (DirectChat Contact {localDisplayName = c}, CIDirectRcv) -> " from " <> ttyContact c
["saving file " <> sShow fileId <> " from " <> ttyContact m <> " to " <> plain filePath] (_, CIGroupRcv GroupMember {localDisplayName = m}) -> " from " <> ttyContact m
savingFile' (AChatItem _ _ _ ChatItem {file = Just CIFile {fileId, filePath = Just filePath}}) = _ -> ""
["saving file " <> sShow fileId <> " to " <> plain filePath] in ["saving file " <> sShow fileId <> from <> " to " <> plain filePath] <> cfArgsStr
savingFile' _ = ["saving file"] -- shouldn't happen where
cfArgsStr = case cfArgs_ of
Just cfArgs@(CFArgs key nonce)
| testView -> [plain $ LB.unpack $ J.encode cfArgs]
| otherwise -> [plain $ "encryption key: " <> strEncode key <> ", nonce: " <> strEncode nonce]
_ -> []
savingFile' _ _ = ["saving file"] -- shouldn't happen
receivingFile_' :: StyledString -> AChatItem -> [StyledString] receivingFile_' :: StyledString -> AChatItem -> [StyledString]
receivingFile_' status (AChatItem _ _ (DirectChat Contact {localDisplayName = c}) ChatItem {file = Just CIFile {fileId, fileName}, chatDir = CIDirectRcv}) = receivingFile_' status (AChatItem _ _ (DirectChat Contact {localDisplayName = c}) ChatItem {file = Just CIFile {fileId, fileName}, chatDir = CIDirectRcv}) =
@ -1397,7 +1405,7 @@ viewFileTransferStatus (FTRcv ft@RcvFileTransfer {fileId, fileInvitation = FileI
RFSCancelled Nothing -> "cancelled" RFSCancelled Nothing -> "cancelled"
viewFileTransferStatusXFTP :: AChatItem -> [StyledString] viewFileTransferStatusXFTP :: AChatItem -> [StyledString]
viewFileTransferStatusXFTP (AChatItem _ _ _ ChatItem {file = Just CIFile {fileId, fileName, fileSize, fileStatus, filePath}}) = viewFileTransferStatusXFTP (AChatItem _ _ _ ChatItem {file = Just CIFile {fileId, fileName, fileSize, fileStatus, fileSource}}) =
case fileStatus of case fileStatus of
CIFSSndStored -> ["sending " <> fstr <> " just started"] CIFSSndStored -> ["sending " <> fstr <> " just started"]
CIFSSndTransfer progress total -> ["sending " <> fstr <> " in progress " <> fileProgressXFTP progress total fileSize] CIFSSndTransfer progress total -> ["sending " <> fstr <> " in progress " <> fileProgressXFTP progress total fileSize]
@ -1407,7 +1415,7 @@ viewFileTransferStatusXFTP (AChatItem _ _ _ ChatItem {file = Just CIFile {fileId
CIFSRcvInvitation -> ["receiving " <> fstr <> " not accepted yet, use " <> highlight ("/fr " <> show fileId) <> " to receive file"] CIFSRcvInvitation -> ["receiving " <> fstr <> " not accepted yet, use " <> highlight ("/fr " <> show fileId) <> " to receive file"]
CIFSRcvAccepted -> ["receiving " <> fstr <> " just started"] CIFSRcvAccepted -> ["receiving " <> fstr <> " just started"]
CIFSRcvTransfer progress total -> ["receiving " <> fstr <> " progress " <> fileProgressXFTP progress total fileSize] CIFSRcvTransfer progress total -> ["receiving " <> fstr <> " progress " <> fileProgressXFTP progress total fileSize]
CIFSRcvComplete -> ["receiving " <> fstr <> " complete" <> maybe "" (\fp -> ", path: " <> plain fp) filePath] CIFSRcvComplete -> ["receiving " <> fstr <> " complete" <> maybe "" (\(CryptoFile fp _) -> ", path: " <> plain fp) fileSource]
CIFSRcvCancelled -> ["receiving " <> fstr <> " cancelled"] CIFSRcvCancelled -> ["receiving " <> fstr <> " cancelled"]
CIFSRcvError -> ["receiving " <> fstr <> " error"] CIFSRcvError -> ["receiving " <> fstr <> " error"]
CIFSInvalid text -> [fstr <> " invalid status: " <> plain text] CIFSInvalid text -> [fstr <> " invalid status: " <> plain text]

View file

@ -49,7 +49,7 @@ extra-deps:
# - simplexmq-1.0.0@sha256:34b2004728ae396e3ae449cd090ba7410781e2b3cefc59259915f4ca5daa9ea8,8561 # - simplexmq-1.0.0@sha256:34b2004728ae396e3ae449cd090ba7410781e2b3cefc59259915f4ca5daa9ea8,8561
# - ../simplexmq # - ../simplexmq
- github: simplex-chat/simplexmq - github: simplex-chat/simplexmq
commit: 4c0b8a31d20870a23e120e243359901d8240f922 commit: 5dc3d739b206edc2b4706ba0eef64ad4492e68e6
- github: kazu-yamamoto/http2 - github: kazu-yamamoto/http2
commit: b5a1b7200cf5bc7044af34ba325284271f6dff25 commit: b5a1b7200cf5bc7044af34ba325284271f6dff25
# - ../direct-sqlcipher # - ../direct-sqlcipher

View file

@ -249,7 +249,7 @@ getTermLine cc =
Just s -> do Just s -> do
-- remove condition to always echo virtual terminal -- remove condition to always echo virtual terminal
when (printOutput cc) $ do when (printOutput cc) $ do
-- when True $ do -- when True $ do
name <- userName cc name <- userName cc
putStrLn $ name <> ": " <> s putStrLn $ name <> ": " <> s
pure s pure s

View file

@ -8,14 +8,19 @@ import ChatClient
import ChatTests.Utils import ChatTests.Utils
import Control.Concurrent (threadDelay) import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (concurrently_) import Control.Concurrent.Async (concurrently_)
import qualified Data.Aeson as J
import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as LB
import Simplex.Chat (roundedFDCount) import Simplex.Chat (roundedFDCount)
import Simplex.Chat.Controller (ChatConfig (..), InlineFilesConfig (..), XFTPFileConfig (..), defaultInlineFilesConfig) import Simplex.Chat.Controller (ChatConfig (..), InlineFilesConfig (..), XFTPFileConfig (..), defaultInlineFilesConfig)
import Simplex.Chat.Mobile.File
import Simplex.Chat.Options (ChatOpts (..)) import Simplex.Chat.Options (ChatOpts (..))
import Simplex.FileTransfer.Client.Main (xftpClientCLI) import Simplex.FileTransfer.Client.Main (xftpClientCLI)
import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..)) import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..))
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Util (unlessM) import Simplex.Messaging.Util (unlessM)
import System.Directory (copyFile, doesFileExist) import System.Directory (copyFile, createDirectoryIfMissing, doesFileExist, getFileSize)
import System.Environment (withArgs) import System.Environment (withArgs)
import System.IO.Silently (capture_) import System.IO.Silently (capture_)
import Test.Hspec import Test.Hspec
@ -59,6 +64,7 @@ chatFileTests = do
describe "file transfer over XFTP" $ do describe "file transfer over XFTP" $ do
it "round file description count" $ const testXFTPRoundFDCount it "round file description count" $ const testXFTPRoundFDCount
it "send and receive file" testXFTPFileTransfer it "send and receive file" testXFTPFileTransfer
it "send and receive locally encrypted files" testXFTPFileTransferEncrypted
it "send and receive file, accepting after upload" testXFTPAcceptAfterUpload it "send and receive file, accepting after upload" testXFTPAcceptAfterUpload
it "send and receive file in group" testXFTPGroupFileTransfer it "send and receive file in group" testXFTPGroupFileTransfer
it "delete uploaded file" testXFTPDeleteUploadedFile it "delete uploaded file" testXFTPDeleteUploadedFile
@ -1013,6 +1019,35 @@ testXFTPFileTransfer =
where where
cfg = testCfg {xftpFileConfig = Just $ XFTPFileConfig {minFileSize = 0}, tempDir = Just "./tests/tmp"} cfg = testCfg {xftpFileConfig = Just $ XFTPFileConfig {minFileSize = 0}, tempDir = Just "./tests/tmp"}
testXFTPFileTransferEncrypted :: HasCallStack => FilePath -> IO ()
testXFTPFileTransferEncrypted =
testChatCfg2 cfg aliceProfile bobProfile $ \alice bob -> do
src <- B.readFile "./tests/fixtures/test.pdf"
srcLen <- getFileSize "./tests/fixtures/test.pdf"
let srcPath = "./tests/tmp/alice/test.pdf"
createDirectoryIfMissing True "./tests/tmp/alice/"
createDirectoryIfMissing True "./tests/tmp/bob/"
WFResult cfArgs <- chatWriteFile srcPath src
let fileJSON = LB.unpack $ J.encode $ CryptoFile srcPath $ Just cfArgs
withXFTPServer $ do
connectUsers alice bob
alice ##> ("/_send @2 json {\"msgContent\":{\"type\":\"file\", \"text\":\"\"}, \"fileSource\": " <> fileJSON <> "}")
alice <# "/f @bob ./tests/tmp/alice/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/"
bob <## "saving file 1 from alice to ./tests/tmp/bob/test.pdf"
Just (CFArgs key nonce) <- J.decode . LB.pack <$> getTermLine bob
alice <## "completed uploading file 1 (test.pdf) for bob"
bob <## "started receiving file 1 (test.pdf) from alice"
bob <## "completed receiving file 1 (test.pdf) from alice"
(RFResult destLen, dest) <- chatReadFile "./tests/tmp/bob/test.pdf" (strEncode key) (strEncode nonce)
fromIntegral destLen `shouldBe` srcLen
dest `shouldBe` src
where
cfg = testCfg {xftpFileConfig = Just $ XFTPFileConfig {minFileSize = 0}, tempDir = Just "./tests/tmp"}
testXFTPAcceptAfterUpload :: HasCallStack => FilePath -> IO () testXFTPAcceptAfterUpload :: HasCallStack => FilePath -> IO ()
testXFTPAcceptAfterUpload = testXFTPAcceptAfterUpload =
testChatCfg2 cfg aliceProfile bobProfile $ \alice bob -> do testChatCfg2 cfg aliceProfile bobProfile $ \alice bob -> do
@ -1447,7 +1482,7 @@ startFileTransfer alice bob =
startFileTransfer' alice bob "test.jpg" "136.5 KiB / 139737 bytes" startFileTransfer' alice bob "test.jpg" "136.5 KiB / 139737 bytes"
startFileTransfer' :: HasCallStack => TestCC -> TestCC -> String -> String -> IO () startFileTransfer' :: HasCallStack => TestCC -> TestCC -> String -> String -> IO ()
startFileTransfer' cc1 cc2 fileName fileSize = startFileTransferWithDest' cc1 cc2 fileName fileSize $ Just "./tests/tmp" startFileTransfer' cc1 cc2 fName fSize = startFileTransferWithDest' cc1 cc2 fName fSize $ Just "./tests/tmp"
checkPartialTransfer :: HasCallStack => String -> IO () checkPartialTransfer :: HasCallStack => String -> IO ()
checkPartialTransfer fileName = do checkPartialTransfer fileName = do