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

SimpleX Directory Service (#2766)

Browse Source 
* SimpleX Directory Service

* more events

* update events

* fix

* Apply suggestions from code review

metavar

Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>

* metavar 2

Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>

* process events

* remove command serialization

* update

* update

* process group profile update

* basic group registration flow

* search works

* better messages

* improve messages

* test broadcast bot

* test for directory service

* better processing of group profile change, test

* refactor

* de-list group when owner or service is removed from the group, tests

* fix: removing any member or any member leaving should not delist the group

* refactor

* more tests, fixes

* disable bot tests in CI

* remove comment

---------

Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
This commit is contained in:
Evgeny Poberezkin
2023-08-01 20:54:51 +01:00
committed by GitHub
parent f0d64a30e9
commit 2b69103055
23 changed files with 1473 additions and 142 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Simplex/Chat.hs
+21 -6
View File
@@ -332,7 +332,13 @@ execChatCommand s = do
u <- readTVarIO =<< asks currentUser
case parseChatCommand s of
Left e -> pure $ chatCmdError u e
Right cmd -> either (CRChatCmdError u) id <$> runExceptT (processChatCommand cmd)
Right cmd -> execChatCommand_ u cmd
execChatCommand' :: ChatMonad' m => ChatCommand -> m ChatResponse
execChatCommand' cmd = asks currentUser >>= readTVarIO >>= (`execChatCommand_` cmd)
execChatCommand_ :: ChatMonad' m => Maybe User -> ChatCommand -> m ChatResponse
execChatCommand_ u cmd = either (CRChatCmdError u) id <$> runExceptT (processChatCommand cmd)
parseChatCommand :: ByteString -> Either String ChatCommand
parseChatCommand = A.parseOnly chatCommandP . B.dropWhileEnd isSpace
@@ -1486,8 +1492,11 @@ processChatCommand = \case
ListMembers gName -> withUser $ \user -> do
groupId <- withStore $ \db -> getGroupIdByName db user gName
processChatCommand $ APIListMembers groupId
ListGroups -> withUser $ \user ->
CRGroupsList user <$> withStore' (`getUserGroupDetails` user)
APIListGroups userId contactId_ search_ -> withUserId userId $ \user ->
CRGroupsList user <$> withStore' (\db -> getUserGroupDetails db user contactId_ search_)
ListGroups cName_ search_ -> withUser $ \user@User {userId} -> do
ct_ <- forM cName_ $ \cName -> withStore $ \db -> getContactByName db user cName
processChatCommand $ APIListGroups userId (contactId' <$> ct_) search_
APIUpdateGroupProfile groupId p' -> withUser $ \user -> do
g <- withStore $ \db -> getGroup db user groupId
runUpdateGroupProfile user g p'
@@ -1497,6 +1506,8 @@ processChatCommand = \case
CRGroupProfile user <$> withStore (\db -> getGroupInfoByName db user gName)
UpdateGroupDescription gName description ->
updateGroupProfileByName gName $ \p -> p {description}
ShowGroupDescription gName -> withUser $ \user ->
CRGroupDescription user <$> withStore (\db -> getGroupInfoByName db user gName)
APICreateGroupLink groupId mRole -> withUser $ \user -> withChatLock "createGroupLink" $ do
gInfo <- withStore $ \db -> getGroupInfo db user groupId
assertUserGroupRole gInfo GRAdmin
@@ -2534,7 +2545,7 @@ expireChatItems user@User {userId} ttl sync = do
createdAtCutoff = addUTCTime (-43200 :: NominalDiffTime) currentTs
contacts <- withStoreCtx' (Just "expireChatItems, getUserContacts") (`getUserContacts` user)
loop contacts $ processContact expirationDate
groups <- withStoreCtx' (Just "expireChatItems, getUserGroupDetails") (`getUserGroupDetails` user)
groups <- withStoreCtx' (Just "expireChatItems, getUserGroupDetails") (\db -> getUserGroupDetails db user Nothing Nothing)
loop groups $ processGroup expirationDate createdAtCutoff
where
loop :: [a] -> (a -> m ()) -> m ()
@@ -3954,7 +3965,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
ci <- saveRcvChatItem user (CDDirectRcv ct) msg msgMeta content
withStore' $ \db -> setGroupInvitationChatItemId db user groupId (chatItemId' ci)
toView $ CRNewChatItem user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci)
toView $ CRReceivedGroupInvitation user gInfo ct memRole
toView $ CRReceivedGroupInvitation {user, groupInfo = gInfo, contact = ct, fromMemberRole = fromRole, memberRole = memRole}
whenContactNtfs user ct $
showToast ("#" <> localDisplayName <> " " <> c <> "> ") "invited you to join the group"
where
@@ -5128,11 +5139,15 @@ chatCommandP =
"/clear #" *> (ClearGroup <$> displayName),
"/clear " *> char_ '@' *> (ClearContact <$> displayName),
("/members " <|> "/ms ") *> char_ '#' *> (ListMembers <$> displayName),
("/groups" <|> "/gs") $> ListGroups,
"/_groups" *> (APIListGroups <$> A.decimal <*> optional (" @" *> A.decimal) <*> optional (A.space *> stringP)),
("/groups" <|> "/gs") *> (ListGroups <$> optional (" @" *> displayName) <*> optional (A.space *> stringP)),
"/_group_profile #" *> (APIUpdateGroupProfile <$> A.decimal <* A.space <*> jsonP),
("/group_profile " <|> "/gp ") *> char_ '#' *> (UpdateGroupNames <$> displayName <* A.space <*> groupProfile),
("/group_profile " <|> "/gp ") *> char_ '#' *> (ShowGroupProfile <$> displayName),
"/group_descr " *> char_ '#' *> (UpdateGroupDescription <$> displayName <*> optional (A.space *> msgTextP)),
"/set welcome " *> char_ '#' *> (UpdateGroupDescription <$> displayName <* A.space <*> (Just <$> msgTextP)),
"/delete welcome " *> char_ '#' *> (UpdateGroupDescription <$> displayName <*> pure Nothing),
"/show welcome " *> char_ '#' *> (ShowGroupDescription <$> displayName),
"/_create link #" *> (APICreateGroupLink <$> A.decimal <*> (memberRole <|> pure GRMember)),
"/_set link role #" *> (APIGroupLinkMemberRole <$> A.decimal <*> memberRole),
"/_delete link #" *> (APIDeleteGroupLink <$> A.decimal),