SimpleX Directory Service (#2766)

* 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>
2026-04-26 15:18:01 +00:00 · 2023-08-01 20:54:51 +01:00
parent f0d64a30e9
commit 2b69103055
23 changed files with 1473 additions and 142 deletions
--- a/src/Simplex/Chat.hs
+++ b/src/Simplex/Chat.hs
@@ -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),
--- a/src/Simplex/Chat/Bot.hs
+++ b/src/Simplex/Chat/Bot.hs
@@ -9,9 +9,7 @@ module Simplex.Chat.Bot where
 import Control.Concurrent.Async
 import Control.Concurrent.STM
 import Control.Monad.Reader
-import qualified Data.Aeson as J
 import qualified Data.ByteString.Char8 as B
-import qualified Data.ByteString.Lazy.Char8 as LB
 import qualified Data.Text as T
 import Simplex.Chat.Controller
 import Simplex.Chat.Core
@@ -19,9 +17,8 @@ import Simplex.Chat.Messages
 import Simplex.Chat.Messages.CIContent
 import Simplex.Chat.Protocol (MsgContent (..))
 import Simplex.Chat.Store
-import Simplex.Chat.Types (Contact (..), IsContact (..), User (..))
+import Simplex.Chat.Types (Contact (..), ContactId, IsContact (..), User (..))
 import Simplex.Messaging.Encoding.String (strEncode)
-import Simplex.Messaging.Util (safeDecodeUtf8)
 import System.Exit (exitFailure)

 chatBotRepl :: String -> (Contact -> String -> IO String) -> User -> ChatController -> IO ()
@@ -32,49 +29,55 @@ chatBotRepl welcome answer _user cc = do
    case resp of
      CRContactConnected _ contact _ -> do
        contactConnected contact
-        void $ sendMsg contact welcome
+        void $ sendMessage cc contact welcome
      CRNewChatItem _ (AChatItem _ SMDRcv (DirectChat contact) ChatItem {content = mc@CIRcvMsgContent {}}) -> do
        let msg = T.unpack $ ciContentToText mc
-        void $ sendMsg contact =<< answer contact msg
+        void $ sendMessage cc contact =<< answer contact msg
      _ -> pure ()
  where
-    sendMsg Contact {contactId} msg = sendChatCmd cc $ "/_send @" <> show contactId <> " text " <> msg
    contactConnected Contact {localDisplayName} = putStrLn $ T.unpack localDisplayName <> " connected"

 initializeBotAddress :: ChatController -> IO ()
 initializeBotAddress cc = do
-  sendChatCmd cc "/show_address" >>= \case
+  sendChatCmd cc ShowMyAddress >>= \case
    CRUserContactLink _ UserContactLink {connReqContact} -> showBotAddress connReqContact
    CRChatCmdError _ (ChatErrorStore SEUserContactLinkNotFound) -> do
      putStrLn "No bot address, creating..."
-      sendChatCmd cc "/address" >>= \case
+      sendChatCmd cc CreateMyAddress >>= \case
        CRUserContactLinkCreated _ uri -> showBotAddress uri
        _ -> putStrLn "can't create bot address" >> exitFailure
    _ -> putStrLn "unexpected response" >> exitFailure
  where
    showBotAddress uri = do
      putStrLn $ "Bot's contact address is: " <> B.unpack (strEncode uri)
-      void $ sendChatCmd cc "/auto_accept on"
+      void $ sendChatCmd cc $ AddressAutoAccept $ Just AutoAccept {acceptIncognito = False, autoReply = Nothing}

 sendMessage :: ChatController -> Contact -> String -> IO ()
 sendMessage cc ct = sendComposedMessage cc ct Nothing . textMsgContent

+sendMessage' :: ChatController -> ContactId -> String -> IO ()
+sendMessage' cc ctId = sendComposedMessage' cc ctId Nothing . textMsgContent
+
 sendComposedMessage :: ChatController -> Contact -> Maybe ChatItemId -> MsgContent -> IO ()
-sendComposedMessage cc ct quotedItemId msgContent = do
+sendComposedMessage cc = sendComposedMessage' cc . contactId'
+
+sendComposedMessage' :: ChatController -> ContactId -> Maybe ChatItemId -> MsgContent -> IO ()
+sendComposedMessage' cc ctId quotedItemId msgContent = do
  let cm = ComposedMessage {filePath = Nothing, quotedItemId, msgContent}
