diff --git a/apps/simplex-directory-service/Main.hs b/apps/simplex-directory-service/Main.hs index 33145497ea..f771199dea 100644 --- a/apps/simplex-directory-service/Main.hs +++ b/apps/simplex-directory-service/Main.hs @@ -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 diff --git a/apps/simplex-directory-service/src/Directory/Options.hs b/apps/simplex-directory-service/src/Directory/Options.hs index 199229964a..89709e66d9 100644 --- a/apps/simplex-directory-service/src/Directory/Options.hs +++ b/apps/simplex-directory-service/src/Directory/Options.hs @@ -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, @@ -254,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" diff --git a/apps/simplex-directory-service/src/Directory/Service.hs b/apps/simplex-directory-service/src/Directory/Service.hs index a3af872ac3..7dc165c4df 100644 --- a/apps/simplex-directory-service/src/Directory/Service.hs +++ b/apps/simplex-directory-service/src/Directory/Service.hs @@ -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 "" -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 () diff --git a/apps/simplex-directory-service/src/Directory/Store.hs b/apps/simplex-directory-service/src/Directory/Store.hs index e3465e64b1..94375eb025 100644 --- a/apps/simplex-directory-service/src/Directory/Store.hs +++ b/apps/simplex-directory-service/src/Directory/Store.hs @@ -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.") diff --git a/apps/simplex-directory-service/src/Directory/Store/Migrate.hs b/apps/simplex-directory-service/src/Directory/Store/Migrate.hs index d501fbd5c3..1a5c45348a 100644 --- a/apps/simplex-directory-service/src/Directory/Store/Migrate.hs +++ b/apps/simplex-directory-service/src/Directory/Store/Migrate.hs @@ -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 diff --git a/tests/Bots/DirectoryTests.hs b/tests/Bots/DirectoryTests.hs index 7643c3b971..4f726bdc80 100644 --- a/tests/Bots/DirectoryTests.hs +++ b/tests/Bots/DirectoryTests.hs @@ -19,9 +19,7 @@ import Directory.Captcha import Directory.Listing import Directory.Options import Directory.Service -import Directory.Store import System.Directory (emptyPermissions, setOwnerExecutable, setOwnerReadable, setOwnerWritable, setPermissions) -import System.IO (hClose) import Simplex.Chat.Bot.KnownContacts import Simplex.Chat.Controller (ChatConfig (..)) import qualified Simplex.Chat.Markdown as MD @@ -136,8 +134,6 @@ mkDirectoryOpts TestParams {tmpPath = ps} superUsers ownersGroup webFolder = profileNameLimit = maxBound, captchaGenerator = Nothing, voiceCaptchaGenerator = Nothing, - directoryLog = Just $ ps "directory_service.log", - migrateDirectoryLog = Nothing, serviceName = "SimpleX Directory", clientService = True, runCLI = False, @@ -1801,11 +1797,10 @@ withDirectoryOwnersGroup ps cfg dsLink createOwnersGroup webFolder test = do test superUser dsLink runDirectory :: ChatConfig -> DirectoryOpts -> IO () -> IO () -runDirectory cfg opts@DirectoryOpts {directoryLog} action = do - st <- openDirectoryLog directoryLog - t <- forkIO $ directoryService st opts cfg +runDirectory cfg opts action = do + t <- forkIO $ directoryService opts cfg threadDelay 500000 - action `finally` (mapM_ hClose (directoryLogFile st) >> killThread t) + action `finally` killThread t registerGroup :: TestCC -> TestCC -> String -> String -> IO () registerGroup su u n fn = registerGroupId su u n fn 1 1