android-apps-mirrors/SimpleX-Chat
0
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2025-06-28 20:29:53 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

commands for filter settings

Browse source
This commit is contained in:
Evgeny Poberezkin 2025-03-02 22:21:19 +00:00
parent 1ec0b7e79c
commit 01fa04ea3c
No known key found for this signature in database
GPG key ID: 494BDDD9A28B577D
4 changed files with 124 additions and 83 deletions
Download patch file Download diff file Expand all files Collapse all files

36
apps/simplex-directory-service/src/Directory/Events.hs
View file

@ -118,8 +118,8 @@ data DirectoryCmdTag (r :: DirectoryRole) where
DCConfirmDuplicateGroup_ :: DirectoryCmdTag 'DRUser DCConfirmDuplicateGroup_ :: DirectoryCmdTag 'DRUser
DCListUserGroups_ :: DirectoryCmdTag 'DRUser DCListUserGroups_ :: DirectoryCmdTag 'DRUser
DCDeleteGroup_ :: DirectoryCmdTag 'DRUser DCDeleteGroup_ :: DirectoryCmdTag 'DRUser
DCSetRole_ :: DirectoryCmdTag 'DRUser DCMemberRole_ :: DirectoryCmdTag 'DRUser
DCSetFilter_ :: DirectoryCmdTag 'DRUser DCGroupFilter_ :: DirectoryCmdTag 'DRUser
DCApproveGroup_ :: DirectoryCmdTag 'DRAdmin DCApproveGroup_ :: DirectoryCmdTag 'DRAdmin
DCRejectGroup_ :: DirectoryCmdTag 'DRAdmin DCRejectGroup_ :: DirectoryCmdTag 'DRAdmin
DCSuspendGroup_ :: DirectoryCmdTag 'DRAdmin DCSuspendGroup_ :: DirectoryCmdTag 'DRAdmin
@ -147,8 +147,8 @@ data DirectoryCmd (r :: DirectoryRole) where
DCConfirmDuplicateGroup :: UserGroupRegId -> GroupName -> DirectoryCmd 'DRUser DCConfirmDuplicateGroup :: UserGroupRegId -> GroupName -> DirectoryCmd 'DRUser
DCListUserGroups :: DirectoryCmd 'DRUser DCListUserGroups :: DirectoryCmd 'DRUser
DCDeleteGroup :: UserGroupRegId -> GroupName -> DirectoryCmd 'DRUser DCDeleteGroup :: UserGroupRegId -> GroupName -> DirectoryCmd 'DRUser
DCSetRole :: UserGroupRegId -> Maybe GroupName -> GroupMemberRole -> DirectoryCmd 'DRUser DCMemberRole :: UserGroupRegId -> Maybe GroupName -> Maybe GroupMemberRole -> DirectoryCmd 'DRUser
DCSetFilter :: UserGroupRegId -> Maybe GroupName -> Maybe DirectoryMemberAcceptance -> DirectoryCmd 'DRUser DCGroupFilter :: UserGroupRegId -> Maybe GroupName -> Maybe DirectoryMemberAcceptance -> DirectoryCmd 'DRUser
DCApproveGroup :: {groupId :: GroupId, displayName :: GroupName, groupApprovalId :: GroupApprovalId} -> DirectoryCmd 'DRAdmin DCApproveGroup :: {groupId :: GroupId, displayName :: GroupName, groupApprovalId :: GroupApprovalId} -> DirectoryCmd 'DRAdmin
DCRejectGroup :: GroupId -> GroupName -> DirectoryCmd 'DRAdmin DCRejectGroup :: GroupId -> GroupName -> DirectoryCmd 'DRAdmin
DCSuspendGroup :: GroupId -> GroupName -> DirectoryCmd 'DRAdmin DCSuspendGroup :: GroupId -> GroupName -> DirectoryCmd 'DRAdmin
@ -191,8 +191,8 @@ directoryCmdP =
"list" -> u DCListUserGroups_ "list" -> u DCListUserGroups_
"ls" -> u DCListUserGroups_ "ls" -> u DCListUserGroups_
"delete" -> u DCDeleteGroup_ "delete" -> u DCDeleteGroup_
"role" -> u DCSetRole_ "role" -> u DCMemberRole_
"filter" -> u DCSetFilter_ "filter" -> u DCGroupFilter_
"approve" -> au DCApproveGroup_ "approve" -> au DCApproveGroup_
"reject" -> au DCRejectGroup_ "reject" -> au DCRejectGroup_
"suspend" -> au DCSuspendGroup_ "suspend" -> au DCSuspendGroup_
@ -221,14 +221,16 @@ directoryCmdP =
DCConfirmDuplicateGroup_ -> gc DCConfirmDuplicateGroup DCConfirmDuplicateGroup_ -> gc DCConfirmDuplicateGroup
DCListUserGroups_ -> pure DCListUserGroups DCListUserGroups_ -> pure DCListUserGroups
DCDeleteGroup_ -> gc DCDeleteGroup DCDeleteGroup_ -> gc DCDeleteGroup
DCSetRole_ -> do DCMemberRole_ -> do
(groupId, displayName_) <- gc_ (,) (groupId, displayName_) <- gc_ (,)
memberRole <- spacesP *> ("member" $> GRMember <|> "observer" $> GRObserver) memberRole_ <- optional $ spacesP *> ("member" $> GRMember <|> "observer" $> GRObserver)
pure $ DCSetRole groupId displayName_ memberRole pure $ DCMemberRole groupId displayName_ memberRole_
DCSetFilter_ -> do DCGroupFilter_ -> do
(groupId, displayName_) <- gc_ (,) (groupId, displayName_) <- gc_ (,)
acceptance_ <- optional $ acceptancePresetsP <|> acceptanceFiltersP acceptance_ <-
pure $ DCSetFilter groupId displayName_ acceptance_ (A.takeWhile (== ' ') >> A.endOfInput) $> Nothing
<|> Just <$> (acceptancePresetsP <|> acceptanceFiltersP)
pure $ DCGroupFilter groupId displayName_ acceptance_
where where
acceptancePresetsP = acceptancePresetsP =
spacesP spacesP
@ -239,10 +241,10 @@ directoryCmdP =
"strong" $> strongJoinFilter "strong" $> strongJoinFilter
] ]
acceptanceFiltersP = do acceptanceFiltersP = do
filterNames <- filterP "name" rejectNames <- filterP "name"
useCaptcha <- filterP "captcha" passCaptcha <- filterP "captcha"
makeObserver <- filterP "observer" makeObserver <- filterP "observer"
pure DirectoryMemberAcceptance {filterNames, useCaptcha, makeObserver} pure DirectoryMemberAcceptance {rejectNames, passCaptcha, makeObserver}
filterP :: Text -> Parser (Maybe ProfileCondition) filterP :: Text -> Parser (Maybe ProfileCondition)
filterP s = Just <$> (spacesP *> A.string s *> conditionP) <|> pure Nothing filterP s = Just <$> (spacesP *> A.string s *> conditionP) <|> pure Nothing
conditionP = conditionP =
@ -288,8 +290,8 @@ directoryCmdTag = \case
DCListUserGroups -> "list" DCListUserGroups -> "list"
DCDeleteGroup {} -> "delete" DCDeleteGroup {} -> "delete"
DCApproveGroup {} -> "approve" DCApproveGroup {} -> "approve"
DCSetRole {} -> "role" DCMemberRole {} -> "role"
DCSetFilter {} -> "filter" DCGroupFilter {} -> "filter"
DCRejectGroup {} -> "reject" DCRejectGroup {} -> "reject"
DCSuspendGroup {} -> "suspend" DCSuspendGroup {} -> "suspend"
DCResumeGroup {} -> "resume" DCResumeGroup {} -> "resume"

