Merge branch 'master' into master-ghc8107

This commit is contained in:
Evgeny Poberezkin
2023-12-23 13:52:44 +00:00
57 changed files with 1833 additions and 515 deletions
+1 -1
View File
@@ -28,7 +28,7 @@ simplexChatCore cfg@ChatConfig {confirmMigrations, testView} opts@ChatOpts {core
exitFailure
run db@ChatDatabase {chatStore} = do
u <- getCreateActiveUser chatStore testView
cc <- newChatController db (Just u) cfg opts
cc <- newChatController db (Just u) cfg opts False
runSimplexChat opts u cc chat
runSimplexChat :: ChatOpts -> User -> ChatController -> (User -> ChatController -> IO ()) -> IO ()
+2 -1
View File
@@ -155,7 +155,8 @@ groupsHelpInfo =
"",
green "Group chat preferences:",
indent <> highlight "/set voice #<group> on/off " <> " - enable/disable voice messages",
-- indent <> highlight "/set files #<group> on/off " <> " - enable/disable files and media (other than voice)",
indent <> highlight "/set files #<group> on/off " <> " - enable/disable files and media (other than voice)",
indent <> highlight "/set history #<group> on/off " <> " - enable/disable sending recent history to new members",
indent <> highlight "/set delete #<group> on/off " <> " - enable/disable full message deletion",
indent <> highlight "/set direct #<group> on/off " <> " - enable/disable direct messages to other members",
indent <> highlight "/set disappear #<group> on <time> " <> " - enable disappearing messages with <time>:",
+13 -6
View File
@@ -21,6 +21,7 @@ import qualified Data.Aeson.Encoding as JE
import qualified Data.Aeson.TH as JQ
import qualified Data.Attoparsec.ByteString.Char8 as A
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Char (isSpace)
import Data.Int (Int64)
@@ -369,6 +370,9 @@ data CIQuote (c :: ChatType) = CIQuote
}
deriving (Show)
quoteItemId :: CIQuote c -> Maybe ChatItemId
quoteItemId CIQuote {itemId} = itemId
data CIReaction (c :: ChatType) (d :: MsgDirection) = CIReaction
{ chatDir :: CIDirection c d,
chatItem :: CChatItem c,
@@ -759,17 +763,20 @@ checkChatType x = case testEquality (chatTypeI @c) (chatTypeI @c') of
Just Refl -> Right x
Nothing -> Left "bad chat type"
data NewMessage e = NewMessage
{ chatMsgEvent :: ChatMsgEvent e,
msgBody :: MsgBody
}
deriving (Show)
type LazyMsgBody = L.ByteString
data SndMessage = SndMessage
{ msgId :: MessageId,
sharedMsgId :: SharedMsgId,
msgBody :: LazyMsgBody
}
deriving (Show)
data NewRcvMessage e = NewRcvMessage
{ chatMsgEvent :: ChatMsgEvent e,
msgBody :: MsgBody
}
deriving (Show)
data RcvMessage = RcvMessage
{ msgId :: MessageId,
@@ -783,7 +790,7 @@ data RcvMessage = RcvMessage
data PendingGroupMessage = PendingGroupMessage
{ msgId :: MessageId,
cmEventTag :: ACMEventTag,
msgBody :: MsgBody,
msgBody :: LazyMsgBody,
introId_ :: Maybe Int64
}
+53
View File
@@ -0,0 +1,53 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Simplex.Chat.Messages.Batch
( MsgBatch (..),
batchMessages,
)
where
import Data.ByteString.Builder (Builder, charUtf8, lazyByteString)
import qualified Data.ByteString.Lazy as LB
import Data.Int (Int64)
import Simplex.Chat.Controller (ChatError (..), ChatErrorType (..))
import Simplex.Chat.Messages
data MsgBatch = MsgBatch Builder [SndMessage]
deriving (Show)
-- | Batches [SndMessage] into batches of ByteString builders in form of JSON arrays.
-- Does not check if the resulting batch is a valid JSON.
-- If a single element is passed, it is returned as is (a JSON string).
-- If an element exceeds maxLen, it is returned as ChatError.
batchMessages :: Int64 -> [SndMessage] -> [Either ChatError MsgBatch]
batchMessages maxLen msgs =
let (batches, batch, _, n) = foldr addToBatch ([], [], 0, 0) msgs
in if n == 0 then batches else msgBatch batch : batches
where
msgBatch batch = Right (MsgBatch (encodeMessages batch) batch)
addToBatch :: SndMessage -> ([Either ChatError MsgBatch], [SndMessage], Int64, Int) -> ([Either ChatError MsgBatch], [SndMessage], Int64, Int)
addToBatch msg@SndMessage {msgBody} (batches, batch, len, n)
| batchLen <= maxLen = (batches, msg : batch, len', n + 1)
| msgLen <= maxLen = (batches', [msg], msgLen, 1)
| otherwise = (errLarge msg : (if n == 0 then batches else batches'), [], 0, 0)
where
msgLen = LB.length msgBody
batches' = msgBatch batch : batches
len'
| n == 0 = msgLen
| otherwise = msgLen + len + 1 -- 1 accounts for comma
batchLen
| n == 0 = len'
| otherwise = len' + 2 -- 2 accounts for opening and closing brackets
errLarge SndMessage {msgId} = Left $ ChatError $ CEInternalError ("large message " <> show msgId)
encodeMessages :: [SndMessage] -> Builder
encodeMessages = \case
[] -> mempty
[msg] -> encodeMsg msg
(msg : msgs) -> charUtf8 '[' <> encodeMsg msg <> mconcat [charUtf8 ',' <> encodeMsg msg' | msg' <- msgs] <> charUtf8 ']'
where
encodeMsg SndMessage {msgBody} = lazyByteString msgBody
+8 -2
View File
@@ -575,10 +575,16 @@ dbParseACIContent = fmap aciContentDBJSON . J.eitherDecodeStrict' . encodeUtf8
instance FromJSON ACIContent where
parseJSON = fmap aciContentJSON . J.parseJSON
sndMsgContentTag :: Text
sndMsgContentTag = "sndMsgContent"
rcvMsgContentTag :: Text
rcvMsgContentTag = "rcvMsgContent"
toCIContentTag :: CIContent e -> Text
toCIContentTag ciContent = case ciContent of
CISndMsgContent _ -> "sndMsgContent"
CIRcvMsgContent _ -> "rcvMsgContent"
CISndMsgContent _ -> sndMsgContentTag
CIRcvMsgContent _ -> rcvMsgContentTag
CISndDeleted _ -> "sndDeleted"
CIRcvDeleted _ -> "rcvDeleted"
CISndCall {} -> "sndCall"
@@ -0,0 +1,100 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Chat.Migrations.M20231215_recreate_msg_deliveries where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20231215_recreate_msg_deliveries :: Query
m20231215_recreate_msg_deliveries =
[sql|
DROP INDEX msg_delivery_events_msg_delivery_id;
DROP TABLE msg_delivery_events;
DROP INDEX idx_msg_deliveries_message_id;
DROP INDEX idx_msg_deliveries_agent_ack_cmd_id;
CREATE TABLE new_msg_deliveries(
msg_delivery_id INTEGER PRIMARY KEY,
message_id INTEGER NOT NULL REFERENCES messages ON DELETE CASCADE, -- non UNIQUE for group messages and for batched messages
connection_id INTEGER NOT NULL REFERENCES connections ON DELETE CASCADE,
agent_msg_id INTEGER, -- internal agent message ID (NULL while pending), non UNIQUE for batched messages
agent_msg_meta TEXT, -- JSON with timestamps etc. sent in MSG, NULL for sent
chat_ts TEXT NOT NULL DEFAULT(datetime('now')),
created_at TEXT CHECK(created_at NOT NULL),
updated_at TEXT CHECK(updated_at NOT NULL),
agent_ack_cmd_id INTEGER, -- broker_ts for received, created_at for sent
delivery_status TEXT -- MsgDeliveryStatus
);
INSERT INTO new_msg_deliveries (
msg_delivery_id, message_id, connection_id, agent_msg_id, agent_msg_meta,
chat_ts, created_at, updated_at, agent_ack_cmd_id
)
SELECT
msg_delivery_id, message_id, connection_id, agent_msg_id, agent_msg_meta,
chat_ts, created_at, updated_at, agent_ack_cmd_id
FROM msg_deliveries;
DROP TABLE msg_deliveries;
ALTER TABLE new_msg_deliveries RENAME TO msg_deliveries;
CREATE INDEX idx_msg_deliveries_message_id ON "msg_deliveries"(message_id);
CREATE INDEX idx_msg_deliveries_agent_ack_cmd_id ON "msg_deliveries"(connection_id, agent_ack_cmd_id);
CREATE INDEX idx_msg_deliveries_agent_msg_id ON "msg_deliveries"(connection_id, agent_msg_id);
|]
down_m20231215_recreate_msg_deliveries :: Query
down_m20231215_recreate_msg_deliveries =
[sql|
DROP INDEX idx_msg_deliveries_message_id;
DROP INDEX idx_msg_deliveries_agent_ack_cmd_id;
DROP INDEX idx_msg_deliveries_agent_msg_id;
CREATE TABLE old_msg_deliveries(
msg_delivery_id INTEGER PRIMARY KEY,
message_id INTEGER NOT NULL REFERENCES messages ON DELETE CASCADE, -- non UNIQUE for group messages
connection_id INTEGER NOT NULL REFERENCES connections ON DELETE CASCADE,
agent_msg_id INTEGER, -- internal agent message ID(NULL while pending)
agent_msg_meta TEXT, -- JSON with timestamps etc. sent in MSG, NULL for sent
chat_ts TEXT NOT NULL DEFAULT(datetime('now')),
created_at TEXT CHECK(created_at NOT NULL),
updated_at TEXT CHECK(updated_at NOT NULL),
agent_ack_cmd_id INTEGER, -- broker_ts for received, created_at for sent
UNIQUE(connection_id, agent_msg_id)
);
INSERT INTO old_msg_deliveries (
msg_delivery_id, message_id, connection_id, agent_msg_id, agent_msg_meta,
chat_ts, created_at, updated_at, agent_ack_cmd_id
)
WITH unique_msg_deliveries AS (
SELECT
msg_delivery_id, message_id, connection_id, agent_msg_id, agent_msg_meta,
chat_ts, created_at, updated_at, agent_ack_cmd_id,
row_number() OVER connection_id_agent_msg_id_win AS row_number
FROM msg_deliveries
WINDOW connection_id_agent_msg_id_win AS (PARTITION BY connection_id, agent_msg_id ORDER BY created_at ASC, msg_delivery_id ASC)
)
SELECT
msg_delivery_id, message_id, connection_id, agent_msg_id, agent_msg_meta,
chat_ts, created_at, updated_at, agent_ack_cmd_id
FROM unique_msg_deliveries
WHERE row_number = 1;
DROP TABLE msg_deliveries;
ALTER TABLE old_msg_deliveries RENAME TO msg_deliveries;
CREATE INDEX idx_msg_deliveries_message_id ON "msg_deliveries"(message_id);
CREATE INDEX idx_msg_deliveries_agent_ack_cmd_id ON "msg_deliveries"(connection_id, agent_ack_cmd_id);
CREATE TABLE msg_delivery_events (
msg_delivery_event_id INTEGER PRIMARY KEY,
msg_delivery_id INTEGER NOT NULL REFERENCES msg_deliveries ON DELETE CASCADE, -- non UNIQUE for multiple events per msg delivery
delivery_status TEXT NOT NULL, -- see MsgDeliveryStatus for allowed values
created_at TEXT NOT NULL DEFAULT (datetime('now')),
updated_at TEXT NOT NULL DEFAULT (datetime('now')),
UNIQUE (msg_delivery_id, delivery_status)
);
CREATE INDEX msg_delivery_events_msg_delivery_id ON msg_delivery_events(msg_delivery_id);
|]
+21 -27
View File
@@ -330,18 +330,6 @@ CREATE TABLE messages(
author_group_member_id INTEGER REFERENCES group_members ON DELETE SET NULL,
forwarded_by_group_member_id INTEGER REFERENCES group_members ON DELETE SET NULL
);
CREATE TABLE msg_deliveries(
msg_delivery_id INTEGER PRIMARY KEY,
message_id INTEGER NOT NULL REFERENCES messages ON DELETE CASCADE, -- non UNIQUE for group messages
connection_id INTEGER NOT NULL REFERENCES connections ON DELETE CASCADE,
agent_msg_id INTEGER, -- internal agent message ID(NULL while pending)
agent_msg_meta TEXT, -- JSON with timestamps etc. sent in MSG, NULL for sent
chat_ts TEXT NOT NULL DEFAULT(datetime('now')),
created_at TEXT CHECK(created_at NOT NULL),
updated_at TEXT CHECK(updated_at NOT NULL),
agent_ack_cmd_id INTEGER, -- broker_ts for received, created_at for sent
UNIQUE(connection_id, agent_msg_id)
);
CREATE TABLE pending_group_messages(
pending_group_message_id INTEGER PRIMARY KEY,
group_member_id INTEGER NOT NULL REFERENCES group_members ON DELETE CASCADE,
@@ -450,13 +438,6 @@ CREATE TABLE extra_xftp_file_descriptions(
created_at TEXT NOT NULL DEFAULT(datetime('now')),
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
);
CREATE TABLE msg_delivery_events(
msg_delivery_event_id INTEGER PRIMARY KEY,
msg_delivery_id INTEGER NOT NULL REFERENCES msg_deliveries ON DELETE CASCADE,
delivery_status TEXT NOT NULL,
created_at TEXT NOT NULL DEFAULT(datetime('now')),
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
);
CREATE TABLE chat_item_versions(
-- contains versions only for edited chat items, including current version
chat_item_version_id INTEGER PRIMARY KEY AUTOINCREMENT,
@@ -554,6 +535,18 @@ CREATE TABLE remote_controllers(
dh_priv_key BLOB NOT NULL, -- last session DH key
prev_dh_priv_key BLOB -- previous session DH key
);
CREATE TABLE IF NOT EXISTS "msg_deliveries"(
msg_delivery_id INTEGER PRIMARY KEY,
message_id INTEGER NOT NULL REFERENCES messages ON DELETE CASCADE, -- non UNIQUE for group messages and for batched messages
connection_id INTEGER NOT NULL REFERENCES connections ON DELETE CASCADE,
agent_msg_id INTEGER, -- internal agent message ID(NULL while pending), non UNIQUE for batched messages
agent_msg_meta TEXT, -- JSON with timestamps etc. sent in MSG, NULL for sent
chat_ts TEXT NOT NULL DEFAULT(datetime('now')),
created_at TEXT CHECK(created_at NOT NULL),
updated_at TEXT CHECK(updated_at NOT NULL),
agent_ack_cmd_id INTEGER, -- broker_ts for received, created_at for sent
delivery_status TEXT -- MsgDeliveryStatus
);
CREATE INDEX contact_profiles_index ON contact_profiles(
display_name,
full_name
@@ -585,7 +578,6 @@ CREATE UNIQUE INDEX idx_chat_items_group_shared_msg_id ON chat_items(
group_member_id,
shared_msg_id
);
CREATE INDEX idx_msg_deliveries_message_id ON msg_deliveries(message_id);
CREATE UNIQUE INDEX idx_user_contact_links_group_id ON user_contact_links(
group_id
);
@@ -717,13 +709,6 @@ CREATE INDEX idx_chat_items_timed_delete_at ON chat_items(
timed_delete_at
);
CREATE INDEX idx_group_members_group_id ON group_members(user_id, group_id);
CREATE INDEX idx_msg_deliveries_agent_ack_cmd_id ON msg_deliveries(
connection_id,
agent_ack_cmd_id
);
CREATE INDEX msg_delivery_events_msg_delivery_id ON msg_delivery_events(
msg_delivery_id
);
CREATE INDEX idx_chat_item_moderations_group_id ON chat_item_moderations(
group_id
);
@@ -818,3 +803,12 @@ CREATE INDEX idx_contact_requests_updated_at ON contact_requests(
updated_at
);
CREATE INDEX idx_connections_updated_at ON connections(user_id, updated_at);
CREATE INDEX idx_msg_deliveries_message_id ON "msg_deliveries"(message_id);
CREATE INDEX idx_msg_deliveries_agent_ack_cmd_id ON "msg_deliveries"(
connection_id,
agent_ack_cmd_id
);
CREATE INDEX idx_msg_deliveries_agent_msg_id ON "msg_deliveries"(
connection_id,
agent_msg_id
);
+9 -9
View File
@@ -72,7 +72,7 @@ $(JQ.deriveToJSON defaultJSON ''APIResponse)
foreign export ccall "chat_migrate_init" cChatMigrateInit :: CString -> CString -> CString -> Ptr (StablePtr ChatController) -> IO CJSONString
foreign export ccall "chat_migrate_init_key" cChatMigrateInitKey :: CString -> CString -> CInt -> CString -> Ptr (StablePtr ChatController) -> IO CJSONString
foreign export ccall "chat_migrate_init_key" cChatMigrateInitKey :: CString -> CString -> CInt -> CString -> CInt -> Ptr (StablePtr ChatController) -> IO CJSONString
foreign export ccall "chat_close_store" cChatCloseStore :: StablePtr ChatController -> IO CString
@@ -108,10 +108,10 @@ foreign export ccall "chat_decrypt_file" cChatDecryptFile :: CString -> CString
-- | check / migrate database and initialize chat controller on success
cChatMigrateInit :: CString -> CString -> CString -> Ptr (StablePtr ChatController) -> IO CJSONString
cChatMigrateInit fp key = cChatMigrateInitKey fp key 0
cChatMigrateInit fp key conf = cChatMigrateInitKey fp key 0 conf 0
cChatMigrateInitKey :: CString -> CString -> CInt -> CString -> Ptr (StablePtr ChatController) -> IO CJSONString
cChatMigrateInitKey fp key keepKey conf ctrl = do
cChatMigrateInitKey :: CString -> CString -> CInt -> CString -> CInt -> Ptr (StablePtr ChatController) -> IO CJSONString
cChatMigrateInitKey fp key keepKey conf background ctrl = do
-- ensure we are set to UTF-8; iOS does not have locale, and will default to
-- US-ASCII all the time.
setLocaleEncoding utf8
@@ -122,7 +122,7 @@ cChatMigrateInitKey fp key keepKey conf ctrl = do
dbKey <- BA.convert <$> B.packCString key
confirm <- peekCAString conf
r <-
chatMigrateInitKey dbPath dbKey (keepKey /= 0) confirm >>= \case
chatMigrateInitKey dbPath dbKey (keepKey /= 0) confirm (background /= 0) >>= \case
Right cc -> (newStablePtr cc >>= poke ctrl) $> DBMOk
Left e -> pure e
newCStringFromLazyBS $ J.encode r
@@ -220,10 +220,10 @@ getActiveUser_ :: SQLiteStore -> IO (Maybe User)
getActiveUser_ st = find activeUser <$> withTransaction st getUsers
chatMigrateInit :: String -> ScrubbedBytes -> String -> IO (Either DBMigrationResult ChatController)
chatMigrateInit dbFilePrefix dbKey = chatMigrateInitKey dbFilePrefix dbKey False
chatMigrateInit dbFilePrefix dbKey confirm = chatMigrateInitKey dbFilePrefix dbKey False confirm False
chatMigrateInitKey :: String -> ScrubbedBytes -> Bool -> String -> IO (Either DBMigrationResult ChatController)
chatMigrateInitKey dbFilePrefix dbKey keepKey confirm = runExceptT $ do
chatMigrateInitKey :: String -> ScrubbedBytes -> Bool -> String -> Bool -> IO (Either DBMigrationResult ChatController)
chatMigrateInitKey dbFilePrefix dbKey keepKey confirm backgroundMode = runExceptT $ do
confirmMigrations <- liftEitherWith (const DBMInvalidConfirmation) $ strDecode $ B.pack confirm
chatStore <- migrate createChatStore (chatStoreFile dbFilePrefix) confirmMigrations
agentStore <- migrate createAgentStore (agentStoreFile dbFilePrefix) confirmMigrations
@@ -231,7 +231,7 @@ chatMigrateInitKey dbFilePrefix dbKey keepKey confirm = runExceptT $ do
where
initialize st db = do
user_ <- getActiveUser_ st
newChatController db user_ defaultMobileConfig (mobileChatOpts dbFilePrefix)
newChatController db user_ defaultMobileConfig (mobileChatOpts dbFilePrefix) backgroundMode
migrate createStore dbFile confirmMigrations =
ExceptT $
(first (DBMErrorMigration dbFile) <$> createStore dbFile dbKey keepKey confirmMigrations)
+46 -12
View File
@@ -29,7 +29,9 @@ import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.ByteString.Internal (c2w, w2c)
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Int (Int64)
import Data.Maybe (fromMaybe)
import Data.String
import Data.Text (Text)
@@ -51,7 +53,7 @@ import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, (<$?>))
import Simplex.Messaging.Version hiding (version)
currentChatVersion :: Version
currentChatVersion = 4
currentChatVersion = 5
supportedChatVRange :: VersionRange
supportedChatVRange = mkVersionRange 1 currentChatVersion
@@ -72,6 +74,10 @@ groupLinkNoContactVRange = mkVersionRange 3 currentChatVersion
groupForwardVRange :: VersionRange
groupForwardVRange = mkVersionRange 4 currentChatVersion
-- version range that supports batch sending in groups
batchSendVRange :: VersionRange
batchSendVRange = mkVersionRange 5 currentChatVersion
data ConnectionEntity
= RcvDirectMsgConnection {entityConnection :: Connection, contact :: Maybe Contact}
| RcvGroupMsgConnection {entityConnection :: Connection, groupInfo :: GroupInfo, groupMember :: GroupMember}
@@ -447,6 +453,18 @@ durationText duration =
| n <= 9 = '0' : show n
| otherwise = show n
msgContentHasText :: MsgContent -> Bool
msgContentHasText = \case
MCText t -> hasText t
MCLink {text} -> hasText text
MCImage {text} -> hasText text
MCVideo {text} -> hasText text
MCVoice {text} -> hasText text
MCFile t -> hasText t
MCUnknown {text} -> hasText text
where
hasText = not . T.null
isVoice :: MsgContent -> Bool
isVoice = \case
MCVoice {} -> True
@@ -467,18 +485,34 @@ data ExtMsgContent = ExtMsgContent {content :: MsgContent, file :: Maybe FileInv
$(JQ.deriveJSON defaultJSON ''QuotedMsg)
instance MsgEncodingI e => StrEncoding (ChatMessage e) where
strEncode msg = case chatToAppMessage msg of
AMJson m -> LB.toStrict $ J.encode m
AMBinary m -> strEncode m
strP = (\(ACMsg _ m) -> checkEncoding m) <$?> strP
-- this limit reserves space for metadata in forwarded messages
-- 15780 (limit used for fileChunkSize) - 161 (x.grp.msg.forward overhead) = 15619, round to 15610
maxChatMsgSize :: Int64
maxChatMsgSize = 15610
instance StrEncoding AChatMessage where
strEncode (ACMsg _ m) = strEncode m
strP =
A.peekChar' >>= \case
'{' -> ACMsg SJson <$> ((appJsonToCM <=< J.eitherDecodeStrict') <$?> A.takeByteString)
_ -> ACMsg SBinary <$> (appBinaryToCM <$?> strP)
data EncodedChatMessage = ECMEncoded L.ByteString | ECMLarge
encodeChatMessage :: MsgEncodingI e => ChatMessage e -> EncodedChatMessage
encodeChatMessage msg = do
case chatToAppMessage msg of
AMJson m -> do
let body = J.encode m
if LB.length body > maxChatMsgSize
then ECMLarge
else ECMEncoded body
AMBinary m -> ECMEncoded . LB.fromStrict $ strEncode m
parseChatMessages :: ByteString -> [Either String AChatMessage]
parseChatMessages "" = [Left "empty string"]
parseChatMessages s = case B.head s of
'{' -> [ACMsg SJson <$> J.eitherDecodeStrict' s]
'[' -> case J.eitherDecodeStrict' s of
Right v -> map parseItem v
Left e -> [Left e]
_ -> [ACMsg SBinary <$> (appBinaryToCM =<< strDecode s)]
where
parseItem :: J.Value -> Either String AChatMessage
parseItem v = ACMsg SJson <$> JT.parseEither parseJSON v
parseMsgContainer :: J.Object -> JT.Parser MsgContainer
parseMsgContainer v =
+33 -12
View File
@@ -46,7 +46,8 @@ module Simplex.Chat.Store.Files
createRcvFileTransfer,
createRcvGroupFileTransfer,
appendRcvFD,
getRcvFileDescrByFileId,
getRcvFileDescrByRcvFileId,
getRcvFileDescrBySndFileId,
updateRcvFileAgentId,
getRcvFileTransferById,
getRcvFileTransfer,
@@ -542,7 +543,7 @@ createRcvFD_ db userId currentTs FileDescr {fileDescrText, fileDescrPartNo, file
appendRcvFD :: DB.Connection -> UserId -> FileTransferId -> FileDescr -> ExceptT StoreError IO RcvFileDescr
appendRcvFD db userId fileId fd@FileDescr {fileDescrText, fileDescrPartNo, fileDescrComplete} = do
currentTs <- liftIO getCurrentTime
liftIO (getRcvFileDescrByFileId_ db fileId) >>= \case
liftIO (getRcvFileDescrByRcvFileId_ db fileId) >>= \case
Nothing -> do
rfd@RcvFileDescr {fileDescrId} <- createRcvFD_ db userId currentTs fd
liftIO $
@@ -571,14 +572,14 @@ appendRcvFD db userId fileId fd@FileDescr {fileDescrText, fileDescrPartNo, fileD
(fileDescrText', fileDescrPartNo, fileDescrComplete, fileDescrId)
pure RcvFileDescr {fileDescrId, fileDescrText = fileDescrText', fileDescrPartNo, fileDescrComplete}
getRcvFileDescrByFileId :: DB.Connection -> FileTransferId -> ExceptT StoreError IO RcvFileDescr
getRcvFileDescrByFileId db fileId = do
liftIO (getRcvFileDescrByFileId_ db fileId) >>= \case
getRcvFileDescrByRcvFileId :: DB.Connection -> FileTransferId -> ExceptT StoreError IO RcvFileDescr
getRcvFileDescrByRcvFileId db fileId = do
liftIO (getRcvFileDescrByRcvFileId_ db fileId) >>= \case
Nothing -> throwError $ SERcvFileDescrNotFound fileId
Just rfd -> pure rfd
getRcvFileDescrByFileId_ :: DB.Connection -> FileTransferId -> IO (Maybe RcvFileDescr)
getRcvFileDescrByFileId_ db fileId =
getRcvFileDescrByRcvFileId_ :: DB.Connection -> FileTransferId -> IO (Maybe RcvFileDescr)
getRcvFileDescrByRcvFileId_ db fileId =
maybeFirstRow toRcvFileDescr $
DB.query
db
@@ -590,10 +591,30 @@ getRcvFileDescrByFileId_ db fileId =
LIMIT 1
|]
(Only fileId)
where
toRcvFileDescr :: (Int64, Text, Int, Bool) -> RcvFileDescr
toRcvFileDescr (fileDescrId, fileDescrText, fileDescrPartNo, fileDescrComplete) =
RcvFileDescr {fileDescrId, fileDescrText, fileDescrPartNo, fileDescrComplete}
getRcvFileDescrBySndFileId :: DB.Connection -> FileTransferId -> ExceptT StoreError IO RcvFileDescr
getRcvFileDescrBySndFileId db fileId = do
liftIO (getRcvFileDescrBySndFileId_ db fileId) >>= \case
Nothing -> throwError $ SERcvFileDescrNotFound fileId
Just rfd -> pure rfd
getRcvFileDescrBySndFileId_ :: DB.Connection -> FileTransferId -> IO (Maybe RcvFileDescr)
getRcvFileDescrBySndFileId_ db fileId =
maybeFirstRow toRcvFileDescr $
DB.query
db
[sql|
SELECT d.file_descr_id, d.file_descr_text, d.file_descr_part_no, d.file_descr_complete
FROM xftp_file_descriptions d
JOIN snd_files f ON f.file_descr_id = d.file_descr_id
WHERE f.file_id = ?
LIMIT 1
|]
(Only fileId)
toRcvFileDescr :: (Int64, Text, Int, Bool) -> RcvFileDescr
toRcvFileDescr (fileDescrId, fileDescrText, fileDescrPartNo, fileDescrComplete) =
RcvFileDescr {fileDescrId, fileDescrText, fileDescrPartNo, fileDescrComplete}
updateRcvFileAgentId :: DB.Connection -> FileTransferId -> Maybe AgentRcvFileId -> IO ()
updateRcvFileAgentId db fileId aFileId = do
@@ -626,7 +647,7 @@ getRcvFileTransfer_ db userId fileId = do
WHERE f.user_id = ? AND f.file_id = ?
|]
(userId, fileId)
rfd_ <- liftIO $ getRcvFileDescrByFileId_ db fileId
rfd_ <- liftIO $ getRcvFileDescrByRcvFileId_ db fileId
rcvFileTransfer rfd_ rftRow
where
rcvFileTransfer ::
+1 -1
View File
@@ -149,7 +149,7 @@ type MaybeGroupMemberRow = ((Maybe Int64, Maybe Int64, Maybe MemberId, Maybe Ver
toGroupInfo :: Int64 -> GroupInfoRow -> GroupInfo
toGroupInfo userContactId ((groupId, localDisplayName, displayName, fullName, description, image, hostConnCustomUserProfileId, enableNtfs_, sendRcpts, favorite, groupPreferences) :. (createdAt, updatedAt, chatTs) :. userMemberRow) =
let membership = toGroupMember userContactId userMemberRow
let membership = (toGroupMember userContactId userMemberRow) {memberChatVRange = JVersionRange supportedChatVRange}
chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts, favorite}
fullGroupPreferences = mergeGroupPreferences groupPreferences
groupProfile = GroupProfile {displayName, fullName, description, image, groupPreferences}
+76 -82
View File
@@ -24,8 +24,8 @@ module Simplex.Chat.Store.Messages
createSndMsgDelivery,
createNewMessageAndRcvMsgDelivery,
createNewRcvMessage,
createSndMsgDeliveryEvent,
createRcvMsgDeliveryEvent,
updateSndMsgDeliveryStatus,
updateRcvMsgDeliveryStatus,
createPendingGroupMessage,
getPendingGroupMessages,
deletePendingGroupMessage,
@@ -99,6 +99,7 @@ module Simplex.Chat.Store.Messages
updateGroupSndStatus,
getGroupSndStatuses,
getGroupSndStatusCounts,
getGroupHistoryItems,
)
where
@@ -159,49 +160,59 @@ deleteGroupCIs db User {userId} GroupInfo {groupId} = do
DB.execute db "DELETE FROM chat_item_reactions WHERE group_id = ?" (Only groupId)
DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND group_id = ?" (userId, groupId)
createNewSndMessage :: MsgEncodingI e => DB.Connection -> TVar ChaChaDRG -> ConnOrGroupId -> (SharedMsgId -> NewMessage e) -> ExceptT StoreError IO SndMessage
createNewSndMessage db gVar connOrGroupId mkMessage =
createWithRandomId gVar $ \sharedMsgId -> do
let NewMessage {chatMsgEvent, msgBody} = mkMessage $ SharedMsgId sharedMsgId
createdAt <- getCurrentTime
DB.execute
db
[sql|
INSERT INTO messages (
msg_sent, chat_msg_event, msg_body, connection_id, group_id,
shared_msg_id, shared_msg_id_user, created_at, updated_at
) VALUES (?,?,?,?,?,?,?,?,?)
|]
(MDSnd, toCMEventTag chatMsgEvent, msgBody, connId_, groupId_, sharedMsgId, Just True, createdAt, createdAt)
msgId <- insertedRowId db
pure SndMessage {msgId, sharedMsgId = SharedMsgId sharedMsgId, msgBody}
createNewSndMessage :: MsgEncodingI e => DB.Connection -> TVar ChaChaDRG -> ConnOrGroupId -> ChatMsgEvent e -> (SharedMsgId -> EncodedChatMessage) -> ExceptT StoreError IO SndMessage
createNewSndMessage db gVar connOrGroupId chatMsgEvent encodeMessage =
createWithRandomId' gVar $ \sharedMsgId ->
case encodeMessage (SharedMsgId sharedMsgId) of
ECMLarge -> pure $ Left SELargeMsg
ECMEncoded msgBody -> do
createdAt <- getCurrentTime
DB.execute
db
[sql|
INSERT INTO messages (
msg_sent, chat_msg_event, msg_body, connection_id, group_id,
shared_msg_id, shared_msg_id_user, created_at, updated_at
) VALUES (?,?,?,?,?,?,?,?,?)
|]
(MDSnd, toCMEventTag chatMsgEvent, msgBody, connId_, groupId_, sharedMsgId, Just True, createdAt, createdAt)
msgId <- insertedRowId db
pure $ Right SndMessage {msgId, sharedMsgId = SharedMsgId sharedMsgId, msgBody}
where
(connId_, groupId_) = case connOrGroupId of
ConnectionId connId -> (Just connId, Nothing)
GroupId groupId -> (Nothing, Just groupId)
createSndMsgDelivery :: DB.Connection -> SndMsgDelivery -> MessageId -> IO Int64
createSndMsgDelivery db sndMsgDelivery messageId = do
createSndMsgDelivery db SndMsgDelivery {connId, agentMsgId} messageId = do
currentTs <- getCurrentTime
msgDeliveryId <- createSndMsgDelivery_ db sndMsgDelivery messageId currentTs
createMsgDeliveryEvent_ db msgDeliveryId MDSSndAgent currentTs
pure msgDeliveryId
DB.execute
db
[sql|
INSERT INTO msg_deliveries
(message_id, connection_id, agent_msg_id, chat_ts, created_at, updated_at, delivery_status)
VALUES (?,?,?,?,?,?,?)
|]
(messageId, connId, agentMsgId, currentTs, currentTs, currentTs, MDSSndAgent)
insertedRowId db
createNewMessageAndRcvMsgDelivery :: forall e. MsgEncodingI e => DB.Connection -> ConnOrGroupId -> NewMessage e -> Maybe SharedMsgId -> RcvMsgDelivery -> Maybe GroupMemberId -> ExceptT StoreError IO RcvMessage
createNewMessageAndRcvMsgDelivery :: forall e. MsgEncodingI e => DB.Connection -> ConnOrGroupId -> NewRcvMessage e -> Maybe SharedMsgId -> RcvMsgDelivery -> Maybe GroupMemberId -> ExceptT StoreError IO RcvMessage
createNewMessageAndRcvMsgDelivery db connOrGroupId newMessage sharedMsgId_ RcvMsgDelivery {connId, agentMsgId, agentMsgMeta, agentAckCmdId} authorGroupMemberId_ = do
msg@RcvMessage {msgId} <- createNewRcvMessage db connOrGroupId newMessage sharedMsgId_ authorGroupMemberId_ Nothing
liftIO $ do
currentTs <- getCurrentTime
DB.execute
db
"INSERT INTO msg_deliveries (message_id, connection_id, agent_msg_id, agent_msg_meta, agent_ack_cmd_id, chat_ts, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)"
(msgId, connId, agentMsgId, msgMetaJson agentMsgMeta, agentAckCmdId, snd $ broker agentMsgMeta, currentTs, currentTs)
msgDeliveryId <- insertedRowId db
createMsgDeliveryEvent_ db msgDeliveryId MDSRcvAgent currentTs
[sql|
INSERT INTO msg_deliveries
(message_id, connection_id, agent_msg_id, agent_msg_meta, agent_ack_cmd_id, chat_ts, created_at, updated_at, delivery_status)
VALUES (?,?,?,?,?,?,?,?,?)
|]
(msgId, connId, agentMsgId, msgMetaJson agentMsgMeta, agentAckCmdId, snd $ broker agentMsgMeta, currentTs, currentTs, MDSRcvAgent)
pure msg
createNewRcvMessage :: forall e. MsgEncodingI e => DB.Connection -> ConnOrGroupId -> NewMessage e -> Maybe SharedMsgId -> Maybe GroupMemberId -> Maybe GroupMemberId -> ExceptT StoreError IO RcvMessage
createNewRcvMessage db connOrGroupId NewMessage {chatMsgEvent, msgBody} sharedMsgId_ authorMember forwardedByMember =
createNewRcvMessage :: forall e. MsgEncodingI e => DB.Connection -> ConnOrGroupId -> NewRcvMessage e -> Maybe SharedMsgId -> Maybe GroupMemberId -> Maybe GroupMemberId -> ExceptT StoreError IO RcvMessage
createNewRcvMessage db connOrGroupId NewRcvMessage {chatMsgEvent, msgBody} sharedMsgId_ authorMember forwardedByMember =
case connOrGroupId of
ConnectionId connId -> liftIO $ insertRcvMsg (Just connId) Nothing
GroupId groupId -> case sharedMsgId_ of
@@ -236,68 +247,29 @@ createNewRcvMessage db connOrGroupId NewMessage {chatMsgEvent, msgBody} sharedMs
msgId <- insertedRowId db
pure RcvMessage {msgId, chatMsgEvent = ACME (encoding @e) chatMsgEvent, sharedMsgId_, msgBody, authorMember, forwardedByMember}
createSndMsgDeliveryEvent :: DB.Connection -> Int64 -> AgentMsgId -> MsgDeliveryStatus 'MDSnd -> ExceptT StoreError IO ()
createSndMsgDeliveryEvent db connId agentMsgId sndMsgDeliveryStatus = do
msgDeliveryId <- getMsgDeliveryId_ db connId agentMsgId
liftIO $ do
currentTs <- getCurrentTime
createMsgDeliveryEvent_ db msgDeliveryId sndMsgDeliveryStatus currentTs
createRcvMsgDeliveryEvent :: DB.Connection -> Int64 -> CommandId -> MsgDeliveryStatus 'MDRcv -> IO ()
createRcvMsgDeliveryEvent db connId cmdId rcvMsgDeliveryStatus = do
msgDeliveryId <- getMsgDeliveryIdByCmdId_ db connId cmdId
forM_ msgDeliveryId $ \mdId -> do
currentTs <- getCurrentTime
createMsgDeliveryEvent_ db mdId rcvMsgDeliveryStatus currentTs
createSndMsgDelivery_ :: DB.Connection -> SndMsgDelivery -> MessageId -> UTCTime -> IO Int64
createSndMsgDelivery_ db SndMsgDelivery {connId, agentMsgId} messageId createdAt = do
updateSndMsgDeliveryStatus :: DB.Connection -> Int64 -> AgentMsgId -> MsgDeliveryStatus 'MDSnd -> IO ()
updateSndMsgDeliveryStatus db connId agentMsgId sndMsgDeliveryStatus = do
currentTs <- getCurrentTime
DB.execute
db
[sql|
INSERT INTO msg_deliveries
(message_id, connection_id, agent_msg_id, agent_msg_meta, chat_ts, created_at, updated_at)
VALUES (?,?,?,NULL,?,?,?)
UPDATE msg_deliveries
SET delivery_status = ?, updated_at = ?
WHERE connection_id = ? AND agent_msg_id = ?
|]
(messageId, connId, agentMsgId, createdAt, createdAt, createdAt)
insertedRowId db
(sndMsgDeliveryStatus, currentTs, connId, agentMsgId)
createMsgDeliveryEvent_ :: DB.Connection -> Int64 -> MsgDeliveryStatus d -> UTCTime -> IO ()
createMsgDeliveryEvent_ db msgDeliveryId msgDeliveryStatus createdAt = do
updateRcvMsgDeliveryStatus :: DB.Connection -> Int64 -> CommandId -> MsgDeliveryStatus 'MDRcv -> IO ()
updateRcvMsgDeliveryStatus db connId cmdId rcvMsgDeliveryStatus = do
currentTs <- getCurrentTime
DB.execute
db
[sql|
INSERT INTO msg_delivery_events
(msg_delivery_id, delivery_status, created_at, updated_at)
VALUES (?,?,?,?)
UPDATE msg_deliveries
SET delivery_status = ?, updated_at = ?
WHERE connection_id = ? AND agent_ack_cmd_id = ?
|]
(msgDeliveryId, msgDeliveryStatus, createdAt, createdAt)
getMsgDeliveryId_ :: DB.Connection -> Int64 -> AgentMsgId -> ExceptT StoreError IO Int64
getMsgDeliveryId_ db connId agentMsgId =
ExceptT . firstRow fromOnly (SENoMsgDelivery connId agentMsgId) $
DB.query
db
[sql|
SELECT msg_delivery_id
FROM msg_deliveries m
WHERE m.connection_id = ? AND m.agent_msg_id = ?
LIMIT 1
|]
(connId, agentMsgId)
getMsgDeliveryIdByCmdId_ :: DB.Connection -> Int64 -> CommandId -> IO (Maybe AgentMsgId)
getMsgDeliveryIdByCmdId_ db connId cmdId =
maybeFirstRow fromOnly $
DB.query
db
[sql|
SELECT msg_delivery_id
FROM msg_deliveries
WHERE connection_id = ? AND agent_ack_cmd_id = ?
LIMIT 1
|]
(connId, cmdId)
(rcvMsgDeliveryStatus, currentTs, connId, cmdId)
createPendingGroupMessage :: DB.Connection -> Int64 -> MessageId -> Maybe Int64 -> IO ()
createPendingGroupMessage db groupMemberId messageId introId_ = do
@@ -2107,3 +2079,25 @@ getGroupSndStatusCounts db itemId =
GROUP BY group_snd_item_status
|]
(Only itemId)
getGroupHistoryItems :: DB.Connection -> User -> GroupInfo -> Int -> IO [Either StoreError (CChatItem 'CTGroup)]
getGroupHistoryItems db user@User {userId} GroupInfo {groupId} count = do
chatItemIds <- getLastItemIds_
-- use getGroupCIWithReactions to read reactions data
reverse <$> mapM (runExceptT . getGroupChatItem db user groupId) chatItemIds
where
getLastItemIds_ :: IO [ChatItemId]
getLastItemIds_ =
map fromOnly
<$> DB.query
db
[sql|
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND group_id = ?
AND item_content_tag IN (?,?)
AND item_deleted = 0
ORDER BY item_ts DESC, chat_item_id DESC
LIMIT ?
|]
(userId, groupId, rcvMsgContentTag, sndMsgContentTag, count)
+3 -1
View File
@@ -93,6 +93,7 @@ import Simplex.Chat.Migrations.M20231114_remote_control
import Simplex.Chat.Migrations.M20231126_remote_ctrl_address
import Simplex.Chat.Migrations.M20231207_chat_list_pagination
import Simplex.Chat.Migrations.M20231214_item_content_tag
import Simplex.Chat.Migrations.M20231215_recreate_msg_deliveries
import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..))
schemaMigrations :: [(String, Query, Maybe Query)]
@@ -185,7 +186,8 @@ schemaMigrations =
("20231114_remote_control", m20231114_remote_control, Just down_m20231114_remote_control),
("20231126_remote_ctrl_address", m20231126_remote_ctrl_address, Just down_m20231126_remote_ctrl_address),
("20231207_chat_list_pagination", m20231207_chat_list_pagination, Just down_m20231207_chat_list_pagination),
("20231214_item_content_tag", m20231214_item_content_tag, Just down_m20231214_item_content_tag)
("20231214_item_content_tag", m20231214_item_content_tag, Just down_m20231214_item_content_tag),
("20231215_recreate_msg_deliveries", m20231215_recreate_msg_deliveries, Just down_m20231215_recreate_msg_deliveries)
]
-- | The list of migrations in ascending order by date
+10 -4
View File
@@ -32,7 +32,7 @@ import Simplex.Chat.Protocol
import Simplex.Chat.Remote.Types
import Simplex.Chat.Types
import Simplex.Chat.Types.Preferences
import Simplex.Messaging.Agent.Protocol (AgentMsgId, ConnId, UserId)
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
@@ -86,8 +86,8 @@ data StoreError
| SEPendingConnectionNotFound {connId :: Int64}
| SEIntroNotFound
| SEUniqueID
| SELargeMsg
| SEInternalError {message :: String}
| SENoMsgDelivery {connId :: Int64, agentMsgId :: AgentMsgId}
| SEBadChatItem {itemId :: ChatItemId}
| SEChatItemNotFound {itemId :: ChatItemId}
| SEChatItemNotFoundByText {text :: Text}
@@ -376,15 +376,21 @@ withLocalDisplayName db userId displayName action = getLdnSuffix >>= (`tryCreate
createWithRandomId :: forall a. TVar ChaChaDRG -> (ByteString -> IO a) -> ExceptT StoreError IO a
createWithRandomId = createWithRandomBytes 12
createWithRandomId' :: forall a. TVar ChaChaDRG -> (ByteString -> IO (Either StoreError a)) -> ExceptT StoreError IO a
createWithRandomId' = createWithRandomBytes' 12
createWithRandomBytes :: forall a. Int -> TVar ChaChaDRG -> (ByteString -> IO a) -> ExceptT StoreError IO a
createWithRandomBytes size gVar create = tryCreate 3
createWithRandomBytes size gVar create = createWithRandomBytes' size gVar (fmap Right . create)
createWithRandomBytes' :: forall a. Int -> TVar ChaChaDRG -> (ByteString -> IO (Either StoreError a)) -> ExceptT StoreError IO a
createWithRandomBytes' size gVar create = tryCreate 3
where
tryCreate :: Int -> ExceptT StoreError IO a
tryCreate 0 = throwError SEUniqueID
tryCreate n = do
id' <- liftIO $ encodedRandomBytes gVar size
liftIO (E.try $ create id') >>= \case
Right x -> pure x
Right x -> liftEither x
Left e
| SQL.sqlError e == SQL.ErrorConstraint -> tryCreate (n - 1)
| otherwise -> throwError . SEInternalError $ show e
+5 -2
View File
@@ -626,7 +626,8 @@ data GroupMember = GroupMember
memberContactProfileId :: ProfileId,
activeConn :: Maybe Connection,
-- member chat protocol version range; if member has active connection, its version range is preferred;
-- for membership current supportedChatVRange is set, it's not updated on protocol version increase
-- for membership current supportedChatVRange is set, it's not updated on protocol version increase in database,
-- but it's correctly set on read (see toGroupInfo)
memberChatVRange :: JVersionRange
}
deriving (Eq, Show)
@@ -1011,9 +1012,11 @@ data XFTPRcvFile = XFTPRcvFile
}
deriving (Eq, Show)
type RcvFileDescrText = Text
data RcvFileDescr = RcvFileDescr
{ fileDescrId :: Int64,
fileDescrText :: Text,
fileDescrText :: RcvFileDescrText,
fileDescrPartNo :: Int,
fileDescrComplete :: Bool
}
+34 -7
View File
@@ -147,6 +147,7 @@ data GroupFeature
| GFReactions
| GFVoice
| GFFiles
| GFHistory
deriving (Show)
data SGroupFeature (f :: GroupFeature) where
@@ -156,6 +157,7 @@ data SGroupFeature (f :: GroupFeature) where
SGFReactions :: SGroupFeature 'GFReactions
SGFVoice :: SGroupFeature 'GFVoice
SGFFiles :: SGroupFeature 'GFFiles
SGFHistory :: SGroupFeature 'GFHistory
deriving instance Show (SGroupFeature f)
@@ -171,6 +173,7 @@ groupFeatureNameText = \case
GFReactions -> "Message reactions"
GFVoice -> "Voice messages"
GFFiles -> "Files and media"
GFHistory -> "Recent history"
groupFeatureNameText' :: SGroupFeature f -> Text
groupFeatureNameText' = groupFeatureNameText . toGroupFeature
@@ -186,7 +189,8 @@ allGroupFeatures =
AGF SGFFullDelete,
AGF SGFReactions,
AGF SGFVoice,
AGF SGFFiles
AGF SGFFiles,
AGF SGFHistory
]
groupPrefSel :: SGroupFeature f -> GroupPreferences -> Maybe (GroupFeaturePreference f)
@@ -197,6 +201,7 @@ groupPrefSel = \case
SGFReactions -> reactions
SGFVoice -> voice
SGFFiles -> files
SGFHistory -> history
toGroupFeature :: SGroupFeature f -> GroupFeature
toGroupFeature = \case
@@ -206,6 +211,7 @@ toGroupFeature = \case
SGFReactions -> GFReactions
SGFVoice -> GFVoice
SGFFiles -> GFFiles
SGFHistory -> GFHistory
class GroupPreferenceI p where
getGroupPreference :: SGroupFeature f -> p -> GroupFeaturePreference f
@@ -224,6 +230,7 @@ instance GroupPreferenceI FullGroupPreferences where
SGFReactions -> reactions
SGFVoice -> voice
SGFFiles -> files
SGFHistory -> history
{-# INLINE getGroupPreference #-}
-- collection of optional group preferences
@@ -233,7 +240,8 @@ data GroupPreferences = GroupPreferences
fullDelete :: Maybe FullDeleteGroupPreference,
reactions :: Maybe ReactionsGroupPreference,
voice :: Maybe VoiceGroupPreference,
files :: Maybe FilesGroupPreference
files :: Maybe FilesGroupPreference,
history :: Maybe HistoryGroupPreference
}
deriving (Eq, Show)
@@ -258,6 +266,7 @@ setGroupPreference_ f pref prefs =
SGFReactions -> prefs {reactions = pref}
SGFVoice -> prefs {voice = pref}
SGFFiles -> prefs {files = pref}
SGFHistory -> prefs {history = pref}
setGroupTimedMessagesPreference :: TimedMessagesGroupPreference -> Maybe GroupPreferences -> GroupPreferences
setGroupTimedMessagesPreference pref prefs_ =
@@ -284,7 +293,8 @@ data FullGroupPreferences = FullGroupPreferences
fullDelete :: FullDeleteGroupPreference,
reactions :: ReactionsGroupPreference,
voice :: VoiceGroupPreference,
files :: FilesGroupPreference
files :: FilesGroupPreference,
history :: HistoryGroupPreference
}
deriving (Eq, Show)
@@ -339,11 +349,12 @@ defaultGroupPrefs =
fullDelete = FullDeleteGroupPreference {enable = FEOff},
reactions = ReactionsGroupPreference {enable = FEOn},
voice = VoiceGroupPreference {enable = FEOn},
files = FilesGroupPreference {enable = FEOn}
files = FilesGroupPreference {enable = FEOn},
history = HistoryGroupPreference {enable = FEOff}
}
emptyGroupPrefs :: GroupPreferences
emptyGroupPrefs = GroupPreferences Nothing Nothing Nothing Nothing Nothing Nothing
emptyGroupPrefs = GroupPreferences Nothing Nothing Nothing Nothing Nothing Nothing Nothing
data TimedMessagesPreference = TimedMessagesPreference
{ allow :: FeatureAllowed,
@@ -438,6 +449,10 @@ data FilesGroupPreference = FilesGroupPreference
{enable :: GroupFeatureEnabled}
deriving (Eq, Show)
data HistoryGroupPreference = HistoryGroupPreference
{enable :: GroupFeatureEnabled}
deriving (Eq, Show)
class (Eq (GroupFeaturePreference f), HasField "enable" (GroupFeaturePreference f) GroupFeatureEnabled) => GroupFeatureI f where
type GroupFeaturePreference (f :: GroupFeature) = p | p -> f
sGroupFeature :: SGroupFeature f
@@ -464,6 +479,9 @@ instance HasField "enable" VoiceGroupPreference GroupFeatureEnabled where
instance HasField "enable" FilesGroupPreference GroupFeatureEnabled where
hasField p = (\enable -> p {enable}, enable (p :: FilesGroupPreference))
instance HasField "enable" HistoryGroupPreference GroupFeatureEnabled where
hasField p = (\enable -> p {enable}, p.enable)
instance GroupFeatureI 'GFTimedMessages where
type GroupFeaturePreference 'GFTimedMessages = TimedMessagesGroupPreference
sGroupFeature = SGFTimedMessages
@@ -494,6 +512,11 @@ instance GroupFeatureI 'GFFiles where
sGroupFeature = SGFFiles
groupPrefParam _ = Nothing
instance GroupFeatureI 'GFHistory where
type GroupFeaturePreference 'GFHistory = HistoryGroupPreference
sGroupFeature = SGFHistory
groupPrefParam _ = Nothing
groupPrefStateText :: HasField "enable" p GroupFeatureEnabled => GroupFeature -> p -> Maybe Int -> Text
groupPrefStateText feature pref param =
let enabled = getField @"enable" pref
@@ -616,7 +639,8 @@ mergeGroupPreferences groupPreferences =
fullDelete = pref SGFFullDelete,
reactions = pref SGFReactions,
voice = pref SGFVoice,
files = pref SGFFiles
files = pref SGFFiles,
history = pref SGFHistory
}
where
pref :: SGroupFeature f -> GroupFeaturePreference f
@@ -630,7 +654,8 @@ toGroupPreferences groupPreferences =
fullDelete = pref SGFFullDelete,
reactions = pref SGFReactions,
voice = pref SGFVoice,
files = pref SGFFiles
files = pref SGFFiles,
history = pref SGFHistory
}
where
pref :: SGroupFeature f -> Maybe (GroupFeaturePreference f)
@@ -736,6 +761,8 @@ $(J.deriveJSON defaultJSON ''VoiceGroupPreference)
$(J.deriveJSON defaultJSON ''FilesGroupPreference)
$(J.deriveJSON defaultJSON ''HistoryGroupPreference)
$(J.deriveJSON defaultJSON ''GroupPreferences)
instance ToField GroupPreferences where
+13 -1
View File
@@ -1,12 +1,18 @@
module Simplex.Chat.Util (week, encryptFile, chunkSize) where
{-# LANGUAGE TupleSections #-}
module Simplex.Chat.Util (week, encryptFile, chunkSize, shuffle) where
import Control.Monad
import Control.Monad.Except
import Control.Monad.IO.Class
import qualified Data.ByteString.Lazy as LB
import Data.List (sortBy)
import Data.Ord (comparing)
import Data.Time (NominalDiffTime)
import Data.Word (Word16)
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
import qualified Simplex.Messaging.Crypto.File as CF
import System.Random (randomRIO)
import UnliftIO.IO (IOMode (..), withFile)
week :: NominalDiffTime
@@ -30,3 +36,9 @@ encryptFile fromPath toPath cfArgs = do
chunkSize :: Num a => a
chunkSize = 65536
{-# INLINE chunkSize #-}
shuffle :: [a] -> IO [a]
shuffle xs = map snd . sortBy (comparing fst) <$> mapM (\x -> (,x) <$> random) xs
where
random :: IO Word16
random = randomRIO (0, 65535)