{-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} module Directory.Service ( welcomeGetOpts, directoryService, ) where import Control.Concurrent (forkIO) import Control.Concurrent.Async import Control.Concurrent.STM import Control.Logger.Simple import Control.Monad import Data.Maybe (fromMaybe, maybeToList) import Data.Set (Set) import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T import Data.Time.Clock (diffUTCTime, getCurrentTime) import Data.Time.LocalTime (getCurrentTimeZone) import Directory.Events import Directory.Options import Directory.Search 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.Options import Simplex.Chat.Protocol (MsgContent (..)) import Simplex.Chat.Store.Shared (StoreError (..)) import Simplex.Chat.Types import Simplex.Chat.Types.Shared import Simplex.Chat.View (serializeChatResponse, simplexChatContact, viewContactName, viewGroupName) import Simplex.Messaging.Encoding.String import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM 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) data ServiceState = ServiceState { searchRequests :: TMap ContactId SearchRequest } newServiceState :: IO ServiceState newServiceState = do searchRequests <- TM.emptyIO pure ServiceState {searchRequests} 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 {adminUsers, superUsers, serviceName, searchResults, testing} user@User {userId} cc = do initializeBotAddress' (not testing) cc env <- newServiceState race_ (forever $ void getLine) . forever $ do (_, _, resp) <- atomically . readTBQueue $ outputQ cc forM_ (crDirectoryEvent resp) $ \case DEContactConnected ct -> deContactConnected ct DEGroupInvitation {contact = ct, groupInfo = g, fromMemberRole, memberRole} -> deGroupInvitation ct g fromMemberRole memberRole DEServiceJoinedGroup ctId g owner -> deServiceJoinedGroup ctId g owner DEGroupUpdated {contactId, fromGroup, toGroup} -> deGroupUpdated contactId fromGroup toGroup DEContactRoleChanged g ctId role -> deContactRoleChanged g ctId role DEServiceRoleChanged g role -> deServiceRoleChanged g role DEContactRemovedFromGroup ctId g -> deContactRemovedFromGroup ctId g DEContactLeftGroup ctId g -> deContactLeftGroup ctId g DEServiceRemovedFromGroup g -> deServiceRemovedFromGroup g DEGroupDeleted _g -> pure () DEUnsupportedMessage _ct _ciId -> pure () DEItemEditIgnored _ct -> pure () DEItemDeleteIgnored _ct -> pure () DEContactCommand ct ciId (ADC sUser cmd) -> do logInfo $ "command received " <> directoryCmdTag cmd case sUser of SDRUser -> deUserCommand env ct ciId cmd SDRAdmin -> deAdminCommand ct ciId cmd SDRSuperUser -> deSuperUserCommand ct ciId cmd DELogChatResponse r -> logInfo r where withAdminUsers action = void . forkIO $ do forM_ superUsers $ \KnownContact {contactId} -> action contactId forM_ adminUsers $ \KnownContact {contactId} -> action contactId withSuperUsers action = void . forkIO $ forM_ superUsers $ \KnownContact {contactId} -> action contactId notifyAdminUsers s = withAdminUsers $ \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 -> logError $ "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 " <> tshow groupId <> " (" <> displayName <> ")" groupAlreadyListed GroupInfo {groupProfile = GroupProfile {displayName, fullName}} = "The group " <> displayName <> " (" <> fullName <> ") is already listed in the directory, please choose another name." getGroups :: Text -> IO (Maybe [(GroupInfo, GroupSummary)]) getGroups = getGroups_ . Just getGroups_ :: Maybe Text -> IO (Maybe [(GroupInfo, GroupSummary)]) getGroups_ search_ = sendChatCmd cc (APIListGroups userId Nothing $ 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 $ case r of CRUserAcceptedGroupSent {} -> "Joining the group " <> displayName <> "…" _ -> "Error joining group " <> displayName <> ", please re-send the invitation!" deContactConnected :: Contact -> IO () deContactConnected ct = when (contactDirect ct) $ do logInfo $ (viewContactName 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.\n\ \Or send */all* or */new* to list groups.\n\n\ \Content and privacy policy: https://simplex.chat/docs/directory.html" deGroupInvitation :: Contact -> GroupInfo -> GroupMemberRole -> GroupMemberRole -> IO () deGroupInvitation ct g@GroupInfo {groupProfile = GroupProfile {displayName, fullName}} fromMemberRole memberRole = do logInfo $ "invited to group " <> viewGroupName g <> " by " <> viewContactName ct 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 $ "The group " <> displayName <> " (" <> fullName <> ") is already submitted to the directory.\nTo confirm the registration, please send:" sendMessage cc ct $ "/confirm " <> tshow ugrId <> ":" <> viewName displayName badRolesMsg :: GroupRolesStatus -> Maybe Text badRolesMsg = \case GRSOk -> Nothing GRSServiceNotAdmin -> Just "You must grant directory service *admin* role to register the group" GRSContactNotOwner -> Just "You must have a group *owner* 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) -> GRSContactNotOwner (GROwner, _) -> GRSServiceNotAdmin _ -> 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 = do logInfo $ "service joined group " <> viewGroupName g withGroupReg g "joined group" $ \gr -> when (ctId `isOwner` gr) $ do setGroupRegOwner st gr owner let GroupInfo {groupId, groupProfile = GroupProfile {displayName}} = g notifyOwner gr $ "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 " <> displayName <> ": " <> strEncodeTxt (simplexChatContact 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 = do logInfo $ "group updated " <> viewGroupName 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." logError $ "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 48 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." notifyAdminUsers $ "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." notifyAdminUsers $ "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." notifyAdminUsers $ "The group " <> groupRef <> " is updated." checkRolesSendToApprove gr n' GPServiceLinkError -> logError $ "Error: no group link for " <> groupRef <> " pending approval." groupProfileUpdate = profileUpdate <$> sendChatCmd cc (APIGetGroupLink groupId) where profileUpdate = \case CRGroupLink {connReqContact} -> let groupLink1 = strEncodeTxt connReqContact groupLink2 = strEncodeTxt $ simplexChatContact connReqContact hadLinkBefore = groupLink1 `isInfix` description p || groupLink2 `isInfix` description p hasLinkNow = groupLink1 `isInfix` description p' || groupLink2 `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 gr_ <- getGroupAndSummary cc dbGroupId let membersStr = maybe "" (\(_, s) -> "_" <> tshow (currentMembers s) <> " members_\n") gr_ text = maybe ("The group ID " <> tshow dbGroupId <> " submitted: ") (\c -> localDisplayName' c <> " submitted the group ID " <> tshow dbGroupId <> ": ") ct_ <> ("\n" <> groupInfoText p <> "\n" <> membersStr <> "\nTo approve send:") msg = maybe (MCText text) (\image -> MCImage {text, image}) image' withAdminUsers $ \cId -> do sendComposedMessage' cc cId Nothing msg sendMessage' cc cId $ "/approve " <> tshow dbGroupId <> ":" <> viewName displayName <> " " <> tshow gaId deContactRoleChanged :: GroupInfo -> ContactId -> GroupMemberRole -> IO () deContactRoleChanged g@GroupInfo {membership = GroupMember {memberRole = serviceRole}} ctId contactRole = do logInfo $ "contact ID " <> tshow ctId <> " role changed in group " <> viewGroupName g <> " to " <> tshow 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." notifyAdminUsers $ "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." notifyAdminUsers $ "The group " <> groupRef <> " is de-listed " <> suCtRole _ -> pure () where rStatus = groupRolesStatus contactRole serviceRole groupRef = groupReference g ctRole = "*" <> strEncodeTxt contactRole <> "*" suCtRole = "(user role is set to " <> ctRole <> ")." deServiceRoleChanged :: GroupInfo -> GroupMemberRole -> IO () deServiceRoleChanged g serviceRole = do logInfo $ "service role changed in group " <> viewGroupName g <> " to " <> tshow serviceRole 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." notifyAdminUsers $ "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." notifyAdminUsers $ "The group " <> groupRef <> " is de-listed " <> suSrvRole _ -> pure () where groupRef = groupReference g srvRole = "*" <> strEncodeTxt 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 = do logInfo $ "contact ID " <> tshow ctId <> " removed from group " <> viewGroupName 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." notifyAdminUsers $ "The group " <> groupReference g <> " is de-listed (group owner is removed)." deContactLeftGroup :: ContactId -> GroupInfo -> IO () deContactLeftGroup ctId g = do logInfo $ "contact ID " <> tshow ctId <> " left group " <> viewGroupName 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." notifyAdminUsers $ "The group " <> groupReference g <> " is de-listed (group owner left)." deServiceRemovedFromGroup :: GroupInfo -> IO () deServiceRemovedFromGroup g = do logInfo $ "service removed from group " <> viewGroupName 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." notifyAdminUsers $ "The group " <> groupReference g <> " is de-listed (directory service is removed)." deUserCommand :: ServiceState -> Contact -> ChatItemId -> DirectoryCmd 'DRUser -> IO () deUserCommand env@ServiceState {searchRequests} ct ciId = \case 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* (you can send `/list` to see all groups you submitted).\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 48 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 -> withFoundListedGroups (Just s) $ sendSearchResults s DCSearchNext -> atomically (TM.lookup (contactId' ct) searchRequests) >>= \case Just search@SearchRequest {searchType, searchTime} -> do currentTime <- getCurrentTime if diffUTCTime currentTime searchTime > 300 -- 5 minutes then do atomically $ TM.delete (contactId' ct) searchRequests showAllGroups else case searchType of STSearch s -> withFoundListedGroups (Just s) $ sendNextSearchResults takeTop search STAll -> withFoundListedGroups Nothing $ sendNextSearchResults takeTop search STRecent -> withFoundListedGroups Nothing $ sendNextSearchResults takeRecent search Nothing -> showAllGroups where showAllGroups = deUserCommand env ct ciId DCAllGroups DCAllGroups -> withFoundListedGroups Nothing $ sendAllGroups takeTop "top" STAll DCRecentGroups -> withFoundListedGroups Nothing $ sendAllGroups takeRecent "the most recent" STRecent DCSubmitGroup _link -> pure () DCConfirmDuplicateGroup ugrId gName -> withUserGroupReg ugrId gName $ \g@GroupInfo {groupProfile = GroupProfile {displayName}} gr -> readTVarIO (groupRegStatus gr) >>= \case GRSPendingConfirmation -> 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 " <> tshow ugrId <> " (" <> displayName <> ") is not pending confirmation." DCListUserGroups -> atomically (getUserGroupRegs st $ contactId' ct) >>= \grs -> do sendReply $ tshow (length grs) <> " registered group(s)" void . forkIO $ forM_ (reverse grs) $ \gr@GroupReg {userGroupRegId} -> sendGroupInfo ct gr userGroupRegId Nothing DCDeleteGroup ugrId gName -> withUserGroupReg ugrId gName $ \GroupInfo {groupProfile = GroupProfile {displayName}} gr -> do delGroupReg st gr sendReply $ "Your group " <> displayName <> " is deleted from the directory" DCSetRole gId gName mRole -> (if isAdmin then withGroupAndReg sendReply else withUserGroupReg) gId gName $ \GroupInfo {groupId, groupProfile = GroupProfile {displayName}} _gr -> do gLink_ <- setGroupLinkRole cc groupId mRole sendReply $ case gLink_ of Nothing -> "Error: the initial member role for the group " <> displayName <> " was NOT upgated" Just gLink -> ("The initial member role for the group " <> displayName <> " is set to *" <> strEncodeTxt mRole <> "*\n\n") <> ("*Please note*: it applies only to members joining via this link: " <> strEncodeTxt (simplexChatContact gLink)) DCUnknownCommand -> sendReply "Unknown command" DCCommandError tag -> sendReply $ "Command error: " <> tshow tag where knownCt = knownContact ct isAdmin = knownCt `elem` adminUsers || knownCt `elem` superUsers withUserGroupReg ugrId gName action = atomically (getUserGroupReg st (contactId' ct) ugrId) >>= \case Nothing -> sendReply $ "Group ID " <> tshow ugrId <> " not found" Just gr@GroupReg {dbGroupId} -> do getGroup cc dbGroupId >>= \case Nothing -> sendReply $ "Group ID " <> tshow ugrId <> " not found" Just g@GroupInfo {groupProfile = GroupProfile {displayName}} | displayName == gName -> action g gr | otherwise -> sendReply $ "Group ID " <> tshow ugrId <> " has the display name " <> displayName sendReply = mkSendReply ct ciId withFoundListedGroups s_ action = getGroups_ s_ >>= \case Just groups -> atomically (filterListedGroups st groups) >>= action Nothing -> sendReply "Error: getGroups. Please notify the developers." sendSearchResults s = \case [] -> sendReply "No groups found" gs -> do let gs' = takeTop searchResults gs moreGroups = length gs - length gs' more = if moreGroups > 0 then ", sending top " <> tshow (length gs') else "" sendReply $ "Found " <> tshow (length gs) <> " group(s)" <> more <> "." updateSearchRequest (STSearch s) $ groupIds gs' sendFoundGroups gs' moreGroups sendAllGroups takeFirst sortName searchType = \case [] -> sendReply "No groups listed" gs -> do let gs' = takeFirst searchResults gs moreGroups = length gs - length gs' more = if moreGroups > 0 then ", sending " <> sortName <> " " <> tshow (length gs') else "" sendReply $ tshow (length gs) <> " group(s) listed" <> more <> "." updateSearchRequest searchType $ groupIds gs' sendFoundGroups gs' moreGroups sendNextSearchResults takeFirst SearchRequest {searchType, sentGroups} = \case [] -> do sendReply "Sorry, no more groups" atomically $ TM.delete (contactId' ct) searchRequests gs -> do let gs' = takeFirst searchResults $ filterNotSent sentGroups gs sentGroups' = sentGroups <> groupIds gs' moreGroups = length gs - S.size sentGroups' sendReply $ "Sending " <> tshow (length gs') <> " more group(s)." updateSearchRequest searchType sentGroups' sendFoundGroups gs' moreGroups updateSearchRequest :: SearchType -> Set GroupId -> IO () updateSearchRequest searchType sentGroups = do searchTime <- getCurrentTime let search = SearchRequest {searchType, searchTime, sentGroups} atomically $ TM.insert (contactId' ct) search searchRequests sendFoundGroups gs moreGroups = void . forkIO $ do forM_ gs $ \(GroupInfo {groupId, groupProfile = p@GroupProfile {image = image_}}, GroupSummary {currentMembers}) -> do let membersStr = "_" <> tshow currentMembers <> " members_" showId = if isAdmin then tshow groupId <> ". " else "" text = showId <> groupInfoText p <> "\n" <> membersStr msg = maybe (MCText text) (\image -> MCImage {text, image}) image_ sendComposedMessage cc ct Nothing msg when (moreGroups > 0) $ sendComposedMessage cc ct Nothing $ MCText $ "Send */next* or just *.* for " <> tshow moreGroups <> " more result(s)." deAdminCommand :: Contact -> ChatItemId -> DirectoryCmd 'DRAdmin -> IO () deAdminCommand ct ciId cmd | knownCt `elem` adminUsers || knownCt `elem` superUsers = case cmd of DCApproveGroup {groupId, displayName = n, groupApprovalId} -> withGroupAndReg sendReply groupId n $ \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 let approved = "The group " <> userGroupReference' gr n <> " is approved" notifyOwner gr $ approved <> " and listed in directory!\nPlease note: if you change the group profile it will be hidden from directory until it is re-approved." sendReply "Group approved!" notifyOtherSuperUsers $ approved <> " by " <> viewName (localDisplayName' ct) 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 withGroupAndReg sendReply groupId gName $ \_ gr -> readTVarIO (groupRegStatus gr) >>= \case GRSActive -> do setGroupStatus st gr GRSSuspended let suspended = "The group " <> userGroupReference' gr gName <> " is suspended" notifyOwner gr $ suspended <> " and hidden from directory. Please contact the administrators." sendReply "Group suspended!" notifyOtherSuperUsers $ suspended <> " by " <> viewName (localDisplayName' ct) _ -> sendReply $ "The group " <> groupRef <> " is not active, can't be suspended." DCResumeGroup groupId gName -> do let groupRef = groupReference' groupId gName withGroupAndReg sendReply groupId gName $ \_ gr -> readTVarIO (groupRegStatus gr) >>= \case GRSSuspended -> do setGroupStatus st gr GRSActive let groupStr = "The group " <> userGroupReference' gr gName notifyOwner gr $ groupStr <> " is listed in the directory again!" sendReply "Group listing resumed!" notifyOtherSuperUsers $ groupStr <> " listing resumed by " <> viewName (localDisplayName' ct) _ -> sendReply $ "The group " <> groupRef <> " is not suspended, can't be resumed." DCListLastGroups count -> listGroups count False DCListPendingGroups count -> listGroups count True DCShowGroupLink groupId gName -> do let groupRef = groupReference' groupId gName withGroupAndReg sendReply groupId gName $ \_ _ -> sendChatCmd cc (APIGetGroupLink groupId) >>= \case CRGroupLink {connReqContact, memberRole} -> sendReply $ T.unlines [ "The link to join the group " <> groupRef <> ":", strEncodeTxt $ simplexChatContact connReqContact, "New member role: " <> strEncodeTxt memberRole ] CRChatCmdError _ (ChatErrorStore (SEGroupLinkNotFound _)) -> sendReply $ "The group " <> groupRef <> " has no public link." r -> do ts <- getCurrentTime tz <- getCurrentTimeZone let resp = T.pack $ serializeChatResponse (Nothing, Just user) ts tz Nothing r sendReply $ "Unexpected error:\n" <> resp DCSendToGroupOwner groupId gName msg -> do let groupRef = groupReference' groupId gName withGroupAndReg sendReply groupId gName $ \_ gr@GroupReg {dbContactId} -> do notifyOwner gr msg owner_ <- getContact cc dbContactId let ownerInfo = "the owner of the group " <> groupRef ownerName ct' = "@" <> viewName (localDisplayName' ct') <> ", " sendReply $ "Forwarded to " <> maybe "" ownerName owner_ <> ownerInfo DCCommandError tag -> sendReply $ "Command error: " <> tshow tag | otherwise = sendReply "You are not allowed to use this command" where knownCt = knownContact ct sendReply = mkSendReply ct ciId notifyOtherSuperUsers s = withSuperUsers $ \ctId -> unless (ctId == contactId' ct) $ sendMessage' cc ctId s listGroups count pending = readTVarIO (groupRegs st) >>= \groups -> do grs <- if pending then filterM (fmap pendingApproval . readTVarIO . groupRegStatus) groups else pure groups sendReply $ tshow (length grs) <> " registered group(s)" <> (if length grs > count then ", showing the last " <> tshow 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 deSuperUserCommand :: Contact -> ChatItemId -> DirectoryCmd 'DRSuperUser -> IO () deSuperUserCommand ct ciId cmd | knownContact ct `elem` superUsers = case cmd of DCExecuteCommand cmdStr -> sendChatCmdStr cc cmdStr >>= \r -> do ts <- getCurrentTime tz <- getCurrentTimeZone sendReply $ T.pack $ serializeChatResponse (Nothing, Just user) ts tz Nothing r DCCommandError tag -> sendReply $ "Command error: " <> tshow tag | otherwise = sendReply "You are not allowed to use this command" where sendReply = mkSendReply ct ciId knownContact :: Contact -> KnownContact knownContact ct = KnownContact {contactId = contactId' ct, localDisplayName = localDisplayName' ct} mkSendReply :: Contact -> ChatItemId -> Text -> IO () mkSendReply ct ciId = sendComposedMessage cc ct (Just ciId) . MCText withGroupAndReg :: (Text -> IO ()) -> GroupId -> GroupName -> (GroupInfo -> GroupReg -> IO ()) -> IO () withGroupAndReg sendReply gId gName action = getGroup cc gId >>= \case Nothing -> sendReply $ "Group ID " <> tshow gId <> " not found (getGroup)" Just g@GroupInfo {groupProfile = GroupProfile {displayName}} | displayName == gName -> atomically (getGroupReg st gId) >>= \case Nothing -> sendReply $ "Registration for group ID " <> tshow gId <> " not found (getGroupReg)" Just gr -> action g gr | otherwise -> sendReply $ "Group ID " <> tshow gId <> " has the display name " <> displayName 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 setGroupLinkRole :: ChatController -> GroupId -> GroupMemberRole -> IO (Maybe ConnReqContact) setGroupLinkRole cc gId mRole = resp <$> sendChatCmd cc (APIGroupLinkMemberRole gId mRole) where resp = \case CRGroupLink _ _ gLink _ -> Just gLink _ -> Nothing unexpectedError :: Text -> Text unexpectedError err = "Unexpected error: " <> err <> ", please notify the developers." strEncodeTxt :: StrEncoding a => a -> Text strEncodeTxt = safeDecodeUtf8 . strEncode