core: support inline file transfers (#1187)

* core: support inline file transfers

* parameterize ChatMessage

* send files inline when accepted

* accept inline file transfers (almost works)

* db error SERcvFileInvalid

* inline file transfer works (TODO fix test)

* inline file transfer tests, change encodings

* fixture

* combine messages into x.file.acpt.inv, refactor

* inline file mode

* decide whether to receive file inline on the recipient side, not only via file invitation

* test inline files "sent" mode

* check that file was offered inline

* update schema

* enable encryption tests

* test name

Co-authored-by: JRoberts <8711996+jr-simplex@users.noreply.github.com>

* fix the list of rcv files to subscribe too

Co-authored-by: JRoberts <8711996+jr-simplex@users.noreply.github.com>
This commit is contained in:
Evgeny Poberezkin
2022-10-14 13:06:33 +01:00
committed by GitHub
parent f7da034cf1
commit fb03a119ea
14 changed files with 1341 additions and 814 deletions
+17
View File
@@ -67,12 +67,29 @@ data ChatConfig = ChatConfig
defaultServers :: InitialAgentServers,
tbqSize :: Natural,
fileChunkSize :: Integer,
inlineFiles :: InlineFilesConfig,
subscriptionConcurrency :: Int,
subscriptionEvents :: Bool,
hostEvents :: Bool,
testView :: Bool
}
data InlineFilesConfig = InlineFilesConfig
{ offerChunks :: Integer,
sendChunks :: Integer,
totalSendChunks :: Integer,
receiveChunks :: Integer
}
defaultInlineFilesConfig :: InlineFilesConfig
defaultInlineFilesConfig =
InlineFilesConfig
{ offerChunks = 15, -- max when chunks are offered - limited to 255 on the encoding level
sendChunks = 0, -- max per file when chunks will be sent inline without acceptance
totalSendChunks = 30, -- max per conversation when chunks will be sent inline without acceptance
receiveChunks = 5 -- max when chunks are accepted
}
data ActiveTo = ActiveNone | ActiveC ContactName | ActiveG GroupName
deriving (Eq)
+6 -4
View File
@@ -338,6 +338,8 @@ data CIFileStatus (d :: MsgDirection) where
CIFSRcvComplete :: CIFileStatus 'MDRcv
CIFSRcvCancelled :: CIFileStatus 'MDRcv
deriving instance Eq (CIFileStatus d)
deriving instance Show (CIFileStatus d)
ciFileEnded :: CIFileStatus d -> Bool
@@ -836,8 +838,8 @@ instance ChatTypeI 'CTDirect where chatTypeI = SCTDirect
instance ChatTypeI 'CTGroup where chatTypeI = SCTGroup
data NewMessage = NewMessage
{ chatMsgEvent :: ChatMsgEvent,
data NewMessage e = NewMessage
{ chatMsgEvent :: ChatMsgEvent e,
msgBody :: MsgBody
}
deriving (Show)
@@ -850,14 +852,14 @@ data SndMessage = SndMessage
data RcvMessage = RcvMessage
{ msgId :: MessageId,
chatMsgEvent :: ChatMsgEvent,
chatMsgEvent :: AChatMsgEvent,
sharedMsgId_ :: Maybe SharedMsgId,
msgBody :: MsgBody
}
data PendingGroupMessage = PendingGroupMessage
{ msgId :: MessageId,
cmEventTag :: CMEventTag,
cmEventTag :: ACMEventTag,
msgBody :: MsgBody,
introId_ :: Maybe Int64
}
@@ -0,0 +1,20 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Chat.Migrations.M20221012_inline_files where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20221012_inline_files :: Query
m20221012_inline_files =
[sql|
DROP INDEX idx_messages_direct_shared_msg_id;
ALTER TABLE files ADD COLUMN file_inline TEXT;
ALTER TABLE rcv_files ADD COLUMN rcv_file_inline TEXT;
ALTER TABLE rcv_files ADD COLUMN file_inline TEXT;
ALTER TABLE snd_files ADD COLUMN file_inline TEXT;
ALTER TABLE snd_files ADD COLUMN last_inline_msg_delivery_id INTEGER;
CREATE UNIQUE INDEX idx_snd_files_last_inline_msg_delivery_id ON snd_files(last_inline_msg_delivery_id);
|]
+10 -7
View File
@@ -182,7 +182,8 @@ CREATE TABLE files(
chat_item_id INTEGER DEFAULT NULL REFERENCES chat_items ON DELETE CASCADE,
updated_at TEXT CHECK(updated_at NOT NULL),
cancelled INTEGER,
ci_file_status TEXT
ci_file_status TEXT,
file_inline TEXT
);
CREATE TABLE snd_files(
file_id INTEGER NOT NULL REFERENCES files ON DELETE CASCADE,
@@ -191,6 +192,8 @@ CREATE TABLE snd_files(
group_member_id INTEGER REFERENCES group_members ON DELETE CASCADE,
created_at TEXT CHECK(created_at NOT NULL),
updated_at TEXT CHECK(updated_at NOT NULL),
file_inline TEXT,
last_inline_msg_delivery_id INTEGER,
PRIMARY KEY(file_id, connection_id)
) WITHOUT ROWID;
CREATE TABLE rcv_files(
@@ -200,7 +203,9 @@ CREATE TABLE rcv_files(
file_queue_info BLOB
,
created_at TEXT CHECK(created_at NOT NULL),
updated_at TEXT CHECK(updated_at NOT NULL)
updated_at TEXT CHECK(updated_at NOT NULL),
rcv_file_inline TEXT,
file_inline TEXT
);
CREATE TABLE snd_file_chunks(
file_id INTEGER NOT NULL,
@@ -370,11 +375,6 @@ CREATE TABLE smp_servers(
UNIQUE(host, port)
);
CREATE INDEX idx_messages_shared_msg_id ON messages(shared_msg_id);
CREATE UNIQUE INDEX idx_messages_direct_shared_msg_id ON messages(
connection_id,
shared_msg_id_user,
shared_msg_id
);
CREATE INDEX idx_chat_items_shared_msg_id ON chat_items(shared_msg_id);
CREATE TABLE calls(
-- stores call invitations state for communicating state between NSE and app when call notification comes
@@ -431,3 +431,6 @@ 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
);
CREATE UNIQUE INDEX idx_snd_files_last_inline_msg_delivery_id ON snd_files(
last_inline_msg_delivery_id
);
+277 -141
View File
@@ -9,7 +9,9 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TypeApplications #-}
module Simplex.Chat.Protocol where
@@ -22,19 +24,25 @@ import qualified Data.Aeson.KeyMap as JM
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
import Data.ByteString.Internal (c2w, w2c)
import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
import Data.Time.Clock (UTCTime)
import Data.Type.Equality
import Data.Typeable (Typeable)
import Data.Word (Word32)
import Database.SQLite.Simple.FromField (FromField (..))
import Database.SQLite.Simple.ToField (ToField (..))
import GHC.Generics (Generic)
import Simplex.Chat.Call
import Simplex.Chat.Types
import Simplex.Chat.Util (safeDecodeUtf8)
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (fromTextField_, fstToLower, sumTypeJSON)
import Simplex.Messaging.Parsers (fromTextField_, fstToLower, parseAll, sumTypeJSON)
import Simplex.Messaging.Util (eitherToMaybe, (<$?>))
data ConnectionEntity
@@ -59,18 +67,64 @@ updateEntityConnStatus connEntity connStatus = case connEntity of
where
st c = c {connStatus}
data MsgEncoding = Binary | Json
data SMsgEncoding (e :: MsgEncoding) where
SBinary :: SMsgEncoding 'Binary
SJson :: SMsgEncoding 'Json
deriving instance Show (SMsgEncoding e)
class MsgEncodingI (e :: MsgEncoding) where
encoding :: SMsgEncoding e
instance MsgEncodingI 'Binary where encoding = SBinary
instance MsgEncodingI 'Json where encoding = SJson
data ACMEventTag = forall e. MsgEncodingI e => ACMEventTag (SMsgEncoding e) (CMEventTag e)
instance TestEquality SMsgEncoding where
testEquality SBinary SBinary = Just Refl
testEquality SJson SJson = Just Refl
testEquality _ _ = Nothing
checkEncoding :: forall t e e'. (MsgEncodingI e, MsgEncodingI e') => t e' -> Either String (t e)
checkEncoding x = case testEquality (encoding @e) (encoding @e') of
Just Refl -> Right x
Nothing -> Left "bad encoding"
data AppMessage (e :: MsgEncoding) where
AMJson :: AppMessageJson -> AppMessage 'Json
AMBinary :: AppMessageBinary -> AppMessage 'Binary
-- chat message is sent as JSON with these properties
data AppMessage = AppMessage
data AppMessageJson = AppMessageJson
{ msgId :: Maybe SharedMsgId,
event :: Text,
params :: J.Object
}
deriving (Generic, FromJSON)
instance ToJSON AppMessage where
data AppMessageBinary = AppMessageBinary
{ msgId :: Maybe SharedMsgId,
tag :: Char,
body :: ByteString
}
instance ToJSON AppMessageJson where
toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
instance StrEncoding AppMessageBinary where
strEncode AppMessageBinary {tag, msgId, body} = smpEncode (tag, msgId', Tail body)
where
msgId' = maybe B.empty (\(SharedMsgId mId') -> mId') msgId
strP = do
(tag, msgId', Tail body) <- smpP
let msgId = if B.null msgId' then Nothing else Just (SharedMsgId msgId')
pure AppMessageBinary {tag, msgId, body}
newtype SharedMsgId = SharedMsgId ByteString
deriving (Eq, Show)
@@ -105,51 +159,99 @@ instance ToJSON MsgRef where
toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
data ChatMessage = ChatMessage {msgId :: Maybe SharedMsgId, chatMsgEvent :: ChatMsgEvent}
data ChatMessage e = ChatMessage {msgId :: Maybe SharedMsgId, chatMsgEvent :: ChatMsgEvent e}
deriving (Eq, Show)
instance StrEncoding ChatMessage where
strEncode = LB.toStrict . J.encode . chatToAppMessage
strDecode = appToChatMessage <=< J.eitherDecodeStrict'
strP = strDecode <$?> A.takeByteString
data AChatMessage = forall e. MsgEncodingI e => ACMsg (SMsgEncoding e) (ChatMessage e)
data ChatMsgEvent
= XMsgNew MsgContainer
| XMsgUpdate SharedMsgId MsgContent
| XMsgDel SharedMsgId
| XMsgDeleted
| XFile FileInvitation -- TODO discontinue
| XFileAcpt String -- direct file protocol
| XFileAcptInv SharedMsgId ConnReqInvitation String -- group file protocol
| XFileCancel SharedMsgId
| XInfo Profile
| XContact Profile (Maybe XContactId)
| XGrpInv GroupInvitation
| XGrpAcpt MemberId
| XGrpMemNew MemberInfo
| XGrpMemIntro MemberInfo
| XGrpMemInv MemberId IntroInvitation
| XGrpMemFwd MemberInfo IntroInvitation
| XGrpMemInfo MemberId Profile
| XGrpMemRole MemberId GroupMemberRole
| XGrpMemCon MemberId -- TODO not implemented
| XGrpMemConAll MemberId -- TODO not implemented
| XGrpMemDel MemberId
| XGrpLeave
| XGrpDel
| XGrpInfo GroupProfile
| XInfoProbe Probe
| XInfoProbeCheck ProbeHash
| XInfoProbeOk Probe
| XCallInv CallId CallInvitation
| XCallOffer CallId CallOffer
| XCallAnswer CallId CallAnswer
| XCallExtra CallId CallExtraInfo
| XCallEnd CallId
| XOk
| XUnknown {event :: Text, params :: J.Object}
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
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 ChatMsgEvent (e :: MsgEncoding) where
XMsgNew :: MsgContainer -> ChatMsgEvent 'Json
XMsgUpdate :: SharedMsgId -> MsgContent -> ChatMsgEvent 'Json
XMsgDel :: SharedMsgId -> ChatMsgEvent 'Json
XMsgDeleted :: ChatMsgEvent 'Json
XFile :: FileInvitation -> ChatMsgEvent 'Json -- TODO discontinue
XFileAcpt :: String -> ChatMsgEvent 'Json -- direct file protocol
XFileAcptInv :: SharedMsgId -> Maybe ConnReqInvitation -> String -> ChatMsgEvent 'Json
XFileCancel :: SharedMsgId -> ChatMsgEvent 'Json
XInfo :: Profile -> ChatMsgEvent 'Json
XContact :: Profile -> Maybe XContactId -> ChatMsgEvent 'Json
XGrpInv :: GroupInvitation -> ChatMsgEvent 'Json
XGrpAcpt :: MemberId -> ChatMsgEvent 'Json
XGrpMemNew :: MemberInfo -> ChatMsgEvent 'Json
XGrpMemIntro :: MemberInfo -> ChatMsgEvent 'Json
XGrpMemInv :: MemberId -> IntroInvitation -> ChatMsgEvent 'Json
XGrpMemFwd :: MemberInfo -> IntroInvitation -> ChatMsgEvent 'Json
XGrpMemInfo :: MemberId -> Profile -> ChatMsgEvent 'Json
XGrpMemRole :: MemberId -> GroupMemberRole -> ChatMsgEvent 'Json
XGrpMemCon :: MemberId -> ChatMsgEvent 'Json -- TODO not implemented
XGrpMemConAll :: MemberId -> ChatMsgEvent 'Json -- TODO not implemented
XGrpMemDel :: MemberId -> ChatMsgEvent 'Json
XGrpLeave :: ChatMsgEvent 'Json
XGrpDel :: ChatMsgEvent 'Json
XGrpInfo :: GroupProfile -> ChatMsgEvent 'Json
XInfoProbe :: Probe -> ChatMsgEvent 'Json
XInfoProbeCheck :: ProbeHash -> ChatMsgEvent 'Json
XInfoProbeOk :: Probe -> ChatMsgEvent 'Json
XCallInv :: CallId -> CallInvitation -> ChatMsgEvent 'Json
XCallOffer :: CallId -> CallOffer -> ChatMsgEvent 'Json
XCallAnswer :: CallId -> CallAnswer -> ChatMsgEvent 'Json
XCallExtra :: CallId -> CallExtraInfo -> ChatMsgEvent 'Json
XCallEnd :: CallId -> ChatMsgEvent 'Json
XOk :: ChatMsgEvent 'Json
XUnknown :: {event :: Text, params :: J.Object} -> ChatMsgEvent 'Json
BFileChunk :: SharedMsgId -> FileChunk -> ChatMsgEvent 'Binary
deriving instance Eq (ChatMsgEvent e)
deriving instance Show (ChatMsgEvent e)
data AChatMsgEvent = forall e. MsgEncodingI e => ACME (SMsgEncoding e) (ChatMsgEvent e)
deriving instance Show AChatMsgEvent
data FileChunk = FileChunk {chunkNo :: Integer, chunkBytes :: ByteString} | FileChunkCancel
deriving (Eq, Show)
instance Encoding FileChunk where
smpEncode = \case
FileChunk {chunkNo, chunkBytes} -> smpEncode ('F', fromIntegral chunkNo :: Word32, Tail chunkBytes)
FileChunkCancel -> smpEncode 'C'
smpP =
smpP >>= \case
'F' -> do
chunkNo <- fromIntegral <$> smpP @Word32
Tail chunkBytes <- smpP
pure FileChunk {chunkNo, chunkBytes}
'C' -> pure FileChunkCancel
_ -> fail "bad FileChunk"
newtype InlineFileChunk = IFC {unIFC :: FileChunk}
instance Encoding InlineFileChunk where
smpEncode (IFC chunk) = case chunk of
FileChunk {chunkNo, chunkBytes} -> smpEncode (w2c $ fromIntegral chunkNo, Tail chunkBytes)
FileChunkCancel -> smpEncode '\NUL'
smpP = do
c <- A.anyChar
IFC <$> case c of
'\NUL' -> pure FileChunkCancel
_ -> do
Tail chunkBytes <- smpP
pure FileChunk {chunkNo = fromIntegral $ c2w c, chunkBytes}
data QuotedMsg = QuotedMsg {msgRef :: MsgRef, content :: MsgContent}
deriving (Eq, Show, Generic, FromJSON)
@@ -157,9 +259,9 @@ instance ToJSON QuotedMsg where
toEncoding = J.genericToEncoding J.defaultOptions
toJSON = J.genericToJSON J.defaultOptions
cmToQuotedMsg :: ChatMsgEvent -> Maybe QuotedMsg
cmToQuotedMsg :: AChatMsgEvent -> Maybe QuotedMsg
cmToQuotedMsg = \case
XMsgNew (MCQuote quotedMsg _) -> Just quotedMsg
ACME _ (XMsgNew (MCQuote quotedMsg _)) -> Just quotedMsg
_ -> Nothing
data MsgContentTag = MCText_ | MCLink_ | MCImage_ | MCFile_ | MCUnknown_ Text
@@ -273,7 +375,7 @@ msgContainerJSON = \case
where
withFile l = \case
Nothing -> l
Just f -> l <> ["file" .= fileInvitationJSON f]
Just f -> l <> ["file" .= f]
instance ToJSON MsgContent where
toJSON = \case
@@ -295,44 +397,48 @@ instance ToField MsgContent where
instance FromField MsgContent where
fromField = fromTextField_ $ J.decode . LB.fromStrict . encodeUtf8
data CMEventTag
= XMsgNew_
| XMsgUpdate_
| XMsgDel_
| XMsgDeleted_
| XFile_
| XFileAcpt_
| XFileAcptInv_
| XFileCancel_
| XInfo_
| XContact_
| XGrpInv_
| XGrpAcpt_
| XGrpMemNew_
| XGrpMemIntro_
| XGrpMemInv_
| XGrpMemFwd_
| XGrpMemInfo_
| XGrpMemRole_
| XGrpMemCon_
| XGrpMemConAll_
| XGrpMemDel_
| XGrpLeave_
| XGrpDel_
| XGrpInfo_
| XInfoProbe_
| XInfoProbeCheck_
| XInfoProbeOk_
| XCallInv_
| XCallOffer_
| XCallAnswer_
| XCallExtra_
| XCallEnd_
| XOk_
| XUnknown_ Text
deriving (Eq, Show)
data CMEventTag (e :: MsgEncoding) where
XMsgNew_ :: CMEventTag 'Json
XMsgUpdate_ :: CMEventTag 'Json
XMsgDel_ :: CMEventTag 'Json
XMsgDeleted_ :: CMEventTag 'Json
XFile_ :: CMEventTag 'Json
XFileAcpt_ :: CMEventTag 'Json
XFileAcptInv_ :: CMEventTag 'Json
XFileCancel_ :: CMEventTag 'Json
XInfo_ :: CMEventTag 'Json
XContact_ :: CMEventTag 'Json
XGrpInv_ :: CMEventTag 'Json
XGrpAcpt_ :: CMEventTag 'Json
XGrpMemNew_ :: CMEventTag 'Json
XGrpMemIntro_ :: CMEventTag 'Json
XGrpMemInv_ :: CMEventTag 'Json
XGrpMemFwd_ :: CMEventTag 'Json
XGrpMemInfo_ :: CMEventTag 'Json
XGrpMemRole_ :: CMEventTag 'Json
XGrpMemCon_ :: CMEventTag 'Json
XGrpMemConAll_ :: CMEventTag 'Json
XGrpMemDel_ :: CMEventTag 'Json
XGrpLeave_ :: CMEventTag 'Json
XGrpDel_ :: CMEventTag 'Json
XGrpInfo_ :: CMEventTag 'Json
XInfoProbe_ :: CMEventTag 'Json
XInfoProbeCheck_ :: CMEventTag 'Json
XInfoProbeOk_ :: CMEventTag 'Json
XCallInv_ :: CMEventTag 'Json
XCallOffer_ :: CMEventTag 'Json
XCallAnswer_ :: CMEventTag 'Json
XCallExtra_ :: CMEventTag 'Json
XCallEnd_ :: CMEventTag 'Json
XOk_ :: CMEventTag 'Json
XUnknown_ :: Text -> CMEventTag 'Json
BFileChunk_ :: CMEventTag 'Binary
instance StrEncoding CMEventTag where
deriving instance Show (CMEventTag e)
deriving instance Eq (CMEventTag e)
instance MsgEncodingI e => StrEncoding (CMEventTag e) where
strEncode = \case
XMsgNew_ -> "x.msg.new"
XMsgUpdate_ -> "x.msg.update"
@@ -368,45 +474,54 @@ instance StrEncoding CMEventTag where
XCallEnd_ -> "x.call.end"
XOk_ -> "x.ok"
XUnknown_ t -> encodeUtf8 t
strDecode = \case
"x.msg.new" -> Right XMsgNew_
"x.msg.update" -> Right XMsgUpdate_
"x.msg.del" -> Right XMsgDel_
"x.msg.deleted" -> Right XMsgDeleted_
"x.file" -> Right XFile_
"x.file.acpt" -> Right XFileAcpt_
"x.file.acpt.inv" -> Right XFileAcptInv_
"x.file.cancel" -> Right XFileCancel_
"x.info" -> Right XInfo_
"x.contact" -> Right XContact_
"x.grp.inv" -> Right XGrpInv_
"x.grp.acpt" -> Right XGrpAcpt_
"x.grp.mem.new" -> Right XGrpMemNew_
"x.grp.mem.intro" -> Right XGrpMemIntro_
"x.grp.mem.inv" -> Right XGrpMemInv_
"x.grp.mem.fwd" -> Right XGrpMemFwd_
"x.grp.mem.info" -> Right XGrpMemInfo_
"x.grp.mem.role" -> Right XGrpMemRole_
"x.grp.mem.con" -> Right XGrpMemCon_
"x.grp.mem.con.all" -> Right XGrpMemConAll_
"x.grp.mem.del" -> Right XGrpMemDel_
"x.grp.leave" -> Right XGrpLeave_
"x.grp.del" -> Right XGrpDel_
"x.grp.info" -> Right XGrpInfo_
"x.info.probe" -> Right XInfoProbe_
"x.info.probe.check" -> Right XInfoProbeCheck_
"x.info.probe.ok" -> Right XInfoProbeOk_
"x.call.inv" -> Right XCallInv_
"x.call.offer" -> Right XCallOffer_
"x.call.answer" -> Right XCallAnswer_
"x.call.extra" -> Right XCallExtra_
"x.call.end" -> Right XCallEnd_
"x.ok" -> Right XOk_
t -> Right . XUnknown_ $ safeDecodeUtf8 t
BFileChunk_ -> "F"
strDecode = (\(ACMEventTag _ t) -> checkEncoding t) <=< strDecode
strP = strDecode <$?> A.takeTill (== ' ')
toCMEventTag :: ChatMsgEvent -> CMEventTag
toCMEventTag = \case
instance StrEncoding ACMEventTag where
strEncode (ACMEventTag _ t) = strEncode t
strP =
((,) <$> A.peekChar' <*> A.takeTill (== ' ')) >>= \case
('x', t) -> pure . ACMEventTag SJson $ case t of
"x.msg.new" -> XMsgNew_
"x.msg.update" -> XMsgUpdate_
"x.msg.del" -> XMsgDel_
"x.msg.deleted" -> XMsgDeleted_
"x.file" -> XFile_
"x.file.acpt" -> XFileAcpt_
"x.file.acpt.inv" -> XFileAcptInv_
"x.file.cancel" -> XFileCancel_
"x.info" -> XInfo_
"x.contact" -> XContact_
"x.grp.inv" -> XGrpInv_
"x.grp.acpt" -> XGrpAcpt_
"x.grp.mem.new" -> XGrpMemNew_
"x.grp.mem.intro" -> XGrpMemIntro_
"x.grp.mem.inv" -> XGrpMemInv_
"x.grp.mem.fwd" -> XGrpMemFwd_
"x.grp.mem.info" -> XGrpMemInfo_
"x.grp.mem.role" -> XGrpMemRole_
"x.grp.mem.con" -> XGrpMemCon_
"x.grp.mem.con.all" -> XGrpMemConAll_
"x.grp.mem.del" -> XGrpMemDel_
"x.grp.leave" -> XGrpLeave_
"x.grp.del" -> XGrpDel_
"x.grp.info" -> XGrpInfo_
"x.info.probe" -> XInfoProbe_
"x.info.probe.check" -> XInfoProbeCheck_
"x.info.probe.ok" -> XInfoProbeOk_
"x.call.inv" -> XCallInv_
"x.call.offer" -> XCallOffer_
"x.call.answer" -> XCallAnswer_
"x.call.extra" -> XCallExtra_
"x.call.end" -> XCallEnd_
"x.ok" -> XOk_
_ -> XUnknown_ $ safeDecodeUtf8 t
(_, "F") -> pure $ ACMEventTag SBinary BFileChunk_
_ -> fail "bad ACMEventTag"
toCMEventTag :: ChatMsgEvent e -> CMEventTag e
toCMEventTag msg = case msg of
XMsgNew _ -> XMsgNew_
XMsgUpdate _ _ -> XMsgUpdate_
XMsgDel _ -> XMsgDel_
@@ -441,18 +556,25 @@ toCMEventTag = \case
XCallEnd _ -> XCallEnd_
XOk -> XOk_
XUnknown t _ -> XUnknown_ t
BFileChunk _ _ -> BFileChunk_
cmEventTagT :: Text -> Maybe CMEventTag
cmEventTagT = eitherToMaybe . strDecode . encodeUtf8
instance MsgEncodingI e => TextEncoding (CMEventTag e) where
textEncode = decodeLatin1 . strEncode
textDecode = eitherToMaybe . strDecode . encodeUtf8
serializeCMEventTag :: CMEventTag -> Text
serializeCMEventTag = decodeLatin1 . strEncode
instance TextEncoding ACMEventTag where
textEncode (ACMEventTag _ t) = textEncode t
textDecode = eitherToMaybe . strDecode . encodeUtf8
instance FromField CMEventTag where fromField = fromTextField_ cmEventTagT
instance (MsgEncodingI e, Typeable e) => FromField (CMEventTag e) where fromField = fromTextField_ textDecode
instance ToField CMEventTag where toField = toField . serializeCMEventTag
instance MsgEncodingI e => ToField (CMEventTag e) where toField = toField . textEncode
hasNotification :: CMEventTag -> Bool
instance FromField ACMEventTag where fromField = fromTextField_ textDecode
instance ToField ACMEventTag where toField = toField . textEncode
hasNotification :: CMEventTag e -> Bool
hasNotification = \case
XMsgNew_ -> True
XFile_ -> True
@@ -463,8 +585,18 @@ hasNotification = \case
XCallInv_ -> True
_ -> False
appToChatMessage :: AppMessage -> Either String ChatMessage
appToChatMessage AppMessage {msgId, event, params} = do
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}
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
eventTag <- strDecode $ encodeUtf8 event
chatMsgEvent <- msg eventTag
pure ChatMessage {msgId, chatMsgEvent}
@@ -473,6 +605,7 @@ appToChatMessage AppMessage {msgId, event, params} = do
p key = JT.parseEither (.: key) params
opt :: FromJSON a => J.Key -> Either String (Maybe a)
opt key = JT.parseEither (.:? key) params
msg :: CMEventTag 'Json -> Either String (ChatMsgEvent 'Json)
msg = \case
XMsgNew_ -> XMsgNew <$> JT.parseEither parseMsgContainer params
XMsgUpdate_ -> XMsgUpdate <$> p "msgId" <*> p "content"
@@ -480,7 +613,7 @@ appToChatMessage AppMessage {msgId, event, params} = do
XMsgDeleted_ -> pure XMsgDeleted
XFile_ -> XFile <$> p "file"
XFileAcpt_ -> XFileAcpt <$> p "fileName"
XFileAcptInv_ -> XFileAcptInv <$> p "msgId" <*> p "fileConnReq" <*> p "fileName"
XFileAcptInv_ -> XFileAcptInv <$> p "msgId" <*> opt "fileConnReq" <*> p "fileName"
XFileCancel_ -> XFileCancel <$> p "msgId"
XInfo_ -> XInfo <$> p "profile"
XContact_ -> XContact <$> p "profile" <*> opt "contactReqId"
@@ -509,21 +642,29 @@ appToChatMessage AppMessage {msgId, event, params} = do
XOk_ -> pure XOk
XUnknown_ t -> pure $ XUnknown t params
chatToAppMessage :: ChatMessage -> AppMessage
chatToAppMessage ChatMessage {msgId, chatMsgEvent} = AppMessage {msgId, event, params}
chatToAppMessage :: forall e. MsgEncodingI e => ChatMessage e -> AppMessage e
chatToAppMessage ChatMessage {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}
where
event = serializeCMEventTag . toCMEventTag $ chatMsgEvent
tag = toCMEventTag chatMsgEvent
o :: [(J.Key, J.Value)] -> J.Object
o = JM.fromList
key .=? value = maybe id ((:) . (key .=)) value
params = case chatMsgEvent of
toBody :: ChatMsgEvent 'Binary -> (Maybe SharedMsgId, ByteString)
toBody = \case
BFileChunk (SharedMsgId msgId') chunk -> (Nothing, smpEncode (msgId', IFC chunk))
params :: ChatMsgEvent 'Json -> J.Object
params = \case
XMsgNew container -> msgContainerJSON container
XMsgUpdate msgId' content -> o ["msgId" .= msgId', "content" .= content]
XMsgDel msgId' -> o ["msgId" .= msgId']
XMsgDeleted -> JM.empty
XFile fileInv -> o ["file" .= fileInvitationJSON fileInv]
XFile fileInv -> o ["file" .= fileInv]
XFileAcpt fileName -> o ["fileName" .= fileName]
XFileAcptInv sharedMsgId fileConnReq fileName -> o ["msgId" .= sharedMsgId, "fileConnReq" .= fileConnReq, "fileName" .= fileName]
XFileAcptInv sharedMsgId fileConnReq fileName -> o $ ("fileConnReq" .=? fileConnReq) ["msgId" .= sharedMsgId, "fileName" .= fileName]
XFileCancel sharedMsgId -> o ["msgId" .= sharedMsgId]
XInfo profile -> o ["profile" .= profile]
XContact profile xContactId -> o $ ("contactReqId" .=? xContactId) ["profile" .= profile]
@@ -551,8 +692,3 @@ chatToAppMessage ChatMessage {msgId, chatMsgEvent} = AppMessage {msgId, event, p
XCallEnd callId -> o ["callId" .= callId]
XOk -> JM.empty
XUnknown _ ps -> ps
fileInvitationJSON :: FileInvitation -> J.Object
fileInvitationJSON FileInvitation {fileName, fileSize, fileConnReq} = case fileConnReq of
Nothing -> JM.fromList ["fileName" .= fileName, "fileSize" .= fileSize]
Just fConnReq -> JM.fromList ["fileName" .= fileName, "fileSize" .= fileSize, "fileConnReq" .= fConnReq]
+212 -131
View File
@@ -111,11 +111,15 @@ module Simplex.Chat.Store
matchReceivedProbeHash,
matchSentProbe,
mergeContactRecords,
createSndFileTransfer,
createSndDirectFileTransfer,
createSndDirectFTConnection,
createSndGroupFileTransfer,
createSndGroupFileTransferConnection,
createSndDirectInlineFT,
createSndGroupInlineFT,
updateSndDirectFTDelivery,
updateSndGroupFTDelivery,
getSndInlineFTViaMsgDelivery,
updateFileCancelled,
updateCIFileStatus,
getSharedMsgIdByFileId,
@@ -132,6 +136,8 @@ module Simplex.Chat.Store
createRcvGroupFileTransfer,
getRcvFileTransfer,
acceptRcvFileTransfer,
acceptRcvInlineFT,
startRcvInlineFT,
updateRcvFileStatus,
createRcvFileChunk,
updatedRcvFileChunkStored,
@@ -139,6 +145,7 @@ module Simplex.Chat.Store
updateFileTransferChatItemId,
getFileTransfer,
getFileTransferProgress,
getFileTransferMeta,
getSndFileTransfer,
getContactFileInfo,
getContactMaxItemTs,
@@ -270,6 +277,7 @@ import Simplex.Chat.Migrations.M20221001_shared_msg_id_indices
import Simplex.Chat.Migrations.M20221003_delete_broken_integrity_error_chat_items
import Simplex.Chat.Migrations.M20221004_idx_msg_deliveries_message_id
import Simplex.Chat.Migrations.M20221011_user_contact_links_group_id
import Simplex.Chat.Migrations.M20221012_inline_files
import Simplex.Chat.Protocol
import Simplex.Chat.Types
import Simplex.Messaging.Agent.Protocol (ACorrId, AgentMsgId, ConnId, InvitationId, MsgMeta (..))
@@ -310,7 +318,8 @@ schemaMigrations =
("20221001_shared_msg_id_indices", m20221001_shared_msg_id_indices),
("20221003_delete_broken_integrity_error_chat_items", m20221003_delete_broken_integrity_error_chat_items),
("20221004_idx_msg_deliveries_message_id", m20221004_idx_msg_deliveries_message_id),
("20221011_user_contact_links_group_id", m20221011_user_contact_links_group_id)
("20221011_user_contact_links_group_id", m20221011_user_contact_links_group_id),
("20221012_inline_files", m20221012_inline_files)
]
-- | The list of migrations in ascending order by date
@@ -570,28 +579,28 @@ deleteContactProfile_ db userId contactId =
updateUserProfile :: DB.Connection -> User -> Profile -> ExceptT StoreError IO ()
updateUserProfile db User {userId, userContactId, localDisplayName, profile = LocalProfile {profileId, displayName}} p'@Profile {displayName = newName}
| displayName == newName =
liftIO $ updateContactProfile_ db userId profileId p'
liftIO $ updateContactProfile_ db userId profileId p'
| otherwise =
checkConstraint SEDuplicateName . liftIO $ do
currentTs <- getCurrentTime
DB.execute db "UPDATE users SET local_display_name = ?, updated_at = ? WHERE user_id = ?" (newName, currentTs, userId)
DB.execute
db
"INSERT INTO display_names (local_display_name, ldn_base, user_id, created_at, updated_at) VALUES (?,?,?,?,?)"
(newName, newName, userId, currentTs, currentTs)
updateContactProfile_' db userId profileId p' currentTs
updateContact_ db userId userContactId localDisplayName newName currentTs
checkConstraint SEDuplicateName . liftIO $ do
currentTs <- getCurrentTime
DB.execute db "UPDATE users SET local_display_name = ?, updated_at = ? WHERE user_id = ?" (newName, currentTs, userId)
DB.execute
db
"INSERT INTO display_names (local_display_name, ldn_base, user_id, created_at, updated_at) VALUES (?,?,?,?,?)"
(newName, newName, userId, currentTs, currentTs)
updateContactProfile_' db userId profileId p' currentTs
updateContact_ db userId userContactId localDisplayName newName currentTs
updateContactProfile :: DB.Connection -> UserId -> Contact -> Profile -> ExceptT StoreError IO Contact
updateContactProfile db userId c@Contact {contactId, localDisplayName, profile = LocalProfile {profileId, displayName, localAlias}} p'@Profile {displayName = newName}
| displayName == newName =
liftIO $ updateContactProfile_ db userId profileId p' $> (c :: Contact) {profile = toLocalProfile profileId p' localAlias}
liftIO $ updateContactProfile_ db userId profileId p' $> (c :: Contact) {profile = toLocalProfile profileId p' localAlias}
| otherwise =
ExceptT . withLocalDisplayName db userId newName $ \ldn -> do
currentTs <- getCurrentTime
updateContactProfile_' db userId profileId p' currentTs
updateContact_ db userId contactId localDisplayName ldn currentTs
pure . Right $ (c :: Contact) {localDisplayName = ldn, profile = toLocalProfile profileId p' localAlias}
ExceptT . withLocalDisplayName db userId newName $ \ldn -> do
currentTs <- getCurrentTime
updateContactProfile_' db userId profileId p' currentTs
updateContact_ db userId contactId localDisplayName ldn currentTs
pure . Right $ (c :: Contact) {localDisplayName = ldn, profile = toLocalProfile profileId p' localAlias}
updateContactAlias :: DB.Connection -> UserId -> Contact -> LocalAlias -> IO Contact
updateContactAlias db userId c@Contact {profile = lp@LocalProfile {profileId}} localAlias = do
@@ -1057,7 +1066,7 @@ getLiveSndFileTransfers db User {userId} = do
SELECT DISTINCT f.file_id
FROM files f
JOIN snd_files s
WHERE f.user_id = ? AND s.file_status IN (?, ?, ?)
WHERE f.user_id = ? AND s.file_status IN (?, ?, ?) AND s.file_inline IS NULL
|]
(userId, FSNew, FSAccepted, FSConnected)
concatMap (filter liveTransfer) . rights <$> mapM (getSndFileTransfers_ db userId) fileIds
@@ -1075,7 +1084,7 @@ getLiveRcvFileTransfers db user@User {userId} = do
SELECT f.file_id
FROM files f
JOIN rcv_files r
WHERE f.user_id = ? AND r.file_status IN (?, ?)
WHERE f.user_id = ? AND r.file_status IN (?, ?) AND r.rcv_file_inline IS NULL
|]
(userId, FSAccepted, FSConnected)
rights <$> mapM (runExceptT . getRcvFileTransfer db user) fileIds
@@ -1373,7 +1382,7 @@ getConnectionEntity db user@User {userId, userContactId} agentConnId = do
DB.query
db
[sql|
SELECT s.file_status, f.file_name, f.file_size, f.chunk_size, f.file_path, cs.local_display_name, m.local_display_name
SELECT s.file_status, f.file_name, f.file_size, f.chunk_size, f.file_path, s.file_inline, cs.local_display_name, m.local_display_name
FROM snd_files s
JOIN files f USING (file_id)
LEFT JOIN contacts cs USING (contact_id)
@@ -1381,10 +1390,10 @@ getConnectionEntity db user@User {userId, userContactId} agentConnId = do
WHERE f.user_id = ? AND f.file_id = ? AND s.connection_id = ?
|]
(userId, fileId, connId)
sndFileTransfer_ :: Int64 -> Int64 -> (FileStatus, String, Integer, Integer, FilePath, Maybe ContactName, Maybe ContactName) -> Either StoreError SndFileTransfer
sndFileTransfer_ fileId connId (fileStatus, fileName, fileSize, chunkSize, filePath, contactName_, memberName_) =
sndFileTransfer_ :: Int64 -> Int64 -> (FileStatus, String, Integer, Integer, FilePath, Maybe InlineFileMode, Maybe ContactName, Maybe ContactName) -> Either StoreError SndFileTransfer
sndFileTransfer_ fileId connId (fileStatus, fileName, fileSize, chunkSize, filePath, fileInline, contactName_, memberName_) =
case contactName_ <|> memberName_ of
Just recipientDisplayName -> Right SndFileTransfer {fileId, fileStatus, fileName, fileSize, chunkSize, filePath, recipientDisplayName, connId, agentConnId}
Just recipientDisplayName -> Right SndFileTransfer {fileId, fileStatus, fileName, fileSize, chunkSize, filePath, fileInline, recipientDisplayName, connId, agentConnId}
Nothing -> Left $ SESndFileInvalid fileId
getUserContact_ :: Int64 -> ExceptT StoreError IO UserContact
getUserContact_ userContactLinkId = ExceptT $ do
@@ -2118,30 +2127,22 @@ getViaGroupContact db User {userId} GroupMember {groupMemberId} =
activeConn = toConnection connRow
in Contact {contactId, localDisplayName, profile, activeConn, viaGroup, chatSettings, createdAt, updatedAt}
createSndFileTransfer :: DB.Connection -> UserId -> Contact -> FilePath -> FileInvitation -> ConnId -> Integer -> IO Int64
createSndFileTransfer db userId Contact {contactId} filePath FileInvitation {fileName, fileSize} acId chunkSize = do
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
currentTs <- getCurrentTime
DB.execute
db
"INSERT INTO files (user_id, contact_id, file_name, file_path, file_size, chunk_size, ci_file_status, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)"
(userId, contactId, fileName, filePath, fileSize, chunkSize, CIFSSndStored, currentTs, currentTs)
"INSERT INTO files (user_id, contact_id, file_name, file_path, file_size, chunk_size, file_inline, ci_file_status, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?)"
(userId, contactId, fileName, filePath, fileSize, chunkSize, fileInline, CIFSSndStored, currentTs, currentTs)
fileId <- insertedRowId db
Connection {connId} <- createSndFileConnection_ db userId fileId acId
let fileStatus = FSNew
DB.execute
db
"INSERT INTO snd_files (file_id, file_status, connection_id, created_at, updated_at) VALUES (?,?,?,?,?)"
(fileId, fileStatus, connId, currentTs, currentTs)
pure fileId
createSndDirectFileTransfer :: DB.Connection -> UserId -> Contact -> FilePath -> FileInvitation -> Integer -> IO Int64
createSndDirectFileTransfer db userId Contact {contactId} filePath FileInvitation {fileName, fileSize} chunkSize = do
currentTs <- getCurrentTime
DB.execute
db
"INSERT INTO files (user_id, contact_id, file_name, file_path, file_size, chunk_size, ci_file_status, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)"
(userId, contactId, fileName, filePath, fileSize, chunkSize, CIFSSndStored, currentTs, currentTs)
insertedRowId db
forM_ acId_ $ \acId -> do
Connection {connId} <- createSndFileConnection_ db userId fileId acId
let fileStatus = FSNew
DB.execute
db
"INSERT INTO snd_files (file_id, file_status, file_inline, connection_id, created_at, updated_at) VALUES (?,?,?,?,?,?)"
(fileId, fileStatus, fileInline, connId, currentTs, currentTs)
pure FileTransferMeta {fileId, fileName, filePath, fileSize, fileInline, chunkSize, cancelled = False}
createSndDirectFTConnection :: DB.Connection -> User -> Int64 -> (CommandId, ConnId) -> IO ()
createSndDirectFTConnection db user@User {userId} fileId (cmdId, acId) = do
@@ -2153,14 +2154,15 @@ createSndDirectFTConnection db user@User {userId} fileId (cmdId, acId) = do
"INSERT INTO snd_files (file_id, file_status, connection_id, created_at, updated_at) VALUES (?,?,?,?,?)"
(fileId, FSAccepted, connId, currentTs, currentTs)
createSndGroupFileTransfer :: DB.Connection -> UserId -> GroupInfo -> FilePath -> FileInvitation -> Integer -> IO Int64
createSndGroupFileTransfer db userId GroupInfo {groupId} filePath FileInvitation {fileName, fileSize} chunkSize = do
createSndGroupFileTransfer :: DB.Connection -> UserId -> GroupInfo -> FilePath -> FileInvitation -> Integer -> IO FileTransferMeta
createSndGroupFileTransfer db userId GroupInfo {groupId} filePath FileInvitation {fileName, fileSize, fileInline} chunkSize = do
currentTs <- getCurrentTime
DB.execute
db
"INSERT INTO files (user_id, group_id, file_name, file_path, file_size, chunk_size, ci_file_status, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)"
(userId, groupId, fileName, filePath, fileSize, chunkSize, CIFSSndStored, currentTs, currentTs)
insertedRowId db
"INSERT INTO files (user_id, group_id, file_name, file_path, file_size, chunk_size, file_inline, ci_file_status, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?)"
(userId, groupId, fileName, filePath, fileSize, chunkSize, fileInline, CIFSSndStored, currentTs, currentTs)
fileId <- insertedRowId db
pure FileTransferMeta {fileId, 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
@@ -2172,6 +2174,63 @@ createSndGroupFileTransferConnection db user@User {userId} fileId (cmdId, acId)
"INSERT INTO snd_files (file_id, file_status, connection_id, group_member_id, created_at, updated_at) VALUES (?,?,?,?,?,?)"
(fileId, FSAccepted, connId, groupMemberId, currentTs, currentTs)
createSndDirectInlineFT :: DB.Connection -> Contact -> FileTransferMeta -> IO SndFileTransfer
createSndDirectInlineFT db Contact {localDisplayName = n, activeConn = Connection {connId, agentConnId}} FileTransferMeta {fileId, fileName, filePath, fileSize, chunkSize, fileInline} = do
currentTs <- getCurrentTime
let fileStatus = FSConnected
fileInline' = Just $ fromMaybe (IFMOffer) fileInline
DB.execute
db
"INSERT INTO snd_files (file_id, file_status, file_inline, connection_id, created_at, updated_at) VALUES (?,?,?,?,?,?)"
(fileId, fileStatus, fileInline', connId, currentTs, currentTs)
pure SndFileTransfer {fileId, fileName, filePath, fileSize, chunkSize, recipientDisplayName = n, connId, agentConnId, fileStatus, fileInline = fileInline'}
createSndGroupInlineFT :: DB.Connection -> GroupMember -> Connection -> FileTransferMeta -> IO SndFileTransfer
createSndGroupInlineFT db GroupMember {groupMemberId, localDisplayName = n} Connection {connId, agentConnId} FileTransferMeta {fileId, fileName, filePath, fileSize, chunkSize, fileInline} = do
currentTs <- getCurrentTime
let fileStatus = FSConnected
fileInline' = Just $ fromMaybe (IFMOffer) fileInline
DB.execute
db
"INSERT INTO snd_files (file_id, file_status, file_inline, connection_id, group_member_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?)"
(fileId, fileStatus, fileInline', connId, groupMemberId, currentTs, currentTs)
pure SndFileTransfer {fileId, fileName, filePath, fileSize, chunkSize, recipientDisplayName = n, connId, agentConnId, fileStatus, fileInline = fileInline'}
updateSndDirectFTDelivery :: DB.Connection -> Contact -> FileTransferMeta -> Int64 -> IO ()
updateSndDirectFTDelivery db Contact {activeConn = Connection {connId}} FileTransferMeta {fileId} msgDeliveryId =
DB.execute
db
"UPDATE snd_files SET last_inline_msg_delivery_id = ? WHERE connection_id = ? AND file_id = ? AND file_inline IS NOT NULL"
(msgDeliveryId, connId, fileId)
updateSndGroupFTDelivery :: DB.Connection -> GroupMember -> Connection -> FileTransferMeta -> Int64 -> IO ()
updateSndGroupFTDelivery db GroupMember {groupMemberId} Connection {connId} FileTransferMeta {fileId} msgDeliveryId =
DB.execute
db
"UPDATE snd_files SET last_inline_msg_delivery_id = ? WHERE group_member_id = ? AND connection_id = ? AND file_id = ? AND file_inline IS NOT NULL"
(msgDeliveryId, groupMemberId, connId, fileId)
getSndInlineFTViaMsgDelivery :: DB.Connection -> User -> Connection -> AgentMsgId -> IO (Maybe SndFileTransfer)
getSndInlineFTViaMsgDelivery db User {userId} Connection {connId, agentConnId} agentMsgId = do
(sndFileTransfer_ <=< listToMaybe)
<$> DB.query
db
[sql|
SELECT s.file_id, s.file_status, f.file_name, f.file_size, f.chunk_size, f.file_path, s.file_inline, c.local_display_name, m.local_display_name
FROM msg_deliveries d
JOIN snd_files s ON s.connection_id = d.connection_id AND s.last_inline_msg_delivery_id = d.msg_delivery_id
JOIN files f ON f.file_id = s.file_id
LEFT JOIN contacts c USING (contact_id)
LEFT JOIN group_members m USING (group_member_id)
WHERE d.connection_id = ? AND d.agent_msg_id = ? AND f.user_id = ? AND s.file_inline IS NOT NULL
|]
(connId, agentMsgId, userId)
where
sndFileTransfer_ :: (Int64, FileStatus, String, Integer, Integer, FilePath, Maybe InlineFileMode, Maybe ContactName, Maybe ContactName) -> Maybe SndFileTransfer
sndFileTransfer_ (fileId, fileStatus, fileName, fileSize, chunkSize, filePath, fileInline, contactName_, memberName_) =
(\n -> SndFileTransfer {fileId, fileStatus, fileName, fileSize, chunkSize, filePath, fileInline, recipientDisplayName = n, connId, agentConnId})
<$> (contactName_ <|> memberName_)
updateFileCancelled :: MsgDirectionI d => DB.Connection -> User -> Int64 -> CIFileStatus d -> IO ()
updateFileCancelled db User {userId} fileId ciFileStatus = do
currentTs <- getCurrentTime
@@ -2308,43 +2367,44 @@ deleteSndFileChunks :: DB.Connection -> SndFileTransfer -> IO ()
deleteSndFileChunks db SndFileTransfer {fileId, connId} =
DB.execute db "DELETE FROM snd_file_chunks WHERE file_id = ? AND connection_id = ?" (fileId, connId)
createRcvFileTransfer :: DB.Connection -> UserId -> Contact -> FileInvitation -> Integer -> IO RcvFileTransfer
createRcvFileTransfer db userId Contact {contactId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileConnReq} chunkSize = do
createRcvFileTransfer :: DB.Connection -> UserId -> Contact -> FileInvitation -> Maybe InlineFileMode -> Integer -> IO RcvFileTransfer
createRcvFileTransfer db userId Contact {contactId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileConnReq, fileInline} rcvFileInline chunkSize = do
currentTs <- getCurrentTime
DB.execute
db
"INSERT INTO files (user_id, contact_id, file_name, file_size, chunk_size, ci_file_status, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)"
(userId, contactId, fileName, fileSize, chunkSize, CIFSRcvInvitation, currentTs, currentTs)
"INSERT INTO files (user_id, contact_id, file_name, file_size, chunk_size, file_inline, ci_file_status, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)"
(userId, contactId, fileName, fileSize, chunkSize, fileInline, CIFSRcvInvitation, currentTs, currentTs)
fileId <- insertedRowId db
DB.execute
db
"INSERT INTO rcv_files (file_id, file_status, file_queue_info, created_at, updated_at) VALUES (?,?,?,?,?)"
(fileId, FSNew, fileConnReq, currentTs, currentTs)
pure RcvFileTransfer {fileId, fileInvitation = f, fileStatus = RFSNew, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Nothing}
"INSERT INTO rcv_files (file_id, file_status, file_queue_info, file_inline, rcv_file_inline, created_at, updated_at) VALUES (?,?,?,?,?,?,?)"
(fileId, FSNew, fileConnReq, fileInline, rcvFileInline, currentTs, currentTs)
pure RcvFileTransfer {fileId, fileInvitation = f, fileStatus = RFSNew, rcvFileInline, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Nothing}
createRcvGroupFileTransfer :: DB.Connection -> UserId -> GroupMember -> FileInvitation -> Integer -> IO RcvFileTransfer
createRcvGroupFileTransfer db userId GroupMember {groupId, groupMemberId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileConnReq} chunkSize = do
createRcvGroupFileTransfer :: DB.Connection -> UserId -> GroupMember -> FileInvitation -> Maybe InlineFileMode -> Integer -> IO RcvFileTransfer
createRcvGroupFileTransfer db userId GroupMember {groupId, groupMemberId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileConnReq, fileInline} rcvFileInline chunkSize = do
currentTs <- getCurrentTime
DB.execute
db
"INSERT INTO files (user_id, group_id, file_name, file_size, chunk_size, ci_file_status, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)"
(userId, groupId, fileName, fileSize, chunkSize, CIFSRcvInvitation, currentTs, currentTs)
"INSERT INTO files (user_id, group_id, file_name, file_size, chunk_size, file_inline, ci_file_status, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)"
(userId, groupId, fileName, fileSize, chunkSize, fileInline, CIFSRcvInvitation, currentTs, currentTs)
fileId <- insertedRowId db
DB.execute
db
"INSERT INTO rcv_files (file_id, file_status, file_queue_info, group_member_id, created_at, updated_at) VALUES (?,?,?,?,?,?)"
(fileId, FSNew, fileConnReq, groupMemberId, currentTs, currentTs)
pure RcvFileTransfer {fileId, fileInvitation = f, fileStatus = RFSNew, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Just groupMemberId}
"INSERT INTO rcv_files (file_id, file_status, file_queue_info, file_inline, rcv_file_inline, group_member_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)"
(fileId, FSNew, fileConnReq, fileInline, rcvFileInline, groupMemberId, currentTs, currentTs)
pure RcvFileTransfer {fileId, fileInvitation = f, fileStatus = RFSNew, rcvFileInline, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Just groupMemberId}
getRcvFileTransfer :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO RcvFileTransfer
getRcvFileTransfer db User {userId} fileId =
ExceptT . firstRow' rcvFileTransfer (SERcvFileNotFound fileId) $
DB.query
db
[sql|
getRcvFileTransfer db user@User {userId} fileId = do
rftRow <-
ExceptT . firstRow id (SERcvFileNotFound fileId) $
DB.query
db
[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, c.connection_id, c.agent_conn_id
f.file_size, f.chunk_size, f.cancelled, cs.contact_id, cs.local_display_name, m.group_id, m.group_member_id, m.local_display_name,
f.file_path, r.file_inline, r.rcv_file_inline, 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
@@ -2352,35 +2412,62 @@ getRcvFileTransfer db User {userId} fileId =
LEFT JOIN group_members m USING (group_member_id)
WHERE f.user_id = ? AND f.file_id = ?
|]
(userId, fileId)
(userId, fileId)
rcvFileTransfer rftRow
where
rcvFileTransfer ::
(FileStatus, Maybe ConnReqInvitation, Maybe Int64, String, Integer, Integer, Maybe Bool, Maybe ContactName, Maybe ContactName, Maybe FilePath, Maybe Int64, Maybe AgentConnId) ->
Either StoreError RcvFileTransfer
rcvFileTransfer (fileStatus', fileConnReq, grpMemberId, fileName, fileSize, chunkSize, cancelled_, contactName_, memberName_, filePath_, connId_, agentConnId_) =
let fileInv = FileInvitation {fileName, fileSize, fileConnReq}
fileInfo = (filePath_, connId_, agentConnId_)
in case contactName_ <|> memberName_ of
Nothing -> Left $ SERcvFileInvalid fileId
Just name ->
case fileStatus' of
FSNew -> ft name fileInv RFSNew
FSAccepted -> ft name fileInv . RFSAccepted =<< rfi fileInfo
FSConnected -> ft name fileInv . RFSConnected =<< rfi fileInfo
FSComplete -> ft name fileInv . RFSComplete =<< rfi fileInfo
FSCancelled -> ft name fileInv . RFSCancelled $ rfi_ fileInfo
(FileStatus, Maybe ConnReqInvitation, Maybe Int64, String, Integer, Integer, Maybe Bool) :. (Maybe Int64, Maybe ContactName, Maybe Int64, Maybe Int64, Maybe ContactName, Maybe FilePath, Maybe InlineFileMode, Maybe InlineFileMode) :. (Maybe Int64, Maybe AgentConnId) ->
ExceptT StoreError IO RcvFileTransfer
rcvFileTransfer ((fileStatus', fileConnReq, grpMemberId, fileName, fileSize, chunkSize, cancelled_) :. (contactId_, contactName_, groupId_, groupMemberId_, memberName_, filePath_, fileInline, rcvFileInline) :. (connId_, agentConnId_)) = do
let fileInv = FileInvitation {fileName, fileSize, fileConnReq, fileInline}
fileInfo = (filePath_, connId_, agentConnId_, contactId_, groupId_, groupMemberId_, isJust fileInline)
case contactName_ <|> memberName_ of
Nothing -> throwError $ SERcvFileInvalid fileId
Just name -> do
case fileStatus' of
FSNew -> pure $ ft name fileInv RFSNew
FSAccepted -> ft name fileInv . RFSAccepted <$> rfi fileInfo
FSConnected -> ft name fileInv . RFSConnected <$> rfi fileInfo
FSComplete -> ft name fileInv . RFSComplete <$> rfi fileInfo
FSCancelled -> ft name fileInv . RFSCancelled <$> rfi_ fileInfo
where
ft senderDisplayName fileInvitation fileStatus =
Right RcvFileTransfer {fileId, fileInvitation, fileStatus, senderDisplayName, chunkSize, cancelled, grpMemberId}
rfi fileInfo = maybe (Left $ SERcvFileInvalid fileId) Right $ rfi_ fileInfo
RcvFileTransfer {fileId, fileInvitation, fileStatus, rcvFileInline, senderDisplayName, chunkSize, cancelled, grpMemberId}
rfi fileInfo = maybe (throwError $ SERcvFileInvalid fileId) pure =<< rfi_ fileInfo
rfi_ = \case
(Just filePath, Just connId, Just agentConnId) -> Just RcvFileInfo {filePath, connId, agentConnId}
_ -> Nothing
(Just filePath, Just connId, Just agentConnId, _, _, _, _) -> pure $ Just RcvFileInfo {filePath, connId, agentConnId}
(Just filePath, Nothing, Nothing, Just contactId, _, _, True) -> do
Contact {activeConn = Connection {connId, agentConnId}} <- getContact db userId contactId
pure $ Just RcvFileInfo {filePath, connId, agentConnId}
(Just filePath, Nothing, Nothing, _, Just groupId, Just groupMemberId, True) -> do
getGroupMember db user groupId groupMemberId >>= \case
GroupMember {activeConn = Just Connection {connId, agentConnId}} ->
pure $ Just RcvFileInfo {filePath, connId, agentConnId}
_ -> pure Nothing
_ -> pure Nothing
cancelled = fromMaybe False cancelled_
acceptRcvFileTransfer :: DB.Connection -> User -> Int64 -> ConnId -> ConnStatus -> FilePath -> ExceptT StoreError IO AChatItem
acceptRcvFileTransfer db user@User {userId} fileId agentConnId connStatus filePath = ExceptT $ do
currentTs <- getCurrentTime
acceptRcvFT_ db user fileId filePath currentTs
DB.execute
db
"INSERT INTO connections (agent_conn_id, conn_status, conn_type, rcv_file_id, user_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?)"
(agentConnId, connStatus, ConnRcvFile, fileId, userId, currentTs, currentTs)
runExceptT $ getChatItemByFileId db user fileId
acceptRcvInlineFT :: DB.Connection -> User -> Int64 -> FilePath -> ExceptT StoreError IO AChatItem
acceptRcvInlineFT db user fileId filePath = do
liftIO $ acceptRcvFT_ db user fileId filePath =<< getCurrentTime
getChatItemByFileId db user fileId
startRcvInlineFT :: DB.Connection -> User -> RcvFileTransfer -> FilePath -> IO ()
startRcvInlineFT db user RcvFileTransfer {fileId} filePath =
acceptRcvFT_ db user fileId filePath =<< getCurrentTime
acceptRcvFT_ :: DB.Connection -> User -> Int64 -> FilePath -> UTCTime -> IO ()
acceptRcvFT_ db User {userId} fileId filePath currentTs = do
DB.execute
db
"UPDATE files SET file_path = ?, ci_file_status = ?, updated_at = ? WHERE user_id = ? AND file_id = ?"
@@ -2389,11 +2476,6 @@ acceptRcvFileTransfer db user@User {userId} fileId agentConnId connStatus filePa
db
"UPDATE rcv_files SET file_status = ?, updated_at = ? WHERE file_id = ?"
(FSAccepted, currentTs, fileId)
DB.execute
db
"INSERT INTO connections (agent_conn_id, conn_status, conn_type, rcv_file_id, user_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?)"
(agentConnId, connStatus, ConnRcvFile, fileId, userId, currentTs, currentTs)
runExceptT $ getChatItemByFileId db user fileId
updateRcvFileStatus :: DB.Connection -> RcvFileTransfer -> FileStatus -> IO ()
updateRcvFileStatus db RcvFileTransfer {fileId} status = do
@@ -2416,20 +2498,20 @@ createRcvFileChunk db RcvFileTransfer {fileId, fileInvitation = FileInvitation {
pure $ case map fromOnly ns of
[]
| chunkNo == 1 ->
if chunkSize >= fileSize
then RcvChunkFinal
else RcvChunkOk
if chunkSize >= fileSize
then RcvChunkFinal
else RcvChunkOk
| otherwise -> RcvChunkError
n : _
| chunkNo == n -> RcvChunkDuplicate
| chunkNo == n + 1 ->
let prevSize = n * chunkSize
in if prevSize >= fileSize
then RcvChunkError
else
if prevSize + chunkSize >= fileSize
then RcvChunkFinal
else RcvChunkOk
let prevSize = n * chunkSize
in if prevSize >= fileSize
then RcvChunkError
else
if prevSize + chunkSize >= fileSize
then RcvChunkFinal
else RcvChunkOk
| otherwise -> RcvChunkError
updatedRcvFileChunkStored :: DB.Connection -> RcvFileTransfer -> Integer -> IO ()
@@ -2485,18 +2567,18 @@ getFileTransfer db user@User {userId} fileId =
(userId, fileId)
getSndFileTransfer :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO (FileTransferMeta, [SndFileTransfer])
getSndFileTransfer db User {userId} fileId = do
fileTransferMeta <- ExceptT $ getFileTransferMeta_ db userId fileId
getSndFileTransfer db user@User {userId} fileId = do
fileTransferMeta <- getFileTransferMeta db user fileId
sndFileTransfers <- ExceptT $ getSndFileTransfers_ db userId fileId
pure (fileTransferMeta, sndFileTransfers)
getSndFileTransfers_ :: DB.Connection -> UserId -> Int64 -> IO (Either StoreError [SndFileTransfer])
getSndFileTransfers_ db userId fileId =
sndFileTransfers
mapM sndFileTransfer
<$> DB.query
db
[sql|
SELECT s.file_status, f.file_name, f.file_size, f.chunk_size, f.file_path, s.connection_id, c.agent_conn_id,
SELECT s.file_status, f.file_name, f.file_size, f.chunk_size, f.file_path, s.file_inline, s.connection_id, c.agent_conn_id,
cs.local_display_name, m.local_display_name
FROM snd_files s
JOIN files f USING (file_id)
@@ -2507,29 +2589,27 @@ getSndFileTransfers_ db userId fileId =
|]
(userId, fileId)
where
sndFileTransfers :: [(FileStatus, String, Integer, Integer, FilePath, Int64, AgentConnId, Maybe ContactName, Maybe ContactName)] -> Either StoreError [SndFileTransfer]
sndFileTransfers [] = Right []
sndFileTransfers fts = mapM sndFileTransfer fts
sndFileTransfer (fileStatus, fileName, fileSize, chunkSize, filePath, connId, agentConnId, contactName_, memberName_) =
sndFileTransfer :: (FileStatus, String, Integer, Integer, FilePath, Maybe InlineFileMode, Int64, AgentConnId, Maybe ContactName, Maybe ContactName) -> Either StoreError SndFileTransfer
sndFileTransfer (fileStatus, fileName, fileSize, chunkSize, filePath, fileInline, connId, agentConnId, contactName_, memberName_) =
case contactName_ <|> memberName_ of
Just recipientDisplayName -> Right SndFileTransfer {fileId, fileStatus, fileName, fileSize, chunkSize, filePath, recipientDisplayName, connId, agentConnId}
Just recipientDisplayName -> Right SndFileTransfer {fileId, fileStatus, fileName, fileSize, chunkSize, filePath, fileInline, recipientDisplayName, connId, agentConnId}
Nothing -> Left $ SESndFileInvalid fileId
getFileTransferMeta_ :: DB.Connection -> UserId -> Int64 -> IO (Either StoreError FileTransferMeta)
getFileTransferMeta_ db userId fileId =
firstRow fileTransferMeta (SEFileNotFound fileId) $
getFileTransferMeta :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO FileTransferMeta
getFileTransferMeta db User {userId} fileId =
ExceptT . firstRow fileTransferMeta (SEFileNotFound fileId) $
DB.query
db
[sql|
SELECT f.file_name, f.file_size, f.chunk_size, f.file_path, f.cancelled
SELECT f.file_name, f.file_size, f.chunk_size, f.file_path, f.file_inline, f.cancelled
FROM files f
WHERE f.user_id = ? AND f.file_id = ?
|]
(userId, fileId)
where
fileTransferMeta :: (String, Integer, Integer, FilePath, Maybe Bool) -> FileTransferMeta
fileTransferMeta (fileName, fileSize, chunkSize, filePath, cancelled_) =
FileTransferMeta {fileId, fileName, filePath, fileSize, chunkSize, cancelled = fromMaybe False cancelled_}
fileTransferMeta :: (String, Integer, Integer, FilePath, Maybe InlineFileMode, Maybe Bool) -> FileTransferMeta
fileTransferMeta (fileName, fileSize, chunkSize, filePath, fileInline, cancelled_) =
FileTransferMeta {fileId, fileName, fileSize, chunkSize, filePath, fileInline, cancelled = fromMaybe False cancelled_}
getContactFileInfo :: DB.Connection -> User -> Contact -> IO [CIFileInfo]
getContactFileInfo db User {userId} Contact {contactId} =
@@ -2601,7 +2681,7 @@ updateGroupTs db User {userId} GroupInfo {groupId} updatedAt =
"UPDATE groups SET updated_at = ? WHERE user_id = ? AND group_id = ?"
(updatedAt, userId, groupId)
createNewSndMessage :: DB.Connection -> TVar ChaChaDRG -> ConnOrGroupId -> (SharedMsgId -> NewMessage) -> ExceptT StoreError IO SndMessage
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
@@ -2622,13 +2702,14 @@ createNewSndMessage db gVar connOrGroupId mkMessage =
ConnectionId connId -> (Just connId, Nothing)
GroupId groupId -> (Nothing, Just groupId)
createSndMsgDelivery :: DB.Connection -> SndMsgDelivery -> MessageId -> IO ()
createSndMsgDelivery :: DB.Connection -> SndMsgDelivery -> MessageId -> IO Int64
createSndMsgDelivery db sndMsgDelivery messageId = do
currentTs <- getCurrentTime
msgDeliveryId <- createSndMsgDelivery_ db sndMsgDelivery messageId currentTs
createMsgDeliveryEvent_ db msgDeliveryId MDSSndAgent currentTs
pure msgDeliveryId
createNewMessageAndRcvMsgDelivery :: DB.Connection -> ConnOrGroupId -> NewMessage -> Maybe SharedMsgId -> RcvMsgDelivery -> IO RcvMessage
createNewMessageAndRcvMsgDelivery :: forall e. MsgEncodingI e => DB.Connection -> ConnOrGroupId -> NewMessage e -> Maybe SharedMsgId -> RcvMsgDelivery -> IO RcvMessage
createNewMessageAndRcvMsgDelivery db connOrGroupId NewMessage {chatMsgEvent, msgBody} sharedMsgId_ RcvMsgDelivery {connId, agentMsgId, agentMsgMeta, agentAckCmdId} = do
currentTs <- getCurrentTime
DB.execute
@@ -2642,7 +2723,7 @@ createNewMessageAndRcvMsgDelivery db connOrGroupId NewMessage {chatMsgEvent, msg
(msgId, connId, agentMsgId, msgMetaJson agentMsgMeta, agentAckCmdId, snd $ broker agentMsgMeta, currentTs, currentTs)
msgDeliveryId <- insertedRowId db
createMsgDeliveryEvent_ db msgDeliveryId MDSRcvAgent currentTs
pure RcvMessage {msgId, chatMsgEvent, sharedMsgId_, msgBody}
pure RcvMessage {msgId, chatMsgEvent = ACME (encoding @e) chatMsgEvent, sharedMsgId_, msgBody}
where
(connId_, groupId_) = case connOrGroupId of
ConnectionId connId' -> (Just connId', Nothing)
@@ -3382,14 +3463,14 @@ getGroupInfo db User {userId, userContactId} groupId =
updateGroupProfile :: DB.Connection -> User -> GroupInfo -> GroupProfile -> ExceptT StoreError IO GroupInfo
updateGroupProfile db User {userId} g@GroupInfo {groupId, localDisplayName, groupProfile = GroupProfile {displayName}} p'@GroupProfile {displayName = newName, fullName, image}
| displayName == newName = liftIO $ do
currentTs <- getCurrentTime
updateGroupProfile_ currentTs $> (g :: GroupInfo) {groupProfile = p'}
| otherwise =
ExceptT . withLocalDisplayName db userId newName $ \ldn -> do
currentTs <- getCurrentTime
updateGroupProfile_ currentTs
updateGroup_ ldn currentTs
pure . Right $ (g :: GroupInfo) {localDisplayName = ldn, groupProfile = p'}
updateGroupProfile_ currentTs $> (g :: GroupInfo) {groupProfile = p'}
| otherwise =
ExceptT . withLocalDisplayName db userId newName $ \ldn -> do
currentTs <- getCurrentTime
updateGroupProfile_ currentTs
updateGroup_ ldn currentTs
pure . Right $ (g :: GroupInfo) {localDisplayName = ldn, groupProfile = p'}
where
updateGroupProfile_ currentTs =
DB.execute
+38 -4
View File
@@ -613,7 +613,8 @@ data SndFileTransfer = SndFileTransfer
recipientDisplayName :: ContactName,
connId :: Int64,
agentConnId :: AgentConnId,
fileStatus :: FileStatus
fileStatus :: FileStatus,
fileInline :: Maybe InlineFileMode
}
deriving (Eq, Show, Generic)
@@ -627,16 +628,48 @@ type FileTransferId = Int64
data FileInvitation = FileInvitation
{ fileName :: String,
fileSize :: Integer,
fileConnReq :: Maybe ConnReqInvitation
fileConnReq :: Maybe ConnReqInvitation,
fileInline :: Maybe InlineFileMode
}
deriving (Eq, Show, Generic, FromJSON)
deriving (Eq, Show, Generic)
instance ToJSON FileInvitation where toEncoding = J.genericToEncoding J.defaultOptions
instance ToJSON FileInvitation where
toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
instance FromJSON FileInvitation where
parseJSON = J.genericParseJSON J.defaultOptions {J.omitNothingFields = True}
data InlineFileMode
= IFMOffer -- file will be sent inline once accepted
| IFMSent -- file is sent inline without acceptance
deriving (Eq, Show, Generic)
instance TextEncoding InlineFileMode where
textEncode = \case
IFMOffer -> "offer"
IFMSent -> "sent"
textDecode = \case
"offer" -> Just IFMOffer
"sent" -> Just IFMSent
_ -> Nothing
instance FromField InlineFileMode where fromField = fromTextField_ textDecode
instance ToField InlineFileMode where toField = toField . textEncode
instance FromJSON InlineFileMode where
parseJSON = J.withText "InlineFileMode" $ maybe (fail "bad InlineFileMode") pure . textDecode
instance ToJSON InlineFileMode where
toJSON = J.String . textEncode
toEncoding = JE.text . textEncode
data RcvFileTransfer = RcvFileTransfer
{ fileId :: FileTransferId,
fileInvitation :: FileInvitation,
fileStatus :: RcvFileStatus,
rcvFileInline :: Maybe InlineFileMode,
senderDisplayName :: ContactName,
chunkSize :: Integer,
cancelled :: Bool,
@@ -724,6 +757,7 @@ data FileTransferMeta = FileTransferMeta
fileName :: String,
filePath :: String,
fileSize :: Integer,
fileInline :: Maybe InlineFileMode,
chunkSize :: Integer,
cancelled :: Bool
}
+19 -28
View File
@@ -241,7 +241,7 @@ showSMPServer = B.unpack . strEncode . host
viewHostEvent :: AProtocolType -> TransportHost -> String
viewHostEvent p h = map toUpper (B.unpack $ strEncode p) <> " host " <> B.unpack (strEncode h)
viewChatItem :: MsgDirectionI d => ChatInfo c -> ChatItem c d -> Bool -> [StyledString]
viewChatItem :: forall c d. MsgDirectionI d => ChatInfo c -> ChatItem c d -> Bool -> [StyledString]
viewChatItem chat ChatItem {chatDir, meta, content, quotedItem, file} doShow = case chat of
DirectChat c -> case chatDir of
CIDirectSnd -> case content of
@@ -714,9 +714,9 @@ viewContactUpdated
| n == n' && fullName == fullName' = []
| n == n' = ["contact " <> ttyContact n <> fullNameUpdate]
| otherwise =
[ "contact " <> ttyContact n <> " changed to " <> ttyFullName n' fullName',
"use " <> ttyToContact n' <> highlight' "<message>" <> " to send messages"
]
[ "contact " <> ttyContact n <> " changed to " <> ttyFullName n' fullName',
"use " <> ttyToContact n' <> highlight' "<message>" <> " to send messages"
]
where
fullNameUpdate = if T.null fullName' || fullName' == n' then " removed full name" else " updated full name: " <> plain fullName'
@@ -748,9 +748,14 @@ viewSentBroadcast :: MsgContent -> Int -> ZonedTime -> [StyledString]
viewSentBroadcast mc n ts = prependFirst (highlight' "/feed" <> " (" <> sShow n <> ") " <> ttyMsgTime ts <> " ") (ttyMsgContent mc)
viewSentFileInvitation :: StyledString -> CIFile d -> CIMeta d -> [StyledString]
viewSentFileInvitation to CIFile {fileId, filePath} = case filePath of
Just fPath -> sentWithTime_ $ ttySentFile to fileId fPath
viewSentFileInvitation to CIFile {fileId, filePath, fileStatus} = case filePath of
Just fPath -> sentWithTime_ $ ttySentFile fPath
_ -> const []
where
ttySentFile fPath = ["/f " <> to <> ttyFilePath fPath] <> cancelSending
cancelSending = case fileStatus of
CIFSSndTransfer -> []
_ -> ["use " <> highlight ("/fc " <> show fileId) <> " to cancel sending"]
sentWithTime_ :: [StyledString] -> CIMeta d -> [StyledString]
sentWithTime_ styledMsg CIMeta {localItemTs} =
@@ -762,9 +767,6 @@ ttyMsgTime = styleTime . formatTime defaultTimeLocale "%H:%M"
ttyMsgContent :: MsgContent -> [StyledString]
ttyMsgContent = msgPlain . msgContentText
ttySentFile :: StyledString -> FileTransferId -> FilePath -> [StyledString]
ttySentFile to fId fPath = ["/f " <> to <> ttyFilePath fPath, "use " <> highlight ("/fc " <> show fId) <> " to cancel sending"]
prependFirst :: StyledString -> [StyledString] -> [StyledString]
prependFirst s [] = [s]
prependFirst s (s' : ss) = (s <> s') : ss
@@ -793,21 +795,11 @@ viewReceivedFileInvitation :: StyledString -> CIFile d -> CIMeta d -> [StyledStr
viewReceivedFileInvitation from file meta = receivedWithTime_ from [] meta (receivedFileInvitation_ file)
receivedFileInvitation_ :: CIFile d -> [StyledString]
receivedFileInvitation_ CIFile {fileId, fileName, fileSize} =
[ "sends file " <> ttyFilePath fileName <> " (" <> humanReadableSize fileSize <> " / " <> sShow fileSize <> " bytes)",
-- below is printed for auto-accepted files as well; auto-accept is disabled in terminal though so in reality it never happens
"use " <> highlight ("/fr " <> show fileId <> " [<dir>/ | <path>]") <> " to receive it"
]
-- TODO remove
viewReceivedFileInvitation' :: StyledString -> RcvFileTransfer -> CIMeta d -> [StyledString]
viewReceivedFileInvitation' from RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName, fileSize}} meta = receivedWithTime_ from [] meta (receivedFileInvitation_' fileId fileName fileSize)
receivedFileInvitation_' :: Int64 -> String -> Integer -> [StyledString]
receivedFileInvitation_' fileId fileName fileSize =
[ "sends file " <> ttyFilePath fileName <> " (" <> humanReadableSize fileSize <> " / " <> sShow fileSize <> " bytes)",
"use " <> highlight ("/fr " <> show fileId <> " [<dir>/ | <path>]") <> " to receive it"
]
receivedFileInvitation_ CIFile {fileId, fileName, fileSize, fileStatus} =
["sends file " <> ttyFilePath fileName <> " (" <> humanReadableSize fileSize <> " / " <> sShow fileSize <> " bytes)"]
<> case fileStatus of
CIFSRcvAccepted -> []
_ -> ["use " <> highlight ("/fr " <> show fileId <> " [<dir>/ | <path>]") <> " to receive it"]
humanReadableSize :: Integer -> StyledString
humanReadableSize size
@@ -849,9 +841,8 @@ fileTransferStr fileId fileName = "file " <> sShow fileId <> " (" <> ttyFilePath
viewFileTransferStatus :: (FileTransfer, [Integer]) -> [StyledString]
viewFileTransferStatus (FTSnd FileTransferMeta {fileId, fileName, cancelled} [], _) =
[ "sending " <> fileTransferStr fileId fileName <> ": no file transfers"
<> if cancelled then ", file transfer cancelled" else ""
]
["sending " <> fileTransferStr fileId fileName <> ": no file transfers"]
<> ["file transfer cancelled" | cancelled]
viewFileTransferStatus (FTSnd FileTransferMeta {cancelled} fts@(ft : _), chunksNum) =
recipientStatuses <> ["file transfer cancelled" | cancelled]
where
@@ -978,7 +969,7 @@ viewChatError = \case
CEGroupCantResendInvitation g c -> viewCannotResendInvitation g c
CEGroupInternal s -> ["chat group bug: " <> plain s]
CEFileNotFound f -> ["file not found: " <> plain f]
CEFileAlreadyReceiving f -> ["file is already accepted: " <> plain f]
CEFileAlreadyReceiving f -> ["file is already being received: " <> plain f]
CEFileCancelled f -> ["file cancelled: " <> plain f]
CEFileAlreadyExists f -> ["file already exists: " <> plain f]
CEFileRead f e -> ["cannot read file " <> plain f, sShow e]