{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} module Directory.Service ( welcomeGetOpts, directoryService, directoryServiceCLI, ) where import Control.Concurrent (forkIO) import Control.Concurrent.STM import Control.Exception (SomeException, try) import Control.Logger.Simple import Control.Monad import Control.Monad.Except import Control.Monad.IO.Class import qualified Data.Attoparsec.Text as A import Data.Bifunctor (first) import Data.Either (fromRight) import Data.List (find, intercalate) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Map.Strict as M import Data.Maybe (fromMaybe, isJust, isNothing) import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime) import Data.Time.LocalTime (getCurrentTimeZone) import Directory.BlockedWords import Directory.Captcha import Directory.Events import Directory.Listing import Directory.Options import Directory.Search import Directory.Store import Directory.Store.Migrate import Directory.Util import Simplex.Chat.Bot import Simplex.Chat.Bot.KnownContacts import Simplex.Chat.Controller import Simplex.Chat.Core import Simplex.Chat.Markdown (Format (..), FormattedText (..), parseMaybeMarkdownList, viewName) import Simplex.Chat.Messages import Simplex.Chat.Options import Simplex.Chat.Protocol (MsgContent (..), memberSupportVoiceVersion) import Simplex.Chat.Store.Direct (getContact) import Simplex.Chat.Store.Groups (getGroupLink, getGroupMember, setGroupCustomData) -- TODO remove setGroupCustomData import Simplex.Chat.Store.Profiles (GroupLinkInfo (..), getGroupLinkInfo) import Simplex.Chat.Store.Shared (StoreError (..)) import Simplex.Chat.Terminal (terminalChatConfig) import Simplex.Chat.Terminal.Main (simplexChatCLI') import Simplex.Chat.Types import Simplex.Chat.Types.Preferences import Simplex.Chat.Types.Shared import Simplex.Chat.View (serializeChatError, serializeChatResponse, simplexChatContact, viewContactName, viewGroupName) import Simplex.Messaging.Agent.Protocol (AConnectionLink (..), ConnectionLink (..), CreatedConnLink (..), SConnectionMode (..), sameConnReqContact, sameShortLinkContact) import qualified Simplex.Messaging.Crypto.File as CF import Simplex.Messaging.Encoding.String import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Util (eitherToMaybe, raceAny_, safeDecodeUtf8, tshow, unlessM, (<$$>)) import System.Directory (getAppUserDataDirectory, removeFile) import System.Exit (exitFailure) import System.Process (readProcess) import Text.Read (readMaybe) data GroupProfileUpdate = GPNoServiceLink | GPServiceLinkAdded {linkNow :: Text} | GPServiceLinkRemoved | GPHasServiceLink {linkBefore :: Text, linkNow :: Text} | 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, blockedWordsCfg :: BlockedWordsConfig, pendingCaptchas :: TMap GroupMemberId PendingCaptcha, updateListingsJob :: TMVar ChatController } data CaptchaMode = CMText | CMAudio data PendingCaptcha = PendingCaptcha { captchaText :: Text, sentAt :: UTCTime, attempts :: Int, captchaMode :: CaptchaMode } captchaLength :: Int captchaLength = 7 maxCaptchaAttempts :: Int maxCaptchaAttempts = 5 captchaTTL :: NominalDiffTime captchaTTL = 600 -- 10 minutes newServiceState :: DirectoryOpts -> IO ServiceState newServiceState opts = do searchRequests <- TM.emptyIO blockedWordsCfg <- readBlockedWordsConfig opts pendingCaptchas <- TM.emptyIO updateListingsJob <- newEmptyTMVarIO pure ServiceState {searchRequests, blockedWordsCfg, pendingCaptchas, updateListingsJob} welcomeGetOpts :: IO DirectoryOpts welcomeGetOpts = do appDir <- getAppUserDataDirectory "simplex" opts@DirectoryOpts {coreOptions, testing, superUsers, adminUsers, ownersGroup} <- getDirectoryOpts appDir "simplex_directory_service" unless testing $ do putStrLn $ "SimpleX Directory Service Bot v" ++ versionNumber printDbOpts coreOptions putStrLn $ knownContacts "superuser" superUsers putStrLn $ knownContacts "admin user" adminUsers putStrLn $ case ownersGroup of Nothing -> "No owner's group" Just KnownGroup {groupId, localDisplayName = n} -> "Owners' group: " <> knownName groupId n pure opts where knownContacts userType = \case [] -> "No " <> userType <> "s" cts -> show (length cts) <> " " <> userType <> "(s): " <> intercalate ", " (map knownContact cts) knownContact KnownContact {contactId, localDisplayName = n} = knownName contactId n knownName i n = show i <> ":" <> T.unpack (viewName n) directoryServiceCLI :: DirectoryLog -> DirectoryOpts -> IO () directoryServiceCLI st opts = do env <- newServiceState opts eventQ <- newTQueueIO let eventHook cc resp = atomically $ resp <$ writeTQueue eventQ (cc, resp) chatHooks = defaultChatHooks { preStartHook = Just $ directoryPreStartHook opts, postStartHook = Just $ directoryPostStartHook opts env, eventHook = Just eventHook, acceptMember = Just $ acceptMemberHook opts env } raceAny_ $ [ simplexChatCLI' terminalChatConfig {chatHooks} (mkChatOpts opts) Nothing, processEvents eventQ env ] <> updateListingsThread_ opts env where processEvents eventQ env = forever $ do (cc, resp) <- atomically $ readTQueue eventQ u_ <- readTVarIO (currentUser cc) forM_ u_ $ \user -> directoryServiceEvent st opts env user cc resp updateListingDelay :: Int updateListingDelay = 5 * 60 * 1000000 -- update every 5 minutes updateListingsThread_ :: DirectoryOpts -> ServiceState -> [IO ()] updateListingsThread_ opts env = maybe [] (\f -> [updateListingsThread f]) $ webFolder opts where updateListingsThread f = do cc <- atomically $ takeTMVar $ updateListingsJob env forever $ do u <- readTVarIO $ currentUser cc forM_ u $ \user -> updateGroupListingFiles cc user f delay <- registerDelay updateListingDelay atomically $ void (takeTMVar $ updateListingsJob env) `orElse` unlessM (readTVar delay) retry listingsUpdated :: ServiceState -> ChatController -> IO () listingsUpdated env = void . atomically . tryPutTMVar (updateListingsJob env) directoryPreStartHook :: DirectoryOpts -> ChatController -> IO () directoryPreStartHook opts ChatController {config, chatStore} = runDirectoryMigrations opts config chatStore directoryPostStartHook :: DirectoryOpts -> ServiceState -> ChatController -> IO () directoryPostStartHook opts@DirectoryOpts {noAddress, testing} env cc = readTVarIO (currentUser cc) >>= \case Nothing -> putStrLn "No current user" >> exitFailure Just User {userId, profile = p@LocalProfile {preferences}} -> do unless noAddress $ initializeBotAddress' (not testing) cc listingsUpdated env cc let cmds = fromMaybe [] $ preferences >>= commands_ unless (cmds == directoryCommands) $ do let prefs = (fromMaybe emptyChatPrefs preferences) {files = Just FilesPreference {allow = FANo}, commands = Just directoryCommands} :: Preferences p' = (fromLocalProfile p) {displayName = serviceName opts, peerType = Just CPTBot, preferences = Just prefs} :: Profile liftIO $ sendChatCmd cc (APIUpdateProfile userId p') >>= \case Right CRUserProfileUpdated {} -> putStrLn "Updated directory commands" Right r -> putStrLn ("Error: unexpected response " <> show r) >> exitFailure Left e -> putStrLn ("Error: " <> show e) >> exitFailure directoryCommands :: [ChatBotCommand] directoryCommands = [ CBCCommand "new" "New groups" Nothing, CBCCommand "help" "How to submit your group" Nothing, CBCCommand "list" "Your own groups" Nothing, CBCMenu "Group settings" [ CBCCommand "role" "View new member role" idParam, CBCCommand "filter" "Anti-spam filter" idParam, CBCCommand "link" "View and upgrade group link" idParam, CBCCommand "delete" "Remove a group from directory" (Just ":''") ] ] where idParam = Just "" directoryService :: DirectoryLog -> DirectoryOpts -> ChatConfig -> IO () directoryService st opts cfg = do env <- newServiceState opts let chatHooks = defaultChatHooks { preStartHook = Just $ directoryPreStartHook opts, postStartHook = Just $ directoryPostStartHook opts env, acceptMember = Just $ acceptMemberHook opts env } simplexChatCore cfg {chatHooks} (mkChatOpts opts) $ \user cc -> raceAny_ $ [ forever $ void getLine, forever $ do (_, resp) <- atomically . readTBQueue $ outputQ cc directoryServiceEvent st opts env user cc resp ] <> updateListingsThread_ opts env acceptMemberHook :: DirectoryOpts -> ServiceState -> GroupInfo -> GroupLinkInfo -> Profile -> IO (Either GroupRejectionReason (GroupAcceptance, GroupMemberRole)) acceptMemberHook DirectoryOpts {profileNameLimit} ServiceState {blockedWordsCfg} g GroupLinkInfo {memberRole} Profile {displayName, image = img} = runExceptT $ do let a = groupMemberAcceptance g when (useMemberFilter img $ rejectNames a) checkName pure $ if | useMemberFilter img (passCaptcha a) -> (GAPendingApproval, GRMember) | useMemberFilter img (makeObserver a) -> (GAAccepted, GRObserver) | otherwise -> (GAAccepted, memberRole) where checkName :: ExceptT GroupRejectionReason IO () checkName | T.length displayName > profileNameLimit = throwError GRRLongName | otherwise = do when (hasBlockedFragments blockedWordsCfg displayName) $ throwError GRRBlockedName when (hasBlockedWords blockedWordsCfg displayName) $ throwError GRRBlockedName groupMemberAcceptance :: GroupInfo -> DirectoryMemberAcceptance groupMemberAcceptance GroupInfo {customData} = (\DirectoryGroupData {memberAcceptance = ma} -> ma) $ fromCustomData customData useMemberFilter :: Maybe ImageData -> Maybe ProfileCondition -> Bool useMemberFilter img_ = \case Just PCAll -> True Just PCNoImage -> maybe True (\(ImageData i) -> i == "") img_ Nothing -> False readBlockedWordsConfig :: DirectoryOpts -> IO BlockedWordsConfig readBlockedWordsConfig DirectoryOpts {blockedFragmentsFile, blockedWordsFile, nameSpellingFile, blockedExtensionRules, testing} = do extensionRules <- maybe (pure []) (fmap read . readFile) blockedExtensionRules spelling <- maybe (pure M.empty) (fmap (M.fromList . read) . readFile) nameSpellingFile blockedFragments <- S.fromList <$> maybe (pure []) (fmap T.lines . T.readFile) blockedFragmentsFile bws <- maybe (pure []) (fmap lines . readFile) blockedWordsFile let blockedWords = S.fromList $ concatMap (wordVariants extensionRules) bws unless testing $ putStrLn $ "Blocked fragments: " <> show (length blockedFragments) <> ", blocked words: " <> show (length blockedWords) <> ", spelling rules: " <> show (M.size spelling) pure BlockedWordsConfig {blockedFragments, blockedWords, extensionRules, spelling} directoryServiceEvent :: DirectoryLog -> DirectoryOpts -> ServiceState -> User -> ChatController -> Either ChatError ChatEvent -> IO () directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName, ownersGroup, searchResults} env@ServiceState {searchRequests} user@User {userId} cc event = forM_ (crDirectoryEvent event) $ \case DEContactConnected ct -> deContactConnected ct DEGroupInvitation {contact = ct, groupInfo = g, fromMemberRole, memberRole} -> deGroupInvitation ct g fromMemberRole memberRole DEServiceJoinedGroup ctId g owner -> deServiceJoinedGroup ctId g owner DEGroupUpdated {member, fromGroup, toGroup} -> deGroupUpdated member fromGroup toGroup DEPendingMember g m -> dePendingMember g m DEPendingMemberMsg g m ciId t -> dePendingMemberMsg g m ciId t 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 -> deGroupDeleted g DEUnsupportedMessage _ct _ciId -> pure () DEItemEditIgnored _ct -> pure () DEItemDeleteIgnored _ct -> pure () DEContactCommand ct ciId (ADC sUser cmd) -> do logInfo $ "command received " <> directoryCmdTag cmd case sUser of SDRUser -> deUserCommand ct ciId cmd SDRAdmin -> deAdminCommand ct ciId cmd SDRSuperUser -> deSuperUserCommand ct ciId cmd DELogChatResponse r -> logInfo r where groupLinkText (CCLink cReq sLnk_) = maybe (strEncodeTxt $ simplexChatContact cReq) strEncodeTxt sLnk_ 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 = sendMessage' cc . dbContactId ctId `isOwner` GroupReg {dbContactId} = ctId == dbContactId withGroupReg :: GroupInfo -> Text -> (GroupReg -> IO ()) -> IO () withGroupReg GroupInfo {groupId, localDisplayName} err action = getGroupReg cc groupId >>= \case Right gr -> action gr Left e -> do let msg = "Error: " <> err <> ", group: " <> tshow groupId <> " " <> localDisplayName <> ", " <> T.pack e notifyAdminUsers msg logError msg groupInfoText p@GroupProfile {description = d} = groupNameDescr p <> maybe "" ("\nWelcome message:\n" <>) d knockingStr :: Maybe GroupMemberAdmission -> [Text] knockingStr = \case Just GroupMemberAdmission {review = Just MCAll} -> ["New members are reviewed by admins"] _ -> [] groupNameDescr GroupProfile {displayName = n, fullName = fn, shortDescr = sd_} = n <> maybe "" (\d' -> " (" <> d' <> ")") descr where descr | n == fn || T.null fn = if sd_ == Just "" then Nothing else sd_ | otherwise = Just fn 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 = p} = "The group " <> groupNameDescr p <> " is already listed in the directory, please choose another name." getDuplicateGroup :: GroupInfo -> IO (Either String DuplicateGroup) getDuplicateGroup GroupInfo {groupId, groupProfile = GroupProfile {displayName}} = duplicateGroup <$$> getDuplicateGroupRegs cc user displayName where duplicateGroup [] = DGUnique duplicateGroup ((GroupInfo {groupId = gId, membership}, GroupReg {groupRegStatus = status}) : groups) | gId == groupId || memberRemoved membership = duplicateGroup groups | otherwise = case grDirectoryStatus status of DSListed -> DGReserved DSReserved -> DGReserved DSRegistered -> case duplicateGroup groups of DGReserved -> DGReserved _ -> DGRegistered DSRemoved -> duplicateGroup groups processInvitation :: Contact -> GroupInfo -> Maybe GroupReg -> IO () processInvitation ct g@GroupInfo {groupId, groupProfile = GroupProfile {displayName}} = \case Nothing -> addGroupReg notifyAdminUsers st cc ct g GRSProposed joinGroup Just _gr -> setGroupStatus notifyAdminUsers st env cc groupId GRSProposed joinGroup where joinGroup _ = do r <- sendChatCmd cc $ APIJoinGroup groupId MFNone sendMessage cc ct $ case r of Right 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 <> "!\n\n") <> "🔍 Send search string to find groups - try _security_.\n\ \/help - how to submit your group.\n\ \/new - recent groups.\n\n\ \[Directory rules](https://simplex.chat/docs/directory.html)." deGroupInvitation :: Contact -> GroupInfo -> GroupMemberRole -> GroupMemberRole -> IO () deGroupInvitation ct g@GroupInfo {groupProfile = p@GroupProfile {displayName}} 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 Right DGUnique -> processInvitation ct g Nothing Right DGRegistered -> askConfirmation Right DGReserved -> sendMessage cc ct $ groupAlreadyListed g Left e -> sendMessage cc ct $ "Error: getDuplicateGroup. Please notify the developers.\n" <> T.pack e where askConfirmation = addGroupReg notifyAdminUsers st cc ct g GRSPendingConfirmation $ \GroupReg {userGroupRegId} -> do sendMessage cc ct $ "The group " <> groupNameDescr p <> " is already submitted to the directory.\nTo confirm the registration, please send:" sendMessage cc ct $ "/confirm " <> tshow userGroupRegId <> ":" <> viewName displayName 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 (Either String GroupRolesStatus) getGroupRolesStatus GroupInfo {groupId, membership = GroupMember {memberRole = serviceRole}} gr = rStatus <$$> getOwnerGroupMember groupId 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 getOwnerGroupMember :: GroupId -> GroupReg -> IO (Either String GroupMember) getOwnerGroupMember gId GroupReg {dbOwnerMemberId} = case dbOwnerMemberId of Just mId -> withDB "getGroupMember" cc $ \db -> withExceptT show $ getGroupMember db (vr cc) user gId mId Nothing -> pure $ Left "no owner member in group registration" deServiceJoinedGroup :: ContactId -> GroupInfo -> GroupMember -> IO () deServiceJoinedGroup ctId g@GroupInfo {groupId} owner = do logInfo $ "service joined group " <> viewGroupName g withGroupReg g "joined group" $ \gr -> when (ctId `isOwner` gr) $ do let GroupInfo {groupProfile = GroupProfile {displayName}} = g setGroupRegOwner cc groupId owner >>= \case Left e -> do let msg = "Error updating group " <> tshow groupId <> " owner: " <> T.pack e logError msg notifyOwner gr msg Right () -> do logGUpdateOwner st groupId $ groupMemberId' owner notifyOwner gr $ "Joined the group " <> displayName <> ", creating the link…" sendChatCmd cc (APICreateGroupLink groupId GRMember) >>= \case Right CRGroupLinkCreated {groupLink = GroupLink {connLinkContact = gLink}} -> setGroupStatus notifyAdminUsers st env cc groupId GRSPendingUpdate $ \gr' -> do 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 <> ": " <> groupLinkText gLink Left (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 :: GroupMember -> GroupInfo -> GroupInfo -> IO () deGroupUpdated m@GroupMember {memberProfile = LocalProfile {displayName = mName}} fromGroup toGroup = do logInfo $ "group updated " <> viewGroupName toGroup unless (sameProfile p p') $ do withGroupReg toGroup "group updated" $ \gr@GroupReg {groupRegStatus} -> do let userGroupRef = userGroupReference gr toGroup byMember = case memberContactId m of Just ctId | ctId `isOwner` gr -> "" -- group registration owner, not any group owner. _ -> " by " <> mName -- owner notification from directory will include the name. case groupRegStatus of GRSPendingConfirmation -> pure () GRSProposed -> pure () GRSPendingUpdate -> groupProfileUpdate >>= \case GPNoServiceLink -> notifyOwner gr $ "The profile updated for " <> userGroupRef <> byMember <> ", but the group link is not added to the welcome message." GPServiceLinkAdded _ -> groupLinkAdded gr byMember GPServiceLinkRemoved -> notifyOwner gr $ "The group link of " <> userGroupRef <> " is removed from the welcome message" <> byMember <> ", please add it." GPHasServiceLink {} -> groupLinkAdded gr byMember GPServiceLinkError -> do notifyOwner gr $ ("Error: " <> serviceName <> " has no group link for " <> userGroupRef) <> " after profile was updated" <> byMember <> ". Please report the error to the developers." logError $ "Error: no group link for " <> userGroupRef GRSPendingApproval n -> processProfileChange gr byMember False $ n + 1 GRSActive -> processProfileChange gr byMember True 1 GRSSuspended -> processProfileChange gr byMember False 1 GRSSuspendedBadRoles -> processProfileChange gr byMember False 1 GRSRemoved -> pure () where GroupInfo {groupId, groupProfile = p} = fromGroup GroupInfo {groupProfile = p'} = toGroup sameProfile GroupProfile {displayName = n, fullName = fn, shortDescr = sd, image = i, description = d, memberAdmission = ma} GroupProfile {displayName = n', fullName = fn', shortDescr = sd', image = i', description = d', memberAdmission = ma'} = n == n' && fn == fn' && i == i' && sd == sd' && (T.words <$> d) == (T.words <$> d') && ma == ma' groupLinkAdded gr byMember = getDuplicateGroup toGroup >>= \case Left e -> notifyOwner gr $ "Error: getDuplicateGroup. Please notify the developers.\n" <> T.pack e Right DGReserved -> notifyOwner gr $ groupAlreadyListed toGroup _ -> setGroupStatus notifyAdminUsers st env cc groupId (GRSPendingApproval gaId) $ \gr' -> do notifyOwner gr' $ ("Thank you! The group link for " <> userGroupReference gr' toGroup <> " is added to the welcome message" <> byMember) <> ".\nYou will be notified once the group is added to the directory - it may take up to 48 hours." checkRolesSendToApprove gr' gaId where gaId = 1 processProfileChange gr byMember isActive n' = do let userGroupRef = userGroupReference gr toGroup groupRef = groupReference toGroup groupProfileUpdate >>= \case GPNoServiceLink -> setGroupStatus notifyAdminUsers st env cc groupId GRSPendingUpdate $ \gr' -> do notifyOwner gr' $ ("The group profile is updated for " <> userGroupRef <> byMember <> ", but no link is added to the welcome message.\n\n") <> "The group will remain hidden from the directory until the group link is added and the group is re-approved." GPServiceLinkRemoved -> setGroupStatus notifyAdminUsers st env cc groupId GRSPendingUpdate $ \gr' -> do notifyOwner gr' $ ("The group link for " <> userGroupRef <> " is removed from the welcome message" <> byMember) <> ".\n\nThe group is hidden from the directory until the group link is added and the group is re-approved." notifyAdminUsers $ "The group link is removed from " <> groupRef <> ", de-listed." GPServiceLinkAdded _ -> setGroupStatus notifyAdminUsers st env cc groupId (GRSPendingApproval n') $ \gr' -> do notifyOwner gr' $ ("The group link is added to " <> userGroupRef <> byMember) <> "!\nIt is hidden from the directory until approved." notifyAdminUsers $ "The group link is added to " <> groupRef <> byMember <> "." checkRolesSendToApprove gr n' GPHasServiceLink {linkBefore, linkNow} | isActive && onlyLinkChanged p p' -> do notifyOwner gr $ ("The group " <> userGroupRef <> " is updated" <> byMember) <> "!\nThe group is listed in directory." notifyAdminUsers $ "The group " <> groupRef <> " is updated" <> byMember <> " - only link or whitespace changes.\nThe group remained listed in directory." | otherwise -> setGroupStatus notifyAdminUsers st env cc groupId (GRSPendingApproval n') $ \gr' -> do notifyOwner gr' $ ("The group " <> userGroupRef <> " is updated" <> byMember) <> "!\nIt is hidden from the directory until approved." notifyAdminUsers $ "The group " <> groupRef <> " is updated" <> byMember <> "." checkRolesSendToApprove gr' n' where onlyLinkChanged GroupProfile {displayName = dn, fullName = fn, shortDescr = sd, image = i, description = d, memberAdmission = ma} GroupProfile {displayName = dn', fullName = fn', shortDescr = sd', image = i', description = d', memberAdmission = ma'} = dn == dn' && fn == fn' && i == i' && sd == sd' && ma == ma' && (T.words . T.replace linkBefore "" <$> d) == (T.words . T.replace linkNow "" <$> d') GPServiceLinkError -> logError $ "Error: no group link for " <> groupRef <> " pending approval." groupProfileUpdate = profileUpdate <$> sendChatCmd cc (APIGetGroupLink groupId) where profileUpdate = \case Right CRGroupLink {groupLink = GroupLink {connLinkContact = CCLink cr sl_}} -> let linkBefore_ = profileGroupLinkText fromGroup linkNow_ = profileGroupLinkText toGroup profileGroupLinkText GroupInfo {groupProfile = gp} = maybe Nothing (fmap (\(FormattedText _ t) -> t) . find ftHasLink) $ parseMaybeMarkdownList =<< description gp ftHasLink = \case FormattedText (Just SimplexLink {simplexUri = ACL SCMContact cLink}) _ -> case cLink of CLFull cr' -> sameConnReqContact cr' cr CLShort sl' -> maybe False (sameShortLinkContact sl') sl_ _ -> False in case (linkBefore_, linkNow_) of (Just linkBefore, Just linkNow) -> GPHasServiceLink linkBefore linkNow (Just _, Nothing) -> GPServiceLinkRemoved (Nothing, Just linkNow) -> GPServiceLinkAdded linkNow (Nothing, Nothing) -> GPNoServiceLink _ -> GPServiceLinkError checkRolesSendToApprove gr gaId = do (badRolesMsg <$$> getGroupRolesStatus toGroup gr) >>= \case Left e -> notifyOwner gr $ "Error: getGroupRolesStatus. Please notify the developers.\n" <> T.pack e Right (Just msg) -> notifyOwner gr msg Right Nothing -> sendToApprove toGroup gr gaId dePendingMember :: GroupInfo -> GroupMember -> IO () dePendingMember g@GroupInfo {groupProfile = GroupProfile {displayName}} m | memberRequiresCaptcha a m = sendMemberCaptcha g m Nothing captchaNotice 0 CMText | otherwise = approvePendingMember a g m where a = groupMemberAcceptance g captchaNotice = "Captcha is generated by SimpleX Directory service.\n\n*Send captcha text* to join the group " <> displayName <> "." <> if canSendVoiceCaptcha g m then "\nSend /audio to receive a voice captcha." else "" sendMemberCaptcha :: GroupInfo -> GroupMember -> Maybe ChatItemId -> Text -> Int -> CaptchaMode -> IO () sendMemberCaptcha GroupInfo {groupId} m quotedId noticeText prevAttempts mode = do s <- getCaptchaStr captchaLength "" sentAt <- getCurrentTime let captcha = PendingCaptcha {captchaText = T.pack s, sentAt, attempts = prevAttempts + 1, captchaMode = mode} atomically $ TM.insert gmId captcha $ pendingCaptchas env case mode of CMAudio -> do mc <- getCaptchaContent s sendComposedMessages_ cc sendRef [(quotedId, MCText noticeText), (Nothing, mc)] sendVoiceCaptcha sendRef s CMText -> do mc <- getCaptchaContent s sendComposedMessages_ cc sendRef [(quotedId, MCText noticeText), (Nothing, mc)] where sendRef = SRGroup groupId (Just $ GCSMemberSupport (Just gmId)) False gmId = groupMemberId' m sendVoiceCaptcha :: SendRef -> String -> IO () sendVoiceCaptcha sendRef s = forM_ (voiceCaptchaGenerator opts) $ \script -> void . forkIO $ do voiceResult <- try $ readProcess script [s] "" :: IO (Either SomeException String) case voiceResult of Right r -> case lines r of (filePath : durationStr : _) | not (null filePath), Just duration <- readMaybe durationStr -> do sendComposedMessageFile cc sendRef Nothing (MCVoice "" duration) (CF.plain filePath) void (try $ removeFile filePath :: IO (Either SomeException ())) _ -> logError "voice captcha generator: unexpected output" Left e -> logError $ "voice captcha generator error: " <> tshow e getCaptchaContent :: String -> IO MsgContent getCaptchaContent s = case captchaGenerator opts of Nothing -> pure $ MCText $ T.pack s Just script -> content <$> readProcess script [s] "" where content r = case T.lines $ T.pack r of [] -> textMsg "" : _ -> textMsg img : _ -> MCImage "" $ ImageData img textMsg = MCText $ T.pack s canSendVoiceCaptcha :: GroupInfo -> GroupMember -> Bool canSendVoiceCaptcha gInfo m = isJust (voiceCaptchaGenerator opts) && (groupFeatureUserAllowed SGFVoice gInfo || supportsVersion m memberSupportVoiceVersion) approvePendingMember :: DirectoryMemberAcceptance -> GroupInfo -> GroupMember -> IO () approvePendingMember a g@GroupInfo {groupId} m@GroupMember {memberProfile = LocalProfile {displayName, image}} = do gli_ <- join . eitherToMaybe <$> withDB' "getGroupLinkInfo" cc (\db -> getGroupLinkInfo db userId groupId) let role = if useMemberFilter image (makeObserver a) then GRObserver else maybe GRMember (\GroupLinkInfo {memberRole} -> memberRole) gli_ gmId = groupMemberId' m sendChatCmd cc (APIAcceptMember groupId gmId role) >>= \case Right CRMemberAccepted {member} -> do atomically $ TM.delete gmId $ pendingCaptchas env if memberStatus member == GSMemPendingReview then logInfo $ "Member " <> viewName displayName <> " accepted and pending review, group " <> tshow groupId <> ":" <> viewGroupName g else logInfo $ "Member " <> viewName displayName <> " accepted, group " <> tshow groupId <> ":" <> viewGroupName g r -> logError $ "unexpected accept member response: " <> tshow r dePendingMemberMsg :: GroupInfo -> GroupMember -> ChatItemId -> Text -> IO () dePendingMemberMsg g@GroupInfo {groupId, groupProfile = GroupProfile {displayName = n}} m@GroupMember {memberProfile = LocalProfile {displayName}} ciId msgText | memberRequiresCaptcha a m = do let gmId = groupMemberId' m sendRef = SRGroup groupId (Just $ GCSMemberSupport (Just gmId)) False -- /audio is matched as text, not as DirectoryCmd, because it is only valid -- in group context at captcha stage, while DirectoryCmd is for DM commands. isAudioCmd = T.strip msgText == "/audio" cmd = fromRight (ADC SDRUser DCUnknownCommand) $ A.parseOnly (directoryCmdP <* A.endOfInput) $ T.strip msgText atomically (TM.lookup gmId $ pendingCaptchas env) >>= \case Nothing | isAudioCmd && canSendVoiceCaptcha g m -> sendMemberCaptcha g m (Just ciId) noCaptcha 0 CMAudio | isAudioCmd -> sendComposedMessages_ cc sendRef [(Just ciId, MCText voiceCaptchaUnavailable)] | otherwise -> sendMemberCaptcha g m (Just ciId) noCaptcha 0 CMText Just pc@PendingCaptcha {captchaText, sentAt, attempts, captchaMode} | isAudioCmd -> if canSendVoiceCaptcha g m then case captchaMode of CMText -> do atomically $ TM.insert gmId pc {captchaMode = CMAudio} $ pendingCaptchas env sendVoiceCaptcha sendRef (T.unpack captchaText) CMAudio -> sendComposedMessages_ cc sendRef [(Just ciId, MCText audioAlreadyEnabled)] else sendComposedMessages_ cc sendRef [(Just ciId, MCText voiceCaptchaUnavailable)] | otherwise -> case cmd of ADC SDRUser (DCSearchGroup _) -> do ts <- getCurrentTime if | ts `diffUTCTime` sentAt > captchaTTL -> sendMemberCaptcha g m (Just ciId) captchaExpired (attempts - 1) captchaMode | matchCaptchaStr captchaText msgText -> do sendComposedMessages_ cc sendRef [(Just ciId, MCText $ "Correct, you joined the group " <> n)] approvePendingMember a g m | attempts >= maxCaptchaAttempts -> rejectPendingMember tooManyAttempts | otherwise -> sendMemberCaptcha g m (Just ciId) (wrongCaptcha attempts) attempts captchaMode _ -> sendComposedMessages_ cc sendRef [(Just ciId, MCText unknownCommand)] | otherwise = approvePendingMember a g m where a = groupMemberAcceptance g rejectPendingMember rjctNotice = do let gmId = groupMemberId' m sendComposedMessages cc (SRGroup groupId (Just $ GCSMemberSupport (Just gmId)) False) [MCText rjctNotice] sendChatCmd cc (APIRemoveMembers groupId [gmId] False) >>= \case Right (CRUserDeletedMembers _ _ (_ : _) _ _) -> do atomically $ TM.delete gmId $ pendingCaptchas env logInfo $ "Member " <> viewName displayName <> " rejected, group " <> tshow groupId <> ":" <> viewGroupName g r -> logError $ "unexpected remove member response: " <> tshow r captchaExpired :: Text captchaExpired = "Captcha expired, please try again." wrongCaptcha :: Int -> Text wrongCaptcha attempts | attempts == maxCaptchaAttempts - 1 = "Incorrect text, please try again - this is your last attempt." | otherwise = "Incorrect text, please try again." noCaptcha :: Text noCaptcha = "Unexpected message, please try again." audioAlreadyEnabled :: Text audioAlreadyEnabled = "Audio captcha is already enabled." voiceCaptchaUnavailable :: Text voiceCaptchaUnavailable = "Voice captcha is not available - please update SimpleX Chat to v6.5+ or use text captcha." unknownCommand :: Text unknownCommand = "Unknown command, please enter captcha text." tooManyAttempts :: Text tooManyAttempts = "Too many failed attempts, you can't join group." memberRequiresCaptcha :: DirectoryMemberAcceptance -> GroupMember -> Bool memberRequiresCaptcha a GroupMember {memberProfile = LocalProfile {image}} = useMemberFilter image $ passCaptcha a sendToApprove :: GroupInfo -> GroupReg -> GroupApprovalId -> IO () sendToApprove GroupInfo {groupId, groupProfile = p@GroupProfile {displayName, image = image'}, groupSummary} GroupReg {dbContactId, promoted} gaId = do ct_ <- getContact' cc user dbContactId let membersStr = "_" <> tshow (currentMembers groupSummary) <> " members_\n" text = either (\_ -> "The group ID " <> tshow groupId <> " submitted: ") (\c -> localDisplayName' c <> " submitted the group ID " <> tshow groupId <> ": ") ct_ <> ("\n" <> groupInfoText p <> "\n" <> membersStr <> "\nTo approve send:") msg = maybe (MCText text) (\image -> MCImage {text, image}) image' withAdminUsers $ \cId -> do let approveCmd = MCText $ "/approve " <> tshow groupId <> ":" <> viewName displayName <> " " <> tshow gaId <> if promoted then " promote=on" else "" sendComposedMessages cc (SRDirect cId) [msg, approveCmd] deContactRoleChanged :: GroupInfo -> ContactId -> GroupMemberRole -> IO () deContactRoleChanged g@GroupInfo {groupId, 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@GroupReg {groupRegStatus} -> do let userGroupRef = userGroupReference gr g uCtRole = "Your role in the group " <> userGroupRef <> " is changed to " <> ctRole when (ctId `isOwner` gr) $ case groupRegStatus of GRSSuspendedBadRoles | rStatus == GRSOk -> setGroupStatus notifyAdminUsers st env cc groupId GRSActive $ \gr' -> do notifyOwner gr' $ uCtRole <> ".\n\nThe group is listed in the directory again." notifyAdminUsers $ "The group " <> groupRef <> " is listed " <> suCtRole GRSPendingApproval gaId | rStatus == GRSOk -> do sendToApprove g gr gaId notifyOwner gr $ uCtRole <> ".\n\nThe group is submitted for approval." GRSActive | rStatus /= GRSOk -> setGroupStatus notifyAdminUsers st env cc groupId GRSSuspendedBadRoles $ \gr' -> do 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 = "*" <> textEncode contactRole <> "*" suCtRole = "(user role is set to " <> ctRole <> ")." deServiceRoleChanged :: GroupInfo -> GroupMemberRole -> IO () deServiceRoleChanged g@GroupInfo {groupId} serviceRole = do logInfo $ "service role changed in group " <> viewGroupName g <> " to " <> tshow serviceRole withGroupReg g "service role changed" $ \gr@GroupReg {groupRegStatus} -> do let userGroupRef = userGroupReference gr g uSrvRole = serviceName <> " role in the group " <> userGroupRef <> " is changed to " <> srvRole case groupRegStatus of GRSSuspendedBadRoles | serviceRole == GRAdmin -> whenContactIsOwner gr $ setGroupStatus notifyAdminUsers st env cc groupId GRSActive $ \gr' -> do notifyOwner gr' $ uSrvRole <> ".\n\nThe group is listed in the directory again." notifyAdminUsers $ "The group " <> groupRef <> " is listed " <> suSrvRole GRSPendingApproval gaId | serviceRole == GRAdmin -> whenContactIsOwner gr $ do sendToApprove g gr gaId notifyOwner gr $ uSrvRole <> ".\n\nThe group is submitted for approval." GRSActive | serviceRole /= GRAdmin -> setGroupStatus notifyAdminUsers st env cc groupId GRSSuspendedBadRoles $ \gr' -> do 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 = "*" <> textEncode serviceRole <> "*" suSrvRole = "(" <> serviceName <> " role is changed to " <> srvRole <> ")." whenContactIsOwner gr action = getOwnerGroupMember groupId gr >>= mapM_ (\cm@GroupMember {memberRole} -> when (memberRole == GROwner && memberActive cm) action) deContactRemovedFromGroup :: ContactId -> GroupInfo -> IO () deContactRemovedFromGroup ctId g@GroupInfo {groupId} = do logInfo $ "contact ID " <> tshow ctId <> " removed from group " <> viewGroupName g withGroupReg g "contact removed" $ \gr -> do when (ctId `isOwner` gr) $ setGroupStatus notifyAdminUsers st env cc groupId GRSRemoved $ \gr' -> do 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@GroupInfo {groupId} = do logInfo $ "contact ID " <> tshow ctId <> " left group " <> viewGroupName g -- TODO combine withGroupReg g "contact left" $ \gr -> when (ctId `isOwner` gr) $ setGroupStatus notifyAdminUsers st env cc groupId GRSRemoved $ \gr' -> do 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@GroupInfo {groupId} = do logInfo $ "service removed from group " <> viewGroupName g setGroupStatus notifyAdminUsers st env cc groupId GRSRemoved $ \gr -> do 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)." deGroupDeleted :: GroupInfo -> IO () deGroupDeleted g@GroupInfo {groupId} = do logInfo $ "group removed " <> viewGroupName g setGroupStatus notifyAdminUsers st env cc groupId GRSRemoved $ \gr -> do notifyOwner gr $ "The group " <> userGroupReference gr g <> " is deleted.\n\nThe group is no longer listed in the directory." notifyAdminUsers $ "The group " <> groupReference g <> " is de-listed (group is deleted)." deUserCommand :: Contact -> ChatItemId -> DirectoryCmd 'DRUser -> IO () deUserCommand ct ciId = \case DCHelp DHSRegistration -> sendMessage cc ct $ "You must be the group owner to add it to the directory:\n\n\ \1️⃣ *Invite* " <> serviceName <> " bot to your group as *admin* - it will create a link for new members to join.\n\ \2️⃣ *Add* this link to the group's welcome message.\n\ \3️⃣ We *review* your group. Once *approved*, anybody can find it.\n\n\ \_We usually approve within a day, except holidays_. [More details](https://simplex.chat/docs/directory.html#adding-groups-to-the-directory)." DCHelp DHSCommands -> sendMessage cc ct $ "/'help commands' - receive this help message.\n\ \/help - how to register your group to be added to directory.\n\ \/list - list the groups you registered.\n\ \`/role ` - view and set default member role for your group.\n\ \`/filter ` - view and set spam filter settings for group.\n\ \`/link ` - view and upgrade group link.\n\ \`/delete :` - remove the group you submitted from directory, with _ID_ and _name_ as shown by /list command.\n\n\ \To search for groups, send the search text." DCSearchGroup s -> sendFoundListedGroups (STSearch s) Nothing "No groups found" $ \gs n -> -- $ sendSearchResults s let more = if n > length gs then ", sending top " <> tshow (length gs) else "" in "Found " <> tshow n <> " group(s)" <> more <> "." DCSearchNext -> atomically (TM.lookup (contactId' ct) searchRequests) >>= \case Just SearchRequest {searchType, searchTime, lastGroup} -> do currentTime <- getCurrentTime if diffUTCTime currentTime searchTime > 300 -- 5 minutes then do atomically $ TM.delete (contactId' ct) searchRequests showAllGroups else sendFoundListedGroups searchType (Just lastGroup) "No more groups" $ \gs _ -> "Sending " <> tshow (length gs) <> " more group(s)." Nothing -> showAllGroups where showAllGroups = deUserCommand ct ciId DCAllGroups DCAllGroups -> sendFoundListedGroups STAll Nothing "No groups listed" $ allGroupsReply "top" DCRecentGroups -> sendFoundListedGroups STRecent Nothing "No groups listed" $ allGroupsReply "the most recent" DCSubmitGroup _link -> pure () DCConfirmDuplicateGroup ugrId gName -> withUserGroupReg ugrId gName $ \g@GroupInfo {groupProfile = GroupProfile {displayName}} gr@GroupReg {groupRegStatus} -> case groupRegStatus of GRSPendingConfirmation -> getDuplicateGroup g >>= \case Left e -> sendMessage cc ct $ "Error: getDuplicateGroup. Please notify the developers.\n" <> T.pack e Right DGReserved -> sendMessage cc ct $ groupAlreadyListed g _ -> processInvitation ct g $ Just gr _ -> sendReply $ "Error: the group ID " <> tshow ugrId <> " (" <> displayName <> ") is not pending confirmation." DCListUserGroups -> getUserGroupRegs cc user (contactId' ct) >>= \case Left e -> sendReply $ "Error reading groups: " <> T.pack e Right gs -> sendGroupsInfo ct ciId isAdmin (gs, length gs) DCDeleteGroup gId gName -> (if isAdmin then withGroupAndReg sendReply else withUserGroupReg) gId gName $ \GroupInfo {groupProfile = GroupProfile {displayName}} GroupReg {dbGroupId} -> do delGroupReg cc dbGroupId >>= \case Right () -> do logGDelete st dbGroupId sendReply $ (if isAdmin then "The group " else "Your group ") <> displayName <> " is deleted from the directory" Left e -> sendReply $ "Error deleting group " <> displayName <> ": " <> T.pack e DCMemberRole gId gName_ mRole_ -> (if isAdmin then withGroupAndReg_ sendReply else withUserGroupReg_) gId gName_ $ \g _gr -> do let GroupInfo {groupProfile = GroupProfile {displayName = n}} = g case mRole_ of Nothing -> getGroupLink' cc user g >>= \case Right GroupLink {connLinkContact = gLink, acceptMemberRole} -> do let anotherRole = case acceptMemberRole of GRObserver -> GRMember; _ -> GRObserver sendReply $ initialRole n acceptMemberRole <> ("Send /'role " <> tshow gId <> " " <> textEncode anotherRole <> "' to change it.\n\n") <> onlyViaLink gLink Left _ -> sendReply $ "Error: failed reading the initial member role for the group " <> n Just mRole -> do setGroupLinkRole cc g mRole >>= \case Just gLink -> sendReply $ initialRole n mRole <> "\n" <> onlyViaLink gLink Nothing -> sendReply $ "Error: the initial member role for the group " <> n <> " was NOT upgated." where initialRole n mRole = "The initial member role for the group " <> n <> " is set to *" <> textEncode mRole <> "*\n" onlyViaLink gLink = "*Please note*: it applies only to members joining via this link: " <> groupLinkText gLink DCGroupFilter gId gName_ acceptance_ -> (if isAdmin then withGroupAndReg_ sendReply else withUserGroupReg_) gId gName_ $ \g _gr -> do let GroupInfo {groupProfile = GroupProfile {displayName = n}} = g a = groupMemberAcceptance g case acceptance_ of Just a' | a /= a' -> do let d = toCustomData $ DirectoryGroupData a' withDB' "setGroupCustomData" cc (\db -> setGroupCustomData db user g $ Just d) >>= \case Right () -> sendSettigns n a' " set to" Left e -> sendReply $ "Error changing spam filter settings for group " <> n <> ": " <> T.pack e _ -> sendSettigns n a "" where sendSettigns n a setTo = sendReply $ T.unlines $ [ "Spam filter settings for group " <> n <> setTo <> ":", "- reject long/inappropriate names: " <> showCondition (rejectNames a), "- pass captcha to join: " <> showCondition (passCaptcha a), -- "- make observer: " <> showCondition (makeObserver a) <> (if isJust (makeObserver a) then "" else " (use default set with /role command)"), "" -- "Use */filter " <> tshow gId <> " * to change spam filter level: no (disable), basic, moderate, strong.", -- "Or use */filter " <> tshow gId <> " [name[=noimage]] [captcha[=noimage]] [observer[=noimage]]* for advanced filter configuration." ] <> ["/'filter " <> tshow gId <> " name' - enable name filter" | isNothing (rejectNames a)] <> ["/'filter " <> tshow gId <> " captcha' - enable captcha challenge" | isNothing (passCaptcha a)] <> ["/'filter " <> tshow gId <> " name captcha' - enable both" | isNothing (rejectNames a) || isNothing (passCaptcha a)] <> ["/'filter " <> tshow gId <> " off' - disable filter" | isJust (rejectNames a) || isJust (passCaptcha a)] showCondition = \case Nothing -> "_disabled_" Just PCAll -> "_enabled_" Just PCNoImage -> "_enabled for profiles without image_" DCShowUpgradeGroupLink gId gName_ -> (if isAdmin then withGroupAndReg_ sendReply else withUserGroupReg_) gId gName_ $ \GroupInfo {groupId, localDisplayName = gName} _ -> do let groupRef = groupReference' gId gName withGroupLinkResult groupRef (sendChatCmd cc $ APIGetGroupLink groupId) $ \GroupLink {connLinkContact = gLink@(CCLink _ sLnk_), acceptMemberRole, shortLinkDataSet, shortLinkLargeDataSet = BoolDef slLargeDataSet} -> do let shouldBeUpgraded = isNothing sLnk_ || not shortLinkDataSet || not slLargeDataSet sendReply $ T.unlines $ [ "The link to join the group " <> groupRef <> ":", groupLinkText gLink, "New member role: " <> textEncode acceptMemberRole ] <> ["The link is being upgraded..." | shouldBeUpgraded] when shouldBeUpgraded $ do let send = sendComposedMessage cc ct Nothing . MCText . T.unlines withGroupLinkResult groupRef (sendChatCmd cc $ APIAddGroupShortLink groupId) $ \GroupLink {connLinkContact = CCLink _ sLnk_'} -> case (sLnk_, sLnk_') of (Just _, Just _) -> send ["The group link is upgraded for: " <> groupRef, "No changes to group needed."] (Nothing, Just sLnk) -> sendComposedMessages cc (SRDirect $ contactId' ct) [ MCText $ T.unlines [ "Please replace the old link in welcome message of your group " <> groupRef, "If this is the only change, the group will remain listed in directory without re-approval.", "", "The new link:" ], MCText $ strEncodeTxt sLnk ] (_, Nothing) -> send ["The short link is not created for " <> groupRef, "Please report it to the developers."] where withGroupLinkResult groupRef a cb = a >>= \case Right CRGroupLink {groupLink} -> cb groupLink Left (ChatErrorStore (SEGroupLinkNotFound _)) -> sendReply $ "The group " <> groupRef <> " has no public link." Right r -> do ts <- getCurrentTime tz <- getCurrentTimeZone let resp = T.pack $ serializeChatResponse (Nothing, Just user) (config cc) ts tz Nothing r sendReply $ "Unexpected error:\n" <> resp Left e -> do let resp = T.pack $ serializeChatError True (config cc) e sendReply $ "Unexpected error:\n" <> resp DCUnknownCommand -> sendReply "Unknown command" DCCommandError tag -> sendReply $ "Command error: " <> tshow tag where knownCt = knownContact ct isAdmin = knownCt `elem` adminUsers || knownCt `elem` superUsers withUserGroupReg ugrId = withUserGroupReg_ ugrId . Just withUserGroupReg_ ugrId gName_ action = getUserGroupReg cc user (contactId' ct) ugrId >>= \case -- TODO differentiate group not found error Left e -> sendReply $ "Group ID " <> tshow ugrId <> " error:" <> T.pack e Right (g@GroupInfo {groupProfile = GroupProfile {displayName}}, gr) | maybe True (displayName ==) gName_ -> action g gr | otherwise -> sendReply $ "Group ID " <> tshow ugrId <> " has the display name " <> displayName sendReply = mkSendReply ct ciId sendFoundListedGroups searchType lastGroup_ notFound replyStr = searchListedGroups cc user searchType lastGroup_ searchResults >>= \case Right ([], _) -> do atomically $ TM.delete (contactId' ct) searchRequests sendReply notFound Right (gs, n) -> do let moreGroups = n - length gs updateSearchRequest searchType $ last gs sendFoundGroups (replyStr gs n) gs moreGroups Left e -> sendReply $ "Error: searchListedGroups. Please notify the developers.\n" <> T.pack e allGroupsReply sortName gs n = let more = if n > length gs then ", sending " <> sortName <> " " <> tshow (length gs) else "" in tshow n <> " group(s) listed" <> more <> "." updateSearchRequest :: SearchType -> (GroupInfo, GroupReg) -> IO () updateSearchRequest searchType (GroupInfo {groupId}, _) = do searchTime <- getCurrentTime let search = SearchRequest {searchType, searchTime, lastGroup = groupId} atomically $ TM.insert (contactId' ct) search searchRequests sendFoundGroups reply gs moreGroups = void . forkIO $ sendComposedMessages_ cc (SRDirect $ contactId' ct) msgs where msgs = replyMsg :| map foundGroup gs <> [moreMsg | moreGroups > 0] replyMsg = (Just ciId, MCText reply) foundGroup (GroupInfo {groupId, groupProfile = p@GroupProfile {image = image_, memberAdmission}, groupSummary = GroupSummary {currentMembers}}, _) = let membersStr = "_" <> tshow currentMembers <> " members_" showId = if isAdmin then tshow groupId <> ". " else "" text = T.unlines $ [showId <> groupInfoText p, membersStr] ++ knockingStr memberAdmission in (Nothing, maybe (MCText text) (\image -> MCImage {text, image}) image_) moreMsg = (Nothing, MCText $ "Send /next 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, promote} -> withGroupAndReg sendReply groupId n $ \g gr@GroupReg {userGroupRegId = ugrId, promoted} -> case groupRegStatus gr of GRSPendingApproval gaId | gaId == groupApprovalId -> getDuplicateGroup g >>= \case Left e -> sendReply $ "Error: getDuplicateGroup. Please notify the developers.\n" <> T.pack e Right DGReserved -> sendReply $ "The group " <> groupRef <> " is already listed in the directory." _ -> getGroupRolesStatus g gr >>= \case Right GRSOk -> do let grPromoted' | promoted || knownCt `elem` superUsers = fromMaybe promoted promote | otherwise = False setGroupStatusPromo sendReply st env cc gr GRSActive grPromoted' $ do let approved = "The group " <> userGroupReference' gr n <> " is approved" notifyOwner gr $ (approved <> " and listed in directory - please moderate it!\n") <> "_Please note_: if you change the group profile it will be hidden from directory until it is re-approved.\n\n" <> "Supported commands:\n" <> ("/'filter " <> tshow ugrId <> "' - to configure anti-spam filter.\n") <> ("/'role " <> tshow ugrId <> "' - to set default member role.\n") <> ("/'link " <> tshow ugrId <> "' - to view/upgrade group link.") invited <- forM ownersGroup $ \og@KnownGroup {localDisplayName = ogName} -> do inviteToOwnersGroup og gr $ \case Right () -> do owner <- groupOwnerInfo groupRef $ dbContactId gr pure $ "Invited " <> owner <> " to owners' group " <> viewName ogName Left err -> pure err sendReply $ "Group approved" <> (if grPromoted' then " (promoted)" else "") <> "!" <> maybe "" ("\n" <>) invited notifyOtherSuperUsers $ approved <> " by " <> viewName (localDisplayName' ct) <> maybe "" ("\n" <>) invited Right GRSServiceNotAdmin -> replyNotApproved serviceNotAdmin Right GRSContactNotOwner -> replyNotApproved "user is not an owner." Right GRSBadRoles -> replyNotApproved $ "user is not an owner, " <> serviceNotAdmin Left e -> sendReply $ "Error: getGroupRolesStatus. Please notify the developers.\n" <> T.pack e 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 -> case groupRegStatus gr of GRSActive -> setGroupStatus sendReply st env cc groupId GRSSuspended $ \gr' -> do let suspended = "The group " <> userGroupReference' gr gName <> " is suspended" notifyOwner gr' $ suspended <> " and hidden from directory. Please contact the administrators." sendReply "Group suspended!" 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 -> case groupRegStatus gr of GRSSuspended -> setGroupStatus sendReply st env cc groupId GRSActive $ \gr' -> do let groupStr = "The group " <> userGroupReference' gr gName notifyOwner gr' $ groupStr <> " is listed in the directory again!" sendReply "Group listing resumed!" notifyOtherSuperUsers $ groupStr <> " listing resumed by " <> viewName (localDisplayName' ct) _ -> sendReply $ "The group " <> groupRef <> " is not suspended, can't be resumed." DCListLastGroups count -> listLastGroups cc user count >>= \case Left e -> sendReply $ "Error reading groups: " <> T.pack e Right gs -> sendGroupsInfo ct ciId True $ first reverse gs DCListPendingGroups count -> listPendingGroups cc user count >>= \case Left e -> sendReply $ "Error reading groups: " <> T.pack e Right gs -> sendGroupsInfo ct ciId True $ first reverse gs DCSendToGroupOwner groupId gName msg -> do let groupRef = groupReference' groupId gName withGroupAndReg sendReply groupId gName $ \_ gr@GroupReg {dbContactId = ctId} -> do notifyOwner gr msg owner <- groupOwnerInfo groupRef ctId sendReply $ "Forwarded to " <> owner DCInviteOwnerToGroup groupId gName -> case ownersGroup of Just og@KnownGroup {localDisplayName = ogName} -> withGroupAndReg sendReply groupId gName $ \_ gr@GroupReg {dbContactId = ctId} -> do inviteToOwnersGroup og gr $ \case Right () -> do let groupRef = groupReference' groupId gName owner <- groupOwnerInfo groupRef ctId let invited = " invited " <> owner <> " to owners' group " <> viewName ogName notifyOtherSuperUsers $ viewName (localDisplayName' ct) <> invited sendReply $ "you" <> invited Left err -> sendReply err Nothing -> sendReply "owners' group is not specified" -- DCAddBlockedWord _word -> pure () -- DCRemoveBlockedWord _word -> pure () 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 inviteToOwnersGroup :: KnownGroup -> GroupReg -> (Either Text () -> IO a) -> IO a inviteToOwnersGroup KnownGroup {groupId = ogId} GroupReg {dbContactId = ctId} cont = sendChatCmd cc (APIListMembers ogId) >>= \case Right (CRGroupMembers _ (Group _ ms)) | alreadyMember ms -> cont $ Left "Owner is already a member of owners' group" | otherwise -> do sendChatCmd cc (APIAddMember ogId ctId GRMember) >>= \case Right CRSentGroupInvitation {} -> do printLog cc CLLInfo $ "invited contact ID " <> show ctId <> " to owners' group" cont $ Right () r -> contErr r r -> contErr r where alreadyMember = isJust . find ((Just ctId ==) . memberContactId) contErr r = do let err = "error inviting contact ID " <> tshow ctId <> " to owners' group: " <> tshow r putStrLn $ T.unpack err cont $ Left err groupOwnerInfo groupRef dbContactId = do owner_ <- getContact' cc user dbContactId let ownerInfo = "the owner of the group " <> groupRef ownerName ct' = "@" <> viewName (localDisplayName' ct') <> ", " pure $ either (const "") ownerName owner_ <> ownerInfo deSuperUserCommand :: Contact -> ChatItemId -> DirectoryCmd 'DRSuperUser -> IO () deSuperUserCommand ct ciId cmd | knownContact ct `elem` superUsers = case cmd of DCPromoteGroup groupId gName promote' -> withGroupAndReg sendReply groupId gName $ \_ gr@GroupReg {groupRegStatus, promoted} -> do let notify = sendReply $ "Group promotion " <> (if promote' then "enabled" <> (if groupRegStatus == GRSActive then "." else ", but the group is not listed.") else "disabled.") if promote' /= promoted then setGroupPromoted sendReply st env cc gr promote' notify else notify DCExecuteCommand cmdStr -> sendChatCmdStr cc cmdStr >>= \case Right r -> do ts <- getCurrentTime tz <- getCurrentTimeZone sendReply $ T.pack $ serializeChatResponse (Nothing, Just user) (config cc) ts tz Nothing r Left e -> sendReply $ T.pack $ serializeChatError True (config cc) e 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 = withGroupAndReg_ sendReply gId . Just withGroupAndReg_ :: (Text -> IO ()) -> GroupId -> Maybe GroupName -> (GroupInfo -> GroupReg -> IO ()) -> IO () withGroupAndReg_ sendReply gId gName_ action = getGroupAndReg cc user gId >>= \case Left e -> sendReply $ "Group " <> tshow gId <> " error (getGroup): " <> T.pack e Right (g@GroupInfo {groupProfile = GroupProfile {displayName}}, gr) | maybe False (displayName ==) gName_ -> action g gr | otherwise -> sendReply $ "Group ID " <> tshow gId <> " has the display name " <> displayName getOwnersInfo :: [(GroupInfo, GroupReg)] -> IO [((GroupInfo, GroupReg), Maybe (Either String Contact))] getOwnersInfo gs = fmap (either (\e -> map (,Just (Left e)) gs) id) $ withDB' "getOwnersInfo" cc $ \db -> mapM (\g@(_, gr) -> fmap ((g,) . Just . first show) $ runExceptT $ getContact db (vr cc) user $ dbContactId gr) gs sendGroupsInfo :: Contact -> ChatItemId -> Bool -> ([(GroupInfo, GroupReg)], Int) -> IO () sendGroupsInfo ct ciId isAdmin (gs, n) = do let more = if n > length gs then ", showing the last " <> tshow (length gs) else "" replyMsg = (Just ciId, MCText $ tshow n <> " registered group(s)" <> more) gs' <- if isAdmin then getOwnersInfo gs else pure $ map (,Nothing) gs sendComposedMessages_ cc (SRDirect $ contactId' ct) $ replyMsg :| map groupMessage gs' where groupMessage ((g, gr), ct_) = let GroupInfo {groupId, groupProfile = p@GroupProfile {image = image_, memberAdmission}, groupSummary} = g GroupReg {userGroupRegId, groupRegStatus} = gr useGroupId = if isAdmin then groupId else userGroupRegId statusStr = "Status: " <> groupRegStatusText groupRegStatus membersStr = "_" <> tshow (currentMembers groupSummary) <> " members_" cmds = "/'role " <> tshow useGroupId <> "', /'filter " <> tshow useGroupId <> "'" ownerStr = maybe "" (("Owner: " <>) . either (("getContact error: " <>) . T.pack) localDisplayName') ct_ text = T.unlines $ [tshow useGroupId <> ". " <> groupInfoText p] ++ [ownerStr | isAdmin] ++ [membersStr, statusStr] ++ knockingStr memberAdmission ++ [cmds] msg = maybe (MCText text) (\image -> MCImage {text, image}) image_ in (Nothing, msg) setGroupStatusPromo :: (Text -> IO ()) -> DirectoryLog -> ServiceState -> ChatController -> GroupReg -> GroupRegStatus -> Bool -> IO () -> IO () setGroupStatusPromo sendReply st env cc GroupReg {dbGroupId = gId} grStatus' grPromoted' continue = do let status' = grDirectoryStatus grStatus' setGroupStatusPromoStore cc gId grStatus' grPromoted' >>= \case Left e -> sendReply $ "Error updating group " <> tshow gId <> " status: " <> T.pack e Right (status, grPromoted) -> do when ((status == DSListed || status' == DSListed) && (status /= status' || grPromoted /= grPromoted')) $ listingsUpdated env cc logGUpdateStatus st gId grStatus' logGUpdatePromotion st gId grPromoted' continue addGroupReg :: (Text -> IO ()) -> DirectoryLog -> ChatController -> Contact -> GroupInfo -> GroupRegStatus -> (GroupReg -> IO ()) -> IO () addGroupReg sendMsg st cc ct g@GroupInfo {groupId} grStatus continue = addGroupRegStore cc ct g grStatus >>= \case Left e -> sendMsg $ "Error creating group registation for group " <> tshow groupId <> ": " <> T.pack e Right gr -> do logGCreate st gr continue gr setGroupStatus :: (Text -> IO ()) -> DirectoryLog -> ServiceState -> ChatController -> GroupId -> GroupRegStatus -> (GroupReg -> IO ()) -> IO () setGroupStatus sendMsg st env cc gId grStatus' continue = do let status' = grDirectoryStatus grStatus' setGroupStatusStore cc gId grStatus' >>= \case Left e -> sendMsg $ "Error updating group " <> tshow gId <> " status: " <> T.pack e Right (grStatus, gr) -> do let status = grDirectoryStatus grStatus when ((status == DSListed || status' == DSListed) && status /= status') $ listingsUpdated env cc logGUpdateStatus st gId grStatus' continue gr setGroupPromoted :: (Text -> IO ()) -> DirectoryLog -> ServiceState -> ChatController -> GroupReg -> Bool -> IO () -> IO () setGroupPromoted sendReply st env cc GroupReg {dbGroupId = gId} grPromoted' continue = setGroupPromotedStore cc gId grPromoted' >>= \case Left e -> sendReply $ "Error updating group " <> tshow gId <> " status: " <> T.pack e Right (status, grPromoted) -> do when (status == DSListed && grPromoted' /= grPromoted) $ listingsUpdated env cc logGUpdatePromotion st gId grPromoted' continue updateGroupListingFiles :: ChatController -> User -> FilePath -> IO () updateGroupListingFiles cc u dir = getAllListedGroups cc u >>= \case Right gs -> generateListing dir gs Left e -> logError $ "generateListing error: failed to read groups: " <> T.pack e getContact' :: ChatController -> User -> ContactId -> IO (Either String Contact) getContact' cc user ctId = withDB "getContact" cc $ \db -> withExceptT show $ getContact db (vr cc) user ctId getGroupLink' :: ChatController -> User -> GroupInfo -> IO (Either String GroupLink) getGroupLink' cc user gInfo = withDB "getGroupLink" cc $ \db -> withExceptT groupDBError $ getGroupLink db user gInfo setGroupLinkRole :: ChatController -> GroupInfo -> GroupMemberRole -> IO (Maybe CreatedLinkContact) setGroupLinkRole cc GroupInfo {groupId} mRole = resp <$> sendChatCmd cc (APIGroupLinkMemberRole groupId mRole) where resp = \case Right (CRGroupLink {groupLink = GroupLink {connLinkContact}}) -> Just connLinkContact _ -> Nothing unexpectedError :: Text -> Text unexpectedError err = "Unexpected error: " <> err <> ", please notify the developers." strEncodeTxt :: StrEncoding a => a -> Text strEncodeTxt = safeDecodeUtf8 . strEncode