From 31faceef7381d7a31c30b4eb0f059e3a33097a5a Mon Sep 17 00:00:00 2001 From: Evgeny Date: Sun, 2 Aug 2026 14:12:57 +0100 Subject: [PATCH 1/2] docs: add bot library APIs (#7334) --- bots/api/COMMANDS.md | 104 ++++++++++++++++++ bots/api/TYPES.md | 1 + bots/src/API/Docs/Commands.hs | 10 +- bots/src/API/Docs/Responses.hs | 4 +- bots/src/API/Docs/Types.hs | 2 +- .../types/typescript/src/commands.ts | 43 ++++++++ .../types/typescript/src/responses.ts | 17 +++ .../types/typescript/src/types.ts | 1 + .../src/simplex_chat/types/_commands.py | 37 +++++++ .../src/simplex_chat/types/_responses.py | 15 ++- .../src/simplex_chat/types/_types.py | 2 +- 11 files changed, 226 insertions(+), 10 deletions(-) diff --git a/bots/api/COMMANDS.md b/bots/api/COMMANDS.md index 8d61622fff..476ee4f94d 100644 --- a/bots/api/COMMANDS.md +++ b/bots/api/COMMANDS.md @@ -15,6 +15,8 @@ This file is generated automatically. - [APIDeleteChatItem](#apideletechatitem) - [APIDeleteMemberChatItem](#apideletememberchatitem) - [APIChatItemReaction](#apichatitemreaction) +- [APIShareMyAddress](#apisharemyaddress) +- [APIShareChatMsgContent](#apisharechatmsgcontent) [File commands](#file-commands) - [ReceiveFile](#receivefile) @@ -35,6 +37,7 @@ This file is generated automatically. - [APIAddGroupRelays](#apiaddgrouprelays) - [APIAllowRelayGroup](#apiallowrelaygroup) - [APIUpdateGroupProfile](#apiupdategroupprofile) +- [APIVerifyGroupDomain](#apiverifygroupdomain) [Group link commands](#group-link-commands) - [APICreateGroupLink](#apicreategrouplink) @@ -489,6 +492,73 @@ ChatCmdError: Command error (only used in WebSockets API). --- +### APIShareMyAddress + +Share user address card + +*Network usage*: no. + +**Parameters**: +- toSendRef: [ChatRef](./TYPES.md#chatref) + +**Syntax**: + +``` +/_share address +``` + +```javascript +'/_share address' + ChatRef.cmdString(toSendRef) // JavaScript +``` + +```python +'/_share address' + ChatRef_cmd_string(toSendRef) # Python +``` + +**Response**: + +ChatMsgContent: Chat card content that can be sent. +- type: "chatMsgContent" +- user: [User](./TYPES.md#user) +- msgContent: [MsgContent](./TYPES.md#msgcontent) + +--- + + +### APIShareChatMsgContent + +Share channel address + +*Network usage*: no. + +**Parameters**: +- shareChatRef: [ChatRef](./TYPES.md#chatref) +- toSendRef: [ChatRef](./TYPES.md#chatref) + +**Syntax**: + +``` +/_share chat content +``` + +```javascript +'/_share chat content ' + ChatRef.cmdString(shareChatRef) + ' ' + ChatRef.cmdString(toSendRef) // JavaScript +``` + +```python +'/_share chat content ' + ChatRef_cmd_string(shareChatRef) + ' ' + ChatRef_cmd_string(toSendRef) # Python +``` + +**Response**: + +ChatMsgContent: Chat card content that can be sent. +- type: "chatMsgContent" +- user: [User](./TYPES.md#user) +- msgContent: [MsgContent](./TYPES.md#msgcontent) + +--- + + ## File commands Commands to receive and to cancel files. Files are sent as part of the message, there are no separate commands to send files. @@ -1165,6 +1235,40 @@ ChatCmdError: Command error (only used in WebSockets API). --- +### APIVerifyGroupDomain + +Verify group domain + +*Network usage*: interactive. + +**Parameters**: +- groupId: int64 + +**Syntax**: + +``` +/_verify domain # +``` + +```javascript +'/_verify domain #' + groupId // JavaScript +``` + +```python +'/_verify domain #' + str(groupId) # Python +``` + +**Response**: + +GroupDomainVerified: Group domain verified. +- type: "groupDomainVerified" +- user: [User](./TYPES.md#user) +- groupInfo: [GroupInfo](./TYPES.md#groupinfo) +- verificationFailure: string? + +--- + + ## Group link commands These commands can be used by bots that manage multiple public groups diff --git a/bots/api/TYPES.md b/bots/api/TYPES.md index 61c8c97132..4546a6aaa7 100644 --- a/bots/api/TYPES.md +++ b/bots/api/TYPES.md @@ -1448,6 +1448,7 @@ Search: **Enum type**: - "human" - "bot" +- "business" --- diff --git a/bots/src/API/Docs/Commands.hs b/bots/src/API/Docs/Commands.hs index da2a9e5d59..09ae1faa5b 100644 --- a/bots/src/API/Docs/Commands.hs +++ b/bots/src/API/Docs/Commands.hs @@ -97,7 +97,9 @@ chatCommandsDocsData = ), ("APIDeleteChatItem", [], "Delete message.", ["CRChatItemsDeleted", "CRChatCmdError"], [], Just UNBackground, "/_delete item " <> Param "chatRef" <> " " <> Join ',' "chatItemIds" <> " " <> Param "deleteMode"), ("APIDeleteMemberChatItem", [], "Moderate message. Requires Moderator role (and higher than message author's).", ["CRChatItemsDeleted", "CRChatCmdError"], [], Just UNBackground, "/_delete member item #" <> Param "groupId" <> " " <> Join ',' "chatItemIds"), - ("APIChatItemReaction", [], "Add/remove message reaction.", ["CRChatItemReaction", "CRChatCmdError"], [], Just UNBackground, "/_reaction " <> Param "chatRef" <> " " <> Param "chatItemId" <> " " <> OnOff "add" <> " " <> Json "reaction") + ("APIChatItemReaction", [], "Add/remove message reaction.", ["CRChatItemReaction", "CRChatCmdError"], [], Just UNBackground, "/_reaction " <> Param "chatRef" <> " " <> Param "chatItemId" <> " " <> OnOff "add" <> " " <> Json "reaction"), + ("APIShareMyAddress", [], "Share user address card", ["CRChatMsgContent"], [], Nothing, "/_share address" <> Param "toSendRef"), + ("APIShareChatMsgContent", [], "Share channel address", ["CRChatMsgContent"], [], Nothing, "/_share chat content " <> Param "shareChatRef" <> " " <> Param "toSendRef") ] ), ( "File commands", @@ -121,7 +123,8 @@ chatCommandsDocsData = ("APIGetGroupRelays", [], "Get group relays.", ["CRGroupRelays", "CRChatCmdError"], [], Nothing, "/_get relays #" <> Param "groupId"), ("APIAddGroupRelays", [], "Add relays to group.", ["CRGroupRelaysAdded", "CRGroupRelaysAddFailed", "CRChatCmdError"], [], Just UNInteractive, "/_add relays #" <> Param "groupId" <> " " <> Join ',' "relayIds"), ("APIAllowRelayGroup", [], "Clear relay rejection for a channel (relay operator).", ["CRRelayGroupAllowed", "CRChatCmdError"], [], Just UNBackground, "/_relay allow #" <> Param "groupId"), - ("APIUpdateGroupProfile", [], "Update group profile.", ["CRGroupUpdated", "CRChatCmdError"], [], Just UNBackground, "/_group_profile #" <> Param "groupId" <> " " <> Json "groupProfile") + ("APIUpdateGroupProfile", [], "Update group profile.", ["CRGroupUpdated", "CRChatCmdError"], [], Just UNBackground, "/_group_profile #" <> Param "groupId" <> " " <> Json "groupProfile"), + ("APIVerifyGroupDomain", [], "Verify group domain", ["CRGroupDomainVerified"], [], Just UNInteractive, "/_verify domain #" <> Param "groupId") ] ), ( "Group link commands", @@ -426,8 +429,6 @@ undocumentedCommands = "APISetUserDomain", "APISetUserServers", "APISetUserUIThemes", - "APIShareChatMsgContent", - "APIShareMyAddress", "APIStandaloneFileInfo", "APIStorageEncryption", "APISuspendChat", @@ -446,7 +447,6 @@ undocumentedCommands = "APIVerifyContact", "APIVerifyContactDomain", "APIVerifyGroupMember", - "APIVerifyGroupDomain", "APIVerifyToken", "CheckChatRunning", "ConfirmRemoteCtrl", diff --git a/bots/src/API/Docs/Responses.hs b/bots/src/API/Docs/Responses.hs index 7f158f7540..76f1ddb76b 100644 --- a/bots/src/API/Docs/Responses.hs +++ b/bots/src/API/Docs/Responses.hs @@ -51,6 +51,7 @@ chatResponsesDocsData = ("CRChatItemReaction", "Message reaction"), ("CRChatItemUpdated", "Message updated"), ("CRChatItemsDeleted", "Messages deleted"), + ("CRChatMsgContent", "Chat card content that can be sent"), ("CRChatRunning", ""), ("CRChatStarted", ""), ("CRChatStopped", ""), @@ -77,6 +78,7 @@ chatResponsesDocsData = ("CRGroupMembers", ""), ("CRGroupUpdated", ""), ("CRGroupsList", "Groups"), + ("CRGroupDomainVerified", ""), ("CRInvitation", "One-time invitation"), ("CRLeftMemberUser", "User left group"), ("CRMemberAccepted", "Member accepted to group"), @@ -136,7 +138,6 @@ undocumentedResponses = "CRChatItemInfo", "CRChatItems", "CRChatItemTTL", - "CRChatMsgContent", "CRChatRelayTestResult", "CRChats", "CRConnectionsDiff", @@ -169,7 +170,6 @@ undocumentedResponses = "CRGroupMemberRatchetSyncStarted", "CRGroupMemberSwitchAborted", "CRGroupMemberSwitchStarted", - "CRGroupDomainVerified", "CRGroupProfile", "CRGroupUserChanged", "CRItemsReadForChat", diff --git a/bots/src/API/Docs/Types.hs b/bots/src/API/Docs/Types.hs index f6b25934b1..e0af1f3ff5 100644 --- a/bots/src/API/Docs/Types.hs +++ b/bots/src/API/Docs/Types.hs @@ -226,7 +226,7 @@ chatTypesDocsData = (sti @BadgeType, STEnum, "BT", ["BTUnknown"], "", ""), (sti @ChatFeature, STEnum, "CF", [], "", ""), (sti @ChatItemDeletion, STRecord, "", [], "", "Message deletion result."), - (sti @ChatPeerType, STEnum, "CPT", [], "", ""), + (sti @ChatPeerType, STEnum, "CPT", ["CPTUnknown"], "", ""), (sti @ChatRef, STRecord, "", [], Param "chatType" <> Param "chatId" <> Optional "" (Param "$0") "chatScope", "Used in API commands. Chat scope can only be passed with groups."), (sti @ChatSettings, STRecord, "", [], "", ""), (sti @ChatStats, STRecord, "", [], "", ""), diff --git a/packages/simplex-chat-client/types/typescript/src/commands.ts b/packages/simplex-chat-client/types/typescript/src/commands.ts index 4c7c13403e..14b03f560f 100644 --- a/packages/simplex-chat-client/types/typescript/src/commands.ts +++ b/packages/simplex-chat-client/types/typescript/src/commands.ts @@ -168,6 +168,35 @@ export namespace APIChatItemReaction { } } +// Share user address card +// Network usage: no. +export interface APIShareMyAddress { + toSendRef: T.ChatRef +} + +export namespace APIShareMyAddress { + export type Response = CR.ChatMsgContent + + export function cmdString(self: APIShareMyAddress): string { + return '/_share address' + T.ChatRef.cmdString(self.toSendRef) + } +} + +// Share channel address +// Network usage: no. +export interface APIShareChatMsgContent { + shareChatRef: T.ChatRef + toSendRef: T.ChatRef +} + +export namespace APIShareChatMsgContent { + export type Response = CR.ChatMsgContent + + export function cmdString(self: APIShareChatMsgContent): string { + return '/_share chat content ' + T.ChatRef.cmdString(self.shareChatRef) + ' ' + T.ChatRef.cmdString(self.toSendRef) + } +} + // File commands // Commands to receive and to cancel files. Files are sent as part of the message, there are no separate commands to send files. @@ -419,6 +448,20 @@ export namespace APIUpdateGroupProfile { } } +// Verify group domain +// Network usage: interactive. +export interface APIVerifyGroupDomain { + groupId: number // int64 +} + +export namespace APIVerifyGroupDomain { + export type Response = CR.GroupDomainVerified + + export function cmdString(self: APIVerifyGroupDomain): string { + return '/_verify domain #' + self.groupId + } +} + // Group link commands // These commands can be used by bots that manage multiple public groups diff --git a/packages/simplex-chat-client/types/typescript/src/responses.ts b/packages/simplex-chat-client/types/typescript/src/responses.ts index fa5c83d03c..b2d29490c8 100644 --- a/packages/simplex-chat-client/types/typescript/src/responses.ts +++ b/packages/simplex-chat-client/types/typescript/src/responses.ts @@ -10,6 +10,7 @@ export type ChatResponse = | CR.ChatItemReaction | CR.ChatItemUpdated | CR.ChatItemsDeleted + | CR.ChatMsgContent | CR.ChatRunning | CR.ChatStarted | CR.ChatStopped @@ -36,6 +37,7 @@ export type ChatResponse = | CR.GroupMembers | CR.GroupUpdated | CR.GroupsList + | CR.GroupDomainVerified | CR.Invitation | CR.LeftMemberUser | CR.MemberAccepted @@ -69,6 +71,7 @@ export namespace CR { | "chatItemReaction" | "chatItemUpdated" | "chatItemsDeleted" + | "chatMsgContent" | "chatRunning" | "chatStarted" | "chatStopped" @@ -95,6 +98,7 @@ export namespace CR { | "groupMembers" | "groupUpdated" | "groupsList" + | "groupDomainVerified" | "invitation" | "leftMemberUser" | "memberAccepted" @@ -162,6 +166,12 @@ export namespace CR { timed: boolean } + export interface ChatMsgContent extends Interface { + type: "chatMsgContent" + user: T.User + msgContent: T.MsgContent + } + export interface ChatRunning extends Interface { type: "chatRunning" } @@ -326,6 +336,13 @@ export namespace CR { groups: T.GroupInfo[] } + export interface GroupDomainVerified extends Interface { + type: "groupDomainVerified" + user: T.User + groupInfo: T.GroupInfo + verificationFailure?: string + } + export interface Invitation extends Interface { type: "invitation" user: T.User diff --git a/packages/simplex-chat-client/types/typescript/src/types.ts b/packages/simplex-chat-client/types/typescript/src/types.ts index abc4187747..5faf084dce 100644 --- a/packages/simplex-chat-client/types/typescript/src/types.ts +++ b/packages/simplex-chat-client/types/typescript/src/types.ts @@ -1680,6 +1680,7 @@ export namespace ChatListQuery { export enum ChatPeerType { Human = "human", Bot = "bot", + Business = "business", } // Used in API commands. Chat scope can only be passed with groups. diff --git a/packages/simplex-chat-python/src/simplex_chat/types/_commands.py b/packages/simplex-chat-python/src/simplex_chat/types/_commands.py index 1886df7868..f73a4fa4f7 100644 --- a/packages/simplex-chat-python/src/simplex_chat/types/_commands.py +++ b/packages/simplex-chat-python/src/simplex_chat/types/_commands.py @@ -149,6 +149,31 @@ def APIChatItemReaction_cmd_string(self: APIChatItemReaction) -> str: APIChatItemReaction_Response = CR.ChatItemReaction | CR.ChatCmdError +# Share user address card +# Network usage: no. +class APIShareMyAddress(TypedDict): + toSendRef: "T.ChatRef" + + +def APIShareMyAddress_cmd_string(self: APIShareMyAddress) -> str: + return '/_share address' + T.ChatRef_cmd_string(self['toSendRef']) + +APIShareMyAddress_Response = CR.ChatMsgContent + + +# Share channel address +# Network usage: no. +class APIShareChatMsgContent(TypedDict): + shareChatRef: "T.ChatRef" + toSendRef: "T.ChatRef" + + +def APIShareChatMsgContent_cmd_string(self: APIShareChatMsgContent) -> str: + return '/_share chat content ' + T.ChatRef_cmd_string(self['shareChatRef']) + ' ' + T.ChatRef_cmd_string(self['toSendRef']) + +APIShareChatMsgContent_Response = CR.ChatMsgContent + + # File commands # Commands to receive and to cancel files. Files are sent as part of the message, there are no separate commands to send files. @@ -368,6 +393,18 @@ def APIUpdateGroupProfile_cmd_string(self: APIUpdateGroupProfile) -> str: APIUpdateGroupProfile_Response = CR.GroupUpdated | CR.ChatCmdError +# Verify group domain +# Network usage: interactive. +class APIVerifyGroupDomain(TypedDict): + groupId: int # int64 + + +def APIVerifyGroupDomain_cmd_string(self: APIVerifyGroupDomain) -> str: + return '/_verify domain #' + str(self['groupId']) + +APIVerifyGroupDomain_Response = CR.GroupDomainVerified + + # Group link commands # These commands can be used by bots that manage multiple public groups diff --git a/packages/simplex-chat-python/src/simplex_chat/types/_responses.py b/packages/simplex-chat-python/src/simplex_chat/types/_responses.py index 955291d0f0..393c20f311 100644 --- a/packages/simplex-chat-python/src/simplex_chat/types/_responses.py +++ b/packages/simplex-chat-python/src/simplex_chat/types/_responses.py @@ -36,6 +36,11 @@ class ChatItemsDeleted(TypedDict): byUser: bool timed: bool +class ChatMsgContent(TypedDict): + type: Literal["chatMsgContent"] + user: "T.User" + msgContent: "T.MsgContent" + class ChatRunning(TypedDict): type: Literal["chatRunning"] @@ -174,6 +179,12 @@ class GroupsList(TypedDict): user: "T.User" groups: list["T.GroupInfo"] +class GroupDomainVerified(TypedDict): + type: Literal["groupDomainVerified"] + user: "T.User" + groupInfo: "T.GroupInfo" + verificationFailure: NotRequired[str] + class Invitation(TypedDict): type: Literal["invitation"] user: "T.User" @@ -319,6 +330,7 @@ ChatResponse = ( | ChatItemReaction | ChatItemUpdated | ChatItemsDeleted + | ChatMsgContent | ChatRunning | ChatStarted | ChatStopped @@ -345,6 +357,7 @@ ChatResponse = ( | GroupMembers | GroupUpdated | GroupsList + | GroupDomainVerified | Invitation | LeftMemberUser | MemberAccepted @@ -371,4 +384,4 @@ ChatResponse = ( | ApiChats ) -ChatResponse_Tag = Literal["acceptingContactRequest", "activeUser", "chatItemNotChanged", "chatItemReaction", "chatItemUpdated", "chatItemsDeleted", "chatRunning", "chatStarted", "chatStopped", "cmdOk", "chatCmdError", "connectionPlan", "contactAlreadyExists", "contactConnectionDeleted", "contactDeleted", "contactPrefsUpdated", "contactRequestRejected", "contactsList", "groupDeletedUser", "groupLink", "groupLinkCreated", "groupLinkDeleted", "groupCreated", "publicGroupCreated", "publicGroupCreationFailed", "groupRelays", "groupRelaysAdded", "groupRelaysAddFailed", "relayGroupAllowed", "groupMembers", "groupUpdated", "groupsList", "invitation", "leftMemberUser", "memberAccepted", "membersBlockedForAllUser", "membersRoleUser", "newChatItems", "rcvFileAccepted", "rcvFileAcceptedSndCancelled", "rcvFileCancelled", "sentConfirmation", "sentGroupInvitation", "sentInvitation", "serviceReplyAccepted", "sndFileCancelled", "userAcceptedGroupSent", "userContactLink", "userContactLinkCreated", "userContactLinkDeleted", "userContactLinkUpdated", "userDeletedMembers", "userProfileUpdated", "userProfileNoChange", "usersList", "apiChats"] +ChatResponse_Tag = Literal["acceptingContactRequest", "activeUser", "chatItemNotChanged", "chatItemReaction", "chatItemUpdated", "chatItemsDeleted", "chatMsgContent", "chatRunning", "chatStarted", "chatStopped", "cmdOk", "chatCmdError", "connectionPlan", "contactAlreadyExists", "contactConnectionDeleted", "contactDeleted", "contactPrefsUpdated", "contactRequestRejected", "contactsList", "groupDeletedUser", "groupLink", "groupLinkCreated", "groupLinkDeleted", "groupCreated", "publicGroupCreated", "publicGroupCreationFailed", "groupRelays", "groupRelaysAdded", "groupRelaysAddFailed", "relayGroupAllowed", "groupMembers", "groupUpdated", "groupsList", "groupDomainVerified", "invitation", "leftMemberUser", "memberAccepted", "membersBlockedForAllUser", "membersRoleUser", "newChatItems", "rcvFileAccepted", "rcvFileAcceptedSndCancelled", "rcvFileCancelled", "sentConfirmation", "sentGroupInvitation", "sentInvitation", "serviceReplyAccepted", "sndFileCancelled", "userAcceptedGroupSent", "userContactLink", "userContactLinkCreated", "userContactLinkDeleted", "userContactLinkUpdated", "userDeletedMembers", "userProfileUpdated", "userProfileNoChange", "usersList", "apiChats"] diff --git a/packages/simplex-chat-python/src/simplex_chat/types/_types.py b/packages/simplex-chat-python/src/simplex_chat/types/_types.py index b57915d2db..b00a559f92 100644 --- a/packages/simplex-chat-python/src/simplex_chat/types/_types.py +++ b/packages/simplex-chat-python/src/simplex_chat/types/_types.py @@ -1175,7 +1175,7 @@ ChatListQuery = ChatListQuery_filters | ChatListQuery_search ChatListQuery_Tag = Literal["filters", "search"] -ChatPeerType = Literal["human", "bot"] +ChatPeerType = Literal["human", "bot", "business"] # Used in API commands. Chat scope can only be passed with groups. From 34b74d1c4986088f6a42c3a13dc584c638ead47a Mon Sep 17 00:00:00 2001 From: Evgeny Date: Sun, 2 Aug 2026 16:01:22 +0100 Subject: [PATCH 2/2] directory: remove support for directory log file (#7331) * directory: remove support for directory log file * remove unused exports --- apps/simplex-directory-service/Main.hs | 20 +-- .../src/Directory/Options.hs | 33 ---- .../src/Directory/Service.hs | 103 ++++++------ .../src/Directory/Store.hs | 146 +----------------- .../src/Directory/Store/Migrate.hs | 70 +-------- tests/Bots/DirectoryTests.hs | 11 +- 6 files changed, 58 insertions(+), 325 deletions(-) diff --git a/apps/simplex-directory-service/Main.hs b/apps/simplex-directory-service/Main.hs index 33145497ea..f771199dea 100644 --- a/apps/simplex-directory-service/Main.hs +++ b/apps/simplex-directory-service/Main.hs @@ -5,23 +5,11 @@ module Main where import Directory.Options import Directory.Service -import Directory.Store -import Directory.Store.Migrate import Simplex.Chat.Terminal (terminalChatConfig) main :: IO () main = do - opts@DirectoryOpts {directoryLog, migrateDirectoryLog, runCLI} <- welcomeGetOpts - case migrateDirectoryLog of - Just cmd -> migrate cmd opts terminalChatConfig - Nothing -> do - st <- openDirectoryLog directoryLog - if runCLI - then directoryServiceCLI st opts - else directoryService st opts terminalChatConfig - where - migrate = \case - MLCheck -> checkDirectoryLog - MLImport -> importDirectoryLogToDB - MLExport -> exportDBToDirectoryLog - MLListing -> saveGroupListingFiles + opts@DirectoryOpts {runCLI} <- welcomeGetOpts + if runCLI + then directoryServiceCLI opts + else directoryService opts terminalChatConfig diff --git a/apps/simplex-directory-service/src/Directory/Options.hs b/apps/simplex-directory-service/src/Directory/Options.hs index 199229964a..89709e66d9 100644 --- a/apps/simplex-directory-service/src/Directory/Options.hs +++ b/apps/simplex-directory-service/src/Directory/Options.hs @@ -14,14 +14,11 @@ module Directory.Options ) where -import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8) import Options.Applicative import Simplex.Chat.Bot.KnownContacts import Simplex.Chat.Controller (updateStr, versionNumber, versionString) import Simplex.Chat.Options (ChatCmdLog (..), ChatOpts (..), CoreChatOpts, CreateBotOpts (..), coreChatOptsP) -import Simplex.Messaging.Parsers (parseAll) data DirectoryOpts = DirectoryOpts { coreOptions :: CoreChatOpts, @@ -36,8 +33,6 @@ data DirectoryOpts = DirectoryOpts profileNameLimit :: Int, captchaGenerator :: Maybe FilePath, voiceCaptchaGenerator :: Maybe FilePath, - directoryLog :: Maybe FilePath, - migrateDirectoryLog :: Maybe MigrateLog, serviceName :: T.Text, clientService :: Bool, runCLI :: Bool, @@ -133,21 +128,6 @@ directoryOpts appDir defaultDbName = do <> metavar "VOICE_CAPTCHA_GENERATOR" <> help "Executable to generate voice captcha, accepts text as parameter, writes audio file, outputs file_path and duration_seconds to stdout" ) - directoryLog <- - optional $ - strOption - ( long "directory-file" - <> metavar "DIRECTORY_FILE" - <> help "Append only log for directory state" - ) - migrateDirectoryLog <- - optional $ - option - parseMigrateLog - ( long "migrate-directory-file" - <> metavar "MIGRATE_COMMAND" - <> help "Command to import/export directory log file" - ) serviceName <- strOption ( long "service-name" @@ -209,8 +189,6 @@ directoryOpts appDir defaultDbName = do profileNameLimit, captchaGenerator, voiceCaptchaGenerator, - directoryLog, - migrateDirectoryLog, serviceName = T.pack serviceName, clientService, runCLI, @@ -254,14 +232,3 @@ mkChatOpts DirectoryOpts {coreOptions, serviceName, clientService} = userDisplayName = Nothing, userImageFile = Nothing } - -parseMigrateLog :: ReadM MigrateLog -parseMigrateLog = eitherReader $ parseAll mlP . encodeUtf8 . T.pack - where - mlP = - A.takeTill (== ' ') >>= \case - "check" -> pure MLCheck - "import" -> pure MLImport - "export" -> pure MLExport - "listing" -> pure MLListing - _ -> fail "bad MigrateLog" diff --git a/apps/simplex-directory-service/src/Directory/Service.hs b/apps/simplex-directory-service/src/Directory/Service.hs index a3af872ac3..7dc165c4df 100644 --- a/apps/simplex-directory-service/src/Directory/Service.hs +++ b/apps/simplex-directory-service/src/Directory/Service.hs @@ -154,8 +154,8 @@ welcomeGetOpts = do knownContact KnownContact {contactId, localDisplayName = n} = knownName contactId n knownName i n = show i <> ":" <> T.unpack (viewName n) -directoryServiceCLI :: DirectoryLog -> DirectoryOpts -> IO () -directoryServiceCLI st opts = do +directoryServiceCLI :: DirectoryOpts -> IO () +directoryServiceCLI opts = do env@ServiceState {eventQ} <- newServiceState opts let eventHook _cc resp = atomically $ resp <$ mapM_ (writeTQueue eventQ) (crDirectoryEvent resp) chatHooks = @@ -178,7 +178,7 @@ directoryServiceCLI st opts = do forM_ u_ $ \user -> forever $ do event <- atomically $ readTQueue eventQ - directoryServiceEvent st opts env user cc event + directoryServiceEvent opts env user cc event updateListingDelay :: Int updateListingDelay = 5 * 60 * 1000000 -- update every 5 minutes @@ -249,8 +249,8 @@ directoryCommands = where idParam = Just "" -directoryService :: DirectoryLog -> DirectoryOpts -> ChatConfig -> IO () -directoryService st opts cfg = do +directoryService :: DirectoryOpts -> ChatConfig -> IO () +directoryService opts cfg = do env@ServiceState {eventQ} <- newServiceState opts let chatHooks = defaultChatHooks @@ -265,7 +265,7 @@ directoryService st opts cfg = do mapM_ (atomically . writeTQueue eventQ) $ crDirectoryEvent resp, forever $ do event <- atomically $ readTQueue eventQ - directoryServiceEvent st opts env user cc event + directoryServiceEvent opts env user cc event ] <> maybeToList (updateListingsThread_ opts env) <> maybeToList (linkCheckThread_ opts env) @@ -317,8 +317,8 @@ readBlockedWordsConfig DirectoryOpts {blockedFragmentsFile, blockedWordsFile, na unless testing $ putStrLn $ "Blocked fragments: " <> show (length blockedFragments) <> ", blocked words: " <> show (length blockedWords) <> ", spelling rules: " <> show (M.size spelling) pure BlockedWordsConfig {blockedFragments, blockedWords, extensionRules, spelling} -directoryServiceEvent :: DirectoryLog -> DirectoryOpts -> ServiceState -> User -> ChatController -> DirectoryEvent -> IO () -directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName, ownersGroup, searchResults, prohibitedToObserver, alwaysCaptcha} env@ServiceState {searchRequests} user@User {userId} cc = \case +directoryServiceEvent :: DirectoryOpts -> ServiceState -> User -> ChatController -> DirectoryEvent -> IO () +directoryServiceEvent opts@DirectoryOpts {adminUsers, superUsers, serviceName, ownersGroup, searchResults, prohibitedToObserver, alwaysCaptcha} env@ServiceState {searchRequests} user@User {userId} cc = \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 @@ -420,8 +420,8 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName processInvitation :: Contact -> GroupInfo -> Maybe GroupReg -> IO () processInvitation ct g@GroupInfo {groupId, groupProfile = GroupProfile {displayName}} = \case - Nothing -> addGroupReg notifyAdminUsers st cc user ct g GRSProposed joinGroup - Just _gr -> setGroupStatus notifyAdminUsers st env cc groupId GRSProposed joinGroup + Nothing -> addGroupReg notifyAdminUsers cc user ct g GRSProposed joinGroup + Just _gr -> setGroupStatus notifyAdminUsers env cc groupId GRSProposed joinGroup where joinGroup _ = do r <- sendChatCmd cc $ APIJoinGroup groupId MFNone @@ -452,7 +452,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName Left e -> sendMessage cc ct $ "Error: getDuplicateGroup. Please notify the developers.\n" <> T.pack e where askConfirmation = - addGroupReg notifyAdminUsers st cc user ct g GRSPendingConfirmation $ \GroupReg {userGroupRegId} -> do + addGroupReg notifyAdminUsers cc user ct g GRSPendingConfirmation $ \GroupReg {userGroupRegId} -> do sendMessage cc ct $ "The group " <> groupNameDescr p <> " is already submitted to the directory.\nTo confirm the registration, please send:" sendMessage cc ct $ "/confirm " <> tshow userGroupRegId <> ":" <> viewName displayName @@ -493,11 +493,10 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName logError msg notifyOwner gr msg Right () -> do - logGUpdateOwner st groupId $ groupMemberId' owner notifyOwner gr $ "Joined the group " <> displayName <> ", creating the link…" sendChatCmd cc (APICreateGroupLink groupId GRMember) >>= \case Right CRGroupLinkCreated {groupLink = GroupLink {connLinkContact = gLink}} -> - setGroupStatus notifyAdminUsers st env cc groupId GRSPendingUpdate $ \gr' -> do + setGroupStatus notifyAdminUsers env cc groupId GRSPendingUpdate $ \gr' -> do notifyOwner gr' "Created the public link to join the group via this directory service that is always online.\n\n\ @@ -576,19 +575,19 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName withDB "getGroupMember" cc (\db -> withExceptT show $ getGroupMember db (storeCxt cc) user groupId ownerGMId) >>= \case Right ownerMember | let GroupMember {memberRole = role} = ownerMember, role >= GROwner -> - setGroupStatus notifyAdminUsers st env cc groupId (GRSPendingApproval n') (`updatedNotification` g') + setGroupStatus notifyAdminUsers env cc groupId (GRSPendingApproval n') (`updatedNotification` g') | otherwise -> do - setGroupStatus notifyAdminUsers st env cc groupId GRSSuspendedBadRoles $ \_ -> pure () + setGroupStatus notifyAdminUsers env cc groupId GRSSuspendedBadRoles $ \_ -> pure () notifyOwner gr $ "The registration owner is no longer an owner. Registration suspended." Left _ -> logError $ "could not find owner member for " <> groupRef Nothing -> logError $ "no owner member set for " <> groupRef _ -> - setGroupStatus notifyAdminUsers st env cc groupId (GRSPendingApproval n') (`updatedNotification` toGroup) + setGroupStatus notifyAdminUsers env cc groupId (GRSPendingApproval n') (`updatedNotification` toGroup) groupLinkAdded gr byMember = getDuplicateGroup toGroup >>= \case Left e -> notifyOwner gr $ "Error: getDuplicateGroup. Please notify the developers.\n" <> T.pack e Right DGReserved -> notifyOwner gr $ groupAlreadyListed toGroup - _ -> setGroupStatus notifyAdminUsers st env cc groupId (GRSPendingApproval gaId) $ \gr' -> do + _ -> setGroupStatus notifyAdminUsers env cc groupId (GRSPendingApproval gaId) $ \gr' -> do notifyOwner gr' $ ("Thank you! The group link for " <> userGroupReference gr' toGroup <> " is added to the welcome message" <> byMember) <> ".\nYou will be notified once the group is added to the directory - it may take up to 48 hours." @@ -599,16 +598,16 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName let userGroupRef = userGroupReference gr toGroup groupRef = groupReference toGroup groupProfileUpdate >>= \case - GPNoServiceLink -> setGroupStatus notifyAdminUsers st env cc groupId GRSPendingUpdate $ \gr' -> do + GPNoServiceLink -> setGroupStatus notifyAdminUsers env cc groupId GRSPendingUpdate $ \gr' -> do notifyOwner gr' $ ("The group profile is updated for " <> userGroupRef <> byMember <> ", but no link is added to the welcome message.\n\n") <> "The group will remain hidden from the directory until the group link is added and the group is re-approved." - GPServiceLinkRemoved -> setGroupStatus notifyAdminUsers st env cc groupId GRSPendingUpdate $ \gr' -> do + GPServiceLinkRemoved -> setGroupStatus notifyAdminUsers env cc groupId GRSPendingUpdate $ \gr' -> do notifyOwner gr' $ ("The group link for " <> userGroupRef <> " is removed from the welcome message" <> byMember) <> ".\n\nThe group is hidden from the directory until the group link is added and the group is re-approved." notifyAdminUsers $ "The group link is removed from " <> groupRef <> ", de-listed." - GPServiceLinkAdded _ -> setGroupStatus notifyAdminUsers st env cc groupId (GRSPendingApproval n') $ \gr' -> do + GPServiceLinkAdded _ -> setGroupStatus notifyAdminUsers env cc groupId (GRSPendingApproval n') $ \gr' -> do notifyOwner gr' $ ("The group link is added to " <> userGroupRef <> byMember) <> "!\nIt is hidden from the directory until approved." @@ -620,7 +619,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName ("The group " <> userGroupRef <> " is updated" <> byMember) <> "!\nThe group is listed in directory." notifyAdminUsers $ "The group " <> groupRef <> " is updated" <> byMember <> " - only link or whitespace changes.\nThe group remained listed in directory." - | otherwise -> setGroupStatus notifyAdminUsers st env cc groupId (GRSPendingApproval n') $ \gr' -> do + | otherwise -> setGroupStatus notifyAdminUsers env cc groupId (GRSPendingApproval n') $ \gr' -> do notifyOwner gr' $ ("The group " <> userGroupRef <> " is updated" <> byMember) <> "!\nIt is hidden from the directory until approved." @@ -839,7 +838,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName when groupUpdated $ reapprove pg gr groupRegStatus g'' when (groupUpdated || summary /= groupSummary g'' || groupDomainVerified g'' /= groupDomainVerified gInfo) $ listingsUpdated env Left (ChatErrorAgent {agentError = SMP _ err}) | linkDeleted err -> - setGroupStatus logError st env cc groupId GRSRemoved $ \gr' -> + setGroupStatus logError env cc groupId GRSRemoved $ \gr' -> notifyOwner gr' "The channel link is no longer valid.\nThe channel is removed from the directory." _ -> pure () where @@ -852,7 +851,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName withDB "checkGroupLink" cc (\db -> withExceptT show $ getGroupMember db (storeCxt cc) user groupId ownerGMId) >>= \case Right GroupMember {memberId, memberPubKey} | any (\GroupLinkOwner {memberId = mId, memberKey} -> memberId == mId && memberPubKey == Just memberKey) owners -> onValid - _ -> setGroupStatus logError st env cc groupId GRSSuspendedBadRoles $ \gr' -> + _ -> setGroupStatus logError env cc groupId GRSSuspendedBadRoles $ \gr' -> notifyOwner gr' "The registration owner is no longer a channel owner.\nThe channel is no longer listed in the directory." Nothing -> onValid reapprove pg gr groupRegStatus g' = do @@ -861,7 +860,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName notifyAdminUsers $ "The " <> gt <> " " <> groupRef <> " profile changed." case groupRegStatus of GRSActive -> - setGroupStatus notifyAdminUsers st env cc groupId (GRSPendingApproval 1) $ \gr' -> do + setGroupStatus notifyAdminUsers env cc groupId (GRSPendingApproval 1) $ \gr' -> do notifyOwner gr' $ "The " <> gt <> " profile has changed.\nIt is hidden from the directory until approved." sendToApprove g' gr' 1 GRSPendingApproval n -> @@ -877,14 +876,14 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName when (ctId `isOwner` gr) $ case groupRegStatus of GRSSuspendedBadRoles | rStatus == GRSOk -> - setGroupStatus notifyAdminUsers st env cc groupId GRSActive $ \gr' -> do + setGroupStatus notifyAdminUsers env cc groupId GRSActive $ \gr' -> do notifyOwner gr' $ uCtRole <> ".\n\nThe group is listed in the directory again." notifyAdminUsers $ "The group " <> groupRef <> " is listed " <> suCtRole GRSPendingApproval gaId | rStatus == GRSOk -> do verifyAndSendToApprove g gr gaId notifyOwner gr $ uCtRole <> ".\n\nThe group is submitted for approval." GRSActive | rStatus /= GRSOk -> - setGroupStatus notifyAdminUsers st env cc groupId GRSSuspendedBadRoles $ \gr' -> do + setGroupStatus notifyAdminUsers env cc groupId GRSSuspendedBadRoles $ \gr' -> do notifyOwner gr' $ uCtRole <> ".\n\nThe group is no longer listed in the directory." notifyAdminUsers $ "The group " <> groupRef <> " is de-listed " <> suCtRole _ -> pure () @@ -903,7 +902,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName case groupRegStatus of GRSSuspendedBadRoles | serviceRole == GRAdmin -> whenContactIsOwner gr $ - setGroupStatus notifyAdminUsers st env cc groupId GRSActive $ \gr' -> do + setGroupStatus notifyAdminUsers env cc groupId GRSActive $ \gr' -> do notifyOwner gr' $ uSrvRole <> ".\n\nThe group is listed in the directory again." notifyAdminUsers $ "The group " <> groupRef <> " is listed " <> suSrvRole GRSPendingApproval gaId | serviceRole == GRAdmin -> @@ -911,7 +910,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName verifyAndSendToApprove g gr gaId notifyOwner gr $ uSrvRole <> ".\n\nThe group is submitted for approval." GRSActive | serviceRole /= GRAdmin -> - setGroupStatus notifyAdminUsers st env cc groupId GRSSuspendedBadRoles $ \gr' -> do + setGroupStatus notifyAdminUsers env cc groupId GRSSuspendedBadRoles $ \gr' -> do notifyOwner gr' $ uSrvRole <> ".\n\nThe group is no longer listed in the directory." notifyAdminUsers $ "The group " <> groupRef <> " is de-listed " <> suSrvRole _ -> pure () @@ -929,7 +928,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName logInfo $ "contact ID " <> tshow ctId <> " removed from group " <> viewGroupName g withGroupReg g "contact removed" $ \gr -> when (ctId `isOwner` gr) $ - setGroupStatus notifyAdminUsers st env cc groupId GRSRemoved $ \gr' -> do + setGroupStatus notifyAdminUsers env cc groupId GRSRemoved $ \gr' -> do notifyOwner gr' $ "You are removed from the " <> gt <> " " <> userGroupReference gr' g <> ".\n\nThe " <> gt <> " is no longer listed in the directory." notifyAdminUsers $ "The " <> gt <> " " <> groupReference g <> " is de-listed (" <> gt <> " owner is removed)." when (isJust pg_) $ leavePublicGroup g @@ -940,7 +939,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName logInfo $ "contact ID " <> tshow ctId <> " left group " <> viewGroupName g withGroupReg g "contact left" $ \gr -> when (ctId `isOwner` gr) $ - setGroupStatus notifyAdminUsers st env cc groupId GRSRemoved $ \gr' -> do + setGroupStatus notifyAdminUsers env cc groupId GRSRemoved $ \gr' -> do notifyOwner gr' $ "You left the " <> gt <> " " <> userGroupReference gr' g <> ".\n\nThe " <> gt <> " is no longer listed in the directory." notifyAdminUsers $ "The " <> gt <> " " <> groupReference g <> " is de-listed (" <> gt <> " owner left)." when (isJust pg_) $ leavePublicGroup g @@ -949,7 +948,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName deServiceRemovedFromGroup g@GroupInfo {groupId, groupProfile = GroupProfile {publicGroup = pg_}} = do let gt = maybe "group" groupTypeStr' pg_ logInfo $ "service removed from group " <> viewGroupName g - setGroupStatus notifyAdminUsers st env cc groupId GRSRemoved $ \gr -> do + setGroupStatus notifyAdminUsers env cc groupId GRSRemoved $ \gr -> do notifyOwner gr $ serviceName <> " is removed from the " <> gt <> " " <> userGroupReference gr g <> ".\n\nThe " <> gt <> " is no longer listed in the directory." notifyAdminUsers $ "The " <> gt <> " " <> groupReference g <> " is de-listed (directory service is removed)." @@ -957,7 +956,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName deGroupDeleted g@GroupInfo {groupId, groupProfile = GroupProfile {publicGroup = pg_}} = do let gt = maybe "group" groupTypeStr' pg_ logInfo $ "group removed " <> viewGroupName g - setGroupStatus notifyAdminUsers st env cc groupId GRSRemoved $ \gr -> do + setGroupStatus notifyAdminUsers env cc groupId GRSRemoved $ \gr -> do notifyOwner gr $ "The " <> gt <> " " <> userGroupReference gr g <> " is deleted.\n\nThe " <> gt <> " is no longer listed in the directory." notifyAdminUsers $ "The " <> gt <> " " <> groupReference g <> " is de-listed (" <> gt <> " is deleted)." @@ -1018,7 +1017,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName sendChatCmd cc (APIPrepareGroup userId ccLink False Nothing groupSLinkData) >>= \case Right (CRNewPreparedChat _ (AChat SCTGroup (Chat (GroupChat gInfo _) _ _))) -> do let gId = groupId' gInfo - addGroupReg notifyAdminUsers st cc user ct gInfo GRSProposed $ \_ -> pure () + addGroupReg notifyAdminUsers cc user ct gInfo GRSProposed $ \_ -> pure () sendChatCmd cc (APIConnectPreparedGroup gId False (Just ownerContact) Nothing) >>= \case Right CRStartedConnectionToGroup {groupInfo = gInfo'} -> withDB "getGroupMember" cc (\db -> withExceptT show $ getGroupMemberByMemberId db (storeCxt cc) user gInfo' mId) >>= \case @@ -1043,7 +1042,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName | contactId' ct `isOwner` gr -> sameOwnerReregistration gr gt | otherwise -> sendMessage cc ct $ "This " <> gt <> " is registered by another owner." Left _ -> - addGroupReg notifyAdminUsers st cc user ct g (GRSPendingApproval 1) $ \gr -> do + addGroupReg notifyAdminUsers cc user ct g (GRSPendingApproval 1) $ \gr -> do void $ setGroupRegOwner cc groupId ownerMember verifyAndSendToApprove g gr 1 | role < GROwner -> sendMessage cc ct $ "You must be the " <> gt <> " owner to register it." @@ -1065,7 +1064,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName GRSRemoved -> pendingApprovalTransition gr gt 1 pendingApprovalTransition gr gt n = do let userGroupRef = userGroupReference gr g - setGroupStatus notifyAdminUsers st env cc groupId (GRSPendingApproval n) $ \gr' -> do + setGroupStatus notifyAdminUsers env cc groupId (GRSPendingApproval n) $ \gr' -> do notifyOwner gr' $ "The " <> gt <> " " <> userGroupRef <> " is submitted for approval.\nIt is hidden from the directory until approved." verifyAndSendToApprove g gr' n @@ -1079,12 +1078,12 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName let GroupMember {memberRole = role} = toMember gt = maybe "group" groupTypeStr' publicGroup in if role >= GROwner - then setGroupStatus notifyAdminUsers st env cc groupId (GRSPendingApproval 1) $ \gr' -> do + then setGroupStatus notifyAdminUsers env cc groupId (GRSPendingApproval 1) $ \gr' -> do notifyOwner gr' $ "Joined the " <> gt <> " " <> displayName <> ". Registration is pending approval — it may take up to 48 hours." notifyOwner gr' $ recommendedSettingsNotice (userGroupRegId gr') verifyAndSendToApprove g gr' 1 else do - setGroupStatus notifyAdminUsers st env cc groupId GRSRemoved $ \_ -> pure () + setGroupStatus notifyAdminUsers env cc groupId GRSRemoved $ \_ -> pure () sendMessage' cc (dbContactId gr) "The signing key does not belong to a current owner. Registration cancelled." deUserCommand :: Contact -> ChatItemId -> DirectoryCmd 'DRUser -> IO () @@ -1159,7 +1158,6 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName let gt = maybe "group" groupTypeStr' pg_ delGroupReg cc dbGroupId >>= \case Right () -> do - logGDelete st dbGroupId sendReply $ (if isAdmin then "The " <> gt <> " " else "Your " <> gt <> " ") <> displayName <> " is deleted from the directory" when (isJust pg_) $ leavePublicGroup g Left e -> sendReply $ "Error deleting " <> gt <> " " <> displayName <> ": " <> T.pack e @@ -1333,7 +1331,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName let grPromoted' | promoted || knownCt `elem` superUsers = fromMaybe promoted promote | otherwise = False - setGroupStatusPromo sendReply st env cc gr GRSActive grPromoted' $ do + setGroupStatusPromo sendReply env cc gr GRSActive grPromoted' $ do let approved = "The " <> gt <> " " <> userGroupReference' gr n <> " is approved" let commands | isPublicGroup_ = "" @@ -1371,7 +1369,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName let groupRef = groupReference' groupId gName withGroupAndReg sendReply groupId gName $ \_ gr -> case groupRegStatus gr of - GRSActive -> setGroupStatus sendReply st env cc groupId GRSSuspended $ \gr' -> do + GRSActive -> setGroupStatus sendReply env cc groupId GRSSuspended $ \gr' -> do let suspended = "The group " <> userGroupReference' gr gName <> " is suspended" notifyOwner gr' $ suspended <> " and hidden from directory. Please contact the administrators." sendReply "Group suspended!" @@ -1381,7 +1379,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName let groupRef = groupReference' groupId gName withGroupAndReg sendReply groupId gName $ \_ gr -> case groupRegStatus gr of - GRSSuspended -> setGroupStatus sendReply st env cc groupId GRSActive $ \gr' -> do + GRSSuspended -> setGroupStatus sendReply env cc groupId GRSActive $ \gr' -> do let groupStr = "The group " <> userGroupReference' gr gName notifyOwner gr' $ groupStr <> " is listed in the directory again!" sendReply "Group listing resumed!" @@ -1452,7 +1450,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName withGroupAndReg sendReply groupId gName $ \_ gr@GroupReg {groupRegStatus, promoted} -> do let notify = sendReply $ "Group promotion " <> (if promote' then "enabled" <> (if groupRegStatus == GRSActive then "." else ", but the group is not listed.") else "disabled.") if promote' /= promoted - then setGroupPromoted sendReply st env cc gr promote' notify + then setGroupPromoted sendReply env cc gr promote' notify else notify DCExecuteCommand cmdStr -> sendChatCmdStr cc cmdStr >>= \case @@ -1510,48 +1508,43 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName msg = maybe (MCText text) (\image -> MCImage {text, image}) image_ in (Nothing, msg) -setGroupStatusPromo :: (Text -> IO ()) -> DirectoryLog -> ServiceState -> ChatController -> GroupReg -> GroupRegStatus -> Bool -> IO () -> IO () -setGroupStatusPromo sendReply st env cc GroupReg {dbGroupId = gId} grStatus' grPromoted' continue = do +setGroupStatusPromo :: (Text -> IO ()) -> ServiceState -> ChatController -> GroupReg -> GroupRegStatus -> Bool -> IO () -> IO () +setGroupStatusPromo sendReply env cc GroupReg {dbGroupId = gId} grStatus' grPromoted' continue = do let status' = grDirectoryStatus grStatus' setGroupStatusPromoStore cc gId grStatus' grPromoted' >>= \case Left e -> sendReply $ "Error updating group " <> tshow gId <> " status: " <> T.pack e Right (status, grPromoted) -> do when ((status == DSListed || status' == DSListed) && (status /= status' || grPromoted /= grPromoted')) $ listingsUpdated env - logGUpdateStatus st gId grStatus' - logGUpdatePromotion st gId grPromoted' continue -addGroupReg :: (Text -> IO ()) -> DirectoryLog -> ChatController -> User -> Contact -> GroupInfo -> GroupRegStatus -> (GroupReg -> IO ()) -> IO () -addGroupReg sendMsg st cc user ct g@GroupInfo {groupId} grStatus continue = +addGroupReg :: (Text -> IO ()) -> ChatController -> User -> Contact -> GroupInfo -> GroupRegStatus -> (GroupReg -> IO ()) -> IO () +addGroupReg sendMsg cc user ct g@GroupInfo {groupId} grStatus continue = addGroupRegStore cc ct g grStatus >>= \case Left e -> sendMsg $ "Error creating group registation for group " <> tshow groupId <> ": " <> T.pack e Right gr -> do - logGCreate st gr let d = toCustomData $ DirectoryGroupData newGroupJoinFilter withDB' "setGroupCustomData" cc (\db -> setGroupCustomData db user g $ Just d) >>= \case Right () -> pure () Left e -> sendMsg $ "Error setting default captcha for group " <> tshow groupId <> ": " <> T.pack e continue gr -setGroupStatus :: (Text -> IO ()) -> DirectoryLog -> ServiceState -> ChatController -> GroupId -> GroupRegStatus -> (GroupReg -> IO ()) -> IO () -setGroupStatus sendMsg st env cc gId grStatus' continue = do +setGroupStatus :: (Text -> IO ()) -> ServiceState -> ChatController -> GroupId -> GroupRegStatus -> (GroupReg -> IO ()) -> IO () +setGroupStatus sendMsg env cc gId grStatus' continue = do let status' = grDirectoryStatus grStatus' setGroupStatusStore cc gId grStatus' >>= \case Left e -> sendMsg $ "Error updating group " <> tshow gId <> " status: " <> T.pack e Right (grStatus, gr) -> do let status = grDirectoryStatus grStatus when ((status == DSListed || status' == DSListed) && status /= status') $ listingsUpdated env - logGUpdateStatus st gId grStatus' continue gr -setGroupPromoted :: (Text -> IO ()) -> DirectoryLog -> ServiceState -> ChatController -> GroupReg -> Bool -> IO () -> IO () -setGroupPromoted sendReply st env cc GroupReg {dbGroupId = gId} grPromoted' continue = +setGroupPromoted :: (Text -> IO ()) -> ServiceState -> ChatController -> GroupReg -> Bool -> IO () -> IO () +setGroupPromoted sendReply env cc GroupReg {dbGroupId = gId} grPromoted' continue = setGroupPromotedStore cc gId grPromoted' >>= \case Left e -> sendReply $ "Error updating group " <> tshow gId <> " status: " <> T.pack e Right (status, grPromoted) -> do when (status == DSListed && grPromoted' /= grPromoted) $ listingsUpdated env - logGUpdatePromotion st gId grPromoted' continue updateGroupListingFiles :: ChatController -> User -> FilePath -> IO () diff --git a/apps/simplex-directory-service/src/Directory/Store.hs b/apps/simplex-directory-service/src/Directory/Store.hs index e3465e64b1..94375eb025 100644 --- a/apps/simplex-directory-service/src/Directory/Store.hs +++ b/apps/simplex-directory-service/src/Directory/Store.hs @@ -11,8 +11,7 @@ {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} module Directory.Store - ( DirectoryLog (..), - GroupReg (..), + ( GroupReg (..), GroupRegStatus (..), UserGroupRegId, GroupApprovalId, @@ -20,9 +19,6 @@ module Directory.Store DirectoryMemberAcceptance (..), DirectoryStatus (..), ProfileCondition (..), - DirectoryLogRecord (..), - openDirectoryLog, - readDirectoryLogData, addGroupRegStore, insertGroupReg, delGroupReg, @@ -55,16 +51,9 @@ module Directory.Store strongJoinFilter, newGroupJoinFilter, groupDBError, - logGCreate, - logGDelete, - logGUpdateOwner, - logGUpdateStatus, - logGUpdatePromotion, ) where -import Control.Applicative ((<|>)) -import Control.Monad import Control.Monad.Except import Control.Monad.IO.Class import Data.Aeson ((.:), (.=)) @@ -72,18 +61,12 @@ import qualified Data.Aeson.KeyMap as JM import qualified Data.Aeson.TH as JQ import qualified Data.Aeson.Types as JT import qualified Data.Attoparsec.ByteString.Char8 as A -import Data.ByteString.Char8 (ByteString) -import qualified Data.ByteString.Char8 as B import Data.Int (Int64) -import Data.List (sortOn) -import Data.Map (Map) -import qualified Data.Map.Strict as M -import Data.Maybe (fromMaybe, isJust) +import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import Data.Time.Clock (UTCTime (..), getCurrentTime) -import Data.Time.Clock.System (systemEpochDay) import Directory.Search import Directory.Util import Simplex.Chat.Controller @@ -99,7 +82,6 @@ import qualified Simplex.Messaging.Agent.Store.DB as DB import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON) import Simplex.Messaging.Util (eitherToMaybe, firstRow, maybeFirstRow', safeDecodeUtf8) -import System.IO (BufferMode (..), Handle, IOMode (..), hSetBuffering, openFile) #if defined(dbPostgres) import Database.PostgreSQL.Simple (Only (..), Query, (:.) (..)) @@ -109,10 +91,6 @@ import Database.SQLite.Simple (Only (..), Query, (:.) (..)) import Database.SQLite.Simple.QQ (sql) #endif -data DirectoryLog = DirectoryLog - { directoryLogFile :: Maybe Handle - } - data GroupReg = GroupReg { dbGroupId :: GroupId, userGroupRegId :: UserGroupRegId, @@ -472,89 +450,6 @@ groupReqQuery = groupInfoQueryFields <> groupRegFields <> groupInfoQueryFrom <> groupRegFields = ", r.group_id, r.user_group_reg_id, r.contact_id, r.owner_member_id, r.group_reg_status, r.group_promoted, r.created_at " groupRegFromCond = " JOIN sx_directory_group_regs r ON r.group_id = g.group_id WHERE g.user_id = ? AND mu.contact_id = ? " -data DirectoryLogRecord - = GRCreate GroupReg - | GRDelete GroupId - | GRUpdateStatus GroupId GroupRegStatus - | GRUpdatePromotion GroupId Bool - | GRUpdateOwner GroupId GroupMemberId - -data DLRTag - = GRCreate_ - | GRDelete_ - | GRUpdateStatus_ - | GRUpdatePromotion_ - | GRUpdateOwner_ - -logDLR :: DirectoryLog -> DirectoryLogRecord -> IO () -logDLR st r = forM_ (directoryLogFile st) $ \h -> B.hPutStrLn h (strEncode r) - -logGCreate :: DirectoryLog -> GroupReg -> IO () -logGCreate st = logDLR st . GRCreate - -logGDelete :: DirectoryLog -> GroupId -> IO () -logGDelete st = logDLR st . GRDelete - -logGUpdateStatus :: DirectoryLog -> GroupId -> GroupRegStatus -> IO () -logGUpdateStatus st gId = logDLR st . GRUpdateStatus gId - -logGUpdatePromotion :: DirectoryLog -> GroupId -> Bool -> IO () -logGUpdatePromotion st gId = logDLR st . GRUpdatePromotion gId - -logGUpdateOwner :: DirectoryLog -> GroupId -> GroupMemberId -> IO () -logGUpdateOwner st gId = logDLR st . GRUpdateOwner gId - -instance StrEncoding DLRTag where - strEncode = \case - GRCreate_ -> "GCREATE" - GRDelete_ -> "GDELETE" - GRUpdateStatus_ -> "GSTATUS" - GRUpdatePromotion_ -> "GPROMOTE" - GRUpdateOwner_ -> "GOWNER" - strP = - A.takeTill (== ' ') >>= \case - "GCREATE" -> pure GRCreate_ - "GDELETE" -> pure GRDelete_ - "GSTATUS" -> pure GRUpdateStatus_ - "GPROMOTE" -> pure GRUpdatePromotion_ - "GOWNER" -> pure GRUpdateOwner_ - _ -> fail "invalid DLRTag" - -instance StrEncoding DirectoryLogRecord where - strEncode = \case - GRCreate gr -> strEncode (GRCreate_, gr) - GRDelete gId -> strEncode (GRDelete_, gId) - GRUpdateStatus gId grStatus -> strEncode (GRUpdateStatus_, gId, grStatus) - GRUpdatePromotion gId promoted -> strEncode (GRUpdatePromotion_, gId, promoted) - GRUpdateOwner gId grOwnerId -> strEncode (GRUpdateOwner_, gId, grOwnerId) - strP = - strP_ >>= \case - GRCreate_ -> GRCreate <$> strP - GRDelete_ -> GRDelete <$> strP - GRUpdateStatus_ -> GRUpdateStatus <$> A.decimal <*> _strP - GRUpdatePromotion_ -> GRUpdatePromotion <$> A.decimal <*> _strP - GRUpdateOwner_ -> GRUpdateOwner <$> A.decimal <* A.space <*> A.decimal - -instance StrEncoding GroupReg where - strEncode GroupReg {dbGroupId, userGroupRegId, dbContactId, dbOwnerMemberId, groupRegStatus, promoted} = - B.unwords $ - [ "group_id=" <> strEncode dbGroupId, - "user_group_id=" <> strEncode userGroupRegId, - "contact_id=" <> strEncode dbContactId, - "owner_member_id=" <> strEncode dbOwnerMemberId, - "status=" <> strEncode groupRegStatus - ] - <> ["promoted=" <> strEncode promoted | promoted] - strP = do - dbGroupId <- "group_id=" *> strP_ - userGroupRegId <- "user_group_id=" *> strP_ - dbContactId <- "contact_id=" *> strP_ - dbOwnerMemberId <- "owner_member_id=" *> strP_ - groupRegStatus <- "status=" *> strP - promoted <- (" promoted=" *> strP) <|> pure False - let createdAt = UTCTime systemEpochDay 0 - pure GroupReg {dbGroupId, userGroupRegId, dbContactId, dbOwnerMemberId, groupRegStatus, promoted, createdAt} - instance StrEncoding GroupRegStatus where strEncode = \case GRSPendingConfirmation -> "pending_confirmation" @@ -580,40 +475,3 @@ instance StrEncoding GroupRegStatus where instance ToField GroupRegStatus where toField = toField . safeDecodeUtf8 . strEncode instance FromField GroupRegStatus where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8 - -openDirectoryLog :: Maybe FilePath -> IO DirectoryLog -openDirectoryLog = \case - Just f -> DirectoryLog . Just <$> openLogFile f - Nothing -> pure $ DirectoryLog Nothing - where - openLogFile f = do - h <- openFile f AppendMode - hSetBuffering h LineBuffering - pure h - -readDirectoryLogData :: FilePath -> IO [GroupReg] -readDirectoryLogData f = - sortOn dbGroupId . M.elems - <$> (foldM processDLR M.empty . B.lines =<< B.readFile f) - where - processDLR :: Map GroupId GroupReg -> ByteString -> IO (Map GroupId GroupReg) - processDLR m l = case strDecode l of - Left e -> m <$ putStrLn ("Error parsing log record: " <> e <> ", " <> B.unpack (B.take 80 l)) - Right r -> case r of - GRCreate gr@GroupReg {dbGroupId = gId} -> do - when (isJust $ M.lookup gId m) $ - putStrLn $ - "Warning: duplicate group with ID " <> show gId <> ", group replaced." - pure $ M.insert gId gr m - GRDelete gId -> case M.lookup gId m of - Just _ -> pure $ M.delete gId m - Nothing -> m <$ putStrLn ("Warning: no group with ID " <> show gId <> ", deletion ignored.") - GRUpdateStatus gId groupRegStatus -> case M.lookup gId m of - Just gr -> pure $ M.insert gId gr {groupRegStatus} m - Nothing -> m <$ putStrLn ("Warning: no group with ID " <> show gId <> ", status update ignored.") - GRUpdatePromotion gId promoted -> case M.lookup gId m of - Just gr -> pure $ M.insert gId gr {promoted} m - Nothing -> m <$ putStrLn ("Warning: no group with ID " <> show gId <> ", promotion update ignored.") - GRUpdateOwner gId grOwnerId -> case M.lookup gId m of - Just gr -> pure $ M.insert gId gr {dbOwnerMemberId = Just grOwnerId} m - Nothing -> m <$ putStrLn ("Warning: no group with ID " <> show gId <> ", owner update ignored.") diff --git a/apps/simplex-directory-service/src/Directory/Store/Migrate.hs b/apps/simplex-directory-service/src/Directory/Store/Migrate.hs index d501fbd5c3..1a5c45348a 100644 --- a/apps/simplex-directory-service/src/Directory/Store/Migrate.hs +++ b/apps/simplex-directory-service/src/Directory/Store/Migrate.hs @@ -7,18 +7,15 @@ module Directory.Store.Migrate where -import Control.Concurrent.STM import Control.Monad import Control.Monad.Except import qualified Data.ByteString.Char8 as B import Data.List (find) -import Data.Maybe (fromMaybe) import qualified Data.Text as T -import Directory.Listing import Directory.Options import Directory.Store import Simplex.Chat (createChatDatabase) -import Simplex.Chat.Controller (ChatConfig (..), ChatDatabase (..), mkStoreCxt) +import Simplex.Chat.Controller (ChatConfig (..), ChatDatabase (..)) import Simplex.Chat.Options (CoreChatOpts (..)) import Simplex.Chat.Options.DB import Simplex.Chat.Store.Groups (getHostMember) @@ -30,11 +27,7 @@ import qualified Simplex.Messaging.Agent.Store.DB as DB import Simplex.Messaging.Agent.Store.Interface (closeDBStore, migrateDBSchema) import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationConfirmation (..)) import Simplex.Messaging.Encoding.String -import qualified Simplex.Messaging.TMap as TM -import Simplex.Messaging.Util (whenM) -import System.Directory (doesFileExist, renamePath) import System.Exit (exitFailure) -import System.IO (IOMode (..), withFile) #if defined(dbPostgres) import Directory.Store.Postgres.Migrations @@ -55,66 +48,9 @@ runDirectoryMigrations opts ChatConfig {confirmMigrations} chatStore = DirectoryOpts {coreOptions = CoreChatOpts {dbOptions, yesToUpMigrations}} = opts confirm = if confirmMigrations == MCConsole && yesToUpMigrations then MCYesUp else confirmMigrations -checkDirectoryLog :: DirectoryOpts -> ChatConfig -> IO () -checkDirectoryLog opts cfg = - withDirectoryLog opts $ \logFile -> withChatStore opts $ \st -> do - runDirectoryMigrations opts cfg st - gs <- readDirectoryLogData logFile - withActiveUser st $ \user -> withTransaction st $ \db -> do - mapM_ (verifyGroupRegistration (mkStoreCxt cfg) db user) gs - putStrLn $ show (length gs) <> " group registrations OK" - -importDirectoryLogToDB :: DirectoryOpts -> ChatConfig -> IO () -importDirectoryLogToDB opts cfg = do - withDirectoryLog opts $ \logFile -> withChatStore opts $ \st -> do - runDirectoryMigrations opts cfg st - gs <- readDirectoryLogData logFile - ctRegs <- TM.emptyIO - withActiveUser st $ \user -> withTransaction st $ \db -> do - forM_ gs $ \gr -> - whenM (verifyGroupRegistration (mkStoreCxt cfg) db user gr) $ do - putStrLn $ "importing group " <> show (dbGroupId gr) - insertGroupReg db =<< fixUserGroupRegId ctRegs gr - renamePath logFile (logFile ++ ".bak") - putStrLn $ show (length gs) <> " group registrations imported" - where - fixUserGroupRegId ctRegs gr@GroupReg {dbGroupId, dbContactId} = do - ugIds <- fromMaybe [] <$> TM.lookupIO dbContactId ctRegs - gr' <- - if userGroupRegId gr `elem` ugIds - then do - let ugId = maximum ugIds + 1 - putStrLn $ "Warning: updating userGroupRegId for group " <> show dbGroupId <> ", contact " <> show dbContactId - pure gr {userGroupRegId = ugId} - else pure gr - atomically $ TM.insert dbContactId (userGroupRegId gr' : ugIds) ctRegs - pure gr' - exit :: String -> IO a exit err = putStrLn ("Error: " <> err) >> exitFailure -exportDBToDirectoryLog :: DirectoryOpts -> ChatConfig -> IO () -exportDBToDirectoryLog opts cfg = - withDirectoryLog opts $ \logFile -> withChatStore opts $ \st -> do - whenM (doesFileExist logFile) $ exit $ "directory log file " ++ logFile ++ " already exists" - runDirectoryMigrations opts cfg st - withActiveUser st $ \user -> do - gs <- withFile logFile WriteMode $ \h -> withTransaction st $ \db -> do - gs <- getAllGroupRegs_ db (mkStoreCxt cfg) user - forM_ gs $ \(_, gr) -> - whenM (verifyGroupRegistration (mkStoreCxt cfg) db user gr) $ - B.hPutStrLn h $ strEncode $ GRCreate gr - pure gs - putStrLn $ show (length gs) <> " group registrations exported" - -saveGroupListingFiles :: DirectoryOpts -> ChatConfig -> IO () -saveGroupListingFiles opts cfg = case webFolder opts of - Nothing -> exit "use --web-folder to generate listings" - Just dir -> - withChatStore opts $ \st -> withActiveUser st $ \user -> - withTransaction st $ \db -> - getAllListedGroups_ db (mkStoreCxt cfg) user >>= generateListing dir - verifyGroupRegistration :: StoreCxt -> DB.Connection -> User -> GroupReg -> IO Bool verifyGroupRegistration cxt db user GroupReg {dbGroupId = gId, dbContactId = ctId, dbOwnerMemberId, groupRegStatus} = runExceptT (getGroupInfo db cxt user gId) >>= \case @@ -129,10 +65,6 @@ verifyGroupRegistration cxt db user GroupReg {dbGroupId = gId, dbContactId = ctI | mId /= mId' -> False <$ putStrLn ("Error: different host member ID of " <> groupRef <> " (skipping): " <> show mId') | otherwise -> True <$ unless (Just ctId == ctId') (putStrLn $ "Warning: bad group " <> groupRef <> " contact ID: " <> show ctId') -withDirectoryLog :: DirectoryOpts -> (FilePath -> IO ()) -> IO () -withDirectoryLog DirectoryOpts {directoryLog} action = - maybe (exit "directory log file not specified") action directoryLog - withChatStore :: DirectoryOpts -> (DBStore -> IO ()) -> IO () withChatStore DirectoryOpts {coreOptions = CoreChatOpts {dbOptions, yesToUpMigrations, migrationBackupPath}} action = createChatDatabase dbOptions migrationConfig >>= \case diff --git a/tests/Bots/DirectoryTests.hs b/tests/Bots/DirectoryTests.hs index 15f713cd1c..ad5fb6c8a4 100644 --- a/tests/Bots/DirectoryTests.hs +++ b/tests/Bots/DirectoryTests.hs @@ -19,9 +19,7 @@ import Directory.Captcha import Directory.Listing import Directory.Options import Directory.Service -import Directory.Store import System.Directory (emptyPermissions, setOwnerExecutable, setOwnerReadable, setOwnerWritable, setPermissions) -import System.IO (hClose) import Simplex.Chat.Bot.KnownContacts import Simplex.Chat.Controller (ChatConfig (..)) import qualified Simplex.Chat.Markdown as MD @@ -136,8 +134,6 @@ mkDirectoryOpts TestParams {tmpPath = ps} superUsers ownersGroup webFolder = profileNameLimit = maxBound, captchaGenerator = Nothing, voiceCaptchaGenerator = Nothing, - directoryLog = Just $ ps "directory_service.log", - migrateDirectoryLog = Nothing, serviceName = "SimpleX Directory", clientService = True, runCLI = False, @@ -1801,11 +1797,10 @@ withDirectoryOwnersGroup ps cfg dsLink createOwnersGroup webFolder test = do test superUser dsLink runDirectory :: ChatConfig -> DirectoryOpts -> IO () -> IO () -runDirectory cfg opts@DirectoryOpts {directoryLog} action = do - st <- openDirectoryLog directoryLog - t <- forkIO $ directoryService st opts cfg +runDirectory cfg opts action = do + t <- forkIO $ directoryService opts cfg threadDelay 500000 - action `finally` (mapM_ hClose (directoryLogFile st) >> killThread t) + action `finally` killThread t registerGroup :: TestCC -> TestCC -> String -> String -> IO () registerGroup su u n fn = registerGroupId su u n fn 1 1