From c25d0ea224077cf00e453383a546b01d9ea6e759 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Thu, 9 Jan 2025 15:58:47 +0000 Subject: [PATCH] directory: option to run service as CLI (#5494) * directory: option to run service as CLI * support muting groups when joining * fix test --- apps/simplex-directory-service/Main.hs | 6 +- .../src/Directory/Options.hs | 7 ++ .../src/Directory/Service.hs | 73 ++++++++++++------- src/Simplex/Chat/Controller.hs | 4 +- src/Simplex/Chat/Library/Commands.hs | 16 ++-- tests/Bots/DirectoryTests.hs | 1 + 6 files changed, 70 insertions(+), 37 deletions(-) diff --git a/apps/simplex-directory-service/Main.hs b/apps/simplex-directory-service/Main.hs index af9c9dd252..0c6464dbfe 100644 --- a/apps/simplex-directory-service/Main.hs +++ b/apps/simplex-directory-service/Main.hs @@ -10,6 +10,8 @@ import Simplex.Chat.Terminal (terminalChatConfig) main :: IO () main = do - opts@DirectoryOpts {directoryLog} <- welcomeGetOpts + opts@DirectoryOpts {directoryLog, runCLI} <- welcomeGetOpts st <- restoreDirectoryStore directoryLog - simplexChatCore terminalChatConfig (mkChatOpts opts) $ directoryService st opts + if runCLI + then directoryServiceCLI st opts + else simplexChatCore terminalChatConfig (mkChatOpts opts) $ directoryService st opts diff --git a/apps/simplex-directory-service/src/Directory/Options.hs b/apps/simplex-directory-service/src/Directory/Options.hs index 7f02a580e6..70135e4ccf 100644 --- a/apps/simplex-directory-service/src/Directory/Options.hs +++ b/apps/simplex-directory-service/src/Directory/Options.hs @@ -23,6 +23,7 @@ data DirectoryOpts = DirectoryOpts superUsers :: [KnownContact], directoryLog :: Maybe FilePath, serviceName :: T.Text, + runCLI :: Bool, searchResults :: Int, testing :: Bool } @@ -58,6 +59,11 @@ directoryOpts appDir defaultDbFileName = do <> help "The display name of the directory service bot, without *'s and spaces (SimpleX-Directory)" <> value "SimpleX-Directory" ) + runCLI <- + switch + ( long "run-cli" + <> help "Run directory service as CLI" + ) pure DirectoryOpts { coreOptions, @@ -65,6 +71,7 @@ directoryOpts appDir defaultDbFileName = do superUsers, directoryLog, serviceName = T.pack serviceName, + runCLI, searchResults = 10, testing = False } diff --git a/apps/simplex-directory-service/src/Directory/Service.hs b/apps/simplex-directory-service/src/Directory/Service.hs index d2016ff1f5..5b96603f68 100644 --- a/apps/simplex-directory-service/src/Directory/Service.hs +++ b/apps/simplex-directory-service/src/Directory/Service.hs @@ -9,6 +9,7 @@ module Directory.Service ( welcomeGetOpts, directoryService, + directoryServiceCLI, ) where @@ -36,6 +37,8 @@ import Simplex.Chat.Messages import Simplex.Chat.Options import Simplex.Chat.Protocol (MsgContent (..)) import Simplex.Chat.Store.Shared (StoreError (..)) +import Simplex.Chat.Terminal (terminalChatConfig) +import Simplex.Chat.Terminal.Main (simplexChatCLI') import Simplex.Chat.Types import Simplex.Chat.Types.Shared import Simplex.Chat.View (serializeChatResponse, simplexChatContact, viewContactName, viewGroupName) @@ -77,33 +80,51 @@ welcomeGetOpts = do putStrLn $ "db: " <> dbFilePrefix <> "_chat.db, " <> dbFilePrefix <> "_agent.db" pure opts +directoryServiceCLI :: DirectoryStore -> DirectoryOpts -> IO () +directoryServiceCLI st opts = do + env <- newServiceState + eventQ <- newTQueueIO + let eventHook cc resp = atomically $ resp <$ writeTQueue eventQ (cc, resp) + race_ + (simplexChatCLI' terminalChatConfig {chatHooks = defaultChatHooks {eventHook}} (mkChatOpts opts) Nothing) + (processEvents eventQ env) + where + processEvents eventQ env = forever $ do + (cc, resp) <- atomically $ readTQueue eventQ + u_ <- readTVarIO (currentUser cc) + forM_ u_ $ \user -> directoryServiceEvent st opts env user cc resp + directoryService :: DirectoryStore -> DirectoryOpts -> User -> ChatController -> IO () -directoryService st DirectoryOpts {adminUsers, superUsers, serviceName, searchResults, testing} user@User {userId} cc = do +directoryService st opts@DirectoryOpts {testing} user cc = do initializeBotAddress' (not testing) cc env <- newServiceState race_ (forever $ void getLine) . forever $ do (_, _, resp) <- atomically . readTBQueue $ outputQ cc - forM_ (crDirectoryEvent resp) $ \case - DEContactConnected ct -> deContactConnected ct - DEGroupInvitation {contact = ct, groupInfo = g, fromMemberRole, memberRole} -> deGroupInvitation ct g fromMemberRole memberRole - DEServiceJoinedGroup ctId g owner -> deServiceJoinedGroup ctId g owner - DEGroupUpdated {contactId, fromGroup, toGroup} -> deGroupUpdated contactId fromGroup toGroup - DEContactRoleChanged g ctId role -> deContactRoleChanged g ctId role - DEServiceRoleChanged g role -> deServiceRoleChanged g role - DEContactRemovedFromGroup ctId g -> deContactRemovedFromGroup ctId g - DEContactLeftGroup ctId g -> deContactLeftGroup ctId g - DEServiceRemovedFromGroup g -> deServiceRemovedFromGroup g - DEGroupDeleted _g -> pure () - DEUnsupportedMessage _ct _ciId -> pure () - DEItemEditIgnored _ct -> pure () - DEItemDeleteIgnored _ct -> pure () - DEContactCommand ct ciId (ADC sUser cmd) -> do - logInfo $ "command received " <> directoryCmdTag cmd - case sUser of - SDRUser -> deUserCommand env ct ciId cmd - SDRAdmin -> deAdminCommand ct ciId cmd - SDRSuperUser -> deSuperUserCommand ct ciId cmd - DELogChatResponse r -> logInfo r + directoryServiceEvent st opts env user cc resp + +directoryServiceEvent :: DirectoryStore -> DirectoryOpts -> ServiceState -> User -> ChatController -> ChatResponse -> IO () +directoryServiceEvent st DirectoryOpts {adminUsers, superUsers, serviceName, searchResults} ServiceState {searchRequests} user@User {userId} cc event = + forM_ (crDirectoryEvent event) $ \case + DEContactConnected ct -> deContactConnected ct + DEGroupInvitation {contact = ct, groupInfo = g, fromMemberRole, memberRole} -> deGroupInvitation ct g fromMemberRole memberRole + DEServiceJoinedGroup ctId g owner -> deServiceJoinedGroup ctId g owner + DEGroupUpdated {contactId, fromGroup, toGroup} -> deGroupUpdated contactId fromGroup toGroup + DEContactRoleChanged g ctId role -> deContactRoleChanged g ctId role + DEServiceRoleChanged g role -> deServiceRoleChanged g role + DEContactRemovedFromGroup ctId g -> deContactRemovedFromGroup ctId g + DEContactLeftGroup ctId g -> deContactLeftGroup ctId g + DEServiceRemovedFromGroup g -> deServiceRemovedFromGroup g + DEGroupDeleted _g -> pure () + DEUnsupportedMessage _ct _ciId -> pure () + DEItemEditIgnored _ct -> pure () + DEItemDeleteIgnored _ct -> pure () + DEContactCommand ct ciId (ADC sUser cmd) -> do + logInfo $ "command received " <> directoryCmdTag cmd + case sUser of + SDRUser -> deUserCommand ct ciId cmd + SDRAdmin -> deAdminCommand ct ciId cmd + SDRSuperUser -> deSuperUserCommand ct ciId cmd + DELogChatResponse r -> logInfo r where withAdminUsers action = void . forkIO $ do forM_ superUsers $ \KnownContact {contactId} -> action contactId @@ -153,7 +174,7 @@ directoryService st DirectoryOpts {adminUsers, superUsers, serviceName, searchRe processInvitation :: Contact -> GroupInfo -> IO () processInvitation ct g@GroupInfo {groupId, groupProfile = GroupProfile {displayName}} = do void $ addGroupReg st ct g GRSProposed - r <- sendChatCmd cc $ APIJoinGroup groupId + r <- sendChatCmd cc $ APIJoinGroup groupId MFNone sendMessage cc ct $ case r of CRUserAcceptedGroupSent {} -> "Joining the group " <> displayName <> "…" _ -> "Error joining group " <> displayName <> ", please re-send the invitation!" @@ -417,8 +438,8 @@ directoryService st DirectoryOpts {adminUsers, superUsers, serviceName, searchRe notifyOwner gr $ serviceName <> " is removed from the group " <> userGroupReference gr g <> ".\n\nThe group is no longer listed in the directory." notifyAdminUsers $ "The group " <> groupReference g <> " is de-listed (directory service is removed)." - deUserCommand :: ServiceState -> Contact -> ChatItemId -> DirectoryCmd 'DRUser -> IO () - deUserCommand env@ServiceState {searchRequests} ct ciId = \case + deUserCommand :: Contact -> ChatItemId -> DirectoryCmd 'DRUser -> IO () + deUserCommand ct ciId = \case DCHelp -> sendMessage cc ct $ "You must be the owner to add the group to the directory:\n\ @@ -446,7 +467,7 @@ directoryService st DirectoryOpts {adminUsers, superUsers, serviceName, searchRe STRecent -> withFoundListedGroups Nothing $ sendNextSearchResults takeRecent search Nothing -> showAllGroups where - showAllGroups = deUserCommand env ct ciId DCAllGroups + showAllGroups = deUserCommand ct ciId DCAllGroups DCAllGroups -> withFoundListedGroups Nothing $ sendAllGroups takeTop "top" STAll DCRecentGroups -> withFoundListedGroups Nothing $ sendAllGroups takeRecent "the most recent" STRecent DCSubmitGroup _link -> pure () diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index f6f7416bb1..3854b0662e 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -349,7 +349,7 @@ data ChatCommand | APIGetNtfConns {nonce :: C.CbNonce, encNtfInfo :: ByteString} | ApiGetConnNtfMessages {connIds :: NonEmpty AgentConnId} | APIAddMember GroupId ContactId GroupMemberRole - | APIJoinGroup GroupId + | APIJoinGroup {groupId :: GroupId, enableNtfs :: MsgFilter} | APIMemberRole GroupId GroupMemberId GroupMemberRole | APIBlockMemberForAll GroupId GroupMemberId Bool | APIRemoveMember GroupId GroupMemberId @@ -467,7 +467,7 @@ data ChatCommand | APINewGroup UserId IncognitoEnabled GroupProfile | NewGroup IncognitoEnabled GroupProfile | AddMember GroupName ContactName GroupMemberRole - | JoinGroup GroupName + | JoinGroup {groupName :: GroupName, enableNtfs :: MsgFilter} | MemberRole GroupName ContactName GroupMemberRole | BlockForAll GroupName ContactName Bool | RemoveMember GroupName ContactName diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index d25444a358..85dd765e7a 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -1924,12 +1924,12 @@ processChatCommand' vr = \case pure $ CRSentGroupInvitation user gInfo contact member {memberRole = memRole} Nothing -> throwChatError $ CEGroupCantResendInvitation gInfo cName | otherwise -> throwChatError $ CEGroupDuplicateMember cName - APIJoinGroup groupId -> withUser $ \user@User {userId} -> do + APIJoinGroup groupId enableNtfs -> withUser $ \user@User {userId} -> do withGroupLock "joinGroup" groupId . procCmd $ do (invitation, ct) <- withFastStore $ \db -> do inv@ReceivedGroupInvitation {fromMember} <- getGroupInvitation db vr user groupId (inv,) <$> getContactViaMember db vr user fromMember - let ReceivedGroupInvitation {fromMember, connRequest, groupInfo = g@GroupInfo {membership}} = invitation + let ReceivedGroupInvitation {fromMember, connRequest, groupInfo = g@GroupInfo {membership, chatSettings}} = invitation GroupMember {memberId = membershipMemId} = membership Contact {activeConn} = ct case activeConn of @@ -1946,7 +1946,9 @@ processChatCommand' vr = \case withFastStore' $ \db -> do updateGroupMemberStatus db userId fromMember GSMemAccepted updateGroupMemberStatus db userId membership GSMemAccepted - void (withAgent $ \a -> joinConnection a (aUserId user) agentConnId True connRequest dm PQSupportOff subMode) + -- MFAll is default for new groups + unless (enableNtfs == MFAll) $ updateGroupSettings db user groupId chatSettings {enableNtfs} + void (withAgent $ \a -> joinConnection a (aUserId user) agentConnId (enableNtfs /= MFNone) connRequest dm PQSupportOff subMode) `catchChatError` \e -> do withFastStore' $ \db -> do updateGroupMemberStatus db userId fromMember GSMemInvited @@ -2043,9 +2045,9 @@ processChatCommand' vr = \case AddMember gName cName memRole -> withUser $ \user -> do (groupId, contactId) <- withFastStore $ \db -> (,) <$> getGroupIdByName db user gName <*> getContactIdByName db user cName processChatCommand $ APIAddMember groupId contactId memRole - JoinGroup gName -> withUser $ \user -> do + JoinGroup gName enableNtfs -> withUser $ \user -> do groupId <- withFastStore $ \db -> getGroupIdByName db user gName - processChatCommand $ APIJoinGroup groupId + processChatCommand $ APIJoinGroup groupId enableNtfs MemberRole gName gMemberName memRole -> withMemberName gName gMemberName $ \gId gMemberId -> APIMemberRole gId gMemberId memRole BlockForAll gName gMemberName blocked -> withMemberName gName gMemberName $ \gId gMemberId -> APIBlockMemberForAll gId gMemberId blocked RemoveMember gName gMemberName -> withMemberName gName gMemberName APIRemoveMember @@ -3630,7 +3632,7 @@ chatCommandP = "/_ntf conns " *> (APIGetNtfConns <$> strP <* A.space <*> strP), "/_ntf conn messages " *> (ApiGetConnNtfMessages <$> strP), "/_add #" *> (APIAddMember <$> A.decimal <* A.space <*> A.decimal <*> memberRole), - "/_join #" *> (APIJoinGroup <$> A.decimal), + "/_join #" *> (APIJoinGroup <$> A.decimal <*> pure MFAll), -- needs to be changed to support in UI "/_member role #" *> (APIMemberRole <$> A.decimal <* A.space <*> A.decimal <*> memberRole), "/_block #" *> (APIBlockMemberForAll <$> A.decimal <* A.space <*> A.decimal <* A.space <* "blocked=" <*> onOffP), "/_remove #" *> (APIRemoveMember <$> A.decimal <* A.space <*> A.decimal), @@ -3712,7 +3714,7 @@ chatCommandP = ("/group" <|> "/g") *> (NewGroup <$> incognitoP <* A.space <* char_ '#' <*> groupProfile), "/_group " *> (APINewGroup <$> A.decimal <*> incognitoOnOffP <* A.space <*> jsonP), ("/add " <|> "/a ") *> char_ '#' *> (AddMember <$> displayName <* A.space <* char_ '@' <*> displayName <*> (memberRole <|> pure GRMember)), - ("/join " <|> "/j ") *> char_ '#' *> (JoinGroup <$> displayName), + ("/join " <|> "/j ") *> char_ '#' *> (JoinGroup <$> displayName <*> (" mute" $> MFNone <|> pure MFAll)), ("/member role " <|> "/mr ") *> char_ '#' *> (MemberRole <$> displayName <* A.space <* char_ '@' <*> displayName <*> memberRole), "/block for all #" *> (BlockForAll <$> displayName <* A.space <*> (char_ '@' *> displayName) <*> pure True), "/unblock for all #" *> (BlockForAll <$> displayName <* A.space <*> (char_ '@' *> displayName) <*> pure False), diff --git a/tests/Bots/DirectoryTests.hs b/tests/Bots/DirectoryTests.hs index c50bb8b02d..9775dddd5f 100644 --- a/tests/Bots/DirectoryTests.hs +++ b/tests/Bots/DirectoryTests.hs @@ -72,6 +72,7 @@ mkDirectoryOpts tmp superUsers = superUsers, directoryLog = Just $ tmp "directory_service.log", serviceName = "SimpleX-Directory", + runCLI = False, searchResults = 3, testing = True }