directory: improve migration (#6319)

* directory: warn only on missing host member/contact relation

* improve verification

* log imported ID

* fix userGroupRegId in case of duplicate

* log updates of userGroupRegId

* fix the fix

* option to generate listings

* clean up

apps/simplex-directory-service/Main.hs

@@ -24,3 +24,4 @@ main = do
       MLCheck -> checkDirectoryLog
       MLImport -> importDirectoryLogToDB
       MLExport -> exportDBToDirectoryLog
+      MLListing -> saveGroupListingFiles

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"

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 =

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 =