diff --git a/apps/simplex-broadcast-bot/Main.hs b/apps/simplex-broadcast-bot/Main.hs index 966971633f..15bb743b56 100644 --- a/apps/simplex-broadcast-bot/Main.hs +++ b/apps/simplex-broadcast-bot/Main.hs @@ -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" diff --git a/apps/simplex-broadcast-bot/src/Broadcast/Bot.hs b/apps/simplex-broadcast-bot/src/Broadcast/Bot.hs new file mode 100644 index 0000000000..3a1be2ae08 --- /dev/null +++ b/apps/simplex-broadcast-bot/src/Broadcast/Bot.hs @@ -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" diff --git a/apps/simplex-broadcast-bot/Options.hs b/apps/simplex-broadcast-bot/src/Broadcast/Options.hs similarity index 69% rename from apps/simplex-broadcast-bot/Options.hs rename to apps/simplex-broadcast-bot/src/Broadcast/Options.hs index 994884760d..76b349a499 100644 --- a/apps/simplex-broadcast-bot/Options.hs +++ b/apps/simplex-broadcast-bot/src/Broadcast/Options.hs @@ -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 $ diff --git a/apps/simplex-chat/Main.hs b/apps/simplex-chat/Main.hs index b16bbd8ee2..8dd02623e2 100644 --- a/apps/simplex-chat/Main.hs +++ b/apps/simplex-chat/Main.hs @@ -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 diff --git a/apps/simplex-directory-service/Main.hs b/apps/simplex-directory-service/Main.hs new file mode 100644 index 0000000000..434e42d851 --- /dev/null +++ b/apps/simplex-directory-service/Main.hs @@ -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 <- restoreDirectoryStore directoryLog + simplexChatCore terminalChatConfig (mkChatOpts opts) Nothing $ directoryService st opts diff --git a/apps/simplex-directory-service/README.md b/apps/simplex-directory-service/README.md new file mode 100644 index 0000000000..b64e018adb --- /dev/null +++ b/apps/simplex-directory-service/README.md @@ -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. diff --git a/apps/simplex-directory-service/src/Directory/Events.hs b/apps/simplex-directory-service/src/Directory/Events.hs new file mode 100644 index 0000000000..8ab6bea805 --- /dev/null +++ b/apps/simplex-directory-service/src/Directory/Events.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Directory.Events + ( DirectoryEvent (..), + DirectoryCmd (..), + ADirectoryCmd (..), + DirectoryRole (..), + SDirectoryRole (..), + crDirectoryEvent, + ) +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 :: ContactId, groupInfo :: GroupInfo, hostMember :: GroupMember} + | DEGroupUpdated {contactId :: ContactId, fromGroup :: GroupInfo, toGroup :: GroupInfo} + | DEContactRoleChanged GroupInfo ContactId GroupMemberRole -- contactId here is the contact whose role changed + | DEServiceRoleChanged GroupInfo GroupMemberRole + | DEContactRemovedFromGroup ContactId GroupInfo + | DEContactLeftGroup ContactId GroupInfo + | DEServiceRemovedFromGroup GroupInfo + | DEGroupDeleted GroupInfo + | DEUnsupportedMessage Contact ChatItemId + | DEItemEditIgnored Contact + | DEItemDeleteIgnored Contact + | DEContactCommand Contact ChatItemId ADirectoryCmd + deriving (Show) + +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} -> (\contactId -> DEServiceJoinedGroup {contactId, groupInfo, hostMember}) <$> memberContactId hostMember + CRGroupUpdated {fromGroup, toGroup, member_} -> (\contactId -> DEGroupUpdated {contactId, fromGroup, toGroup}) <$> (memberContactId =<< member_) + CRMemberRole {groupInfo, member, toRole} + | groupMemberId' member == groupMemberId' (membership groupInfo) -> Just $ DEServiceRoleChanged groupInfo toRole + | otherwise -> (\ctId -> DEContactRoleChanged groupInfo ctId toRole) <$> memberContactId member + 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 + +deriving instance Show (SDirectoryRole r) + +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 + DCListLastGroups_ :: 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, displayName :: GroupName, groupApprovalId :: GroupApprovalId} -> DirectoryCmd 'DRSuperUser + DCRejectGroup :: GroupId -> GroupName -> DirectoryCmd 'DRSuperUser + DCSuspendGroup :: GroupId -> GroupName -> DirectoryCmd 'DRSuperUser + DCResumeGroup :: GroupId -> GroupName -> DirectoryCmd 'DRSuperUser + DCListLastGroups :: Int -> DirectoryCmd 'DRSuperUser + DCUnknownCommand :: DirectoryCmd 'DRUser + DCCommandError :: DirectoryCmdTag r -> DirectoryCmd r + +deriving instance Show (DirectoryCmd r) + +data ADirectoryCmd = forall r. ADC (SDirectoryRole r) (DirectoryCmd r) + +deriving instance Show ADirectoryCmd + +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_ + "confirm" -> u DCConfirmDuplicateGroup_ + "list" -> u DCListUserGroups_ + "delete" -> u DCDeleteGroup_ + "approve" -> su DCApproveGroup_ + "reject" -> su DCRejectGroup_ + "suspend" -> su DCSuspendGroup_ + "resume" -> su DCResumeGroup_ + "last" -> su DCListLastGroups_ + _ -> 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, displayName) <- gc (,) + groupApprovalId <- A.space *> A.decimal + pure $ DCApproveGroup {groupId, displayName, groupApprovalId} + DCRejectGroup_ -> gc DCRejectGroup + DCSuspendGroup_ -> gc DCSuspendGroup + DCResumeGroup_ -> gc DCResumeGroup + DCListLastGroups_ -> DCListLastGroups <$> (A.space *> A.decimal <|> pure 10) + where + gc f = f <$> (A.space *> A.decimal <* A.char ':') <*> A.takeTill (== ' ') diff --git a/apps/simplex-directory-service/src/Directory/Options.hs b/apps/simplex-directory-service/src/Directory/Options.hs new file mode 100644 index 0000000000..1f06afe116 --- /dev/null +++ b/apps/simplex-directory-service/src/Directory/Options.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Directory.Options + ( DirectoryOpts (..), + getDirectoryOpts, + mkChatOpts, + ) +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 :: Maybe FilePath, + serviceName :: String, + testing :: Bool + } + +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" + ) + directoryLog <- + Just <$> + 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, + testing = False + } + +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 + } diff --git a/apps/simplex-directory-service/src/Directory/Service.hs b/apps/simplex-directory-service/src/Directory/Service.hs new file mode 100644 index 0000000000..570aa57817 --- /dev/null +++ b/apps/simplex-directory-service/src/Directory/Service.hs @@ -0,0 +1,539 @@ +{-# 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, maybeToList) +import qualified Data.Set as S +import Data.Text (Text) +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 + +data DuplicateGroup + = DGUnique -- display name or full name is unique + | DGRegistered -- the group with the same names is registered, additional confirmation is required + | DGReserved -- the group with the same names is listed, the registration is not allowed + +data GroupRolesStatus + = GRSOk + | GRSServiceNotAdmin + | GRSContactNotOwner + | GRSBadRoles + deriving (Eq) + +welcomeGetOpts :: IO DirectoryOpts +welcomeGetOpts = do + appDir <- getAppUserDataDirectory "simplex" + opts@DirectoryOpts {coreOptions = CoreChatOpts {dbFilePrefix}, testing} <- getDirectoryOpts appDir "simplex_directory_service" + unless testing $ do + 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, testing} User {userId} cc = do + initializeBotAddress' (not testing) 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 owner -> deServiceJoinedGroup ctId g owner + DEGroupUpdated {contactId, fromGroup, toGroup} -> deGroupUpdated contactId fromGroup toGroup + DEContactRoleChanged g ctId role -> deContactRoleChanged g ctId role + DEServiceRoleChanged g role -> deServiceRoleChanged g role + DEContactRemovedFromGroup ctId g -> deContactRemovedFromGroup ctId g + DEContactLeftGroup ctId g -> deContactLeftGroup ctId g + DEServiceRemovedFromGroup g -> deServiceRemovedFromGroup g + DEGroupDeleted _g -> pure () + DEUnsupportedMessage _ct _ciId -> pure () + DEItemEditIgnored _ct -> pure () + DEItemDeleteIgnored _ct -> pure () + DEContactCommand ct ciId 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 + 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 + groupInfoText GroupProfile {displayName = n, fullName = fn, description = d} = + n <> (if n == fn || T.null fn then "" else " (" <> fn <> ")") <> maybe "" ("\nWelcome message:\n" <>) d + userGroupReference gr GroupInfo {groupProfile = GroupProfile {displayName}} = userGroupReference' gr displayName + userGroupReference' GroupReg {userGroupRegId} displayName = groupReference' userGroupRegId displayName + groupReference GroupInfo {groupId, groupProfile = GroupProfile {displayName}} = groupReference' groupId displayName + groupReference' groupId displayName = "ID " <> show groupId <> " (" <> T.unpack displayName <> ")" + groupAlreadyListed GroupInfo {groupProfile = GroupProfile {displayName, fullName}} = + T.unpack $ "The group " <> displayName <> " (" <> fullName <> ") is already listed in the directory, please choose another name." + + getGroups :: Text -> IO (Maybe [(GroupInfo, GroupSummary)]) + getGroups search = + sendChatCmd cc (APIListGroups userId Nothing $ Just $ T.unpack search) >>= \case + CRGroupsList {groups} -> pure $ Just groups + _ -> pure Nothing + + getDuplicateGroup :: GroupInfo -> IO (Maybe DuplicateGroup) + getDuplicateGroup GroupInfo {groupId, groupProfile = GroupProfile {displayName, fullName}} = + getGroups fullName >>= mapM duplicateGroup + where + sameGroup (GroupInfo {groupId = gId, groupProfile = GroupProfile {displayName = n, fullName = fn}}, _) = + gId /= groupId && n == displayName && fn == fullName + duplicateGroup [] = pure DGUnique + duplicateGroup groups = do + let gs = filter sameGroup groups + if null gs + then pure DGUnique + else do + (lgs, rgs) <- atomically $ (,) <$> readTVar (listedGroups st) <*> readTVar (reservedGroups st) + let reserved = any (\(GroupInfo {groupId = gId}, _) -> gId `S.member` lgs || gId `S.member` rgs) gs + pure $ if reserved then DGReserved else DGRegistered + + processInvitation :: Contact -> GroupInfo -> IO () + processInvitation ct g@GroupInfo {groupId, groupProfile = GroupProfile {displayName}} = do + void $ addGroupReg st ct g GRSProposed + 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!" + + deContactConnected :: Contact -> IO () + deContactConnected ct = do + unless testing $ 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@GroupInfo {groupProfile = GroupProfile {displayName, fullName}} fromMemberRole memberRole = do + case badRolesMsg $ groupRolesStatus fromMemberRole memberRole of + Just msg -> sendMessage cc ct msg + Nothing -> getDuplicateGroup g >>= \case + Just DGUnique -> processInvitation ct g + Just DGRegistered -> askConfirmation + Just DGReserved -> sendMessage cc ct $ groupAlreadyListed g + Nothing -> sendMessage cc ct "Error: getDuplicateGroup. Please notify the developers." + where + askConfirmation = do + ugrId <- addGroupReg st ct g GRSPendingConfirmation + sendMessage cc ct $ T.unpack $ "The group " <> displayName <> " (" <> fullName <> ") is already submitted to the directory.\nTo confirm the registration, please send:" + sendMessage cc ct $ "/confirm " <> show ugrId <> ":" <> T.unpack displayName + + badRolesMsg :: GroupRolesStatus -> Maybe String + badRolesMsg = \case + GRSOk -> Nothing + GRSServiceNotAdmin -> Just "You must have a group *owner* role to register the group" + GRSContactNotOwner -> Just "You must grant directory service *admin* role to register the group" + GRSBadRoles -> Just "You must have a group *owner* role and you must grant directory service *admin* role to register the group" + + getGroupRolesStatus :: GroupInfo -> GroupReg -> IO (Maybe GroupRolesStatus) + getGroupRolesStatus GroupInfo {membership = GroupMember {memberRole = serviceRole}} gr = + rStatus <$$> getGroupMember gr + where + rStatus GroupMember {memberRole} = groupRolesStatus memberRole serviceRole + + groupRolesStatus :: GroupMemberRole -> GroupMemberRole -> GroupRolesStatus + groupRolesStatus contactRole serviceRole = case (contactRole, serviceRole) of + (GROwner, GRAdmin) -> GRSOk + (_, GRAdmin) -> GRSServiceNotAdmin + (GROwner, _) -> GRSContactNotOwner + _ -> GRSBadRoles + + getGroupMember :: GroupReg -> IO (Maybe GroupMember) + getGroupMember GroupReg {dbGroupId, dbOwnerMemberId} = + readTVarIO dbOwnerMemberId + $>>= \mId -> resp <$> sendChatCmd cc (APIGroupMemberInfo dbGroupId mId) + where + resp = \case + CRGroupMemberInfo {member} -> Just member + _ -> Nothing + + deServiceJoinedGroup :: ContactId -> GroupInfo -> GroupMember -> IO () + deServiceJoinedGroup ctId g owner = + withGroupReg g "joined group" $ \gr -> + when (ctId `isOwner` gr) $ do + setGroupRegOwner st gr owner + 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 + setGroupStatus st 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 + withGroupReg toGroup "group updated" $ \gr -> do + let userGroupRef = userGroupReference gr toGroup + readTVarIO (groupRegStatus gr) >>= \case + GRSPendingConfirmation -> pure () + GRSProposed -> pure () + GRSPendingUpdate -> groupProfileUpdate >>= \case + GPNoServiceLink -> + when (ctId `isOwner` gr) $ notifyOwner gr $ "The profile updated for " <> userGroupRef <> ", 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 " <> userGroupRef <> " 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 " <> userGroupRef <> ". Please report the error to the developers." + putStrLn $ "Error: no group link for " <> userGroupRef + GRSPendingApproval n -> processProfileChange gr $ n + 1 + GRSActive -> processProfileChange gr 1 + GRSSuspended -> processProfileChange gr 1 + GRSSuspendedBadRoles -> processProfileChange gr 1 + GRSRemoved -> pure () + where + isInfix l d_ = l `T.isInfixOf` fromMaybe "" d_ + GroupInfo {groupId, groupProfile = p} = fromGroup + GroupInfo {groupProfile = p'} = 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 + getDuplicateGroup toGroup >>= \case + Nothing -> notifyOwner gr "Error: getDuplicateGroup. Please notify the developers." + Just DGReserved -> notifyOwner gr $ groupAlreadyListed toGroup + _ -> do + let gaId = 1 + setGroupStatus st gr $ GRSPendingApproval gaId + notifyOwner gr $ "Thank you! The group link for " <> userGroupReference gr toGroup <> " 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." + checkRolesSendToApprove gr gaId + processProfileChange gr n' = do + setGroupStatus st gr GRSPendingUpdate + let userGroupRef = userGroupReference gr toGroup + groupRef = groupReference toGroup + groupProfileUpdate >>= \case + GPNoServiceLink -> do + notifyOwner gr $ "The group profile is updated " <> userGroupRef <> ", 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 + notifyOwner gr $ "The group link for " <> userGroupRef <> " 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 + setGroupStatus st gr $ GRSPendingApproval n' + notifyOwner gr $ "The group link is added to " <> userGroupRef <> "!\nIt is hidden from the directory until approved." + notifySuperUsers $ "The group link is added to " <> groupRef <> "." + checkRolesSendToApprove gr n' + GPHasServiceLink -> do + setGroupStatus st gr $ GRSPendingApproval n' + notifyOwner gr $ "The group " <> userGroupRef <> " is updated!\nIt is hidden from the directory until approved." + notifySuperUsers $ "The group " <> groupRef <> " is updated." + checkRolesSendToApprove 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 + checkRolesSendToApprove gr gaId = do + (badRolesMsg <$$> getGroupRolesStatus toGroup gr) >>= \case + Nothing -> notifyOwner gr "Error: getGroupRolesStatus. Please notify the developers." + Just (Just msg) -> notifyOwner gr msg + Just Nothing -> sendToApprove toGroup gr gaId + + sendToApprove :: GroupInfo -> GroupReg -> GroupApprovalId -> IO () + sendToApprove GroupInfo {groupProfile = p@GroupProfile {displayName, image = image'}} 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 displayName <> " " <> show gaId + + deContactRoleChanged :: GroupInfo -> ContactId -> GroupMemberRole -> IO () + deContactRoleChanged g@GroupInfo {membership = GroupMember {memberRole = serviceRole}} ctId contactRole = + withGroupReg g "contact role changed" $ \gr -> do + let userGroupRef = userGroupReference gr g + uCtRole = "Your role in the group " <> userGroupRef <> " is changed to " <> ctRole + when (ctId `isOwner` gr) $ do + readTVarIO (groupRegStatus gr) >>= \case + GRSSuspendedBadRoles -> when (rStatus == GRSOk) $ do + setGroupStatus st gr GRSActive + notifyOwner gr $ uCtRole <> ".\n\nThe group is listed in the directory again." + notifySuperUsers $ "The group " <> groupRef <> " is listed " <> suCtRole + GRSPendingApproval gaId -> when (rStatus == GRSOk) $ do + sendToApprove g gr gaId + notifyOwner gr $ uCtRole <> ".\n\nThe group is submitted for approval." + GRSActive -> when (rStatus /= GRSOk) $ do + setGroupStatus st gr GRSSuspendedBadRoles + notifyOwner gr $ uCtRole <> ".\n\nThe group is no longer listed in the directory." + notifySuperUsers $ "The group " <> groupRef <> " is de-listed " <> suCtRole + _ -> pure () + where + rStatus = groupRolesStatus contactRole serviceRole + groupRef = groupReference g + ctRole = "*" <> B.unpack (strEncode contactRole) <> "*" + suCtRole = "(user role is set to " <> ctRole <> ")." + + deServiceRoleChanged :: GroupInfo -> GroupMemberRole -> IO () + deServiceRoleChanged g serviceRole = do + withGroupReg g "service role changed" $ \gr -> do + let userGroupRef = userGroupReference gr g + uSrvRole = serviceName <> " role in the group " <> userGroupRef <> " is changed to " <> srvRole + readTVarIO (groupRegStatus gr) >>= \case + GRSSuspendedBadRoles -> when (serviceRole == GRAdmin) $ + whenContactIsOwner gr $ do + setGroupStatus st gr GRSActive + notifyOwner gr $ uSrvRole <> ".\n\nThe group is listed in the directory again." + notifySuperUsers $ "The group " <> groupRef <> " is listed " <> suSrvRole + GRSPendingApproval gaId -> when (serviceRole == GRAdmin) $ + whenContactIsOwner gr $ do + sendToApprove g gr gaId + notifyOwner gr $ uSrvRole <> ".\n\nThe group is submitted for approval." + GRSActive -> when (serviceRole /= GRAdmin) $ do + setGroupStatus st gr GRSSuspendedBadRoles + notifyOwner gr $ uSrvRole <> ".\n\nThe group is no longer listed in the directory." + notifySuperUsers $ "The group " <> groupRef <> " is de-listed " <> suSrvRole + _ -> pure () + where + groupRef = groupReference g + srvRole = "*" <> B.unpack (strEncode serviceRole) <> "*" + suSrvRole = "(" <> serviceName <> " role is changed to " <> srvRole <> ")." + whenContactIsOwner gr action = + getGroupMember gr >>= + mapM_ (\cm@GroupMember {memberRole} -> when (memberRole == GROwner && memberActive cm) action) + + deContactRemovedFromGroup :: ContactId -> GroupInfo -> IO () + deContactRemovedFromGroup ctId g = + withGroupReg g "contact removed" $ \gr -> do + when (ctId `isOwner` gr) $ do + setGroupStatus st gr GRSRemoved + notifyOwner gr $ "You are removed from the group " <> userGroupReference gr g <> ".\n\nThe group is no longer listed in the directory." + notifySuperUsers $ "The group " <> groupReference g <> " 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 + setGroupStatus st gr GRSRemoved + notifyOwner gr $ "You left the group " <> userGroupReference gr g <> ".\n\nThe group is no longer listed in the directory." + notifySuperUsers $ "The group " <> groupReference g <> " is de-listed (group owner left)." + + deServiceRemovedFromGroup :: GroupInfo -> IO () + deServiceRemovedFromGroup g = + withGroupReg g "service removed" $ \gr -> do + setGroupStatus st gr GRSRemoved + notifyOwner gr $ serviceName <> " is removed from the group " <> userGroupReference gr g <> ".\n\nThe group is no longer listed in the directory." + notifySuperUsers $ "The group " <> groupReference g <> " 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 -> + getGroups s >>= \case + Just groups -> + atomically (filterListedGroups st groups) >>= \case + [] -> sendReply "No groups found" + gs -> do + sendReply $ "Found " <> show (length gs) <> " group(s)" <> if length gs > 10 then ", sending 10." else "" + void . forkIO $ forM_ (take 10 gs) $ + \(GroupInfo {groupProfile = p@GroupProfile {image = image_}}, GroupSummary {currentMembers}) -> do + let membersStr = tshow currentMembers <> " members" + text = groupInfoText p <> "\n" <> membersStr + msg = maybe (MCText text) (\image -> MCImage {text, image}) image_ + sendComposedMessage cc ct Nothing msg + Nothing -> sendReply "Error: getGroups. Please notify the developers." + DCConfirmDuplicateGroup ugrId gName -> + atomically (getUserGroupReg st (contactId' ct) ugrId) >>= \case + Nothing -> sendReply $ "Group ID " <> show ugrId <> " not found" + Just GroupReg {dbGroupId, groupRegStatus} -> do + getGroup cc dbGroupId >>= \case + Nothing -> sendReply $ "Group ID " <> show ugrId <> " not found" + Just g@GroupInfo {groupProfile = GroupProfile {displayName}} + | displayName == gName -> + readTVarIO groupRegStatus >>= \case + GRSPendingConfirmation -> do + getDuplicateGroup g >>= \case + Nothing -> sendMessage cc ct "Error: getDuplicateGroup. Please notify the developers." + Just DGReserved -> sendMessage cc ct $ groupAlreadyListed g + _ -> processInvitation ct g + _ -> sendReply $ "Error: the group ID " <> show ugrId <> " (" <> T.unpack displayName <> ") is not pending confirmation." + | otherwise -> sendReply $ "Group ID " <> show ugrId <> " has the display name " <> T.unpack displayName + DCListUserGroups -> + atomically (getUserGroupRegs st $ contactId' ct) >>= \grs -> do + sendReply $ show (length grs) <> " registered group(s)" + void . forkIO $ forM_ (reverse grs) $ \gr@GroupReg {userGroupRegId} -> + sendGroupInfo ct gr userGroupRegId Nothing + 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, displayName = n, groupApprovalId} -> do + getGroupAndReg groupId n >>= \case + Nothing -> sendReply $ "The group " <> groupRef <> " not found (getGroupAndReg)." + Just (g, gr) -> + readTVarIO (groupRegStatus gr) >>= \case + GRSPendingApproval gaId + | gaId == groupApprovalId -> do + getDuplicateGroup g >>= \case + Nothing -> sendReply "Error: getDuplicateGroup. Please notify the developers." + Just DGReserved -> sendReply $ "The group " <> groupRef <> " is already listed in the directory." + _ -> do + getGroupRolesStatus g gr >>= \case + Just GRSOk -> do + setGroupStatus st gr GRSActive + sendReply "Group approved!" + notifyOwner gr $ "The group " <> userGroupReference' gr 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." + Just GRSServiceNotAdmin -> replyNotApproved serviceNotAdmin + Just GRSContactNotOwner -> replyNotApproved "user is not an owner." + Just GRSBadRoles -> replyNotApproved $ "user is not an owner, " <> serviceNotAdmin + Nothing -> sendReply "Error: getGroupRolesStatus. Please notify the developers." + where + replyNotApproved reason = sendReply $ "Group is not approved: " <> reason + serviceNotAdmin = serviceName <> " is not an admin." + | otherwise -> sendReply "Incorrect approval code" + _ -> sendReply $ "Error: the group " <> groupRef <> " is not pending approval." + where + groupRef = groupReference' groupId n + DCRejectGroup _gaId _gName -> pure () + DCSuspendGroup groupId gName -> do + let groupRef = groupReference' groupId gName + getGroupAndReg groupId gName >>= \case + Nothing -> sendReply $ "The group " <> groupRef <> " not found (getGroupAndReg)." + Just (_, gr) -> + readTVarIO (groupRegStatus gr) >>= \case + GRSActive -> do + setGroupStatus st gr GRSSuspended + notifyOwner gr $ "The group " <> userGroupReference' gr gName <> " is suspended and hidden from directory. Please contact the administrators." + sendReply "Group suspended!" + _ -> sendReply $ "The group " <> groupRef <> " is not active, can't be suspended." + DCResumeGroup groupId gName -> do + let groupRef = groupReference' groupId gName + getGroupAndReg groupId gName >>= \case + Nothing -> sendReply $ "The group " <> groupRef <> " not found (getGroupAndReg)." + Just (_, gr) -> + readTVarIO (groupRegStatus gr) >>= \case + GRSSuspended -> do + setGroupStatus st gr GRSActive + notifyOwner gr $ "The group " <> userGroupReference' gr gName <> " is listed in the directory again!" + sendReply "Group listing resumed!" + _ -> sendReply $ "The group " <> groupRef <> " is not suspended, can't be resumed." + DCListLastGroups count -> + readTVarIO (groupRegs st) >>= \grs -> do + sendReply $ show (length grs) <> " registered group(s)" <> (if length grs > count then ", showing the last " <> show count else "") + void . forkIO $ forM_ (reverse $ take count grs) $ \gr@GroupReg {dbGroupId, dbContactId} -> do + ct_ <- getContact cc dbContactId + let ownerStr = "Owner: " <> maybe "getContact error" localDisplayName' ct_ + sendGroupInfo ct gr dbGroupId $ Just ownerStr + 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 + + getGroupAndReg :: GroupId -> GroupName -> IO (Maybe (GroupInfo, GroupReg)) + getGroupAndReg gId gName = + getGroup cc gId + $>>= \g@GroupInfo {groupProfile = GroupProfile {displayName}} -> + if displayName == gName + then atomically (getGroupReg st gId) + $>>= \gr -> pure $ Just (g, gr) + else pure Nothing + + sendGroupInfo :: Contact -> GroupReg -> GroupId -> Maybe Text -> IO () + sendGroupInfo ct gr@GroupReg {dbGroupId} useGroupId ownerStr_ = do + grStatus <- readTVarIO $ groupRegStatus gr + let statusStr = "Status: " <> groupRegStatusText grStatus + getGroupAndSummary cc dbGroupId >>= \case + Just (GroupInfo {groupProfile = p@GroupProfile {image = image_}}, GroupSummary {currentMembers}) -> do + let membersStr = tshow currentMembers <> " members" + text = T.unlines $ [tshow useGroupId <> ". " <> groupInfoText p] <> maybeToList ownerStr_ <> [membersStr, statusStr] + msg = maybe (MCText text) (\image -> MCImage {text, image}) image_ + sendComposedMessage cc ct Nothing msg + Nothing -> do + let text = T.unlines $ [tshow useGroupId <> ". Error: getGroup. Please notify the developers."] <> maybeToList ownerStr_ <> [statusStr] + sendComposedMessage cc ct Nothing $ MCText text + +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 (APIGroupInfo gId) + where + resp :: ChatResponse -> Maybe GroupInfo + resp = \case + CRGroupInfo {groupInfo} -> Just groupInfo + _ -> Nothing + +getGroupAndSummary :: ChatController -> GroupId -> IO (Maybe (GroupInfo, GroupSummary)) +getGroupAndSummary cc gId = resp <$> sendChatCmd cc (APIGroupInfo gId) + where + resp = \case + CRGroupInfo {groupInfo, groupSummary} -> Just (groupInfo, groupSummary) + _ -> Nothing + +unexpectedError :: String -> String +unexpectedError err = "Unexpected error: " <> err <> ", please notify the developers." diff --git a/apps/simplex-directory-service/src/Directory/Store.hs b/apps/simplex-directory-service/src/Directory/Store.hs new file mode 100644 index 0000000000..5082cab2ce --- /dev/null +++ b/apps/simplex-directory-service/src/Directory/Store.hs @@ -0,0 +1,328 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Directory.Store + ( DirectoryStore (..), + GroupReg (..), + GroupRegStatus (..), + UserGroupRegId, + GroupApprovalId, + restoreDirectoryStore, + addGroupReg, + setGroupStatus, + setGroupRegOwner, + getGroupReg, + getUserGroupReg, + getUserGroupRegs, + filterListedGroups, + groupRegStatusText, + ) +where + +import Control.Concurrent.STM +import Control.Monad +import qualified Data.Attoparsec.ByteString.Char8 as A +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.Composition ((.:)) +import Data.Int (Int64) +import Data.List (find, foldl', sortOn) +import Data.Map (Map) +import qualified Data.Map.Strict as M +import Data.Maybe (isJust) +import Data.Set (Set) +import qualified Data.Set as S +import Data.Text (Text) +import Simplex.Chat.Types +import Simplex.Messaging.Encoding.String +import Simplex.Messaging.Util (ifM) +import System.IO (Handle, IOMode (..), openFile, BufferMode (..), hSetBuffering) +import System.Directory (renameFile, doesFileExist) + +data DirectoryStore = DirectoryStore + { groupRegs :: TVar [GroupReg], + listedGroups :: TVar (Set GroupId), + reservedGroups :: TVar (Set GroupId), + directoryLogFile :: Maybe Handle + } + +data GroupReg = GroupReg + { dbGroupId :: GroupId, + userGroupRegId :: UserGroupRegId, + dbContactId :: ContactId, + dbOwnerMemberId :: TVar (Maybe GroupMemberId), + groupRegStatus :: TVar GroupRegStatus + } + +data GroupRegData = GroupRegData + { dbGroupId_ :: GroupId, + userGroupRegId_ :: UserGroupRegId, + dbContactId_ :: ContactId, + dbOwnerMemberId_ :: Maybe GroupMemberId, + groupRegStatus_ :: GroupRegStatus + } + +type UserGroupRegId = Int64 + +type GroupApprovalId = Int64 + +data GroupRegStatus + = GRSPendingConfirmation + | GRSProposed + | GRSPendingUpdate + | GRSPendingApproval GroupApprovalId + | GRSActive + | GRSSuspended + | GRSSuspendedBadRoles + | GRSRemoved + +data DirectoryStatus = DSListed | DSReserved | DSRegistered + +groupRegStatusText :: GroupRegStatus -> Text +groupRegStatusText = \case + GRSPendingConfirmation -> "pending confirmation (duplicate names)" + GRSProposed -> "proposed" + GRSPendingUpdate -> "pending profile update" + GRSPendingApproval _ -> "pending admin approval" + GRSActive -> "active" + GRSSuspended -> "suspended by admin" + GRSSuspendedBadRoles -> "suspended because roles changed" + GRSRemoved -> "removed" + +grDirectoryStatus :: GroupRegStatus -> DirectoryStatus +grDirectoryStatus = \case + GRSActive -> DSListed + GRSSuspended -> DSReserved + GRSSuspendedBadRoles -> DSReserved + _ -> DSRegistered + +addGroupReg :: DirectoryStore -> Contact -> GroupInfo -> GroupRegStatus -> IO UserGroupRegId +addGroupReg st ct GroupInfo {groupId} grStatus = do + grData <- atomically addGroupReg_ + logGCreate st grData + pure $ userGroupRegId_ grData + where + addGroupReg_ = do + let grData = GroupRegData {dbGroupId_ = groupId, userGroupRegId_ = 1, dbContactId_ = ctId, dbOwnerMemberId_ = Nothing, groupRegStatus_ = grStatus} + gr <- dataToGroupReg grData + stateTVar (groupRegs st) $ \grs -> + let ugrId = 1 + foldl' maxUgrId 0 grs + grData' = grData {userGroupRegId_ = ugrId} + gr' = gr {userGroupRegId = ugrId} + in (grData', gr' : grs) + ctId = contactId' ct + maxUgrId mx GroupReg {dbContactId, userGroupRegId} + | dbContactId == ctId && userGroupRegId > mx = userGroupRegId + | otherwise = mx + +setGroupStatus :: DirectoryStore -> GroupReg -> GroupRegStatus -> IO () +setGroupStatus st gr grStatus = do + logGUpdateStatus st (dbGroupId gr) grStatus + atomically $ do + writeTVar (groupRegStatus gr) grStatus + updateListing st $ dbGroupId gr + where + updateListing = case grDirectoryStatus grStatus of + DSListed -> listGroup + DSReserved -> reserveGroup + DSRegistered -> unlistGroup + +setGroupRegOwner :: DirectoryStore -> GroupReg -> GroupMember -> IO () +setGroupRegOwner st gr owner = do + let memberId = groupMemberId' owner + logGUpdateOwner st (dbGroupId gr) memberId + atomically $ writeTVar (dbOwnerMemberId gr) (Just memberId) + +getGroupReg :: DirectoryStore -> GroupId -> STM (Maybe GroupReg) +getGroupReg st gId = find ((gId ==) . dbGroupId) <$> readTVar (groupRegs st) + +getUserGroupReg :: DirectoryStore -> ContactId -> UserGroupRegId -> STM (Maybe GroupReg) +getUserGroupReg st ctId ugrId = find (\r -> ctId == dbContactId r && ugrId == userGroupRegId r) <$> readTVar (groupRegs st) + +getUserGroupRegs :: DirectoryStore -> ContactId -> STM [GroupReg] +getUserGroupRegs st ctId = filter ((ctId ==) . dbContactId) <$> readTVar (groupRegs st) + +filterListedGroups :: DirectoryStore -> [(GroupInfo, GroupSummary)] -> STM [(GroupInfo, GroupSummary)] +filterListedGroups st gs = do + lgs <- readTVar $ listedGroups st + pure $ filter (\(GroupInfo {groupId}, _) -> groupId `S.member` lgs) gs + +listGroup :: DirectoryStore -> GroupId -> STM () +listGroup st gId = do + modifyTVar' (listedGroups st) $ S.insert gId + modifyTVar' (reservedGroups st) $ S.delete gId + +reserveGroup :: DirectoryStore -> GroupId -> STM () +reserveGroup st gId = do + modifyTVar' (listedGroups st) $ S.delete gId + modifyTVar' (reservedGroups st) $ S.insert gId + +unlistGroup :: DirectoryStore -> GroupId -> STM () +unlistGroup st gId = do + modifyTVar' (listedGroups st) $ S.delete gId + modifyTVar' (reservedGroups st) $ S.delete gId + +data DirectoryLogRecord + = GRCreate GroupRegData + | GRUpdateStatus GroupId GroupRegStatus + | GRUpdateOwner GroupId GroupMemberId + +data DLRTag = GRCreate_ | GRUpdateStatus_ | GRUpdateOwner_ + +logDLR :: DirectoryStore -> DirectoryLogRecord -> IO () +logDLR st r = forM_ (directoryLogFile st) $ \h -> B.hPutStrLn h (strEncode r) + +logGCreate :: DirectoryStore -> GroupRegData -> IO () +logGCreate st = logDLR st . GRCreate + +logGUpdateStatus :: DirectoryStore -> GroupId -> GroupRegStatus -> IO () +logGUpdateStatus st = logDLR st .: GRUpdateStatus + +logGUpdateOwner :: DirectoryStore -> GroupId -> GroupMemberId -> IO () +logGUpdateOwner st = logDLR st .: GRUpdateOwner + +instance StrEncoding DLRTag where + strEncode = \case + GRCreate_ -> "GCREATE" + GRUpdateStatus_ -> "GSTATUS" + GRUpdateOwner_ -> "GOWNER" + strP = + A.takeTill (== ' ') >>= \case + "GCREATE" -> pure GRCreate_ + "GSTATUS" -> pure GRUpdateStatus_ + "GOWNER" -> pure GRUpdateOwner_ + _ -> fail "invalid DLRTag" + +instance StrEncoding DirectoryLogRecord where + strEncode = \case + GRCreate gr -> strEncode (GRCreate_, gr) + GRUpdateStatus gId grStatus -> strEncode (GRUpdateStatus_, gId, grStatus) + GRUpdateOwner gId grOwnerId -> strEncode (GRUpdateOwner_, gId, grOwnerId) + strP = + strP >>= \case + GRCreate_ -> GRCreate <$> (A.space *> strP) + GRUpdateStatus_ -> GRUpdateStatus <$> (A.space *> A.decimal) <*> (A.space *> strP) + GRUpdateOwner_ -> GRUpdateOwner <$> (A.space *> A.decimal) <*> (A.space *> A.decimal) + +instance StrEncoding GroupRegData where + strEncode GroupRegData {dbGroupId_, userGroupRegId_, dbContactId_, dbOwnerMemberId_, groupRegStatus_} = + B.unwords + [ "group_id=" <> strEncode dbGroupId_, + "user_group_id=" <> strEncode userGroupRegId_, + "contact_id=" <> strEncode dbContactId_, + "owner_member_id=" <> strEncode dbOwnerMemberId_, + "status=" <> strEncode groupRegStatus_ + ] + strP = do + dbGroupId_ <- "group_id=" *> strP_ + userGroupRegId_ <- "user_group_id=" *> strP_ + dbContactId_ <- "contact_id=" *> strP_ + dbOwnerMemberId_ <- "owner_member_id=" *> strP_ + groupRegStatus_ <- "status=" *> strP + pure GroupRegData {dbGroupId_, userGroupRegId_, dbContactId_, dbOwnerMemberId_, groupRegStatus_} + +instance StrEncoding GroupRegStatus where + strEncode = \case + GRSPendingConfirmation -> "pending_confirmation" + GRSProposed -> "proposed" + GRSPendingUpdate -> "pending_update" + GRSPendingApproval gaId -> "pending_approval:" <> strEncode gaId + GRSActive -> "active" + GRSSuspended -> "suspended" + GRSSuspendedBadRoles -> "suspended_bad_roles" + GRSRemoved -> "removed" + strP = + A.takeTill (\c -> c == ' ' || c == ':') >>= \case + "pending_confirmation" -> pure GRSPendingConfirmation + "proposed" -> pure GRSProposed + "pending_update" -> pure GRSPendingUpdate + "pending_approval" -> GRSPendingApproval <$> (A.char ':' *> A.decimal) + "active" -> pure GRSActive + "suspended" -> pure GRSSuspended + "suspended_bad_roles" -> pure GRSSuspendedBadRoles + "removed" -> pure GRSRemoved + _ -> fail "invalid GroupRegStatus" + +dataToGroupReg :: GroupRegData -> STM GroupReg +dataToGroupReg GroupRegData {dbGroupId_, userGroupRegId_, dbContactId_, dbOwnerMemberId_, groupRegStatus_} = do + dbOwnerMemberId <- newTVar dbOwnerMemberId_ + groupRegStatus <- newTVar groupRegStatus_ + pure + GroupReg + { dbGroupId = dbGroupId_, + userGroupRegId = userGroupRegId_, + dbContactId = dbContactId_, + dbOwnerMemberId, + groupRegStatus + } + +restoreDirectoryStore :: Maybe FilePath -> IO DirectoryStore +restoreDirectoryStore = \case + Just f -> ifM (doesFileExist f) (restore f) (newFile f >>= new . Just) + Nothing -> new Nothing + where + new = atomically . newDirectoryStore + newFile f = do + h <- openFile f WriteMode + hSetBuffering h LineBuffering + pure h + restore f = do + grs <- readDirectoryData f + renameFile f (f <> ".bak") + h <- writeDirectoryData f grs -- compact + atomically $ mkDirectoryStore h grs + +emptyStoreData :: ([GroupReg], Set GroupId, Set GroupId) +emptyStoreData = ([], S.empty, S.empty) + +newDirectoryStore :: Maybe Handle -> STM DirectoryStore +newDirectoryStore = (`mkDirectoryStore_` emptyStoreData) + +mkDirectoryStore :: Handle -> [GroupRegData] -> STM DirectoryStore +mkDirectoryStore h groups = + foldM addGroupRegData emptyStoreData groups >>= mkDirectoryStore_ (Just h) + where + addGroupRegData (!grs, !listed, !reserved) gr@GroupRegData {dbGroupId_ = gId} = do + gr' <- dataToGroupReg gr + let grs' = gr' : grs + pure $ case grDirectoryStatus $ groupRegStatus_ gr of + DSListed -> (grs', S.insert gId listed, reserved) + DSReserved -> (grs', listed, S.insert gId reserved) + DSRegistered -> (grs', listed, reserved) + +mkDirectoryStore_ :: Maybe Handle -> ([GroupReg], Set GroupId, Set GroupId) -> STM DirectoryStore +mkDirectoryStore_ h (grs, listed, reserved) = do + groupRegs <- newTVar grs + listedGroups <- newTVar listed + reservedGroups <- newTVar reserved + pure DirectoryStore {groupRegs, listedGroups, reservedGroups, directoryLogFile = h} + +readDirectoryData :: FilePath -> IO [GroupRegData] +readDirectoryData f = + sortOn dbGroupId_ . M.elems + <$> (foldM processDLR M.empty . B.lines =<< B.readFile f) + where + processDLR :: Map GroupId GroupRegData -> ByteString -> IO (Map GroupId GroupRegData) + 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@GroupRegData {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 + 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.") + 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.") + +writeDirectoryData :: FilePath -> [GroupRegData] -> IO Handle +writeDirectoryData f grs = do + h <- openFile f WriteMode + hSetBuffering h LineBuffering + forM_ grs $ B.hPutStrLn h . strEncode . GRCreate + pure h diff --git a/package.yaml b/package.yaml index 80749cdc03..1d4a88fca6 100644 --- a/package.yaml +++ b/package.yaml @@ -10,6 +10,7 @@ copyright: 2020-22 simplex.chat category: Web, System, Services, Cryptography extra-source-files: - README.md + - cabal.project dependencies: - aeson == 2.0.* @@ -91,8 +92,16 @@ executables: - -threaded simplex-broadcast-bot: - source-dirs: apps/simplex-broadcast-bot - main: Main.hs + source-dirs: apps/simplex-broadcast-bot/src + main: ../Main.hs + dependencies: + - simplex-chat + ghc-options: + - -threaded + + simplex-directory-service: + source-dirs: apps/simplex-directory-service/src + main: ../Main.hs dependencies: - simplex-chat ghc-options: @@ -100,7 +109,10 @@ executables: tests: simplex-chat-test: - source-dirs: tests + source-dirs: + - tests + - apps/simplex-broadcast-bot/src + - apps/simplex-directory-service/src main: Test.hs dependencies: - simplex-chat diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 2c7d84ab75..7945becde1 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -28,6 +28,7 @@ library Simplex.Chat Simplex.Chat.Archive Simplex.Chat.Bot + Simplex.Chat.Bot.KnownContacts Simplex.Chat.Call Simplex.Chat.Controller Simplex.Chat.Core @@ -275,12 +276,13 @@ executable simplex-bot-advanced cpp-options: -DswiftJSON executable simplex-broadcast-bot - main-is: Main.hs + main-is: ../Main.hs other-modules: - Options + Broadcast.Bot + Broadcast.Options Paths_simplex_chat hs-source-dirs: - apps/simplex-broadcast-bot + apps/simplex-broadcast-bot/src ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded build-depends: aeson ==2.0.* @@ -375,10 +377,65 @@ executable simplex-chat if flag(swift) cpp-options: -DswiftJSON +executable simplex-directory-service + main-is: ../Main.hs + other-modules: + Directory.Events + Directory.Options + Directory.Service + Directory.Store + Paths_simplex_chat + hs-source-dirs: + apps/simplex-directory-service/src + ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded + build-depends: + aeson ==2.0.* + , ansi-terminal >=0.10 && <0.12 + , async ==2.2.* + , attoparsec ==0.14.* + , base >=4.7 && <5 + , base64-bytestring >=1.0 && <1.3 + , bytestring ==0.10.* + , composition ==1.0.* + , constraints >=0.12 && <0.14 + , containers ==0.6.* + , cryptonite >=0.27 && <0.30 + , direct-sqlcipher ==2.3.* + , directory ==1.3.* + , email-validate ==2.3.* + , exceptions ==0.10.* + , filepath ==1.4.* + , http-types ==0.12.* + , memory ==0.15.* + , mtl ==2.2.* + , network >=3.1.2.7 && <3.2 + , optparse-applicative >=0.15 && <0.17 + , process ==1.6.* + , random >=1.1 && <1.3 + , record-hasfield ==1.0.* + , simple-logger ==0.1.* + , simplex-chat + , simplexmq >=5.0 + , socks ==0.6.* + , sqlcipher-simple ==0.4.* + , stm ==2.5.* + , template-haskell ==2.16.* + , terminal ==0.2.* + , text ==1.2.* + , time ==1.9.* + , unliftio ==0.2.* + , unliftio-core ==0.2.* + , zip ==1.7.* + default-language: Haskell2010 + if flag(swift) + cpp-options: -DswiftJSON + test-suite simplex-chat-test type: exitcode-stdio-1.0 main-is: Test.hs other-modules: + Bots.BroadcastTests + Bots.DirectoryTests ChatClient ChatTests ChatTests.Direct @@ -392,9 +449,17 @@ test-suite simplex-chat-test SchemaDump ViewTests WebRTCTests + Broadcast.Bot + Broadcast.Options + Directory.Events + Directory.Options + Directory.Service + Directory.Store Paths_simplex_chat hs-source-dirs: tests + apps/simplex-broadcast-bot/src + apps/simplex-directory-service/src ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded build-depends: aeson ==2.0.* diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 79745f198b..7eacbe378c 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -332,7 +332,13 @@ execChatCommand s = do u <- readTVarIO =<< asks currentUser case parseChatCommand s of Left e -> pure $ chatCmdError u e - Right cmd -> either (CRChatCmdError u) id <$> runExceptT (processChatCommand cmd) + Right cmd -> execChatCommand_ u cmd + +execChatCommand' :: ChatMonad' m => ChatCommand -> m ChatResponse +execChatCommand' cmd = asks currentUser >>= readTVarIO >>= (`execChatCommand_` cmd) + +execChatCommand_ :: ChatMonad' m => Maybe User -> ChatCommand -> m ChatResponse +execChatCommand_ u cmd = either (CRChatCmdError u) id <$> runExceptT (processChatCommand cmd) parseChatCommand :: ByteString -> Either String ChatCommand parseChatCommand = A.parseOnly chatCommandP . B.dropWhileEnd isSpace @@ -1138,6 +1144,9 @@ processChatCommand = \case incognitoProfile <- forM customUserProfileId $ \profileId -> withStore (\db -> getProfileById db userId profileId) connectionStats <- withAgent (`getConnectionServers` contactConnId ct) pure $ CRContactInfo user ct connectionStats (fmap fromLocalProfile incognitoProfile) + APIGroupInfo gId -> withUser $ \user -> do + (g, s) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> liftIO (getGroupSummary db user gId) + pure $ CRGroupInfo user g s APIGroupMemberInfo gId gMemberId -> withUser $ \user -> do (g, m) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> getGroupMember db user gId gMemberId connectionStats <- mapM (withAgent . flip getConnectionServers) (memberConnId m) @@ -1224,6 +1233,9 @@ processChatCommand = \case SetShowMessages cName ntfOn -> updateChatSettings cName (\cs -> cs {enableNtfs = ntfOn}) SetSendReceipts cName rcptsOn_ -> updateChatSettings cName (\cs -> cs {sendRcpts = rcptsOn_}) ContactInfo cName -> withContactName cName APIContactInfo + ShowGroupInfo gName -> withUser $ \user -> do + groupId <- withStore $ \db -> getGroupIdByName db user gName + processChatCommand $ APIGroupInfo groupId GroupMemberInfo gName mName -> withMemberName gName mName APIGroupMemberInfo SwitchContact cName -> withContactName cName APISwitchContact SwitchGroupMember gName mName -> withMemberName gName mName APISwitchGroupMember @@ -1486,8 +1498,11 @@ processChatCommand = \case ListMembers gName -> withUser $ \user -> do groupId <- withStore $ \db -> getGroupIdByName db user gName processChatCommand $ APIListMembers groupId - ListGroups -> withUser $ \user -> - CRGroupsList user <$> withStore' (`getUserGroupDetails` user) + APIListGroups userId contactId_ search_ -> withUserId userId $ \user -> + CRGroupsList user <$> withStore' (\db -> getUserGroupsWithSummary db user contactId_ search_) + ListGroups cName_ search_ -> withUser $ \user@User {userId} -> do + ct_ <- forM cName_ $ \cName -> withStore $ \db -> getContactByName db user cName + processChatCommand $ APIListGroups userId (contactId' <$> ct_) search_ APIUpdateGroupProfile groupId p' -> withUser $ \user -> do g <- withStore $ \db -> getGroup db user groupId runUpdateGroupProfile user g p' @@ -1497,6 +1512,8 @@ processChatCommand = \case CRGroupProfile user <$> withStore (\db -> getGroupInfoByName db user gName) UpdateGroupDescription gName description -> updateGroupProfileByName gName $ \p -> p {description} + ShowGroupDescription gName -> withUser $ \user -> + CRGroupDescription user <$> withStore (\db -> getGroupInfoByName db user gName) APICreateGroupLink groupId mRole -> withUser $ \user -> withChatLock "createGroupLink" $ do gInfo <- withStore $ \db -> getGroupInfo db user groupId assertUserGroupRole gInfo GRAdmin @@ -2534,7 +2551,7 @@ expireChatItems user@User {userId} ttl sync = do createdAtCutoff = addUTCTime (-43200 :: NominalDiffTime) currentTs contacts <- withStoreCtx' (Just "expireChatItems, getUserContacts") (`getUserContacts` user) loop contacts $ processContact expirationDate - groups <- withStoreCtx' (Just "expireChatItems, getUserGroupDetails") (`getUserGroupDetails` user) + groups <- withStoreCtx' (Just "expireChatItems, getUserGroupDetails") (\db -> getUserGroupDetails db user Nothing Nothing) loop groups $ processGroup expirationDate createdAtCutoff where loop :: [a] -> (a -> m ()) -> m () @@ -3954,7 +3971,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do ci <- saveRcvChatItem user (CDDirectRcv ct) msg msgMeta content withStore' $ \db -> setGroupInvitationChatItemId db user groupId (chatItemId' ci) toView $ CRNewChatItem user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci) - toView $ CRReceivedGroupInvitation user gInfo ct memRole + toView $ CRReceivedGroupInvitation {user, groupInfo = gInfo, contact = ct, fromMemberRole = fromRole, memberRole = memRole} whenContactNtfs user ct $ showToast ("#" <> localDisplayName <> " " <> c <> "> ") "invited you to join the group" where @@ -4830,13 +4847,13 @@ createInternalChatItem user cd content itemTs_ = do ci <- liftIO $ mkChatItem cd ciId content Nothing Nothing Nothing Nothing False itemTs createdAt toView $ CRNewChatItem user (AChatItem (chatTypeI @c) (msgDirection @d) (toChatInfo cd) ci) -getCreateActiveUser :: SQLiteStore -> IO User -getCreateActiveUser st = do +getCreateActiveUser :: SQLiteStore -> Bool -> IO User +getCreateActiveUser st testView = do user <- withTransaction st getUsers >>= \case [] -> newUser users -> maybe (selectUser users) pure (find activeUser users) - putStrLn $ "Current user: " <> userStr user + unless testView $ putStrLn $ "Current user: " <> userStr user pure user where newUser :: IO User @@ -5081,8 +5098,10 @@ chatCommandP = "/reconnect" $> ReconnectAllServers, "/_settings " *> (APISetChatSettings <$> chatRefP <* A.space <*> jsonP), "/_info #" *> (APIGroupMemberInfo <$> A.decimal <* A.space <*> A.decimal), + "/_info #" *> (APIGroupInfo <$> A.decimal), "/_info @" *> (APIContactInfo <$> A.decimal), ("/info #" <|> "/i #") *> (GroupMemberInfo <$> displayName <* A.space <* char_ '@' <*> displayName), + ("/info #" <|> "/i #") *> (ShowGroupInfo <$> displayName), ("/info " <|> "/i ") *> char_ '@' *> (ContactInfo <$> displayName), "/_switch #" *> (APISwitchGroupMember <$> A.decimal <* A.space <*> A.decimal), "/_switch @" *> (APISwitchContact <$> A.decimal), @@ -5128,11 +5147,15 @@ chatCommandP = "/clear #" *> (ClearGroup <$> displayName), "/clear " *> char_ '@' *> (ClearContact <$> displayName), ("/members " <|> "/ms ") *> char_ '#' *> (ListMembers <$> displayName), - ("/groups" <|> "/gs") $> ListGroups, + "/_groups" *> (APIListGroups <$> A.decimal <*> optional (" @" *> A.decimal) <*> optional (A.space *> stringP)), + ("/groups" <|> "/gs") *> (ListGroups <$> optional (" @" *> displayName) <*> optional (A.space *> stringP)), "/_group_profile #" *> (APIUpdateGroupProfile <$> A.decimal <* A.space <*> jsonP), ("/group_profile " <|> "/gp ") *> char_ '#' *> (UpdateGroupNames <$> displayName <* A.space <*> groupProfile), ("/group_profile " <|> "/gp ") *> char_ '#' *> (ShowGroupProfile <$> displayName), "/group_descr " *> char_ '#' *> (UpdateGroupDescription <$> displayName <*> optional (A.space *> msgTextP)), + "/set welcome " *> char_ '#' *> (UpdateGroupDescription <$> displayName <* A.space <*> (Just <$> msgTextP)), + "/delete welcome " *> char_ '#' *> (UpdateGroupDescription <$> displayName <*> pure Nothing), + "/show welcome " *> char_ '#' *> (ShowGroupDescription <$> displayName), "/_create link #" *> (APICreateGroupLink <$> A.decimal <*> (memberRole <|> pure GRMember)), "/_set link role #" *> (APIGroupLinkMemberRole <$> A.decimal <*> memberRole), "/_delete link #" *> (APIDeleteGroupLink <$> A.decimal), diff --git a/src/Simplex/Chat/Bot.hs b/src/Simplex/Chat/Bot.hs index 05a755fd87..234963b44c 100644 --- a/src/Simplex/Chat/Bot.hs +++ b/src/Simplex/Chat/Bot.hs @@ -9,9 +9,7 @@ module Simplex.Chat.Bot where import Control.Concurrent.Async import Control.Concurrent.STM import Control.Monad.Reader -import qualified Data.Aeson as J import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString.Lazy.Char8 as LB import qualified Data.Text as T import Simplex.Chat.Controller import Simplex.Chat.Core @@ -19,9 +17,8 @@ import Simplex.Chat.Messages import Simplex.Chat.Messages.CIContent import Simplex.Chat.Protocol (MsgContent (..)) import Simplex.Chat.Store -import Simplex.Chat.Types (Contact (..), IsContact (..), User (..)) +import Simplex.Chat.Types (Contact (..), ContactId, IsContact (..), User (..)) import Simplex.Messaging.Encoding.String (strEncode) -import Simplex.Messaging.Util (safeDecodeUtf8) import System.Exit (exitFailure) chatBotRepl :: String -> (Contact -> String -> IO String) -> User -> ChatController -> IO () @@ -32,49 +29,58 @@ chatBotRepl welcome answer _user cc = do case resp of CRContactConnected _ contact _ -> do contactConnected contact - void $ sendMsg contact welcome + void $ sendMessage cc contact welcome CRNewChatItem _ (AChatItem _ SMDRcv (DirectChat contact) ChatItem {content = mc@CIRcvMsgContent {}}) -> do let msg = T.unpack $ ciContentToText mc - void $ sendMsg contact =<< answer contact msg + void $ sendMessage cc contact =<< answer contact msg _ -> pure () where - sendMsg Contact {contactId} msg = sendChatCmd cc $ "/_send @" <> show contactId <> " text " <> msg contactConnected Contact {localDisplayName} = putStrLn $ T.unpack localDisplayName <> " connected" initializeBotAddress :: ChatController -> IO () -initializeBotAddress cc = do - sendChatCmd cc "/show_address" >>= \case +initializeBotAddress = initializeBotAddress' True + +initializeBotAddress' :: Bool -> ChatController -> IO () +initializeBotAddress' logAddress cc = do + sendChatCmd cc ShowMyAddress >>= \case CRUserContactLink _ UserContactLink {connReqContact} -> showBotAddress connReqContact CRChatCmdError _ (ChatErrorStore SEUserContactLinkNotFound) -> do - putStrLn "No bot address, creating..." - sendChatCmd cc "/address" >>= \case + when logAddress $ putStrLn "No bot address, creating..." + sendChatCmd cc CreateMyAddress >>= \case CRUserContactLinkCreated _ uri -> showBotAddress uri _ -> putStrLn "can't create bot address" >> exitFailure _ -> putStrLn "unexpected response" >> exitFailure where showBotAddress uri = do - putStrLn $ "Bot's contact address is: " <> B.unpack (strEncode uri) - void $ sendChatCmd cc "/auto_accept on" + when logAddress $ putStrLn $ "Bot's contact address is: " <> B.unpack (strEncode uri) + void $ sendChatCmd cc $ AddressAutoAccept $ Just AutoAccept {acceptIncognito = False, autoReply = Nothing} sendMessage :: ChatController -> Contact -> String -> IO () sendMessage cc ct = sendComposedMessage cc ct Nothing . textMsgContent +sendMessage' :: ChatController -> ContactId -> String -> IO () +sendMessage' cc ctId = sendComposedMessage' cc ctId Nothing . textMsgContent + sendComposedMessage :: ChatController -> Contact -> Maybe ChatItemId -> MsgContent -> IO () -sendComposedMessage cc ct quotedItemId msgContent = do +sendComposedMessage cc = sendComposedMessage' cc . contactId' + +sendComposedMessage' :: ChatController -> ContactId -> Maybe ChatItemId -> MsgContent -> IO () +sendComposedMessage' cc ctId quotedItemId msgContent = do let cm = ComposedMessage {filePath = Nothing, quotedItemId, msgContent} - sendChatCmd cc ("/_send @" <> show (contactId' ct) <> " json " <> jsonEncode cm) >>= \case - CRNewChatItem {} -> printLog cc CLLInfo $ "sent message to " <> contactInfo ct + sendChatCmd cc (APISendMessage (ChatRef CTDirect ctId) False Nothing cm) >>= \case + CRNewChatItem {} -> printLog cc CLLInfo $ "sent message to contact ID " <> show ctId r -> putStrLn $ "unexpected send message response: " <> show r - where - jsonEncode = T.unpack . safeDecodeUtf8 . LB.toStrict . J.encode deleteMessage :: ChatController -> Contact -> ChatItemId -> IO () deleteMessage cc ct chatItemId = do - let cmd = "/_delete item @" <> show (contactId' ct) <> " " <> show chatItemId <> " internal" + let cmd = APIDeleteChatItem (contactRef ct) chatItemId CIDMInternal sendChatCmd cc cmd >>= \case CRChatItemDeleted {} -> printLog cc CLLInfo $ "deleted message from " <> contactInfo ct r -> putStrLn $ "unexpected delete message response: " <> show r +contactRef :: Contact -> ChatRef +contactRef = ChatRef CTDirect . contactId' + textMsgContent :: String -> MsgContent textMsgContent = MCText . T.pack diff --git a/src/Simplex/Chat/Bot/KnownContacts.hs b/src/Simplex/Chat/Bot/KnownContacts.hs new file mode 100644 index 0000000000..c079b994a6 --- /dev/null +++ b/src/Simplex/Chat/Bot/KnownContacts.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Simplex.Chat.Bot.KnownContacts where + +import qualified Data.Attoparsec.ByteString.Char8 as A +import Data.Int (Int64) +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) +import qualified Data.Text as T +import Options.Applicative +import Simplex.Messaging.Parsers (parseAll) +import Simplex.Messaging.Util (safeDecodeUtf8) + +data KnownContact = KnownContact + { contactId :: Int64, + localDisplayName :: Text + } + deriving (Eq) + +knownContactNames :: [KnownContact] -> String +knownContactNames = T.unpack . T.intercalate ", " . map (("@" <>) . localDisplayName) + +parseKnownContacts :: ReadM [KnownContact] +parseKnownContacts = eitherReader $ parseAll knownContactsP . encodeUtf8 . T.pack + +knownContactsP :: A.Parser [KnownContact] +knownContactsP = contactP `A.sepBy1` A.char ',' + where + contactP = do + contactId <- A.decimal <* A.char ':' + localDisplayName <- safeDecodeUtf8 <$> A.takeTill (A.inClass ", ") + pure KnownContact {contactId, localDisplayName} diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 90f90fdcb6..4c9c7993f1 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -291,6 +291,7 @@ data ChatCommand | ReconnectAllServers | APISetChatSettings ChatRef ChatSettings | APIContactInfo ContactId + | APIGroupInfo GroupId | APIGroupMemberInfo GroupId GroupMemberId | APISwitchContact ContactId | APISwitchGroupMember GroupId GroupMemberId @@ -307,6 +308,7 @@ data ChatCommand | SetShowMessages ChatName Bool | SetSendReceipts ChatName (Maybe Bool) | ContactInfo ContactName + | ShowGroupInfo GroupName | GroupMemberInfo GroupName ContactName | SwitchContact ContactName | SwitchGroupMember GroupName ContactName @@ -362,10 +364,12 @@ data ChatCommand | DeleteGroup GroupName | ClearGroup GroupName | ListMembers GroupName - | ListGroups -- UserId (not used in UI) + | APIListGroups UserId (Maybe ContactId) (Maybe String) + | ListGroups (Maybe ContactName) (Maybe String) | UpdateGroupNames GroupName GroupProfile | ShowGroupProfile GroupName | UpdateGroupDescription GroupName (Maybe Text) + | ShowGroupDescription GroupName | CreateGroupLink GroupName GroupMemberRole | GroupLinkMemberRole GroupName GroupMemberRole | DeleteGroupLink GroupName @@ -422,6 +426,7 @@ data ChatResponse | CRChatItemTTL {user :: User, chatItemTTL :: Maybe Int64} | CRNetworkConfig {networkConfig :: NetworkConfig} | CRContactInfo {user :: User, contact :: Contact, connectionStats :: ConnectionStats, customUserProfile :: Maybe Profile} + | CRGroupInfo {user :: User, groupInfo :: GroupInfo, groupSummary :: GroupSummary} | CRGroupMemberInfo {user :: User, groupInfo :: GroupInfo, member :: GroupMember, connectionStats_ :: Maybe ConnectionStats} | CRContactSwitchStarted {user :: User, contact :: Contact, connectionStats :: ConnectionStats} | CRGroupMemberSwitchStarted {user :: User, groupInfo :: GroupInfo, member :: GroupMember, connectionStats :: ConnectionStats} @@ -459,7 +464,7 @@ data ChatResponse | CRContactRequestRejected {user :: User, contactRequest :: UserContactRequest} | CRUserAcceptedGroupSent {user :: User, groupInfo :: GroupInfo, hostContact :: Maybe Contact} | CRUserDeletedMember {user :: User, groupInfo :: GroupInfo, member :: GroupMember} - | CRGroupsList {user :: User, groups :: [GroupInfo]} + | CRGroupsList {user :: User, groups :: [(GroupInfo, GroupSummary)]} | CRSentGroupInvitation {user :: User, groupInfo :: GroupInfo, contact :: Contact, member :: GroupMember} | CRFileTransferStatus User (FileTransfer, [Integer]) -- TODO refactor this type to FileTransferStatus | CRFileTransferStatusXFTP User AChatItem @@ -518,7 +523,7 @@ data ChatResponse | CRHostConnected {protocol :: AProtocolType, transportHost :: TransportHost} | CRHostDisconnected {protocol :: AProtocolType, transportHost :: TransportHost} | CRGroupInvitation {user :: User, groupInfo :: GroupInfo} - | CRReceivedGroupInvitation {user :: User, groupInfo :: GroupInfo, contact :: Contact, memberRole :: GroupMemberRole} + | CRReceivedGroupInvitation {user :: User, groupInfo :: GroupInfo, contact :: Contact, fromMemberRole :: GroupMemberRole, memberRole :: GroupMemberRole} | CRUserJoinedGroup {user :: User, groupInfo :: GroupInfo, hostMember :: GroupMember} | CRJoinedGroupMember {user :: User, groupInfo :: GroupInfo, member :: GroupMember} | CRJoinedGroupMemberConnecting {user :: User, groupInfo :: GroupInfo, hostMember :: GroupMember, member :: GroupMember} @@ -533,6 +538,7 @@ data ChatResponse | CRGroupDeleted {user :: User, groupInfo :: GroupInfo, member :: GroupMember} | CRGroupUpdated {user :: User, fromGroup :: GroupInfo, toGroup :: GroupInfo, member_ :: Maybe GroupMember} | CRGroupProfile {user :: User, groupInfo :: GroupInfo} + | CRGroupDescription {user :: User, groupInfo :: GroupInfo} -- only used in CLI | CRGroupLinkCreated {user :: User, groupInfo :: GroupInfo, connReqContact :: ConnReqContact, memberRole :: GroupMemberRole} | CRGroupLink {user :: User, groupInfo :: GroupInfo, connReqContact :: ConnReqContact, memberRole :: GroupMemberRole} | CRGroupLinkDeleted {user :: User, groupInfo :: GroupInfo} diff --git a/src/Simplex/Chat/Core.hs b/src/Simplex/Chat/Core.hs index e23dbc5a96..4af161ab41 100644 --- a/src/Simplex/Chat/Core.hs +++ b/src/Simplex/Chat/Core.hs @@ -15,7 +15,7 @@ import System.Exit (exitFailure) import UnliftIO.Async simplexChatCore :: ChatConfig -> ChatOpts -> Maybe (Notification -> IO ()) -> (User -> ChatController -> IO ()) -> IO () -simplexChatCore cfg@ChatConfig {confirmMigrations} opts@ChatOpts {coreOptions = CoreChatOpts {dbFilePrefix, dbKey, logAgent}} sendToast chat = +simplexChatCore cfg@ChatConfig {confirmMigrations, testView} opts@ChatOpts {coreOptions = CoreChatOpts {dbFilePrefix, dbKey, logAgent}} sendToast chat = case logAgent of Just level -> do setLogLevel level @@ -27,7 +27,7 @@ simplexChatCore cfg@ChatConfig {confirmMigrations} opts@ChatOpts {coreOptions = putStrLn $ "Error opening database: " <> show e exitFailure run db@ChatDatabase {chatStore} = do - u <- getCreateActiveUser chatStore + u <- getCreateActiveUser chatStore testView cc <- newChatController db (Just u) cfg opts sendToast runSimplexChat opts u cc chat @@ -39,5 +39,8 @@ runSimplexChat ChatOpts {maintenance} u cc chat a2 <- async $ chat u cc waitEither_ a1 a2 -sendChatCmd :: ChatController -> String -> IO ChatResponse -sendChatCmd cc s = runReaderT (execChatCommand . encodeUtf8 $ T.pack s) cc +sendChatCmdStr :: ChatController -> String -> IO ChatResponse +sendChatCmdStr cc s = runReaderT (execChatCommand . encodeUtf8 $ T.pack s) cc + +sendChatCmd :: ChatController -> ChatCommand -> IO ChatResponse +sendChatCmd cc cmd = runReaderT (execChatCommand' cmd) cc diff --git a/src/Simplex/Chat/Store/Groups.hs b/src/Simplex/Chat/Store/Groups.hs index c3c62d52da..274d6edc6f 100644 --- a/src/Simplex/Chat/Store/Groups.hs +++ b/src/Simplex/Chat/Store/Groups.hs @@ -45,6 +45,8 @@ module Simplex.Chat.Store.Groups deleteGroup, getUserGroups, getUserGroupDetails, + getUserGroupsWithSummary, + getGroupSummary, getContactGroupPreferences, checkContactHasGroups, getGroupInvitation, @@ -448,8 +450,8 @@ getUserGroups db user@User {userId} = do groupIds <- map fromOnly <$> DB.query db "SELECT group_id FROM groups WHERE user_id = ?" (Only userId) rights <$> mapM (runExceptT . getGroup db user) groupIds -getUserGroupDetails :: DB.Connection -> User -> IO [GroupInfo] -getUserGroupDetails db User {userId, userContactId} = +getUserGroupDetails :: DB.Connection -> User -> Maybe ContactId -> Maybe String -> IO [GroupInfo] +getUserGroupDetails db User {userId, userContactId} _contactId_ search_ = map (toGroupInfo userContactId) <$> DB.query db @@ -462,8 +464,35 @@ getUserGroupDetails db User {userId, userContactId} = JOIN group_members mu USING (group_id) JOIN contact_profiles pu ON pu.contact_profile_id = COALESCE(mu.member_profile_id, mu.contact_profile_id) WHERE g.user_id = ? AND mu.contact_id = ? + AND (gp.display_name LIKE '%' || ? || '%' OR gp.full_name LIKE '%' || ? || '%' OR gp.description LIKE '%' || ? || '%') |] - (userId, userContactId) + (userId, userContactId, search, search, search) + where + search = fromMaybe "" search_ + +getUserGroupsWithSummary :: DB.Connection -> User -> Maybe ContactId -> Maybe String -> IO [(GroupInfo, GroupSummary)] +getUserGroupsWithSummary db user _contactId_ search_ = + getUserGroupDetails db user _contactId_ search_ + >>= mapM (\g@GroupInfo {groupId} -> (g,) <$> getGroupSummary db user groupId) + +-- the statuses on non-current members should match memberCurrent' function +getGroupSummary :: DB.Connection -> User -> GroupId -> IO GroupSummary +getGroupSummary db User {userId} groupId = do + currentMembers_ <- maybeFirstRow fromOnly $ + DB.query + db + [sql| + SELECT count (m.group_member_id) + FROM groups g + JOIN group_members m USING (group_id) + WHERE g.user_id = ? + AND g.group_id = ? + AND m.member_status != ? + AND m.member_status != ? + AND m.member_status != ? + |] + (userId, groupId, GSMemRemoved, GSMemLeft, GSMemInvited) + pure GroupSummary {currentMembers = fromMaybe 0 currentMembers_} getContactGroupPreferences :: DB.Connection -> User -> Contact -> IO [FullGroupPreferences] getContactGroupPreferences db User {userId} Contact {contactId} = do diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index 9d9791f1a9..77b5b763c3 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -318,6 +318,13 @@ instance ToJSON GroupInfo where toEncoding = J.genericToEncoding J.defaultOption groupName' :: GroupInfo -> GroupName groupName' GroupInfo {localDisplayName = g} = g +data GroupSummary = GroupSummary + { currentMembers :: Int + } + deriving (Show, Generic) + +instance ToJSON GroupSummary where toEncoding = J.genericToEncoding J.defaultOptions + data ContactOrGroup = CGContact Contact | CGGroup Group contactAndGroupIds :: ContactOrGroup -> (Maybe ContactId, Maybe GroupId) @@ -784,6 +791,7 @@ memberActive m = case memberStatus m of memberCurrent :: GroupMember -> Bool memberCurrent = memberCurrent' . memberStatus +-- update getGroupSummary if this is changed memberCurrent' :: GroupMemberStatus -> Bool memberCurrent' = \case GSMemRemoved -> False diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index d6e443401d..febda0de5b 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -79,6 +79,7 @@ responseToView user_ ChatConfig {logLevel, showReactions, showReceipts, testView CRChatItemTTL u ttl -> ttyUser u $ viewChatItemTTL ttl CRNetworkConfig cfg -> viewNetworkConfig cfg CRContactInfo u ct cStats customUserProfile -> ttyUser u $ viewContactInfo ct cStats customUserProfile + CRGroupInfo u g s -> ttyUser u $ viewGroupInfo g s CRGroupMemberInfo u g m cStats -> ttyUser u $ viewGroupMemberInfo g m cStats CRContactSwitchStarted {} -> ["switch started"] CRGroupMemberSwitchStarted {} -> ["switch started"] @@ -200,7 +201,7 @@ responseToView user_ ChatConfig {logLevel, showReactions, showReceipts, testView addressSS UserContactSubStatus {userContactError} = maybe ("Your address is active! To show: " <> highlight' "/sa") (\e -> "User address error: " <> sShow e <> ", to delete your address: " <> highlight' "/da") userContactError (groupLinkErrors, groupLinksSubscribed) = partition (isJust . userContactError) groupLinks CRGroupInvitation u g -> ttyUser u [groupInvitation' g] - CRReceivedGroupInvitation u g c role -> ttyUser u $ viewReceivedGroupInvitation g c role + CRReceivedGroupInvitation {user = u, groupInfo = g, contact = c, memberRole = r} -> ttyUser u $ viewReceivedGroupInvitation g c r CRUserJoinedGroup u g _ -> ttyUser u $ viewUserJoinedGroup g CRJoinedGroupMember u g m -> ttyUser u $ viewJoinedGroupMember g m CRHostConnected p h -> [plain $ "connected to " <> viewHostEvent p h] @@ -217,6 +218,7 @@ responseToView user_ ChatConfig {logLevel, showReactions, showReceipts, testView CRGroupDeleted u g m -> ttyUser u [ttyGroup' g <> ": " <> ttyMember m <> " deleted the group", "use " <> highlight ("/d #" <> groupName' g) <> " to delete the local copy of the group"] CRGroupUpdated u g g' m -> ttyUser u $ viewGroupUpdated g g' m CRGroupProfile u g -> ttyUser u $ viewGroupProfile g + CRGroupDescription u g -> ttyUser u $ viewGroupDescription g CRGroupLinkCreated u g cReq mRole -> ttyUser u $ groupLink_ "Group link is created!" g cReq mRole CRGroupLink u g cReq mRole -> ttyUser u $ groupLink_ "Group link:" g cReq mRole CRGroupLinkDeleted u g -> ttyUser u $ viewGroupLinkDeleted g @@ -810,12 +812,12 @@ viewContactConnected ct@Contact {localDisplayName} userIncognitoProfile testView Nothing -> [ttyFullContact ct <> ": contact is connected"] -viewGroupsList :: [GroupInfo] -> [StyledString] +viewGroupsList :: [(GroupInfo, GroupSummary)] -> [StyledString] viewGroupsList [] = ["you have no groups!", "to create: " <> highlight' "/g "] viewGroupsList gs = map groupSS $ sortOn ldn_ gs where - ldn_ = T.toLower . (localDisplayName :: GroupInfo -> GroupName) - groupSS g@GroupInfo {localDisplayName = ldn, groupProfile = GroupProfile {fullName}, membership, chatSettings} = + ldn_ = T.toLower . (localDisplayName :: GroupInfo -> GroupName) . fst + groupSS (g@GroupInfo {localDisplayName = ldn, groupProfile = GroupProfile {fullName}, membership, chatSettings}, GroupSummary {currentMembers}) = case memberStatus membership of GSMemInvited -> groupInvitation' g s -> membershipIncognito g <> ttyGroup ldn <> optFullName ldn fullName <> viewMemberStatus s @@ -825,9 +827,10 @@ viewGroupsList gs = map groupSS $ sortOn ldn_ gs GSMemLeft -> delete "you left" GSMemGroupDeleted -> delete "group deleted" _ - | enableNtfs chatSettings -> "" - | otherwise -> " (muted, you can " <> highlight ("/unmute #" <> ldn) <> ")" + | enableNtfs chatSettings -> " (" <> memberCount <> ")" + | otherwise -> " (" <> memberCount <> ", muted, you can " <> highlight ("/unmute #" <> ldn) <> ")" delete reason = " (" <> reason <> ", delete local copy: " <> highlight ("/d #" <> ldn) <> ")" + memberCount = sShow currentMembers <> " member" <> if currentMembers == 1 then "" else "s" groupInvitation' :: GroupInfo -> StyledString groupInvitation' GroupInfo {localDisplayName = ldn, groupProfile = GroupProfile {fullName}, membership = membership@GroupMember {memberProfile}} = @@ -934,6 +937,12 @@ viewContactInfo ct@Contact {contactId, profile = LocalProfile {localAlias, conta <> ["alias: " <> plain localAlias | localAlias /= ""] <> [viewConnectionVerified (contactSecurityCode ct)] +viewGroupInfo :: GroupInfo -> GroupSummary -> [StyledString] +viewGroupInfo GroupInfo {groupId} s = + [ "group ID: " <> sShow groupId, + "current members: " <> sShow (currentMembers s) + ] + viewGroupMemberInfo :: GroupInfo -> GroupMember -> Maybe ConnectionStats -> [StyledString] viewGroupMemberInfo GroupInfo {groupId} m@GroupMember {groupMemberId, memberProfile = LocalProfile {localAlias}} stats = [ "group ID: " <> sShow groupId, @@ -1135,6 +1144,10 @@ viewGroupProfile g@GroupInfo {groupProfile = GroupProfile {description, image, g where pref = getGroupPreference f . mergeGroupPreferences +viewGroupDescription :: GroupInfo -> [StyledString] +viewGroupDescription GroupInfo {groupProfile = GroupProfile {description}} = + maybe ["No welcome message!"] ((bold' "Welcome message:" :) . map plain . T.lines) description + bold' :: String -> StyledString bold' = styled Bold diff --git a/tests/Bots/BroadcastTests.hs b/tests/Bots/BroadcastTests.hs new file mode 100644 index 0000000000..69ec10a7ab --- /dev/null +++ b/tests/Bots/BroadcastTests.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Bots.BroadcastTests where + +import Broadcast.Bot +import Broadcast.Options +import ChatClient +import ChatTests.Utils +import Control.Concurrent (forkIO, killThread, threadDelay) +import Control.Exception (bracket) +import Simplex.Chat.Bot.KnownContacts +import Simplex.Chat.Core +import Simplex.Chat.Options (ChatOpts (..), CoreChatOpts (..)) +import Simplex.Chat.Types (Profile (..)) +import System.FilePath (()) +import Test.Hspec + +broadcastBotTests :: SpecWith FilePath +broadcastBotTests = do + it "should broadcast message" testBroadcastMessages + +withBroadcastBot :: BroadcastBotOpts -> IO () -> IO () +withBroadcastBot opts test = + bracket (forkIO bot) killThread (\_ -> threadDelay 500000 >> test) + where + bot = simplexChatCore testCfg (mkChatOpts opts) Nothing $ broadcastBot opts + +broadcastBotProfile :: Profile +broadcastBotProfile = Profile {displayName = "broadcast_bot", fullName = "Broadcast Bot", image = Nothing, contactLink = Nothing, preferences = Nothing} + +mkBotOpts :: FilePath -> [KnownContact] -> BroadcastBotOpts +mkBotOpts tmp publishers = + BroadcastBotOpts + { coreOptions = (coreOptions (testOpts :: ChatOpts)) {dbFilePrefix = tmp botDbPrefix}, + publishers, + welcomeMessage = defaultWelcomeMessage publishers, + prohibitedMessage = defaultWelcomeMessage publishers + } + +botDbPrefix :: FilePath +botDbPrefix = "broadcast_bot" + +testBroadcastMessages :: HasCallStack => FilePath -> IO () +testBroadcastMessages tmp = do + botLink <- + withNewTestChat tmp botDbPrefix broadcastBotProfile $ \bc_bot -> + withNewTestChat tmp "alice" aliceProfile $ \alice -> do + connectUsers bc_bot alice + bc_bot ##> "/ad" + getContactLink bc_bot True + let botOpts = mkBotOpts tmp [KnownContact 2 "alice"] + withBroadcastBot botOpts $ + withTestChat tmp "alice" $ \alice -> + withNewTestChat tmp "bob" bobProfile $ \bob -> + withNewTestChat tmp "cath" cathProfile $ \cath -> do + alice <## "1 contacts connected (use /cs for the list)" + bob `connectVia` botLink + bob #> "@broadcast_bot hello" + bob <# "broadcast_bot> > hello" + bob <## " Hello! I am a broadcast bot." + bob <## "I broadcast messages to all connected users from @alice." + cath `connectVia` botLink + alice #> "@broadcast_bot hello all!" + bob <# "broadcast_bot> hello all!" + cath <# "broadcast_bot> hello all!" + alice <# "broadcast_bot> > hello all!" + alice <## " Forwarded to 2 contact(s)" + where + cc `connectVia` botLink = do + cc ##> ("/c " <> botLink) + cc <## "connection request sent!" + cc <## "broadcast_bot (Broadcast Bot): contact is connected" + cc <# "broadcast_bot> Hello! I am a broadcast bot." + cc <## "I broadcast messages to all connected users from @alice." diff --git a/tests/Bots/DirectoryTests.hs b/tests/Bots/DirectoryTests.hs new file mode 100644 index 0000000000..e074587ad5 --- /dev/null +++ b/tests/Bots/DirectoryTests.hs @@ -0,0 +1,882 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PostfixOperators #-} + +module Bots.DirectoryTests where + +import ChatClient +import ChatTests.Utils +import Control.Concurrent (forkIO, killThread, threadDelay) +import Control.Exception (finally) +import Control.Monad (forM_) +import Directory.Options +import Directory.Service +import Directory.Store +import Simplex.Chat.Bot.KnownContacts +import Simplex.Chat.Core +import Simplex.Chat.Options (ChatOpts (..), CoreChatOpts (..)) +import Simplex.Chat.Types (GroupMemberRole (..), Profile (..)) +import System.FilePath (()) +import Test.Hspec +import GHC.IO.Handle (hClose) + +directoryServiceTests :: SpecWith FilePath +directoryServiceTests = do + it "should register group" testDirectoryService + it "should suspend and resume group" testSuspendResume + describe "de-listing the group" $ do + it "should de-list if owner leaves the group" testDelistedOwnerLeaves + it "should de-list if owner is removed from the group" testDelistedOwnerRemoved + it "should NOT de-list if another member leaves the group" testNotDelistedMemberLeaves + it "should NOT de-list if another member is removed from the group" testNotDelistedMemberRemoved + it "should de-list if service is removed from the group" testDelistedServiceRemoved + it "should de-list/re-list when service/owner roles change" testDelistedRoleChanges + it "should NOT de-list if another member role changes" testNotDelistedMemberRoleChanged + it "should NOT send to approval if roles are incorrect" testNotSentApprovalBadRoles + it "should NOT allow approving if roles are incorrect" testNotApprovedBadRoles + describe "should require re-approval if profile is changed by" $ do + it "the registration owner" testRegOwnerChangedProfile + it "another owner" testAnotherOwnerChangedProfile + describe "should require profile update if group link is removed by " $ do + it "the registration owner" testRegOwnerRemovedLink + it "another owner" testAnotherOwnerRemovedLink + describe "duplicate groups (same display name and full name)" $ do + it "should ask for confirmation if a duplicate group is submitted" testDuplicateAskConfirmation + it "should prohibit registration if a duplicate group is listed" testDuplicateProhibitRegistration + it "should prohibit confirmation if a duplicate group is listed" testDuplicateProhibitConfirmation + it "should prohibit when profile is updated and not send for approval" testDuplicateProhibitWhenUpdated + it "should prohibit approval if a duplicate group is listed" testDuplicateProhibitApproval + describe "list groups" $ do + it "should list user's groups" testListUserGroups + describe "store log" $ do + it "should restore directory service state" testRestoreDirectory + +directoryProfile :: Profile +directoryProfile = Profile {displayName = "SimpleX-Directory", fullName = "", image = Nothing, contactLink = Nothing, preferences = Nothing} + +mkDirectoryOpts :: FilePath -> [KnownContact] -> DirectoryOpts +mkDirectoryOpts tmp superUsers = + DirectoryOpts + { coreOptions = (coreOptions (testOpts :: ChatOpts)) {dbFilePrefix = tmp serviceDbPrefix}, + superUsers, + directoryLog = Just $ tmp "directory_service.log", + serviceName = "SimpleX-Directory", + testing = True + } + +serviceDbPrefix :: FilePath +serviceDbPrefix = "directory_service" + +testDirectoryService :: HasCallStack => FilePath -> IO () +testDirectoryService tmp = + withDirectoryService tmp $ \superUser dsLink -> + withNewTestChat tmp "bob" bobProfile $ \bob -> + withNewTestChat tmp "cath" cathProfile $ \cath -> do + bob `connectVia` dsLink + bob #> "@SimpleX-Directory privacy" + bob <# "SimpleX-Directory> > privacy" + bob <## " No groups found" + -- putStrLn "*** create a group" + bob ##> "/g PSA Privacy, Security & Anonymity" + bob <## "group #PSA (Privacy, Security & Anonymity) is created" + bob <## "to add members use /a PSA or /create link #PSA" + bob ##> "/a PSA SimpleX-Directory member" + bob <## "invitation to join the group #PSA sent to SimpleX-Directory" + bob <# "SimpleX-Directory> You must grant directory service admin role to register the group" + bob ##> "/mr PSA SimpleX-Directory admin" + -- putStrLn "*** discover service joins group and creates the link for profile" + bob <## "#PSA: you changed the role of SimpleX-Directory from member to admin" + bob <# "SimpleX-Directory> Joining the group PSA…" + bob <## "#PSA: SimpleX-Directory joined the group" + bob <# "SimpleX-Directory> Joined the group PSA, creating the link…" + bob <# "SimpleX-Directory> Created the public link to join the group via this directory service that is always online." + bob <## "" + bob <## "Please add it to the group welcome message." + bob <## "For example, add:" + welcomeWithLink <- dropStrPrefix "SimpleX-Directory> " . dropTime <$> getTermLine bob + -- putStrLn "*** update profile without link" + updateGroupProfile bob "Welcome!" + bob <# "SimpleX-Directory> The profile updated for ID 1 (PSA), but the group link is not added to the welcome message." + (superUser Thank you! The group link for ID 1 (PSA) is added to the welcome message." + bob <## "You will be notified once the group is added to the directory - it may take up to 24 hours." + approvalRequested superUser welcomeWithLink (1 :: Int) + -- putStrLn "*** update profile so that it still has link" + let welcomeWithLink' = "Welcome! " <> welcomeWithLink + updateGroupProfile bob welcomeWithLink' + bob <# "SimpleX-Directory> The group ID 1 (PSA) is updated!" + bob <## "It is hidden from the directory until approved." + superUser <# "SimpleX-Directory> The group ID 1 (PSA) is updated." + approvalRequested superUser welcomeWithLink' (2 :: Int) + -- putStrLn "*** try approving with the old registration code" + superUser #> "@SimpleX-Directory /approve 1:PSA 1" + superUser <# "SimpleX-Directory> > /approve 1:PSA 1" + superUser <## " Incorrect approval code" + -- putStrLn "*** update profile so that it has no link" + updateGroupProfile bob "Welcome!" + bob <# "SimpleX-Directory> The group link for ID 1 (PSA) is removed from the welcome message." + bob <## "" + bob <## "The group is hidden from the directory until the group link is added and the group is re-approved." + superUser <# "SimpleX-Directory> The group link is removed from ID 1 (PSA), de-listed." + superUser #> "@SimpleX-Directory /approve 1:PSA 2" + superUser <# "SimpleX-Directory> > /approve 1:PSA 2" + superUser <## " Error: the group ID 1 (PSA) is not pending approval." + -- putStrLn "*** update profile so that it has link again" + updateGroupProfile bob welcomeWithLink' + bob <# "SimpleX-Directory> Thank you! The group link for ID 1 (PSA) is added to the welcome message." + bob <## "You will be notified once the group is added to the directory - it may take up to 24 hours." + approvalRequested superUser welcomeWithLink' (1 :: Int) + superUser #> "@SimpleX-Directory /approve 1:PSA 1" + superUser <# "SimpleX-Directory> > /approve 1:PSA 1" + superUser <## " Group approved!" + bob <# "SimpleX-Directory> The group ID 1 (PSA) is approved and listed in directory!" + bob <## "Please note: if you change the group profile it will be hidden from directory until it is re-approved." + search bob "privacy" welcomeWithLink' + search bob "security" welcomeWithLink' + cath `connectVia` dsLink + search cath "privacy" welcomeWithLink' + where + search u s welcome = do + u #> ("@SimpleX-Directory " <> s) + u <# ("SimpleX-Directory> > " <> s) + u <## " Found 1 group(s)" + u <# "SimpleX-Directory> PSA (Privacy, Security & Anonymity)" + u <## "Welcome message:" + u <## welcome + u <## "2 members" + updateGroupProfile u welcome = do + u ##> ("/set welcome #PSA " <> welcome) + u <## "description changed to:" + u <## welcome + approvalRequested su welcome grId = do + su <# "SimpleX-Directory> bob submitted the group ID 1: PSA (Privacy, Security & Anonymity)" + su <## "Welcome message:" + su <## welcome + su <## "" + su <## "To approve send:" + su <# ("SimpleX-Directory> /approve 1:PSA " <> show grId) + +testSuspendResume :: HasCallStack => FilePath -> IO () +testSuspendResume tmp = + withDirectoryService tmp $ \superUser dsLink -> + withNewTestChat tmp "bob" bobProfile $ \bob -> do + bob `connectVia` dsLink + registerGroup superUser bob "privacy" "Privacy" + groupFound bob "privacy" + superUser #> "@SimpleX-Directory /suspend 1:privacy" + superUser <# "SimpleX-Directory> > /suspend 1:privacy" + superUser <## " Group suspended!" + bob <# "SimpleX-Directory> The group ID 1 (privacy) is suspended and hidden from directory. Please contact the administrators." + groupNotFound bob "privacy" + superUser #> "@SimpleX-Directory /resume 1:privacy" + superUser <# "SimpleX-Directory> > /resume 1:privacy" + superUser <## " Group listing resumed!" + bob <# "SimpleX-Directory> The group ID 1 (privacy) is listed in the directory again!" + groupFound bob "privacy" + +testDelistedOwnerLeaves :: HasCallStack => FilePath -> IO () +testDelistedOwnerLeaves tmp = + withDirectoryService tmp $ \superUser dsLink -> + withNewTestChat tmp "bob" bobProfile $ \bob -> + withNewTestChat tmp "cath" cathProfile $ \cath -> do + bob `connectVia` dsLink + registerGroup superUser bob "privacy" "Privacy" + addCathAsOwner bob cath + leaveGroup "privacy" bob + cath <## "#privacy: bob left the group" + bob <# "SimpleX-Directory> You left the group ID 1 (privacy)." + bob <## "" + bob <## "The group is no longer listed in the directory." + superUser <# "SimpleX-Directory> The group ID 1 (privacy) is de-listed (group owner left)." + groupNotFound cath "privacy" + +testDelistedOwnerRemoved :: HasCallStack => FilePath -> IO () +testDelistedOwnerRemoved tmp = + withDirectoryService tmp $ \superUser dsLink -> + withNewTestChat tmp "bob" bobProfile $ \bob -> + withNewTestChat tmp "cath" cathProfile $ \cath -> do + bob `connectVia` dsLink + registerGroup superUser bob "privacy" "Privacy" + addCathAsOwner bob cath + removeMember "privacy" cath bob + bob <# "SimpleX-Directory> You are removed from the group ID 1 (privacy)." + bob <## "" + bob <## "The group is no longer listed in the directory." + superUser <# "SimpleX-Directory> The group ID 1 (privacy) is de-listed (group owner is removed)." + groupNotFound cath "privacy" + +testNotDelistedMemberLeaves :: HasCallStack => FilePath -> IO () +testNotDelistedMemberLeaves tmp = + withDirectoryService tmp $ \superUser dsLink -> + withNewTestChat tmp "bob" bobProfile $ \bob -> + withNewTestChat tmp "cath" cathProfile $ \cath -> do + bob `connectVia` dsLink + registerGroup superUser bob "privacy" "Privacy" + addCathAsOwner bob cath + leaveGroup "privacy" cath + bob <## "#privacy: cath left the group" + (superUser FilePath -> IO () +testNotDelistedMemberRemoved tmp = + withDirectoryService tmp $ \superUser dsLink -> + withNewTestChat tmp "bob" bobProfile $ \bob -> + withNewTestChat tmp "cath" cathProfile $ \cath -> do + bob `connectVia` dsLink + registerGroup superUser bob "privacy" "Privacy" + addCathAsOwner bob cath + removeMember "privacy" bob cath + (superUser FilePath -> IO () +testDelistedServiceRemoved tmp = + withDirectoryService tmp $ \superUser dsLink -> + withNewTestChat tmp "bob" bobProfile $ \bob -> + withNewTestChat tmp "cath" cathProfile $ \cath -> do + bob `connectVia` dsLink + registerGroup superUser bob "privacy" "Privacy" + addCathAsOwner bob cath + bob ##> "/rm #privacy SimpleX-Directory" + bob <## "#privacy: you removed SimpleX-Directory from the group" + cath <## "#privacy: bob removed SimpleX-Directory from the group" + bob <# "SimpleX-Directory> SimpleX-Directory is removed from the group ID 1 (privacy)." + bob <## "" + bob <## "The group is no longer listed in the directory." + superUser <# "SimpleX-Directory> The group ID 1 (privacy) is de-listed (directory service is removed)." + groupNotFound cath "privacy" + +testDelistedRoleChanges :: HasCallStack => FilePath -> IO () +testDelistedRoleChanges tmp = + withDirectoryService tmp $ \superUser dsLink -> + withNewTestChat tmp "bob" bobProfile $ \bob -> + withNewTestChat tmp "cath" cathProfile $ \cath -> do + bob `connectVia` dsLink + registerGroup superUser bob "privacy" "Privacy" + addCathAsOwner bob cath + groupFoundN 3 cath "privacy" + -- de-listed if service role changed + bob ##> "/mr privacy SimpleX-Directory member" + bob <## "#privacy: you changed the role of SimpleX-Directory from admin to member" + cath <## "#privacy: bob changed the role of SimpleX-Directory from admin to member" + bob <# "SimpleX-Directory> SimpleX-Directory role in the group ID 1 (privacy) is changed to member." + bob <## "" + bob <## "The group is no longer listed in the directory." + superUser <# "SimpleX-Directory> The group ID 1 (privacy) is de-listed (SimpleX-Directory role is changed to member)." + groupNotFound cath "privacy" + -- re-listed if service role changed back without profile changes + cath ##> "/mr privacy SimpleX-Directory admin" + cath <## "#privacy: you changed the role of SimpleX-Directory from member to admin" + bob <## "#privacy: cath changed the role of SimpleX-Directory from member to admin" + bob <# "SimpleX-Directory> SimpleX-Directory role in the group ID 1 (privacy) is changed to admin." + bob <## "" + bob <## "The group is listed in the directory again." + superUser <# "SimpleX-Directory> The group ID 1 (privacy) is listed (SimpleX-Directory role is changed to admin)." + groupFoundN 3 cath "privacy" + -- de-listed if owner role changed + cath ##> "/mr privacy bob admin" + cath <## "#privacy: you changed the role of bob from owner to admin" + bob <## "#privacy: cath changed your role from owner to admin" + bob <# "SimpleX-Directory> Your role in the group ID 1 (privacy) is changed to admin." + bob <## "" + bob <## "The group is no longer listed in the directory." + superUser <# "SimpleX-Directory> The group ID 1 (privacy) is de-listed (user role is set to admin)." + groupNotFound cath "privacy" + -- re-listed if owner role changed back without profile changes + cath ##> "/mr privacy bob owner" + cath <## "#privacy: you changed the role of bob from admin to owner" + bob <## "#privacy: cath changed your role from admin to owner" + bob <# "SimpleX-Directory> Your role in the group ID 1 (privacy) is changed to owner." + bob <## "" + bob <## "The group is listed in the directory again." + superUser <# "SimpleX-Directory> The group ID 1 (privacy) is listed (user role is set to owner)." + groupFoundN 3 cath "privacy" + +testNotDelistedMemberRoleChanged :: HasCallStack => FilePath -> IO () +testNotDelistedMemberRoleChanged tmp = + withDirectoryService tmp $ \superUser dsLink -> + withNewTestChat tmp "bob" bobProfile $ \bob -> + withNewTestChat tmp "cath" cathProfile $ \cath -> do + bob `connectVia` dsLink + registerGroup superUser bob "privacy" "Privacy" + addCathAsOwner bob cath + groupFoundN 3 cath "privacy" + bob ##> "/mr privacy cath member" + bob <## "#privacy: you changed the role of cath from owner to member" + cath <## "#privacy: bob changed your role from owner to member" + groupFoundN 3 cath "privacy" + +testNotSentApprovalBadRoles :: HasCallStack => FilePath -> IO () +testNotSentApprovalBadRoles tmp = + withDirectoryService tmp $ \superUser dsLink -> + withNewTestChat tmp "bob" bobProfile $ \bob -> + withNewTestChat tmp "cath" cathProfile $ \cath -> do + bob `connectVia` dsLink + cath `connectVia` dsLink + submitGroup bob "privacy" "Privacy" + welcomeWithLink <- groupAccepted bob "privacy" + bob ##> "/mr privacy SimpleX-Directory member" + bob <## "#privacy: you changed the role of SimpleX-Directory from admin to member" + updateProfileWithLink bob "privacy" welcomeWithLink 1 + bob <# "SimpleX-Directory> You must grant directory service admin role to register the group" + bob ##> "/mr privacy SimpleX-Directory admin" + bob <## "#privacy: you changed the role of SimpleX-Directory from member to admin" + bob <# "SimpleX-Directory> SimpleX-Directory role in the group ID 1 (privacy) is changed to admin." + bob <## "" + bob <## "The group is submitted for approval." + notifySuperUser superUser bob "privacy" "Privacy" welcomeWithLink 1 + groupNotFound cath "privacy" + approveRegistration superUser bob "privacy" 1 + groupFound cath "privacy" + +testNotApprovedBadRoles :: HasCallStack => FilePath -> IO () +testNotApprovedBadRoles tmp = + withDirectoryService tmp $ \superUser dsLink -> + withNewTestChat tmp "bob" bobProfile $ \bob -> + withNewTestChat tmp "cath" cathProfile $ \cath -> do + bob `connectVia` dsLink + cath `connectVia` dsLink + submitGroup bob "privacy" "Privacy" + welcomeWithLink <- groupAccepted bob "privacy" + updateProfileWithLink bob "privacy" welcomeWithLink 1 + notifySuperUser superUser bob "privacy" "Privacy" welcomeWithLink 1 + bob ##> "/mr privacy SimpleX-Directory member" + bob <## "#privacy: you changed the role of SimpleX-Directory from admin to member" + let approve = "/approve 1:privacy 1" + superUser #> ("@SimpleX-Directory " <> approve) + superUser <# ("SimpleX-Directory> > " <> approve) + superUser <## " Group is not approved: user is not an owner." + groupNotFound cath "privacy" + bob ##> "/mr privacy SimpleX-Directory admin" + bob <## "#privacy: you changed the role of SimpleX-Directory from member to admin" + bob <# "SimpleX-Directory> SimpleX-Directory role in the group ID 1 (privacy) is changed to admin." + bob <## "" + bob <## "The group is submitted for approval." + notifySuperUser superUser bob "privacy" "Privacy" welcomeWithLink 1 + approveRegistration superUser bob "privacy" 1 + groupFound cath "privacy" + +testRegOwnerChangedProfile :: HasCallStack => FilePath -> IO () +testRegOwnerChangedProfile tmp = + withDirectoryService tmp $ \superUser dsLink -> + withNewTestChat tmp "bob" bobProfile $ \bob -> + withNewTestChat tmp "cath" cathProfile $ \cath -> do + bob `connectVia` dsLink + registerGroup superUser bob "privacy" "Privacy" + addCathAsOwner bob cath + bob ##> "/gp privacy privacy Privacy and Security" + bob <## "full name changed to: Privacy and Security" + bob <# "SimpleX-Directory> The group ID 1 (privacy) is updated!" + bob <## "It is hidden from the directory until approved." + cath <## "bob updated group #privacy:" + cath <## "full name changed to: Privacy and Security" + groupNotFound cath "privacy" + superUser <# "SimpleX-Directory> The group ID 1 (privacy) is updated." + reapproveGroup superUser bob + groupFoundN 3 cath "privacy" + +testAnotherOwnerChangedProfile :: HasCallStack => FilePath -> IO () +testAnotherOwnerChangedProfile tmp = + withDirectoryService tmp $ \superUser dsLink -> + withNewTestChat tmp "bob" bobProfile $ \bob -> + withNewTestChat tmp "cath" cathProfile $ \cath -> do + bob `connectVia` dsLink + registerGroup superUser bob "privacy" "Privacy" + addCathAsOwner bob cath + cath ##> "/gp privacy privacy Privacy and Security" + cath <## "full name changed to: Privacy and Security" + bob <## "cath updated group #privacy:" + bob <## "full name changed to: Privacy and Security" + bob <# "SimpleX-Directory> The group ID 1 (privacy) is updated!" + bob <## "It is hidden from the directory until approved." + groupNotFound cath "privacy" + superUser <# "SimpleX-Directory> The group ID 1 (privacy) is updated." + reapproveGroup superUser bob + groupFoundN 3 cath "privacy" + +testRegOwnerRemovedLink :: HasCallStack => FilePath -> IO () +testRegOwnerRemovedLink tmp = + withDirectoryService tmp $ \superUser dsLink -> + withNewTestChat tmp "bob" bobProfile $ \bob -> + withNewTestChat tmp "cath" cathProfile $ \cath -> do + bob `connectVia` dsLink + registerGroup superUser bob "privacy" "Privacy" + addCathAsOwner bob cath + bob ##> "/show welcome #privacy" + bob <## "Welcome message:" + welcomeWithLink <- getTermLine bob + bob ##> "/set welcome #privacy Welcome!" + bob <## "description changed to:" + bob <## "Welcome!" + bob <# "SimpleX-Directory> The group link for ID 1 (privacy) is removed from the welcome message." + bob <## "" + bob <## "The group is hidden from the directory until the group link is added and the group is re-approved." + cath <## "bob updated group #privacy:" + cath <## "description changed to:" + cath <## "Welcome!" + superUser <# "SimpleX-Directory> The group link is removed from ID 1 (privacy), de-listed." + groupNotFound cath "privacy" + bob ##> ("/set welcome #privacy " <> welcomeWithLink) + bob <## "description changed to:" + bob <## welcomeWithLink + bob <# "SimpleX-Directory> Thank you! The group link for ID 1 (privacy) is added to the welcome message." + bob <## "You will be notified once the group is added to the directory - it may take up to 24 hours." + cath <## "bob updated group #privacy:" + cath <## "description changed to:" + cath <## welcomeWithLink + reapproveGroup superUser bob + groupFoundN 3 cath "privacy" + +testAnotherOwnerRemovedLink :: HasCallStack => FilePath -> IO () +testAnotherOwnerRemovedLink tmp = + withDirectoryService tmp $ \superUser dsLink -> + withNewTestChat tmp "bob" bobProfile $ \bob -> + withNewTestChat tmp "cath" cathProfile $ \cath -> do + bob `connectVia` dsLink + registerGroup superUser bob "privacy" "Privacy" + addCathAsOwner bob cath + bob ##> "/show welcome #privacy" + bob <## "Welcome message:" + welcomeWithLink <- getTermLine bob + cath ##> "/set welcome #privacy Welcome!" + cath <## "description changed to:" + cath <## "Welcome!" + bob <## "cath updated group #privacy:" + bob <## "description changed to:" + bob <## "Welcome!" + bob <# "SimpleX-Directory> The group link for ID 1 (privacy) is removed from the welcome message." + bob <## "" + bob <## "The group is hidden from the directory until the group link is added and the group is re-approved." + superUser <# "SimpleX-Directory> The group link is removed from ID 1 (privacy), de-listed." + groupNotFound cath "privacy" + cath ##> ("/set welcome #privacy " <> welcomeWithLink) + cath <## "description changed to:" + cath <## welcomeWithLink + bob <## "cath updated group #privacy:" + bob <## "description changed to:" + bob <## welcomeWithLink + bob <# "SimpleX-Directory> The group link is added by another group member, your registration will not be processed." + bob <## "" + bob <## "Please update the group profile yourself." + bob ##> ("/set welcome #privacy " <> welcomeWithLink <> " - welcome!") + bob <## "description changed to:" + bob <## (welcomeWithLink <> " - welcome!") + bob <# "SimpleX-Directory> Thank you! The group link for ID 1 (privacy) is added to the welcome message." + bob <## "You will be notified once the group is added to the directory - it may take up to 24 hours." + cath <## "bob updated group #privacy:" + cath <## "description changed to:" + cath <## (welcomeWithLink <> " - welcome!") + reapproveGroup superUser bob + groupFoundN 3 cath "privacy" + +testDuplicateAskConfirmation :: HasCallStack => FilePath -> IO () +testDuplicateAskConfirmation tmp = + withDirectoryService tmp $ \superUser dsLink -> + withNewTestChat tmp "bob" bobProfile $ \bob -> + withNewTestChat tmp "cath" cathProfile $ \cath -> do + bob `connectVia` dsLink + submitGroup bob "privacy" "Privacy" + _ <- groupAccepted bob "privacy" + cath `connectVia` dsLink + submitGroup cath "privacy" "Privacy" + cath <# "SimpleX-Directory> The group privacy (Privacy) is already submitted to the directory." + cath <## "To confirm the registration, please send:" + cath <# "SimpleX-Directory> /confirm 1:privacy" + cath #> "@SimpleX-Directory /confirm 1:privacy" + welcomeWithLink <- groupAccepted cath "privacy" + groupNotFound bob "privacy" + completeRegistration superUser cath "privacy" "Privacy" welcomeWithLink 2 + groupFound bob "privacy" + +testDuplicateProhibitRegistration :: HasCallStack => FilePath -> IO () +testDuplicateProhibitRegistration tmp = + withDirectoryService tmp $ \superUser dsLink -> + withNewTestChat tmp "bob" bobProfile $ \bob -> + withNewTestChat tmp "cath" cathProfile $ \cath -> do + bob `connectVia` dsLink + registerGroup superUser bob "privacy" "Privacy" + cath `connectVia` dsLink + groupFound cath "privacy" + _ <- submitGroup cath "privacy" "Privacy" + cath <# "SimpleX-Directory> The group privacy (Privacy) is already listed in the directory, please choose another name." + +testDuplicateProhibitConfirmation :: HasCallStack => FilePath -> IO () +testDuplicateProhibitConfirmation tmp = + withDirectoryService tmp $ \superUser dsLink -> + withNewTestChat tmp "bob" bobProfile $ \bob -> + withNewTestChat tmp "cath" cathProfile $ \cath -> do + bob `connectVia` dsLink + submitGroup bob "privacy" "Privacy" + welcomeWithLink <- groupAccepted bob "privacy" + cath `connectVia` dsLink + submitGroup cath "privacy" "Privacy" + cath <# "SimpleX-Directory> The group privacy (Privacy) is already submitted to the directory." + cath <## "To confirm the registration, please send:" + cath <# "SimpleX-Directory> /confirm 1:privacy" + groupNotFound cath "privacy" + completeRegistration superUser bob "privacy" "Privacy" welcomeWithLink 1 + groupFound cath "privacy" + cath #> "@SimpleX-Directory /confirm 1:privacy" + cath <# "SimpleX-Directory> The group privacy (Privacy) is already listed in the directory, please choose another name." + +testDuplicateProhibitWhenUpdated :: HasCallStack => FilePath -> IO () +testDuplicateProhibitWhenUpdated tmp = + withDirectoryService tmp $ \superUser dsLink -> + withNewTestChat tmp "bob" bobProfile $ \bob -> + withNewTestChat tmp "cath" cathProfile $ \cath -> do + bob `connectVia` dsLink + submitGroup bob "privacy" "Privacy" + welcomeWithLink <- groupAccepted bob "privacy" + cath `connectVia` dsLink + submitGroup cath "privacy" "Privacy" + cath <# "SimpleX-Directory> The group privacy (Privacy) is already submitted to the directory." + cath <## "To confirm the registration, please send:" + cath <# "SimpleX-Directory> /confirm 1:privacy" + cath #> "@SimpleX-Directory /confirm 1:privacy" + welcomeWithLink' <- groupAccepted cath "privacy" + groupNotFound cath "privacy" + completeRegistration superUser bob "privacy" "Privacy" welcomeWithLink 1 + groupFound cath "privacy" + cath ##> ("/set welcome privacy " <> welcomeWithLink') + cath <## "description changed to:" + cath <## welcomeWithLink' + cath <# "SimpleX-Directory> The group privacy (Privacy) is already listed in the directory, please choose another name." + cath ##> "/gp privacy security Security" + cath <## "changed to #security (Security)" + cath <# "SimpleX-Directory> Thank you! The group link for ID 2 (security) is added to the welcome message." + cath <## "You will be notified once the group is added to the directory - it may take up to 24 hours." + notifySuperUser superUser cath "security" "Security" welcomeWithLink' 2 + approveRegistration superUser cath "security" 2 + groupFound bob "security" + groupFound cath "security" + +testDuplicateProhibitApproval :: HasCallStack => FilePath -> IO () +testDuplicateProhibitApproval tmp = + withDirectoryService tmp $ \superUser dsLink -> + withNewTestChat tmp "bob" bobProfile $ \bob -> + withNewTestChat tmp "cath" cathProfile $ \cath -> do + bob `connectVia` dsLink + submitGroup bob "privacy" "Privacy" + welcomeWithLink <- groupAccepted bob "privacy" + cath `connectVia` dsLink + submitGroup cath "privacy" "Privacy" + cath <# "SimpleX-Directory> The group privacy (Privacy) is already submitted to the directory." + cath <## "To confirm the registration, please send:" + cath <# "SimpleX-Directory> /confirm 1:privacy" + cath #> "@SimpleX-Directory /confirm 1:privacy" + welcomeWithLink' <- groupAccepted cath "privacy" + updateProfileWithLink cath "privacy" welcomeWithLink' 2 + notifySuperUser superUser cath "privacy" "Privacy" welcomeWithLink' 2 + groupNotFound cath "privacy" + completeRegistration superUser bob "privacy" "Privacy" welcomeWithLink 1 + groupFound cath "privacy" + -- fails at approval, as already listed + let approve = "/approve 2:privacy 1" + superUser #> ("@SimpleX-Directory " <> approve) + superUser <# ("SimpleX-Directory> > " <> approve) + superUser <## " The group ID 2 (privacy) is already listed in the directory." + +testListUserGroups :: HasCallStack => FilePath -> IO () +testListUserGroups tmp = + withDirectoryService tmp $ \superUser dsLink -> + withNewTestChat tmp "bob" bobProfile $ \bob -> + withNewTestChat tmp "cath" cathProfile $ \cath -> do + bob `connectVia` dsLink + cath `connectVia` dsLink + registerGroup superUser bob "privacy" "Privacy" + connectUsers bob cath + fullAddMember "privacy" "Privacy" bob cath GRMember + joinGroup "privacy" cath bob + cath <## "#privacy: member SimpleX-Directory_1 is connected" + cath <## "contact SimpleX-Directory_1 is merged into SimpleX-Directory" + cath <## "use @SimpleX-Directory to send messages" + registerGroupId superUser bob "security" "Security" 2 2 + registerGroupId superUser cath "anonymity" "Anonymity" 3 1 + cath #> "@SimpleX-Directory /list" + cath <# "SimpleX-Directory> > /list" + cath <## " 1 registered group(s)" + cath <# "SimpleX-Directory> 1. anonymity (Anonymity)" + cath <## "Welcome message:" + cath <##. "Link to join the group anonymity: " + cath <## "2 members" + cath <## "Status: active" + -- with de-listed group + groupFound cath "anonymity" + cath ##> "/mr anonymity SimpleX-Directory member" + cath <## "#anonymity: you changed the role of SimpleX-Directory from admin to member" + cath <# "SimpleX-Directory> SimpleX-Directory role in the group ID 1 (anonymity) is changed to member." + cath <## "" + cath <## "The group is no longer listed in the directory." + superUser <# "SimpleX-Directory> The group ID 3 (anonymity) is de-listed (SimpleX-Directory role is changed to member)." + groupNotFound cath "anonymity" + listGroups superUser bob cath + +testRestoreDirectory :: HasCallStack => FilePath -> IO () +testRestoreDirectory tmp = do + testListUserGroups tmp + restoreDirectoryService tmp 3 3 $ \superUser _dsLink -> + withTestChat tmp "bob" $ \bob -> + withTestChat tmp "cath" $ \cath -> do + bob <## "2 contacts connected (use /cs for the list)" + bob <### + [ "#privacy (Privacy): connected to server(s)", + "#security (Security): connected to server(s)" + ] + cath <## "2 contacts connected (use /cs for the list)" + cath <### + [ "#privacy (Privacy): connected to server(s)", + "#anonymity (Anonymity): connected to server(s)" + ] + listGroups superUser bob cath + groupFoundN 3 bob "privacy" + groupFound bob "security" + groupFoundN 3 cath "privacy" + groupFound cath "security" + +listGroups :: HasCallStack => TestCC -> TestCC -> TestCC -> IO () +listGroups superUser bob cath = do + bob #> "@SimpleX-Directory /list" + bob <# "SimpleX-Directory> > /list" + bob <## " 2 registered group(s)" + bob <# "SimpleX-Directory> 1. privacy (Privacy)" + bob <## "Welcome message:" + bob <##. "Link to join the group privacy: " + bob <## "3 members" + bob <## "Status: active" + bob <# "SimpleX-Directory> 2. security (Security)" + bob <## "Welcome message:" + bob <##. "Link to join the group security: " + bob <## "2 members" + bob <## "Status: active" + cath #> "@SimpleX-Directory /list" + cath <# "SimpleX-Directory> > /list" + cath <## " 1 registered group(s)" + cath <# "SimpleX-Directory> 1. anonymity (Anonymity)" + cath <## "Welcome message:" + cath <##. "Link to join the group anonymity: " + cath <## "2 members" + cath <## "Status: suspended because roles changed" + -- superuser lists all groups + superUser #> "@SimpleX-Directory /last" + superUser <# "SimpleX-Directory> > /last" + superUser <## " 3 registered group(s)" + superUser <# "SimpleX-Directory> 1. privacy (Privacy)" + superUser <## "Welcome message:" + superUser <##. "Link to join the group privacy: " + superUser <## "Owner: bob" + superUser <## "3 members" + superUser <## "Status: active" + superUser <# "SimpleX-Directory> 2. security (Security)" + superUser <## "Welcome message:" + superUser <##. "Link to join the group security: " + superUser <## "Owner: bob" + superUser <## "2 members" + superUser <## "Status: active" + superUser <# "SimpleX-Directory> 3. anonymity (Anonymity)" + superUser <## "Welcome message:" + superUser <##. "Link to join the group anonymity: " + superUser <## "Owner: cath" + superUser <## "2 members" + superUser <## "Status: suspended because roles changed" + -- showing last 1 group + superUser #> "@SimpleX-Directory /last 1" + superUser <# "SimpleX-Directory> > /last 1" + superUser <## " 3 registered group(s), showing the last 1" + superUser <# "SimpleX-Directory> 3. anonymity (Anonymity)" + superUser <## "Welcome message:" + superUser <##. "Link to join the group anonymity: " + superUser <## "Owner: cath" + superUser <## "2 members" + superUser <## "Status: suspended because roles changed" + +reapproveGroup :: HasCallStack => TestCC -> TestCC -> IO () +reapproveGroup superUser bob = do + superUser <#. "SimpleX-Directory> bob submitted the group ID 1: privacy (" + superUser <## "Welcome message:" + superUser <##. "Link to join the group privacy: " + superUser <## "" + superUser <## "To approve send:" + superUser <# "SimpleX-Directory> /approve 1:privacy 1" + superUser #> "@SimpleX-Directory /approve 1:privacy 1" + superUser <# "SimpleX-Directory> > /approve 1:privacy 1" + superUser <## " Group approved!" + bob <# "SimpleX-Directory> The group ID 1 (privacy) is approved and listed in directory!" + bob <## "Please note: if you change the group profile it will be hidden from directory until it is re-approved." + +addCathAsOwner :: HasCallStack => TestCC -> TestCC -> IO () +addCathAsOwner bob cath = do + connectUsers bob cath + fullAddMember "privacy" "Privacy" bob cath GROwner + joinGroup "privacy" cath bob + cath <## "#privacy: member SimpleX-Directory is connected" + +withDirectoryService :: HasCallStack => FilePath -> (TestCC -> String -> IO ()) -> IO () +withDirectoryService tmp test = do + dsLink <- + withNewTestChat tmp serviceDbPrefix directoryProfile $ \ds -> + withNewTestChat tmp "super_user" aliceProfile $ \superUser -> do + connectUsers ds superUser + ds ##> "/ad" + getContactLink ds True + withDirectory tmp dsLink test + +restoreDirectoryService :: HasCallStack => FilePath -> Int -> Int -> (TestCC -> String -> IO ()) -> IO () +restoreDirectoryService tmp ctCount grCount test = do + dsLink <- + withTestChat tmp serviceDbPrefix $ \ds -> do + ds <## (show ctCount <> " contacts connected (use /cs for the list)") + ds <## "Your address is active! To show: /sa" + ds <## (show grCount <> " group links active") + forM_ [1..grCount] $ \_ -> ds <##. "#" + ds ##> "/sa" + dsLink <- getContactLink ds False + ds <## "auto_accept on" + pure dsLink + withDirectory tmp dsLink test + +withDirectory :: HasCallStack => FilePath -> String -> (TestCC -> String -> IO ()) -> IO () +withDirectory tmp dsLink test = do + let opts = mkDirectoryOpts tmp [KnownContact 2 "alice"] + runDirectory opts $ + withTestChat tmp "super_user" $ \superUser -> do + superUser <## "1 contacts connected (use /cs for the list)" + test superUser dsLink + +runDirectory :: DirectoryOpts -> IO () -> IO () +runDirectory opts@DirectoryOpts {directoryLog} action = do + st <- restoreDirectoryStore directoryLog + t <- forkIO $ bot st + threadDelay 500000 + action `finally` (mapM_ hClose (directoryLogFile st) >> killThread t) + where + bot st = simplexChatCore testCfg (mkChatOpts opts) Nothing $ directoryService st opts + +registerGroup :: TestCC -> TestCC -> String -> String -> IO () +registerGroup su u n fn = registerGroupId su u n fn 1 1 + +registerGroupId :: TestCC -> TestCC -> String -> String -> Int -> Int -> IO () +registerGroupId su u n fn gId ugId = do + submitGroup u n fn + welcomeWithLink <- groupAccepted u n + completeRegistrationId su u n fn welcomeWithLink gId ugId + +submitGroup :: TestCC -> String -> String -> IO () +submitGroup u n fn = do + u ##> ("/g " <> n <> " " <> fn) + u <## ("group #" <> n <> " (" <> fn <> ") is created") + u <## ("to add members use /a " <> n <> " or /create link #" <> n) + u ##> ("/a " <> n <> " SimpleX-Directory admin") + u <## ("invitation to join the group #" <> n <> " sent to SimpleX-Directory") + +groupAccepted :: TestCC -> String -> IO String +groupAccepted u n = do + u <# ("SimpleX-Directory> Joining the group " <> n <> "…") + u <## ("#" <> n <> ": SimpleX-Directory joined the group") + u <# ("SimpleX-Directory> Joined the group " <> n <> ", creating the link…") + u <# "SimpleX-Directory> Created the public link to join the group via this directory service that is always online." + u <## "" + u <## "Please add it to the group welcome message." + u <## "For example, add:" + dropStrPrefix "SimpleX-Directory> " . dropTime <$> getTermLine u -- welcome message with link + +completeRegistration :: TestCC -> TestCC -> String -> String -> String -> Int -> IO () +completeRegistration su u n fn welcomeWithLink gId = + completeRegistrationId su u n fn welcomeWithLink gId gId + +completeRegistrationId :: TestCC -> TestCC -> String -> String -> String -> Int -> Int -> IO () +completeRegistrationId su u n fn welcomeWithLink gId ugId = do + updateProfileWithLink u n welcomeWithLink ugId + notifySuperUser su u n fn welcomeWithLink gId + approveRegistrationId su u n gId ugId + +updateProfileWithLink :: TestCC -> String -> String -> Int -> IO () +updateProfileWithLink u n welcomeWithLink ugId = do + u ##> ("/set welcome " <> n <> " " <> welcomeWithLink) + u <## "description changed to:" + u <## welcomeWithLink + u <# ("SimpleX-Directory> Thank you! The group link for ID " <> show ugId <> " (" <> n <> ") is added to the welcome message.") + u <## "You will be notified once the group is added to the directory - it may take up to 24 hours." + +notifySuperUser :: TestCC -> TestCC -> String -> String -> String -> Int -> IO () +notifySuperUser su u n fn welcomeWithLink gId = do + uName <- userName u + su <# ("SimpleX-Directory> " <> uName <> " submitted the group ID " <> show gId <> ": " <> n <> " (" <> fn <> ")") + su <## "Welcome message:" + su <## welcomeWithLink + su <## "" + su <## "To approve send:" + let approve = "/approve " <> show gId <> ":" <> n <> " 1" + su <# ("SimpleX-Directory> " <> approve) + +approveRegistration :: TestCC -> TestCC -> String -> Int -> IO () +approveRegistration su u n gId = + approveRegistrationId su u n gId gId + +approveRegistrationId :: TestCC -> TestCC -> String -> Int -> Int -> IO () +approveRegistrationId su u n gId ugId = do + let approve = "/approve " <> show gId <> ":" <> n <> " 1" + su #> ("@SimpleX-Directory " <> approve) + su <# ("SimpleX-Directory> > " <> approve) + su <## " Group approved!" + u <# ("SimpleX-Directory> The group ID " <> show ugId <> " (" <> n <> ") is approved and listed in directory!") + u <## "Please note: if you change the group profile it will be hidden from directory until it is re-approved." + +connectVia :: TestCC -> String -> IO () +u `connectVia` dsLink = do + u ##> ("/c " <> dsLink) + u <## "connection request sent!" + u <## "SimpleX-Directory: contact is connected" + u <# "SimpleX-Directory> Welcome to SimpleX-Directory service!" + u <## "Send a search string to find groups or /help to learn how to add groups to directory." + u <## "" + u <## "For example, send privacy to find groups about privacy." + +joinGroup :: String -> TestCC -> TestCC -> IO () +joinGroup gName member host = do + let gn = "#" <> gName + memberName <- userName member + hostName <- userName host + member ##> ("/j " <> gName) + member <## (gn <> ": you joined the group") + member <#. (gn <> " " <> hostName <> "> Link to join the group " <> gName <> ": ") + host <## (gn <> ": " <> memberName <> " joined the group") + +leaveGroup :: String -> TestCC -> IO () +leaveGroup gName member = do + let gn = "#" <> gName + member ##> ("/l " <> gName) + member <## (gn <> ": you left the group") + member <## ("use /d " <> gn <> " to delete the group") + +removeMember :: String -> TestCC -> TestCC -> IO () +removeMember gName admin removed = do + let gn = "#" <> gName + adminName <- userName admin + removedName <- userName removed + admin ##> ("/rm " <> gName <> " " <> removedName) + admin <## (gn <> ": you removed " <> removedName <> " from the group") + removed <## (gn <> ": " <> adminName <> " removed you from the group") + removed <## ("use /d " <> gn <> " to delete the group") + +groupFound :: TestCC -> String -> IO () +groupFound = groupFoundN 2 + +groupFoundN :: Int -> TestCC -> String -> IO () +groupFoundN count u name = do + u #> ("@SimpleX-Directory " <> name) + u <# ("SimpleX-Directory> > " <> name) + u <## " Found 1 group(s)" + u <#. ("SimpleX-Directory> " <> name <> " (") + u <## "Welcome message:" + u <##. "Link to join the group " + u <## (show count <> " members") + +groupNotFound :: TestCC -> String -> IO () +groupNotFound u s = do + u #> ("@SimpleX-Directory " <> s) + u <# ("SimpleX-Directory> > " <> s) + u <## " No groups found" diff --git a/tests/ChatTests/Direct.hs b/tests/ChatTests/Direct.hs index 7b93b97589..2384daac3f 100644 --- a/tests/ChatTests/Direct.hs +++ b/tests/ChatTests/Direct.hs @@ -990,7 +990,7 @@ testMuteGroup = (bob hi") bob ##> "/gs" - bob <## "#team (muted, you can /unmute #team)" + bob <## "#team (3 members, muted, you can /unmute #team)" bob ##> "/unmute #team" bob <## "ok" alice #> "#team hi again" @@ -998,7 +998,7 @@ testMuteGroup = (bob <# "#team alice> hi again") (cath <# "#team alice> hi again") bob ##> "/gs" - bob <## "#team" + bob <## "#team (3 members)" testCreateSecondUser :: HasCallStack => FilePath -> IO () testCreateSecondUser = diff --git a/tests/ChatTests/Groups.hs b/tests/ChatTests/Groups.hs index 6e1e761208..5882319efb 100644 --- a/tests/ChatTests/Groups.hs +++ b/tests/ChatTests/Groups.hs @@ -132,7 +132,7 @@ testGroupShared alice bob cath checkMessages = do when checkMessages $ getReadChats msgItem1 msgItem2 -- list groups alice ##> "/gs" - alice <## "#team" + alice <## "#team (3 members)" -- list group members alice ##> "/ms team" alice @@ -739,18 +739,18 @@ testGroupList = ] -- alice sees both groups alice ##> "/gs" - alice <### ["#team", "#tennis"] + alice <### ["#team (2 members)", "#tennis (1 member)"] -- bob sees #tennis as invitation bob ##> "/gs" bob - <### [ "#team", + <### [ "#team (2 members)", "#tennis - you are invited (/j tennis to join, /d #tennis to delete invitation)" ] -- after deleting invitation bob sees only one group bob ##> "/d #tennis" bob <## "#tennis: you deleted the group" bob ##> "/gs" - bob <## "#team" + bob <## "#team (2 members)" testGroupMessageQuotedReply :: HasCallStack => FilePath -> IO () testGroupMessageQuotedReply = diff --git a/tests/ChatTests/Profiles.hs b/tests/ChatTests/Profiles.hs index 08d33df1d6..b9e8371b0b 100644 --- a/tests/ChatTests/Profiles.hs +++ b/tests/ChatTests/Profiles.hs @@ -770,7 +770,7 @@ testJoinGroupIncognito = testChat4 aliceProfile bobProfile cathProfile danProfil dan <##> cath -- list groups cath ##> "/gs" - cath <## "i #secret_club" + cath <## "i #secret_club (4 members)" -- list group members alice ##> "/ms secret_club" alice diff --git a/tests/ChatTests/Utils.hs b/tests/ChatTests/Utils.hs index c4b7e16c58..4c7ca8d0a4 100644 --- a/tests/ChatTests/Utils.hs +++ b/tests/ChatTests/Utils.hs @@ -48,9 +48,15 @@ xit' :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a) xit' = if os == "linux" then xit else it xit'' :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a) -xit'' d t = do +xit'' = ifCI xit it + +xdescribe'' :: HasCallStack => String -> SpecWith a -> SpecWith a +xdescribe'' = ifCI xdescribe describe + +ifCI :: HasCallStack => (HasCallStack => String -> a -> SpecWith b) -> (HasCallStack => String -> a -> SpecWith b) -> String -> a -> SpecWith b +ifCI xrun run d t = do ci <- runIO $ lookupEnv "CI" - (if ci == Just "true" then xit else it) d t + (if ci == Just "true" then xrun else run) d t versionTestMatrix2 :: (HasCallStack => TestCC -> TestCC -> IO ()) -> SpecWith FilePath versionTestMatrix2 runTest = do @@ -349,6 +355,11 @@ dropTime_ msg = case splitAt 6 msg of if all isDigit [m, m', s, s'] then Just text else Nothing _ -> Nothing +dropStrPrefix :: HasCallStack => String -> String -> String +dropStrPrefix pfx s = + let (p, rest) = splitAt (length pfx) s + in if p == pfx then rest else error $ "no prefix " <> pfx <> " in string : " <> s + dropReceipt :: HasCallStack => String -> String dropReceipt msg = fromMaybe err $ dropReceipt_ msg where @@ -459,6 +470,7 @@ createGroup3 :: HasCallStack => String -> TestCC -> TestCC -> TestCC -> IO () createGroup3 gName cc1 cc2 cc3 = do createGroup2 gName cc1 cc2 connectUsers cc1 cc3 + name1 <- userName cc1 name3 <- userName cc3 sName2 <- showName cc2 sName3 <- showName cc3 @@ -470,19 +482,23 @@ createGroup3 gName cc1 cc2 cc3 = do cc3 <## ("#" <> gName <> ": you joined the group") cc3 <## ("#" <> gName <> ": member " <> sName2 <> " is connected"), do - cc2 <## ("#" <> gName <> ": alice added " <> sName3 <> " to the group (connecting...)") + cc2 <## ("#" <> gName <> ": " <> name1 <> " added " <> sName3 <> " to the group (connecting...)") cc2 <## ("#" <> gName <> ": new member " <> name3 <> " is connected") ] addMember :: HasCallStack => String -> TestCC -> TestCC -> GroupMemberRole -> IO () -addMember gName inviting invitee role = do +addMember gName = fullAddMember gName "" + +fullAddMember :: HasCallStack => String -> String -> TestCC -> TestCC -> GroupMemberRole -> IO () +fullAddMember gName fullName inviting invitee role = do name1 <- userName inviting memName <- userName invitee inviting ##> ("/a " <> gName <> " " <> memName <> " " <> B.unpack (strEncode role)) + let fullName' = if null fullName || fullName == gName then "" else " (" <> fullName <> ")" concurrentlyN_ [ inviting <## ("invitation to join the group #" <> gName <> " sent to " <> memName), do - invitee <## ("#" <> gName <> ": " <> name1 <> " invites you to join the group as " <> B.unpack (strEncode role)) + invitee <## ("#" <> gName <> fullName' <> ": " <> name1 <> " invites you to join the group as " <> B.unpack (strEncode role)) invitee <## ("use /j " <> gName <> " to accept") ] diff --git a/tests/Test.hs b/tests/Test.hs index 9010aefa0f..d9d36d472b 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -1,5 +1,8 @@ +import Bots.BroadcastTests +import Bots.DirectoryTests import ChatClient import ChatTests +import ChatTests.Utils (xdescribe'') import Control.Logger.Simple import Data.Time.Clock.System import MarkdownTests @@ -23,6 +26,8 @@ main = do around testBracket $ do describe "Mobile API Tests" mobileTests describe "SimpleX chat client" chatTests + xdescribe'' "SimpleX Broadcast bot" broadcastBotTests + xdescribe'' "SimpleX Directory service bot" directoryServiceTests where testBracket test = do t <- getSystemTime