diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 803dedd6d9..e59086973d 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -992,20 +992,8 @@ processChatCommand = \case processChatCommand $ APIListMembers groupId ListGroups -> CRGroupsList <$> withUser (\user -> withStore' (`getUserGroupDetails` user)) APIUpdateGroupProfile groupId p' -> withUser $ \user -> do - Group g@GroupInfo {groupProfile = p} ms <- withStore $ \db -> getGroup db user groupId - let s = memberStatus $ membership g - canUpdate = - memberRole (membership g :: GroupMember) == GROwner - || (s == GSMemRemoved || s == GSMemLeft || s == GSMemGroupDeleted || s == GSMemInvited) - unless canUpdate $ throwChatError CEGroupUserRole - g' <- withStore $ \db -> updateGroupProfile db user g p' - msg <- sendGroupMessage g' ms (XGrpInfo p') - let cd = CDGroupSnd g' - unless (sameGroupProfileInfo p p') $ do - ci <- saveSndChatItem user cd msg (CISndGroupEvent $ SGEGroupUpdated p') Nothing Nothing - toView . CRNewChatItem $ AChatItem SCTGroup SMDSnd (GroupChat g') ci - createGroupFeatureChangedItems user cd CISndGroupFeature p p' - pure $ CRGroupUpdated g g' Nothing + g <- withStore $ \db -> getGroup db user groupId + runUpdateGroupProfile user g p' UpdateGroupProfile gName profile -> withUser $ \user -> do groupId <- withStore $ \db -> getGroupIdByName db user gName processChatCommand $ APIUpdateGroupProfile groupId profile @@ -1096,6 +1084,17 @@ processChatCommand = \case UpdateProfileImage image -> withUser $ \user@User {profile} -> do let p = (fromLocalProfile profile :: Profile) {image} updateProfile user p + SetUserFeature f allowed -> withUser $ \user@User {profile} -> do + let p = (fromLocalProfile profile :: Profile) {preferences = Just . setPreference f (Just allowed) $ preferences' user} + updateProfile user p + SetContactFeature f cName allowed_ -> withUser $ \user -> do + ct@Contact {userPreferences} <- withStore $ \db -> getContactByName db user cName + let prefs' = setPreference f allowed_ $ Just userPreferences + updateContactPrefs user ct prefs' + SetGroupFeature f gName enabled -> withUser $ \user -> do + g@(Group GroupInfo {groupProfile = p} _) <- withStore $ \db -> getGroup db user =<< getGroupIdByName db user gName + let p' = p {groupPreferences = Just . setGroupPreference f enabled $ groupPreferences p} + runUpdateGroupProfile user g p' QuitChat -> liftIO exitSuccess ShowVersion -> pure $ CRVersionInfo versionNumber DebugLocks -> do @@ -1202,6 +1201,21 @@ processChatCommand = \case void (sendDirectContactMessage ct' $ XInfo p') `catchError` (toView . CRChatError) when (directContact ct) $ createFeatureChangedItems user ct ct' CDDirectSnd CISndChatFeature pure $ CRContactPrefsUpdated ct ct' + runUpdateGroupProfile :: User -> Group -> GroupProfile -> m ChatResponse + runUpdateGroupProfile user (Group g@GroupInfo {groupProfile = p} ms) p' = do + let s = memberStatus $ membership g + canUpdate = + memberRole (membership g :: GroupMember) == GROwner + || (s == GSMemRemoved || s == GSMemLeft || s == GSMemGroupDeleted || s == GSMemInvited) + unless canUpdate $ throwChatError CEGroupUserRole + g' <- withStore $ \db -> updateGroupProfile db user g p' + msg <- sendGroupMessage g' ms (XGrpInfo p') + let cd = CDGroupSnd g' + unless (sameGroupProfileInfo p p') $ do + ci <- saveSndChatItem user cd msg (CISndGroupEvent $ SGEGroupUpdated p') Nothing Nothing + toView . CRNewChatItem $ AChatItem SCTGroup SMDSnd (GroupChat g') ci + createGroupFeatureChangedItems user cd CISndGroupFeature p p' + pure $ CRGroupUpdated g g' Nothing isReady :: Contact -> Bool isReady ct = let s = connStatus $ activeConn (ct :: Contact) @@ -2412,7 +2426,7 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage = receiveInlineChunk :: RcvFileTransfer -> FileChunk -> MsgMeta -> m () receiveInlineChunk RcvFileTransfer {fileId, fileStatus = RFSNew} FileChunk {chunkNo} _ - | chunkNo == 1 = throwChatError $ CEFileLargeSentInline fileId + | chunkNo == 1 = throwChatError $ CEInlineFileProhibited fileId | otherwise = pure () receiveInlineChunk ft chunk meta = do case chunk of @@ -3384,6 +3398,9 @@ chatCommandP = "/profile_image" $> UpdateProfileImage Nothing, ("/profile " <|> "/p ") *> (uncurry UpdateProfile <$> userNames), ("/profile" <|> "/p") $> ShowProfile, + "/voice #" *> (SetGroupFeature CFVoice <$> displayName <*> (A.space *> strP)), + "/voice @" *> (SetContactFeature CFVoice <$> displayName <*> optional (A.space *> strP)), + "/voice " *> (SetUserFeature CFVoice <$> strP), "/incognito " *> (SetIncognito <$> onOffP), ("/quit" <|> "/q" <|> "/exit") $> QuitChat, ("/version" <|> "/v") $> ShowVersion, diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 7855c562c1..7750d76a3e 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -250,6 +250,9 @@ data ChatCommand | ShowProfile | UpdateProfile ContactName Text | UpdateProfileImage (Maybe ImageData) + | SetUserFeature ChatFeature FeatureAllowed + | SetContactFeature ChatFeature ContactName (Maybe FeatureAllowed) + | SetGroupFeature ChatFeature GroupName GroupFeatureEnabled | QuitChat | ShowVersion | DebugLocks @@ -536,7 +539,7 @@ data ChatErrorType | CEFileImageType {filePath :: FilePath} | CEFileImageSize {filePath :: FilePath} | CEFileNotReceived {fileId :: FileTransferId} - | CEFileLargeSentInline {fileId :: FileTransferId} + | CEInlineFileProhibited {fileId :: FileTransferId} | CEInvalidQuote | CEInvalidChatItemUpdate | CEInvalidChatItemDelete diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index 564f112aec..f36483791f 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -303,6 +303,14 @@ instance PreferenceI FullPreferences where CFVoice -> voice {-# INLINE getPreference #-} +setPreference :: ChatFeature -> Maybe FeatureAllowed -> Maybe Preferences -> Preferences +setPreference f allow_ prefs_ = + let prefs = toChatPrefs $ mergePreferences Nothing prefs_ + pref = (\allow -> (getPreference f prefs :: Preference) {allow}) <$> allow_ + in case f of + CFVoice -> prefs {voice = pref} + CFFullDelete -> prefs {fullDelete = pref} + -- collection of optional chat preferences for the user and the contact data Preferences = Preferences { fullDelete :: Maybe Preference, @@ -361,6 +369,14 @@ instance ToField GroupPreferences where instance FromField GroupPreferences where fromField = fromTextField_ decodeJSON +setGroupPreference :: ChatFeature -> GroupFeatureEnabled -> Maybe GroupPreferences -> GroupPreferences +setGroupPreference f enable prefs_ = + let prefs = mergeGroupPreferences prefs_ + pref = (getGroupPreference f prefs :: GroupPreference) {enable} + in toGroupPreferences $ case f of + CFVoice -> prefs {voice = pref} + CFFullDelete -> prefs {fullDelete = pref} + -- full collection of chat preferences defined in the app - it is used to ensure we include all preferences and to simplify processing -- if some of the preferences are not defined in Preferences, defaults from defaultChatPrefs are used here. data FullPreferences = FullPreferences @@ -534,6 +550,16 @@ mergeGroupPreferences groupPreferences = where pref pt = fromMaybe (getGroupPreference pt defaultGroupPrefs) (groupPreferences >>= groupPrefSel pt) +toGroupPreferences :: FullGroupPreferences -> GroupPreferences +toGroupPreferences groupPreferences = + GroupPreferences + { fullDelete = pref CFFullDelete, + -- receipts = pref CFReceipts, + voice = pref CFVoice + } + where + pref f = Just $ getGroupPreference f groupPreferences + data PrefEnabled = PrefEnabled {forUser :: Bool, forContact :: Bool} deriving (Eq, Show, Generic, FromJSON) diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index b5793e0262..be38b768c5 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -1083,7 +1083,7 @@ viewChatError = \case CEFileImageType _ -> ["image type must be jpg, send as a file using " <> highlight' "/f"] CEFileImageSize _ -> ["max image size: " <> sShow maxImageSize <> " bytes, resize it or send as a file using " <> highlight' "/f"] CEFileNotReceived fileId -> ["file " <> sShow fileId <> " not received"] - CEFileLargeSentInline _ -> ["A small file sent without acceptance - you can enable receiving such files automatically with -f option."] + CEInlineFileProhibited _ -> ["A small file sent without acceptance - you can enable receiving such files with -f option."] CEInvalidQuote -> ["cannot reply to this message"] CEInvalidChatItemUpdate -> ["cannot update this item"] CEInvalidChatItemDelete -> ["cannot delete this item"] diff --git a/tests/ChatTests.hs b/tests/ChatTests.hs index ead53c08d2..cd1ba99400 100644 --- a/tests/ChatTests.hs +++ b/tests/ChatTests.hs @@ -80,6 +80,7 @@ chatTests = do describe "send and receive file" $ fileTestMatrix2 runTestFileTransfer it "send and receive file inline (without accepting)" testInlineFileTransfer it "send and receive small file inline (default config)" testSmallInlineFileTransfer + it "small file sent without acceptance is ignored in terminal by default" testSmallInlineFileIgnored it "receive file inline with inline=on option" testReceiveInline describe "send and receive a small file" $ fileTestMatrix2 runTestSmallFileTransfer describe "sender cancelled file transfer before transfer" $ fileTestMatrix2 runTestFileSndCancelBeforeTransfer @@ -88,6 +89,7 @@ chatTests = do describe "send and receive file to group" $ fileTestMatrix3 runTestGroupFileTransfer it "send and receive file inline to group (without accepting)" testInlineGroupFileTransfer it "send and receive small file inline to group (default config)" testSmallInlineGroupFileTransfer + it "small file sent without acceptance is ignored in terminal by default" testSmallInlineGroupFileIgnored describe "sender cancelled group file transfer before transfer" $ fileTestMatrix3 runTestGroupFileSndCancelBeforeTransfer describe "messages with files" $ do describe "send and receive message with file" $ fileTestMatrix2 runTestMessageWithFile @@ -1616,7 +1618,7 @@ testInlineFileTransfer = testSmallInlineFileTransfer :: IO () testSmallInlineFileTransfer = - testChatCfg2 testCfg aliceProfile bobProfile $ \alice bob -> do + testChat2 aliceProfile bobProfile $ \alice bob -> do connectUsers alice bob bob ##> "/_files_folder ./tests/tmp/" bob <## "ok" @@ -1637,6 +1639,28 @@ testSmallInlineFileTransfer = dest <- B.readFile "./tests/tmp/logo.jpg" dest `shouldBe` src +testSmallInlineFileIgnored :: IO () +testSmallInlineFileIgnored = withTmpFiles $ do + withNewTestChat "alice" aliceProfile $ \alice -> + withNewTestChatOpts testOpts {allowInstantFiles = False} "bob" bobProfile $ \bob -> do + connectUsers alice bob + bob ##> "/_files_folder ./tests/tmp/" + bob <## "ok" + alice ##> "/_send @2 json {\"msgContent\":{\"type\":\"voice\", \"duration\":10, \"text\":\"\"}, \"filePath\":\"./tests/fixtures/logo.jpg\"}" + alice <# "@bob voice message (00:10)" + alice <# "/f @bob ./tests/fixtures/logo.jpg" + -- below is not shown in "sent" mode + -- alice <## "use /fc 1 to cancel sending" + bob <# "alice> voice message (00:10)" + bob <# "alice> sends file logo.jpg (31.3 KiB / 32080 bytes)" + bob <## "use /fr 1 [