diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 11fb655fc7..3b1ef5878c 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -471,7 +471,7 @@ processChatCommand = \case let CIMeta {itemTs, createdAt, updatedAt} = meta ciInfo = ChatItemInfo {chatItemId = itemId, itemTs, createdAt, updatedAt, itemVersions} pure $ CRChatItemInfo user chatItem ciInfo - APISendMessage (ChatRef cType chatId) live (ComposedMessage file_ quotedItemId_ mc) -> withUser $ \user@User {userId} -> withChatLock "sendMessage" $ case cType of + APISendMessage (ChatRef cType chatId) live ttl (ComposedMessage file_ quotedItemId_ mc) -> withUser $ \user@User {userId} -> withChatLock "sendMessage" $ case cType of CTDirect -> do ct@Contact {contactId, localDisplayName = c, contactUsed} <- withStore $ \db -> getContact db user chatId assertDirectAllowed user MDSnd ct XMsgNew_ @@ -480,7 +480,7 @@ processChatCommand = \case then pure $ chatCmdError (Just user) ("feature not allowed " <> T.unpack (chatFeatureNameText CFVoice)) else do (fInv_, ciFile_, ft_) <- unzipMaybe3 <$> setupSndFileTransfer ct - timed_ <- sndContactCITimed live ct + timed_ <- sndContactCITimed live ttl ct (msgContainer, quotedItem_) <- prepareMsg fInv_ timed_ (msg@SndMessage {sharedMsgId}, _) <- sendDirectContactMessage ct (XMsgNew msgContainer) case ft_ of @@ -540,7 +540,7 @@ processChatCommand = \case then pure $ chatCmdError (Just user) ("feature not allowed " <> T.unpack (groupFeatureNameText GFVoice)) else do (fInv_, ciFile_, ft_) <- unzipMaybe3 <$> setupSndFileTransfer g (length $ filter memberCurrent ms) - timed_ <- sndGroupCITimed live gInfo + timed_ <- sndGroupCITimed live ttl gInfo (msgContainer, quotedItem_) <- prepareMsg fInv_ timed_ membership msg@SndMessage {sharedMsgId} <- sendGroupMessage user gInfo ms (XMsgNew msgContainer) mapM_ (sendGroupFileInline ms sharedMsgId) ft_ @@ -1206,7 +1206,7 @@ processChatCommand = \case contactId <- withStore $ \db -> getContactIdByName db user cName quotedItemId <- withStore $ \db -> getDirectChatItemIdByText db userId contactId msgDir quotedMsg let mc = MCText msg - processChatCommand . APISendMessage (ChatRef CTDirect contactId) False $ ComposedMessage Nothing (Just quotedItemId) mc + processChatCommand . APISendMessage (ChatRef CTDirect contactId) False Nothing $ ComposedMessage Nothing (Just quotedItemId) mc DeleteMessage chatName deletedMsg -> withUser $ \user -> do chatRef <- getChatRef user chatName deletedItemId <- getSentChatItemIdByText user chatRef deletedMsg @@ -1404,7 +1404,7 @@ processChatCommand = \case groupId <- withStore $ \db -> getGroupIdByName db user gName quotedItemId <- withStore $ \db -> getGroupChatItemIdByText db user groupId cName quotedMsg let mc = MCText msg - processChatCommand . APISendMessage (ChatRef CTGroup groupId) False $ ComposedMessage Nothing (Just quotedItemId) mc + processChatCommand . APISendMessage (ChatRef CTGroup groupId) False Nothing $ ComposedMessage Nothing (Just quotedItemId) mc LastChats count_ -> withUser' $ \user -> do chats <- withStore' $ \db -> getChatPreviews db user False pure $ CRChats $ maybe id take count_ chats @@ -1436,7 +1436,7 @@ processChatCommand = \case asks showLiveItems >>= atomically . (`writeTVar` on) >> ok_ SendFile chatName f -> withUser $ \user -> do chatRef <- getChatRef user chatName - processChatCommand . APISendMessage chatRef False $ ComposedMessage (Just f) Nothing (MCFile "") + processChatCommand . APISendMessage chatRef False Nothing $ ComposedMessage (Just f) Nothing (MCFile "") SendImage chatName f -> withUser $ \user -> do chatRef <- getChatRef user chatName filePath <- toFSFilePath f @@ -1444,7 +1444,7 @@ processChatCommand = \case fileSize <- getFileSize filePath unless (fileSize <= maxImageSize) $ throwChatError CEFileImageSize {filePath} -- TODO include file description for preview - processChatCommand . APISendMessage chatRef False $ ComposedMessage (Just f) Nothing (MCImage "" fixedImagePreview) + processChatCommand . APISendMessage chatRef False Nothing $ ComposedMessage (Just f) Nothing (MCImage "" fixedImagePreview) ForwardFile chatName fileId -> forwardFile chatName fileId SendFile ForwardImage chatName fileId -> forwardFile chatName fileId SendImage SendFileDescription _chatName _f -> pure $ chatCmdError Nothing "TODO" @@ -1784,11 +1784,11 @@ processChatCommand = \case sendTextMessage chatName msg live = withUser $ \user -> do chatRef <- getChatRef user chatName let mc = MCText msg - processChatCommand . APISendMessage chatRef live $ ComposedMessage Nothing Nothing mc - sndContactCITimed :: Bool -> Contact -> m (Maybe CITimed) - sndContactCITimed live = mapM (sndCITimed_ live) . contactTimedTTL - sndGroupCITimed :: Bool -> GroupInfo -> m (Maybe CITimed) - sndGroupCITimed live = mapM (sndCITimed_ live) . groupTimedTTL + processChatCommand . APISendMessage chatRef live Nothing $ ComposedMessage Nothing Nothing mc + sndContactCITimed :: Bool -> Maybe Int -> Contact -> m (Maybe CITimed) + sndContactCITimed live itemTTL ct = mapM (sndCITimed_ live) $ contactTimedTTL ct itemTTL + sndGroupCITimed :: Bool -> Maybe Int -> GroupInfo -> m (Maybe CITimed) + sndGroupCITimed live itemTTL g = mapM (sndCITimed_ live) $ groupTimedTTL g itemTTL sndCITimed_ :: Bool -> Int -> m CITimed sndCITimed_ live ttl = CITimed ttl @@ -4639,7 +4639,7 @@ chatCommandP = "/_get chat " *> (APIGetChat <$> chatRefP <* A.space <*> chatPaginationP <*> optional (" search=" *> stringP)), "/_get items " *> (APIGetChatItems <$> chatPaginationP <*> optional (" search=" *> stringP)), "/_get item info " *> (APIGetChatItemInfo <$> A.decimal), - "/_send " *> (APISendMessage <$> chatRefP <*> liveMessageP <*> (" json " *> jsonP <|> " text " *> (ComposedMessage Nothing Nothing <$> mcTextP))), + "/_send " *> (APISendMessage <$> chatRefP <*> liveMessageP <*> sendMessageTTLP <*> (" json " *> jsonP <|> " text " *> (ComposedMessage Nothing Nothing <$> mcTextP))), "/_update item " *> (APIUpdateChatItem <$> chatRefP <* A.space <*> A.decimal <*> liveMessageP <* A.space <*> msgContentP), "/_delete item " *> (APIDeleteChatItem <$> chatRefP <* A.space <*> A.decimal <* A.space <*> ciDeleteMode), "/_delete member item #" *> (APIDeleteMemberChatItem <$> A.decimal <* A.space <*> A.decimal <* A.space <*> A.decimal), @@ -4833,6 +4833,8 @@ chatCommandP = quotedMsg = safeDecodeUtf8 <$> (A.char '(' *> A.takeTill (== ')') <* A.char ')') <* optional A.space refChar c = c > ' ' && c /= '#' && c /= '@' liveMessageP = " live=" *> onOffP <|> pure False + sendMessageTTLP = " ttl=" *> ((Just <$> A.decimal) <|> ("default" $> Nothing)) <|> pure Nothing + -- sendMessageTTLP = (Just <$ " ttl=" <*> A.decimal) <|> pure Nothing onOffP = ("on" $> True) <|> ("off" $> False) profileNames = (,) <$> displayName <*> fullNameP newUserP = do diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 28facb4d98..1c2a56d956 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -214,7 +214,7 @@ data ChatCommand | APIGetChat ChatRef ChatPagination (Maybe String) | APIGetChatItems ChatPagination (Maybe String) | APIGetChatItemInfo ChatItemId - | APISendMessage {chatRef :: ChatRef, liveMessage :: Bool, composedMessage :: ComposedMessage} + | APISendMessage {chatRef :: ChatRef, liveMessage :: Bool, ttl :: Maybe Int, composedMessage :: ComposedMessage} | APIUpdateChatItem {chatRef :: ChatRef, chatItemId :: ChatItemId, liveMessage :: Bool, msgContent :: MsgContent} | APIDeleteChatItem ChatRef ChatItemId CIDeleteMode | APIDeleteMemberChatItem GroupId GroupMemberId ChatItemId diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index fa29d40544..170489d8e5 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -353,26 +353,30 @@ instance ToJSON CITimed where toEncoding = J.genericToEncoding J.defaultOptions ttl' :: CITimed -> Int ttl' CITimed {ttl} = ttl -contactTimedTTL :: Contact -> Maybe Int -contactTimedTTL Contact {mergedPreferences = ContactUserPreferences {timedMessages = ContactUserPreference {enabled, userPreference}}} - | forUser enabled && forContact enabled = ttl - | otherwise = Nothing - where - TimedMessagesPreference {ttl} = preference (userPreference :: ContactUserPref TimedMessagesPreference) +contactTimedTTL :: Contact -> Maybe Int -> Maybe Int +contactTimedTTL + Contact {mergedPreferences = ContactUserPreferences {timedMessages = ContactUserPreference {enabled, userPreference}}} + itemTTL + | forUser enabled && forContact enabled = itemTTL <|> ttl + | otherwise = Nothing + where + TimedMessagesPreference {ttl} = preference (userPreference :: ContactUserPref TimedMessagesPreference) -groupTimedTTL :: GroupInfo -> Maybe Int -groupTimedTTL GroupInfo {fullGroupPreferences = FullGroupPreferences {timedMessages = TimedMessagesGroupPreference {enable, ttl}}} - | enable == FEOn = Just ttl - | otherwise = Nothing +groupTimedTTL :: GroupInfo -> Maybe Int -> Maybe Int +groupTimedTTL + GroupInfo {fullGroupPreferences = FullGroupPreferences {timedMessages = TimedMessagesGroupPreference {enable, ttl}}} + itemTTL + | enable == FEOn = itemTTL <|> Just ttl + | otherwise = Nothing rcvContactCITimed :: Contact -> Maybe Int -> Maybe CITimed -rcvContactCITimed = rcvCITimed_ . contactTimedTTL +rcvContactCITimed ct itemTTL = rcvCITimed_ $ contactTimedTTL ct itemTTL rcvGroupCITimed :: GroupInfo -> Maybe Int -> Maybe CITimed -rcvGroupCITimed = rcvCITimed_ . groupTimedTTL +rcvGroupCITimed g itemTTL = rcvCITimed_ $ groupTimedTTL g itemTTL -rcvCITimed_ :: Maybe Int -> Maybe Int -> Maybe CITimed -rcvCITimed_ chatTTL itemTTL = (`CITimed` Nothing) <$> (chatTTL >> itemTTL) +rcvCITimed_ :: Maybe Int -> Maybe CITimed +rcvCITimed_ rcvTTL = (`CITimed` Nothing) <$> rcvTTL data CIQuote (c :: ChatType) = CIQuote { chatDir :: CIQDirection c, diff --git a/tests/ChatTests/Direct.hs b/tests/ChatTests/Direct.hs index 66893d0f92..0ed918d9b2 100644 --- a/tests/ChatTests/Direct.hs +++ b/tests/ChatTests/Direct.hs @@ -34,6 +34,7 @@ chatDirectTests = do it "direct message edit history" testDirectMessageEditHistory it "direct message delete" testDirectMessageDelete it "direct live message" testDirectLiveMessage + fit "direct timed message" testDirectTimedMessage it "repeat AUTH errors disable contact" testRepeatAuthErrorsDisableContact it "should send multiline message" testMultilineMessage describe "SMP servers" $ do @@ -440,6 +441,32 @@ testDirectLiveMessage = bob .<## ": hello 2" bob .<## ":" +testDirectTimedMessage :: HasCallStack => FilePath -> IO () +testDirectTimedMessage = + testChat2 aliceProfile bobProfile $ + \alice bob -> do + connectUsers alice bob + + alice ##> "/_send @2 ttl=1 text hello!" + alice <# "@bob hello!" + bob <# "alice> hello!" + alice <## "timed message deleted: hello!" + bob <## "timed message deleted: hello!" + + alice ##> "/_send @2 live=off ttl=1 text hey" + alice <# "@bob hey" + bob <# "alice> hey" + alice <## "timed message deleted: hey" + bob <## "timed message deleted: hey" + + alice ##> "/_send @2 ttl=default text hello" + alice <# "@bob hello" + bob <# "alice> hello" + + alice ##> "/_send @2 live=off text hi" + alice <# "@bob hi" + bob <# "alice> hi" + testRepeatAuthErrorsDisableContact :: HasCallStack => FilePath -> IO () testRepeatAuthErrorsDisableContact = testChat2 aliceProfile bobProfile $ \alice bob -> do