diff --git a/apps/simplex-directory-service/Main.hs b/apps/simplex-directory-service/Main.hs index e5c3fda573..33145497ea 100644 --- a/apps/simplex-directory-service/Main.hs +++ b/apps/simplex-directory-service/Main.hs @@ -24,3 +24,4 @@ main = do MLCheck -> checkDirectoryLog MLImport -> importDirectoryLogToDB MLExport -> exportDBToDirectoryLog + MLListing -> saveGroupListingFiles diff --git a/apps/simplex-directory-service/src/Directory/Options.hs b/apps/simplex-directory-service/src/Directory/Options.hs index 93a93ed61e..fb82c27b78 100644 --- a/apps/simplex-directory-service/src/Directory/Options.hs +++ b/apps/simplex-directory-service/src/Directory/Options.hs @@ -42,7 +42,7 @@ data DirectoryOpts = DirectoryOpts testing :: Bool } -data MigrateLog = MLCheck | MLImport | MLExport +data MigrateLog = MLCheck | MLImport | MLExport | MLListing directoryOpts :: FilePath -> FilePath -> Parser DirectoryOpts directoryOpts appDir defaultDbName = do @@ -206,4 +206,5 @@ parseMigrateLog = eitherReader $ parseAll mlP . encodeUtf8 . T.pack "check" -> pure MLCheck "import" -> pure MLImport "export" -> pure MLExport + "listing" -> pure MLListing _ -> fail "bad MigrateLog" diff --git a/apps/simplex-directory-service/src/Directory/Store.hs b/apps/simplex-directory-service/src/Directory/Store.hs index b10afc9be9..b78b446821 100644 --- a/apps/simplex-directory-service/src/Directory/Store.hs +++ b/apps/simplex-directory-service/src/Directory/Store.hs @@ -41,6 +41,7 @@ module Directory.Store listLastGroups, listPendingGroups, getAllListedGroups, + getAllListedGroups_, searchListedGroups, groupRegStatusText, pendingApproval, @@ -330,12 +331,14 @@ getUserGroupRegs cc user@User {userId, userContactId} ctId = <$> DB.query db (groupReqQuery <> " AND r.contact_id = ? ORDER BY r.user_group_reg_id") (userId, userContactId, ctId) getAllListedGroups :: ChatController -> User -> IO (Either String [(GroupInfo, GroupReg, Maybe GroupLink)]) -getAllListedGroups cc user@User {userId, userContactId} = - withDB' "getAllListedGroups" cc $ \db -> - DB.query db (groupReqQuery <> " AND r.group_reg_status = ?") (userId, userContactId, GRSActive) - >>= mapM (withGroupLink db . toGroupInfoReg (vr cc) user) +getAllListedGroups cc user = withDB' "getAllListedGroups" cc $ \db -> getAllListedGroups_ db (vr cc) user + +getAllListedGroups_ :: DB.Connection -> VersionRangeChat -> User -> IO [(GroupInfo, GroupReg, Maybe GroupLink)] +getAllListedGroups_ db vr' user@User {userId, userContactId} = + DB.query db (groupReqQuery <> " AND r.group_reg_status = ?") (userId, userContactId, GRSActive) + >>= mapM (withGroupLink . toGroupInfoReg vr' user) where - withGroupLink db (g, gr) = (g,gr,) . eitherToMaybe <$> runExceptT (getGroupLink db user g) + withGroupLink (g, gr) = (g,gr,) . eitherToMaybe <$> runExceptT (getGroupLink db user g) searchListedGroups :: ChatController -> User -> SearchType -> Maybe GroupId -> Int -> IO (Either String ([(GroupInfo, GroupReg)], Int)) searchListedGroups cc user@User {userId, userContactId} searchType lastGroup_ pageSize = diff --git a/apps/simplex-directory-service/src/Directory/Store/Migrate.hs b/apps/simplex-directory-service/src/Directory/Store/Migrate.hs index 06a1846d3f..ad37eba6d7 100644 --- a/apps/simplex-directory-service/src/Directory/Store/Migrate.hs +++ b/apps/simplex-directory-service/src/Directory/Store/Migrate.hs @@ -7,10 +7,14 @@ 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) @@ -18,7 +22,7 @@ import Simplex.Chat.Controller (ChatConfig (..), ChatDatabase (..)) import Simplex.Chat.Options (CoreChatOpts (..)) import Simplex.Chat.Options.DB import Simplex.Chat.Protocol (supportedChatVRange) -import Simplex.Chat.Store.Groups (getHostMember) +import Simplex.Chat.Store.Groups (getGroupInfo, getHostMember) import Simplex.Chat.Store.Profiles (getUsers) import Simplex.Chat.Types import Simplex.Messaging.Agent.Store.Common @@ -26,6 +30,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) @@ -64,12 +69,26 @@ 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 -> do - verifyGroupRegistration db user gr - insertGroupReg db gr + forM_ gs $ \gr -> + whenM (verifyGroupRegistration 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 @@ -82,19 +101,33 @@ exportDBToDirectoryLog opts cfg = withActiveUser st $ \user -> do gs <- withFile logFile WriteMode $ \h -> withTransaction st $ \db -> do gs <- getAllGroupRegs_ db user - forM_ gs $ \(_, gr) -> do - verifyGroupRegistration db user gr - B.hPutStrLn h $ strEncode $ GRCreate gr + forM_ gs $ \(_, gr) -> + whenM (verifyGroupRegistration db user gr) $ + B.hPutStrLn h $ strEncode $ GRCreate gr pure gs putStrLn $ show (length gs) <> " group registrations exported" -verifyGroupRegistration :: DB.Connection -> User -> GroupReg -> IO () -verifyGroupRegistration db user GroupReg {dbGroupId = gId, dbContactId = ctId, dbOwnerMemberId = mId} = - runExceptT (getHostMember db supportedChatVRange user gId) >>= \case - Left e -> exit $ "error loading group " <> show gId <> " host member: " <> show e - Right GroupMember {groupMemberId = mId', memberContactId = ctId'} -> do - unless (mId == Just mId') $ exit $ "bad group " <> show gId <> " host member ID: " <> show mId' - unless (Just ctId == ctId') $ exit $ "bad group " <> show gId <> " contact ID: " <> show ctId' +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 supportedChatVRange user >>= generateListing dir + +verifyGroupRegistration :: DB.Connection -> User -> GroupReg -> IO Bool +verifyGroupRegistration db user GroupReg {dbGroupId = gId, dbContactId = ctId, dbOwnerMemberId, groupRegStatus} = + runExceptT (getGroupInfo db supportedChatVRange user gId) >>= \case + Left e -> False <$ putStrLn ("Error: loading group " <> show gId <> " (skipping): " <> show e) + Right GroupInfo {localDisplayName} -> do + let groupRef = show gId <> " " <> T.unpack localDisplayName + runExceptT (getHostMember db supportedChatVRange user gId) >>= \case + Left e -> False <$ putStrLn ("Error: loading host member of group " <> groupRef <> " (skipping): " <> show e) + Right GroupMember {groupMemberId = mId', memberContactId = ctId'} -> case dbOwnerMemberId of + Nothing -> True <$ putStrLn ("Warning: group " <> groupRef <> " has no owner member ID, host member ID is " <> show mId' <> ", registration status: " <> B.unpack (strEncode groupRegStatus)) + Just mId + | 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 =