dandri/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-04-26 13:08:02 +00:00
Code Issues Packages Projects Releases Wiki Activity

Merge branch 'master' into new-website

Browse Source
This commit is contained in:
Evgeny Poberezkin
2025-09-18 21:31:16 +01:00
parent 6fd88f2542 429ec9d21a
commit bf53e0eb80
9 changed files with 437 additions and 140 deletions
Download Patch File Download Diff File Expand all files Collapse all files

8
apps/simplex-directory-service/Main.hs
View File

@@ -17,5 +17,9 @@ main = do
then directoryServiceCLI st opts
else do
env <- newServiceState opts
let cfg = terminalChatConfig {chatHooks = defaultChatHooks {acceptMember = Just $ acceptMemberHook opts env}}
simplexChatCore cfg (mkChatOpts opts) $ directoryService st opts env
let chatHooks =
defaultChatHooks
{ postStartHook = Just $ directoryStartHook st opts,
acceptMember = Just $ acceptMemberHook opts env
}
simplexChatCore (terminalChatConfig {chatHooks}) (mkChatOpts opts) $ directoryService st opts env

14
apps/simplex-directory-service/src/Directory/Events.hs
View File

@@ -135,6 +135,7 @@ data DirectoryCmdTag (r :: DirectoryRole) where
DCInviteOwnerToGroup_ :: DirectoryCmdTag 'DRAdmin
-- DCAddBlockedWord_ :: DirectoryCmdTag 'DRAdmin
-- DCRemoveBlockedWord_ :: DirectoryCmdTag 'DRAdmin
DCPromoteGroup_ :: DirectoryCmdTag 'DRSuperUser
DCExecuteCommand_ :: DirectoryCmdTag 'DRSuperUser
deriving instance Show (DirectoryCmdTag r)
@@ -157,7 +158,7 @@ data DirectoryCmd (r :: DirectoryRole) where
DCMemberRole :: UserGroupRegId -> Maybe GroupName -> Maybe GroupMemberRole -> DirectoryCmd 'DRUser
DCGroupFilter :: UserGroupRegId -> Maybe GroupName -> Maybe DirectoryMemberAcceptance -> DirectoryCmd 'DRUser
DCShowUpgradeGroupLink :: GroupId -> Maybe GroupName -> DirectoryCmd 'DRUser
DCApproveGroup :: {groupId :: GroupId, displayName :: GroupName, groupApprovalId :: GroupApprovalId} -> DirectoryCmd 'DRAdmin
DCApproveGroup :: {groupId :: GroupId, displayName :: GroupName, groupApprovalId :: GroupApprovalId, promote :: Maybe Bool} -> DirectoryCmd 'DRAdmin
DCRejectGroup :: GroupId -> GroupName -> DirectoryCmd 'DRAdmin
DCSuspendGroup :: GroupId -> GroupName -> DirectoryCmd 'DRAdmin
DCResumeGroup :: GroupId -> GroupName -> DirectoryCmd 'DRAdmin
@@ -167,6 +168,7 @@ data DirectoryCmd (r :: DirectoryRole) where
DCInviteOwnerToGroup :: GroupId -> GroupName -> DirectoryCmd 'DRAdmin
-- DCAddBlockedWord :: Text -> DirectoryCmd 'DRAdmin
-- DCRemoveBlockedWord :: Text -> DirectoryCmd 'DRAdmin
DCPromoteGroup :: GroupId -> GroupName -> Bool -> DirectoryCmd 'DRSuperUser
DCExecuteCommand :: String -> DirectoryCmd 'DRSuperUser
DCUnknownCommand :: DirectoryCmd 'DRUser
DCCommandError :: DirectoryCmdTag r -> DirectoryCmd r
@@ -211,6 +213,7 @@ directoryCmdP =
"invite" -> au DCInviteOwnerToGroup_
-- "block_word" -> au DCAddBlockedWord_
-- "unblock_word" -> au DCRemoveBlockedWord_
"promote" -> su DCPromoteGroup_
"exec" -> su DCExecuteCommand_
"x" -> su DCExecuteCommand_
_ -> fail "bad command tag"
@@ -270,7 +273,8 @@ directoryCmdP =
DCApproveGroup_ -> do
(groupId, displayName) <- gc (,)
groupApprovalId <- A.space *> A.decimal
pure DCApproveGroup {groupId, displayName, groupApprovalId}
promote <- Just <$> (" promote=" *> onOffP) <|> pure Nothing
pure DCApproveGroup {groupId, displayName, groupApprovalId, promote}
DCRejectGroup_ -> gc DCRejectGroup
DCSuspendGroup_ -> gc DCSuspendGroup
DCResumeGroup_ -> gc DCResumeGroup
@@ -283,12 +287,17 @@ directoryCmdP =
DCInviteOwnerToGroup_ -> gc DCInviteOwnerToGroup
-- DCAddBlockedWord_ -> DCAddBlockedWord <$> wordP
-- DCRemoveBlockedWord_ -> DCRemoveBlockedWord <$> wordP
DCPromoteGroup_ -> do
(groupId, displayName) <- gc (,)
promote <- A.space *> onOffP
pure $ DCPromoteGroup groupId displayName promote
DCExecuteCommand_ -> DCExecuteCommand . T.unpack <$> (spacesP *> A.takeText)
where
gc f = f <$> (spacesP *> A.decimal) <*> (A.char ':' *> displayNameTextP)
gc_ f = f <$> (spacesP *> A.decimal) <*> optional (A.char ':' *> displayNameTextP)
-- wordP = spacesP *> A.takeTill isSpace
spacesP = A.takeWhile1 isSpace
onOffP = (A.string "on" $> True) <|> (A.string "off" $> False)
directoryCmdTag :: DirectoryCmd r -> Text
directoryCmdTag = \case
@@ -314,6 +323,7 @@ directoryCmdTag = \case
DCInviteOwnerToGroup {} -> "invite"
-- DCAddBlockedWord _ -> "block_word"
-- DCRemoveBlockedWord _ -> "unblock_word"
DCPromoteGroup {} -> "promote"
DCExecuteCommand _ -> "exec"
DCUnknownCommand -> "unknown"
DCCommandError _ -> "error"

97
apps/simplex-directory-service/src/Directory/Listing.hs Normal file
View File

@@ -0,0 +1,97 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module Directory.Listing where
import Control.Applicative ((<|>))
import Control.Concurrent.STM
import Control.Monad
import qualified Data.Aeson as J
import qualified Data.Aeson.TH as JQ
import Data.ByteString (ByteString)
import Data.ByteString.Base64 as B64
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as LB
import Data.Maybe (fromMaybe)
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Directory.Store
import Simplex.Chat.Types
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, taggedObjectJSON)
import System.Directory
import System.FilePath
listingFileName :: String
listingFileName = "listing.json"
promotedFileName :: String
promotedFileName = "promoted.json"
listingImageFolder :: String
listingImageFolder = "images"
data DirectoryEntryType = DETGroup
{ admission :: Maybe GroupMemberAdmission,
summary :: GroupSummary
}
$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "DET") ''DirectoryEntryType)
data DirectoryEntry = DirectoryEntry
{ entryType :: DirectoryEntryType,
displayName :: Text,
shortDescr :: Maybe Text,
welcomeMessage :: Maybe Text,
imageFile :: Maybe String
}
$(JQ.deriveJSON defaultJSON ''DirectoryEntry)
data DirectoryListing = DirectoryListing {entries :: [DirectoryEntry]}
$(JQ.deriveJSON defaultJSON ''DirectoryListing)
type ImageFileData = ByteString
groupDirectoryEntry :: GroupInfoSummary -> (DirectoryEntry, Maybe (FilePath, ImageFileData))
groupDirectoryEntry (GIS GroupInfo {groupId, groupProfile} summary) =
let GroupProfile {displayName, shortDescr, description, image, memberAdmission} = groupProfile
entryType = DETGroup memberAdmission summary
imgData = imgFileData =<< image
in (DirectoryEntry {entryType, displayName, shortDescr, welcomeMessage = description, imageFile = fst <$> imgData}, imgData)
where
imgFileData (ImageData img) =
let (img', imgExt) =
fromMaybe (img, ".jpg") $
(,".jpg") <$> T.stripPrefix "data:image/jpg;base64," img
<|> (,".png") <$> T.stripPrefix "data:image/png;base64," img
imgFile = listingImageFolder </> show groupId <> imgExt
in case B64.decode $ encodeUtf8 img' of
Right img'' -> Just (imgFile, img'')
Left _ -> Nothing
generateListing :: DirectoryStore -> FilePath -> [GroupInfoSummary] -> IO ()
generateListing st dir gs = do
gs' <- filterListedGroups st gs
removePathForcibly (dir </> listingImageFolder)
createDirectoryIfMissing True (dir </> listingImageFolder)
gs'' <- forM gs' $ \g@(GIS GroupInfo {groupId} _) -> do
let (g', img) = groupDirectoryEntry g
forM_ img $ \(imgFile, imgData) -> B.writeFile (dir </> imgFile) imgData
pure (groupId, g')
saveListing listingFileName gs''
saveListing promotedFileName =<< filterPromotedGroups st gs''
where
saveListing f = LB.writeFile (dir </> f) . J.encode . DirectoryListing . map snd
filterPromotedGroups :: DirectoryStore -> [(GroupId, DirectoryEntry)] -> IO [(GroupId, DirectoryEntry)]
filterPromotedGroups st gs = do
pgs <- readTVarIO $ promotedGroups st
pure $ filter (\g -> fst g `S.member` pgs) gs

9
apps/simplex-directory-service/src/Directory/Options.hs
View File

@@ -33,6 +33,7 @@ data DirectoryOpts = DirectoryOpts
serviceName :: T.Text,
runCLI :: Bool,
searchResults :: Int,
webFolder :: Maybe FilePath,
testing :: Bool
}
@@ -124,6 +125,13 @@ directoryOpts appDir defaultDbName = do
( long "run-cli"
<> help "Run directory service as CLI"
)
webFolder <-
optional $
strOption
( long "web-folder"
<> metavar "WEB_FOLDER"
<> help "Folder to store static web assets"
)
pure
DirectoryOpts
{ coreOptions,
@@ -140,6 +148,7 @@ directoryOpts appDir defaultDbName = do
serviceName = T.pack serviceName,
runCLI,
searchResults = 10,
webFolder,
testing = False
}

185
apps/simplex-directory-service/src/Directory/Service.hs
View File

@@ -15,14 +15,14 @@ module Directory.Service
directoryService,
directoryServiceCLI,
newServiceState,
acceptMemberHook
directoryStartHook,
acceptMemberHook,
)
where
import Control.Concurrent (forkIO)
import Control.Concurrent.Async
import Control.Concurrent.STM
import qualified Control.Exception as E
import Control.Logger.Simple
import Control.Monad
import Control.Monad.Except
@@ -41,20 +41,22 @@ 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.Util
import Simplex.Chat.Bot
import Simplex.Chat.Bot.KnownContacts
import Simplex.Chat.Controller
import Simplex.Chat.Core
import Simplex.Chat.Markdown (FormattedText (..), Format (..), parseMaybeMarkdownList, viewName)
import Simplex.Chat.Markdown (Format (..), FormattedText (..), parseMaybeMarkdownList, viewName)
import Simplex.Chat.Messages
import Simplex.Chat.Options
import Simplex.Chat.Protocol (MsgContent (..))
import Simplex.Chat.Store (GroupLink (..))
import Simplex.Chat.Store.Direct (getContact)
import Simplex.Chat.Store.Groups (getGroupInfo, getGroupLink, getGroupSummary, setGroupCustomData)
import Simplex.Chat.Store.Groups (getGroupInfo, getGroupLink, getGroupSummary, getUserGroupsWithSummary, setGroupCustomData)
import Simplex.Chat.Store.Profiles (GroupLinkInfo (..), getGroupLinkInfo)
import Simplex.Chat.Store.Shared (StoreError (..))
import Simplex.Chat.Terminal (terminalChatConfig)
@@ -63,14 +65,11 @@ 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 (..))
import Simplex.Messaging.Agent.Store.Common (withTransaction)
import Simplex.Messaging.Agent.Protocol (SConnectionMode (..), sameConnReqContact, sameShortLinkContact)
import qualified Simplex.Messaging.Agent.Store.DB as DB
import Simplex.Messaging.Agent.Protocol (AConnectionLink (..), ConnectionLink (..), CreatedConnLink (..), SConnectionMode (..), sameConnReqContact, sameShortLinkContact)
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Util (safeDecodeUtf8, tshow, ($>>=), (<$$>))
import Simplex.Messaging.Util (safeDecodeUtf8, tshow, unlessM, whenM, ($>>=), (<$$>))
import System.Directory (getAppUserDataDirectory)
import System.Exit (exitFailure)
import System.Process (readProcess)
@@ -147,7 +146,7 @@ directoryServiceCLI st opts = do
env <- newServiceState opts
eventQ <- newTQueueIO
let eventHook cc resp = atomically $ resp <$ writeTQueue eventQ (cc, resp)
chatHooks = defaultChatHooks {postStartHook = Just postStartHook, eventHook = Just eventHook, acceptMember = Just $ acceptMemberHook opts env}
chatHooks = defaultChatHooks {postStartHook = Just $ directoryStartHook st opts, eventHook = Just eventHook, acceptMember = Just $ acceptMemberHook opts env}
race_
(simplexChatCLI' terminalChatConfig {chatHooks} (mkChatOpts opts) Nothing)
(processEvents eventQ env)
@@ -156,18 +155,22 @@ directoryServiceCLI st opts = do
(cc, resp) <- atomically $ readTQueue eventQ
u_ <- readTVarIO (currentUser cc)
forM_ u_ $ \user -> directoryServiceEvent st opts env user cc resp
postStartHook cc =
readTVarIO (currentUser cc) >>= \case
Nothing -> putStrLn "No current user" >> exitFailure
Just User {userId, profile = p@LocalProfile {preferences}} -> do
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
directoryStartHook :: DirectoryStore -> DirectoryOpts -> ChatController -> IO ()
directoryStartHook st opts cc =
readTVarIO (currentUser cc) >>= \case
Nothing -> putStrLn "No current user" >> exitFailure
Just user@User {userId, profile = p@LocalProfile {preferences}} -> do
forM_ (webFolder opts) $ updateGroupListingFiles cc st user
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 =
@@ -323,7 +326,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
void $ addGroupReg st ct g GRSProposed
r <- sendChatCmd cc $ APIJoinGroup groupId MFNone
sendMessage cc ct $ case r of
Right CRUserAcceptedGroupSent {} -> "Joining the group " <> displayName <> "…"
Right CRUserAcceptedGroupSent {} -> "Joining the group " <> displayName <> "…"
_ -> "Error joining group " <> displayName <> ", please re-send the invitation!"
deContactConnected :: Contact -> IO ()
@@ -392,7 +395,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
notifyOwner gr $ "Joined the group " <> displayName <> ", creating the link…"
sendChatCmd cc (APICreateGroupLink groupId GRMember) >>= \case
Right CRGroupLinkCreated {groupLink = GroupLink {connLinkContact = gLink}} -> do
setGroupStatus st gr GRSPendingUpdate
setGroupStatus st opts cc user gr GRSPendingUpdate
notifyOwner
gr
"Created the public link to join the group via this directory service that is always online.\n\n\
@@ -431,7 +434,9 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
GPServiceLinkError -> do
notifyOwner gr $
("Error: " <> serviceName <> " has no group link for " <> userGroupRef)
<> " after profile was updated" <> byMember <> ". Please report the error to the developers."
<> " 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
@@ -451,7 +456,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
Just DGReserved -> notifyOwner gr $ groupAlreadyListed toGroup
_ -> do
let gaId = 1
setGroupStatus st gr $ GRSPendingApproval gaId
setGroupStatus st opts cc user gr $ GRSPendingApproval gaId
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."
@@ -461,18 +466,18 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
groupRef = groupReference toGroup
groupProfileUpdate >>= \case
GPNoServiceLink -> do
setGroupStatus st gr GRSPendingUpdate
setGroupStatus st opts cc user gr GRSPendingUpdate
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 -> do
setGroupStatus st gr GRSPendingUpdate
setGroupStatus st opts cc user gr GRSPendingUpdate
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 _ -> do
setGroupStatus st gr $ GRSPendingApproval n'
setGroupStatus st opts cc user gr $ GRSPendingApproval n'
notifyOwner gr $
("The group link is added to " <> userGroupRef <> byMember)
<> "!\nIt is hidden from the directory until approved."
@@ -485,7 +490,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
<> "!\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 -> do
setGroupStatus st gr $ GRSPendingApproval n'
setGroupStatus st opts cc user gr $ GRSPendingApproval n'
notifyOwner gr $
("The group " <> userGroupRef <> " is updated" <> byMember)
<> "!\nIt is hidden from the directory until approved."
@@ -523,7 +528,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
Just Nothing -> sendToApprove toGroup gr gaId
dePendingMember :: GroupInfo -> GroupMember -> IO ()
dePendingMember g@GroupInfo {groupProfile = GroupProfile {displayName}} m
dePendingMember g@GroupInfo {groupProfile = GroupProfile {displayName}} m
| memberRequiresCaptcha a m = sendMemberCaptcha g m Nothing captchaNotice 0
| otherwise = approvePendingMember a g m
where
@@ -600,7 +605,8 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
useMemberFilter image $ passCaptcha a
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, promoted} gaId = do
-- TODO account for promotion
ct_ <- getContact' cc user dbContactId
gr_ <- getGroupAndSummary cc user dbGroupId
let membersStr = maybe "" (\(_, s) -> "_" <> tshow (currentMembers s) <> " members_\n") gr_
@@ -608,9 +614,10 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
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'
promote <- readTVarIO promoted
withAdminUsers $ \cId -> do
sendComposedMessage' cc cId Nothing msg
sendMessage' cc cId $ "/approve " <> tshow dbGroupId <> ":" <> viewName displayName <> " " <> tshow gaId
sendMessage' cc cId $ "/approve " <> tshow dbGroupId <> ":" <> viewName displayName <> " " <> tshow gaId <> if promote then " promote=on" else ""
deContactRoleChanged :: GroupInfo -> ContactId -> GroupMemberRole -> IO ()
deContactRoleChanged g@GroupInfo {membership = GroupMember {memberRole = serviceRole}} ctId contactRole = do
@@ -621,14 +628,14 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
when (ctId `isOwner` gr) $ do
readTVarIO (groupRegStatus gr) >>= \case
GRSSuspendedBadRoles -> when (rStatus == GRSOk) $ do
setGroupStatus st gr GRSActive
setGroupStatus st opts cc user 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
setGroupStatus st opts cc user gr GRSSuspendedBadRoles
notifyOwner gr $ uCtRole <> ".\n\nThe group is no longer listed in the directory."
notifyAdminUsers $ "The group " <> groupRef <> " is de-listed " <> suCtRole
_ -> pure ()
@@ -647,7 +654,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
readTVarIO (groupRegStatus gr) >>= \case
GRSSuspendedBadRoles -> when (serviceRole == GRAdmin) $
whenContactIsOwner gr $ do
setGroupStatus st gr GRSActive
setGroupStatus st opts cc user 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) $
@@ -655,7 +662,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
sendToApprove g gr gaId
notifyOwner gr $ uSrvRole <> ".\n\nThe group is submitted for approval."
GRSActive -> when (serviceRole /= GRAdmin) $ do
setGroupStatus st gr GRSSuspendedBadRoles
setGroupStatus st opts cc user gr GRSSuspendedBadRoles
notifyOwner gr $ uSrvRole <> ".\n\nThe group is no longer listed in the directory."
notifyAdminUsers $ "The group " <> groupRef <> " is de-listed " <> suSrvRole
_ -> pure ()
@@ -672,7 +679,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
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
setGroupStatus st opts cc user 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)."
@@ -681,7 +688,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
logInfo $ "contact ID " <> tshow ctId <> " left group " <> viewGroupName g
withGroupReg g "contact left" $ \gr -> do
when (ctId `isOwner` gr) $ do
setGroupStatus st gr GRSRemoved
setGroupStatus st opts cc user 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)."
@@ -689,7 +696,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
deServiceRemovedFromGroup g = do
logInfo $ "service removed from group " <> viewGroupName g
withGroupReg g "service removed" $ \gr -> do
setGroupStatus st gr GRSRemoved
setGroupStatus st opts cc user 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)."
@@ -697,7 +704,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
deGroupDeleted g = do
logInfo $ "group removed " <> viewGroupName g
withGroupReg g "group removed" $ \gr -> do
setGroupStatus st gr GRSRemoved
setGroupStatus st opts cc user gr GRSRemoved
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)."
@@ -817,12 +824,13 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
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: " <> strEncodeTxt acceptMemberRole
]
<> ["The link is being upgraded..." | shouldBeUpgraded]
sendReply $
T.unlines $
[ "The link to join the group " <> groupRef <> ":",
groupLinkText gLink,
"New member role: " <> strEncodeTxt 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) $
@@ -830,13 +838,16 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
(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:"
],
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) ->
@@ -924,8 +935,8 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
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@GroupReg {userGroupRegId = ugrId} ->
DCApproveGroup {groupId, displayName = n, groupApprovalId, promote} ->
withGroupAndReg sendReply groupId n $ \g gr@GroupReg {userGroupRegId = ugrId, promoted} ->
readTVarIO (groupRegStatus gr) >>= \case
GRSPendingApproval gaId
| gaId == groupApprovalId -> do
@@ -935,7 +946,17 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
_ -> do
getGroupRolesStatus g gr >>= \case
Just GRSOk -> do
setGroupStatus st gr GRSActive
setGroupStatus st opts cc user gr GRSActive
forM_ promote $ \promo ->
if promo -- admins can unpromote, only super-user can promote when approving
then
unlessM (readTVarIO promoted) $
if knownCt `elem` superUsers
then setGroupPromoted st opts cc user gr True
else sendReply "You cannot promote groups"
else do
whenM (readTVarIO promoted) $ setGroupPromoted st opts cc user gr False
notifyOtherSuperUsers $ "Group promotion is disabled for " <> groupRef
let approved = "The group " <> userGroupReference' gr n <> " is approved"
notifyOwner gr $
(approved <> " and listed in directory - please moderate it!\n")
@@ -970,7 +991,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
withGroupAndReg sendReply groupId gName $ \_ gr ->
readTVarIO (groupRegStatus gr) >>= \case
GRSActive -> do
setGroupStatus st gr GRSSuspended
setGroupStatus st opts cc user 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!"
@@ -981,7 +1002,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
withGroupAndReg sendReply groupId gName $ \_ gr ->
readTVarIO (groupRegStatus gr) >>= \case
GRSSuspended -> do
setGroupStatus st gr GRSActive
setGroupStatus st opts cc user gr GRSActive
let groupStr = "The group " <> userGroupReference' gr gName
notifyOwner gr $ groupStr <> " is listed in the directory again!"
sendReply "Group listing resumed!"
@@ -1002,7 +1023,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
Right () -> do
let groupRef = groupReference' groupId gName
owner <- groupOwnerInfo groupRef ctId
let invited = " invited " <> owner <> " to owners' group " <> viewName ogName
let invited = " invited " <> owner <> " to owners' group " <> viewName ogName
notifyOtherSuperUsers $ viewName (localDisplayName' ct) <> invited
sendReply $ "you" <> invited
Left err -> sendReply err
@@ -1039,7 +1060,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
r -> contErr r
r -> contErr r
where
alreadyMember = isJust . find ((Just ctId == ) . memberContactId)
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
@@ -1053,6 +1074,15 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
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
status <- readTVarIO groupRegStatus
promote <- readTVarIO promoted
when (promote' /= promote) $ setGroupPromoted st opts cc user gr promote'
let msg =
"Group promotion "
<> (if promote' then "enabled" <> (if status == GRSActive then "." else ", but the group is not listed.") else "disabled.")
sendReply msg
DCExecuteCommand cmdStr ->
sendChatCmdStr cc cmdStr >>= \case
Right r -> do
@@ -1102,30 +1132,35 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
let text = T.unlines $ [tshow useGroupId <> ". Error: getGroup. Please notify the developers."] <> maybeToList ownerStr_ <> [statusStr]
sendComposedMessage cc ct Nothing $ MCText text
setGroupStatus :: DirectoryStore -> DirectoryOpts -> ChatController -> User -> GroupReg -> GroupRegStatus -> IO ()
setGroupStatus st opts cc u gr grStatus' = do
let status' = grDirectoryStatus grStatus'
status <- setGroupStatusStore st gr grStatus'
forM_ (webFolder opts) $ \dir ->
when ((status == DSListed || status' == DSListed) && status /= status') $ updateGroupListingFiles cc st u dir
setGroupPromoted :: DirectoryStore -> DirectoryOpts -> ChatController -> User -> GroupReg -> Bool -> IO ()
setGroupPromoted st opts cc u gr grPromoted' = do
(status, grPromoted) <- setGroupPromotedStore st gr grPromoted'
forM_ (webFolder opts) $ \dir ->
when (status == DSListed && grPromoted' /= grPromoted) $ updateGroupListingFiles cc st u dir
updateGroupListingFiles :: ChatController -> DirectoryStore -> User -> FilePath -> IO ()
updateGroupListingFiles cc st u dir =
withDB' "generateListing" cc (\db -> getUserGroupsWithSummary db (vr cc) u Nothing Nothing) >>= \case
Just gs -> generateListing st dir gs
Nothing -> putStrLn "generateListing error: failed to read groups"
getContact' :: ChatController -> User -> ContactId -> IO (Maybe Contact)
getContact' cc user ctId = withDB "getContact" cc $ \db -> getContact db (vr cc) user ctId
getGroup :: ChatController -> User -> GroupId -> IO (Maybe GroupInfo)
getGroup cc user gId = withDB "getGroupInfo" cc $ \db -> getGroupInfo db (vr cc) user gId
withDB' :: Text -> ChatController -> (DB.Connection -> IO a) -> IO (Maybe a)
withDB' cxt cc a = withDB cxt cc $ ExceptT . fmap Right . a
withDB :: Text -> ChatController -> (DB.Connection -> ExceptT StoreError IO a) -> IO (Maybe a)
withDB cxt ChatController {chatStore} action = do
r_ :: Either ChatError a <- withTransaction chatStore (runExceptT . withExceptT ChatErrorStore . action) `E.catches` handleDBErrors
case r_ of
Right r -> pure $ Just r
Left e -> Nothing <$ logError ("Database error: " <> cxt <> " " <> tshow e)
getGroupAndSummary :: ChatController -> User -> GroupId -> IO (Maybe (GroupInfo, GroupSummary))
getGroupAndSummary cc user gId =
withDB "getGroupAndSummary" cc $ \db -> (,) <$> getGroupInfo db (vr cc) user gId <*> liftIO (getGroupSummary db user gId)
vr :: ChatController -> VersionRangeChat
vr ChatController {config = ChatConfig {chatVRange}} = chatVRange
{-# INLINE vr #-}
getGroupLink' :: ChatController -> User -> GroupInfo -> IO (Maybe GroupLink)
getGroupLink' cc user gInfo =
withDB "getGroupLink" cc $ \db -> getGroupLink db user gInfo

144
apps/simplex-directory-service/src/Directory/Store.hs
View File

@@ -13,11 +13,14 @@ module Directory.Store
GroupApprovalId,
DirectoryGroupData (..),
DirectoryMemberAcceptance (..),
DirectoryStatus (..),
ProfileCondition (..),
restoreDirectoryStore,
addGroupReg,
delGroupReg,
setGroupStatus,
setGroupStatusStore,
setGroupPromotedStore,
grDirectoryStatus,
setGroupRegOwner,
getGroupReg,
getUserGroupReg,
@@ -31,13 +34,14 @@ module Directory.Store
noJoinFilter,
basicJoinFilter,
moderateJoinFilter,
strongJoinFilter
strongJoinFilter,
)
where
import Control.Applicative ((<|>))
import Control.Concurrent.STM
import Control.Monad
import Data.Aeson ((.=), (.:))
import Data.Aeson ((.:), (.=))
import qualified Data.Aeson.KeyMap as JM
import qualified Data.Aeson.TH as JQ
import qualified Data.Aeson.Types as JT
@@ -55,23 +59,32 @@ import Data.Text (Text)
import Simplex.Chat.Types
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON)
import Simplex.Messaging.Util (ifM)
import System.Directory (doesFileExist, renameFile)
import Simplex.Messaging.Util (ifM, whenM)
import System.Directory
import System.IO (BufferMode (..), Handle, IOMode (..), hSetBuffering, openFile)
data DirectoryStore = DirectoryStore
{ groupRegs :: TVar [GroupReg],
listedGroups :: TVar (Set GroupId),
{ groupRegs :: TVar [GroupReg], -- most recent first, reversed when listed
listedGroups :: TVar (Set GroupId), -- includes promoted
promotedGroups :: TVar (Set GroupId),
reservedGroups :: TVar (Set GroupId),
directoryLogFile :: Maybe Handle
}
data DirectoryStoreData = DirectoryStoreData
{ groupRegs_ :: [GroupReg],
listedGroups_ :: Set GroupId,
promotedGroups_ :: Set GroupId,
reservedGroups_ :: Set GroupId
}
data GroupReg = GroupReg
{ dbGroupId :: GroupId,
userGroupRegId :: UserGroupRegId,
dbContactId :: ContactId,
dbOwnerMemberId :: TVar (Maybe GroupMemberId),
groupRegStatus :: TVar GroupRegStatus
groupRegStatus :: TVar GroupRegStatus,
promoted :: TVar Bool
}
data GroupRegData = GroupRegData
@@ -79,7 +92,8 @@ data GroupRegData = GroupRegData
userGroupRegId_ :: UserGroupRegId,
dbContactId_ :: ContactId,
dbOwnerMemberId_ :: Maybe GroupMemberId,
groupRegStatus_ :: GroupRegStatus
groupRegStatus_ :: GroupRegStatus,
promoted_ :: Bool
}
data DirectoryGroupData = DirectoryGroupData
@@ -140,7 +154,7 @@ data GroupRegStatus
| GRSSuspended
| GRSSuspendedBadRoles
| GRSRemoved
deriving (Show)
deriving (Eq, Show)
pendingApproval :: GroupRegStatus -> Bool
pendingApproval = \case
@@ -153,6 +167,7 @@ groupRemoved = \case
_ -> False
data DirectoryStatus = DSListed | DSReserved | DSRegistered | DSRemoved
deriving (Eq)
groupRegStatusText :: GroupRegStatus -> Text
groupRegStatusText = \case
@@ -195,7 +210,7 @@ addGroupReg st ct GroupInfo {groupId} grStatus = do
pure $ userGroupRegId_ grData
where
addGroupReg_ = do
let grData = GroupRegData {dbGroupId_ = groupId, userGroupRegId_ = 1, dbContactId_ = ctId, dbOwnerMemberId_ = Nothing, groupRegStatus_ = grStatus}
let grData = GroupRegData {dbGroupId_ = groupId, userGroupRegId_ = 1, dbContactId_ = ctId, dbOwnerMemberId_ = Nothing, groupRegStatus_ = grStatus, promoted_ = False}
gr <- dataToGroupReg grData
atomically $ stateTVar (groupRegs st) $ \grs ->
let ugrId = 1 + foldl' maxUgrId 0 grs
@@ -208,25 +223,38 @@ addGroupReg st ct GroupInfo {groupId} grStatus = do
| otherwise = mx
delGroupReg :: DirectoryStore -> GroupReg -> IO ()
delGroupReg st GroupReg {dbGroupId = gId, groupRegStatus} = do
delGroupReg st gr@GroupReg {dbGroupId = gId, groupRegStatus} = do
logGDelete st gId
atomically $ writeTVar groupRegStatus GRSRemoved
atomically $ unlistGroup st gId
atomically $ unlistGroup st gr
atomically $ modifyTVar' (groupRegs st) $ filter ((gId /=) . dbGroupId)
setGroupStatus :: DirectoryStore -> GroupReg -> GroupRegStatus -> IO ()
setGroupStatus st gr grStatus = do
logGUpdateStatus st (dbGroupId gr) grStatus
setGroupStatusStore :: DirectoryStore -> GroupReg -> GroupRegStatus -> IO DirectoryStatus
setGroupStatusStore st gr grStatus' = do
logGUpdateStatus st (dbGroupId gr) grStatus'
atomically $ do
writeTVar (groupRegStatus gr) grStatus
updateListing st $ dbGroupId gr
grStatus <- swapTVar (groupRegStatus gr) grStatus'
updateListing st gr
pure $ grDirectoryStatus grStatus
where
updateListing = case grDirectoryStatus grStatus of
status' = grDirectoryStatus grStatus'
updateListing = case status' of
DSListed -> listGroup
DSReserved -> reserveGroup
DSRegistered -> unlistGroup
DSRemoved -> unlistGroup
setGroupPromotedStore :: DirectoryStore -> GroupReg -> Bool -> IO (DirectoryStatus, Bool)
setGroupPromotedStore st gr grPromoted' = do
let gId = dbGroupId gr
logGUpdatePromotion st gId grPromoted'
atomically $ do
grPromoted <- swapTVar (promoted gr) grPromoted'
status <- grDirectoryStatus <$> readTVar (groupRegStatus gr)
let update = if status == DSListed && grPromoted' then S.insert else S.delete
modifyTVar' (promotedGroups st) $ update gId
pure (status, grPromoted)
setGroupRegOwner :: DirectoryStore -> GroupReg -> GroupMember -> IO ()
setGroupRegOwner st gr owner = do
let memberId = groupMemberId' owner
@@ -247,31 +275,39 @@ filterListedGroups st gs = do
lgs <- readTVarIO $ listedGroups st
pure $ filter (\(GIS GroupInfo {groupId} _) -> groupId `S.member` lgs) gs
listGroup :: DirectoryStore -> GroupId -> STM ()
listGroup st gId = do
listGroup :: DirectoryStore -> GroupReg -> STM ()
listGroup st gr = do
let gId = dbGroupId gr
modifyTVar' (listedGroups st) $ S.insert gId
whenM (readTVar $ promoted gr) $ modifyTVar' (promotedGroups st) $ S.insert gId
modifyTVar' (reservedGroups st) $ S.delete gId
reserveGroup :: DirectoryStore -> GroupId -> STM ()
reserveGroup st gId = do
reserveGroup :: DirectoryStore -> GroupReg -> STM ()
reserveGroup st gr = do
let gId = dbGroupId gr
modifyTVar' (listedGroups st) $ S.delete gId
modifyTVar' (promotedGroups st) $ S.delete gId
modifyTVar' (reservedGroups st) $ S.insert gId
unlistGroup :: DirectoryStore -> GroupId -> STM ()
unlistGroup st gId = do
unlistGroup :: DirectoryStore -> GroupReg -> STM ()
unlistGroup st gr = do
let gId = dbGroupId gr
modifyTVar' (listedGroups st) $ S.delete gId
modifyTVar' (promotedGroups st) $ S.delete gId
modifyTVar' (reservedGroups st) $ S.delete gId
data DirectoryLogRecord
= GRCreate GroupRegData
| GRDelete GroupId
| GRUpdateStatus GroupId GroupRegStatus
| GRUpdatePromotion GroupId Bool
| GRUpdateOwner GroupId GroupMemberId
data DLRTag
= GRCreate_
| GRDelete_
| GRUpdateStatus_
| GRUpdatePromotion_
| GRUpdateOwner_
logDLR :: DirectoryStore -> DirectoryLogRecord -> IO ()
@@ -286,6 +322,9 @@ logGDelete st = logDLR st . GRDelete
logGUpdateStatus :: DirectoryStore -> GroupId -> GroupRegStatus -> IO ()
logGUpdateStatus st gId = logDLR st . GRUpdateStatus gId
logGUpdatePromotion :: DirectoryStore -> GroupId -> Bool -> IO ()
logGUpdatePromotion st gId = logDLR st . GRUpdatePromotion gId
logGUpdateOwner :: DirectoryStore -> GroupId -> GroupMemberId -> IO ()
logGUpdateOwner st gId = logDLR st . GRUpdateOwner gId
@@ -294,12 +333,14 @@ instance StrEncoding DLRTag where
GRCreate_ -> "GCREATE"
GRDelete_ -> "GDELETE"
GRUpdateStatus_ -> "GSTATUS"
GRUpdatePromotion_ -> "GPROMOTE"
GRUpdateOwner_ -> "GOWNER"
strP =
A.takeTill (== ' ') >>= \case
"GCREATE" -> pure GRCreate_
"GDELETE" -> pure GRDelete_
"GSTATUS" -> pure GRUpdateStatus_
"GPROMOTE" -> pure GRUpdatePromotion_
"GOWNER" -> pure GRUpdateOwner_
_ -> fail "invalid DLRTag"
@@ -308,30 +349,34 @@ instance StrEncoding DirectoryLogRecord where
GRCreate gr -> strEncode (GRCreate_, gr)
GRDelete gId -> strEncode (GRDelete_, gId)
GRUpdateStatus gId grStatus -> strEncode (GRUpdateStatus_, gId, grStatus)
GRUpdatePromotion gId promoted -> strEncode (GRUpdatePromotion_, gId, promoted)
GRUpdateOwner gId grOwnerId -> strEncode (GRUpdateOwner_, gId, grOwnerId)
strP =
strP_ >>= \case
GRCreate_ -> GRCreate <$> strP
GRDelete_ -> GRDelete <$> strP
GRUpdateStatus_ -> GRUpdateStatus <$> A.decimal <*> _strP
GRUpdatePromotion_ -> GRUpdatePromotion <$> A.decimal <*> _strP
GRUpdateOwner_ -> GRUpdateOwner <$> A.decimal <* A.space <*> A.decimal
instance StrEncoding GroupRegData where
strEncode GroupRegData {dbGroupId_, userGroupRegId_, dbContactId_, dbOwnerMemberId_, groupRegStatus_} =
B.unwords
strEncode GroupRegData {dbGroupId_, userGroupRegId_, dbContactId_, dbOwnerMemberId_, groupRegStatus_, promoted_} =
B.unwords $
[ "group_id=" <> strEncode dbGroupId_,
"user_group_id=" <> strEncode userGroupRegId_,
"contact_id=" <> strEncode dbContactId_,
"owner_member_id=" <> strEncode dbOwnerMemberId_,
"status=" <> strEncode groupRegStatus_
]
<> ["promoted=" <> strEncode promoted_ | promoted_]
strP = do
dbGroupId_ <- "group_id=" *> strP_
userGroupRegId_ <- "user_group_id=" *> strP_
dbContactId_ <- "contact_id=" *> strP_
dbOwnerMemberId_ <- "owner_member_id=" *> strP_
groupRegStatus_ <- "status=" *> strP
pure GroupRegData {dbGroupId_, userGroupRegId_, dbContactId_, dbOwnerMemberId_, groupRegStatus_}
promoted_ <- (" promoted=" *> strP) <|> pure False
pure GroupRegData {dbGroupId_, userGroupRegId_, dbContactId_, dbOwnerMemberId_, groupRegStatus_, promoted_}
instance StrEncoding GroupRegStatus where
strEncode = \case
@@ -356,16 +401,18 @@ instance StrEncoding GroupRegStatus where
_ -> fail "invalid GroupRegStatus"
dataToGroupReg :: GroupRegData -> IO GroupReg
dataToGroupReg GroupRegData {dbGroupId_, userGroupRegId_, dbContactId_, dbOwnerMemberId_, groupRegStatus_} = do
dataToGroupReg GroupRegData {dbGroupId_, userGroupRegId_, dbContactId_, dbOwnerMemberId_, groupRegStatus_, promoted_} = do
dbOwnerMemberId <- newTVarIO dbOwnerMemberId_
groupRegStatus <- newTVarIO groupRegStatus_
promoted <- newTVarIO promoted_
pure
GroupReg
{ dbGroupId = dbGroupId_,
userGroupRegId = userGroupRegId_,
dbContactId = dbContactId_,
dbOwnerMemberId,
groupRegStatus
groupRegStatus,
promoted
}
restoreDirectoryStore :: Maybe FilePath -> IO DirectoryStore
@@ -383,8 +430,8 @@ restoreDirectoryStore = \case
h <- writeDirectoryData f grs -- compact
mkDirectoryStore h grs
emptyStoreData :: ([GroupReg], Set GroupId, Set GroupId)
emptyStoreData = ([], S.empty, S.empty)
emptyStoreData :: DirectoryStoreData
emptyStoreData = DirectoryStoreData [] S.empty S.empty S.empty
newDirectoryStore :: Maybe Handle -> IO DirectoryStore
newDirectoryStore = (`mkDirectoryStore_` emptyStoreData)
@@ -393,21 +440,27 @@ mkDirectoryStore :: Handle -> [GroupRegData] -> IO DirectoryStore
mkDirectoryStore h groups =
foldM addGroupRegData emptyStoreData groups >>= mkDirectoryStore_ (Just h)
where
addGroupRegData (!grs, !listed, !reserved) gr@GroupRegData {dbGroupId_ = gId} = do
addGroupRegData d gr@GroupRegData {dbGroupId_ = gId} = do
gr' <- dataToGroupReg gr
let grs' = gr' : grs
let !grs' = gr' : groupRegs_ d
pure $ case grDirectoryStatus $ groupRegStatus_ gr of
DSListed -> (grs', S.insert gId listed, reserved)
DSReserved -> (grs', listed, S.insert gId reserved)
DSRegistered -> (grs', listed, reserved)
DSRemoved -> (grs, listed, reserved)
DSListed ->
let !listed = S.insert gId $ listedGroups_ d
!promoted = (if promoted_ gr then S.insert gId else id) $ promotedGroups_ d
in d {groupRegs_ = grs', listedGroups_ = listed, promotedGroups_ = promoted}
DSReserved ->
let !reserved = S.insert gId $ reservedGroups_ d
in d {groupRegs_ = grs', reservedGroups_ = reserved}
DSRegistered -> d {groupRegs_ = grs'}
DSRemoved -> d
mkDirectoryStore_ :: Maybe Handle -> ([GroupReg], Set GroupId, Set GroupId) -> IO DirectoryStore
mkDirectoryStore_ h (grs, listed, reserved) = do
groupRegs <- newTVarIO grs
listedGroups <- newTVarIO listed
reservedGroups <- newTVarIO reserved
pure DirectoryStore {groupRegs, listedGroups, reservedGroups, directoryLogFile = h}
mkDirectoryStore_ :: Maybe Handle -> DirectoryStoreData -> IO DirectoryStore
mkDirectoryStore_ h d = do
groupRegs <- newTVarIO $ groupRegs_ d
listedGroups <- newTVarIO $ listedGroups_ d
promotedGroups <- newTVarIO $ promotedGroups_ d
reservedGroups <- newTVarIO $ reservedGroups_ d
pure DirectoryStore {groupRegs, listedGroups, promotedGroups, reservedGroups, directoryLogFile = h}
readDirectoryData :: FilePath -> IO [GroupRegData]
readDirectoryData f =
@@ -429,6 +482,9 @@ readDirectoryData f =
GRUpdateStatus gId groupRegStatus_ -> case M.lookup gId m of
Just gr -> pure $ M.insert gId gr {groupRegStatus_} m
Nothing -> m <$ putStrLn ("Warning: no group with ID " <> show gId <> ", status update ignored.")
GRUpdatePromotion gId promoted_ -> case M.lookup gId m of
Just gr -> pure $ M.insert gId gr {promoted_} m
Nothing -> m <$ putStrLn ("Warning: no group with ID " <> show gId <> ", promotion update ignored.")
GRUpdateOwner gId grOwnerId -> case M.lookup gId m of
Just gr -> pure $ M.insert gId gr {dbOwnerMemberId_ = Just grOwnerId} m
Nothing -> m <$ putStrLn ("Warning: no group with ID " <> show gId <> ", owner update ignored.")

31
apps/simplex-directory-service/src/Directory/Util.hs Normal file
View File

@@ -0,0 +1,31 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Directory.Util where
import qualified Control.Exception as E
import Control.Logger.Simple
import Control.Monad.Except
import Data.Text (Text)
import Simplex.Chat.Controller
import Simplex.Chat.Store.Shared (StoreError (..))
import Simplex.Chat.Types
import Simplex.Messaging.Agent.Store.Common (withTransaction)
import qualified Simplex.Messaging.Agent.Store.DB as DB
import Simplex.Messaging.Util (tshow)
vr :: ChatController -> VersionRangeChat
vr ChatController {config = ChatConfig {chatVRange}} = chatVRange
{-# INLINE vr #-}
withDB' :: Text -> ChatController -> (DB.Connection -> IO a) -> IO (Maybe a)
withDB' cxt cc a = withDB cxt cc $ ExceptT . fmap Right . a
withDB :: Text -> ChatController -> (DB.Connection -> ExceptT StoreError IO a) -> IO (Maybe a)
withDB cxt ChatController {chatStore} action = do
r_ :: Either ChatError a <- withTransaction chatStore (runExceptT . withExceptT ChatErrorStore . action) `E.catches` handleDBErrors
case r_ of
Right r -> pure $ Just r
Left e -> Nothing <$ logError ("Database error: " <> cxt <> " " <> tshow e)

6
simplex-chat.cabal
View File

@@ -457,10 +457,12 @@ executable simplex-directory-service
Directory.BlockedWords
Directory.Captcha
Directory.Events
Directory.Listing
Directory.Options
Directory.Search
Directory.Service
Directory.Store
Directory.Util
Paths_simplex_chat
ghc-options: -O2 -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=missing-methods -Werror=incomplete-uni-patterns -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -threaded
build-depends:
@@ -468,9 +470,11 @@ executable simplex-directory-service
, async ==2.2.*
, attoparsec ==0.14.*
, base >=4.7 && <5
, base64-bytestring >=1.0 && <1.3
, composition ==1.0.*
, containers ==0.6.*
, directory ==1.3.*
, filepath ==1.4.*
, mtl >=2.3.1 && <3.0
, optparse-applicative >=0.15 && <0.17
, process >=1.6 && <1.6.18
@@ -539,10 +543,12 @@ test-suite simplex-chat-test
Directory.BlockedWords
Directory.Captcha
Directory.Events
Directory.Listing
Directory.Options
Directory.Search
Directory.Service
Directory.Store
Directory.Util
Paths_simplex_chat
if flag(client_postgres)
other-modules:

83
tests/Bots/DirectoryTests.hs
View File

@@ -12,8 +12,10 @@ import ChatTests.Utils
import Control.Concurrent (forkIO, killThread, threadDelay)
import Control.Exception (finally)
import Control.Monad (forM_, when)
import qualified Data.Aeson as J
import qualified Data.Text as T
import Directory.Captcha
import Directory.Listing
import Directory.Options
import Directory.Service
import Directory.Store
@@ -65,8 +67,8 @@ directoryServiceTests = do
it "should prohibit confirmation if a duplicate group is listed" testDuplicateProhibitConfirmation
it "should prohibit when profile is updated and not send for approval" testDuplicateProhibitWhenUpdated
it "should prohibit approval if a duplicate group is listed" testDuplicateProhibitApproval
describe "list groups" $ do
it "should list user's groups" testListUserGroups
describe "list and promote groups" $ do
it "should list and promote user's groups" $ testListUserGroups True
describe "member admission" $ do
it "should ask member to pass captcha screen" testCapthaScreening
describe "store log" $ do
@@ -77,8 +79,8 @@ directoryServiceTests = do
directoryProfile :: Profile
directoryProfile = Profile {displayName = "SimpleX Directory", fullName = "", shortDescr = Nothing, image = Nothing, contactLink = Nothing, peerType = Just CPTBot, preferences = Nothing}
mkDirectoryOpts :: TestParams -> [KnownContact] -> Maybe KnownGroup -> DirectoryOpts
mkDirectoryOpts TestParams {tmpPath = ps} superUsers ownersGroup =
mkDirectoryOpts :: TestParams -> [KnownContact] -> Maybe KnownGroup -> Maybe FilePath -> DirectoryOpts
mkDirectoryOpts TestParams {tmpPath = ps} superUsers ownersGroup webFolder =
DirectoryOpts
{ coreOptions =
testCoreOpts
@@ -104,6 +106,7 @@ mkDirectoryOpts TestParams {tmpPath = ps} superUsers ownersGroup =
serviceName = "SimpleX Directory",
runCLI = False,
searchResults = 3,
webFolder,
testing = True
}
@@ -531,7 +534,7 @@ testSearchGroups ps =
testInviteToOwnersGroup :: HasCallStack => TestParams -> IO ()
testInviteToOwnersGroup ps =
withDirectoryServiceCfgOwnersGroup ps testCfg True $ \superUser dsLink ->
withDirectoryServiceCfgOwnersGroup ps testCfg True Nothing $ \superUser dsLink ->
withNewTestChatCfg ps testCfg "bob" bobProfile $ \bob -> do
bob `connectVia` dsLink
registerGroupId superUser bob "privacy" "Privacy" 2 1
@@ -1060,14 +1063,15 @@ testDuplicateProhibitApproval ps =
superUser <# ("'SimpleX Directory'> > " <> approve)
superUser <## " The group ID 2 (privacy) is already listed in the directory."
testListUserGroups :: HasCallStack => TestParams -> IO ()
testListUserGroups ps =
withDirectoryService ps $ \superUser dsLink ->
testListUserGroups :: HasCallStack => Bool -> TestParams -> IO ()
testListUserGroups promote ps =
withDirectoryServiceCfgOwnersGroup ps testCfg False (Just "./tests/tmp/web") $ \superUser dsLink ->
withNewTestChat ps "bob" bobProfile $ \bob ->
withNewTestChat ps "cath" cathProfile $ \cath -> do
bob `connectVia` dsLink
cath `connectVia` dsLink
registerGroup superUser bob "privacy" "Privacy"
checkListings ["privacy"] []
connectUsers bob cath
fullAddMember "privacy" "Privacy" bob cath GRMember
joinGroup "privacy" cath bob
@@ -1075,7 +1079,9 @@ testListUserGroups ps =
cath <## "contact and member are merged: 'SimpleX Directory', #privacy 'SimpleX Directory_1'"
cath <## "use @'SimpleX Directory' <message> to send messages"
registerGroupId superUser bob "security" "Security" 2 2
checkListings ["privacy", "security"] []
registerGroupId superUser cath "anonymity" "Anonymity" 3 1
checkListings ["privacy", "security", "anonymity"] []
listUserGroup cath "anonymity" "Anonymity"
-- with de-listed group
groupFound cath "anonymity"
@@ -1085,8 +1091,51 @@ testListUserGroups ps =
cath <## ""
cath <## "The group is no longer listed in the directory."
superUser <# "'SimpleX Directory'> The group ID 3 (anonymity) is de-listed (SimpleX Directory role is changed to member)."
checkListings ["privacy", "security"] []
groupNotFound cath "anonymity"
listGroups superUser bob cath
when promote $ do
superUser #> "@'SimpleX Directory' /promote 1:privacy on"
superUser <# "'SimpleX Directory'> > /promote 1:privacy on"
superUser <## " Group promotion enabled."
checkListings ["privacy", "security"] ["privacy"]
bob ##> "/gp privacy privacy"
bob <## "description removed"
bob <# "'SimpleX Directory'> The group ID 1 (privacy) is updated!"
bob <## "It is hidden from the directory until approved."
cath <## "bob updated group #privacy:"
cath <## "description removed"
superUser <# "'SimpleX Directory'> The group ID 1 (privacy) is updated."
superUser <# "'SimpleX Directory'> bob submitted the group ID 1:"
superUser <## "privacy"
superUser <## "Welcome message:"
superUser <##. "Link to join the group privacy: https://localhost/g#"
superUser <## "3 members"
superUser <## ""
superUser <## "To approve send:"
superUser <# "'SimpleX Directory'> /approve 1:privacy 1 promote=on"
checkListings ["security"] []
superUser #> "@'SimpleX Directory' /approve 1:privacy 1"
superUser <# "'SimpleX Directory'> > /approve 1:privacy 1"
superUser <## " Group approved!"
bob <# "'SimpleX Directory'> The group ID 1 (privacy) is approved and listed in directory - please moderate it!"
bob <## "Please note: if you change the group profile it will be hidden from directory until it is re-approved."
bob <## ""
bob <## "Supported commands:"
bob <## "/'filter 1' - to configure anti-spam filter."
bob <## "/'role 1' - to set default member role."
bob <## "/'link 1' - to view/upgrade group link."
checkListings ["privacy", "security"] ["privacy"]
checkListings :: [T.Text] -> [T.Text] -> IO ()
checkListings listed promoted = do
checkListing listingFileName listed
checkListing promotedFileName promoted
where
checkListing f expected = do
Just (DirectoryListing gs) <- J.decodeFileStrict $ "./tests/tmp/web" </> f
map groupName gs `shouldBe` expected
groupName DirectoryEntry {displayName} = displayName
testCapthaScreening :: HasCallStack => TestParams -> IO ()
testCapthaScreening ps =
@@ -1176,7 +1225,7 @@ testCapthaScreening ps =
testRestoreDirectory :: HasCallStack => TestParams -> IO ()
testRestoreDirectory ps = do
testListUserGroups ps
testListUserGroups False ps
restoreDirectoryService ps 3 3 $ \superUser _dsLink ->
withTestChat ps "bob" $ \bob ->
withTestChat ps "cath" $ \cath -> do
@@ -1294,10 +1343,10 @@ withDirectoryService :: HasCallStack => TestParams -> (TestCC -> String -> IO ()
withDirectoryService ps = withDirectoryServiceCfg ps testCfg
withDirectoryServiceCfg :: HasCallStack => TestParams -> ChatConfig -> (TestCC -> String -> IO ()) -> IO ()
withDirectoryServiceCfg ps cfg = withDirectoryServiceCfgOwnersGroup ps cfg False
withDirectoryServiceCfg ps cfg = withDirectoryServiceCfgOwnersGroup ps cfg False Nothing
withDirectoryServiceCfgOwnersGroup :: HasCallStack => TestParams -> ChatConfig -> Bool -> (TestCC -> String -> IO ()) -> IO ()
withDirectoryServiceCfgOwnersGroup ps cfg createOwnersGroup test = do
withDirectoryServiceCfgOwnersGroup :: HasCallStack => TestParams -> ChatConfig -> Bool -> Maybe FilePath -> (TestCC -> String -> IO ()) -> IO ()
withDirectoryServiceCfgOwnersGroup ps cfg createOwnersGroup webFolder test = do
dsLink <-
withNewTestChatCfg ps cfg serviceDbPrefix directoryProfile $ \ds ->
withNewTestChatCfg ps cfg "super_user" aliceProfile $ \superUser -> do
@@ -1315,7 +1364,7 @@ withDirectoryServiceCfgOwnersGroup ps cfg createOwnersGroup test = do
superUser <## "#owners: 'SimpleX Directory' joined the group"
ds ##> "/ad"
getContactLink ds True
withDirectoryOwnersGroup ps cfg dsLink createOwnersGroup test
withDirectoryOwnersGroup ps cfg dsLink createOwnersGroup webFolder test
restoreDirectoryService :: HasCallStack => TestParams -> Int -> Int -> (TestCC -> String -> IO ()) -> IO ()
restoreDirectoryService ps ctCount grCount test = do
@@ -1332,11 +1381,11 @@ restoreDirectoryService ps ctCount grCount test = do
withDirectory ps testCfg dsLink test
withDirectory :: HasCallStack => TestParams -> ChatConfig -> String -> (TestCC -> String -> IO ()) -> IO ()
withDirectory ps cfg dsLink = withDirectoryOwnersGroup ps cfg dsLink False
withDirectory ps cfg dsLink = withDirectoryOwnersGroup ps cfg dsLink False Nothing
withDirectoryOwnersGroup :: HasCallStack => TestParams -> ChatConfig -> String -> Bool -> (TestCC -> String -> IO ()) -> IO ()
withDirectoryOwnersGroup ps cfg dsLink createOwnersGroup test = do
let opts = mkDirectoryOpts ps [KnownContact 2 "alice"] $ if createOwnersGroup then Just $ KnownGroup 1 "owners" else Nothing
withDirectoryOwnersGroup :: HasCallStack => TestParams -> ChatConfig -> String -> Bool -> Maybe FilePath -> (TestCC -> String -> IO ()) -> IO ()
withDirectoryOwnersGroup ps cfg dsLink createOwnersGroup webFolder test = do
let opts = mkDirectoryOpts ps [KnownContact 2 "alice"] (if createOwnersGroup then Just $ KnownGroup 1 "owners" else Nothing) webFolder
runDirectory cfg opts $
withTestChatCfg ps cfg "super_user" $ \superUser -> do
superUser <## "1 contacts connected (use /cs for the list)"