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>
2024-12-17 17:20:21 +01:00 · 2023-08-01 20:54:51 +01:00
parent f0d64a30e9
commit 2b69103055
23 changed files with 1473 additions and 142 deletions
@@ -1,76 +1,11 @@
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-
 module Main where

-import Control.Concurrent (forkIO)
-import Control.Concurrent.Async
-import Control.Concurrent.STM
-import Control.Monad.Reader
-import qualified Data.Text as T
-import Options
-import Simplex.Chat.Bot
-import Simplex.Chat.Controller
+import Broadcast.Bot
+import Broadcast.Options
 import Simplex.Chat.Core
-import Simplex.Chat.Messages
-import Simplex.Chat.Messages.CIContent
-import Simplex.Chat.Options
-import Simplex.Chat.Protocol (MsgContent (..))
 import Simplex.Chat.Terminal (terminalChatConfig)
-import Simplex.Chat.Types
-import System.Directory (getAppUserDataDirectory)

 main :: IO ()
 main = do
  opts <- welcomeGetOpts
  simplexChatCore terminalChatConfig (mkChatOpts opts) Nothing $ broadcastBot opts
-
-welcomeGetOpts :: IO BroadcastBotOpts
-welcomeGetOpts = do
-  appDir <- getAppUserDataDirectory "simplex"
-  opts@BroadcastBotOpts {coreOptions = CoreChatOpts {dbFilePrefix}} <- getBroadcastBotOpts appDir "simplex_status_bot"
-  putStrLn $ "SimpleX Chat Bot v" ++ versionNumber
-  putStrLn $ "db: " <> dbFilePrefix <> "_chat.db, " <> dbFilePrefix <> "_agent.db"
-  pure opts
-
-broadcastBot :: BroadcastBotOpts -> User -> ChatController -> IO ()
-broadcastBot BroadcastBotOpts {publishers, welcomeMessage, prohibitedMessage} _user cc = do
-  initializeBotAddress cc
-  race_ (forever $ void getLine) . forever $ do
-    (_, resp) <- atomically . readTBQueue $ outputQ cc
-    case resp of
-      CRContactConnected _ ct _ -> do
-        contactConnected ct
-        sendMessage cc ct welcomeMessage
-      CRNewChatItem _ (AChatItem _ SMDRcv (DirectChat ct) ci@ChatItem {content = CIRcvMsgContent mc})
-        | publisher `elem` publishers ->
-          if allowContent mc
-            then do
-              sendChatCmd cc "/contacts" >>= \case
-                CRContactsList _ cts -> void . forkIO $ do
-                  let cts' = filter broadcastTo cts
-                  forM_ cts' $ \ct' -> sendComposedMessage cc ct' Nothing mc
-                  sendReply $ "Forwarded to " <> show (length cts') <> " contact(s)"
-                r -> putStrLn $ "Error getting contacts list: " <> show r
-            else sendReply "!1 Message is not supported!"
-        | otherwise -> do
-          sendReply prohibitedMessage
-          deleteMessage cc ct $ chatItemId' ci
-        where
-          sendReply = sendComposedMessage cc ct (Just $ chatItemId' ci) . textMsgContent
-          publisher = Publisher {contactId = contactId' ct, localDisplayName = localDisplayName' ct}
-          allowContent = \case
-            MCText _ -> True
-            MCLink {} -> True
-            MCImage {} -> True
-            _ -> False
-          broadcastTo ct'@Contact {activeConn = conn@Connection {connStatus}} =
-            (connStatus == ConnSndReady || connStatus == ConnReady)
-              && not (connDisabled conn)
-              && contactId' ct' /= contactId' ct
-      _ -> pure ()
-  where
-    contactConnected ct = putStrLn $ T.unpack (localDisplayName' ct) <> " connected"
@@ -0,0 +1,71 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Broadcast.Bot where
+
+import Control.Concurrent (forkIO)
+import Control.Concurrent.Async
+import Control.Concurrent.STM
+import Control.Monad.Reader
+import qualified Data.Text as T
+import Broadcast.Options
+import Simplex.Chat.Bot
+import Simplex.Chat.Bot.KnownContacts
+import Simplex.Chat.Controller
+import Simplex.Chat.Core
+import Simplex.Chat.Messages
+import Simplex.Chat.Messages.CIContent
+import Simplex.Chat.Options
+import Simplex.Chat.Protocol (MsgContent (..))
+import Simplex.Chat.Types
+import System.Directory (getAppUserDataDirectory)
+
+welcomeGetOpts :: IO BroadcastBotOpts
+welcomeGetOpts = do
+  appDir <- getAppUserDataDirectory "simplex"
+  opts@BroadcastBotOpts {coreOptions = CoreChatOpts {dbFilePrefix}} <- getBroadcastBotOpts appDir "simplex_status_bot"
+  putStrLn $ "SimpleX Chat Bot v" ++ versionNumber
+  putStrLn $ "db: " <> dbFilePrefix <> "_chat.db, " <> dbFilePrefix <> "_agent.db"
+  pure opts
+
+broadcastBot :: BroadcastBotOpts -> User -> ChatController -> IO ()
+broadcastBot BroadcastBotOpts {publishers, welcomeMessage, prohibitedMessage} _user cc = do
+  initializeBotAddress cc
+  race_ (forever $ void getLine) . forever $ do
+    (_, resp) <- atomically . readTBQueue $ outputQ cc
+    case resp of
+      CRContactConnected _ ct _ -> do
+        contactConnected ct
+        sendMessage cc ct welcomeMessage
+      CRNewChatItem _ (AChatItem _ SMDRcv (DirectChat ct) ci@ChatItem {content = CIRcvMsgContent mc})
+        | publisher `elem` publishers ->
+          if allowContent mc
+            then do
+              sendChatCmd cc ListContacts >>= \case
+                CRContactsList _ cts -> void . forkIO $ do
+                  let cts' = filter broadcastTo cts
+                  forM_ cts' $ \ct' -> sendComposedMessage cc ct' Nothing mc
+                  sendReply $ "Forwarded to " <> show (length cts') <> " contact(s)"
+                r -> putStrLn $ "Error getting contacts list: " <> show r
+            else sendReply "!1 Message is not supported!"
+        | otherwise -> do
+          sendReply prohibitedMessage
+          deleteMessage cc ct $ chatItemId' ci
+        where
+          sendReply = sendComposedMessage cc ct (Just $ chatItemId' ci) . textMsgContent
+          publisher = KnownContact {contactId = contactId' ct, localDisplayName = localDisplayName' ct}
+          allowContent = \case
+            MCText _ -> True
+            MCLink {} -> True
+            MCImage {} -> True
+            _ -> False
+          broadcastTo ct'@Contact {activeConn = conn@Connection {connStatus}} =
+            (connStatus == ConnSndReady || connStatus == ConnReady)
+              && not (connDisabled conn)
+              && contactId' ct' /= contactId' ct
+      _ -> pure ()
+  where
+    contactConnected ct = putStrLn $ T.unpack (localDisplayName' ct) <> " connected"
@@ -4,48 +4,33 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}

-module Options where
+module Broadcast.Options where

-import qualified Data.Attoparsec.ByteString.Char8 as A
-import Data.Int (Int64)
 import Data.Maybe (fromMaybe)
-import Data.Text (Text)
-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 (ChatOpts (..), CoreChatOpts, coreChatOptsP)
-import Simplex.Messaging.Parsers (parseAll)
-import Simplex.Messaging.Util (safeDecodeUtf8)
-
-data Publisher = Publisher
-  { contactId :: Int64,
-    localDisplayName :: Text
-  }
-  deriving (Eq)

 data BroadcastBotOpts = BroadcastBotOpts
  { coreOptions :: CoreChatOpts,
-    publishers :: [Publisher],
+    publishers :: [KnownContact],
    welcomeMessage :: String,
    prohibitedMessage :: String
  }

-defaultWelcomeMessage :: [Publisher] -> String
-defaultWelcomeMessage ps = "Hello! I am a broadcast bot.\nI broadcast messages to all connected users from " <> publisherNames ps <> "."
+defaultWelcomeMessage :: [KnownContact] -> String
+defaultWelcomeMessage ps = "Hello! I am a broadcast bot.\nI broadcast messages to all connected users from " <> knownContactNames ps <> "."

-defaultProhibitedMessage :: [Publisher] -> String
-defaultProhibitedMessage ps = "Sorry, only these users can broadcast messages: " <> publisherNames ps <> ". Your message is deleted."
-
-publisherNames :: [Publisher] -> String
-publisherNames = T.unpack . T.intercalate ", " . map (("@" <>) . localDisplayName)
+defaultProhibitedMessage :: [KnownContact] -> String
+defaultProhibitedMessage ps = "Sorry, only these users can broadcast messages: " <> knownContactNames ps <> ". Your message is deleted."

 broadcastBotOpts :: FilePath -> FilePath -> Parser BroadcastBotOpts
 broadcastBotOpts appDir defaultDbFileName = do
  coreOptions <- coreChatOptsP appDir defaultDbFileName
  publishers <-
    option
-      parsePublishers
+      parseKnownContacts
      ( long "publishers"
          <> metavar "PUBLISHERS"
          <> help "Comma-separated list of publishers in the format CONTACT_ID:DISPLAY_NAME whose messages will be broadcasted"
@@ -74,17 +59,6 @@ broadcastBotOpts appDir defaultDbFileName = do
        prohibitedMessage = fromMaybe (defaultProhibitedMessage publishers) prohibitedMessage_
      }

-parsePublishers :: ReadM [Publisher]
-parsePublishers = eitherReader $ parseAll publishersP . encodeUtf8 . T.pack
-
-publishersP :: A.Parser [Publisher]
-publishersP = publisherP `A.sepBy1` A.char ','
-  where
-    publisherP = do
-      contactId <- A.decimal <* A.char ':'
-      localDisplayName <- safeDecodeUtf8 <$> A.takeTill (A.inClass ", ")
-      pure Publisher {contactId, localDisplayName}
-
 getBroadcastBotOpts :: FilePath -> FilePath -> IO BroadcastBotOpts
 getBroadcastBotOpts appDir defaultDbFileName =
  execParser $
@@ -28,7 +28,7 @@ main = do
        t <- withTerminal pure
        simplexChatTerminal terminalChatConfig opts t
    else simplexChatCore terminalChatConfig opts Nothing $ \user cc -> do
-      r <- sendChatCmd cc chatCmd
+      r <- sendChatCmdStr cc chatCmd
      ts <- getCurrentTime
      tz <- getCurrentTimeZone
      putStrLn $ serializeChatResponse (Just user) ts tz r
@@ -0,0 +1,15 @@
+{-# LANGUAGE NamedFieldPuns #-}
+
+module Main where
+
+import Directory.Options
+import Directory.Service
+import Directory.Store
+import Simplex.Chat.Core
+import Simplex.Chat.Terminal (terminalChatConfig)
+
+main :: IO ()
+main = do
+  opts@DirectoryOpts {directoryLog} <- welcomeGetOpts
+  st <- getDirectoryStore directoryLog
+  simplexChatCore terminalChatConfig (mkChatOpts opts) Nothing $ directoryService st opts
@@ -0,0 +1,5 @@
+# SimpleX Directory Service
+
+The service is currently a chat bot that allows to register and search for groups.
+
+Superusers are configured via CLI options.
@@ -0,0 +1,139 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE StandaloneDeriving #-}
+
+module Directory.Events where
+
+import Control.Applicative ((<|>))
+import Data.Attoparsec.Text (Parser)
+import qualified Data.Attoparsec.Text as A
+import Data.Text (Text)
+import qualified Data.Text as T
+import Directory.Store
+import Simplex.Chat.Controller
+import Simplex.Chat.Messages
+import Simplex.Chat.Messages.CIContent
+import Simplex.Chat.Protocol (MsgContent (..))
+import Simplex.Chat.Types
+import Data.Char (isSpace)
+import Data.Either (fromRight)
+
+data DirectoryEvent
+  = DEContactConnected Contact
+  | DEGroupInvitation {contact :: Contact, groupInfo :: GroupInfo, fromMemberRole :: GroupMemberRole, memberRole :: GroupMemberRole}
+  | DEServiceJoinedGroup ContactId GroupInfo
+  | DEGroupUpdated {contactId :: ContactId, fromGroup :: GroupInfo, toGroup :: GroupInfo}
+  | DEContactRoleChanged ContactId GroupInfo GroupMemberRole
+  | DEServiceRoleChanged GroupInfo GroupMemberRole
+  | DEContactRemovedFromGroup ContactId GroupInfo
+  | DEContactLeftGroup ContactId GroupInfo
+  | DEServiceRemovedFromGroup GroupInfo
+  | DEGroupDeleted GroupInfo
+  | DEUnsupportedMessage Contact ChatItemId
+  | DEItemEditIgnored Contact
+  | DEItemDeleteIgnored Contact
+  | DEContactCommand Contact ChatItemId ADirectoryCmd
+
+crDirectoryEvent :: ChatResponse -> Maybe DirectoryEvent
+crDirectoryEvent = \case
+  CRContactConnected {contact} -> Just $ DEContactConnected contact
+  CRReceivedGroupInvitation {contact, groupInfo, fromMemberRole, memberRole} -> Just $ DEGroupInvitation {contact, groupInfo, fromMemberRole, memberRole}
+  CRUserJoinedGroup {groupInfo, hostMember} -> (`DEServiceJoinedGroup` groupInfo) <$> memberContactId hostMember
+  CRGroupUpdated {fromGroup, toGroup, member_} -> (\contactId -> DEGroupUpdated {contactId, fromGroup, toGroup}) <$> (memberContactId =<< member_)
+  CRMemberRole {groupInfo, member, toRole} -> (\ctId -> DEContactRoleChanged ctId groupInfo toRole) <$> memberContactId member
+  CRMemberRoleUser {groupInfo, toRole} -> Just $ DEServiceRoleChanged groupInfo toRole
+  CRDeletedMember {groupInfo, deletedMember} -> (`DEContactRemovedFromGroup` groupInfo) <$> memberContactId deletedMember
+  CRLeftMember {groupInfo, member} -> (`DEContactLeftGroup` groupInfo) <$> memberContactId member
+  CRDeletedMemberUser {groupInfo} -> Just $ DEServiceRemovedFromGroup groupInfo
+  CRGroupDeleted {groupInfo} -> Just $ DEGroupDeleted groupInfo
+  CRChatItemUpdated {chatItem = AChatItem _ SMDRcv (DirectChat ct) _} -> Just $ DEItemEditIgnored ct
+  CRChatItemDeleted {deletedChatItem = AChatItem _ SMDRcv (DirectChat ct) _, byUser = False} -> Just $ DEItemDeleteIgnored ct
+  CRNewChatItem {chatItem = AChatItem _ SMDRcv (DirectChat ct) ci@ChatItem {content = CIRcvMsgContent mc, meta = CIMeta {itemLive}}} ->
+    Just $ case (mc, itemLive) of
+      (MCText t, Nothing) -> DEContactCommand ct ciId $ fromRight err $ A.parseOnly directoryCmdP $ T.dropWhileEnd isSpace t
+      _ -> DEUnsupportedMessage ct ciId
+    where
+      ciId = chatItemId' ci
+      err = ADC SDRUser DCUnknownCommand
+  _ -> Nothing
+
+data DirectoryRole = DRUser | DRSuperUser
+
+data SDirectoryRole (r :: DirectoryRole) where
+  SDRUser :: SDirectoryRole 'DRUser
+  SDRSuperUser :: SDirectoryRole 'DRSuperUser
+
+data DirectoryCmdTag (r :: DirectoryRole) where
+  DCHelp_ :: DirectoryCmdTag 'DRUser
+  DCConfirmDuplicateGroup_ :: DirectoryCmdTag 'DRUser
+  DCListUserGroups_ :: DirectoryCmdTag 'DRUser
+  DCDeleteGroup_ :: DirectoryCmdTag 'DRUser
+  DCApproveGroup_ :: DirectoryCmdTag 'DRSuperUser
+  DCRejectGroup_ :: DirectoryCmdTag 'DRSuperUser
+  DCSuspendGroup_ :: DirectoryCmdTag 'DRSuperUser
+  DCResumeGroup_ :: DirectoryCmdTag 'DRSuperUser
+  DCListGroups_ :: DirectoryCmdTag 'DRSuperUser
+
+deriving instance Show (DirectoryCmdTag r)
+
+data ADirectoryCmdTag = forall r. ADCT (SDirectoryRole r) (DirectoryCmdTag r)
+
+data DirectoryCmd (r :: DirectoryRole) where
+  DCHelp :: DirectoryCmd 'DRUser
+  DCSearchGroup :: Text -> DirectoryCmd 'DRUser
+  DCConfirmDuplicateGroup :: UserGroupRegId -> GroupName -> DirectoryCmd 'DRUser
+  DCListUserGroups :: DirectoryCmd 'DRUser
+  DCDeleteGroup :: UserGroupRegId -> GroupName -> DirectoryCmd 'DRUser
+  DCApproveGroup :: {groupId :: GroupId, localDisplayName :: GroupName, groupApprovalId :: GroupApprovalId} -> DirectoryCmd 'DRSuperUser
+  DCRejectGroup :: GroupId -> GroupName -> DirectoryCmd 'DRSuperUser
+  DCSuspendGroup :: GroupId -> GroupName -> DirectoryCmd 'DRSuperUser
+  DCResumeGroup :: GroupId -> GroupName -> DirectoryCmd 'DRSuperUser
+  DCListGroups :: DirectoryCmd 'DRSuperUser
+  DCUnknownCommand :: DirectoryCmd 'DRUser
+  DCCommandError :: DirectoryCmdTag r -> DirectoryCmd r
+
+data ADirectoryCmd = forall r. ADC (SDirectoryRole r) (DirectoryCmd r)
+
+directoryCmdP :: Parser ADirectoryCmd
+directoryCmdP =
+  (A.char '/' *> cmdStrP) <|> (ADC SDRUser . DCSearchGroup <$> A.takeText)
+  where
+    cmdStrP =
+      (tagP >>= \(ADCT u t) -> ADC u <$> (cmdP t <|> pure (DCCommandError t)))
+        <|> pure (ADC SDRUser DCUnknownCommand)
+    tagP = A.takeTill (== ' ') >>= \case
+      "help" -> u DCHelp_
+      "h" -> u DCHelp_
+      "confim" -> u DCConfirmDuplicateGroup_
+      "list" -> u DCListUserGroups_
+      "delete" -> u DCDeleteGroup_
+      "approve" -> su DCApproveGroup_
+      "reject" -> su DCRejectGroup_
+      "suspend" -> su DCSuspendGroup_
+      "resume" -> su DCResumeGroup_
+      "all" -> su DCListGroups_
+      _ -> fail "bad command tag"
+      where
+        u = pure . ADCT SDRUser
+        su = pure . ADCT SDRSuperUser
+    cmdP :: DirectoryCmdTag r -> Parser (DirectoryCmd r)
+    cmdP = \case
+      DCHelp_ -> pure DCHelp
+      DCConfirmDuplicateGroup_ -> gc DCConfirmDuplicateGroup
+      DCListUserGroups_ -> pure DCListUserGroups
+      DCDeleteGroup_ -> gc DCDeleteGroup
+      DCApproveGroup_ -> do
+        (groupId, localDisplayName) <- gc (,)
+        groupApprovalId <- A.space *> A.decimal
+        pure $ DCApproveGroup {groupId, localDisplayName, groupApprovalId}
+      DCRejectGroup_ -> gc DCRejectGroup
+      DCSuspendGroup_ -> gc DCSuspendGroup
+      DCResumeGroup_ -> gc DCResumeGroup
+      DCListGroups_ -> pure DCListGroups
+      where
+        gc f = f <$> (A.space *> A.decimal <* A.char ':') <*> A.takeTill (== ' ')
@@ -0,0 +1,77 @@
+{-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Directory.Options where
+
+import Options.Applicative
+import Simplex.Chat.Bot.KnownContacts
+import Simplex.Chat.Controller (updateStr, versionNumber, versionString)
+import Simplex.Chat.Options (ChatOpts (..), CoreChatOpts, coreChatOptsP)
+
+data DirectoryOpts = DirectoryOpts
+  { coreOptions :: CoreChatOpts,
+    superUsers :: [KnownContact],
+    directoryLog :: FilePath,
+    serviceName :: String
+  }
+
+directoryOpts :: FilePath -> FilePath -> Parser DirectoryOpts
+directoryOpts appDir defaultDbFileName = do
+  coreOptions <- coreChatOptsP appDir defaultDbFileName
+  superUsers <-
+    option
+      parseKnownContacts
+      ( long "super-users"
+          <> metavar "SUPER_USERS"
+          <> help "Comma-separated list of super-users in the format CONTACT_ID:DISPLAY_NAME who will be allowed to manage the directory"
+          <> value []
+      )
+  directoryLog <-
+    strOption
+      ( long "directory-file"
+          <> metavar "DIRECTORY_FILE"
+          <> help "Append only log for directory state"
+      )
+  serviceName <-
+    strOption
+      ( long "service-name"
+          <> metavar "SERVICE_NAME"
+          <> help "The display name of the directory service bot, without *'s and spaces (SimpleX-Directory)"
+          <> value "SimpleX-Directory"
+      )
+  pure
+    DirectoryOpts
+      { coreOptions,
+        superUsers,
+        directoryLog,
+        serviceName
+      }
+
+getDirectoryOpts :: FilePath -> FilePath -> IO DirectoryOpts
+getDirectoryOpts appDir defaultDbFileName =
+  execParser $
+    info
+      (helper <*> versionOption <*> directoryOpts appDir defaultDbFileName)
+      (header versionStr <> fullDesc <> progDesc "Start SimpleX Directory Service with DB_FILE, DIRECTORY_FILE and SUPER_USERS options")
+  where
+    versionStr = versionString versionNumber
+    versionOption = infoOption versionAndUpdate (long "version" <> short 'v' <> help "Show version")
+    versionAndUpdate = versionStr <> "\n" <> updateStr
+
+mkChatOpts :: DirectoryOpts -> ChatOpts
+mkChatOpts DirectoryOpts {coreOptions} =
+  ChatOpts
+    { coreOptions,
+      chatCmd = "",
+      chatCmdDelay = 3,
+      chatServerPort = Nothing,
+      optFilesFolder = Nothing,
+      showReactions = False,
+      allowInstantFiles = True,
+      autoAcceptFileSize = 0,
+      muteNotifications = True,
+      maintenance = False
+    }
@@ -0,0 +1,331 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE MultiWayIf #-}
+
+module Directory.Service
+  ( welcomeGetOpts,
+    directoryService,
+  )
+where
+
+import Control.Concurrent (forkIO)
+import Control.Concurrent.Async
+import Control.Concurrent.STM
+import Control.Monad.Reader
+import qualified Data.ByteString.Char8 as B
+import Data.Maybe (fromMaybe)
+import qualified Data.Text as T
+import Directory.Events
+import Directory.Options
+import Directory.Store
+import Simplex.Chat.Bot
+import Simplex.Chat.Bot.KnownContacts
+import Simplex.Chat.Controller
+import Simplex.Chat.Core
+import Simplex.Chat.Messages
+-- import Simplex.Chat.Messages.CIContent
+import Simplex.Chat.Options
+import Simplex.Chat.Protocol (MsgContent (..))
+import Simplex.Chat.Types
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Util (safeDecodeUtf8, tshow)
+import System.Directory (getAppUserDataDirectory)
+
+data GroupProfileUpdate = GPNoServiceLink | GPServiceLinkAdded | GPServiceLinkRemoved | GPHasServiceLink | GPServiceLinkError
+
+welcomeGetOpts :: IO DirectoryOpts
+welcomeGetOpts = do
+  appDir <- getAppUserDataDirectory "simplex"
+  opts@DirectoryOpts {coreOptions = CoreChatOpts {dbFilePrefix}} <- getDirectoryOpts appDir "simplex_directory_service"
+  putStrLn $ "SimpleX Directory Service Bot v" ++ versionNumber
+  putStrLn $ "db: " <> dbFilePrefix <> "_chat.db, " <> dbFilePrefix <> "_agent.db"
+  pure opts
+
+directoryService :: DirectoryStore -> DirectoryOpts -> User -> ChatController -> IO ()
+directoryService st DirectoryOpts {superUsers, serviceName} User {userId} cc = do
+  initializeBotAddress cc
+  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 -> deServiceJoinedGroup ctId g
+      DEGroupUpdated {contactId, fromGroup, toGroup} -> deGroupUpdated contactId fromGroup toGroup
+      DEContactRoleChanged ctId g role -> deContactRoleChanged ctId g 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 aCmd -> case aCmd of
+        ADC SDRUser cmd -> deUserCommand ct ciId cmd
+        ADC SDRSuperUser cmd -> deSuperUserCommand ct ciId cmd
+  where
+    withSuperUsers action = void . forkIO $ forM_ superUsers $ \KnownContact {contactId} -> action contactId
+    notifySuperUsers s = withSuperUsers $ \contactId -> sendMessage' cc contactId s
+    -- withContact ctId GroupInfo {localDisplayName} err action = do
+    --   getContact cc ctId >>= \case
+    --     Just ct -> action ct
+    --     Nothing -> putStrLn $ T.unpack $ "Error: " <> err <> ", group: " <> localDisplayName <> ", can't find contact ID " <> tshow ctId
+    notifyOwner GroupReg {dbContactId} = sendMessage' cc dbContactId
+    ctId `isOwner` GroupReg {dbContactId} = ctId == dbContactId
+    withGroupReg GroupInfo {groupId, localDisplayName} err action = do
+      atomically (getGroupReg st groupId) >>= \case
+        Just gr -> action gr
+        Nothing -> putStrLn $ T.unpack $ "Error: " <> err <> ", group: " <> localDisplayName <> ", can't find group registration ID " <> tshow groupId
+    setGroupInactive GroupReg {groupRegStatus, dbGroupId} grStatus = atomically $ do
+      writeTVar groupRegStatus grStatus
+      unlistGroup st dbGroupId
+
+    groupInfoText GroupProfile {displayName = n, fullName = fn, description = d} =
+      n <> (if n == fn || T.null fn then "" else " (" <> fn <> ")") <> maybe "" ("\nWelcome message:\n" <>) d
+    groupReference GroupInfo {groupId, groupProfile = p'@GroupProfile {displayName}} =
+      "ID " <> show groupId <> " (" <> T.unpack displayName <> ")"
+
+    deContactConnected :: Contact -> IO ()
+    deContactConnected ct = do
+      putStrLn $ T.unpack (localDisplayName' ct) <> " connected"
+      sendMessage cc ct $
+        "Welcome to " <> serviceName <> " service!\n\
+        \Send a search string to find groups or */help* to learn how to add groups to directory.\n\n\
+        \For example, send _privacy_ to find groups about privacy."
+
+    deGroupInvitation :: Contact -> GroupInfo -> GroupMemberRole -> GroupMemberRole -> IO ()
+    deGroupInvitation ct g fromMemberRole memberRole =
+      case badInvitation fromMemberRole memberRole of
+        -- TODO check duplicate group name and ask to confirm
+        Just msg -> sendMessage cc ct msg
+        Nothing -> do
+          let GroupInfo {groupId, groupProfile = GroupProfile {displayName}} = g
+          atomically $ addGroupReg st ct g
+          r <- sendChatCmd cc $ APIJoinGroup groupId
+          sendMessage cc ct $ T.unpack $ case r of
+            CRUserAcceptedGroupSent {} -> "Joining the group #" <> displayName <> "…"
+            _ -> "Error joining group " <> displayName <> ", please re-send the invitation!"
+
+    deServiceJoinedGroup :: ContactId -> GroupInfo -> IO ()
+    deServiceJoinedGroup ctId g =
+      withGroupReg g "joined group" $ \gr ->
+        when (ctId `isOwner` gr) $ do
+          let GroupInfo {groupId, groupProfile = GroupProfile {displayName}} = g
+          notifyOwner gr $ T.unpack $ "Joined the group #" <> displayName <> ", creating the link…"
+          sendChatCmd cc (APICreateGroupLink groupId GRMember) >>= \case
+            CRGroupLinkCreated {connReqContact} -> do
+              setGroupInactive gr GRSPendingUpdate
+              notifyOwner gr
+                "Created the public link to join the group via this directory service that is always online.\n\n\
+                \Please add it to the group welcome message.\n\
+                \For example, add:"
+              notifyOwner gr $ "Link to join the group " <> T.unpack displayName <> ": " <> B.unpack (strEncode connReqContact)
+            CRChatCmdError _ (ChatError e) -> case e of
+              CEGroupUserRole {} -> notifyOwner gr "Failed creating group link, as service is no longer an admin."
+              CEGroupMemberUserRemoved -> notifyOwner gr "Failed creating group link, as service is removed from the group."
+              CEGroupNotJoined _ -> notifyOwner gr $ unexpectedError "group not joined"
+              CEGroupMemberNotActive -> notifyOwner gr $ unexpectedError "service membership is not active"
+              _ -> notifyOwner gr $ unexpectedError "can't create group link"
+            _ -> notifyOwner gr $ unexpectedError "can't create group link"
+
+    deGroupUpdated :: ContactId -> GroupInfo -> GroupInfo -> IO ()
+    deGroupUpdated ctId fromGroup toGroup =
+      unless (sameProfile p p') $ do
+        atomically $ unlistGroup st groupId
+        withGroupReg toGroup "group updated" $ \gr -> do
+          readTVarIO (groupRegStatus gr) >>= \case
+            GRSPendingConfirmation -> pure ()
+            GRSProposed -> pure ()
+            GRSPendingUpdate -> groupProfileUpdate >>= \case
+              GPNoServiceLink ->
+                when (ctId `isOwner` gr) $ notifyOwner gr $ "The profile updated for " <> groupRef <> ", but the group link is not added to the welcome message."
+              GPServiceLinkAdded
+                | ctId `isOwner` gr -> groupLinkAdded gr
+                | otherwise -> notifyOwner gr "The group link is added by another group member, your registration will not be processed.\n\nPlease update the group profile yourself."
+              GPServiceLinkRemoved -> when (ctId `isOwner` gr) $ notifyOwner gr $ "The group link of " <> groupRef <> " is removed from the welcome message, please add it."
+              GPHasServiceLink -> when (ctId `isOwner` gr) $ groupLinkAdded gr
+              GPServiceLinkError -> do
+                when (ctId `isOwner` gr) $ notifyOwner gr $ "Error: " <> serviceName <> " has no group link for " <> groupRef <> ". Please report the error to the developers."
+                putStrLn $ "Error: no group link for " <> groupRef
+            GRSPendingApproval n -> processProfileChange gr $ n + 1
+            GRSActive -> processProfileChange gr 1
+            GRSSuspended -> processProfileChange gr 1
+            GRSRemoved -> pure ()
+      where
+        isInfix l d_ = l `T.isInfixOf` fromMaybe "" d_
+        GroupInfo {groupId, groupProfile = p} = fromGroup
+        GroupInfo {localDisplayName, groupProfile = p'@GroupProfile {image = image'}} = toGroup
+        groupRef = groupReference toGroup
+        sameProfile
+          GroupProfile {displayName = n, fullName = fn, image = i, description = d}
+          GroupProfile {displayName = n', fullName = fn', image = i', description = d'} =
+            n == n' && fn == fn' && i == i' && d == d'
+        groupLinkAdded gr = do
+          notifyOwner gr $ "Thank you! The group link for " <> groupRef <> " is added to the welcome message.\nYou will be notified once the group is added to the directory - it may take up to 24 hours."
+          let gaId = 1
+          setGroupInactive gr $ GRSPendingApproval gaId
+          sendForApproval gr gaId
+        processProfileChange gr n' = groupProfileUpdate >>= \case
+          GPNoServiceLink -> do
+            setGroupInactive gr GRSPendingUpdate
+            notifyOwner gr $ "The group profile is updated " <> groupRef <> ", but no link is added to the welcome message.\n\nThe group will remain hidden from the directory until the group link is added and the group is re-approved."
+          GPServiceLinkRemoved -> do
+            setGroupInactive gr GRSPendingUpdate
+            notifyOwner gr $ "The group link for " <> groupRef <> " is removed from the welcome message.\n\nThe group is hidden from the directory until the group link is added and the group is re-approved."
+            notifySuperUsers $ "The group link is removed from " <> groupRef <> ", de-listed."
+          GPServiceLinkAdded -> do
+            setGroupInactive gr $ GRSPendingApproval n'
+            notifyOwner gr $ "The group link is added to " <> groupRef <> "!\nIt is hidden from the directory until approved."
+            notifySuperUsers $ "The group link is added to " <> groupRef <> "."
+            sendForApproval gr n'
+          GPHasServiceLink -> do
+            setGroupInactive gr $ GRSPendingApproval n'
+            notifyOwner gr $ "The group " <> groupRef <> " is updated!\nIt is hidden from the directory until approved."
+            notifySuperUsers $ "The group " <> groupRef <> " is updated."
+            sendForApproval gr n'
+          GPServiceLinkError -> putStrLn $ "Error: no group link for " <> groupRef <> " pending approval."
+        groupProfileUpdate = profileUpdate <$> sendChatCmd cc (APIGetGroupLink groupId)
+          where
+            profileUpdate = \case
+              CRGroupLink {connReqContact} ->
+                let groupLink = safeDecodeUtf8 $ strEncode connReqContact
+                    hadLinkBefore = groupLink `isInfix` description p
+                    hasLinkNow = groupLink `isInfix` description p'
+                in if
+                      | hadLinkBefore && hasLinkNow -> GPHasServiceLink
+                      | hadLinkBefore -> GPServiceLinkRemoved
+                      | hasLinkNow -> GPServiceLinkAdded
+                      | otherwise -> GPNoServiceLink
+              _ -> GPServiceLinkError
+        sendForApproval GroupReg {dbGroupId, dbContactId} gaId = do
+          ct_ <-  getContact cc dbContactId
+          let text = maybe ("The group ID " <> tshow dbGroupId <> " submitted: ") (\c -> localDisplayName' c <> " submitted the group ID " <> tshow dbGroupId <> ": ") ct_
+                      <> groupInfoText p' <> "\n\nTo approve send:"
+              msg = maybe (MCText text) (\image -> MCImage {text, image}) image'
+          withSuperUsers $ \cId -> do
+            sendComposedMessage' cc cId Nothing msg
+            sendMessage' cc cId $ "/approve " <> show dbGroupId <> ":" <> T.unpack localDisplayName <> " " <> show gaId
+
+    deContactRoleChanged :: ContactId -> GroupInfo -> GroupMemberRole -> IO ()
+    deContactRoleChanged ctId g role = undefined
+
+    deServiceRoleChanged :: GroupInfo -> GroupMemberRole -> IO ()
+    deServiceRoleChanged g role = undefined
+
+    deContactRemovedFromGroup :: ContactId -> GroupInfo -> IO ()
+    deContactRemovedFromGroup ctId g =
+      withGroupReg g "contact removed" $ \gr -> do
+        when (ctId `isOwner` gr) $ do
+          setGroupInactive gr GRSRemoved
+          let groupRef = groupReference g
+          notifyOwner gr $ "You are removed from the group " <> groupRef <> ".\n\nGroup is no longer listed in the directory."
+          notifySuperUsers $ "The group " <> groupRef <> " is de-listed (group owner is removed)."
+
+    deContactLeftGroup :: ContactId -> GroupInfo -> IO ()
+    deContactLeftGroup ctId g =
+      withGroupReg g "contact left" $ \gr -> do
+        when (ctId `isOwner` gr) $ do
+          setGroupInactive gr GRSRemoved
+          let groupRef = groupReference g
+          notifyOwner gr $ "You left the group " <> groupRef <> ".\n\nGroup is no longer listed in the directory."
+          notifySuperUsers $ "The group " <> groupRef <> " is de-listed (group owner left)."
+
+    deServiceRemovedFromGroup :: GroupInfo -> IO ()
+    deServiceRemovedFromGroup g =
+      withGroupReg g "service removed" $ \gr -> do
+        setGroupInactive gr GRSRemoved
+        let groupRef = groupReference g
+        notifyOwner gr $ serviceName <> " is removed from the group " <> groupRef <> ".\n\nGroup is no longer listed in the directory."
+        notifySuperUsers $ "The group " <> groupRef <> " is de-listed (directory service is removed)."
+
+    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\
+          \1. Invite " <> serviceName <> " bot to your group as *admin*.\n\
+          \2. " <> serviceName <> " bot will create a public group link for the new members to join even when you are offline.\n\
+          \3. You will then need to add this link to the group welcome message.\n\
+          \4. Once the link is added, service admins will approve the group (it can take up to 24 hours), and everybody will be able to find it in directory.\n\n\
+          \Start from inviting the bot to your group as admin - it will guide you through the process"
+      DCSearchGroup s -> do
+        sendChatCmd cc (APIListGroups userId Nothing $ Just $ T.unpack s) >>= \case
+          CRGroupsList {groups} ->
+            atomically (filterListedGroups st groups) >>= \case
+              [] -> sendReply "No groups found"
+              gs -> do
+                sendReply $ "Found " <> show (length gs) <> " group(s)"
+                void . forkIO $ forM_ gs $ \GroupInfo {groupProfile = p@GroupProfile {image = image_}} -> do
+                  let text = groupInfoText p
+                      msg = maybe (MCText text) (\image -> MCImage {text, image}) image_
+                  sendComposedMessage cc ct Nothing msg
+          _ -> sendReply "Unexpected error"
+      DCConfirmDuplicateGroup _ugrId _gName -> pure ()
+      DCListUserGroups -> pure ()
+      DCDeleteGroup _ugrId _gName -> pure ()
+      DCUnknownCommand -> sendReply "Unknown command"
+      DCCommandError tag -> sendReply $ "Command error: " <> show tag
+      where
+        sendReply = sendComposedMessage cc ct (Just ciId) . textMsgContent
+
+    deSuperUserCommand :: Contact -> ChatItemId -> DirectoryCmd 'DRSuperUser -> IO ()
+    deSuperUserCommand ct ciId cmd
+      | superUser `elem` superUsers = case cmd of
+        DCApproveGroup {groupId, localDisplayName = n, groupApprovalId} ->
+          atomically (getGroupReg st groupId) >>= \case
+            Nothing -> sendMessage cc ct $ "Group ID " <> show groupId <> " not found"
+            Just GroupReg {dbContactId, groupRegStatus} -> do
+              readTVarIO groupRegStatus >>= \case
+                GRSPendingApproval gaId
+                  | gaId == groupApprovalId -> do
+                    getGroup cc groupId >>= \case
+                      Just GroupInfo {localDisplayName = n'}
+                        | n == n' -> do
+                          atomically $ do
+                            writeTVar groupRegStatus GRSActive
+                            listGroup st groupId
+                          sendReply "Group approved!"
+                          sendMessage' cc dbContactId $ "The group ID " <> show groupId <> " (" <> T.unpack n <> ") is approved and listed in directory!\nPlease note: if you change the group profile it will be hidden from directory until it is re-approved."
+                        | otherwise -> sendReply "Incorrect group name"
+                      Nothing -> pure ()
+                  | otherwise -> sendReply "Incorrect approval code"
+                _ -> sendReply $ "Error: the group ID " <> show groupId <> " (" <> T.unpack n <> ") is not pending approval."
+        DCRejectGroup _gaId _gName -> pure ()
+        DCSuspendGroup _gId _gName -> pure ()
+        DCResumeGroup _gId _gName -> pure ()
+        DCListGroups -> pure ()
+        DCCommandError tag -> sendReply $ "Command error: " <> show tag
+      | otherwise = sendReply "You are not allowed to use this command"
+      where
+        superUser = KnownContact {contactId = contactId' ct, localDisplayName = localDisplayName' ct}
+        sendReply = sendComposedMessage cc ct (Just ciId) . textMsgContent
+
+badInvitation :: GroupMemberRole -> GroupMemberRole -> Maybe String
+badInvitation contactRole serviceRole = case (contactRole, serviceRole) of
+  (GROwner, GRAdmin) -> Nothing
+  (_, GRAdmin) -> Just "You must have a group *owner* role to register the group"
+  (GROwner, _) -> Just "You must grant directory service *admin* role to register the group"
+  _ -> Just "You must have a group *owner* role and you must grant directory service *admin* role to register the group"
+
+getContact :: ChatController -> ContactId -> IO (Maybe Contact)
+getContact cc ctId = resp <$> sendChatCmd cc (APIGetChat (ChatRef CTDirect ctId) (CPLast 0) Nothing)
+  where
+    resp :: ChatResponse -> Maybe Contact
+    resp = \case
+      CRApiChat _ (AChat SCTDirect Chat {chatInfo = DirectChat ct}) -> Just ct
+      _ -> Nothing
+
+getGroup :: ChatController -> GroupId -> IO (Maybe GroupInfo)
+getGroup cc gId = resp <$> sendChatCmd cc (APIGetChat (ChatRef CTGroup gId) (CPLast 0) Nothing)
+  where
+    resp :: ChatResponse -> Maybe GroupInfo
+    resp = \case
+      CRApiChat _ (AChat SCTGroup Chat {chatInfo = GroupChat g}) -> Just g
+      _ -> Nothing
+
+unexpectedError :: String -> String
+unexpectedError err = "Unexpected error: " <> err <> ", please notify the developers."
@@ -0,0 +1,90 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
+
+module Directory.Store where
+
+import Control.Concurrent.STM
+import Data.Int (Int64)
+import Data.Set (Set)
+import Simplex.Chat.Types
+import Data.List (find)
+import qualified Data.Set as S
+
+data DirectoryStore = DirectoryStore
+  { groupRegs :: TVar [GroupReg],
+    listedGroups :: TVar (Set GroupId)
+  }
+
+data GroupReg = GroupReg
+  { userGroupRegId :: UserGroupRegId,
+    dbGroupId :: GroupId,
+    dbContactId :: ContactId,
+    groupRegStatus :: TVar GroupRegStatus
+  }
+
+type GroupRegId = Int64
+
+type UserGroupRegId = Int64
+
+type GroupApprovalId = Int64
+
+data GroupRegStatus
+  = GRSPendingConfirmation
+  | GRSProposed
+  | GRSPendingUpdate
+  | GRSPendingApproval GroupApprovalId
+  | GRSActive
+  | GRSSuspended
+  | GRSRemoved
+
+addGroupReg :: DirectoryStore -> Contact -> GroupInfo -> STM ()
+addGroupReg st ct GroupInfo {groupId} = do
+  groupRegStatus <- newTVar GRSProposed
+  let gr = GroupReg {userGroupRegId = groupId, dbGroupId = groupId, dbContactId = contactId' ct, groupRegStatus}
+  modifyTVar' (groupRegs st) (gr :)
+
+getGroupReg :: DirectoryStore -> GroupRegId -> STM (Maybe GroupReg)
+getGroupReg st gId = find ((gId ==) . dbGroupId) <$> readTVar (groupRegs st)
+
+getUserGroupRegId :: DirectoryStore -> ContactId -> UserGroupRegId -> STM (Maybe GroupReg)
+getUserGroupRegId st ctId ugrId = find (\r -> ctId == dbContactId r && ugrId == userGroupRegId r) <$> readTVar (groupRegs st)
+
+getContactGroupRegs :: DirectoryStore -> ContactId -> STM [GroupReg]
+getContactGroupRegs st ctId = filter ((ctId ==) . dbContactId) <$> readTVar (groupRegs st)
+
+filterListedGroups :: DirectoryStore -> [GroupInfo] -> STM [GroupInfo]
+filterListedGroups st gs = do
+  lgs <- readTVar $ listedGroups st
+  pure $ filter (\GroupInfo {groupId} -> groupId `S.member` lgs) gs
+
+listGroup :: DirectoryStore -> GroupId -> STM ()
+listGroup st gId = modifyTVar' (listedGroups st) $ S.insert gId
+
+unlistGroup :: DirectoryStore -> GroupId -> STM ()
+unlistGroup st gId = modifyTVar' (listedGroups st) $ S.delete gId
+
+data DirectoryLogRecord
+  = CreateGroupReg GroupReg
+  | UpdateGroupRegStatus GroupRegId GroupRegStatus
+
+getDirectoryStore :: FilePath -> IO DirectoryStore
+getDirectoryStore path = do
+  groupRegs <- readDirectoryState path
+  st <- atomically newDirectoryStore
+  atomically $ mapM_ (add st) groupRegs
+  pure st
+  where
+    add :: DirectoryStore -> GroupReg -> STM ()
+    add st gr = modifyTVar' (groupRegs st) (gr :) -- TODO set listedGroups
+
+newDirectoryStore :: STM DirectoryStore
+newDirectoryStore = do
+  groupRegs <- newTVar []
+  listedGroups <- newTVar mempty
+  pure DirectoryStore {groupRegs, listedGroups}
+
+readDirectoryState :: FilePath -> IO [GroupReg]
+readDirectoryState _ = pure []
+
+writeDirectoryState :: FilePath -> [GroupReg] -> IO ()
+writeDirectoryState _ _ = pure ()