146
apps/simplex-directory-service/src/Directory/Service.hs
View file

@ -25,8 +25,10 @@ import qualified Control.Exception as E
import Control.Logger.Simple import Control.Logger.Simple
import Control.Monad import Control.Monad
import Control.Monad.Except import Control.Monad.Except
import Control.Monad.IO.Class
import Data.Int (Int64)
import Data.List (find, intercalate) import Data.List (find, intercalate)
import qualified Data.List.NonEmpty as L import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe, isJust, maybeToList) import Data.Maybe (fromMaybe, isJust, maybeToList)
import Data.Set (Set) import Data.Set (Set)
@ -49,6 +51,7 @@ import Simplex.Chat.Messages
import Simplex.Chat.Options import Simplex.Chat.Options
import Simplex.Chat.Protocol (MsgContent (..)) import Simplex.Chat.Protocol (MsgContent (..))
import Simplex.Chat.Store.Direct (getContact) import Simplex.Chat.Store.Direct (getContact)
import Simplex.Chat.Store.Groups (getGroupInfo, getGroupLink, getGroupSummary, setGroupCustomData)
import Simplex.Chat.Store.Profiles (GroupLinkInfo (..), getGroupLinkInfo) import Simplex.Chat.Store.Profiles (GroupLinkInfo (..), getGroupLinkInfo)
import Simplex.Chat.Store.Shared (StoreError (..)) import Simplex.Chat.Store.Shared (StoreError (..))
import Simplex.Chat.Terminal (terminalChatConfig) import Simplex.Chat.Terminal (terminalChatConfig)
@ -158,10 +161,10 @@ acceptMemberHook
GroupLinkInfo {memberRole} GroupLinkInfo {memberRole}
Profile {displayName, image = img} = runExceptT $ do Profile {displayName, image = img} = runExceptT $ do
let a = groupMemberAcceptance g let a = groupMemberAcceptance g
when (useMemberFilter img $ filterNames a) checkName when (useMemberFilter img $ rejectNames a) checkName
pure $ pure $
if if
| useMemberFilter img (useCaptcha a) -> (GAManual, GRMember) | useMemberFilter img (passCaptcha a) -> (GAManual, GRMember)
| useMemberFilter img (makeObserver a) -> (GAAuto, GRObserver) | useMemberFilter img (makeObserver a) -> (GAAuto, GRObserver)
| otherwise -> (GAAuto, memberRole) | otherwise -> (GAAuto, memberRole)
-- TODO [captcha] uncomment for testing -- TODO [captcha] uncomment for testing
@ -514,14 +517,14 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
memberRequiresCaptcha :: DirectoryMemberAcceptance -> GroupMember -> Bool memberRequiresCaptcha :: DirectoryMemberAcceptance -> GroupMember -> Bool
memberRequiresCaptcha a GroupMember {memberProfile = LocalProfile {image}} = memberRequiresCaptcha a GroupMember {memberProfile = LocalProfile {image}} =
useMemberFilter image $ useCaptcha a useMemberFilter image $ passCaptcha a
-- TODO [captcha] uncomment for testing -- TODO [captcha] uncomment for testing
-- True -- True
sendToApprove :: GroupInfo -> GroupReg -> GroupApprovalId -> IO () sendToApprove :: GroupInfo -> GroupReg -> GroupApprovalId -> IO ()
sendToApprove GroupInfo {groupProfile = p@GroupProfile {displayName, image = image'}} GroupReg {dbGroupId, dbContactId} gaId = do sendToApprove GroupInfo {groupProfile = p@GroupProfile {displayName, image = image'}} GroupReg {dbGroupId, dbContactId} gaId = do
ct_ <- getContact' cc user dbContactId ct_ <- getContact' cc user dbContactId
gr_ <- getGroupAndSummary cc dbGroupId gr_ <- getGroupAndSummary cc user dbGroupId
let membersStr = maybe "" (\(_, s) -> "_" <> tshow (currentMembers s) <> " members_\n") gr_ let membersStr = maybe "" (\(_, s) -> "_" <> tshow (currentMembers s) <> " members_\n") gr_
text = text =
maybe ("The group ID " <> tshow dbGroupId <> " submitted: ") (\c -> localDisplayName' c <> " submitted the group ID " <> tshow dbGroupId <> ": ") ct_ maybe ("The group ID " <> tshow dbGroupId <> " submitted: ") (\c -> localDisplayName' c <> " submitted the group ID " <> tshow dbGroupId <> ": ") ct_
@ -676,16 +679,54 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
withUserGroupReg ugrId gName $ \GroupInfo {groupProfile = GroupProfile {displayName}} gr -> do withUserGroupReg ugrId gName $ \GroupInfo {groupProfile = GroupProfile {displayName}} gr -> do
delGroupReg st gr delGroupReg st gr
sendReply $ "Your group " <> displayName <> " is deleted from the directory" sendReply $ "Your group " <> displayName <> " is deleted from the directory"
DCSetRole gId gName_ mRole -> DCMemberRole gId gName_ mRole_ ->
(if isAdmin then withGroupAndReg_ sendReply else withUserGroupReg_) gId gName_ $ (if isAdmin then withGroupAndReg_ sendReply else withUserGroupReg_) gId gName_ $ \g _gr -> do
\GroupInfo {groupId, groupProfile = GroupProfile {displayName}} _gr -> do let GroupInfo {groupProfile = GroupProfile {displayName = n}} = g
gLink_ <- setGroupLinkRole cc groupId mRole case mRole_ of
sendReply $ case gLink_ of Nothing ->
Nothing -> "Error: the initial member role for the group " <> displayName <> " was NOT upgated" getGroupLinkRole cc user g >>= \case
Just gLink -> Just (_, gLink, mRole) -> do
("The initial member role for the group " <> displayName <> " is set to *" <> strEncodeTxt mRole <> "*\n\n") let anotherRole = case mRole of GRObserver -> GRMember; _ -> GRObserver
<> ("*Please note*: it applies only to members joining via this link: " <> strEncodeTxt (simplexChatContact gLink)) sendReply $
DCSetFilter gId gName_ acceptance_ -> pure () initialRole n mRole
<> ("Send */role " <> tshow gId <> " " <> strEncodeTxt anotherRole <> "* to change it.\n\n")
<> onlyViaLink gLink
Nothing -> 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 *" <> strEncodeTxt mRole <> "*\n"
onlyViaLink gLink = "*Please note*: it applies only to members joining via this link: " <> strEncodeTxt (simplexChatContact 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' cc (\db -> setGroupCustomData db user g $ Just d) >>= \case
Just () -> sendSettigns n a' " set to"
Nothing -> sendReply $ "Error changing spam filter settings for group " <> n
_ -> 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 <> " <level>* 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."
"Or use */filter " <> tshow gId <> " [name[=noimage]] [captcha[=noimage]]* for advanced filter configuration."
]
showCondition = \case
Nothing -> "_disabled_"
Just PCAll -> "_enabled_"
Just PCNoImage -> "_enabled for profiles without image_"
DCUnknownCommand -> sendReply "Unknown command" DCUnknownCommand -> sendReply "Unknown command"
DCCommandError tag -> sendReply $ "Command error: " <> tshow tag DCCommandError tag -> sendReply $ "Command error: " <> tshow tag
where where
@ -696,7 +737,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
getUserGroupReg st (contactId' ct) ugrId >>= \case getUserGroupReg st (contactId' ct) ugrId >>= \case
Nothing -> sendReply $ "Group ID " <> tshow ugrId <> " not found" Nothing -> sendReply $ "Group ID " <> tshow ugrId <> " not found"
Just gr@GroupReg {dbGroupId} -> do Just gr@GroupReg {dbGroupId} -> do
getGroup cc dbGroupId >>= \case getGroup cc user dbGroupId >>= \case
Nothing -> sendReply $ "Group ID " <> tshow ugrId <> " not found" Nothing -> sendReply $ "Group ID " <> tshow ugrId <> " not found"
Just g@GroupInfo {groupProfile = GroupProfile {displayName}} Just g@GroupInfo {groupProfile = GroupProfile {displayName}}
| maybe True (displayName ==) gName_ -> action g gr | maybe True (displayName ==) gName_ -> action g gr
@ -712,18 +753,18 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
let gs' = takeTop searchResults gs let gs' = takeTop searchResults gs
moreGroups = length gs - length gs' moreGroups = length gs - length gs'
more = if moreGroups > 0 then ", sending top " <> tshow (length gs') else "" more = if moreGroups > 0 then ", sending top " <> tshow (length gs') else ""
sendReply $ "Found " <> tshow (length gs) <> " group(s)" <> more <> "." reply = "Found " <> tshow (length gs) <> " group(s)" <> more <> "."
updateSearchRequest (STSearch s) $ groupIds gs' updateSearchRequest (STSearch s) $ groupIds gs'
sendFoundGroups gs' moreGroups sendFoundGroups reply gs' moreGroups
sendAllGroups takeFirst sortName searchType = \case sendAllGroups takeFirst sortName searchType = \case
[] -> sendReply "No groups listed" [] -> sendReply "No groups listed"
gs -> do gs -> do
let gs' = takeFirst searchResults gs let gs' = takeFirst searchResults gs
moreGroups = length gs - length gs' moreGroups = length gs - length gs'
more = if moreGroups > 0 then ", sending " <> sortName <> " " <> tshow (length gs') else "" more = if moreGroups > 0 then ", sending " <> sortName <> " " <> tshow (length gs') else ""
sendReply $ tshow (length gs) <> " group(s) listed" <> more <> "." reply = tshow (length gs) <> " group(s) listed" <> more <> "."
updateSearchRequest searchType $ groupIds gs' updateSearchRequest searchType $ groupIds gs'
sendFoundGroups gs' moreGroups sendFoundGroups reply gs' moreGroups
sendNextSearchResults takeFirst SearchRequest {searchType, sentGroups} = \case sendNextSearchResults takeFirst SearchRequest {searchType, sentGroups} = \case
[] -> do [] -> do
sendReply "Sorry, no more groups" sendReply "Sorry, no more groups"
@ -732,27 +773,25 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
let gs' = takeFirst searchResults $ filterNotSent sentGroups gs let gs' = takeFirst searchResults $ filterNotSent sentGroups gs
sentGroups' = sentGroups <> groupIds gs' sentGroups' = sentGroups <> groupIds gs'
moreGroups = length gs - S.size sentGroups' moreGroups = length gs - S.size sentGroups'
sendReply $ "Sending " <> tshow (length gs') <> " more group(s)." reply = "Sending " <> tshow (length gs') <> " more group(s)."
updateSearchRequest searchType sentGroups' updateSearchRequest searchType sentGroups'
sendFoundGroups gs' moreGroups sendFoundGroups reply gs' moreGroups
updateSearchRequest :: SearchType -> Set GroupId -> IO () updateSearchRequest :: SearchType -> Set GroupId -> IO ()
updateSearchRequest searchType sentGroups = do updateSearchRequest searchType sentGroups = do
searchTime <- getCurrentTime searchTime <- getCurrentTime
let search = SearchRequest {searchType, searchTime, sentGroups} let search = SearchRequest {searchType, searchTime, sentGroups}
atomically $ TM.insert (contactId' ct) search searchRequests atomically $ TM.insert (contactId' ct) search searchRequests
sendFoundGroups gs moreGroups = sendFoundGroups reply gs moreGroups =
void . forkIO $ do void . forkIO $ sendComposedMessages_ cc (SRDirect $ contactId' ct) msgs
forM_ gs $ where
\(GroupInfo {groupId, groupProfile = p@GroupProfile {image = image_}}, GroupSummary {currentMembers}) -> do msgs = replyMsg :| map foundGroup gs <> [moreMsg | moreGroups > 0]
let membersStr = "_" <> tshow currentMembers <> " members_" replyMsg = (Just ciId, MCText reply)
showId = if isAdmin then tshow groupId <> ". " else "" foundGroup (GroupInfo {groupId, groupProfile = p@GroupProfile {image = image_}}, GroupSummary {currentMembers}) =
text = showId <> groupInfoText p <> "\n" <> membersStr let membersStr = "_" <> tshow currentMembers <> " members_"
msg = maybe (MCText text) (\image -> MCImage {text, image}) image_ showId = if isAdmin then tshow groupId <> ". " else ""
sendComposedMessage cc ct Nothing msg text = showId <> groupInfoText p <> "\n" <> membersStr
when (moreGroups > 0) $ in (Nothing, maybe (MCText text) (\image -> MCImage {text, image}) image_)
sendComposedMessage cc ct Nothing $ moreMsg = (Nothing, MCText $ "Send */next* or just *.* for " <> tshow moreGroups <> " more result(s).")
MCText $
"Send */next* or just *.* for " <> tshow moreGroups <> " more result(s)."
deAdminCommand :: Contact -> ChatItemId -> DirectoryCmd 'DRAdmin -> IO () deAdminCommand :: Contact -> ChatItemId -> DirectoryCmd 'DRAdmin -> IO ()
deAdminCommand ct ciId cmd deAdminCommand ct ciId cmd
@ -918,7 +957,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
withGroupAndReg_ :: (Text -> IO ()) -> GroupId -> Maybe GroupName -> (GroupInfo -> GroupReg -> IO ()) -> IO () withGroupAndReg_ :: (Text -> IO ()) -> GroupId -> Maybe GroupName -> (GroupInfo -> GroupReg -> IO ()) -> IO ()
withGroupAndReg_ sendReply gId gName_ action = withGroupAndReg_ sendReply gId gName_ action =
getGroup cc gId >>= \case getGroup cc user gId >>= \case
Nothing -> sendReply $ "Group ID " <> tshow gId <> " not found (getGroup)" Nothing -> sendReply $ "Group ID " <> tshow gId <> " not found (getGroup)"
Just g@GroupInfo {groupProfile = GroupProfile {displayName}} Just g@GroupInfo {groupProfile = GroupProfile {displayName}}
| maybe False (displayName ==) gName_ -> | maybe False (displayName ==) gName_ ->
@ -932,7 +971,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
sendGroupInfo ct gr@GroupReg {dbGroupId} useGroupId ownerStr_ = do sendGroupInfo ct gr@GroupReg {dbGroupId} useGroupId ownerStr_ = do
grStatus <- readTVarIO $ groupRegStatus gr grStatus <- readTVarIO $ groupRegStatus gr
let statusStr = "Status: " <> groupRegStatusText grStatus let statusStr = "Status: " <> groupRegStatusText grStatus
getGroupAndSummary cc dbGroupId >>= \case getGroupAndSummary cc user dbGroupId >>= \case
Just (GroupInfo {groupProfile = p@GroupProfile {image = image_}}, GroupSummary {currentMembers}) -> do Just (GroupInfo {groupProfile = p@GroupProfile {image = image_}}, GroupSummary {currentMembers}) -> do
let membersStr = "_" <> tshow currentMembers <> " members_" let membersStr = "_" <> tshow currentMembers <> " members_"
text = T.unlines $ [tshow useGroupId <> ". " <> groupInfoText p] <> maybeToList ownerStr_ <> [membersStr, statusStr] text = T.unlines $ [tshow useGroupId <> ". " <> groupInfoText p] <> maybeToList ownerStr_ <> [membersStr, statusStr]
@ -943,16 +982,10 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
sendComposedMessage cc ct Nothing $ MCText text sendComposedMessage cc ct Nothing $ MCText text
getContact' :: ChatController -> User -> ContactId -> IO (Maybe Contact) getContact' :: ChatController -> User -> ContactId -> IO (Maybe Contact)
getContact' cc@ChatController {config = ChatConfig {chatVRange = vr}} user ctId = do getContact' cc user ctId = withDB cc $ \db -> getContact db (vr cc) user ctId
withDB cc $ \db -> getContact db vr user ctId
getGroup :: ChatController -> GroupId -> IO (Maybe GroupInfo) getGroup :: ChatController -> User -> GroupId -> IO (Maybe GroupInfo)
getGroup cc gId = resp <$> sendChatCmd cc (APIGroupInfo gId) getGroup cc user gId = withDB cc $ \db -> getGroupInfo db (vr cc) user gId
where
resp :: ChatResponse -> Maybe GroupInfo
resp = \case
CRGroupInfo {groupInfo} -> Just groupInfo
_ -> Nothing
withDB' :: ChatController -> (DB.Connection -> IO a) -> IO (Maybe a) withDB' :: ChatController -> (DB.Connection -> IO a) -> IO (Maybe a)
withDB' cc a = withDB cc $ ExceptT . fmap Right . a withDB' cc a = withDB cc $ ExceptT . fmap Right . a
@ -964,15 +997,20 @@ withDB ChatController {chatStore} action = do
Right r -> pure $ Just r Right r -> pure $ Just r
Left e -> Nothing <$ logError ("Database error: " <> tshow e) Left e -> Nothing <$ logError ("Database error: " <> tshow e)
getGroupAndSummary :: ChatController -> GroupId -> IO (Maybe (GroupInfo, GroupSummary)) getGroupAndSummary :: ChatController -> User -> GroupId -> IO (Maybe (GroupInfo, GroupSummary))
getGroupAndSummary cc gId = resp <$> sendChatCmd cc (APIGroupInfo gId) getGroupAndSummary cc user gId =
where withDB cc $ \db -> (,) <$> getGroupInfo db (vr cc) user gId <*> liftIO (getGroupSummary db user gId)
resp = \case
CRGroupInfo {groupInfo, groupSummary} -> Just (groupInfo, groupSummary)
_ -> Nothing
setGroupLinkRole :: ChatController -> GroupId -> GroupMemberRole -> IO (Maybe ConnReqContact) vr :: ChatController -> VersionRangeChat
setGroupLinkRole cc gId mRole = resp <$> sendChatCmd cc (APIGroupLinkMemberRole gId mRole) vr ChatController {config = ChatConfig {chatVRange}} = chatVRange
{-# INLINE vr #-}
getGroupLinkRole :: ChatController -> User -> GroupInfo -> IO (Maybe (Int64, ConnReqContact, GroupMemberRole))
getGroupLinkRole cc user gInfo =
withDB cc $ \db -> getGroupLink db user gInfo
setGroupLinkRole :: ChatController -> GroupInfo -> GroupMemberRole -> IO (Maybe ConnReqContact)
setGroupLinkRole cc GroupInfo {groupId} mRole = resp <$> sendChatCmd cc (APIGroupLinkMemberRole groupId mRole)
where where
resp = \case resp = \case
CRGroupLink _ _ gLink _ -> Just gLink CRGroupLink _ _ gLink _ -> Just gLink

24
apps/simplex-directory-service/src/Directory/Store.hs
View file

@ -53,7 +53,7 @@ import qualified Data.Set as S
import Data.Text (Text) import Data.Text (Text)
import Simplex.Chat.Types import Simplex.Chat.Types
import Simplex.Messaging.Encoding.String import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, taggedObjectJSON) import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON)
import Simplex.Messaging.Util (ifM) import Simplex.Messaging.Util (ifM)
import System.Directory (doesFileExist, renameFile) import System.Directory (doesFileExist, renameFile)
import System.IO (BufferMode (..), Handle, IOMode (..), hSetBuffering, openFile) import System.IO (BufferMode (..), Handle, IOMode (..), hSetBuffering, openFile)
@ -91,13 +91,13 @@ data DirectoryGroupData = DirectoryGroupData
-- PCAll - apply to all profiles -- PCAll - apply to all profiles
-- PCNoImage - apply to profiles without images -- PCNoImage - apply to profiles without images
data DirectoryMemberAcceptance = DirectoryMemberAcceptance data DirectoryMemberAcceptance = DirectoryMemberAcceptance
{ filterNames :: Maybe ProfileCondition, -- reject long names and names with profanity { rejectNames :: Maybe ProfileCondition, -- reject long names and names with profanity
useCaptcha :: Maybe ProfileCondition, -- run captcha challenge with joining members passCaptcha :: Maybe ProfileCondition, -- run captcha challenge with joining members
makeObserver :: Maybe ProfileCondition -- the role assigned in the end, after captcha challenge makeObserver :: Maybe ProfileCondition -- the role assigned in the end, after captcha challenge
} }
deriving (Show) deriving (Eq, Show)
data ProfileCondition = PCAll | PCNoImage deriving (Show) data ProfileCondition = PCAll | PCNoImage deriving (Eq, Show)
noJoinFilter :: DirectoryMemberAcceptance noJoinFilter :: DirectoryMemberAcceptance
noJoinFilter = DirectoryMemberAcceptance Nothing Nothing Nothing noJoinFilter = DirectoryMemberAcceptance Nothing Nothing Nothing
@ -105,24 +105,24 @@ noJoinFilter = DirectoryMemberAcceptance Nothing Nothing Nothing
basicJoinFilter :: DirectoryMemberAcceptance basicJoinFilter :: DirectoryMemberAcceptance
basicJoinFilter = basicJoinFilter =
DirectoryMemberAcceptance DirectoryMemberAcceptance
{ filterNames = Just PCNoImage, { rejectNames = Just PCNoImage,
useCaptcha = Nothing, passCaptcha = Nothing,
makeObserver = Nothing makeObserver = Nothing
} }
moderateJoinFilter :: DirectoryMemberAcceptance moderateJoinFilter :: DirectoryMemberAcceptance
moderateJoinFilter = moderateJoinFilter =
DirectoryMemberAcceptance DirectoryMemberAcceptance
{ filterNames = Just PCAll, { rejectNames = Just PCAll,
useCaptcha = Just PCNoImage, passCaptcha = Just PCNoImage,
makeObserver = Nothing makeObserver = Nothing
} }
strongJoinFilter :: DirectoryMemberAcceptance strongJoinFilter :: DirectoryMemberAcceptance
strongJoinFilter = strongJoinFilter =
DirectoryMemberAcceptance DirectoryMemberAcceptance
{ filterNames = Just PCAll, { rejectNames = Just PCAll,
useCaptcha = Just PCAll, passCaptcha = Just PCAll,
makeObserver = Nothing makeObserver = Nothing
} }
@ -167,7 +167,7 @@ grDirectoryStatus = \case
$(JQ.deriveJSON (enumJSON $ dropPrefix "PC") ''ProfileCondition) $(JQ.deriveJSON (enumJSON $ dropPrefix "PC") ''ProfileCondition)
$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "MA") ''DirectoryMemberAcceptance) $(JQ.deriveJSON defaultJSON ''DirectoryMemberAcceptance)
$(JQ.deriveJSON defaultJSON ''DirectoryGroupData) $(JQ.deriveJSON defaultJSON ''DirectoryGroupData)

1
simplex-chat.cabal
View file

@ -474,6 +474,7 @@ test-suite simplex-chat-test
ViewTests ViewTests
Broadcast.Bot Broadcast.Bot
Broadcast.Options Broadcast.Options
Directory.BlockedWords
Directory.Events Directory.Events
Directory.Options Directory.Options
Directory.Search Directory.Search