dandri/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-08-27 22:34:51 +00:00
Code Issues Packages Projects Releases Wiki Activity

Merge branch 'master' into master-ghc9

Browse Source
This commit is contained in:
Evgeny Poberezkin
2023-09-10 21:11:35 +01:00
parent 215020b1df 2dff6c8859
commit fedc31c72c
226 changed files with 16182 additions and 2495 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Simplex/Chat.hs
+364 -233
View File
File diff suppressed because it is too large Load Diff
src/Simplex/Chat/Bot.hs
+1 -1
View File
@@ -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
src/Simplex/Chat/Controller.hs
+37 -10
View File
@@ -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,19 @@ 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.Protocol (AProtoServerWithAuth, AProtocolType, CorrId, MsgFlags, NtfServer, ProtoServerWithAuth, ProtocolTypeI, QueueId, SProtocolType, SubscriptionMode (..), 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 Simplex.Messaging.Version
import System.IO (Handle)
import System.Mem.Weak (Weak)
import UnliftIO.STM
@@ -72,7 +76,7 @@ versionNumber :: String
versionNumber = showVersion SC.version
versionString :: String -> String
versionString version = "SimpleX Chat v" <> version
versionString ver = "SimpleX Chat v" <> ver
updateStr :: String
updateStr = "To update run: curl -o- https://raw.githubusercontent.com/simplex-chat/simplex-chat/master/install.sh | bash"
@@ -101,6 +105,7 @@ coreVersionInfo simplexmqCommit =
data ChatConfig = ChatConfig
{ agentConfig :: AgentConfig,
chatVRange :: VersionRange,
confirmMigrations :: MigrationConfirmation,
defaultServers :: DefaultAgentServers,
tbqSize :: Natural,
@@ -171,6 +176,7 @@ data ChatController = ChatController
outputQ :: TBQueue (Maybe CorrId, ChatResponse),
notifyQ :: TBQueue Notification,
sendNotification :: Notification -> IO (),
subscriptionMode :: TVar SubscriptionMode,
chatLock :: Lock,
sndFiles :: TVar (Map Int64 Handle),
rcvFiles :: TVar (Map Int64 Handle),
@@ -387,8 +393,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)
@@ -570,7 +576,7 @@ data ChatResponse
| CRSlowSQLQueries {chatQueries :: [SlowSQLQuery], agentQueries :: [SlowSQLQuery]}
| CRDebugLocks {chatLockName :: Maybe String, agentLocks :: AgentLocks}
| CRAgentStats {agentStats :: [[String]]}
| CRAgentSubs {activeSubs :: Map Text Int, distinctActiveSubs :: Map Text Int, pendingSubs :: Map Text Int, distinctPendingSubs :: Map Text Int}
| CRAgentSubs {activeSubs :: Map Text Int, pendingSubs :: Map Text Int, removedSubs :: Map Text [String]}
| CRAgentSubsDetails {agentSubs :: SubscriptionsInfo}
| CRConnectionDisabled {connectionEntity :: ConnectionEntity}
| CRAgentRcvQueueDeleted {agentConnId :: AgentConnId, server :: SMPServer, agentQueueId :: AgentQueueId, agentError_ :: Maybe AgentErrorType}
@@ -723,11 +729,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}
@@ -942,6 +961,14 @@ type ChatMonad' m = (MonadUnliftIO m, MonadReader ChatController m)
type ChatMonad m = (ChatMonad' m, MonadError ChatError m)
chatReadVar :: ChatMonad' m => (ChatController -> TVar a) -> m a
chatReadVar f = asks f >>= readTVarIO
{-# INLINE chatReadVar #-}
chatWriteVar :: ChatMonad' m => (ChatController -> TVar a) -> a -> m ()
chatWriteVar f value = asks f >>= atomically . (`writeTVar` value)
{-# INLINE chatWriteVar #-}
tryChatError :: ChatMonad m => m a -> m (Either ChatError a)
tryChatError = tryAllErrors mkChatError
{-# INLINE tryChatError #-}
src/Simplex/Chat/Messages.hs
+11 -1
View File
@@ -40,6 +40,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)
@@ -462,7 +464,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
}
@@ -634,6 +636,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
src/Simplex/Chat/Messages/CIContent.hs
+1 -1
View File
@@ -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
src/Simplex/Chat/Migrations/M20230827_file_encryption.hs
+20
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;
|]
src/Simplex/Chat/Migrations/M20230829_connections_chat_vrange.hs
+26
View File
@@ -0,0 +1,26 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Chat.Migrations.M20230829_connections_chat_vrange where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20230829_connections_chat_vrange :: Query
m20230829_connections_chat_vrange =
[sql|
ALTER TABLE connections ADD COLUMN peer_chat_min_version INTEGER NOT NULL DEFAULT 1;
ALTER TABLE connections ADD COLUMN peer_chat_max_version INTEGER NOT NULL DEFAULT 1;
ALTER TABLE contact_requests ADD COLUMN peer_chat_min_version INTEGER NOT NULL DEFAULT 1;
ALTER TABLE contact_requests ADD COLUMN peer_chat_max_version INTEGER NOT NULL DEFAULT 1;
|]
down_m20230829_connections_chat_vrange :: Query
down_m20230829_connections_chat_vrange =
[sql|
ALTER TABLE contact_requests DROP COLUMN peer_chat_max_version;
ALTER TABLE contact_requests DROP COLUMN peer_chat_min_version;
ALTER TABLE connections DROP COLUMN peer_chat_max_version;
ALTER TABLE connections DROP COLUMN peer_chat_min_version;
|]
src/Simplex/Chat/Migrations/M20230903_connections_to_subscribe.hs
+20
View File
@@ -0,0 +1,20 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Chat.Migrations.M20230903_connections_to_subscribe where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20230903_connections_to_subscribe :: Query
m20230903_connections_to_subscribe =
[sql|
ALTER TABLE connections ADD COLUMN to_subscribe INTEGER DEFAULT 0 NOT NULL;
CREATE INDEX idx_connections_to_subscribe ON connections(to_subscribe);
|]
down_m20230903_connections_to_subscribe :: Query
down_m20230903_connections_to_subscribe =
[sql|
DROP INDEX idx_connections_to_subscribe;
ALTER TABLE connections DROP COLUMN to_subscribe;
|]
src/Simplex/Chat/Migrations/chat_schema.sql
+9 -1
View File
@@ -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,
@@ -283,6 +285,9 @@ CREATE TABLE connections(
security_code TEXT NULL,
security_code_verified_at TEXT NULL,
auth_err_counter INTEGER DEFAULT 0 CHECK(auth_err_counter NOT NULL),
peer_chat_min_version INTEGER NOT NULL DEFAULT 1,
peer_chat_max_version INTEGER NOT NULL DEFAULT 1,
to_subscribe INTEGER DEFAULT 0 NOT NULL,
FOREIGN KEY(snd_file_id, connection_id)
REFERENCES snd_files(file_id, connection_id)
ON DELETE CASCADE
@@ -316,6 +321,8 @@ CREATE TABLE contact_requests(
user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE,
updated_at TEXT CHECK(updated_at NOT NULL),
xcontact_id BLOB,
peer_chat_min_version INTEGER NOT NULL DEFAULT 1,
peer_chat_max_version INTEGER NOT NULL DEFAULT 1,
FOREIGN KEY(user_id, local_display_name)
REFERENCES display_names(user_id, local_display_name)
ON UPDATE CASCADE
@@ -705,3 +712,4 @@ CREATE INDEX idx_chat_items_user_id_item_status ON chat_items(
user_id,
item_status
);
CREATE INDEX idx_connections_to_subscribe ON connections(to_subscribe);
src/Simplex/Chat/Mobile.hs
+10 -2
View File
@@ -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,14 @@ 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)
foreign export ccall "chat_encrypt_file" cChatEncryptFile :: CString -> CString -> IO CJSONString
foreign export ccall "chat_decrypt_file" cChatDecryptFile :: CString -> CString -> CString -> CString -> IO CString
-- | 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 +161,6 @@ defaultMobileConfig =
logLevel = CLLError
}
type CJSONString = CString
getActiveUser_ :: SQLiteStore -> IO (Maybe User)
getActiveUser_ st = find activeUser <$> withTransaction st getUsers
src/Simplex/Chat/Mobile/File.hs
+155
View File
@@ -0,0 +1,155 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module Simplex.Chat.Mobile.File
( cChatWriteFile,
cChatReadFile,
cChatEncryptFile,
cChatDecryptFile,
WriteFileResult (..),
ReadFileResult (..),
chatWriteFile,
chatReadFile,
)
where
import Control.Monad
import Control.Monad.Except
import Control.Monad.IO.Class
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.Char (chr)
import Data.Either (fromLeft)
import Data.Word (Word8, Word32)
import Foreign.C
import Foreign.Marshal.Alloc (mallocBytes)
import Foreign.Ptr
import Foreign.Storable (poke)
import GHC.Generics (Generic)
import Simplex.Chat.Mobile.Shared
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..), CryptoFileHandle, FTCryptoError (..))
import qualified Simplex.Messaging.Crypto.File as CF
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
import Simplex.Messaging.Util (catchAll)
import UnliftIO (Handle, IOMode (..), withFile)
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 <- peekCString 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 (\_ -> WFResult cfArgs)
<$> runCatchExceptT (withExceptT show $ CF.writeFile file $ LB.fromStrict s)
data ReadFileResult
= RFResult {fileSize :: Int}
| 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 <- peekCString cPath
key <- B.packCString cKey
nonce <- B.packCString cNonce
chatReadFile path key nonce >>= \case
Left e -> castPtr <$> newCString (chr 1 : e)
Right s -> do
let s' = LB.toStrict s
len = B.length s'
ptr <- mallocBytes $ len + 5
poke ptr 0
poke (ptr `plusPtr` 1) (fromIntegral len :: Word32)
putByteString (ptr `plusPtr` 5) s'
pure ptr
chatReadFile :: FilePath -> ByteString -> ByteString -> IO (Either String LB.ByteString)
chatReadFile path keyStr nonceStr = runCatchExceptT $ do
key <- liftEither $ strDecode keyStr
nonce <- liftEither $ strDecode nonceStr
let file = CryptoFile path $ Just $ CFArgs key nonce
withExceptT show $ CF.readFile file
cChatEncryptFile :: CString -> CString -> IO CJSONString
cChatEncryptFile cFromPath cToPath = do
fromPath <- peekCString cFromPath
toPath <- peekCString cToPath
r <- chatEncryptFile fromPath toPath
newCAString . LB'.unpack $ J.encode r
chatEncryptFile :: FilePath -> FilePath -> IO WriteFileResult
chatEncryptFile fromPath toPath =
either WFError WFResult <$> runCatchExceptT encrypt
where
encrypt = do
cfArgs <- liftIO $ CF.randomArgs
let toFile = CryptoFile toPath $ Just cfArgs
withExceptT show $
withFile fromPath ReadMode $ \r -> CF.withFile toFile WriteMode $ \w -> do
encryptChunks r w
liftIO $ CF.hPutTag w
pure cfArgs
encryptChunks r w = do
ch <- liftIO $ LB.hGet r chunkSize
unless (LB.null ch) $ liftIO $ CF.hPut w ch
unless (LB.length ch < chunkSize) $ encryptChunks r w
cChatDecryptFile :: CString -> CString -> CString -> CString -> IO CString
cChatDecryptFile cFromPath cKey cNonce cToPath = do
fromPath <- peekCString cFromPath
key <- B.packCString cKey
nonce <- B.packCString cNonce
toPath <- peekCString cToPath
r <- chatDecryptFile fromPath key nonce toPath
newCAString r
chatDecryptFile :: FilePath -> ByteString -> ByteString -> FilePath -> IO String
chatDecryptFile fromPath keyStr nonceStr toPath = fromLeft "" <$> runCatchExceptT decrypt
where
decrypt = do
key <- liftEither $ strDecode keyStr
nonce <- liftEither $ strDecode nonceStr
let fromFile = CryptoFile fromPath $ Just $ CFArgs key nonce
size <- liftIO $ CF.getFileContentsSize fromFile
withExceptT show $
CF.withFile fromFile ReadMode $ \r -> withFile toPath WriteMode $ \w -> do
decryptChunks r w size
CF.hGetTag r
decryptChunks :: CryptoFileHandle -> Handle -> Integer -> ExceptT FTCryptoError IO ()
decryptChunks r w !size = do
let chSize = min size chunkSize
chSize' = fromIntegral chSize
size' = size - chSize
ch <- liftIO $ CF.hGet r chSize'
when (B.length ch /= chSize') $ throwError $ FTCEFileIOError "encrypting file: unexpected EOF"
liftIO $ B.hPut w ch
when (size' > 0) $ decryptChunks r w size'
runCatchExceptT :: ExceptT String IO a -> IO (Either String a)
runCatchExceptT action = runExceptT action `catchAll` (pure . Left . show)
chunkSize :: Num a => a
chunkSize = 65536
{-# INLINE chunkSize #-}
src/Simplex/Chat/Mobile/Shared.hs
+19
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
src/Simplex/Chat/Mobile/WebRTC.hs
+5 -12
View File
@@ -14,16 +14,15 @@ import Control.Monad.IO.Class
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
@@ -34,16 +33,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
src/Simplex/Chat/Protocol.hs
+24 -8
View File
@@ -48,6 +48,17 @@ import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (dropPrefix, fromTextField_, fstToLower, parseAll, sumTypeJSON, taggedObjectJSON)
import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, (<$?>))
import Simplex.Messaging.Version hiding (version)
currentChatVersion :: Version
currentChatVersion = 2
supportedChatVRange :: VersionRange
supportedChatVRange = mkVersionRange 1 currentChatVersion
-- version range that supports skipping establishing direct connections in a group
groupNoDirectVRange :: VersionRange
groupNoDirectVRange = mkVersionRange 2 currentChatVersion
data ConnectionEntity
= RcvDirectMsgConnection {entityConnection :: Connection, contact :: Maybe Contact}
@@ -104,7 +115,8 @@ data AppMessage (e :: MsgEncoding) where
-- chat message is sent as JSON with these properties
data AppMessageJson = AppMessageJson
{ msgId :: Maybe SharedMsgId,
{ v :: Maybe ChatVersionRange,
msgId :: Maybe SharedMsgId,
event :: Text,
params :: J.Object
}
@@ -163,7 +175,11 @@ instance ToJSON MsgRef where
toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
data ChatMessage e = ChatMessage {msgId :: Maybe SharedMsgId, chatMsgEvent :: ChatMsgEvent e}
data ChatMessage e = ChatMessage
{ chatVRange :: VersionRange,
msgId :: Maybe SharedMsgId,
chatMsgEvent :: ChatMsgEvent e
}
deriving (Eq, Show)
data AChatMessage = forall e. MsgEncodingI e => ACMsg (SMsgEncoding e) (ChatMessage e)
@@ -726,17 +742,17 @@ appBinaryToCM :: AppMessageBinary -> Either String (ChatMessage 'Binary)
appBinaryToCM AppMessageBinary {msgId, tag, body} = do
eventTag <- strDecode $ B.singleton tag
chatMsgEvent <- parseAll (msg eventTag) body
pure ChatMessage {msgId, chatMsgEvent}
pure ChatMessage {chatVRange = chatInitialVRange, msgId, chatMsgEvent}
where
msg :: CMEventTag 'Binary -> A.Parser (ChatMsgEvent 'Binary)
msg = \case
BFileChunk_ -> BFileChunk <$> (SharedMsgId <$> smpP) <*> (unIFC <$> smpP)
appJsonToCM :: AppMessageJson -> Either String (ChatMessage 'Json)
appJsonToCM AppMessageJson {msgId, event, params} = do
appJsonToCM AppMessageJson {v, msgId, event, params} = do
eventTag <- strDecode $ encodeUtf8 event
chatMsgEvent <- msg eventTag
pure ChatMessage {msgId, chatMsgEvent}
pure ChatMessage {chatVRange = maybe chatInitialVRange fromChatVRange v, msgId, chatMsgEvent}
where
p :: FromJSON a => J.Key -> Either String a
p key = JT.parseEither (.: key) params
@@ -786,11 +802,11 @@ appJsonToCM AppMessageJson {msgId, event, params} = do
key .=? value = maybe id ((:) . (key .=)) value
chatToAppMessage :: forall e. MsgEncodingI e => ChatMessage e -> AppMessage e
chatToAppMessage ChatMessage {msgId, chatMsgEvent} = case encoding @e of
chatToAppMessage ChatMessage {chatVRange, msgId, chatMsgEvent} = case encoding @e of
SBinary ->
let (binaryMsgId, body) = toBody chatMsgEvent
in AMBinary AppMessageBinary {msgId = binaryMsgId, tag = B.head $ strEncode tag, body}
SJson -> AMJson AppMessageJson {msgId, event = textEncode tag, params = params chatMsgEvent}
SJson -> AMJson AppMessageJson {v = Just $ ChatVersionRange chatVRange, msgId, event = textEncode tag, params = params chatMsgEvent}
where
tag = toCMEventTag chatMsgEvent
o :: [(J.Key, J.Value)] -> J.Object
@@ -806,7 +822,7 @@ chatToAppMessage ChatMessage {msgId, chatMsgEvent} = case encoding @e of
XMsgUpdate msgId' content ttl live -> o $ ("ttl" .=? ttl) $ ("live" .=? live) ["msgId" .= msgId', "content" .= content]
XMsgDel msgId' memberId -> o $ ("memberId" .=? memberId) ["msgId" .= msgId']
XMsgDeleted -> JM.empty
XMsgReact msgId' memberId reaction add -> o $ ("memberId" .=? memberId) ["msgId" .= msgId', "reaction" .= reaction, "add" .= add]
XMsgReact msgId' memberId reaction add -> o $ ("memberId" .=? memberId) ["msgId" .= msgId', "reaction" .= reaction, "add" .= add]
XFile fileInv -> o ["file" .= fileInv]
XFileAcpt fileName -> o ["fileName" .= fileName]
XFileAcptInv sharedMsgId fileConnReq fileName -> o $ ("fileConnReq" .=? fileConnReq) ["msgId" .= sharedMsgId, "fileName" .= fileName]
src/Simplex/Chat/Store/Connections.hs
+25 -3
View File
@@ -1,4 +1,5 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
@@ -8,25 +9,31 @@
module Simplex.Chat.Store.Connections
( getConnectionEntity,
getConnectionsToSubscribe,
unsetConnectionToSubscribe,
)
where
import Control.Applicative ((<|>))
import Control.Monad
import Control.Monad.Except
import Data.Int (Int64)
import Data.Maybe (fromMaybe)
import Data.Maybe (catMaybes, fromMaybe)
import Data.Text (Text)
import Data.Time.Clock (UTCTime (..))
import Database.SQLite.Simple ((:.) (..))
import Database.SQLite.Simple (Only (..), (:.) (..))
import Database.SQLite.Simple.QQ (sql)
import Simplex.Chat.Store.Files
import Simplex.Chat.Store.Groups
import Simplex.Chat.Store.Profiles
import Simplex.Chat.Store.Shared
import Simplex.Chat.Protocol
import Simplex.Chat.Types
import Simplex.Chat.Types.Preferences
import Simplex.Messaging.Agent.Protocol (ConnId)
import Simplex.Messaging.Agent.Store.SQLite (firstRow, firstRow')
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
import Simplex.Messaging.Util (eitherToMaybe)
getConnectionEntity :: DB.Connection -> User -> AgentConnId -> ExceptT StoreError IO ConnectionEntity
getConnectionEntity db user@User {userId, userContactId} agentConnId = do
@@ -51,7 +58,8 @@ getConnectionEntity db user@User {userId, userContactId} agentConnId = do
db
[sql|
SELECT connection_id, agent_conn_id, conn_level, via_contact, via_user_contact_link, via_group_link, group_link_id, custom_user_profile_id,
conn_status, conn_type, local_alias, contact_id, group_member_id, snd_file_id, rcv_file_id, user_contact_link_id, created_at, security_code, security_code_verified_at, auth_err_counter
conn_status, conn_type, local_alias, contact_id, group_member_id, snd_file_id, rcv_file_id, user_contact_link_id, created_at, security_code, security_code_verified_at, auth_err_counter,
peer_chat_min_version, peer_chat_max_version
FROM connections
WHERE user_id = ? AND agent_conn_id = ?
|]
@@ -143,3 +151,17 @@ getConnectionEntity db user@User {userId, userContactId} agentConnId = do
userContact_ :: [(ConnReqContact, Maybe GroupId)] -> Either StoreError UserContact
userContact_ [(cReq, groupId)] = Right UserContact {userContactLinkId, connReqContact = cReq, groupId}
userContact_ _ = Left SEUserContactLinkNotFound
getConnectionsToSubscribe :: DB.Connection -> IO ([ConnId], [ConnectionEntity])
getConnectionsToSubscribe db = do
aConnIds <- map fromOnly <$> DB.query_ db "SELECT agent_conn_id FROM connections where to_subscribe = 1"
entities <- forM aConnIds $ \acId -> do
getUserByAConnId db acId >>= \case
Just user -> eitherToMaybe <$> runExceptT (getConnectionEntity db user acId)
Nothing -> pure Nothing
unsetConnectionToSubscribe db
let connIds = map (\(AgentConnId connId) -> connId) aConnIds
pure (connIds, catMaybes entities)
unsetConnectionToSubscribe :: DB.Connection -> IO ()
unsetConnectionToSubscribe db = DB.execute_ db "UPDATE connections SET to_subscribe = 0 WHERE to_subscribe = 1"
src/Simplex/Chat/Store/Direct.hs
+52 -27
View File
@@ -80,6 +80,8 @@ import Simplex.Chat.Types.Preferences
import Simplex.Messaging.Agent.Protocol (ConnId, InvitationId, UserId)
import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow)
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
import Simplex.Messaging.Protocol (SubscriptionMode (..))
import Simplex.Messaging.Version
getPendingContactConnection :: DB.Connection -> UserId -> Int64 -> ExceptT StoreError IO PendingContactConnection
getPendingContactConnection db userId connId = do
@@ -113,8 +115,8 @@ deletePendingContactConnection db userId connId =
|]
(userId, connId, ConnContact)
createConnReqConnection :: DB.Connection -> UserId -> ConnId -> ConnReqUriHash -> XContactId -> Maybe Profile -> Maybe GroupLinkId -> IO PendingContactConnection
createConnReqConnection db userId acId cReqHash xContactId incognitoProfile groupLinkId = do
createConnReqConnection :: DB.Connection -> UserId -> ConnId -> ConnReqUriHash -> XContactId -> Maybe Profile -> Maybe GroupLinkId -> SubscriptionMode -> IO PendingContactConnection
createConnReqConnection db userId acId cReqHash xContactId incognitoProfile groupLinkId subMode = do
createdAt <- getCurrentTime
customUserProfileId <- mapM (createIncognitoProfile_ db userId createdAt) incognitoProfile
let pccConnStatus = ConnJoined
@@ -123,10 +125,10 @@ createConnReqConnection db userId acId cReqHash xContactId incognitoProfile grou
[sql|
INSERT INTO connections (
user_id, agent_conn_id, conn_status, conn_type,
via_contact_uri_hash, xcontact_id, custom_user_profile_id, via_group_link, group_link_id, created_at, updated_at
) VALUES (?,?,?,?,?,?,?,?,?,?,?)
via_contact_uri_hash, xcontact_id, custom_user_profile_id, via_group_link, group_link_id, created_at, updated_at, to_subscribe
) VALUES (?,?,?,?,?,?,?,?,?,?,?,?)
|]
((userId, acId, pccConnStatus, ConnContact, cReqHash, xContactId) :. (customUserProfileId, isJust groupLinkId, groupLinkId, createdAt, createdAt))
((userId, acId, pccConnStatus, ConnContact, cReqHash, xContactId) :. (customUserProfileId, isJust groupLinkId, groupLinkId, createdAt, createdAt, subMode == SMOnlyCreate))
pccConnId <- insertedRowId db
pure PendingContactConnection {pccConnId, pccAgentConnId = AgentConnId acId, pccConnStatus, viaContactUri = True, viaUserContactLink = Nothing, groupLinkId, customUserProfileId, connReqInv = Nothing, localAlias = "", createdAt, updatedAt = createdAt}
@@ -148,7 +150,8 @@ getConnReqContactXContactId db user@User {userId} cReqHash = do
cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts,
-- Connection
c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.local_alias,
c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter
c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter,
c.peer_chat_min_version, c.peer_chat_max_version
FROM contacts ct
JOIN contact_profiles cp ON ct.contact_profile_id = cp.contact_profile_id
JOIN connections c ON c.contact_id = ct.contact_id
@@ -165,17 +168,17 @@ getConnReqContactXContactId db user@User {userId} cReqHash = do
"SELECT xcontact_id FROM connections WHERE user_id = ? AND via_contact_uri_hash = ? LIMIT 1"
(userId, cReqHash)
createDirectConnection :: DB.Connection -> User -> ConnId -> ConnReqInvitation -> ConnStatus -> Maybe Profile -> IO PendingContactConnection
createDirectConnection db User {userId} acId cReq pccConnStatus incognitoProfile = do
createDirectConnection :: DB.Connection -> User -> ConnId -> ConnReqInvitation -> ConnStatus -> Maybe Profile -> SubscriptionMode -> IO PendingContactConnection
createDirectConnection db User {userId} acId cReq pccConnStatus incognitoProfile subMode = do
createdAt <- getCurrentTime
customUserProfileId <- mapM (createIncognitoProfile_ db userId createdAt) incognitoProfile
DB.execute
db
[sql|
INSERT INTO connections
(user_id, agent_conn_id, conn_req_inv, conn_status, conn_type, custom_user_profile_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)
(user_id, agent_conn_id, conn_req_inv, conn_status, conn_type, custom_user_profile_id, created_at, updated_at, to_subscribe) VALUES (?,?,?,?,?,?,?,?,?)
|]
(userId, acId, cReq, pccConnStatus, ConnContact, customUserProfileId, createdAt, createdAt)
(userId, acId, cReq, pccConnStatus, ConnContact, customUserProfileId, createdAt, createdAt, subMode == SMOnlyCreate)
pccConnId <- insertedRowId db
pure PendingContactConnection {pccConnId, pccAgentConnId = AgentConnId acId, pccConnStatus, viaContactUri = False, viaUserContactLink = Nothing, groupLinkId = Nothing, customUserProfileId, connReqInv = Just cReq, localAlias = "", createdAt, updatedAt = createdAt}
@@ -416,8 +419,8 @@ getUserContacts db user@User {userId} = do
contactIds <- map fromOnly <$> DB.query db "SELECT contact_id FROM contacts WHERE user_id = ? AND deleted = 0" (Only userId)
rights <$> mapM (runExceptT . getContact db user) contactIds
createOrUpdateContactRequest :: DB.Connection -> User -> Int64 -> InvitationId -> Profile -> Maybe XContactId -> ExceptT StoreError IO ContactOrRequest
createOrUpdateContactRequest db user@User {userId} userContactLinkId invId Profile {displayName, fullName, image, contactLink, preferences} xContactId_ =
createOrUpdateContactRequest :: DB.Connection -> User -> Int64 -> InvitationId -> VersionRange -> Profile -> Maybe XContactId -> ExceptT StoreError IO ContactOrRequest
createOrUpdateContactRequest db user@User {userId} userContactLinkId invId (VersionRange minV maxV) Profile {displayName, fullName, image, contactLink, preferences} xContactId_ =
liftIO (maybeM getContact' xContactId_) >>= \case
Just contact -> pure $ CORContact contact
Nothing -> CORRequest <$> createOrUpdate_
@@ -446,10 +449,10 @@ createOrUpdateContactRequest db user@User {userId} userContactLinkId invId Profi
db
[sql|
INSERT INTO contact_requests
(user_contact_link_id, agent_invitation_id, contact_profile_id, local_display_name, user_id, created_at, updated_at, xcontact_id)
VALUES (?,?,?,?,?,?,?,?)
(user_contact_link_id, agent_invitation_id, peer_chat_min_version, peer_chat_max_version, contact_profile_id, local_display_name, user_id, created_at, updated_at, xcontact_id)
VALUES (?,?,?,?,?,?,?,?,?,?)
|]
(userContactLinkId, invId, profileId, ldn, userId, currentTs, currentTs, xContactId_)
(userContactLinkId, invId, minV, maxV, profileId, ldn, userId, currentTs, currentTs, xContactId_)
insertedRowId db
getContact' :: XContactId -> IO (Maybe Contact)
getContact' xContactId =
@@ -463,7 +466,8 @@ createOrUpdateContactRequest db user@User {userId} userContactLinkId invId Profi
cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts,
-- Connection
c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.local_alias,
c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter
c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter,
c.peer_chat_min_version, c.peer_chat_max_version
FROM contacts ct
JOIN contact_profiles cp ON ct.contact_profile_id = cp.contact_profile_id
LEFT JOIN connections c ON c.contact_id = ct.contact_id
@@ -480,7 +484,8 @@ createOrUpdateContactRequest db user@User {userId} userContactLinkId invId Profi
[sql|
SELECT
cr.contact_request_id, cr.local_display_name, cr.agent_invitation_id, cr.user_contact_link_id,
c.agent_conn_id, cr.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, cr.xcontact_id, p.preferences, cr.created_at, cr.updated_at
c.agent_conn_id, cr.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, cr.xcontact_id, p.preferences, cr.created_at, cr.updated_at,
cr.peer_chat_min_version, cr.peer_chat_max_version
FROM contact_requests cr
JOIN connections c USING (user_contact_link_id)
JOIN contact_profiles p USING (contact_profile_id)
@@ -494,10 +499,26 @@ createOrUpdateContactRequest db user@User {userId} userContactLinkId invId Profi
currentTs <- liftIO getCurrentTime
updateProfile currentTs
if displayName == oldDisplayName
then Right <$> DB.execute db "UPDATE contact_requests SET agent_invitation_id = ?, updated_at = ? WHERE user_id = ? AND contact_request_id = ?" (invId, currentTs, userId, cReqId)
then
Right
<$> DB.execute
db
[sql|
UPDATE contact_requests
SET agent_invitation_id = ?, peer_chat_min_version = ?, peer_chat_max_version = ?, updated_at = ?
WHERE user_id = ? AND contact_request_id = ?
|]
(invId, minV, maxV, currentTs, userId, cReqId)
else withLocalDisplayName db userId displayName $ \ldn ->
Right <$> do
DB.execute db "UPDATE contact_requests SET agent_invitation_id = ?, local_display_name = ?, updated_at = ? WHERE user_id = ? AND contact_request_id = ?" (invId, ldn, currentTs, userId, cReqId)
DB.execute
db
[sql|
UPDATE contact_requests
SET agent_invitation_id = ?, peer_chat_min_version = ?, peer_chat_max_version = ?, local_display_name = ?, updated_at = ?
WHERE user_id = ? AND contact_request_id = ?
|]
(invId, minV, maxV, ldn, currentTs, userId, cReqId)
DB.execute db "DELETE FROM display_names WHERE local_display_name = ? AND user_id = ?" (oldLdn, userId)
where
updateProfile currentTs =
@@ -532,7 +553,8 @@ getContactRequest db User {userId} contactRequestId =
[sql|
SELECT
cr.contact_request_id, cr.local_display_name, cr.agent_invitation_id, cr.user_contact_link_id,
c.agent_conn_id, cr.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, cr.xcontact_id, p.preferences, cr.created_at, cr.updated_at
c.agent_conn_id, cr.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, cr.xcontact_id, p.preferences, cr.created_at, cr.updated_at,
cr.peer_chat_min_version, cr.peer_chat_max_version
FROM contact_requests cr
JOIN connections c USING (user_contact_link_id)
JOIN contact_profiles p USING (contact_profile_id)
@@ -571,8 +593,8 @@ deleteContactRequest db User {userId} contactRequestId = do
(userId, userId, contactRequestId)
DB.execute db "DELETE FROM contact_requests WHERE user_id = ? AND contact_request_id = ?" (userId, contactRequestId)
createAcceptedContact :: DB.Connection -> User -> ConnId -> ContactName -> ProfileId -> Profile -> Int64 -> Maybe XContactId -> Maybe IncognitoProfile -> IO Contact
createAcceptedContact db user@User {userId, profile = LocalProfile {preferences}} agentConnId localDisplayName profileId profile userContactLinkId xContactId incognitoProfile = do
createAcceptedContact :: DB.Connection -> User -> ConnId -> VersionRange -> ContactName -> ProfileId -> Profile -> Int64 -> Maybe XContactId -> Maybe IncognitoProfile -> SubscriptionMode -> IO Contact
createAcceptedContact db user@User {userId, profile = LocalProfile {preferences}} agentConnId cReqChatVRange localDisplayName profileId profile userContactLinkId xContactId incognitoProfile subMode = do
DB.execute db "DELETE FROM contact_requests WHERE user_id = ? AND local_display_name = ?" (userId, localDisplayName)
createdAt <- getCurrentTime
customUserProfileId <- forM incognitoProfile $ \case
@@ -584,7 +606,7 @@ createAcceptedContact db user@User {userId, profile = LocalProfile {preferences}
"INSERT INTO contacts (user_id, local_display_name, contact_profile_id, enable_ntfs, user_preferences, created_at, updated_at, chat_ts, xcontact_id) VALUES (?,?,?,?,?,?,?,?,?)"
(userId, localDisplayName, profileId, True, userPreferences, createdAt, createdAt, createdAt, xContactId)
contactId <- insertedRowId db
activeConn <- createConnection_ db userId ConnContact (Just contactId) agentConnId Nothing (Just userContactLinkId) customUserProfileId 0 createdAt
activeConn <- createConnection_ db userId ConnContact (Just contactId) agentConnId cReqChatVRange Nothing (Just userContactLinkId) customUserProfileId 0 createdAt subMode
let mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn
pure $ Contact {contactId, localDisplayName, profile = toLocalProfile profileId profile "", activeConn, viaGroup = Nothing, contactUsed = False, chatSettings = defaultChatSettings, userPreferences, mergedPreferences, createdAt = createdAt, updatedAt = createdAt, chatTs = Just createdAt}
@@ -600,7 +622,7 @@ getContact_ :: DB.Connection -> User -> Int64 -> Bool -> ExceptT StoreError IO C
getContact_ db user@User {userId} contactId deleted =
ExceptT . fmap join . firstRow (toContactOrError user) (SEContactNotFound contactId) $
DB.query
db
db
[sql|
SELECT
-- Contact
@@ -608,7 +630,8 @@ getContact_ db user@User {userId} contactId deleted =
cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts,
-- Connection
c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.local_alias,
c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter
c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter,
c.peer_chat_min_version, c.peer_chat_max_version
FROM contacts ct
JOIN contact_profiles cp ON ct.contact_profile_id = cp.contact_profile_id
LEFT JOIN connections c ON c.contact_id = ct.contact_id
@@ -656,7 +679,8 @@ getContactConnections db userId Contact {contactId} =
db
[sql|
SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id,
c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter
c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter,
c.peer_chat_min_version, c.peer_chat_max_version
FROM connections c
JOIN contacts ct ON ct.contact_id = c.contact_id
WHERE c.user_id = ? AND ct.user_id = ? AND ct.contact_id = ?
@@ -672,7 +696,8 @@ getConnectionById db User {userId} connId = ExceptT $ do
db
[sql|
SELECT connection_id, agent_conn_id, conn_level, via_contact, via_user_contact_link, via_group_link, group_link_id, custom_user_profile_id,
conn_status, conn_type, local_alias, contact_id, group_member_id, snd_file_id, rcv_file_id, user_contact_link_id, created_at, security_code, security_code_verified_at, auth_err_counter
conn_status, conn_type, local_alias, contact_id, group_member_id, snd_file_id, rcv_file_id, user_contact_link_id, created_at, security_code, security_code_verified_at, auth_err_counter,
peer_chat_min_version, peer_chat_max_version
FROM connections
WHERE user_id = ? AND connection_id = ?
|]
src/Simplex/Chat/Store/Files.hs
+57 -44
View File
@@ -56,6 +56,7 @@ module Simplex.Chat.Store.Files
startRcvInlineFT,
xftpAcceptRcvFT,
setRcvFileToReceive,
setFileCryptoArgs,
getRcvFilesToReceive,
setRcvFTAgentDeleted,
updateRcvFileStatus,
@@ -86,18 +87,22 @@ 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
import Simplex.Messaging.Protocol (SubscriptionMode (..))
getLiveSndFileTransfers :: DB.Connection -> User -> IO [SndFileTransfer]
getLiveSndFileTransfers db User {userId} = do
@@ -154,8 +159,8 @@ getPendingSndChunks db fileId connId =
|]
(fileId, connId)
createSndDirectFileTransfer :: DB.Connection -> UserId -> Contact -> FilePath -> FileInvitation -> Maybe ConnId -> Integer -> IO FileTransferMeta
createSndDirectFileTransfer db userId Contact {contactId} filePath FileInvitation {fileName, fileSize, fileInline} acId_ chunkSize = do
createSndDirectFileTransfer :: DB.Connection -> UserId -> Contact -> FilePath -> FileInvitation -> Maybe ConnId -> Integer -> SubscriptionMode -> IO FileTransferMeta
createSndDirectFileTransfer db userId Contact {contactId} filePath FileInvitation {fileName, fileSize, fileInline} acId_ chunkSize subMode = do
currentTs <- getCurrentTime
DB.execute
db
@@ -163,7 +168,7 @@ createSndDirectFileTransfer db userId Contact {contactId} filePath FileInvitatio
((userId, contactId, fileName, filePath, fileSize, chunkSize) :. (fileInline, CIFSSndStored, FPSMP, currentTs, currentTs))
fileId <- insertedRowId db
forM_ acId_ $ \acId -> do
Connection {connId} <- createSndFileConnection_ db userId fileId acId
Connection {connId} <- createSndFileConnection_ db userId fileId acId subMode
let fileStatus = FSNew
DB.execute
db
@@ -171,10 +176,10 @@ createSndDirectFileTransfer db userId Contact {contactId} filePath FileInvitatio
(fileId, fileStatus, fileInline, connId, currentTs, currentTs)
pure FileTransferMeta {fileId, xftpSndFile = Nothing, fileName, filePath, fileSize, fileInline, chunkSize, cancelled = False}
createSndDirectFTConnection :: DB.Connection -> User -> Int64 -> (CommandId, ConnId) -> IO ()
createSndDirectFTConnection db user@User {userId} fileId (cmdId, acId) = do
createSndDirectFTConnection :: DB.Connection -> User -> Int64 -> (CommandId, ConnId) -> SubscriptionMode -> IO ()
createSndDirectFTConnection db user@User {userId} fileId (cmdId, acId) subMode = do
currentTs <- getCurrentTime
Connection {connId} <- createSndFileConnection_ db userId fileId acId
Connection {connId} <- createSndFileConnection_ db userId fileId acId subMode
setCommandConnId db user cmdId connId
DB.execute
db
@@ -191,10 +196,10 @@ createSndGroupFileTransfer db userId GroupInfo {groupId} filePath FileInvitation
fileId <- insertedRowId db
pure FileTransferMeta {fileId, xftpSndFile = Nothing, fileName, filePath, fileSize, fileInline, chunkSize, cancelled = False}
createSndGroupFileTransferConnection :: DB.Connection -> User -> Int64 -> (CommandId, ConnId) -> GroupMember -> IO ()
createSndGroupFileTransferConnection db user@User {userId} fileId (cmdId, acId) GroupMember {groupMemberId} = do
createSndGroupFileTransferConnection :: DB.Connection -> User -> Int64 -> (CommandId, ConnId) -> GroupMember -> SubscriptionMode -> IO ()
createSndGroupFileTransferConnection db user@User {userId} fileId (cmdId, acId) GroupMember {groupMemberId} subMode = do
currentTs <- getCurrentTime
Connection {connId} <- createSndFileConnection_ db userId fileId acId
Connection {connId} <- createSndFileConnection_ db userId fileId acId subMode
setCommandConnId db user cmdId connId
DB.execute
db
@@ -259,14 +264,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}
@@ -420,10 +425,10 @@ getChatRefByFileId db User {userId} fileId =
|]
(userId, fileId)
createSndFileConnection_ :: DB.Connection -> UserId -> Int64 -> ConnId -> IO Connection
createSndFileConnection_ db userId fileId agentConnId = do
createSndFileConnection_ :: DB.Connection -> UserId -> Int64 -> ConnId -> SubscriptionMode -> IO Connection
createSndFileConnection_ db userId fileId agentConnId subMode = do
currentTs <- getCurrentTime
createConnection_ db userId ConnSndFile (Just fileId) agentConnId Nothing Nothing Nothing 0 currentTs
createConnection_ db userId ConnSndFile (Just fileId) agentConnId chatInitialVRange Nothing Nothing Nothing 0 currentTs subMode
updateSndFileStatus :: DB.Connection -> SndFileTransfer -> FileStatus -> IO ()
updateSndFileStatus db SndFileTransfer {fileId, connId} status = do
@@ -480,10 +485,9 @@ createRcvFileTransfer :: DB.Connection -> UserId -> Contact -> FileInvitation ->
createRcvFileTransfer db userId Contact {contactId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileConnReq, fileInline, fileDescr} rcvFileInline chunkSize = do
currentTs <- liftIO getCurrentTime
rfd_ <- mapM (createRcvFD_ db userId currentTs) fileDescr
let getFDId :: RcvFileDescr -> Int64
getFDId RcvFileDescr{fileDescrId} = fileDescrId
let rfdId = getFDId <$> rfd_
xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId = Nothing, agentRcvFileDeleted = False}) <$> rfd_
let rfdId = (\RcvFileDescr {fileDescrId} -> fileDescrId) <$> rfd_
-- cryptoArgs = Nothing here, the decision to encrypt is made when receiving it
xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId = Nothing, agentRcvFileDeleted = False, cryptoArgs = Nothing}) <$> rfd_
fileProtocol = if isJust rfd_ then FPXFTP else FPSMP
fileId <- liftIO $ do
DB.execute
@@ -502,10 +506,9 @@ createRcvGroupFileTransfer :: DB.Connection -> UserId -> GroupMember -> FileInvi
createRcvGroupFileTransfer db userId GroupMember {groupId, groupMemberId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileConnReq, fileInline, fileDescr} rcvFileInline chunkSize = do
currentTs <- liftIO getCurrentTime
rfd_ <- mapM (createRcvFD_ db userId currentTs) fileDescr
let getFDId :: RcvFileDescr -> Int64
getFDId RcvFileDescr{fileDescrId} = fileDescrId
let rfdId = getFDId <$> rfd_
xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId = Nothing, agentRcvFileDeleted = False}) <$> rfd_
let rfdId = (\RcvFileDescr {fileDescrId} -> fileDescrId) <$> rfd_
-- cryptoArgs = Nothing here, the decision to encrypt is made when receiving it
xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId = Nothing, agentRcvFileDeleted = False, cryptoArgs = Nothing}) <$> rfd_
fileProtocol = if isJust rfd_ then FPXFTP else FPSMP
fileId <- liftIO $ do
DB.execute
@@ -606,7 +609,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
@@ -620,9 +623,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
@@ -635,7 +638,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
@@ -643,14 +647,14 @@ getRcvFileTransfer db User {userId} fileId = do
_ -> pure Nothing
cancelled = fromMaybe False cancelled_
acceptRcvFileTransfer :: DB.Connection -> User -> Int64 -> (CommandId, ConnId) -> ConnStatus -> FilePath -> ExceptT StoreError IO AChatItem
acceptRcvFileTransfer db user@User {userId} fileId (cmdId, acId) connStatus filePath = ExceptT $ do
acceptRcvFileTransfer :: DB.Connection -> User -> Int64 -> (CommandId, ConnId) -> ConnStatus -> FilePath -> SubscriptionMode -> ExceptT StoreError IO AChatItem
acceptRcvFileTransfer db user@User {userId} fileId (cmdId, acId) connStatus filePath subMode = ExceptT $ do
currentTs <- getCurrentTime
acceptRcvFT_ db user fileId filePath Nothing currentTs
DB.execute
db
"INSERT INTO connections (agent_conn_id, conn_status, conn_type, rcv_file_id, user_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?)"
(acId, connStatus, ConnRcvFile, fileId, userId, currentTs, currentTs)
"INSERT INTO connections (agent_conn_id, conn_status, conn_type, rcv_file_id, user_id, created_at, updated_at, to_subscribe) VALUES (?,?,?,?,?,?,?,?)"
(acId, connStatus, ConnRcvFile, fileId, userId, currentTs, currentTs, subMode == SMOnlyCreate)
connId <- insertedRowId db
setCommandConnId db user cmdId connId
runExceptT $ getChatItemByFileId db user fileId
@@ -689,13 +693,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
@@ -848,15 +860,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]
src/Simplex/Chat/Store/Groups.hs
+123 -107
View File
@@ -86,6 +86,7 @@ module Simplex.Chat.Store.Groups
updateGroupSettings,
getXGrpMemIntroContDirect,
getXGrpMemIntroContGroup,
getHostConnId,
)
where
@@ -109,7 +110,9 @@ import Simplex.Messaging.Agent.Protocol (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.Protocol (SubscriptionMode)
import Simplex.Messaging.Util (eitherToMaybe)
import Simplex.Messaging.Version
import UnliftIO.STM
type GroupInfoRow = (Int64, GroupName, GroupName, Text, Maybe Text, Maybe ImageData, Maybe ProfileId, Maybe Bool, Maybe Bool, Bool, Maybe GroupPreferences) :. (UTCTime, UTCTime, Maybe UTCTime) :. GroupMemberRow
@@ -138,8 +141,8 @@ toMaybeGroupMember userContactId ((Just groupMemberId, Just groupId, Just member
Just $ toGroupMember userContactId ((groupMemberId, groupId, memberId, memberRole, memberCategory, memberStatus) :. (invitedById, localDisplayName, memberContactId, memberContactProfileId, profileId, displayName, fullName, image, contactLink, localAlias, contactPreferences))
toMaybeGroupMember _ _ = Nothing
createGroupLink :: DB.Connection -> User -> GroupInfo -> ConnId -> ConnReqContact -> GroupLinkId -> GroupMemberRole -> ExceptT StoreError IO ()
createGroupLink db User {userId} groupInfo@GroupInfo {groupId, localDisplayName} agentConnId cReq groupLinkId memberRole =
createGroupLink :: DB.Connection -> User -> GroupInfo -> ConnId -> ConnReqContact -> GroupLinkId -> GroupMemberRole -> SubscriptionMode -> ExceptT StoreError IO ()
createGroupLink db User {userId} groupInfo@GroupInfo {groupId, localDisplayName} agentConnId cReq groupLinkId memberRole subMode =
checkConstraint (SEDuplicateGroupLink groupInfo) . liftIO $ do
currentTs <- getCurrentTime
DB.execute
@@ -147,7 +150,7 @@ createGroupLink db User {userId} groupInfo@GroupInfo {groupId, localDisplayName}
"INSERT INTO user_contact_links (user_id, group_id, group_link_id, local_display_name, conn_req_contact, group_link_member_role, auto_accept, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)"
(userId, groupId, groupLinkId, "group_link_" <> localDisplayName, cReq, memberRole, True, currentTs, currentTs)
userContactLinkId <- insertedRowId db
void $ createConnection_ db userId ConnUserContact (Just userContactLinkId) agentConnId Nothing Nothing Nothing 0 currentTs
void $ createConnection_ db userId ConnUserContact (Just userContactLinkId) agentConnId chatInitialVRange Nothing Nothing Nothing 0 currentTs subMode
getGroupLinkConnection :: DB.Connection -> User -> GroupInfo -> ExceptT StoreError IO Connection
getGroupLinkConnection db User {userId} groupInfo@GroupInfo {groupId} =
@@ -156,7 +159,8 @@ getGroupLinkConnection db User {userId} groupInfo@GroupInfo {groupId} =
db
[sql|
SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id,
c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter
c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter,
c.peer_chat_min_version, c.peer_chat_max_version
FROM connections c
JOIN user_contact_links uc ON c.user_contact_link_id = uc.user_contact_link_id
WHERE c.user_id = ? AND uc.user_id = ? AND uc.group_id = ?
@@ -237,7 +241,8 @@ getGroupAndMember db User {userId, userContactId} groupMemberId =
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, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences,
c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id,
c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter
c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter,
c.peer_chat_min_version, c.peer_chat_max_version
FROM group_members m
JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id)
JOIN groups g ON g.group_id = m.group_id
@@ -483,20 +488,21 @@ getUserGroupsWithSummary db user _contactId_ search_ =
-- the statuses on non-current members should match memberCurrent' function
getGroupSummary :: DB.Connection -> User -> GroupId -> IO GroupSummary
getGroupSummary db User {userId} groupId = do
currentMembers_ <- maybeFirstRow fromOnly $
DB.query
db
[sql|
SELECT count (m.group_member_id)
FROM groups g
JOIN group_members m USING (group_id)
WHERE g.user_id = ?
AND g.group_id = ?
AND m.member_status != ?
AND m.member_status != ?
AND m.member_status != ?
|]
(userId, groupId, GSMemRemoved, GSMemLeft, GSMemInvited)
currentMembers_ <-
maybeFirstRow fromOnly $
DB.query
db
[sql|
SELECT count (m.group_member_id)
FROM groups g
JOIN group_members m USING (group_id)
WHERE g.user_id = ?
AND g.group_id = ?
AND m.member_status != ?
AND m.member_status != ?
AND m.member_status != ?
|]
(userId, groupId, GSMemRemoved, GSMemLeft, GSMemInvited)
pure GroupSummary {currentMembers = fromMaybe 0 currentMembers_}
getContactGroupPreferences :: DB.Connection -> User -> Contact -> IO [FullGroupPreferences]
@@ -529,13 +535,14 @@ groupMemberQuery =
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, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences,
c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id,
c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter
c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter,
c.peer_chat_min_version, c.peer_chat_max_version
FROM group_members m
JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id)
LEFT JOIN connections c ON c.connection_id = (
SELECT max(cc.connection_id)
FROM connections cc
where cc.user_id = ? AND cc.group_member_id = m.group_member_id
WHERE cc.user_id = ? AND cc.group_member_id = m.group_member_id
)
|]
@@ -613,12 +620,12 @@ getGroupInvitation db user groupId =
firstRow fromOnly (SEGroupNotFound groupId) $
DB.query db "SELECT g.inv_queue_info FROM groups g WHERE g.group_id = ? AND g.user_id = ?" (groupId, userId)
createNewContactMember :: DB.Connection -> TVar ChaChaDRG -> User -> GroupId -> Contact -> GroupMemberRole -> ConnId -> ConnReqInvitation -> ExceptT StoreError IO GroupMember
createNewContactMember db gVar User {userId, userContactId} groupId Contact {contactId, localDisplayName, profile} memberRole agentConnId connRequest =
createNewContactMember :: DB.Connection -> TVar ChaChaDRG -> User -> GroupId -> Contact -> GroupMemberRole -> ConnId -> ConnReqInvitation -> SubscriptionMode -> ExceptT StoreError IO GroupMember
createNewContactMember db gVar User {userId, userContactId} groupId Contact {contactId, localDisplayName, profile, activeConn = Connection {peerChatVRange}} memberRole agentConnId connRequest subMode =
createWithRandomId gVar $ \memId -> do
createdAt <- liftIO getCurrentTime
member@GroupMember {groupMemberId} <- createMember_ (MemberId memId) createdAt
void $ createMemberConnection_ db userId groupMemberId agentConnId Nothing 0 createdAt
void $ createMemberConnection_ db userId groupMemberId agentConnId peerChatVRange Nothing 0 createdAt subMode
pure member
where
createMember_ memberId createdAt = do
@@ -653,13 +660,13 @@ createNewContactMember db gVar User {userId, userContactId} groupId Contact {con
:. (userId, localDisplayName, contactId, localProfileId profile, connRequest, createdAt, createdAt)
)
createNewContactMemberAsync :: DB.Connection -> TVar ChaChaDRG -> User -> GroupId -> Contact -> GroupMemberRole -> (CommandId, ConnId) -> ExceptT StoreError IO ()
createNewContactMemberAsync db gVar user@User {userId, userContactId} groupId Contact {contactId, localDisplayName, profile} memberRole (cmdId, agentConnId) =
createNewContactMemberAsync :: DB.Connection -> TVar ChaChaDRG -> User -> GroupId -> Contact -> GroupMemberRole -> (CommandId, ConnId) -> VersionRange -> SubscriptionMode -> ExceptT StoreError IO ()
createNewContactMemberAsync db gVar user@User {userId, userContactId} groupId Contact {contactId, localDisplayName, profile} memberRole (cmdId, agentConnId) peerChatVRange subMode =
createWithRandomId gVar $ \memId -> do
createdAt <- liftIO getCurrentTime
insertMember_ (MemberId memId) createdAt
groupMemberId <- liftIO $ insertedRowId db
Connection {connId} <- createMemberConnection_ db userId groupMemberId agentConnId Nothing 0 createdAt
Connection {connId} <- createMemberConnection_ db userId groupMemberId agentConnId peerChatVRange Nothing 0 createdAt subMode
setCommandConnId db user cmdId connId
where
insertMember_ memberId createdAt =
@@ -675,30 +682,32 @@ createNewContactMemberAsync db gVar user@User {userId, userContactId} groupId Co
:. (userId, localDisplayName, contactId, localProfileId profile, createdAt, createdAt)
)
getContactViaMember :: DB.Connection -> User -> GroupMember -> IO (Maybe Contact)
getContactViaMember :: DB.Connection -> User -> GroupMember -> ExceptT StoreError IO Contact
getContactViaMember db user@User {userId} GroupMember {groupMemberId} =
maybeFirstRow (toContact user) $
DB.query
db
[sql|
SELECT
-- Contact
ct.contact_id, ct.contact_profile_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, ct.contact_used, ct.enable_ntfs, ct.send_rcpts, ct.favorite,
cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts,
-- Connection
c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.local_alias,
c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter
FROM contacts ct
JOIN contact_profiles cp ON cp.contact_profile_id = ct.contact_profile_id
JOIN connections c ON c.connection_id = (
SELECT max(cc.connection_id)
FROM connections cc
where cc.contact_id = ct.contact_id
)
JOIN group_members m ON m.contact_id = ct.contact_id
WHERE ct.user_id = ? AND m.group_member_id = ? AND ct.deleted = 0
|]
(userId, groupMemberId)
ExceptT $
firstRow (toContact user) (SEContactNotFoundByMemberId groupMemberId) $
DB.query
db
[sql|
SELECT
-- Contact
ct.contact_id, ct.contact_profile_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, ct.contact_used, ct.enable_ntfs, ct.send_rcpts, ct.favorite,
cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts,
-- Connection
c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.local_alias,
c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter,
c.peer_chat_min_version, c.peer_chat_max_version
FROM contacts ct
JOIN contact_profiles cp ON cp.contact_profile_id = ct.contact_profile_id
JOIN connections c ON c.connection_id = (
SELECT max(cc.connection_id)
FROM connections cc
where cc.contact_id = ct.contact_id
)
JOIN group_members m ON m.contact_id = ct.contact_id
WHERE ct.user_id = ? AND m.group_member_id = ? AND ct.deleted = 0
|]
(userId, groupMemberId)
setNewContactMemberConnRequest :: DB.Connection -> User -> GroupMember -> ConnReqInvitation -> IO ()
setNewContactMemberConnRequest db User {userId} GroupMember {groupMemberId} connRequest = do
@@ -710,15 +719,15 @@ getMemberInvitation db User {userId} groupMemberId =
fmap join . maybeFirstRow fromOnly $
DB.query db "SELECT sent_inv_queue_info FROM group_members WHERE group_member_id = ? AND user_id = ?" (groupMemberId, userId)
createMemberConnection :: DB.Connection -> UserId -> GroupMember -> ConnId -> IO ()
createMemberConnection db userId GroupMember {groupMemberId} agentConnId = do
createMemberConnection :: DB.Connection -> UserId -> GroupMember -> ConnId -> VersionRange -> SubscriptionMode -> IO ()
createMemberConnection db userId GroupMember {groupMemberId} agentConnId peerChatVRange subMode = do
currentTs <- getCurrentTime
void $ createMemberConnection_ db userId groupMemberId agentConnId Nothing 0 currentTs
void $ createMemberConnection_ db userId groupMemberId agentConnId peerChatVRange Nothing 0 currentTs subMode
createMemberConnectionAsync :: DB.Connection -> User -> GroupMemberId -> (CommandId, ConnId) -> IO ()
createMemberConnectionAsync db user@User {userId} groupMemberId (cmdId, agentConnId) = do
createMemberConnectionAsync :: DB.Connection -> User -> GroupMemberId -> (CommandId, ConnId) -> VersionRange -> SubscriptionMode -> IO ()
createMemberConnectionAsync db user@User {userId} groupMemberId (cmdId, agentConnId) peerChatVRange subMode = do
currentTs <- getCurrentTime
Connection {connId} <- createMemberConnection_ db userId groupMemberId agentConnId Nothing 0 currentTs
Connection {connId} <- createMemberConnection_ db userId groupMemberId agentConnId peerChatVRange Nothing 0 currentTs subMode
setCommandConnId db user cmdId connId
updateGroupMemberStatus :: DB.Connection -> UserId -> GroupMember -> GroupMemberStatus -> IO ()
@@ -738,25 +747,30 @@ updateGroupMemberStatusById db userId groupMemberId memStatus = do
-- | add new member with profile
createNewGroupMember :: DB.Connection -> User -> GroupInfo -> MemberInfo -> GroupMemberCategory -> GroupMemberStatus -> ExceptT StoreError IO GroupMember
createNewGroupMember db user@User {userId} gInfo memInfo@(MemberInfo _ _ Profile {displayName, fullName, image, contactLink, preferences}) memCategory memStatus =
ExceptT . withLocalDisplayName db userId displayName $ \localDisplayName -> do
currentTs <- getCurrentTime
createNewGroupMember db user gInfo memInfo memCategory memStatus = do
currentTs <- liftIO getCurrentTime
(localDisplayName, memProfileId) <- createNewMemberProfile_ db user memInfo currentTs
let newMember =
NewGroupMember
{ memInfo,
memCategory,
memStatus,
memInvitedBy = IBUnknown,
localDisplayName,
memContactId = Nothing,
memProfileId
}
liftIO $ createNewMember_ db user gInfo newMember currentTs
createNewMemberProfile_ :: DB.Connection -> User -> MemberInfo -> UTCTime -> ExceptT StoreError IO (Text, ProfileId)
createNewMemberProfile_ db User {userId} (MemberInfo _ _ _ Profile {displayName, fullName, image, contactLink, preferences}) createdAt =
ExceptT . withLocalDisplayName db userId displayName $ \ldn -> do
DB.execute
db
"INSERT INTO contact_profiles (display_name, full_name, image, contact_link, user_id, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)"
(displayName, fullName, image, contactLink, userId, preferences, currentTs, currentTs)
memProfileId <- insertedRowId db
let newMember =
NewGroupMember
{ memInfo,
memCategory,
memStatus,
memInvitedBy = IBUnknown,
localDisplayName,
memContactId = Nothing,
memProfileId
}
Right <$> createNewMember_ db user gInfo newMember currentTs
(displayName, fullName, image, contactLink, userId, preferences, createdAt, createdAt)
profileId <- insertedRowId db
pure $ Right (ldn, profileId)
createNewMember_ :: DB.Connection -> User -> GroupInfo -> NewGroupMember -> UTCTime -> IO GroupMember
createNewMember_
@@ -764,7 +778,7 @@ createNewMember_
User {userId, userContactId}
GroupInfo {groupId}
NewGroupMember
{ memInfo = MemberInfo memberId memberRole memberProfile,
{ memInfo = MemberInfo memberId memberRole _ memberProfile,
memCategory = memberCategory,
memStatus = memberStatus,
memInvitedBy = invitedBy,
@@ -908,47 +922,41 @@ getIntroduction_ db reMember toMember = ExceptT $ do
where
toIntro :: [(Int64, Maybe ConnReqInvitation, Maybe ConnReqInvitation, GroupMemberIntroStatus)] -> Either StoreError GroupMemberIntro
toIntro [(introId, groupConnReq, directConnReq, introStatus)] =
let introInvitation = IntroInvitation <$> groupConnReq <*> directConnReq
let introInvitation = IntroInvitation <$> groupConnReq <*> pure directConnReq
in Right GroupMemberIntro {introId, reMember, toMember, introStatus, introInvitation}
toIntro _ = Left SEIntroNotFound
createIntroReMember :: DB.Connection -> User -> GroupInfo -> GroupMember -> MemberInfo -> (CommandId, ConnId) -> (CommandId, ConnId) -> Maybe ProfileId -> ExceptT StoreError IO GroupMember
createIntroReMember db user@User {userId} gInfo@GroupInfo {groupId} _host@GroupMember {memberContactId, activeConn} memInfo@(MemberInfo _ _ memberProfile) (groupCmdId, groupAgentConnId) (directCmdId, directAgentConnId) customUserProfileId = do
let cLevel = 1 + case activeConn of
Just (Connection{connLevel}) -> connLevel
_ -> 0
createIntroReMember :: DB.Connection -> User -> GroupInfo -> GroupMember -> MemberInfo -> (CommandId, ConnId) -> Maybe (CommandId, ConnId) -> Maybe ProfileId -> SubscriptionMode -> ExceptT StoreError IO GroupMember
createIntroReMember db user@User {userId} gInfo@GroupInfo {groupId} _host@GroupMember {memberContactId, activeConn} memInfo@(MemberInfo _ _ memberChatVRange memberProfile) (groupCmdId, groupAgentConnId) directConnIds customUserProfileId subMode = do
let mcvr = maybe chatInitialVRange fromChatVRange memberChatVRange
cLevel = 1 + maybe 0 (\Connection {connLevel} -> connLevel) activeConn
currentTs <- liftIO getCurrentTime
Connection {connId = directConnId} <- liftIO $ createConnection_ db userId ConnContact Nothing directAgentConnId memberContactId Nothing customUserProfileId cLevel currentTs
liftIO $ setCommandConnId db user directCmdId directConnId
(localDisplayName, contactId, memProfileId) <- createContact_ db userId directConnId memberProfile "" (Just groupId) currentTs Nothing
newMember <- case directConnIds of
Just (directCmdId, directAgentConnId) -> do
Connection {connId = directConnId} <- liftIO $ createConnection_ db userId ConnContact Nothing directAgentConnId mcvr memberContactId Nothing customUserProfileId cLevel currentTs subMode
liftIO $ setCommandConnId db user directCmdId directConnId
(localDisplayName, contactId, memProfileId) <- createContact_ db userId directConnId memberProfile "" (Just groupId) currentTs Nothing
pure $ NewGroupMember {memInfo, memCategory = GCPreMember, memStatus = GSMemIntroduced, memInvitedBy = IBUnknown, localDisplayName, memContactId = Just contactId, memProfileId}
Nothing -> do
(localDisplayName, memProfileId) <- createNewMemberProfile_ db user memInfo currentTs
pure $ NewGroupMember {memInfo, memCategory = GCPreMember, memStatus = GSMemIntroduced, memInvitedBy = IBUnknown, localDisplayName, memContactId = Nothing, memProfileId}
liftIO $ do
let newMember =
NewGroupMember
{ memInfo,
memCategory = GCPreMember,
memStatus = GSMemIntroduced,
memInvitedBy = IBUnknown,
localDisplayName,
memContactId = Just contactId,
memProfileId
}
member <- createNewMember_ db user gInfo newMember currentTs
conn@Connection {connId = groupConnId} <- createMemberConnection_ db userId (groupMemberId' member) groupAgentConnId memberContactId cLevel currentTs
conn@Connection {connId = groupConnId} <- createMemberConnection_ db userId (groupMemberId' member) groupAgentConnId mcvr memberContactId cLevel currentTs subMode
liftIO $ setCommandConnId db user groupCmdId groupConnId
pure (member :: GroupMember) {activeConn = Just conn}
createIntroToMemberContact :: DB.Connection -> User -> GroupMember -> GroupMember -> (CommandId, ConnId) -> (CommandId, ConnId) -> Maybe ProfileId -> IO ()
createIntroToMemberContact db user@User {userId} GroupMember {memberContactId = viaContactId, activeConn} _to@GroupMember {groupMemberId, localDisplayName} (groupCmdId, groupAgentConnId) (directCmdId, directAgentConnId) customUserProfileId = do
let cLevel = 1 + case activeConn of
Just (Connection{connLevel}) -> connLevel
_ -> 0
createIntroToMemberContact :: DB.Connection -> User -> GroupMember -> GroupMember -> VersionRange -> (CommandId, ConnId) -> Maybe (CommandId, ConnId) -> Maybe ProfileId -> SubscriptionMode -> IO ()
createIntroToMemberContact db user@User {userId} GroupMember {memberContactId = viaContactId, activeConn} _to@GroupMember {groupMemberId, localDisplayName} mcvr (groupCmdId, groupAgentConnId) directConnIds customUserProfileId subMode = do
let cLevel = 1 + maybe 0 (\Connection {connLevel} -> connLevel) activeConn
currentTs <- getCurrentTime
Connection {connId = groupConnId} <- createMemberConnection_ db userId groupMemberId groupAgentConnId viaContactId cLevel currentTs
Connection {connId = groupConnId} <- createMemberConnection_ db userId groupMemberId groupAgentConnId mcvr viaContactId cLevel currentTs subMode
setCommandConnId db user groupCmdId groupConnId
Connection {connId = directConnId} <- createConnection_ db userId ConnContact Nothing directAgentConnId viaContactId Nothing customUserProfileId cLevel currentTs
setCommandConnId db user directCmdId directConnId
contactId <- createMemberContact_ directConnId currentTs
updateMember_ contactId currentTs
forM_ directConnIds $ \(directCmdId, directAgentConnId) -> do
Connection {connId = directConnId} <- createConnection_ db userId ConnContact Nothing directAgentConnId mcvr viaContactId Nothing customUserProfileId cLevel currentTs subMode
setCommandConnId db user directCmdId directConnId
contactId <- createMemberContact_ directConnId currentTs
updateMember_ contactId currentTs
where
createMemberContact_ :: Int64 -> UTCTime -> IO Int64
createMemberContact_ connId ts = do
@@ -975,8 +983,8 @@ createIntroToMemberContact db user@User {userId} GroupMember {memberContactId =
|]
[":contact_id" := contactId, ":updated_at" := ts, ":group_member_id" := groupMemberId]
createMemberConnection_ :: DB.Connection -> UserId -> Int64 -> ConnId -> Maybe Int64 -> Int -> UTCTime -> IO Connection
createMemberConnection_ db userId groupMemberId agentConnId viaContact = createConnection_ db userId ConnMember (Just groupMemberId) agentConnId viaContact Nothing Nothing
createMemberConnection_ :: DB.Connection -> UserId -> Int64 -> ConnId -> VersionRange -> Maybe Int64 -> Int -> UTCTime -> SubscriptionMode -> IO Connection
createMemberConnection_ db userId groupMemberId agentConnId peerChatVRange viaContact = createConnection_ db userId ConnMember (Just groupMemberId) agentConnId peerChatVRange viaContact Nothing Nothing
getViaGroupMember :: DB.Connection -> User -> Contact -> IO (Maybe (GroupInfo, GroupMember))
getViaGroupMember db User {userId, userContactId} Contact {contactId} =
@@ -996,7 +1004,8 @@ getViaGroupMember db User {userId, userContactId} Contact {contactId} =
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, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences,
c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id,
c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter
c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter,
c.peer_chat_min_version, c.peer_chat_max_version
FROM group_members m
JOIN contacts ct ON ct.contact_id = m.contact_id
JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id)
@@ -1029,7 +1038,8 @@ getViaGroupContact db user@User {userId} GroupMember {groupMemberId} =
ct.contact_id, ct.contact_profile_id, ct.local_display_name, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, ct.via_group, ct.contact_used, ct.enable_ntfs, ct.send_rcpts, ct.favorite,
p.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts,
c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id,
c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter
c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter,
c.peer_chat_min_version, c.peer_chat_max_version
FROM contacts ct
JOIN contact_profiles p ON ct.contact_profile_id = p.contact_profile_id
JOIN connections c ON c.connection_id = (
@@ -1345,3 +1355,9 @@ getXGrpMemIntroContGroup db User {userId} GroupMember {groupMemberId} = do
toCont (hostConnId, connReq_) = case connReq_ of
Just connReq -> Just (hostConnId, connReq)
_ -> Nothing
getHostConnId :: DB.Connection -> User -> GroupId -> ExceptT StoreError IO GroupMemberId
getHostConnId db user@User {userId} groupId = do
hostMemberId <- getHostMemberId_ db user groupId
ExceptT . firstRow fromOnly (SEConnectionNotFoundByMemberId hostMemberId) $
DB.query db "SELECT connection_id FROM connections WHERE user_id = ? AND group_member_id = ?" (userId, hostMemberId)
src/Simplex/Chat/Store/Messages.hs
+25 -16
View File
@@ -15,7 +15,6 @@
module Simplex.Chat.Store.Messages
( getContactConnIds_,
getDirectChatReactions_,
toDirectChatItem,
-- * Message and chat item functions
deleteContactCIs,
@@ -126,6 +125,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
@@ -482,12 +483,13 @@ getDirectChatPreviews_ db user@User {userId} = do
-- Connection
c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.local_alias,
c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter,
c.peer_chat_min_version, c.peer_chat_max_version,
-- ChatStats
COALESCE(ChatStats.UnreadCount, 0), COALESCE(ChatStats.MinUnread, 0), ct.unread_chat,
-- 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
@@ -552,7 +554,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,
@@ -612,7 +614,8 @@ getContactRequestChatPreviews_ db User {userId} =
[sql|
SELECT
cr.contact_request_id, cr.local_display_name, cr.agent_invitation_id, cr.user_contact_link_id,
c.agent_conn_id, cr.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, cr.xcontact_id, p.preferences, cr.created_at, cr.updated_at
c.agent_conn_id, cr.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, cr.xcontact_id, p.preferences, cr.created_at, cr.updated_at,
cr.peer_chat_min_version, cr.peer_chat_max_version
FROM contact_requests cr
JOIN connections c ON c.user_contact_link_id = cr.user_contact_link_id
JOIN contact_profiles p ON p.contact_profile_id = cr.contact_profile_id
@@ -673,7 +676,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
@@ -702,7 +705,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
@@ -732,7 +735,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
@@ -954,7 +957,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)
@@ -975,7 +978,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
@@ -992,7 +995,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 =
@@ -1025,7 +1031,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_
@@ -1045,7 +1051,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 =
@@ -1145,7 +1154,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_
@@ -1153,7 +1162,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
@@ -1298,7 +1307,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
@@ -1473,7 +1482,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,
src/Simplex/Chat/Store/Migrations.hs
+7 -1
View File
@@ -76,6 +76,9 @@ 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.Chat.Migrations.M20230829_connections_chat_vrange
import Simplex.Chat.Migrations.M20230903_connections_to_subscribe
import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..))
schemaMigrations :: [(String, Query, Maybe Query)]
@@ -151,7 +154,10 @@ 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),
("20230829_connections_chat_vrange", m20230829_connections_chat_vrange, Just down_m20230829_connections_chat_vrange),
("20230903_connections_to_subscribe", m20230903_connections_to_subscribe, Just down_m20230903_connections_to_subscribe)
]
-- | The list of migrations in ascending order by date
src/Simplex/Chat/Store/Profiles.hs
+7 -5
View File
@@ -84,7 +84,7 @@ 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.Encoding.String
import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI (..))
import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI (..), SubscriptionMode)
import Simplex.Messaging.Transport.Client (TransportHost)
import Simplex.Messaging.Util (safeDecodeUtf8)
@@ -297,8 +297,8 @@ getUserContactProfiles db User {userId} =
toContactProfile :: (ContactName, Text, Maybe ImageData, Maybe ConnReqContact, Maybe Preferences) -> Profile
toContactProfile (displayName, fullName, image, contactLink, preferences) = Profile {displayName, fullName, image, contactLink, preferences}
createUserContactLink :: DB.Connection -> User -> ConnId -> ConnReqContact -> ExceptT StoreError IO ()
createUserContactLink db User {userId} agentConnId cReq =
createUserContactLink :: DB.Connection -> User -> ConnId -> ConnReqContact -> SubscriptionMode -> ExceptT StoreError IO ()
createUserContactLink db User {userId} agentConnId cReq subMode =
checkConstraint SEDuplicateContactLink . liftIO $ do
currentTs <- getCurrentTime
DB.execute
@@ -306,7 +306,7 @@ createUserContactLink db User {userId} agentConnId cReq =
"INSERT INTO user_contact_links (user_id, conn_req_contact, created_at, updated_at) VALUES (?,?,?,?)"
(userId, cReq, currentTs, currentTs)
userContactLinkId <- insertedRowId db
void $ createConnection_ db userId ConnUserContact (Just userContactLinkId) agentConnId Nothing Nothing Nothing 0 currentTs
void $ createConnection_ db userId ConnUserContact (Just userContactLinkId) agentConnId chatInitialVRange Nothing Nothing Nothing 0 currentTs subMode
getUserAddressConnections :: DB.Connection -> User -> ExceptT StoreError IO [Connection]
getUserAddressConnections db User {userId} = do
@@ -320,7 +320,8 @@ getUserAddressConnections db User {userId} = do
db
[sql|
SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id,
c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter
c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter,
c.peer_chat_min_version, c.peer_chat_max_version
FROM connections c
JOIN user_contact_links uc ON c.user_contact_link_id = uc.user_contact_link_id
WHERE c.user_id = ? AND uc.user_id = ? AND uc.local_display_name = '' AND uc.group_id IS NULL
@@ -335,6 +336,7 @@ getUserContactLinks db User {userId} =
[sql|
SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id,
c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter,
c.peer_chat_min_version, c.peer_chat_max_version,
uc.user_contact_link_id, uc.conn_req_contact, uc.group_id
FROM connections c
JOIN user_contact_links uc ON c.user_contact_link_id = uc.user_contact_link_id
src/Simplex/Chat/Store/Shared.hs
+34 -15
View File
@@ -18,8 +18,8 @@ import Control.Monad.IO.Class
import Crypto.Random (ChaChaDRG, randomBytesGenerate)
import Data.Aeson (ToJSON)
import qualified Data.Aeson as J
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Base64 as B64
import Data.ByteString.Char8 (ByteString)
import Data.Int (Int64)
import Data.Maybe (fromMaybe, isJust, listToMaybe)
import Data.Text (Text)
@@ -37,7 +37,9 @@ 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 Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
import Simplex.Messaging.Protocol (SubscriptionMode (..))
import Simplex.Messaging.Util (allFinally)
import Simplex.Messaging.Version
import UnliftIO.STM
-- These error type constructors must be added to mobile apps
@@ -51,6 +53,7 @@ data StoreError
| SEUserNotFoundByContactRequestId {contactRequestId :: Int64}
| SEContactNotFound {contactId :: ContactId}
| SEContactNotFoundByName {contactName :: ContactName}
| SEContactNotFoundByMemberId {groupMemberId :: GroupMemberId}
| SEContactNotReady {contactName :: ContactName}
| SEDuplicateContactLink
| SEUserContactLinkNotFound
@@ -78,6 +81,7 @@ data StoreError
| SERcvFileNotFoundXFTP {agentRcvFileId :: AgentRcvFileId}
| SEConnectionNotFound {agentConnId :: AgentConnId}
| SEConnectionNotFoundById {connId :: Int64}
| SEConnectionNotFoundByMemberId {groupMemberId :: GroupMemberId}
| SEPendingConnectionNotFound {connId :: Int64}
| SEIntroNotFound
| SEUniqueID
@@ -133,15 +137,16 @@ toFileInfo (fileId, fileStatus, filePath) = CIFileInfo {fileId, fileStatus, file
type EntityIdsRow = (Maybe Int64, Maybe Int64, Maybe Int64, Maybe Int64, Maybe Int64)
type ConnectionRow = (Int64, ConnId, Int, Maybe Int64, Maybe Int64, Bool, Maybe GroupLinkId, Maybe Int64, ConnStatus, ConnType, LocalAlias) :. EntityIdsRow :. (UTCTime, Maybe Text, Maybe UTCTime, Int)
type ConnectionRow = (Int64, ConnId, Int, Maybe Int64, Maybe Int64, Bool, Maybe GroupLinkId, Maybe Int64, ConnStatus, ConnType, LocalAlias) :. EntityIdsRow :. (UTCTime, Maybe Text, Maybe UTCTime, Int, Version, Version)
type MaybeConnectionRow = (Maybe Int64, Maybe ConnId, Maybe Int, Maybe Int64, Maybe Int64, Maybe Bool, Maybe GroupLinkId, Maybe Int64, Maybe ConnStatus, Maybe ConnType, Maybe LocalAlias) :. EntityIdsRow :. (Maybe UTCTime, Maybe Text, Maybe UTCTime, Maybe Int)
type MaybeConnectionRow = (Maybe Int64, Maybe ConnId, Maybe Int, Maybe Int64, Maybe Int64, Maybe Bool, Maybe GroupLinkId, Maybe Int64, Maybe ConnStatus, Maybe ConnType, Maybe LocalAlias) :. EntityIdsRow :. (Maybe UTCTime, Maybe Text, Maybe UTCTime, Maybe Int, Maybe Version, Maybe Version)
toConnection :: ConnectionRow -> Connection
toConnection ((connId, acId, connLevel, viaContact, viaUserContactLink, viaGroupLink, groupLinkId, customUserProfileId, connStatus, connType, localAlias) :. (contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId) :. (createdAt, code_, verifiedAt_, authErrCounter)) =
toConnection ((connId, acId, connLevel, viaContact, viaUserContactLink, viaGroupLink, groupLinkId, customUserProfileId, connStatus, connType, localAlias) :. (contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId) :. (createdAt, code_, verifiedAt_, authErrCounter, minVer, maxVer)) =
let entityId = entityId_ connType
connectionCode = SecurityCode <$> code_ <*> verifiedAt_
in Connection {connId, agentConnId = AgentConnId acId, connLevel, viaContact, viaUserContactLink, viaGroupLink, groupLinkId, customUserProfileId, connStatus, connType, localAlias, entityId, connectionCode, authErrCounter, createdAt}
peerChatVRange = fromMaybe (versionToRange maxVer) $ safeVersionRange minVer maxVer
in Connection {connId, agentConnId = AgentConnId acId, peerChatVRange, connLevel, viaContact, viaUserContactLink, viaGroupLink, groupLinkId, customUserProfileId, connStatus, connType, localAlias, entityId, connectionCode, authErrCounter, createdAt}
where
entityId_ :: ConnType -> Maybe Int64
entityId_ ConnContact = contactId
@@ -151,12 +156,12 @@ toConnection ((connId, acId, connLevel, viaContact, viaUserContactLink, viaGroup
entityId_ ConnUserContact = userContactLinkId
toMaybeConnection :: MaybeConnectionRow -> Maybe Connection
toMaybeConnection ((Just connId, Just agentConnId, Just connLevel, viaContact, viaUserContactLink, Just viaGroupLink, groupLinkId, customUserProfileId, Just connStatus, Just connType, Just localAlias) :. (contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId) :. (Just createdAt, code_, verifiedAt_, Just authErrCounter)) =
Just $ toConnection ((connId, agentConnId, connLevel, viaContact, viaUserContactLink, viaGroupLink, groupLinkId, customUserProfileId, connStatus, connType, localAlias) :. (contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId) :. (createdAt, code_, verifiedAt_, authErrCounter))
toMaybeConnection ((Just connId, Just agentConnId, Just connLevel, viaContact, viaUserContactLink, Just viaGroupLink, groupLinkId, customUserProfileId, Just connStatus, Just connType, Just localAlias) :. (contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId) :. (Just createdAt, code_, verifiedAt_, Just authErrCounter, Just minVer, Just maxVer)) =
Just $ toConnection ((connId, agentConnId, connLevel, viaContact, viaUserContactLink, viaGroupLink, groupLinkId, customUserProfileId, connStatus, connType, localAlias) :. (contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId) :. (createdAt, code_, verifiedAt_, authErrCounter, minVer, maxVer))
toMaybeConnection _ = Nothing
createConnection_ :: DB.Connection -> UserId -> ConnType -> Maybe Int64 -> ConnId -> Maybe ContactId -> Maybe Int64 -> Maybe ProfileId -> Int -> UTCTime -> IO Connection
createConnection_ db userId connType entityId acId viaContact viaUserContactLink customUserProfileId connLevel currentTs = do
createConnection_ :: DB.Connection -> UserId -> ConnType -> Maybe Int64 -> ConnId -> VersionRange -> Maybe ContactId -> Maybe Int64 -> Maybe ProfileId -> Int -> UTCTime -> SubscriptionMode -> IO Connection
createConnection_ db userId connType entityId acId peerChatVRange@(VersionRange minV maxV) viaContact viaUserContactLink customUserProfileId connLevel currentTs subMode = do
viaLinkGroupId :: Maybe Int64 <- fmap join . forM viaUserContactLink $ \ucLinkId ->
maybeFirstRow fromOnly $ DB.query db "SELECT group_id FROM user_contact_links WHERE user_id = ? AND user_contact_link_id = ? AND group_id IS NOT NULL" (userId, ucLinkId)
let viaGroupLink = isJust viaLinkGroupId
@@ -165,17 +170,30 @@ createConnection_ db userId connType entityId acId viaContact viaUserContactLink
[sql|
INSERT INTO connections (
user_id, agent_conn_id, conn_level, via_contact, via_user_contact_link, via_group_link, custom_user_profile_id, conn_status, conn_type,
contact_id, group_member_id, snd_file_id, rcv_file_id, user_contact_link_id, created_at, updated_at
) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
contact_id, group_member_id, snd_file_id, rcv_file_id, user_contact_link_id, created_at, updated_at,
peer_chat_min_version, peer_chat_max_version, to_subscribe
) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|]
( (userId, acId, connLevel, viaContact, viaUserContactLink, viaGroupLink, customUserProfileId, ConnNew, connType)
:. (ent ConnContact, ent ConnMember, ent ConnSndFile, ent ConnRcvFile, ent ConnUserContact, currentTs, currentTs)
:. (minV, maxV, subMode == SMOnlyCreate)
)
connId <- insertedRowId db
pure Connection {connId, agentConnId = AgentConnId acId, connType, entityId, viaContact, viaUserContactLink, viaGroupLink, groupLinkId = Nothing, customUserProfileId, connLevel, connStatus = ConnNew, localAlias = "", createdAt = currentTs, connectionCode = Nothing, authErrCounter = 0}
pure Connection {connId, agentConnId = AgentConnId acId, peerChatVRange, connType, entityId, viaContact, viaUserContactLink, viaGroupLink, groupLinkId = Nothing, customUserProfileId, connLevel, connStatus = ConnNew, localAlias = "", createdAt = currentTs, connectionCode = Nothing, authErrCounter = 0}
where
ent ct = if connType == ct then entityId else Nothing
setPeerChatVRange :: DB.Connection -> Int64 -> VersionRange -> IO ()
setPeerChatVRange db connId (VersionRange minVer maxVer) =
DB.execute
db
[sql|
UPDATE connections
SET peer_chat_min_version = ?, peer_chat_max_version = ?
WHERE connection_id = ?
|]
(minVer, maxVer, connId)
setCommandConnId :: DB.Connection -> User -> CommandId -> Int64 -> IO ()
setCommandConnId db User {userId} cmdId connId = do
updatedAt <- getCurrentTime
@@ -257,12 +275,13 @@ getProfileById db userId profileId =
toProfile :: (ContactName, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Maybe Preferences) -> LocalProfile
toProfile (displayName, fullName, image, contactLink, localAlias, preferences) = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias}
type ContactRequestRow = (Int64, ContactName, AgentInvId, Int64, AgentConnId, Int64, ContactName, Text, Maybe ImageData, Maybe ConnReqContact) :. (Maybe XContactId, Maybe Preferences, UTCTime, UTCTime)
type ContactRequestRow = (Int64, ContactName, AgentInvId, Int64, AgentConnId, Int64, ContactName, Text, Maybe ImageData, Maybe ConnReqContact) :. (Maybe XContactId, Maybe Preferences, UTCTime, UTCTime, Version, Version)
toContactRequest :: ContactRequestRow -> UserContactRequest
toContactRequest ((contactRequestId, localDisplayName, agentInvitationId, userContactLinkId, agentContactConnId, profileId, displayName, fullName, image, contactLink) :. (xContactId, preferences, createdAt, updatedAt)) = do
toContactRequest ((contactRequestId, localDisplayName, agentInvitationId, userContactLinkId, agentContactConnId, profileId, displayName, fullName, image, contactLink) :. (xContactId, preferences, createdAt, updatedAt, minVer, maxVer)) = do
let profile = Profile {displayName, fullName, image, contactLink, preferences}
in UserContactRequest {contactRequestId, agentInvitationId, userContactLinkId, agentContactConnId, localDisplayName, profileId, profile, xContactId, createdAt, updatedAt}
cReqChatVRange = fromMaybe (versionToRange maxVer) $ safeVersionRange minVer maxVer
in UserContactRequest {contactRequestId, agentInvitationId, userContactLinkId, agentContactConnId, cReqChatVRange, localDisplayName, profileId, profile, xContactId, createdAt, updatedAt}
userQuery :: Query
userQuery =
src/Simplex/Chat/Types.hs
+38 -12
View File
@@ -44,10 +44,12 @@ 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)
import Simplex.Messaging.Util ((<$?>))
import Simplex.Messaging.Version
class IsContact a where
contactId' :: a -> ContactId
@@ -233,6 +235,7 @@ data UserContactRequest = UserContactRequest
agentInvitationId :: AgentInvId,
userContactLinkId :: Int64,
agentContactConnId :: AgentConnId, -- connection id of user contact
cReqChatVRange :: VersionRange,
localDisplayName :: ContactName,
profileId :: Int64,
profile :: Profile,
@@ -347,11 +350,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}
@@ -538,24 +542,31 @@ instance ToJSON MemberIdRole where toEncoding = J.genericToEncoding J.defaultOpt
data IntroInvitation = IntroInvitation
{ groupConnReq :: ConnReqInvitation,
directConnReq :: ConnReqInvitation
directConnReq :: Maybe ConnReqInvitation
}
deriving (Eq, Show, Generic, FromJSON)
instance ToJSON IntroInvitation where toEncoding = J.genericToEncoding J.defaultOptions
instance ToJSON IntroInvitation where
toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
data MemberInfo = MemberInfo
{ memberId :: MemberId,
memberRole :: GroupMemberRole,
v :: Maybe ChatVersionRange,
profile :: Profile
}
deriving (Eq, Show, Generic, FromJSON)
instance ToJSON MemberInfo where toEncoding = J.genericToEncoding J.defaultOptions
instance ToJSON MemberInfo where
toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
memberInfo :: GroupMember -> MemberInfo
memberInfo GroupMember {memberId, memberRole, memberProfile} =
MemberInfo memberId memberRole (fromLocalProfile memberProfile)
memberInfo GroupMember {memberId, memberRole, memberProfile, activeConn} =
MemberInfo memberId memberRole memberChatVRange (fromLocalProfile memberProfile)
where
memberChatVRange = ChatVersionRange . peerChatVRange <$> activeConn
data ReceivedGroupInvitation = ReceivedGroupInvitation
{ fromMember :: GroupMember,
@@ -955,7 +966,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)
@@ -1110,7 +1122,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)
@@ -1156,6 +1169,7 @@ type ConnReqContact = ConnectionRequestUri 'CMContact
data Connection = Connection
{ connId :: Int64,
agentConnId :: AgentConnId,
peerChatVRange :: VersionRange,
connLevel :: Int,
viaContact :: Maybe Int64, -- group member contact ID, if not direct connection
viaUserContactLink :: Maybe Int64, -- user contact link ID, if connected via "user address"
@@ -1466,3 +1480,15 @@ instance ProtocolTypeI p => ToJSON (ServerCfg p) where
instance ProtocolTypeI p => FromJSON (ServerCfg p) where
parseJSON = J.genericParseJSON J.defaultOptions {J.omitNothingFields = True}
newtype ChatVersionRange = ChatVersionRange {fromChatVRange :: VersionRange} deriving (Eq, Show)
chatInitialVRange :: VersionRange
chatInitialVRange = versionToRange 1
instance FromJSON ChatVersionRange where
parseJSON v = ChatVersionRange <$> strParseJSON "ChatVersionRange" v
instance ToJSON ChatVersionRange where
toJSON (ChatVersionRange vr) = strToJSON vr
toEncoding (ChatVersionRange vr) = strToJEncoding vr
src/Simplex/Chat/View.hs
+41 -25
View File
@@ -21,6 +21,7 @@ import Data.Int (Int64)
import Data.List (groupBy, intercalate, intersperse, partition, sortOn)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as L
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe)
import Data.Text (Text)
@@ -51,6 +52,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)
@@ -58,6 +60,7 @@ import Simplex.Messaging.Protocol (AProtoServerWithAuth (..), AProtocolType, Pro
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Transport.Client (TransportHost (..))
import Simplex.Messaging.Util (bshow, tshow)
import Simplex.Messaging.Version hiding (version)
import System.Console.ANSI.Types
type CurrentTime = UTCTime
@@ -161,7 +164,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
@@ -252,7 +255,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))
@@ -262,20 +265,21 @@ responseToView user_ ChatConfig {logLevel, showReactions, showReceipts, testView
plain $ "agent locks: " <> LB.unpack (J.encode agentLocks)
]
CRAgentStats stats -> map (plain . intercalate ",") stats
CRAgentSubs {activeSubs, distinctActiveSubs, pendingSubs, distinctPendingSubs} ->
[plain $ "Subscriptions: active = " <> show (sum activeSubs) <> ", distinct active = " <> show (sum distinctActiveSubs) <> ", pending = " <> show (sum pendingSubs) <> ", distinct pending = " <> show (sum distinctPendingSubs)]
CRAgentSubs {activeSubs, pendingSubs, removedSubs} ->
[plain $ "Subscriptions: active = " <> show (sum activeSubs) <> ", pending = " <> show (sum pendingSubs) <> ", removed = " <> show (sum $ M.map length removedSubs)]
<> ("active subscriptions:" : listSubs activeSubs)
<> ("distinct active subscriptions:" : listSubs distinctActiveSubs)
<> ("pending subscriptions:" : listSubs pendingSubs)
<> ("distinct pending subscriptions:" : listSubs distinctPendingSubs)
<> ("removed subscriptions:" : listSubs removedSubs)
where
listSubs = map (\(srv, count) -> plain $ srv <> ": " <> tshow count) . M.assocs
CRAgentSubsDetails SubscriptionsInfo {activeSubscriptions, pendingSubscriptions} ->
listSubs :: Show a => Map Text a -> [StyledString]
listSubs = map (\(srv, info) -> plain $ srv <> ": " <> tshow info) . M.assocs
CRAgentSubsDetails SubscriptionsInfo {activeSubscriptions, pendingSubscriptions, removedSubscriptions} ->
("active subscriptions:" : map sShow activeSubscriptions)
<> ("pending subscriptions: " : map sShow pendingSubscriptions)
<> ("removed subscriptions: " : map sShow removedSubscriptions)
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_
@@ -328,7 +332,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_ =
@@ -954,8 +958,9 @@ 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
viewContactInfo ct@Contact {contactId, profile = LocalProfile {localAlias, contactLink}, activeConn} stats incognitoProfile =
["contact ID: " <> sShow contactId]
<> viewConnectionStats stats
<> maybe [] (\l -> ["contact address: " <> (plain . strEncode) l]) contactLink
<> maybe
["you've shared main profile with this contact"]
@@ -963,6 +968,7 @@ viewContactInfo ct@Contact {contactId, profile = LocalProfile {localAlias, conta
incognitoProfile
<> ["alias: " <> plain localAlias | localAlias /= ""]
<> [viewConnectionVerified (contactSecurityCode ct)]
<> [viewPeerChatVRange (peerChatVRange activeConn)]
viewGroupInfo :: GroupInfo -> GroupSummary -> [StyledString]
viewGroupInfo GroupInfo {groupId} s =
@@ -971,18 +977,22 @@ viewGroupInfo GroupInfo {groupId} s =
]
viewGroupMemberInfo :: GroupInfo -> GroupMember -> Maybe ConnectionStats -> [StyledString]
viewGroupMemberInfo GroupInfo {groupId} m@GroupMember {groupMemberId, memberProfile = LocalProfile {localAlias}} stats =
viewGroupMemberInfo GroupInfo {groupId} m@GroupMember {groupMemberId, memberProfile = LocalProfile {localAlias}, activeConn} stats =
[ "group ID: " <> sShow groupId,
"member ID: " <> sShow groupMemberId
]
<> maybe ["member not connected"] viewConnectionStats stats
<> ["alias: " <> plain localAlias | localAlias /= ""]
<> [viewConnectionVerified (memberSecurityCode m) | isJust stats]
<> maybe [] (\ac -> [viewPeerChatVRange (peerChatVRange ac)]) activeConn
viewConnectionVerified :: Maybe SecurityCode -> StyledString
viewConnectionVerified (Just _) = "connection verified" -- TODO show verification time?
viewConnectionVerified _ = "connection not verified, use " <> highlight' "/code" <> " command to see security code"
viewPeerChatVRange :: VersionRange -> StyledString
viewPeerChatVRange (VersionRange minVer maxVer) = "peer chat protocol version range: (" <> sShow minVer <> ", " <> sShow maxVer <> ")"
viewConnectionStats :: ConnectionStats -> [StyledString]
viewConnectionStats ConnectionStats {rcvQueuesInfo, sndQueuesInfo} =
["receiving messages via: " <> viewRcvQueuesInfo rcvQueuesInfo | not $ null rcvQueuesInfo]
@@ -1274,8 +1284,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
@@ -1343,14 +1353,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}) =
@@ -1403,7 +1419,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]
@@ -1413,7 +1429,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]