-  sendChatCmd cc ("/_send @" <> show (contactId' ct) <> " json " <> jsonEncode cm) >>= \case
-    CRNewChatItem {} -> printLog cc CLLInfo $ "sent message to " <> contactInfo ct
+  sendChatCmd cc (APISendMessage (ChatRef CTDirect ctId) False Nothing cm) >>= \case
+    CRNewChatItem {} -> printLog cc CLLInfo $ "sent message to contact ID " <> show ctId
    r -> putStrLn $ "unexpected send message response: " <> show r
-  where
-    jsonEncode = T.unpack . safeDecodeUtf8 . LB.toStrict . J.encode

 deleteMessage :: ChatController -> Contact -> ChatItemId -> IO ()
 deleteMessage cc ct chatItemId = do
-  let cmd = "/_delete item @" <> show (contactId' ct) <> " " <> show chatItemId <> " internal"
+  let cmd = APIDeleteChatItem (contactRef ct) chatItemId CIDMInternal
  sendChatCmd cc cmd >>= \case
    CRChatItemDeleted {} -> printLog cc CLLInfo $ "deleted message from " <> contactInfo ct
    r -> putStrLn $ "unexpected delete message response: " <> show r

+contactRef :: Contact -> ChatRef
+contactRef = ChatRef CTDirect . contactId'
+
 textMsgContent :: String -> MsgContent
 textMsgContent = MCText . T.pack

--- a/src/Simplex/Chat/Bot/KnownContacts.hs
+++ b/src/Simplex/Chat/Bot/KnownContacts.hs
@@ -0,0 +1,33 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Simplex.Chat.Bot.KnownContacts where
+
+import qualified Data.Attoparsec.ByteString.Char8 as A
+import Data.Int (Int64)
+import Data.Text (Text)
+import Data.Text.Encoding (encodeUtf8)
+import qualified Data.Text as T
+import Options.Applicative
+import Simplex.Messaging.Parsers (parseAll)
+import Simplex.Messaging.Util (safeDecodeUtf8)
+
+data KnownContact = KnownContact
+  { contactId :: Int64,
+    localDisplayName :: Text
+  }
+  deriving (Eq)
+
+knownContactNames :: [KnownContact] -> String
+knownContactNames = T.unpack . T.intercalate ", " . map (("@" <>) . localDisplayName)
+
+parseKnownContacts :: ReadM [KnownContact]
+parseKnownContacts = eitherReader $ parseAll knownContactsP . encodeUtf8 . T.pack
+
+knownContactsP :: A.Parser [KnownContact]
+knownContactsP = contactP `A.sepBy1` A.char ','
+  where
+    contactP = do
+      contactId <- A.decimal <* A.char ':'
+      localDisplayName <- safeDecodeUtf8 <$> A.takeTill (A.inClass ", ")
+      pure KnownContact {contactId, localDisplayName}
--- a/src/Simplex/Chat/Controller.hs
+++ b/src/Simplex/Chat/Controller.hs
@@ -362,10 +362,12 @@ data ChatCommand
  | DeleteGroup GroupName
  | ClearGroup GroupName
  | ListMembers GroupName
-  | ListGroups -- UserId (not used in UI)
+  | APIListGroups UserId (Maybe ContactId) (Maybe String)
+  | ListGroups (Maybe ContactName) (Maybe String)
  | UpdateGroupNames GroupName GroupProfile
  | ShowGroupProfile GroupName
  | UpdateGroupDescription GroupName (Maybe Text)
+  | ShowGroupDescription GroupName
  | CreateGroupLink GroupName GroupMemberRole
  | GroupLinkMemberRole GroupName GroupMemberRole
  | DeleteGroupLink GroupName
@@ -518,7 +520,7 @@ data ChatResponse
  | CRHostConnected {protocol :: AProtocolType, transportHost :: TransportHost}
  | CRHostDisconnected {protocol :: AProtocolType, transportHost :: TransportHost}
  | CRGroupInvitation {user :: User, groupInfo :: GroupInfo}
-  | CRReceivedGroupInvitation {user :: User, groupInfo :: GroupInfo, contact :: Contact, memberRole :: GroupMemberRole}
+  | CRReceivedGroupInvitation {user :: User, groupInfo :: GroupInfo, contact :: Contact, fromMemberRole :: GroupMemberRole, memberRole :: GroupMemberRole}
  | CRUserJoinedGroup {user :: User, groupInfo :: GroupInfo, hostMember :: GroupMember}
  | CRJoinedGroupMember {user :: User, groupInfo :: GroupInfo, member :: GroupMember}
  | CRJoinedGroupMemberConnecting {user :: User, groupInfo :: GroupInfo, hostMember :: GroupMember, member :: GroupMember}
@@ -533,6 +535,7 @@ data ChatResponse
  | CRGroupDeleted {user :: User, groupInfo :: GroupInfo, member :: GroupMember}
  | CRGroupUpdated {user :: User, fromGroup :: GroupInfo, toGroup :: GroupInfo, member_ :: Maybe GroupMember}
  | CRGroupProfile {user :: User, groupInfo :: GroupInfo}
+  | CRGroupDescription {user :: User, groupInfo :: GroupInfo} -- only used in CLI
  | CRGroupLinkCreated {user :: User, groupInfo :: GroupInfo, connReqContact :: ConnReqContact, memberRole :: GroupMemberRole}
  | CRGroupLink {user :: User, groupInfo :: GroupInfo, connReqContact :: ConnReqContact, memberRole :: GroupMemberRole}
  | CRGroupLinkDeleted {user :: User, groupInfo :: GroupInfo}
--- a/src/Simplex/Chat/Core.hs
+++ b/src/Simplex/Chat/Core.hs
@@ -39,5 +39,8 @@ runSimplexChat ChatOpts {maintenance} u cc chat
    a2 <- async $ chat u cc
    waitEither_ a1 a2

-sendChatCmd :: ChatController -> String -> IO ChatResponse
-sendChatCmd cc s = runReaderT (execChatCommand . encodeUtf8 $ T.pack s) cc
+sendChatCmdStr :: ChatController -> String -> IO ChatResponse
+sendChatCmdStr cc s = runReaderT (execChatCommand . encodeUtf8 $ T.pack s) cc
+
+sendChatCmd :: ChatController -> ChatCommand -> IO ChatResponse
+sendChatCmd cc cmd = runReaderT (execChatCommand' cmd) cc
--- a/src/Simplex/Chat/Store/Groups.hs
+++ b/src/Simplex/Chat/Store/Groups.hs
@@ -448,8 +448,8 @@ getUserGroups db user@User {userId} = do
  groupIds <- map fromOnly <$> DB.query db "SELECT group_id FROM groups WHERE user_id = ?" (Only userId)
  rights <$> mapM (runExceptT . getGroup db user) groupIds

-getUserGroupDetails :: DB.Connection -> User -> IO [GroupInfo]
-getUserGroupDetails db User {userId, userContactId} =
+getUserGroupDetails :: DB.Connection -> User -> Maybe ContactId -> Maybe String -> IO [GroupInfo]
+getUserGroupDetails db User {userId, userContactId} _contactId_ search_ =
  map (toGroupInfo userContactId)
    <$> DB.query
      db
@@ -462,8 +462,11 @@ getUserGroupDetails db User {userId, userContactId} =
        JOIN group_members mu USING (group_id)
        JOIN contact_profiles pu ON pu.contact_profile_id = COALESCE(mu.member_profile_id, mu.contact_profile_id)
        WHERE g.user_id = ? AND mu.contact_id = ?
+          AND (gp.display_name LIKE '%' || ? || '%' OR gp.full_name LIKE '%' || ? || '%' OR gp.description LIKE '%' || ? || '%')
      |]
-      (userId, userContactId)
+      (userId, userContactId, search, search, search)
+  where
+    search = fromMaybe "" search_

 getContactGroupPreferences :: DB.Connection -> User -> Contact -> IO [FullGroupPreferences]
 getContactGroupPreferences db User {userId} Contact {contactId} = do
--- a/src/Simplex/Chat/View.hs
+++ b/src/Simplex/Chat/View.hs
@@ -200,7 +200,7 @@ responseToView user_ ChatConfig {logLevel, showReactions, showReceipts, testView
      addressSS UserContactSubStatus {userContactError} = maybe ("Your address is active! To show: " <> highlight' "/sa") (\e -> "User address error: " <> sShow e <> ", to delete your address: " <> highlight' "/da") userContactError
      (groupLinkErrors, groupLinksSubscribed) = partition (isJust . userContactError) groupLinks
  CRGroupInvitation u g -> ttyUser u [groupInvitation' g]
-  CRReceivedGroupInvitation u g c role -> ttyUser u $ viewReceivedGroupInvitation g c role
+  CRReceivedGroupInvitation {user = u, groupInfo = g, contact = c, memberRole = r} -> ttyUser u $ viewReceivedGroupInvitation g c r
  CRUserJoinedGroup u g _ -> ttyUser u $ viewUserJoinedGroup g
  CRJoinedGroupMember u g m -> ttyUser u $ viewJoinedGroupMember g m
  CRHostConnected p h -> [plain $ "connected to " <> viewHostEvent p h]
@@ -217,6 +217,7 @@ responseToView user_ ChatConfig {logLevel, showReactions, showReceipts, testView
  CRGroupDeleted u g m -> ttyUser u [ttyGroup' g <> ": " <> ttyMember m <> " deleted the group", "use " <> highlight ("/d #" <> groupName' g) <> " to delete the local copy of the group"]
  CRGroupUpdated u g g' m -> ttyUser u $ viewGroupUpdated g g' m
  CRGroupProfile u g -> ttyUser u $ viewGroupProfile g
+  CRGroupDescription u g -> ttyUser u $ viewGroupDescription g
  CRGroupLinkCreated u g cReq mRole -> ttyUser u $ groupLink_ "Group link is created!" g cReq mRole
  CRGroupLink u g cReq mRole -> ttyUser u $ groupLink_ "Group link:" g cReq mRole
  CRGroupLinkDeleted u g -> ttyUser u $ viewGroupLinkDeleted g
@@ -1135,6 +1136,10 @@ viewGroupProfile g@GroupInfo {groupProfile = GroupProfile {description, image, g
      where
        pref = getGroupPreference f . mergeGroupPreferences

+viewGroupDescription :: GroupInfo -> [StyledString]
+viewGroupDescription GroupInfo {groupProfile = GroupProfile {description}} =
+  maybe ["No welcome message!"] ((bold' "Welcome message:" :) . map plain . T.lines) description
+
 bold' :: String -> StyledString
 bold' = styled Bold