mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2025-03-14 09:45:42 +00:00
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
GitHub
parent
1c90eb0a2e
commit
0b214acf97
22 changed files with 390 additions and 147 deletions
|
|
@ -9,7 +9,7 @@ constraints: zip +disable-bzip2 +disable-zstd
|
|||
source-repository-package
|
||||
type: git
|
||||
location: https://github.com/simplex-chat/simplexmq.git
|
||||
tag: 4c0b8a31d20870a23e120e243359901d8240f922
|
||||
tag: 5dc3d739b206edc2b4706ba0eef64ad4492e68e6
|
||||
|
||||
source-repository-package
|
||||
type: git
|
||||
|
|
|
|||
|
|
@ -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/kazu-yamamoto/http2.git"."b5a1b7200cf5bc7044af34ba325284271f6dff25" = "0dqb50j57an64nf4qcf5vcz4xkd1vzvghvf8bk529c1k30r9nfzb";
|
||||
"https://github.com/simplex-chat/direct-sqlcipher.git"."34309410eb2069b029b8fc1872deb1e0db123294" = "0kwkmhyfsn2lixdlgl15smgr1h5gjk7fky6abzh8rng2h5ymnffd";
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
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
|
||||
|
||||
|
|
@ -10,7 +10,7 @@ category: Web, System, Services, Cryptography
|
|||
homepage: https://github.com/simplex-chat/simplex-chat#readme
|
||||
author: simplex.chat
|
||||
maintainer: chat@simplex.chat
|
||||
copyright: 2020-23 simplex.chat
|
||||
copyright: 2020-22 simplex.chat
|
||||
license: AGPL-3
|
||||
license-file: LICENSE
|
||||
build-type: Simple
|
||||
|
|
@ -108,7 +108,10 @@ library
|
|||
Simplex.Chat.Migrations.M20230705_delivery_receipts
|
||||
Simplex.Chat.Migrations.M20230721_group_snd_item_statuses
|
||||
Simplex.Chat.Migrations.M20230814_indexes
|
||||
Simplex.Chat.Migrations.M20230827_file_encryption
|
||||
Simplex.Chat.Mobile
|
||||
Simplex.Chat.Mobile.File
|
||||
Simplex.Chat.Mobile.Shared
|
||||
Simplex.Chat.Mobile.WebRTC
|
||||
Simplex.Chat.Options
|
||||
Simplex.Chat.ProfileGenerator
|
||||
|
|
|
|||
|
|
@ -1,4 +1,3 @@
|
|||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# 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 Simplex.Messaging.Client (defaultNetworkConfig)
|
||||
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.String
|
||||
import Simplex.Messaging.Parsers (base64P)
|
||||
|
|
@ -562,8 +563,9 @@ processChatCommand = \case
|
|||
SendFileSMP fileInline -> smpSndFileTransfer file fileSize fileInline
|
||||
SendFileXFTP -> xftpSndFileTransfer user file fileSize 1 $ CGContact ct
|
||||
where
|
||||
smpSndFileTransfer :: FilePath -> Integer -> Maybe InlineFileMode -> m (FileInvitation, CIFile 'MDSnd, FileTransferMeta)
|
||||
smpSndFileTransfer file fileSize fileInline = do
|
||||
smpSndFileTransfer :: CryptoFile -> Integer -> Maybe InlineFileMode -> m (FileInvitation, CIFile 'MDSnd, FileTransferMeta)
|
||||
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) <-
|
||||
if isJust fileInline
|
||||
then pure (Nothing, Nothing)
|
||||
|
|
@ -576,7 +578,8 @@ processChatCommand = \case
|
|||
fileStatus <- case fileInline of
|
||||
Just IFMSent -> createSndDirectInlineFT db ct ft $> CIFSSndTransfer 0 1
|
||||
_ -> 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)
|
||||
prepareMsg :: Maybe FileInvitation -> Maybe CITimed -> m (MsgContainer, Maybe (CIQuote 'CTDirect))
|
||||
prepareMsg fInv_ timed_ = case quotedItemId_ of
|
||||
|
|
@ -625,15 +628,17 @@ processChatCommand = \case
|
|||
SendFileSMP fileInline -> smpSndFileTransfer file fileSize fileInline
|
||||
SendFileXFTP -> xftpSndFileTransfer user file fileSize n $ CGGroup g
|
||||
where
|
||||
smpSndFileTransfer :: FilePath -> Integer -> Maybe InlineFileMode -> m (FileInvitation, CIFile 'MDSnd, FileTransferMeta)
|
||||
smpSndFileTransfer file fileSize fileInline = do
|
||||
smpSndFileTransfer :: CryptoFile -> Integer -> Maybe InlineFileMode -> m (FileInvitation, CIFile 'MDSnd, FileTransferMeta)
|
||||
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
|
||||
fileInvitation = FileInvitation {fileName, fileSize, fileDigest = Nothing, fileConnReq = Nothing, fileInline, fileDescr = Nothing}
|
||||
fileStatus = if fileInline == Just IFMSent then CIFSSndTransfer 0 1 else CIFSSndStored
|
||||
chSize <- asks $ fileChunkSize . config
|
||||
withStore' $ \db -> do
|
||||
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)
|
||||
sendGroupFileInline :: [GroupMember] -> SharedMsgId -> FileTransferMeta -> m ()
|
||||
sendGroupFileInline ms sharedMsgId ft@FileTransferMeta {fileInline} =
|
||||
|
|
@ -688,17 +693,19 @@ processChatCommand = \case
|
|||
qText = msgContentText qmc
|
||||
qFileName = maybe qText (T.pack . (fileName :: CIFile d -> String)) ciFile_
|
||||
qTextOrFile = if T.null qText then qFileName else qText
|
||||
xftpSndFileTransfer :: User -> FilePath -> Integer -> Int -> ContactOrGroup -> m (FileInvitation, CIFile 'MDSnd, FileTransferMeta)
|
||||
xftpSndFileTransfer user file fileSize n contactOrGroup = do
|
||||
let fileName = takeFileName file
|
||||
xftpSndFileTransfer :: User -> CryptoFile -> Integer -> Int -> ContactOrGroup -> m (FileInvitation, CIFile 'MDSnd, FileTransferMeta)
|
||||
xftpSndFileTransfer user file@(CryptoFile filePath cfArgs) fileSize n contactOrGroup = do
|
||||
let fileName = takeFileName filePath
|
||||
fileDescr = FileDescr {fileDescrText = "", fileDescrPartNo = 0, fileDescrComplete = False}
|
||||
fInv = xftpFileInvitation fileName fileSize fileDescr
|
||||
fsFilePath <- toFSFilePath file
|
||||
aFileId <- withAgent $ \a -> xftpSendFile a (aUserId user) fsFilePath (roundedFDCount n)
|
||||
fsFilePath <- toFSFilePath filePath
|
||||
let srcFile = CryptoFile fsFilePath cfArgs
|
||||
aFileId <- withAgent $ \a -> xftpSendFile a (aUserId user) srcFile (roundedFDCount n)
|
||||
-- TODO CRSndFileStart event for XFTP
|
||||
chSize <- asks $ fileChunkSize . config
|
||||
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
|
||||
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))
|
||||
|
|
@ -1613,26 +1620,40 @@ processChatCommand = \case
|
|||
asks showLiveItems >>= atomically . (`writeTVar` on) >> ok_
|
||||
SendFile chatName f -> withUser $ \user -> do
|
||||
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
|
||||
chatRef <- getChatRef user chatName
|
||||
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
|
||||
unless (fileSize <= maxImageSize) $ throwChatError CEFileImageSize {filePath}
|
||||
-- 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
|
||||
ForwardImage chatName fileId -> forwardFile chatName fileId SendImage
|
||||
SendFileDescription _chatName _f -> pure $ chatCmdError Nothing "TODO"
|
||||
ReceiveFile fileId rcvInline_ filePath_ -> withUser $ \_ ->
|
||||
ReceiveFile fileId encrypted rcvInline_ filePath_ -> withUser $ \_ ->
|
||||
withChatLock "receiveFile" . procCmd $ do
|
||||
(user, ft) <- withStore $ \db -> getRcvFileTransferById db fileId
|
||||
receiveFile' user ft rcvInline_ filePath_
|
||||
SetFileToReceive fileId -> withUser $ \_ -> do
|
||||
(user, ft) <- withStore (`getRcvFileTransferById` fileId)
|
||||
ft' <- if encrypted then encryptLocalFile ft else pure ft
|
||||
receiveFile' user ft' rcvInline_ filePath_
|
||||
where
|
||||
encryptLocalFile ft@RcvFileTransfer {xftpRcvFile} = case xftpRcvFile of
|
||||
Nothing -> throwChatError $ CEFileInternal "locally encrypted files can't be received via SMP"
|
||||
Just f -> do
|
||||
cfArgs <- liftIO $ CF.randomArgs
|
||||
withStore' $ \db -> setFileCryptoArgs db fileId cfArgs
|
||||
pure ft {xftpRcvFile = Just ((f :: XFTPRcvFile) {cryptoArgs = Just cfArgs})}
|
||||
SetFileToReceive fileId encrypted -> withUser $ \_ -> do
|
||||
withChatLock "setFileToReceive" . procCmd $ do
|
||||
withStore' (`setRcvFileToReceive` fileId)
|
||||
cfArgs <- if encrypted then fileCryptoArgs else pure Nothing
|
||||
withStore' $ \db -> setRcvFileToReceive db fileId cfArgs
|
||||
ok_
|
||||
where
|
||||
fileCryptoArgs = do
|
||||
(_, RcvFileTransfer {xftpRcvFile = f}) <- withStore (`getRcvFileTransferById` fileId)
|
||||
unless (isJust f) $ throwChatError $ CEFileInternal "locally encrypted files can't be received via SMP"
|
||||
liftIO $ Just <$> CF.randomArgs
|
||||
CancelFile fileId -> withUser $ \user@User {userId} ->
|
||||
withChatLock "cancelFile" . procCmd $
|
||||
withStore (\db -> getFileTransfer db user fileId) >>= \case
|
||||
|
|
@ -1829,18 +1850,19 @@ processChatCommand = \case
|
|||
contactMember Contact {contactId} =
|
||||
find $ \GroupMember {memberContactId = cId, memberStatus = s} ->
|
||||
cId == Just contactId && s /= GSMemRemoved && s /= GSMemLeft
|
||||
checkSndFile :: MsgContent -> FilePath -> Integer -> m (Integer, SendFileMode)
|
||||
checkSndFile mc f n = do
|
||||
checkSndFile :: MsgContent -> CryptoFile -> Integer -> m (Integer, SendFileMode)
|
||||
checkSndFile mc (CryptoFile f cfArgs) n = do
|
||||
fsFilePath <- toFSFilePath f
|
||||
unlessM (doesFileExist fsFilePath) . throwChatError $ CEFileNotFound f
|
||||
ChatConfig {fileChunkSize, inlineFiles} <- asks config
|
||||
xftpCfg <- readTVarIO =<< asks userXFTPFileConfig
|
||||
fileSize <- getFileSize fsFilePath
|
||||
fileSize <- liftIO $ CF.getFileContentsSize $ CryptoFile fsFilePath cfArgs
|
||||
when (fromInteger fileSize > maxFileSize) $ throwChatError $ CEFileSize f
|
||||
let chunks = - ((- fileSize) `div` fileChunkSize)
|
||||
let chunks = -((-fileSize) `div` fileChunkSize)
|
||||
fileInline = inlineFileMode mc inlineFiles chunks n
|
||||
fileMode = case xftpCfg of
|
||||
Just cfg
|
||||
| isJust cfArgs -> SendFileXFTP
|
||||
| fileInline == Just IFMSent || fileSize < minFileSize cfg || n <= 0 -> SendFileSMP fileInline
|
||||
| otherwise -> SendFileXFTP
|
||||
_ -> SendFileSMP fileInline
|
||||
|
|
@ -1867,17 +1889,17 @@ processChatCommand = \case
|
|||
summary <- foldM (processAndCount user' logLevel) (UserProfileUpdateSummary 0 0 0 []) contacts
|
||||
pure $ CRUserProfileUpdated user' (fromLocalProfile p) p' summary
|
||||
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
|
||||
ct' = updateMergedPreferences user' ct
|
||||
mergedProfile' = userProfileToSend user' Nothing $ Just ct'
|
||||
if mergedProfile' == mergedProfile
|
||||
then pure s {notChanged = notChanged + 1}
|
||||
else
|
||||
let cts' = if mergedPreferences ct == mergedPreferences ct' then cts else ct' : cts
|
||||
else
|
||||
let cts' = if mergedPreferences ct == mergedPreferences ct' then cts else ct' : 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'}
|
||||
where
|
||||
where
|
||||
notifyContact mergedProfile' ct' = do
|
||||
void $ sendDirectContactMessage ct' (XInfo mergedProfile')
|
||||
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
|
||||
withStoreCtx (Just "acceptFileReceive, acceptRcvFileTransfer") $ \db -> acceptRcvFileTransfer db user fileId connIds ConnJoined filePath
|
||||
-- XFTP
|
||||
(Just _xftpRcvFile, _) -> do
|
||||
(Just XFTPRcvFile {cryptoArgs}, _) -> do
|
||||
filePath <- getRcvFilePath fileId filePath_ fName False
|
||||
(ci, rfd) <- withStoreCtx (Just "acceptFileReceive, xftpAcceptRcvFT ...") $ \db -> do
|
||||
-- marking file as accepted and reading description in the same transaction
|
||||
|
|
@ -2222,7 +2244,7 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI
|
|||
ci <- xftpAcceptRcvFT db user fileId filePath
|
||||
rfd <- getRcvFileDescrByFileId db fileId
|
||||
pure (ci, rfd)
|
||||
receiveViaCompleteFD user fileId rfd
|
||||
receiveViaCompleteFD user fileId rfd cryptoArgs
|
||||
pure ci
|
||||
-- group & direct file protocol
|
||||
_ -> do
|
||||
|
|
@ -2265,11 +2287,11 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI
|
|||
|| (rcvInline_ == Just True && fileSize <= fileChunkSize * offerChunks)
|
||||
)
|
||||
|
||||
receiveViaCompleteFD :: ChatMonad m => User -> FileTransferId -> RcvFileDescr -> m ()
|
||||
receiveViaCompleteFD user fileId RcvFileDescr {fileDescrText, fileDescrComplete} =
|
||||
receiveViaCompleteFD :: ChatMonad m => User -> FileTransferId -> RcvFileDescr -> Maybe CryptoFileArgs -> m ()
|
||||
receiveViaCompleteFD user fileId RcvFileDescr {fileDescrText, fileDescrComplete} cfArgs =
|
||||
when fileDescrComplete $ do
|
||||
rd <- parseFileDescription fileDescrText
|
||||
aFileId <- withAgent $ \a -> xftpReceiveFile a (aUserId user) rd
|
||||
aFileId <- withAgent $ \a -> xftpReceiveFile a (aUserId user) rd cfArgs
|
||||
startReceivingFile user fileId
|
||||
withStoreCtx' (Just "receiveViaCompleteFD, updateRcvFileAgentId") $ \db -> updateRcvFileAgentId db fileId (Just $ AgentRcvFileId aFileId)
|
||||
|
||||
|
|
@ -2535,7 +2557,7 @@ cleanupManager = do
|
|||
`catchChatError` (toView . CRChatError (Just user))
|
||||
cleanupMessages = do
|
||||
ts <- liftIO getCurrentTime
|
||||
let cutoffTs = addUTCTime (- (30 * nominalDay)) ts
|
||||
let cutoffTs = addUTCTime (-(30 * nominalDay)) ts
|
||||
withStoreCtx' (Just "cleanupManager, deleteOldMessages") (`deleteOldMessages` cutoffTs)
|
||||
|
||||
startProximateTimedItemThread :: ChatMonad m => User -> (ChatRef, ChatItemId) -> UTCTime -> m ()
|
||||
|
|
@ -3567,14 +3589,14 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
|||
processFDMessage fileId fileDescr = do
|
||||
ft <- withStore $ \db -> getRcvFileTransfer db user fileId
|
||||
unless (rcvFileCompleteOrCancelled ft) $ do
|
||||
(rfd, RcvFileTransfer {fileStatus}) <- withStore $ \db -> do
|
||||
(rfd, RcvFileTransfer {fileStatus, xftpRcvFile}) <- withStore $ \db -> do
|
||||
rfd <- appendRcvFD db userId fileId fileDescr
|
||||
-- reading second time in the same transaction as appending description
|
||||
-- to prevent race condition with accept
|
||||
ft' <- getRcvFileTransfer db user fileId
|
||||
pure (rfd, ft')
|
||||
case fileStatus of
|
||||
RFSAccepted _ -> receiveViaCompleteFD user fileId rfd
|
||||
case (fileStatus, xftpRcvFile) of
|
||||
(RFSAccepted _, Just XFTPRcvFile {cryptoArgs}) -> receiveViaCompleteFD user fileId rfd cryptoArgs
|
||||
_ -> pure ()
|
||||
|
||||
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
|
||||
pure (Just fPath, CIFSRcvAccepted)
|
||||
_ -> 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 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
|
||||
RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvFileTransfer db userId ct fInv inline fileChunkSize
|
||||
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
|
||||
toView $ CRNewChatItem user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci)
|
||||
whenContactNtfs user ct $ do
|
||||
|
|
@ -3831,7 +3854,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
|||
inline <- receiveInlineMode fInv Nothing fileChunkSize
|
||||
RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvGroupFileTransfer db userId m fInv inline fileChunkSize
|
||||
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
|
||||
groupMsgToView gInfo m ci msgMeta
|
||||
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
|
||||
|
||||
deleteCIFile :: (ChatMonad m, MsgDirectionI d) => User -> Maybe (CIFile d) -> m ()
|
||||
deleteCIFile user file =
|
||||
forM_ file $ \CIFile {fileId, filePath, fileStatus} -> do
|
||||
let fileInfo = CIFileInfo {fileId, fileStatus = Just $ AFS msgDirection fileStatus, filePath}
|
||||
fileAgentConnIds <- deleteFile' user fileInfo True
|
||||
deleteCIFile user file_ =
|
||||
forM_ file_ $ \file -> do
|
||||
fileAgentConnIds <- deleteFile' user (mkCIFileInfo file) True
|
||||
deleteAgentConnectionsAsync user fileAgentConnIds
|
||||
|
||||
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'
|
||||
|
||||
cancelCIFile :: (ChatMonad m, MsgDirectionI d) => User -> Maybe (CIFile d) -> m ()
|
||||
cancelCIFile user file =
|
||||
forM_ file $ \CIFile {fileId, filePath, fileStatus} -> do
|
||||
let fileInfo = CIFileInfo {fileId, fileStatus = Just $ AFS msgDirection fileStatus, filePath}
|
||||
fileAgentConnIds <- cancelFile' user fileInfo True
|
||||
cancelCIFile user file_ =
|
||||
forM_ file_ $ \file -> do
|
||||
fileAgentConnIds <- cancelFile' user (mkCIFileInfo file) True
|
||||
deleteAgentConnectionsAsync user fileAgentConnIds
|
||||
|
||||
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 =
|
||||
asks smpAgent
|
||||
>>= runExceptT . action
|
||||
>>= liftEither . first (\e -> ChatErrorAgent e Nothing)
|
||||
>>= liftEither . first (`ChatErrorAgent` Nothing)
|
||||
|
||||
withStore' :: ChatMonad m => (DB.Connection -> IO a) -> m a
|
||||
withStore' action = withStore $ liftIO . action
|
||||
|
|
@ -5235,8 +5256,8 @@ chatCommandP =
|
|||
("/fforward " <|> "/ff ") *> (ForwardFile <$> chatNameP' <* A.space <*> A.decimal),
|
||||
("/image_forward " <|> "/imgf ") *> (ForwardImage <$> chatNameP' <* A.space <*> A.decimal),
|
||||
("/fdescription " <|> "/fd") *> (SendFileDescription <$> chatNameP' <* A.space <*> filePath),
|
||||
("/freceive " <|> "/fr ") *> (ReceiveFile <$> A.decimal <*> optional (" inline=" *> onOffP) <*> optional (A.space *> filePath)),
|
||||
"/_set_file_to_receive " *> (SetFileToReceive <$> A.decimal),
|
||||
("/freceive " <|> "/fr ") *> (ReceiveFile <$> A.decimal <*> (" encrypt=" *> onOffP <|> pure False) <*> optional (" inline=" *> onOffP) <*> optional (A.space *> filePath)),
|
||||
"/_set_file_to_receive " *> (SetFileToReceive <$> A.decimal <*> (" encrypt=" *> onOffP <|> pure False)),
|
||||
("/fcancel " <|> "/fc ") *> (CancelFile <$> A.decimal),
|
||||
("/fstatus " <|> "/fs ") *> (FileStatus <$> A.decimal),
|
||||
"/simplex" *> (ConnectSimplex <$> incognitoP),
|
||||
|
|
|
|||
|
|
@ -66,7 +66,7 @@ sendComposedMessage cc = sendComposedMessage' cc . contactId'
|
|||
|
||||
sendComposedMessage' :: ChatController -> ContactId -> Maybe ChatItemId -> MsgContent -> IO ()
|
||||
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
|
||||
CRNewChatItem {} -> printLog cc CLLInfo $ "sent message to contact ID " <> show ctId
|
||||
r -> putStrLn $ "unexpected send message response: " <> show r
|
||||
|
|
|
|||
|
|
@ -22,8 +22,9 @@ import Control.Monad.Except
|
|||
import Control.Monad.IO.Unlift
|
||||
import Control.Monad.Reader
|
||||
import Crypto.Random (ChaChaDRG)
|
||||
import Data.Aeson (FromJSON (..), ToJSON (..))
|
||||
import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.:?))
|
||||
import qualified Data.Aeson as J
|
||||
import qualified Data.Aeson.Types as JT
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
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.Protocol
|
||||
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 Simplex.Messaging.Crypto.File (CryptoFile (..))
|
||||
import qualified Simplex.Messaging.Crypto.File as CF
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfTknStatus)
|
||||
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.TMap (TMap)
|
||||
import Simplex.Messaging.Agent.Store.SQLite.DB (SlowQueryStats (..))
|
||||
import Simplex.Messaging.Transport (simplexMQVersion)
|
||||
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.Mem.Weak (Weak)
|
||||
import UnliftIO.STM
|
||||
|
|
@ -387,8 +390,8 @@ data ChatCommand
|
|||
| ForwardFile ChatName FileTransferId
|
||||
| ForwardImage ChatName FileTransferId
|
||||
| SendFileDescription ChatName FilePath
|
||||
| ReceiveFile {fileId :: FileTransferId, fileInline :: Maybe Bool, filePath :: Maybe FilePath}
|
||||
| SetFileToReceive FileTransferId
|
||||
| ReceiveFile {fileId :: FileTransferId, storeEncrypted :: Bool, fileInline :: Maybe Bool, filePath :: Maybe FilePath}
|
||||
| SetFileToReceive {fileId :: FileTransferId, storeEncrypted :: Bool}
|
||||
| CancelFile FileTransferId
|
||||
| FileStatus FileTransferId
|
||||
| ShowProfile -- UserId (not used in UI)
|
||||
|
|
@ -723,11 +726,24 @@ data UserProfileUpdateSummary = UserProfileUpdateSummary
|
|||
instance ToJSON UserProfileUpdateSummary where toEncoding = J.genericToEncoding J.defaultOptions
|
||||
|
||||
data ComposedMessage = ComposedMessage
|
||||
{ filePath :: Maybe FilePath,
|
||||
{ fileSource :: Maybe CryptoFile,
|
||||
quotedItemId :: Maybe ChatItemId,
|
||||
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
|
||||
toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
|
||||
|
|
|
|||
|
|
@ -37,6 +37,8 @@ import Simplex.Chat.Protocol
|
|||
import Simplex.Chat.Types
|
||||
import Simplex.Chat.Types.Preferences
|
||||
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.Parsers (dropPrefix, enumJSON, fromTextField_, parseAll, sumTypeJSON)
|
||||
import Simplex.Messaging.Protocol (MsgBody)
|
||||
|
|
@ -459,7 +461,7 @@ data CIFile (d :: MsgDirection) = CIFile
|
|||
{ fileId :: Int64,
|
||||
fileName :: String,
|
||||
fileSize :: Integer,
|
||||
filePath :: Maybe FilePath, -- local file path
|
||||
fileSource :: Maybe CryptoFile, -- local file path with optional key and nonce
|
||||
fileStatus :: CIFileStatus d,
|
||||
fileProtocol :: FileProtocol
|
||||
}
|
||||
|
|
@ -631,6 +633,14 @@ data CIFileInfo = CIFileInfo
|
|||
}
|
||||
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
|
||||
CISSndNew :: CIStatus 'MDSnd
|
||||
CISSndSent :: SndCIStatusProgress -> CIStatus 'MDSnd
|
||||
|
|
|
|||
|
|
@ -50,7 +50,7 @@ instance FromField AMsgDirection where fromField = fromIntField_ $ fmap fromMsgD
|
|||
|
||||
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
|
||||
f@(Field (SQLInteger i) _) ->
|
||||
case fromInt i of
|
||||
|
|
|
|||
20
src/Simplex/Chat/Migrations/M20230827_file_encryption.hs
Normal file
20
src/Simplex/Chat/Migrations/M20230827_file_encryption.hs
Normal 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;
|
||||
|]
|
||||
|
|
@ -204,7 +204,9 @@ CREATE TABLE files(
|
|||
agent_snd_file_id BLOB NULL,
|
||||
private_snd_file_descr TEXT 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(
|
||||
file_id INTEGER NOT NULL REFERENCES files ON DELETE CASCADE,
|
||||
|
|
|
|||
|
|
@ -35,6 +35,8 @@ import GHC.Generics (Generic)
|
|||
import Simplex.Chat
|
||||
import Simplex.Chat.Controller
|
||||
import Simplex.Chat.Markdown (ParsedMarkdown (..), parseMaybeMarkdownList)
|
||||
import Simplex.Chat.Mobile.File
|
||||
import Simplex.Chat.Mobile.Shared
|
||||
import Simplex.Chat.Mobile.WebRTC
|
||||
import Simplex.Chat.Options
|
||||
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_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
|
||||
cChatMigrateInit :: CString -> CString -> CString -> Ptr (StablePtr ChatController) -> IO CJSONString
|
||||
cChatMigrateInit fp key conf ctrl = do
|
||||
|
|
@ -151,8 +157,6 @@ defaultMobileConfig =
|
|||
logLevel = CLLError
|
||||
}
|
||||
|
||||
type CJSONString = CString
|
||||
|
||||
getActiveUser_ :: SQLiteStore -> IO (Maybe User)
|
||||
getActiveUser_ st = find activeUser <$> withTransaction st getUsers
|
||||
|
||||
|
|
|
|||
83
src/Simplex/Chat/Mobile/File.hs
Normal file
83
src/Simplex/Chat/Mobile/File.hs
Normal 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
|
||||
19
src/Simplex/Chat/Mobile/Shared.hs
Normal file
19
src/Simplex/Chat/Mobile/Shared.hs
Normal 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
|
||||
|
|
@ -12,16 +12,15 @@ import Control.Monad.Except
|
|||
import qualified Crypto.Cipher.Types as AES
|
||||
import Data.Bifunctor (bimap)
|
||||
import qualified Data.ByteArray as BA
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Base64.URL as U
|
||||
import Data.ByteString.Internal (ByteString (PS), memcpy)
|
||||
import Data.Either (fromLeft)
|
||||
import Data.Word (Word8)
|
||||
import Foreign.C (CInt, CString, newCAString)
|
||||
import Foreign.ForeignPtr (newForeignPtr_)
|
||||
import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
|
||||
import Foreign.Ptr (Ptr, plusPtr)
|
||||
import Foreign.Ptr (Ptr)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Chat.Mobile.Shared
|
||||
|
||||
cChatEncryptMedia :: CString -> Ptr Word8 -> CInt -> IO CString
|
||||
cChatEncryptMedia = cTransformMedia chatEncryptMedia
|
||||
|
|
@ -32,16 +31,10 @@ cChatDecryptMedia = cTransformMedia chatDecryptMedia
|
|||
cTransformMedia :: (ByteString -> ByteString -> ExceptT String IO ByteString) -> CString -> Ptr Word8 -> CInt -> IO CString
|
||||
cTransformMedia f cKey cFrame cFrameLen = do
|
||||
key <- B.packCString cKey
|
||||
frame <- getFrame
|
||||
frame <- getByteString cFrame cFrameLen
|
||||
runExceptT (f key frame >>= liftIO . putFrame) >>= newCAString . fromLeft ""
|
||||
where
|
||||
getFrame = do
|
||||
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
|
||||
putFrame s = when (B.length s < fromIntegral cFrameLen) $ putByteString cFrame s
|
||||
{-# INLINE cTransformMedia #-}
|
||||
|
||||
chatEncryptMedia :: ByteString -> ByteString -> ExceptT String IO ByteString
|
||||
|
|
|
|||
|
|
@ -56,6 +56,7 @@ module Simplex.Chat.Store.Files
|
|||
startRcvInlineFT,
|
||||
xftpAcceptRcvFT,
|
||||
setRcvFileToReceive,
|
||||
setFileCryptoArgs,
|
||||
getRcvFilesToReceive,
|
||||
setRcvFTAgentDeleted,
|
||||
updateRcvFileStatus,
|
||||
|
|
@ -84,18 +85,21 @@ import Data.Time.Clock (UTCTime (..), getCurrentTime, nominalDay)
|
|||
import Data.Type.Equality
|
||||
import Database.SQLite.Simple (Only (..), (:.) (..))
|
||||
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.Messages
|
||||
import Simplex.Chat.Store.Profiles
|
||||
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.Util (week)
|
||||
import Simplex.Messaging.Agent.Protocol (AgentMsgId, ConnId, UserId)
|
||||
import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow)
|
||||
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 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})
|
||||
<$> (contactName_ <|> memberName_)
|
||||
|
||||
createSndFileTransferXFTP :: DB.Connection -> User -> ContactOrGroup -> FilePath -> FileInvitation -> AgentSndFileId -> Integer -> IO FileTransferMeta
|
||||
createSndFileTransferXFTP db User {userId} contactOrGroup filePath FileInvitation {fileName, fileSize} agentSndFileId chunkSize = do
|
||||
createSndFileTransferXFTP :: DB.Connection -> User -> ContactOrGroup -> CryptoFile -> FileInvitation -> AgentSndFileId -> Integer -> IO FileTransferMeta
|
||||
createSndFileTransferXFTP db User {userId} contactOrGroup (CryptoFile filePath cryptoArgs) FileInvitation {fileName, fileSize} agentSndFileId chunkSize = do
|
||||
currentTs <- getCurrentTime
|
||||
let xftpSndFile = Just XFTPSndFile {agentSndFileId, privateSndFileDescr = Nothing, agentSndFileDeleted = False}
|
||||
let xftpSndFile = Just XFTPSndFile {agentSndFileId, privateSndFileDescr = Nothing, agentSndFileDeleted = False, cryptoArgs}
|
||||
DB.execute
|
||||
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 (?,?,?,?,?,?,?,?,?,?,?,?)"
|
||||
(contactAndGroupIds contactOrGroup :. (userId, fileName, filePath, fileSize, chunkSize, agentSndFileId, CIFSSndStored, FPXFTP, currentTs, currentTs))
|
||||
"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, CF.fileKey <$> cryptoArgs, CF.fileNonce <$> cryptoArgs, fileSize, chunkSize, agentSndFileId, CIFSSndStored, FPXFTP, currentTs, currentTs))
|
||||
fileId <- insertedRowId db
|
||||
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
|
||||
rfd_ <- mapM (createRcvFD_ db userId currentTs) fileDescr
|
||||
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
|
||||
fileId <- liftIO $ do
|
||||
DB.execute
|
||||
|
|
@ -499,7 +504,8 @@ createRcvGroupFileTransfer db userId GroupMember {groupId, groupMemberId, localD
|
|||
currentTs <- liftIO getCurrentTime
|
||||
rfd_ <- mapM (createRcvFD_ db userId currentTs) fileDescr
|
||||
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
|
||||
fileId <- liftIO $ do
|
||||
DB.execute
|
||||
|
|
@ -600,7 +606,7 @@ getRcvFileTransfer db User {userId} fileId = do
|
|||
[sql|
|
||||
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_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
|
||||
JOIN files f USING (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
|
||||
rcvFileTransfer ::
|
||||
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
|
||||
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
|
||||
Nothing -> throwError $ SERcvFileInvalid fileId
|
||||
Just name -> do
|
||||
|
|
@ -629,7 +635,8 @@ getRcvFileTransfer db User {userId} fileId = do
|
|||
where
|
||||
ft senderDisplayName fileStatus =
|
||||
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}
|
||||
rfi = maybe (throwError $ SERcvFileInvalid fileId) pure =<< rfi_
|
||||
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 = ?"
|
||||
(rcvFileInline, FSAccepted, currentTs, fileId)
|
||||
|
||||
setRcvFileToReceive :: DB.Connection -> FileTransferId -> IO ()
|
||||
setRcvFileToReceive db fileId = do
|
||||
setRcvFileToReceive :: DB.Connection -> FileTransferId -> Maybe CryptoFileArgs -> IO ()
|
||||
setRcvFileToReceive db fileId cfArgs_ = do
|
||||
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
|
||||
"UPDATE rcv_files SET to_receive = 1, updated_at = ? WHERE file_id = ?"
|
||||
(currentTs, fileId)
|
||||
"UPDATE files SET file_crypto_key = ?, file_crypto_nonce = ?, updated_at = ? WHERE file_id = ?"
|
||||
(key, nonce, currentTs, fileId)
|
||||
|
||||
getRcvFilesToReceive :: DB.Connection -> User -> IO [RcvFileTransfer]
|
||||
getRcvFilesToReceive db user@User {userId} = do
|
||||
|
|
@ -842,15 +857,16 @@ getFileTransferMeta db User {userId} fileId =
|
|||
DB.query
|
||||
db
|
||||
[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
|
||||
WHERE user_id = ? AND file_id = ?
|
||||
|]
|
||||
(userId, fileId)
|
||||
where
|
||||
fileTransferMeta :: (String, Integer, Integer, FilePath, Maybe InlineFileMode, Maybe AgentSndFileId, Bool, Maybe Text, Maybe Bool) -> FileTransferMeta
|
||||
fileTransferMeta (fileName, fileSize, chunkSize, filePath, fileInline, aSndFileId_, agentSndFileDeleted, privateSndFileDescr, cancelled_) =
|
||||
let xftpSndFile = (\fId -> XFTPSndFile {agentSndFileId = fId, privateSndFileDescr, agentSndFileDeleted}) <$> aSndFileId_
|
||||
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, fileKey, fileNonce, fileInline, aSndFileId_, agentSndFileDeleted, privateSndFileDescr, cancelled_) =
|
||||
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_}
|
||||
|
||||
getContactFileInfo :: DB.Connection -> User -> Contact -> IO [CIFileInfo]
|
||||
|
|
|
|||
|
|
@ -13,7 +13,6 @@
|
|||
module Simplex.Chat.Store.Messages
|
||||
( getContactConnIds_,
|
||||
getDirectChatReactions_,
|
||||
toDirectChatItem,
|
||||
|
||||
-- * Message and chat item functions
|
||||
deleteContactCIs,
|
||||
|
|
@ -122,6 +121,8 @@ import Simplex.Chat.Types
|
|||
import Simplex.Messaging.Agent.Protocol (AgentMsgId, ConnId, MsgMeta (..), UserId)
|
||||
import Simplex.Messaging.Agent.Store.SQLite (firstRow, firstRow', maybeFirstRow)
|
||||
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 UnliftIO.STM
|
||||
|
||||
|
|
@ -483,7 +484,7 @@ getDirectChatPreviews_ db user@User {userId} = do
|
|||
-- 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,
|
||||
-- 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
|
||||
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent
|
||||
FROM contacts ct
|
||||
|
|
@ -548,7 +549,7 @@ getGroupChatPreviews_ db User {userId, userContactId} = do
|
|||
-- 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,
|
||||
-- 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
|
||||
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,
|
||||
|
|
@ -669,7 +670,7 @@ getDirectChatItemsLast db User {userId} contactId count search = ExceptT $ do
|
|||
-- 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,
|
||||
-- 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
|
||||
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent
|
||||
FROM chat_items i
|
||||
|
|
@ -698,7 +699,7 @@ getDirectChatAfter_ db User {userId} ct@Contact {contactId} afterChatItemId coun
|
|||
-- 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,
|
||||
-- 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
|
||||
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent
|
||||
FROM chat_items i
|
||||
|
|
@ -728,7 +729,7 @@ getDirectChatBefore_ db User {userId} ct@Contact {contactId} beforeChatItemId co
|
|||
-- 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,
|
||||
-- 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
|
||||
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent
|
||||
FROM chat_items i
|
||||
|
|
@ -950,7 +951,7 @@ type ChatStatsRow = (Int, ChatItemId, Bool)
|
|||
toChatStats :: ChatStatsRow -> ChatStats
|
||||
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)
|
||||
|
||||
|
|
@ -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
|
||||
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
|
||||
where
|
||||
invalid = ACIContent msgDir $ CIInvalidJSON itemContentText
|
||||
|
|
@ -988,7 +989,10 @@ toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentT
|
|||
maybeCIFile :: CIFileStatus d -> Maybe (CIFile d)
|
||||
maybeCIFile fileStatus =
|
||||
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
|
||||
cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTDirect d -> CIStatus d -> CIContent d -> Maybe (CIFile d) -> CChatItem 'CTDirect
|
||||
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
|
||||
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
|
||||
where
|
||||
member_ = toMaybeGroupMember userContactId memberRow_
|
||||
|
|
@ -1041,7 +1045,10 @@ toGroupChatItem currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir,
|
|||
maybeCIFile :: CIFileStatus d -> Maybe (CIFile d)
|
||||
maybeCIFile fileStatus =
|
||||
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
|
||||
cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTGroup d -> CIStatus d -> CIContent d -> Maybe (CIFile d) -> CChatItem 'CTGroup
|
||||
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 _ 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
|
||||
ci <- liftEither . correctDir =<< getDirectChatItem db user contactId itemId
|
||||
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 _ 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
|
||||
currentTs <- liftIO getCurrentTime
|
||||
let ci' = updatedChatItem ci newContent live currentTs
|
||||
|
|
@ -1294,7 +1301,7 @@ getDirectChatItem db User {userId} contactId itemId = ExceptT $ do
|
|||
-- 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,
|
||||
-- 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
|
||||
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent
|
||||
FROM chat_items i
|
||||
|
|
@ -1469,7 +1476,7 @@ getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do
|
|||
-- 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,
|
||||
-- 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
|
||||
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,
|
||||
|
|
|
|||
|
|
@ -76,6 +76,7 @@ import Simplex.Chat.Migrations.M20230621_chat_item_moderations
|
|||
import Simplex.Chat.Migrations.M20230705_delivery_receipts
|
||||
import Simplex.Chat.Migrations.M20230721_group_snd_item_statuses
|
||||
import Simplex.Chat.Migrations.M20230814_indexes
|
||||
import Simplex.Chat.Migrations.M20230827_file_encryption
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..))
|
||||
|
||||
schemaMigrations :: [(String, Query, Maybe Query)]
|
||||
|
|
@ -151,7 +152,8 @@ schemaMigrations =
|
|||
("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),
|
||||
("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
|
||||
|
|
|
|||
|
|
@ -42,6 +42,7 @@ import Simplex.Chat.Types.Preferences
|
|||
import Simplex.Chat.Types.Util
|
||||
import Simplex.FileTransfer.Description (FileDigest)
|
||||
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.Parsers (dropPrefix, fromTextField_, sumTypeJSON, taggedObjectJSON)
|
||||
import Simplex.Messaging.Protocol (ProtoServerWithAuth, ProtocolTypeI)
|
||||
|
|
@ -345,11 +346,12 @@ data ChatSettings = ChatSettings
|
|||
instance ToJSON ChatSettings where toEncoding = J.genericToEncoding J.defaultOptions
|
||||
|
||||
defaultChatSettings :: ChatSettings
|
||||
defaultChatSettings = ChatSettings
|
||||
{ enableNtfs = True,
|
||||
sendRcpts = Nothing,
|
||||
favorite = False
|
||||
}
|
||||
defaultChatSettings =
|
||||
ChatSettings
|
||||
{ enableNtfs = True,
|
||||
sendRcpts = Nothing,
|
||||
favorite = False
|
||||
}
|
||||
|
||||
pattern DisableNtfs :: ChatSettings
|
||||
pattern DisableNtfs <- ChatSettings {enableNtfs = False}
|
||||
|
|
@ -953,7 +955,8 @@ instance ToJSON RcvFileTransfer where toEncoding = J.genericToEncoding J.default
|
|||
data XFTPRcvFile = XFTPRcvFile
|
||||
{ rcvFileDescription :: RcvFileDescr,
|
||||
agentRcvFileId :: Maybe AgentRcvFileId,
|
||||
agentRcvFileDeleted :: Bool
|
||||
agentRcvFileDeleted :: Bool,
|
||||
cryptoArgs :: Maybe CryptoFileArgs
|
||||
}
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
|
|
@ -1108,7 +1111,8 @@ instance ToJSON FileTransferMeta where toEncoding = J.genericToEncoding J.defaul
|
|||
data XFTPSndFile = XFTPSndFile
|
||||
{ agentSndFileId :: AgentSndFileId,
|
||||
privateSndFileDescr :: Maybe Text,
|
||||
agentSndFileDeleted :: Bool
|
||||
agentSndFileDeleted :: Bool,
|
||||
cryptoArgs :: Maybe CryptoFileArgs
|
||||
}
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
|
|
|
|||
|
|
@ -50,6 +50,7 @@ import Simplex.Messaging.Agent.Env.SQLite (NetworkConfig (..))
|
|||
import Simplex.Messaging.Agent.Protocol
|
||||
import Simplex.Messaging.Agent.Store.SQLite.DB (SlowQueryStats (..))
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers (dropPrefix, taggedObjectJSON)
|
||||
|
|
@ -160,7 +161,7 @@ responseToView user_ ChatConfig {logLevel, showReactions, showReceipts, testView
|
|||
CRRcvFileDescrReady _ _ -> []
|
||||
CRRcvFileDescrNotReady _ _ -> []
|
||||
CRRcvFileProgressXFTP {} -> []
|
||||
CRRcvFileAccepted u ci -> ttyUser u $ savingFile' ci
|
||||
CRRcvFileAccepted u ci -> ttyUser u $ savingFile' testView ci
|
||||
CRRcvFileAcceptedSndCancelled u ft -> ttyUser u $ viewRcvFileSndCancelled ft
|
||||
CRSndFileCancelled u _ ftm fts -> ttyUser u $ viewSndFileCancelled ftm fts
|
||||
CRRcvFileCancelled u _ ft -> ttyUser u $ receivingFile_ "cancelled" ft
|
||||
|
|
@ -251,7 +252,7 @@ responseToView user_ ChatConfig {logLevel, showReactions, showReceipts, testView
|
|||
CRSQLResult rows -> map plain rows
|
||||
CRSlowSQLQueries {chatQueries, agentQueries} ->
|
||||
let viewQuery SlowSQLQuery {query, queryStats = SlowQueryStats {count, timeMax, timeAvg}} =
|
||||
"count: " <> sShow count
|
||||
("count: " <> sShow count)
|
||||
<> (" :: max: " <> sShow timeMax <> " ms")
|
||||
<> (" :: avg: " <> sShow timeAvg <> " ms")
|
||||
<> (" :: " <> plain (T.unwords $ T.lines query))
|
||||
|
|
@ -274,7 +275,7 @@ responseToView user_ ChatConfig {logLevel, showReactions, showReceipts, testView
|
|||
<> ("pending subscriptions: " : map sShow pendingSubscriptions)
|
||||
CRConnectionDisabled entity -> viewConnectionEntityDisabled entity
|
||||
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)
|
||||
<> (", agent queue id: " <> sShow aqId)
|
||||
<> maybe "" (\e -> ", error: " <> sShow e) err_
|
||||
|
|
@ -327,7 +328,7 @@ responseToView user_ ChatConfig {logLevel, showReactions, showReceipts, testView
|
|||
Just CIQuote {chatDir = quoteDir, content} ->
|
||||
Just (msgDirectionInt $ quoteMsgDirection quoteDir, msgContentText content)
|
||||
fPath = case file of
|
||||
Just CIFile {filePath = Just fp} -> Just fp
|
||||
Just CIFile {fileSource = Just (CryptoFile fp _)} -> Just fp
|
||||
_ -> Nothing
|
||||
testViewItem :: CChatItem c -> Maybe GroupMember -> Text
|
||||
testViewItem (CChatItem _ ci@ChatItem {meta = CIMeta {itemText}}) membership_ =
|
||||
|
|
@ -950,7 +951,8 @@ viewNetworkConfig NetworkConfig {socksProxy, tcpTimeout} =
|
|||
|
||||
viewContactInfo :: Contact -> ConnectionStats -> Maybe Profile -> [StyledString]
|
||||
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
|
||||
["you've shared main profile with this contact"]
|
||||
|
|
@ -1269,8 +1271,8 @@ viewSentBroadcast mc s f ts tz time = prependFirst (highlight' "/feed" <> " (" <
|
|||
| otherwise = ""
|
||||
|
||||
viewSentFileInvitation :: StyledString -> CIFile d -> CurrentTime -> TimeZone -> CIMeta c d -> [StyledString]
|
||||
viewSentFileInvitation to CIFile {fileId, filePath, fileStatus} ts tz = case filePath of
|
||||
Just fPath -> sentWithTime_ ts tz $ ttySentFile fPath
|
||||
viewSentFileInvitation to CIFile {fileId, fileSource, fileStatus} ts tz = case fileSource of
|
||||
Just (CryptoFile fPath _) -> sentWithTime_ ts tz $ ttySentFile fPath
|
||||
_ -> const []
|
||||
where
|
||||
ttySentFile fPath = ["/f " <> to <> ttyFilePath fPath] <> cancelSending
|
||||
|
|
@ -1338,14 +1340,20 @@ humanReadableSize size
|
|||
mB = kB * 1024
|
||||
gB = mB * 1024
|
||||
|
||||
savingFile' :: AChatItem -> [StyledString]
|
||||
savingFile' (AChatItem _ _ (DirectChat Contact {localDisplayName = c}) ChatItem {file = Just CIFile {fileId, filePath = Just filePath}, chatDir = CIDirectRcv}) =
|
||||
["saving file " <> sShow fileId <> " from " <> ttyContact c <> " to " <> plain filePath]
|
||||
savingFile' (AChatItem _ _ _ ChatItem {file = Just CIFile {fileId, filePath = Just filePath}, chatDir = CIGroupRcv GroupMember {localDisplayName = m}}) =
|
||||
["saving file " <> sShow fileId <> " from " <> ttyContact m <> " to " <> plain filePath]
|
||||
savingFile' (AChatItem _ _ _ ChatItem {file = Just CIFile {fileId, filePath = Just filePath}}) =
|
||||
["saving file " <> sShow fileId <> " to " <> plain filePath]
|
||||
savingFile' _ = ["saving file"] -- shouldn't happen
|
||||
savingFile' :: Bool -> AChatItem -> [StyledString]
|
||||
savingFile' testView (AChatItem _ _ chat ChatItem {file = Just CIFile {fileId, fileSource = Just (CryptoFile filePath cfArgs_)}, chatDir}) =
|
||||
let from = case (chat, chatDir) of
|
||||
(DirectChat Contact {localDisplayName = c}, CIDirectRcv) -> " from " <> ttyContact c
|
||||
(_, CIGroupRcv GroupMember {localDisplayName = m}) -> " from " <> ttyContact m
|
||||
_ -> ""
|
||||
in ["saving file " <> sShow fileId <> from <> " to " <> plain filePath] <> cfArgsStr
|
||||
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_' 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"
|
||||
|
||||
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
|
||||
CIFSSndStored -> ["sending " <> fstr <> " just started"]
|
||||
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"]
|
||||
CIFSRcvAccepted -> ["receiving " <> fstr <> " just started"]
|
||||
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"]
|
||||
CIFSRcvError -> ["receiving " <> fstr <> " error"]
|
||||
CIFSInvalid text -> [fstr <> " invalid status: " <> plain text]
|
||||
|
|
|
|||
|
|
@ -49,7 +49,7 @@ extra-deps:
|
|||
# - simplexmq-1.0.0@sha256:34b2004728ae396e3ae449cd090ba7410781e2b3cefc59259915f4ca5daa9ea8,8561
|
||||
# - ../simplexmq
|
||||
- github: simplex-chat/simplexmq
|
||||
commit: 4c0b8a31d20870a23e120e243359901d8240f922
|
||||
commit: 5dc3d739b206edc2b4706ba0eef64ad4492e68e6
|
||||
- github: kazu-yamamoto/http2
|
||||
commit: b5a1b7200cf5bc7044af34ba325284271f6dff25
|
||||
# - ../direct-sqlcipher
|
||||
|
|
|
|||
|
|
@ -249,7 +249,7 @@ getTermLine cc =
|
|||
Just s -> do
|
||||
-- remove condition to always echo virtual terminal
|
||||
when (printOutput cc) $ do
|
||||
-- when True $ do
|
||||
-- when True $ do
|
||||
name <- userName cc
|
||||
putStrLn $ name <> ": " <> s
|
||||
pure s
|
||||
|
|
|
|||
|
|
@ -8,14 +8,19 @@ import ChatClient
|
|||
import ChatTests.Utils
|
||||
import Control.Concurrent (threadDelay)
|
||||
import Control.Concurrent.Async (concurrently_)
|
||||
import qualified Data.Aeson as J
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import qualified Data.ByteString.Lazy.Char8 as LB
|
||||
import Simplex.Chat (roundedFDCount)
|
||||
import Simplex.Chat.Controller (ChatConfig (..), InlineFilesConfig (..), XFTPFileConfig (..), defaultInlineFilesConfig)
|
||||
import Simplex.Chat.Mobile.File
|
||||
import Simplex.Chat.Options (ChatOpts (..))
|
||||
import Simplex.FileTransfer.Client.Main (xftpClientCLI)
|
||||
import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..))
|
||||
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Util (unlessM)
|
||||
import System.Directory (copyFile, doesFileExist)
|
||||
import System.Directory (copyFile, createDirectoryIfMissing, doesFileExist, getFileSize)
|
||||
import System.Environment (withArgs)
|
||||
import System.IO.Silently (capture_)
|
||||
import Test.Hspec
|
||||
|
|
@ -59,6 +64,7 @@ chatFileTests = do
|
|||
describe "file transfer over XFTP" $ do
|
||||
it "round file description count" $ const testXFTPRoundFDCount
|
||||
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 in group" testXFTPGroupFileTransfer
|
||||
it "delete uploaded file" testXFTPDeleteUploadedFile
|
||||
|
|
@ -1013,6 +1019,35 @@ testXFTPFileTransfer =
|
|||
where
|
||||
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 =
|
||||
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' :: 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 fileName = do
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue