dandri/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-08-22 14:29:49 +00:00
Code Issues Packages Projects Releases Wiki Activity

Merge branch 'master' into sh/play-version

Browse Source
This commit is contained in:
Evgeny Poberezkin
2026-08-04 08:48:54 +01:00
parent 97506da99f 34b74d1c49
commit 38fd687346
61 changed files with 1515 additions and 585 deletions
Download Patch File Download Diff File Expand all files Collapse all files
apps/ios/SimpleXChat/APITypes.swift
+2 -1
View File
@@ -1071,8 +1071,9 @@ public enum SMPHandshakeError: Decodable, Hashable {
public enum SMPAgentError: Decodable, Hashable {
case A_MESSAGE
case A_PROHIBITED
case A_PROHIBITED(prohibitedErr: String)
case A_VERSION
case A_LINK(linkErr: String)
case A_CRYPTO
case A_DUPLICATE
case A_QUEUE(queueErr: String)
apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/model/SimpleXAPI.kt
+3 -1
View File
@@ -8072,13 +8072,15 @@ sealed class SMPAgentError {
is A_MESSAGE -> "A_MESSAGE"
is A_PROHIBITED -> "A_PROHIBITED"
is A_VERSION -> "A_VERSION"
is A_LINK -> "A_LINK"
is A_CRYPTO -> "A_CRYPTO"
is A_DUPLICATE -> "A_DUPLICATE"
is A_QUEUE -> "A_QUEUE"
}
@Serializable @SerialName("A_MESSAGE") object A_MESSAGE: SMPAgentError()
@Serializable @SerialName("A_PROHIBITED") object A_PROHIBITED: SMPAgentError()
@Serializable @SerialName("A_PROHIBITED") class A_PROHIBITED(val prohibitedErr: String): SMPAgentError()
@Serializable @SerialName("A_VERSION") object A_VERSION: SMPAgentError()
@Serializable @SerialName("A_LINK") class A_LINK(val linkErr: String): SMPAgentError()
@Serializable @SerialName("A_CRYPTO") object A_CRYPTO: SMPAgentError()
@Serializable @SerialName("A_DUPLICATE") object A_DUPLICATE: SMPAgentError()
@Serializable @SerialName("A_QUEUE") class A_QUEUE(val queueErr: String): SMPAgentError()
apps/simplex-broadcast-bot/src/Broadcast/Options.hs
+1
View File
@@ -90,6 +90,7 @@ mkChatOpts BroadcastBotOpts {coreOptions, botDisplayName} =
optFilesFolder = Nothing,
optTempDirectory = Nothing,
showReactions = False,
showFullLinks = False,
allowInstantFiles = True,
autoAcceptFileSize = 0,
muteNotifications = True,
apps/simplex-directory-service/Main.hs
+4 -16
View File
@@ -5,23 +5,11 @@ module Main where
import Directory.Options
import Directory.Service
import Directory.Store
import Directory.Store.Migrate
import Simplex.Chat.Terminal (terminalChatConfig)
main :: IO ()
main = do
opts@DirectoryOpts {directoryLog, migrateDirectoryLog, runCLI} <- welcomeGetOpts
case migrateDirectoryLog of
Just cmd -> migrate cmd opts terminalChatConfig
Nothing -> do
st <- openDirectoryLog directoryLog
if runCLI
then directoryServiceCLI st opts
else directoryService st opts terminalChatConfig
where
migrate = \case
MLCheck -> checkDirectoryLog
MLImport -> importDirectoryLogToDB
MLExport -> exportDBToDirectoryLog
MLListing -> saveGroupListingFiles
opts@DirectoryOpts {runCLI} <- welcomeGetOpts
if runCLI
then directoryServiceCLI opts
else directoryService opts terminalChatConfig
apps/simplex-directory-service/src/Directory/Options.hs
+1 -33
View File
@@ -14,14 +14,11 @@ module Directory.Options
)
where
import qualified Data.Attoparsec.ByteString.Char8 as A
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Options.Applicative
import Simplex.Chat.Bot.KnownContacts
import Simplex.Chat.Controller (updateStr, versionNumber, versionString)
import Simplex.Chat.Options (ChatCmdLog (..), ChatOpts (..), CoreChatOpts, CreateBotOpts (..), coreChatOptsP)
import Simplex.Messaging.Parsers (parseAll)
data DirectoryOpts = DirectoryOpts
{ coreOptions :: CoreChatOpts,
@@ -36,8 +33,6 @@ data DirectoryOpts = DirectoryOpts
profileNameLimit :: Int,
captchaGenerator :: Maybe FilePath,
voiceCaptchaGenerator :: Maybe FilePath,
directoryLog :: Maybe FilePath,
migrateDirectoryLog :: Maybe MigrateLog,
serviceName :: T.Text,
clientService :: Bool,
runCLI :: Bool,
@@ -133,21 +128,6 @@ directoryOpts appDir defaultDbName = do
<> metavar "VOICE_CAPTCHA_GENERATOR"
<> help "Executable to generate voice captcha, accepts text as parameter, writes audio file, outputs file_path and duration_seconds to stdout"
)
directoryLog <-
optional $
strOption
( long "directory-file"
<> metavar "DIRECTORY_FILE"
<> help "Append only log for directory state"
)
migrateDirectoryLog <-
optional $
option
parseMigrateLog
( long "migrate-directory-file"
<> metavar "MIGRATE_COMMAND"
<> help "Command to import/export directory log file"
)
serviceName <-
strOption
( long "service-name"
@@ -209,8 +189,6 @@ directoryOpts appDir defaultDbName = do
profileNameLimit,
captchaGenerator,
voiceCaptchaGenerator,
directoryLog,
migrateDirectoryLog,
serviceName = T.pack serviceName,
clientService,
runCLI,
@@ -245,6 +223,7 @@ mkChatOpts DirectoryOpts {coreOptions, serviceName, clientService} =
optFilesFolder = Nothing,
optTempDirectory = Nothing,
showReactions = False,
showFullLinks = False,
allowInstantFiles = True,
autoAcceptFileSize = 0,
muteNotifications = True,
@@ -253,14 +232,3 @@ mkChatOpts DirectoryOpts {coreOptions, serviceName, clientService} =
userDisplayName = Nothing,
userImageFile = Nothing
}
parseMigrateLog :: ReadM MigrateLog
parseMigrateLog = eitherReader $ parseAll mlP . encodeUtf8 . T.pack
where
mlP =
A.takeTill (== ' ') >>= \case
"check" -> pure MLCheck
"import" -> pure MLImport
"export" -> pure MLExport
"listing" -> pure MLListing
_ -> fail "bad MigrateLog"
apps/simplex-directory-service/src/Directory/Service.hs
+48 -55
View File
@@ -154,8 +154,8 @@ welcomeGetOpts = do
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
directoryServiceCLI :: DirectoryOpts -> IO ()
directoryServiceCLI opts = do
env@ServiceState {eventQ} <- newServiceState opts
let eventHook _cc resp = atomically $ resp <$ mapM_ (writeTQueue eventQ) (crDirectoryEvent resp)
chatHooks =
@@ -178,7 +178,7 @@ directoryServiceCLI st opts = do
forM_ u_ $ \user ->
forever $ do
event <- atomically $ readTQueue eventQ
directoryServiceEvent st opts env user cc event
directoryServiceEvent opts env user cc event
updateListingDelay :: Int
updateListingDelay = 5 * 60 * 1000000 -- update every 5 minutes
@@ -249,8 +249,8 @@ directoryCommands =
where
idParam = Just "<ID>"
directoryService :: DirectoryLog -> DirectoryOpts -> ChatConfig -> IO ()
directoryService st opts cfg = do
directoryService :: DirectoryOpts -> ChatConfig -> IO ()
directoryService opts cfg = do
env@ServiceState {eventQ} <- newServiceState opts
let chatHooks =
defaultChatHooks
@@ -265,7 +265,7 @@ directoryService st opts cfg = do
mapM_ (atomically . writeTQueue eventQ) $ crDirectoryEvent resp,
forever $ do
event <- atomically $ readTQueue eventQ
directoryServiceEvent st opts env user cc event
directoryServiceEvent opts env user cc event
]
<> maybeToList (updateListingsThread_ opts env)
<> maybeToList (linkCheckThread_ opts env)
@@ -317,8 +317,8 @@ readBlockedWordsConfig DirectoryOpts {blockedFragmentsFile, blockedWordsFile, na
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 -> DirectoryEvent -> IO ()
directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName, ownersGroup, searchResults, prohibitedToObserver, alwaysCaptcha} env@ServiceState {searchRequests} user@User {userId} cc = \case
directoryServiceEvent :: DirectoryOpts -> ServiceState -> User -> ChatController -> DirectoryEvent -> IO ()
directoryServiceEvent opts@DirectoryOpts {adminUsers, superUsers, serviceName, ownersGroup, searchResults, prohibitedToObserver, alwaysCaptcha} env@ServiceState {searchRequests} user@User {userId} cc = \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
@@ -420,8 +420,8 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
processInvitation :: Contact -> GroupInfo -> Maybe GroupReg -> IO ()
processInvitation ct g@GroupInfo {groupId, groupProfile = GroupProfile {displayName}} = \case
Nothing -> addGroupReg notifyAdminUsers st cc user ct g GRSProposed joinGroup
Just _gr -> setGroupStatus notifyAdminUsers st env cc groupId GRSProposed joinGroup
Nothing -> addGroupReg notifyAdminUsers cc user ct g GRSProposed joinGroup
Just _gr -> setGroupStatus notifyAdminUsers env cc groupId GRSProposed joinGroup
where
joinGroup _ = do
r <- sendChatCmd cc $ APIJoinGroup groupId MFNone
@@ -452,7 +452,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
Left e -> sendMessage cc ct $ "Error: getDuplicateGroup. Please notify the developers.\n" <> T.pack e
where
askConfirmation =
addGroupReg notifyAdminUsers st cc user ct g GRSPendingConfirmation $ \GroupReg {userGroupRegId} -> do
addGroupReg notifyAdminUsers cc user 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
@@ -493,11 +493,10 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
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
setGroupStatus notifyAdminUsers 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\
@@ -576,19 +575,19 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
withDB "getGroupMember" cc (\db -> withExceptT show $ getGroupMember db (storeCxt cc) user groupId ownerGMId) >>= \case
Right ownerMember
| let GroupMember {memberRole = role} = ownerMember, role >= GROwner ->
setGroupStatus notifyAdminUsers st env cc groupId (GRSPendingApproval n') (`updatedNotification` g')
setGroupStatus notifyAdminUsers env cc groupId (GRSPendingApproval n') (`updatedNotification` g')
| otherwise -> do
setGroupStatus notifyAdminUsers st env cc groupId GRSSuspendedBadRoles $ \_ -> pure ()
setGroupStatus notifyAdminUsers env cc groupId GRSSuspendedBadRoles $ \_ -> pure ()
notifyOwner gr $ "The registration owner is no longer an owner. Registration suspended."
Left _ -> logError $ "could not find owner member for " <> groupRef
Nothing -> logError $ "no owner member set for " <> groupRef
_ ->
setGroupStatus notifyAdminUsers st env cc groupId (GRSPendingApproval n') (`updatedNotification` toGroup)
setGroupStatus notifyAdminUsers env cc groupId (GRSPendingApproval n') (`updatedNotification` toGroup)
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
_ -> setGroupStatus notifyAdminUsers 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."
@@ -599,16 +598,16 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
let userGroupRef = userGroupReference gr toGroup
groupRef = groupReference toGroup
groupProfileUpdate >>= \case
GPNoServiceLink -> setGroupStatus notifyAdminUsers st env cc groupId GRSPendingUpdate $ \gr' -> do
GPNoServiceLink -> setGroupStatus notifyAdminUsers 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
GPServiceLinkRemoved -> setGroupStatus notifyAdminUsers 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
GPServiceLinkAdded _ -> setGroupStatus notifyAdminUsers 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."
@@ -620,7 +619,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
("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
| otherwise -> setGroupStatus notifyAdminUsers env cc groupId (GRSPendingApproval n') $ \gr' -> do
notifyOwner gr' $
("The group " <> userGroupRef <> " is updated" <> byMember)
<> "!\nIt is hidden from the directory until approved."
@@ -839,7 +838,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
when groupUpdated $ reapprove pg gr groupRegStatus g''
when (groupUpdated || summary /= groupSummary g'' || groupDomainVerified g'' /= groupDomainVerified gInfo) $ listingsUpdated env
Left (ChatErrorAgent {agentError = SMP _ err}) | linkDeleted err ->
setGroupStatus logError st env cc groupId GRSRemoved $ \gr' ->
setGroupStatus logError env cc groupId GRSRemoved $ \gr' ->
notifyOwner gr' "The channel link is no longer valid.\nThe channel is removed from the directory."
_ -> pure ()
where
@@ -852,7 +851,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
withDB "checkGroupLink" cc (\db -> withExceptT show $ getGroupMember db (storeCxt cc) user groupId ownerGMId) >>= \case
Right GroupMember {memberId, memberPubKey}
| any (\GroupLinkOwner {memberId = mId, memberKey} -> memberId == mId && memberPubKey == Just memberKey) owners -> onValid
_ -> setGroupStatus logError st env cc groupId GRSSuspendedBadRoles $ \gr' ->
_ -> setGroupStatus logError env cc groupId GRSSuspendedBadRoles $ \gr' ->
notifyOwner gr' "The registration owner is no longer a channel owner.\nThe channel is no longer listed in the directory."
Nothing -> onValid
reapprove pg gr groupRegStatus g' = do
@@ -861,7 +860,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
notifyAdminUsers $ "The " <> gt <> " " <> groupRef <> " profile changed."
case groupRegStatus of
GRSActive ->
setGroupStatus notifyAdminUsers st env cc groupId (GRSPendingApproval 1) $ \gr' -> do
setGroupStatus notifyAdminUsers env cc groupId (GRSPendingApproval 1) $ \gr' -> do
notifyOwner gr' $ "The " <> gt <> " profile has changed.\nIt is hidden from the directory until approved."
sendToApprove g' gr' 1
GRSPendingApproval n ->
@@ -877,14 +876,14 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
when (ctId `isOwner` gr) $
case groupRegStatus of
GRSSuspendedBadRoles | rStatus == GRSOk ->
setGroupStatus notifyAdminUsers st env cc groupId GRSActive $ \gr' -> do
setGroupStatus notifyAdminUsers 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
verifyAndSendToApprove 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
setGroupStatus notifyAdminUsers 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 ()
@@ -903,7 +902,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
case groupRegStatus of
GRSSuspendedBadRoles | serviceRole == GRAdmin ->
whenContactIsOwner gr $
setGroupStatus notifyAdminUsers st env cc groupId GRSActive $ \gr' -> do
setGroupStatus notifyAdminUsers 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 ->
@@ -911,7 +910,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
verifyAndSendToApprove 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
setGroupStatus notifyAdminUsers 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 ()
@@ -929,7 +928,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
logInfo $ "contact ID " <> tshow ctId <> " removed from group " <> viewGroupName g
withGroupReg g "contact removed" $ \gr ->
when (ctId `isOwner` gr) $
setGroupStatus notifyAdminUsers st env cc groupId GRSRemoved $ \gr' -> do
setGroupStatus notifyAdminUsers env cc groupId GRSRemoved $ \gr' -> do
notifyOwner gr' $ "You are removed from the " <> gt <> " " <> userGroupReference gr' g <> ".\n\nThe " <> gt <> " is no longer listed in the directory."
notifyAdminUsers $ "The " <> gt <> " " <> groupReference g <> " is de-listed (" <> gt <> " owner is removed)."
when (isJust pg_) $ leavePublicGroup g
@@ -940,7 +939,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
logInfo $ "contact ID " <> tshow ctId <> " left group " <> viewGroupName g
withGroupReg g "contact left" $ \gr ->
when (ctId `isOwner` gr) $
setGroupStatus notifyAdminUsers st env cc groupId GRSRemoved $ \gr' -> do
setGroupStatus notifyAdminUsers env cc groupId GRSRemoved $ \gr' -> do
notifyOwner gr' $ "You left the " <> gt <> " " <> userGroupReference gr' g <> ".\n\nThe " <> gt <> " is no longer listed in the directory."
notifyAdminUsers $ "The " <> gt <> " " <> groupReference g <> " is de-listed (" <> gt <> " owner left)."
when (isJust pg_) $ leavePublicGroup g
@@ -949,7 +948,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
deServiceRemovedFromGroup g@GroupInfo {groupId, groupProfile = GroupProfile {publicGroup = pg_}} = do
let gt = maybe "group" groupTypeStr' pg_
logInfo $ "service removed from group " <> viewGroupName g
setGroupStatus notifyAdminUsers st env cc groupId GRSRemoved $ \gr -> do
setGroupStatus notifyAdminUsers env cc groupId GRSRemoved $ \gr -> do
notifyOwner gr $ serviceName <> " is removed from the " <> gt <> " " <> userGroupReference gr g <> ".\n\nThe " <> gt <> " is no longer listed in the directory."
notifyAdminUsers $ "The " <> gt <> " " <> groupReference g <> " is de-listed (directory service is removed)."
@@ -957,7 +956,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
deGroupDeleted g@GroupInfo {groupId, groupProfile = GroupProfile {publicGroup = pg_}} = do
let gt = maybe "group" groupTypeStr' pg_
logInfo $ "group removed " <> viewGroupName g
setGroupStatus notifyAdminUsers st env cc groupId GRSRemoved $ \gr -> do
setGroupStatus notifyAdminUsers env cc groupId GRSRemoved $ \gr -> do
notifyOwner gr $ "The " <> gt <> " " <> userGroupReference gr g <> " is deleted.\n\nThe " <> gt <> " is no longer listed in the directory."
notifyAdminUsers $ "The " <> gt <> " " <> groupReference g <> " is de-listed (" <> gt <> " is deleted)."
@@ -1018,7 +1017,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
sendChatCmd cc (APIPrepareGroup userId ccLink False Nothing groupSLinkData) >>= \case
Right (CRNewPreparedChat _ (AChat SCTGroup (Chat (GroupChat gInfo _) _ _))) -> do
let gId = groupId' gInfo
addGroupReg notifyAdminUsers st cc user ct gInfo GRSProposed $ \_ -> pure ()
addGroupReg notifyAdminUsers cc user ct gInfo GRSProposed $ \_ -> pure ()
sendChatCmd cc (APIConnectPreparedGroup gId False (Just ownerContact) Nothing) >>= \case
Right CRStartedConnectionToGroup {groupInfo = gInfo'} ->
withDB "getGroupMember" cc (\db -> withExceptT show $ getGroupMemberByMemberId db (storeCxt cc) user gInfo' mId) >>= \case
@@ -1043,7 +1042,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
| contactId' ct `isOwner` gr -> sameOwnerReregistration gr gt
| otherwise -> sendMessage cc ct $ "This " <> gt <> " is registered by another owner."
Left _ ->
addGroupReg notifyAdminUsers st cc user ct g (GRSPendingApproval 1) $ \gr -> do
addGroupReg notifyAdminUsers cc user ct g (GRSPendingApproval 1) $ \gr -> do
void $ setGroupRegOwner cc groupId ownerMember
verifyAndSendToApprove g gr 1
| role < GROwner -> sendMessage cc ct $ "You must be the " <> gt <> " owner to register it."
@@ -1065,7 +1064,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
GRSRemoved -> pendingApprovalTransition gr gt 1
pendingApprovalTransition gr gt n = do
let userGroupRef = userGroupReference gr g
setGroupStatus notifyAdminUsers st env cc groupId (GRSPendingApproval n) $ \gr' -> do
setGroupStatus notifyAdminUsers env cc groupId (GRSPendingApproval n) $ \gr' -> do
notifyOwner gr' $
"The " <> gt <> " " <> userGroupRef <> " is submitted for approval.\nIt is hidden from the directory until approved."
verifyAndSendToApprove g gr' n
@@ -1079,12 +1078,12 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
let GroupMember {memberRole = role} = toMember
gt = maybe "group" groupTypeStr' publicGroup
in if role >= GROwner
then setGroupStatus notifyAdminUsers st env cc groupId (GRSPendingApproval 1) $ \gr' -> do
then setGroupStatus notifyAdminUsers env cc groupId (GRSPendingApproval 1) $ \gr' -> do
notifyOwner gr' $ "Joined the " <> gt <> " " <> displayName <> ". Registration is pending approval — it may take up to 48 hours."
notifyOwner gr' $ recommendedSettingsNotice (userGroupRegId gr')
verifyAndSendToApprove g gr' 1
else do
setGroupStatus notifyAdminUsers st env cc groupId GRSRemoved $ \_ -> pure ()
setGroupStatus notifyAdminUsers env cc groupId GRSRemoved $ \_ -> pure ()
sendMessage' cc (dbContactId gr) "The signing key does not belong to a current owner. Registration cancelled."
deUserCommand :: Contact -> ChatItemId -> DirectoryCmd 'DRUser -> IO ()
@@ -1159,7 +1158,6 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
let gt = maybe "group" groupTypeStr' pg_
delGroupReg cc dbGroupId >>= \case
Right () -> do
logGDelete st dbGroupId
sendReply $ (if isAdmin then "The " <> gt <> " " else "Your " <> gt <> " ") <> displayName <> " is deleted from the directory"
when (isJust pg_) $ leavePublicGroup g
Left e -> sendReply $ "Error deleting " <> gt <> " " <> displayName <> ": " <> T.pack e
@@ -1333,7 +1331,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
let grPromoted'
| promoted || knownCt `elem` superUsers = fromMaybe promoted promote
| otherwise = False
setGroupStatusPromo sendReply st env cc gr GRSActive grPromoted' $ do
setGroupStatusPromo sendReply env cc gr GRSActive grPromoted' $ do
let approved = "The " <> gt <> " " <> userGroupReference' gr n <> " is approved"
let commands
| isPublicGroup_ = ""
@@ -1371,7 +1369,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
let groupRef = groupReference' groupId gName
withGroupAndReg sendReply groupId gName $ \_ gr ->
case groupRegStatus gr of
GRSActive -> setGroupStatus sendReply st env cc groupId GRSSuspended $ \gr' -> do
GRSActive -> setGroupStatus sendReply 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!"
@@ -1381,7 +1379,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
let groupRef = groupReference' groupId gName
withGroupAndReg sendReply groupId gName $ \_ gr ->
case groupRegStatus gr of
GRSSuspended -> setGroupStatus sendReply st env cc groupId GRSActive $ \gr' -> do
GRSSuspended -> setGroupStatus sendReply 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!"
@@ -1452,7 +1450,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
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
then setGroupPromoted sendReply env cc gr promote' notify
else notify
DCExecuteCommand cmdStr ->
sendChatCmdStr cc cmdStr >>= \case
@@ -1510,48 +1508,43 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
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
setGroupStatusPromo :: (Text -> IO ()) -> ServiceState -> ChatController -> GroupReg -> GroupRegStatus -> Bool -> IO () -> IO ()
setGroupStatusPromo sendReply 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
logGUpdateStatus st gId grStatus'
logGUpdatePromotion st gId grPromoted'
continue
addGroupReg :: (Text -> IO ()) -> DirectoryLog -> ChatController -> User -> Contact -> GroupInfo -> GroupRegStatus -> (GroupReg -> IO ()) -> IO ()
addGroupReg sendMsg st cc user ct g@GroupInfo {groupId} grStatus continue =
addGroupReg :: (Text -> IO ()) -> ChatController -> User -> Contact -> GroupInfo -> GroupRegStatus -> (GroupReg -> IO ()) -> IO ()
addGroupReg sendMsg cc user 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
let d = toCustomData $ DirectoryGroupData newGroupJoinFilter
withDB' "setGroupCustomData" cc (\db -> setGroupCustomData db user g $ Just d) >>= \case
Right () -> pure ()
Left e -> sendMsg $ "Error setting default captcha for group " <> tshow groupId <> ": " <> T.pack e
continue gr
setGroupStatus :: (Text -> IO ()) -> DirectoryLog -> ServiceState -> ChatController -> GroupId -> GroupRegStatus -> (GroupReg -> IO ()) -> IO ()
setGroupStatus sendMsg st env cc gId grStatus' continue = do
setGroupStatus :: (Text -> IO ()) -> ServiceState -> ChatController -> GroupId -> GroupRegStatus -> (GroupReg -> IO ()) -> IO ()
setGroupStatus sendMsg 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
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 =
setGroupPromoted :: (Text -> IO ()) -> ServiceState -> ChatController -> GroupReg -> Bool -> IO () -> IO ()
setGroupPromoted sendReply 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
logGUpdatePromotion st gId grPromoted'
continue
updateGroupListingFiles :: ChatController -> User -> FilePath -> IO ()
apps/simplex-directory-service/src/Directory/Store.hs
+2 -144
View File
@@ -11,8 +11,7 @@
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module Directory.Store
( DirectoryLog (..),
GroupReg (..),
( GroupReg (..),
GroupRegStatus (..),
UserGroupRegId,
GroupApprovalId,
@@ -20,9 +19,6 @@ module Directory.Store
DirectoryMemberAcceptance (..),
DirectoryStatus (..),
ProfileCondition (..),
DirectoryLogRecord (..),
openDirectoryLog,
readDirectoryLogData,
addGroupRegStore,
insertGroupReg,
delGroupReg,
@@ -55,16 +51,9 @@ module Directory.Store
strongJoinFilter,
newGroupJoinFilter,
groupDBError,
logGCreate,
logGDelete,
logGUpdateOwner,
logGUpdateStatus,
logGUpdatePromotion,
)
where
import Control.Applicative ((<|>))
import Control.Monad
import Control.Monad.Except
import Control.Monad.IO.Class
import Data.Aeson ((.:), (.=))
@@ -72,18 +61,12 @@ import qualified Data.Aeson.KeyMap as JM
import qualified Data.Aeson.TH as JQ
import qualified Data.Aeson.Types as JT
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Int (Int64)
import Data.List (sortOn)
import Data.Map (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe, isJust)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Data.Time.Clock (UTCTime (..), getCurrentTime)
import Data.Time.Clock.System (systemEpochDay)
import Directory.Search
import Directory.Util
import Simplex.Chat.Controller
@@ -99,7 +82,6 @@ import qualified Simplex.Messaging.Agent.Store.DB as DB
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON)
import Simplex.Messaging.Util (eitherToMaybe, firstRow, maybeFirstRow', safeDecodeUtf8)
import System.IO (BufferMode (..), Handle, IOMode (..), hSetBuffering, openFile)
#if defined(dbPostgres)
import Database.PostgreSQL.Simple (Only (..), Query, (:.) (..))
@@ -109,10 +91,6 @@ import Database.SQLite.Simple (Only (..), Query, (:.) (..))
import Database.SQLite.Simple.QQ (sql)
#endif
data DirectoryLog = DirectoryLog
{ directoryLogFile :: Maybe Handle
}
data GroupReg = GroupReg
{ dbGroupId :: GroupId,
userGroupRegId :: UserGroupRegId,
@@ -472,89 +450,6 @@ groupReqQuery = groupInfoQueryFields <> groupRegFields <> groupInfoQueryFrom <>
groupRegFields = ", r.group_id, r.user_group_reg_id, r.contact_id, r.owner_member_id, r.group_reg_status, r.group_promoted, r.created_at "
groupRegFromCond = " JOIN sx_directory_group_regs r ON r.group_id = g.group_id WHERE g.user_id = ? AND mu.contact_id = ? "
data DirectoryLogRecord
= GRCreate GroupReg
| GRDelete GroupId
| GRUpdateStatus GroupId GroupRegStatus
| GRUpdatePromotion GroupId Bool
| GRUpdateOwner GroupId GroupMemberId
data DLRTag
= GRCreate_
| GRDelete_
| GRUpdateStatus_
| GRUpdatePromotion_
| GRUpdateOwner_
logDLR :: DirectoryLog -> DirectoryLogRecord -> IO ()
logDLR st r = forM_ (directoryLogFile st) $ \h -> B.hPutStrLn h (strEncode r)
logGCreate :: DirectoryLog -> GroupReg -> IO ()
logGCreate st = logDLR st . GRCreate
logGDelete :: DirectoryLog -> GroupId -> IO ()
logGDelete st = logDLR st . GRDelete
logGUpdateStatus :: DirectoryLog -> GroupId -> GroupRegStatus -> IO ()
logGUpdateStatus st gId = logDLR st . GRUpdateStatus gId
logGUpdatePromotion :: DirectoryLog -> GroupId -> Bool -> IO ()
logGUpdatePromotion st gId = logDLR st . GRUpdatePromotion gId
logGUpdateOwner :: DirectoryLog -> GroupId -> GroupMemberId -> IO ()
logGUpdateOwner st gId = logDLR st . GRUpdateOwner gId
instance StrEncoding DLRTag where
strEncode = \case
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"
instance StrEncoding DirectoryLogRecord where
strEncode = \case
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 GroupReg where
strEncode GroupReg {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
promoted <- (" promoted=" *> strP) <|> pure False
let createdAt = UTCTime systemEpochDay 0
pure GroupReg {dbGroupId, userGroupRegId, dbContactId, dbOwnerMemberId, groupRegStatus, promoted, createdAt}
instance StrEncoding GroupRegStatus where
strEncode = \case
GRSPendingConfirmation -> "pending_confirmation"
@@ -580,40 +475,3 @@ instance StrEncoding GroupRegStatus where
instance ToField GroupRegStatus where toField = toField . safeDecodeUtf8 . strEncode
instance FromField GroupRegStatus where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8
openDirectoryLog :: Maybe FilePath -> IO DirectoryLog
openDirectoryLog = \case
Just f -> DirectoryLog . Just <$> openLogFile f
Nothing -> pure $ DirectoryLog Nothing
where
openLogFile f = do
h <- openFile f AppendMode
hSetBuffering h LineBuffering
pure h
readDirectoryLogData :: FilePath -> IO [GroupReg]
readDirectoryLogData f =
sortOn dbGroupId . M.elems
<$> (foldM processDLR M.empty . B.lines =<< B.readFile f)
where
processDLR :: Map GroupId GroupReg -> ByteString -> IO (Map GroupId GroupReg)
processDLR m l = case strDecode l of
Left e -> m <$ putStrLn ("Error parsing log record: " <> e <> ", " <> B.unpack (B.take 80 l))
Right r -> case r of
GRCreate gr@GroupReg {dbGroupId = gId} -> do
when (isJust $ M.lookup gId m) $
putStrLn $
"Warning: duplicate group with ID " <> show gId <> ", group replaced."
pure $ M.insert gId gr m
GRDelete gId -> case M.lookup gId m of
Just _ -> pure $ M.delete gId m
Nothing -> m <$ putStrLn ("Warning: no group with ID " <> show gId <> ", deletion ignored.")
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.")
apps/simplex-directory-service/src/Directory/Store/Migrate.hs
+1 -69
View File
@@ -7,18 +7,15 @@
module Directory.Store.Migrate where
import Control.Concurrent.STM
import Control.Monad
import Control.Monad.Except
import qualified Data.ByteString.Char8 as B
import Data.List (find)
import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import Directory.Listing
import Directory.Options
import Directory.Store
import Simplex.Chat (createChatDatabase)
import Simplex.Chat.Controller (ChatConfig (..), ChatDatabase (..), mkStoreCxt)
import Simplex.Chat.Controller (ChatConfig (..), ChatDatabase (..))
import Simplex.Chat.Options (CoreChatOpts (..))
import Simplex.Chat.Options.DB
import Simplex.Chat.Store.Groups (getHostMember)
@@ -30,11 +27,7 @@ import qualified Simplex.Messaging.Agent.Store.DB as DB
import Simplex.Messaging.Agent.Store.Interface (closeDBStore, migrateDBSchema)
import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationConfirmation (..))
import Simplex.Messaging.Encoding.String
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Util (whenM)
import System.Directory (doesFileExist, renamePath)
import System.Exit (exitFailure)
import System.IO (IOMode (..), withFile)
#if defined(dbPostgres)
import Directory.Store.Postgres.Migrations
@@ -55,66 +48,9 @@ runDirectoryMigrations opts ChatConfig {confirmMigrations} chatStore =
DirectoryOpts {coreOptions = CoreChatOpts {dbOptions, yesToUpMigrations}} = opts
confirm = if confirmMigrations == MCConsole && yesToUpMigrations then MCYesUp else confirmMigrations
checkDirectoryLog :: DirectoryOpts -> ChatConfig -> IO ()
checkDirectoryLog opts cfg =
withDirectoryLog opts $ \logFile -> withChatStore opts $ \st -> do
runDirectoryMigrations opts cfg st
gs <- readDirectoryLogData logFile
withActiveUser st $ \user -> withTransaction st $ \db -> do
mapM_ (verifyGroupRegistration (mkStoreCxt cfg) db user) gs
putStrLn $ show (length gs) <> " group registrations OK"
importDirectoryLogToDB :: DirectoryOpts -> ChatConfig -> IO ()
importDirectoryLogToDB opts cfg = do
withDirectoryLog opts $ \logFile -> withChatStore opts $ \st -> do
runDirectoryMigrations opts cfg st
gs <- readDirectoryLogData logFile
ctRegs <- TM.emptyIO
withActiveUser st $ \user -> withTransaction st $ \db -> do
forM_ gs $ \gr ->
whenM (verifyGroupRegistration (mkStoreCxt cfg) db user gr) $ do
putStrLn $ "importing group " <> show (dbGroupId gr)
insertGroupReg db =<< fixUserGroupRegId ctRegs gr
renamePath logFile (logFile ++ ".bak")
putStrLn $ show (length gs) <> " group registrations imported"
where
fixUserGroupRegId ctRegs gr@GroupReg {dbGroupId, dbContactId} = do
ugIds <- fromMaybe [] <$> TM.lookupIO dbContactId ctRegs
gr' <-
if userGroupRegId gr `elem` ugIds
then do
let ugId = maximum ugIds + 1
putStrLn $ "Warning: updating userGroupRegId for group " <> show dbGroupId <> ", contact " <> show dbContactId
pure gr {userGroupRegId = ugId}
else pure gr
atomically $ TM.insert dbContactId (userGroupRegId gr' : ugIds) ctRegs
pure gr'
exit :: String -> IO a
exit err = putStrLn ("Error: " <> err) >> exitFailure
exportDBToDirectoryLog :: DirectoryOpts -> ChatConfig -> IO ()
exportDBToDirectoryLog opts cfg =
withDirectoryLog opts $ \logFile -> withChatStore opts $ \st -> do
whenM (doesFileExist logFile) $ exit $ "directory log file " ++ logFile ++ " already exists"
runDirectoryMigrations opts cfg st
withActiveUser st $ \user -> do
gs <- withFile logFile WriteMode $ \h -> withTransaction st $ \db -> do
gs <- getAllGroupRegs_ db (mkStoreCxt cfg) user
forM_ gs $ \(_, gr) ->
whenM (verifyGroupRegistration (mkStoreCxt cfg) db user gr) $
B.hPutStrLn h $ strEncode $ GRCreate gr
pure gs
putStrLn $ show (length gs) <> " group registrations exported"
saveGroupListingFiles :: DirectoryOpts -> ChatConfig -> IO ()
saveGroupListingFiles opts cfg = case webFolder opts of
Nothing -> exit "use --web-folder to generate listings"
Just dir ->
withChatStore opts $ \st -> withActiveUser st $ \user ->
withTransaction st $ \db ->
getAllListedGroups_ db (mkStoreCxt cfg) user >>= generateListing dir
verifyGroupRegistration :: StoreCxt -> DB.Connection -> User -> GroupReg -> IO Bool
verifyGroupRegistration cxt db user GroupReg {dbGroupId = gId, dbContactId = ctId, dbOwnerMemberId, groupRegStatus} =
runExceptT (getGroupInfo db cxt user gId) >>= \case
@@ -129,10 +65,6 @@ verifyGroupRegistration cxt db user GroupReg {dbGroupId = gId, dbContactId = ctI
| mId /= mId' -> False <$ putStrLn ("Error: different host member ID of " <> groupRef <> " (skipping): " <> show mId')
| otherwise -> True <$ unless (Just ctId == ctId') (putStrLn $ "Warning: bad group " <> groupRef <> " contact ID: " <> show ctId')
withDirectoryLog :: DirectoryOpts -> (FilePath -> IO ()) -> IO ()
withDirectoryLog DirectoryOpts {directoryLog} action =
maybe (exit "directory log file not specified") action directoryLog
withChatStore :: DirectoryOpts -> (DBStore -> IO ()) -> IO ()
withChatStore DirectoryOpts {coreOptions = CoreChatOpts {dbOptions, yesToUpMigrations, migrationBackupPath}} action =
createChatDatabase dbOptions migrationConfig >>= \case