directory: store log (#2863)

* directory: store log

* store log test (fails)

* fix store log

apps/simplex-directory-service/Main.hs

@@ -11,5 +11,5 @@ import Simplex.Chat.Terminal (terminalChatConfig)
 main :: IO ()
 main = do
   opts@DirectoryOpts {directoryLog} <- welcomeGetOpts
-  st <- getDirectoryStore directoryLog
+  st <- restoreDirectoryStore directoryLog
   simplexChatCore terminalChatConfig (mkChatOpts opts) Nothing $ directoryService st opts

apps/simplex-directory-service/src/Directory/Events.hs

@@ -7,7 +7,15 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE StandaloneDeriving #-}
 
-module Directory.Events where
+module Directory.Events
+  ( DirectoryEvent (..),
+    DirectoryCmd (..),
+    ADirectoryCmd (..),
+    DirectoryRole (..),
+    SDirectoryRole (..),
+    crDirectoryEvent,
+  )
+where
 
 import Control.Applicative ((<|>))
 import Data.Attoparsec.Text (Parser)

apps/simplex-directory-service/src/Directory/Options.hs

@@ -4,7 +4,12 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
-module Directory.Options where
+module Directory.Options
+ ( DirectoryOpts (..),
+   getDirectoryOpts,
+   mkChatOpts,
+ )
+where
 
 import Options.Applicative
 import Simplex.Chat.Bot.KnownContacts
@@ -14,8 +19,9 @@ import Simplex.Chat.Options (ChatOpts (..), CoreChatOpts, coreChatOptsP)
 data DirectoryOpts = DirectoryOpts
   { coreOptions :: CoreChatOpts,
     superUsers :: [KnownContact],
-    directoryLog :: FilePath,
-    serviceName :: String
+    directoryLog :: Maybe FilePath,
+    serviceName :: String,
+    testing :: Bool
   }
 
 directoryOpts :: FilePath -> FilePath -> Parser DirectoryOpts
@@ -27,14 +33,14 @@ directoryOpts appDir defaultDbFileName = do
       ( long "super-users"
           <> metavar "SUPER_USERS"
           <> help "Comma-separated list of super-users in the format CONTACT_ID:DISPLAY_NAME who will be allowed to manage the directory"
-          <> value []
       )
   directoryLog <-
-    strOption
-      ( long "directory-file"
-          <> metavar "DIRECTORY_FILE"
-          <> help "Append only log for directory state"
-      )
+    Just <$>
+      strOption
+        ( long "directory-file"
+            <> metavar "DIRECTORY_FILE"
+            <> help "Append only log for directory state"
+        )
   serviceName <-
     strOption
       ( long "service-name"
@@ -47,7 +53,8 @@ directoryOpts appDir defaultDbFileName = do
       { coreOptions,
         superUsers,
         directoryLog,
-        serviceName
+        serviceName,
+        testing = False
       }
 
 getDirectoryOpts :: FilePath -> FilePath -> IO DirectoryOpts

apps/simplex-directory-service/src/Directory/Service.hs

@@ -54,14 +54,15 @@ data GroupRolesStatus
 welcomeGetOpts :: IO DirectoryOpts
 welcomeGetOpts = do
   appDir <- getAppUserDataDirectory "simplex"
-  opts@DirectoryOpts {coreOptions = CoreChatOpts {dbFilePrefix}} <- getDirectoryOpts appDir "simplex_directory_service"
-  putStrLn $ "SimpleX Directory Service Bot v" ++ versionNumber
-  putStrLn $ "db: " <> dbFilePrefix <> "_chat.db, " <> dbFilePrefix <> "_agent.db"
+  opts@DirectoryOpts {coreOptions = CoreChatOpts {dbFilePrefix}, testing} <- getDirectoryOpts appDir "simplex_directory_service"
+  unless testing $ do  
+    putStrLn $ "SimpleX Directory Service Bot v" ++ versionNumber
+    putStrLn $ "db: " <> dbFilePrefix <> "_chat.db, " <> dbFilePrefix <> "_agent.db"
   pure opts
 
 directoryService :: DirectoryStore -> DirectoryOpts -> User -> ChatController -> IO ()
-directoryService st DirectoryOpts {superUsers, serviceName} User {userId} cc = do
-  initializeBotAddress cc
+directoryService st DirectoryOpts {superUsers, serviceName, testing} User {userId} cc = do
+  initializeBotAddress' (not testing) cc
   race_ (forever $ void getLine) . forever $ do
     (_, resp) <- atomically . readTBQueue $ outputQ cc
     forM_ (crDirectoryEvent resp) $ \case
@@ -90,14 +91,6 @@ directoryService st DirectoryOpts {superUsers, serviceName} User {userId} cc = d
       atomically (getGroupReg st groupId) >>= \case
         Just gr -> action gr
         Nothing -> putStrLn $ T.unpack $ "Error: " <> err <> ", group: " <> localDisplayName <> ", can't find group registration ID " <> tshow groupId
-    setGroupStatus GroupReg {groupRegStatus, dbGroupId} grStatus = atomically $ do
-      writeTVar groupRegStatus grStatus
-      case grStatus of
-        GRSActive -> listGroup st dbGroupId
-        GRSSuspended -> reserveGroup st dbGroupId
-        GRSSuspendedBadRoles -> reserveGroup st dbGroupId
-        _ -> unlistGroup st dbGroupId
-
     groupInfoText GroupProfile {displayName = n, fullName = fn, description = d} =
       n <> (if n == fn || T.null fn then "" else " (" <> fn <> ")") <> maybe "" ("\nWelcome message:\n" <>) d
     userGroupReference gr GroupInfo {groupProfile = GroupProfile {displayName}} = userGroupReference' gr displayName
@@ -131,7 +124,7 @@ directoryService st DirectoryOpts {superUsers, serviceName} User {userId} cc = d
 
     processInvitation :: Contact -> GroupInfo -> IO ()
     processInvitation ct g@GroupInfo {groupId, groupProfile = GroupProfile {displayName}} = do
-      void $ atomically $ addGroupReg st ct g GRSProposed
+      void $ addGroupReg st ct g GRSProposed
       r <- sendChatCmd cc $ APIJoinGroup groupId
       sendMessage cc ct $ T.unpack $ case r of
         CRUserAcceptedGroupSent {} -> "Joining the group " <> displayName <> "…"
@@ -139,7 +132,7 @@ directoryService st DirectoryOpts {superUsers, serviceName} User {userId} cc = d
 
     deContactConnected :: Contact -> IO ()
     deContactConnected ct = do
-      putStrLn $ T.unpack (localDisplayName' ct) <> " connected"
+      unless testing $ putStrLn $ T.unpack (localDisplayName' ct) <> " connected"
       sendMessage cc ct $
         "Welcome to " <> serviceName <> " service!\n\
         \Send a search string to find groups or */help* to learn how to add groups to directory.\n\n\
@@ -156,7 +149,7 @@ directoryService st DirectoryOpts {superUsers, serviceName} User {userId} cc = d
           Nothing -> sendMessage cc ct "Error: getDuplicateGroup. Please notify the developers."
       where
         askConfirmation = do
-          ugrId <- atomically $ addGroupReg st ct g GRSPendingConfirmation
+          ugrId <- addGroupReg st ct g GRSPendingConfirmation
           sendMessage cc ct $ T.unpack $ "The group " <> displayName <> " (" <> fullName <> ") is already submitted to the directory.\nTo confirm the registration, please send:"
           sendMessage cc ct $ "/confirm " <> show ugrId <> ":" <> T.unpack displayName
 
@@ -193,12 +186,12 @@ directoryService st DirectoryOpts {superUsers, serviceName} User {userId} cc = d
     deServiceJoinedGroup ctId g owner =
       withGroupReg g "joined group" $ \gr ->
         when (ctId `isOwner` gr) $ do
-          atomically $ writeTVar (dbOwnerMemberId gr) (Just $ groupMemberId' owner)
+          setGroupRegOwner st gr owner
           let GroupInfo {groupId, groupProfile = GroupProfile {displayName}} = g
           notifyOwner gr $ T.unpack $ "Joined the group " <> displayName <> ", creating the link…"
           sendChatCmd cc (APICreateGroupLink groupId GRMember) >>= \case
             CRGroupLinkCreated {connReqContact} -> do
-              setGroupStatus gr GRSPendingUpdate
+              setGroupStatus st gr GRSPendingUpdate
               notifyOwner gr
                 "Created the public link to join the group via this directory service that is always online.\n\n\
                 \Please add it to the group welcome message.\n\
@@ -215,7 +208,6 @@ directoryService st DirectoryOpts {superUsers, serviceName} User {userId} cc = d
     deGroupUpdated :: ContactId -> GroupInfo -> GroupInfo -> IO ()
     deGroupUpdated ctId fromGroup toGroup =
       unless (sameProfile p p') $ do
-        atomically $ unlistGroup st groupId
         withGroupReg toGroup "group updated" $ \gr -> do
           let userGroupRef = userGroupReference gr toGroup
           readTVarIO (groupRegStatus gr) >>= \case
@@ -250,28 +242,27 @@ directoryService st DirectoryOpts {superUsers, serviceName} User {userId} cc = d
             Nothing -> notifyOwner gr "Error: getDuplicateGroup. Please notify the developers."
             Just DGReserved -> notifyOwner gr $ groupAlreadyListed toGroup
             _ -> do
-              notifyOwner gr $ "Thank you! The group link for " <> userGroupReference gr toGroup <> " is added to the welcome message.\nYou will be notified once the group is added to the directory - it may take up to 24 hours."
               let gaId = 1
-              setGroupStatus gr $ GRSPendingApproval gaId
+              setGroupStatus st gr $ GRSPendingApproval gaId
+              notifyOwner gr $ "Thank you! The group link for " <> userGroupReference gr toGroup <> " is added to the welcome message.\nYou will be notified once the group is added to the directory - it may take up to 24 hours."
               checkRolesSendToApprove gr gaId
         processProfileChange gr n' = do
+          setGroupStatus st gr GRSPendingUpdate
           let userGroupRef = userGroupReference gr toGroup
               groupRef = groupReference toGroup
           groupProfileUpdate >>= \case
             GPNoServiceLink -> do
-              setGroupStatus gr GRSPendingUpdate
               notifyOwner gr $ "The group profile is updated " <> userGroupRef <> ", but no link is added to the welcome message.\n\nThe group will remain hidden from the directory until the group link is added and the group is re-approved."
             GPServiceLinkRemoved -> do
-              setGroupStatus gr GRSPendingUpdate
               notifyOwner gr $ "The group link for " <> userGroupRef <> " is removed from the welcome message.\n\nThe group is hidden from the directory until the group link is added and the group is re-approved."
               notifySuperUsers $ "The group link is removed from " <> groupRef <> ", de-listed."
             GPServiceLinkAdded -> do
-              setGroupStatus gr $ GRSPendingApproval n'
+              setGroupStatus st gr $ GRSPendingApproval n'
               notifyOwner gr $ "The group link is added to " <> userGroupRef <> "!\nIt is hidden from the directory until approved."
               notifySuperUsers $ "The group link is added to " <> groupRef <> "."
               checkRolesSendToApprove gr n'
             GPHasServiceLink -> do
-              setGroupStatus gr $ GRSPendingApproval n'
+              setGroupStatus st gr $ GRSPendingApproval n'
               notifyOwner gr $ "The group " <> userGroupRef <> " is updated!\nIt is hidden from the directory until approved."
               notifySuperUsers $ "The group " <> groupRef <> " is updated."
               checkRolesSendToApprove gr n'
@@ -313,14 +304,14 @@ directoryService st DirectoryOpts {superUsers, serviceName} User {userId} cc = d
         when (ctId `isOwner` gr) $ do
           readTVarIO (groupRegStatus gr) >>= \case
             GRSSuspendedBadRoles -> when (rStatus == GRSOk) $ do
-              setGroupStatus gr GRSActive
+              setGroupStatus st gr GRSActive
               notifyOwner gr $ uCtRole <> ".\n\nThe group is listed in the directory again."
               notifySuperUsers $ "The group " <> groupRef <> " is listed " <> suCtRole
             GRSPendingApproval gaId -> when (rStatus == GRSOk) $ do
               sendToApprove g gr gaId
               notifyOwner gr $ uCtRole <> ".\n\nThe group is submitted for approval."
             GRSActive -> when (rStatus /= GRSOk) $ do
-              setGroupStatus gr GRSSuspendedBadRoles
+              setGroupStatus st gr GRSSuspendedBadRoles
               notifyOwner gr $ uCtRole <> ".\n\nThe group is no longer listed in the directory."
               notifySuperUsers $ "The group " <> groupRef <> " is de-listed " <> suCtRole
             _ -> pure ()
@@ -338,7 +329,7 @@ directoryService st DirectoryOpts {superUsers, serviceName} User {userId} cc = d
         readTVarIO (groupRegStatus gr) >>= \case
           GRSSuspendedBadRoles -> when (serviceRole == GRAdmin) $
             whenContactIsOwner gr $ do
-              setGroupStatus gr GRSActive
+              setGroupStatus st gr GRSActive
               notifyOwner gr $ uSrvRole <> ".\n\nThe group is listed in the directory again."
               notifySuperUsers $ "The group " <> groupRef <> " is listed " <> suSrvRole
           GRSPendingApproval gaId -> when (serviceRole == GRAdmin) $
@@ -346,7 +337,7 @@ directoryService st DirectoryOpts {superUsers, serviceName} User {userId} cc = d
               sendToApprove g gr gaId
               notifyOwner gr $ uSrvRole <> ".\n\nThe group is submitted for approval."
           GRSActive -> when (serviceRole /= GRAdmin) $ do
-            setGroupStatus gr GRSSuspendedBadRoles
+            setGroupStatus st gr GRSSuspendedBadRoles
             notifyOwner gr $ uSrvRole <> ".\n\nThe group is no longer listed in the directory."
             notifySuperUsers $ "The group " <> groupRef <> " is de-listed " <> suSrvRole
           _ -> pure ()
@@ -362,7 +353,7 @@ directoryService st DirectoryOpts {superUsers, serviceName} User {userId} cc = d
     deContactRemovedFromGroup ctId g =
       withGroupReg g "contact removed" $ \gr -> do
         when (ctId `isOwner` gr) $ do
-          setGroupStatus gr GRSRemoved
+          setGroupStatus st gr GRSRemoved
           notifyOwner gr $ "You are removed from the group " <> userGroupReference gr g <> ".\n\nThe group is no longer listed in the directory."
           notifySuperUsers $ "The group " <> groupReference g <> " is de-listed (group owner is removed)."
 
@@ -370,14 +361,14 @@ directoryService st DirectoryOpts {superUsers, serviceName} User {userId} cc = d
     deContactLeftGroup ctId g =
       withGroupReg g "contact left" $ \gr -> do
         when (ctId `isOwner` gr) $ do
-          setGroupStatus gr GRSRemoved
+          setGroupStatus st gr GRSRemoved
           notifyOwner gr $ "You left the group " <> userGroupReference gr g <> ".\n\nThe group is no longer listed in the directory."
           notifySuperUsers $ "The group " <> groupReference g <> " is de-listed (group owner left)."
 
     deServiceRemovedFromGroup :: GroupInfo -> IO ()
     deServiceRemovedFromGroup g =
       withGroupReg g "service removed" $ \gr -> do
-        setGroupStatus gr GRSRemoved
+        setGroupStatus st gr GRSRemoved
         notifyOwner gr $ serviceName <> " is removed from the group " <> userGroupReference gr g <> ".\n\nThe group is no longer listed in the directory."
         notifySuperUsers $ "The group " <> groupReference g <> " is de-listed (directory service is removed)."
 
@@ -397,8 +388,8 @@ directoryService st DirectoryOpts {superUsers, serviceName} User {userId} cc = d
             atomically (filterListedGroups st groups) >>= \case
               [] -> sendReply "No groups found"
               gs -> do
-                sendReply $ "Found " <> show (length gs) <> " group(s)"
-                void . forkIO $ forM_ gs $
+                sendReply $ "Found " <> show (length gs) <> " group(s)" <> if length gs > 10 then ", sending 10." else ""
+                void . forkIO $ forM_ (take 10 gs) $
                   \(GroupInfo {groupProfile = p@GroupProfile {image = image_}}, GroupSummary {currentMembers}) -> do
                     let membersStr = tshow currentMembers <> " members"
                         text = groupInfoText p <> "\n" <> membersStr
@@ -448,7 +439,7 @@ directoryService st DirectoryOpts {superUsers, serviceName} User {userId} cc = d
                       _ -> do
                         getGroupRolesStatus g gr >>= \case
                           Just GRSOk -> do
-                            setGroupStatus gr GRSActive
+                            setGroupStatus st gr GRSActive
                             sendReply "Group approved!"
                             notifyOwner gr $ "The group " <> userGroupReference' gr n <> " is approved and listed in directory!\nPlease note: if you change the group profile it will be hidden from directory until it is re-approved."
                           Just GRSServiceNotAdmin -> replyNotApproved serviceNotAdmin
@@ -470,7 +461,7 @@ directoryService st DirectoryOpts {superUsers, serviceName} User {userId} cc = d
             Just (_, gr) ->
               readTVarIO (groupRegStatus gr) >>= \case
                 GRSActive -> do
-                  setGroupStatus gr GRSSuspended
+                  setGroupStatus st gr GRSSuspended
                   notifyOwner gr $ "The group " <> userGroupReference' gr gName <> " is suspended and hidden from directory. Please contact the administrators."
                   sendReply "Group suspended!"
                 _ -> sendReply $ "The group " <> groupRef <> " is not active, can't be suspended."
@@ -481,7 +472,7 @@ directoryService st DirectoryOpts {superUsers, serviceName} User {userId} cc = d
             Just (_, gr) ->
               readTVarIO (groupRegStatus gr) >>= \case
                 GRSSuspended -> do
-                  setGroupStatus gr GRSActive
+                  setGroupStatus st gr GRSActive
                   notifyOwner gr $ "The group " <> userGroupReference' gr gName <> " is listed in the directory again!"
                   sendReply "Group listing resumed!"
                 _ -> sendReply $ "The group " <> groupRef <> " is not suspended, can't be resumed."

apps/simplex-directory-service/src/Directory/Store.hs

@@ -1,32 +1,70 @@
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 
-module Directory.Store where
+module Directory.Store
+  ( DirectoryStore (..),
+    GroupReg (..),
+    GroupRegStatus (..),
+    UserGroupRegId,
+    GroupApprovalId,
+    restoreDirectoryStore,
+    addGroupReg,
+    setGroupStatus,
+    setGroupRegOwner,
+    getGroupReg,
+    getUserGroupReg,
+    getUserGroupRegs,
+    filterListedGroups,
+    groupRegStatusText,
+  )
+where
 
 import Control.Concurrent.STM
+import Control.Monad
+import qualified Data.Attoparsec.ByteString.Char8 as A
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
+import Data.Composition ((.:))
 import Data.Int (Int64)
+import Data.List (find, foldl', sortOn)
+import Data.Map (Map)
+import qualified Data.Map.Strict as M
+import Data.Maybe (isJust)
 import Data.Set (Set)
+import qualified Data.Set as S
 import Data.Text (Text)
 import Simplex.Chat.Types
-import Data.List (find, foldl')
-import qualified Data.Set as S
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Util (ifM)
+import System.IO (Handle, IOMode (..), openFile, BufferMode (..), hSetBuffering)
+import System.Directory (renameFile, doesFileExist)
 
 data DirectoryStore = DirectoryStore
   { groupRegs :: TVar [GroupReg],
     listedGroups :: TVar (Set GroupId),
-    reservedGroups :: TVar (Set GroupId)
+    reservedGroups :: TVar (Set GroupId),
+    directoryLogFile :: Maybe Handle
   }
 
 data GroupReg = GroupReg
-  { userGroupRegId :: UserGroupRegId,
-    dbGroupId :: GroupId,
+  { dbGroupId :: GroupId,
+    userGroupRegId :: UserGroupRegId,
     dbContactId :: ContactId,
     dbOwnerMemberId :: TVar (Maybe GroupMemberId),
     groupRegStatus :: TVar GroupRegStatus
   }
 
+data GroupRegData = GroupRegData
+  { dbGroupId_ :: GroupId,
+    userGroupRegId_ :: UserGroupRegId,
+    dbContactId_ :: ContactId,
+    dbOwnerMemberId_ :: Maybe GroupMemberId,
+    groupRegStatus_ :: GroupRegStatus
+  }
+
 type UserGroupRegId = Int64
 
 type GroupApprovalId = Int64
@@ -41,6 +79,8 @@ data GroupRegStatus
   | GRSSuspendedBadRoles
   | GRSRemoved
 
+data DirectoryStatus = DSListed | DSReserved | DSRegistered
+
 groupRegStatusText :: GroupRegStatus -> Text
 groupRegStatusText = \case
   GRSPendingConfirmation -> "pending confirmation (duplicate names)"
@@ -52,20 +92,50 @@ groupRegStatusText = \case
   GRSSuspendedBadRoles -> "suspended because roles changed"
   GRSRemoved -> "removed"
 
-addGroupReg :: DirectoryStore -> Contact -> GroupInfo -> GroupRegStatus -> STM UserGroupRegId
+grDirectoryStatus :: GroupRegStatus -> DirectoryStatus
+grDirectoryStatus = \case
+  GRSActive -> DSListed
+  GRSSuspended -> DSReserved
+  GRSSuspendedBadRoles -> DSReserved
+  _ -> DSRegistered
+
+addGroupReg :: DirectoryStore -> Contact -> GroupInfo -> GroupRegStatus -> IO UserGroupRegId
 addGroupReg st ct GroupInfo {groupId} grStatus = do
-  dbOwnerMemberId <- newTVar Nothing
-  groupRegStatus <- newTVar grStatus
-  let gr = GroupReg {userGroupRegId = 1, dbGroupId = groupId, dbContactId = ctId, dbOwnerMemberId, groupRegStatus}
-  stateTVar (groupRegs st) $ \grs ->
-    let ugrId = 1 + foldl' maxUgrId 0 grs
-     in (ugrId, gr {userGroupRegId = ugrId} : grs)
+  grData <- atomically addGroupReg_
+  logGCreate st grData
+  pure $ userGroupRegId_ grData
   where
+    addGroupReg_ = do
+      let grData = GroupRegData {dbGroupId_ = groupId, userGroupRegId_ = 1, dbContactId_ = ctId, dbOwnerMemberId_ = Nothing, groupRegStatus_ = grStatus}
+      gr <- dataToGroupReg grData
+      stateTVar (groupRegs st) $ \grs ->
+        let ugrId = 1 + foldl' maxUgrId 0 grs
+            grData' = grData {userGroupRegId_ = ugrId}
+            gr' = gr {userGroupRegId = ugrId}
+        in (grData', gr' : grs)
     ctId = contactId' ct
     maxUgrId mx GroupReg {dbContactId, userGroupRegId}
       | dbContactId == ctId && userGroupRegId > mx = userGroupRegId
       | otherwise = mx
 
+setGroupStatus :: DirectoryStore -> GroupReg -> GroupRegStatus -> IO ()
+setGroupStatus st gr grStatus = do
+  logGUpdateStatus st (dbGroupId gr) grStatus
+  atomically $ do
+    writeTVar (groupRegStatus gr) grStatus
+    updateListing st $ dbGroupId gr
+  where
+    updateListing = case grDirectoryStatus grStatus of
+      DSListed -> listGroup
+      DSReserved -> reserveGroup
+      DSRegistered -> unlistGroup
+
+setGroupRegOwner :: DirectoryStore -> GroupReg -> GroupMember -> IO ()
+setGroupRegOwner st gr owner = do
+  let memberId = groupMemberId' owner
+  logGUpdateOwner st (dbGroupId gr) memberId
+  atomically $ writeTVar (dbOwnerMemberId gr) (Just memberId)
+
 getGroupReg :: DirectoryStore -> GroupId -> STM (Maybe GroupReg)
 getGroupReg st gId = find ((gId ==) . dbGroupId) <$> readTVar (groupRegs st)
 
@@ -96,28 +166,163 @@ unlistGroup st gId = do
   modifyTVar' (reservedGroups st) $ S.delete gId
 
 data DirectoryLogRecord
-  = CreateGroupReg GroupReg
-  | UpdateGroupRegStatus GroupId GroupRegStatus
+  = GRCreate GroupRegData
+  | GRUpdateStatus GroupId GroupRegStatus
+  | GRUpdateOwner GroupId GroupMemberId
 
-getDirectoryStore :: FilePath -> IO DirectoryStore
-getDirectoryStore path = do
-  groupRegs <- readDirectoryState path
-  st <- atomically newDirectoryStore
-  atomically $ mapM_ (add st) groupRegs
-  pure st
+data DLRTag = GRCreate_ | GRUpdateStatus_ | GRUpdateOwner_
+
+logDLR :: DirectoryStore -> DirectoryLogRecord -> IO ()
+logDLR st r = forM_ (directoryLogFile st) $ \h -> B.hPutStrLn h (strEncode r)
+
+logGCreate :: DirectoryStore -> GroupRegData -> IO ()
+logGCreate st = logDLR st . GRCreate
+
+logGUpdateStatus :: DirectoryStore -> GroupId -> GroupRegStatus -> IO ()
+logGUpdateStatus st = logDLR st .: GRUpdateStatus
+
+logGUpdateOwner :: DirectoryStore -> GroupId -> GroupMemberId -> IO ()
+logGUpdateOwner st = logDLR st .: GRUpdateOwner
+
+instance StrEncoding DLRTag where
+  strEncode = \case
+    GRCreate_ -> "GCREATE"
+    GRUpdateStatus_ -> "GSTATUS"
+    GRUpdateOwner_ -> "GOWNER"
+  strP =
+    A.takeTill (== ' ') >>= \case
+      "GCREATE" -> pure GRCreate_
+      "GSTATUS" -> pure GRUpdateStatus_
+      "GOWNER" -> pure GRUpdateOwner_
+      _ -> fail "invalid DLRTag"
+
+instance StrEncoding DirectoryLogRecord where
+  strEncode = \case
+    GRCreate gr -> strEncode (GRCreate_, gr)
+    GRUpdateStatus gId grStatus -> strEncode (GRUpdateStatus_, gId, grStatus)
+    GRUpdateOwner gId grOwnerId -> strEncode (GRUpdateOwner_, gId, grOwnerId)
+  strP =
+    strP >>= \case
+      GRCreate_ -> GRCreate <$> (A.space *> strP)
+      GRUpdateStatus_ -> GRUpdateStatus <$> (A.space *> A.decimal) <*> (A.space *> strP)
+      GRUpdateOwner_ -> GRUpdateOwner <$> (A.space *> A.decimal) <*> (A.space *> A.decimal)
+
+instance StrEncoding GroupRegData where
+  strEncode GroupRegData {dbGroupId_, userGroupRegId_, dbContactId_, dbOwnerMemberId_, groupRegStatus_} =
+    B.unwords
+      [ "group_id=" <> strEncode dbGroupId_,
+        "user_group_id=" <> strEncode userGroupRegId_,
+        "contact_id=" <> strEncode dbContactId_,
+        "owner_member_id=" <> strEncode dbOwnerMemberId_,
+        "status=" <> strEncode groupRegStatus_
+      ]
+  strP = do
+    dbGroupId_ <- "group_id=" *> strP_
+    userGroupRegId_ <- "user_group_id=" *> strP_
+    dbContactId_ <- "contact_id=" *> strP_
+    dbOwnerMemberId_ <- "owner_member_id=" *> strP_
+    groupRegStatus_ <- "status=" *> strP
+    pure GroupRegData {dbGroupId_, userGroupRegId_, dbContactId_, dbOwnerMemberId_, groupRegStatus_}
+
+instance StrEncoding GroupRegStatus where
+  strEncode = \case
+    GRSPendingConfirmation -> "pending_confirmation"
+    GRSProposed -> "proposed"
+    GRSPendingUpdate -> "pending_update"
+    GRSPendingApproval gaId -> "pending_approval:" <> strEncode gaId
+    GRSActive -> "active"
+    GRSSuspended -> "suspended"
+    GRSSuspendedBadRoles -> "suspended_bad_roles"
+    GRSRemoved -> "removed"
+  strP =
+    A.takeTill (\c -> c == ' ' || c == ':') >>= \case
+      "pending_confirmation" -> pure GRSPendingConfirmation
+      "proposed" -> pure GRSProposed
+      "pending_update" -> pure GRSPendingUpdate
+      "pending_approval" -> GRSPendingApproval <$> (A.char ':' *> A.decimal)
+      "active" -> pure GRSActive
+      "suspended" -> pure GRSSuspended
+      "suspended_bad_roles" -> pure GRSSuspendedBadRoles
+      "removed" -> pure GRSRemoved
+      _ -> fail "invalid GroupRegStatus"
+
+dataToGroupReg :: GroupRegData -> STM GroupReg
+dataToGroupReg GroupRegData {dbGroupId_, userGroupRegId_, dbContactId_, dbOwnerMemberId_, groupRegStatus_} = do
+  dbOwnerMemberId <- newTVar dbOwnerMemberId_
+  groupRegStatus <- newTVar groupRegStatus_
+  pure
+    GroupReg
+      { dbGroupId = dbGroupId_,
+        userGroupRegId = userGroupRegId_,
+        dbContactId = dbContactId_,
+        dbOwnerMemberId,
+        groupRegStatus
+      }
+
+restoreDirectoryStore :: Maybe FilePath -> IO DirectoryStore
+restoreDirectoryStore = \case
+  Just f -> ifM (doesFileExist f) (restore f) (newFile f >>= new . Just)
+  Nothing -> new Nothing
   where
-    add :: DirectoryStore -> GroupReg -> STM ()
-    add st gr = modifyTVar' (groupRegs st) (gr :) -- TODO set listedGroups
+    new = atomically . newDirectoryStore
+    newFile f = do
+      h <- openFile f WriteMode
+      hSetBuffering h LineBuffering
+      pure h
+    restore f = do
+      grs <- readDirectoryData f
+      renameFile f (f <> ".bak")
+      h <- writeDirectoryData f grs -- compact
+      atomically $ mkDirectoryStore h grs
 
-newDirectoryStore :: STM DirectoryStore
-newDirectoryStore = do
-  groupRegs <- newTVar []
-  listedGroups <- newTVar mempty
-  reservedGroups <- newTVar mempty
-  pure DirectoryStore {groupRegs, listedGroups, reservedGroups}
+emptyStoreData :: ([GroupReg], Set GroupId, Set GroupId)
+emptyStoreData = ([], S.empty, S.empty)
 
-readDirectoryState :: FilePath -> IO [GroupReg]
-readDirectoryState _ = pure []
+newDirectoryStore :: Maybe Handle -> STM DirectoryStore
+newDirectoryStore = (`mkDirectoryStore_` emptyStoreData)
 
-writeDirectoryState :: FilePath -> [GroupReg] -> IO ()
-writeDirectoryState _ _ = pure ()
+mkDirectoryStore :: Handle -> [GroupRegData] -> STM DirectoryStore
+mkDirectoryStore h groups =
+  foldM addGroupRegData emptyStoreData groups >>= mkDirectoryStore_ (Just h)
+  where
+    addGroupRegData (!grs, !listed, !reserved) gr@GroupRegData {dbGroupId_ = gId} = do
+      gr' <- dataToGroupReg gr
+      let grs' = gr' : grs
+      pure $ case grDirectoryStatus $ groupRegStatus_ gr of
+        DSListed -> (grs', S.insert gId listed, reserved)
+        DSReserved -> (grs', listed, S.insert gId reserved)
+        DSRegistered -> (grs', listed, reserved)
+
+mkDirectoryStore_ :: Maybe Handle -> ([GroupReg], Set GroupId, Set GroupId) -> STM DirectoryStore
+mkDirectoryStore_ h (grs, listed, reserved) = do
+  groupRegs <- newTVar grs
+  listedGroups <- newTVar listed
+  reservedGroups <- newTVar reserved
+  pure DirectoryStore {groupRegs, listedGroups, reservedGroups, directoryLogFile = h}
+
+readDirectoryData :: FilePath -> IO [GroupRegData]
+readDirectoryData f =
+  sortOn dbGroupId_ . M.elems
+    <$> (foldM processDLR M.empty . B.lines =<< B.readFile f)
+  where
+    processDLR :: Map GroupId GroupRegData -> ByteString -> IO (Map GroupId GroupRegData)
+    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@GroupRegData {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
+        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.")
+        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.")
+
+writeDirectoryData :: FilePath -> [GroupRegData] -> IO Handle
+writeDirectoryData f grs = do
+  h <- openFile f WriteMode
+  hSetBuffering h LineBuffering
+  forM_ grs $ B.hPutStrLn h . strEncode . GRCreate
+  pure h

src/Simplex/Chat.hs

@@ -4847,13 +4847,13 @@ createInternalChatItem user cd content itemTs_ = do
   ci <- liftIO $ mkChatItem cd ciId content Nothing Nothing Nothing Nothing False itemTs createdAt
   toView $ CRNewChatItem user (AChatItem (chatTypeI @c) (msgDirection @d) (toChatInfo cd) ci)
 
-getCreateActiveUser :: SQLiteStore -> IO User
-getCreateActiveUser st = do
+getCreateActiveUser :: SQLiteStore -> Bool -> IO User
+getCreateActiveUser st testView = do
   user <-
     withTransaction st getUsers >>= \case
       [] -> newUser
       users -> maybe (selectUser users) pure (find activeUser users)
-  putStrLn $ "Current user: " <> userStr user
+  unless testView $ putStrLn $ "Current user: " <> userStr user
   pure user
   where
     newUser :: IO User

src/Simplex/Chat/Bot.hs

@@ -38,18 +38,21 @@ chatBotRepl welcome answer _user cc = do
     contactConnected Contact {localDisplayName} = putStrLn $ T.unpack localDisplayName <> " connected"
 
 initializeBotAddress :: ChatController -> IO ()
-initializeBotAddress cc = do
+initializeBotAddress = initializeBotAddress' True
+
+initializeBotAddress' :: Bool -> ChatController -> IO ()
+initializeBotAddress' logAddress cc = do
   sendChatCmd cc ShowMyAddress >>= \case
     CRUserContactLink _ UserContactLink {connReqContact} -> showBotAddress connReqContact
     CRChatCmdError _ (ChatErrorStore SEUserContactLinkNotFound) -> do
-      putStrLn "No bot address, creating..."
+      when logAddress $ putStrLn "No bot address, creating..."
       sendChatCmd cc CreateMyAddress >>= \case
         CRUserContactLinkCreated _ uri -> showBotAddress uri
         _ -> putStrLn "can't create bot address" >> exitFailure
     _ -> putStrLn "unexpected response" >> exitFailure
   where
     showBotAddress uri = do
-      putStrLn $ "Bot's contact address is: " <> B.unpack (strEncode uri)
+      when logAddress $ putStrLn $ "Bot's contact address is: " <> B.unpack (strEncode uri)
       void $ sendChatCmd cc $ AddressAutoAccept $ Just AutoAccept {acceptIncognito = False, autoReply = Nothing}
 
 sendMessage :: ChatController -> Contact -> String -> IO ()

src/Simplex/Chat/Core.hs

@@ -15,7 +15,7 @@ import System.Exit (exitFailure)
 import UnliftIO.Async
 
 simplexChatCore :: ChatConfig -> ChatOpts -> Maybe (Notification -> IO ()) -> (User -> ChatController -> IO ()) -> IO ()
-simplexChatCore cfg@ChatConfig {confirmMigrations} opts@ChatOpts {coreOptions = CoreChatOpts {dbFilePrefix, dbKey, logAgent}} sendToast chat =
+simplexChatCore cfg@ChatConfig {confirmMigrations, testView} opts@ChatOpts {coreOptions = CoreChatOpts {dbFilePrefix, dbKey, logAgent}} sendToast chat =
   case logAgent of
     Just level -> do
       setLogLevel level
@@ -27,7 +27,7 @@ simplexChatCore cfg@ChatConfig {confirmMigrations} opts@ChatOpts {coreOptions =
       putStrLn $ "Error opening database: " <> show e
       exitFailure
     run db@ChatDatabase {chatStore} = do
-      u <- getCreateActiveUser chatStore
+      u <- getCreateActiveUser chatStore testView
       cc <- newChatController db (Just u) cfg opts sendToast
       runSimplexChat opts u cc chat
 

tests/Bots/DirectoryTests.hs

@@ -9,6 +9,7 @@ import ChatClient
 import ChatTests.Utils
 import Control.Concurrent (forkIO, killThread, threadDelay)
 import Control.Exception (finally)
+import Control.Monad (forM_)
 import Directory.Options
 import Directory.Service
 import Directory.Store
@@ -18,6 +19,7 @@ import Simplex.Chat.Options (ChatOpts (..), CoreChatOpts (..))
 import Simplex.Chat.Types (GroupMemberRole (..), Profile (..))
 import System.FilePath ((</>))
 import Test.Hspec
+import GHC.IO.Handle (hClose)
 
 directoryServiceTests :: SpecWith FilePath
 directoryServiceTests = do
@@ -47,6 +49,8 @@ directoryServiceTests = do
     it "should prohibit approval if a duplicate group is listed" testDuplicateProhibitApproval
   describe "list groups" $ do
     it "should list user's groups" testListUserGroups
+  describe "store log" $ do
+    it "should restore directory service state" testRestoreDirectory
 
 directoryProfile :: Profile
 directoryProfile = Profile {displayName = "SimpleX-Directory", fullName = "", image = Nothing, contactLink = Nothing, preferences = Nothing}
@@ -56,8 +60,9 @@ mkDirectoryOpts tmp superUsers =
   DirectoryOpts
     { coreOptions = (coreOptions (testOpts :: ChatOpts)) {dbFilePrefix = tmp </> serviceDbPrefix},
       superUsers,
-      directoryLog = tmp </> "directory_service.log",
-      serviceName = "SimpleX-Directory"
+      directoryLog = Just $ tmp </> "directory_service.log",
+      serviceName = "SimpleX-Directory",
+      testing = True
     }
 
 serviceDbPrefix :: FilePath
@@ -591,19 +596,6 @@ testListUserGroups tmp =
         cath <## "use @SimpleX-Directory <message> to send messages"
         registerGroupId superUser bob "security" "Security" 2 2
         registerGroupId superUser cath "anonymity" "Anonymity" 3 1
-        bob #> "@SimpleX-Directory /list"
-        bob <# "SimpleX-Directory> > /list"
-        bob <## "      2 registered group(s)"
-        bob <# "SimpleX-Directory> 1. privacy (Privacy)"
-        bob <## "Welcome message:"
-        bob <##. "Link to join the group privacy: "
-        bob <## "3 members"
-        bob <## "Status: active"
-        bob <# "SimpleX-Directory> 2. security (Security)"
-        bob <## "Welcome message:"
-        bob <##. "Link to join the group security: "
-        bob <## "2 members"
-        bob <## "Status: active"
         cath #> "@SimpleX-Directory /list"
         cath <# "SimpleX-Directory> > /list"
         cath <## "      1 registered group(s)"
@@ -621,46 +613,85 @@ testListUserGroups tmp =
         cath <## "The group is no longer listed in the directory."
         superUser <# "SimpleX-Directory> The group ID 3 (anonymity) is de-listed (SimpleX-Directory role is changed to member)."
         groupNotFound cath "anonymity"
-        cath #> "@SimpleX-Directory /list"
-        cath <# "SimpleX-Directory> > /list"
-        cath <## "      1 registered group(s)"
-        cath <# "SimpleX-Directory> 1. anonymity (Anonymity)"
-        cath <## "Welcome message:"
-        cath <##. "Link to join the group anonymity: "
-        cath <## "2 members"
-        cath <## "Status: suspended because roles changed"
-        -- superuser lists all groups
-        superUser #> "@SimpleX-Directory /last"
-        superUser <# "SimpleX-Directory> > /last"
-        superUser <## "      3 registered group(s)"
-        superUser <# "SimpleX-Directory> 1. privacy (Privacy)"
-        superUser <## "Welcome message:"
-        superUser <##. "Link to join the group privacy: "
-        superUser <## "Owner: bob"
-        superUser <## "3 members"
-        superUser <## "Status: active"
-        superUser <# "SimpleX-Directory> 2. security (Security)"
-        superUser <## "Welcome message:"
-        superUser <##. "Link to join the group security: "
-        superUser <## "Owner: bob"
-        superUser <## "2 members"
-        superUser <## "Status: active"
-        superUser <# "SimpleX-Directory> 3. anonymity (Anonymity)"
-        superUser <## "Welcome message:"
-        superUser <##. "Link to join the group anonymity: "
-        superUser <## "Owner: cath"
-        superUser <## "2 members"
-        superUser <## "Status: suspended because roles changed"
-        -- showing last 1 group
-        superUser #> "@SimpleX-Directory /last 1"
-        superUser <# "SimpleX-Directory> > /last 1"
-        superUser <## "      3 registered group(s), showing the last 1"
-        superUser <# "SimpleX-Directory> 3. anonymity (Anonymity)"
-        superUser <## "Welcome message:"
-        superUser <##. "Link to join the group anonymity: "
-        superUser <## "Owner: cath"
-        superUser <## "2 members"
-        superUser <## "Status: suspended because roles changed"
+        listGroups superUser bob cath
+
+testRestoreDirectory :: HasCallStack => FilePath -> IO ()
+testRestoreDirectory tmp = do
+  testListUserGroups tmp
+  restoreDirectoryService tmp 3 3 $ \superUser _dsLink ->
+    withTestChat tmp "bob" $ \bob ->
+      withTestChat tmp "cath" $ \cath -> do
+        bob <## "2 contacts connected (use /cs for the list)"
+        bob <###
+          [ "#privacy (Privacy): connected to server(s)",
+            "#security (Security): connected to server(s)"
+          ] 
+        cath <## "2 contacts connected (use /cs for the list)"
+        cath <###
+          [ "#privacy (Privacy): connected to server(s)",
+            "#anonymity (Anonymity): connected to server(s)"
+          ]
+        listGroups superUser bob cath
+        groupFoundN 3 bob "privacy"
+        groupFound bob "security"
+        groupFoundN 3 cath "privacy"
+        groupFound cath "security"
+
+listGroups :: HasCallStack => TestCC -> TestCC -> TestCC -> IO ()
+listGroups superUser bob cath = do
+  bob #> "@SimpleX-Directory /list"
+  bob <# "SimpleX-Directory> > /list"
+  bob <## "      2 registered group(s)"
+  bob <# "SimpleX-Directory> 1. privacy (Privacy)"
+  bob <## "Welcome message:"
+  bob <##. "Link to join the group privacy: "
+  bob <## "3 members"
+  bob <## "Status: active"
+  bob <# "SimpleX-Directory> 2. security (Security)"
+  bob <## "Welcome message:"
+  bob <##. "Link to join the group security: "
+  bob <## "2 members"
+  bob <## "Status: active"
+  cath #> "@SimpleX-Directory /list"
+  cath <# "SimpleX-Directory> > /list"
+  cath <## "      1 registered group(s)"
+  cath <# "SimpleX-Directory> 1. anonymity (Anonymity)"
+  cath <## "Welcome message:"
+  cath <##. "Link to join the group anonymity: "
+  cath <## "2 members"
+  cath <## "Status: suspended because roles changed"
+  -- superuser lists all groups
+  superUser #> "@SimpleX-Directory /last"
+  superUser <# "SimpleX-Directory> > /last"
+  superUser <## "      3 registered group(s)"
+  superUser <# "SimpleX-Directory> 1. privacy (Privacy)"
+  superUser <## "Welcome message:"
+  superUser <##. "Link to join the group privacy: "
+  superUser <## "Owner: bob"
+  superUser <## "3 members"
+  superUser <## "Status: active"
+  superUser <# "SimpleX-Directory> 2. security (Security)"
+  superUser <## "Welcome message:"
+  superUser <##. "Link to join the group security: "
+  superUser <## "Owner: bob"
+  superUser <## "2 members"
+  superUser <## "Status: active"
+  superUser <# "SimpleX-Directory> 3. anonymity (Anonymity)"
+  superUser <## "Welcome message:"
+  superUser <##. "Link to join the group anonymity: "
+  superUser <## "Owner: cath"
+  superUser <## "2 members"
+  superUser <## "Status: suspended because roles changed"
+  -- showing last 1 group
+  superUser #> "@SimpleX-Directory /last 1"
+  superUser <# "SimpleX-Directory> > /last 1"
+  superUser <## "      3 registered group(s), showing the last 1"
+  superUser <# "SimpleX-Directory> 3. anonymity (Anonymity)"
+  superUser <## "Welcome message:"
+  superUser <##. "Link to join the group anonymity: "
+  superUser <## "Owner: cath"
+  superUser <## "2 members"
+  superUser <## "Status: suspended because roles changed"
 
 reapproveGroup :: HasCallStack => TestCC -> TestCC -> IO ()
 reapproveGroup superUser bob = do
@@ -691,20 +722,38 @@ withDirectoryService tmp test = do
         connectUsers ds superUser
         ds ##> "/ad"
         getContactLink ds True
+  withDirectory tmp dsLink test
+
+restoreDirectoryService :: HasCallStack => FilePath -> Int -> Int -> (TestCC -> String -> IO ()) -> IO ()
+restoreDirectoryService tmp ctCount grCount test = do
+  dsLink <-
+    withTestChat tmp serviceDbPrefix $ \ds -> do
+      ds <## (show ctCount <> " contacts connected (use /cs for the list)")
+      ds <## "Your address is active! To show: /sa"
+      ds <## (show grCount <> " group links active")
+      forM_ [1..grCount] $ \_ -> ds <##. "#"
+      ds ##> "/sa"
+      dsLink <- getContactLink ds False
+      ds <## "auto_accept on"
+      pure dsLink
+  withDirectory tmp dsLink test
+
+withDirectory :: HasCallStack => FilePath -> String -> (TestCC -> String -> IO ()) -> IO ()
+withDirectory tmp dsLink test = do
   let opts = mkDirectoryOpts tmp [KnownContact 2 "alice"]
-  withDirectory opts $
+  runDirectory opts $
     withTestChat tmp "super_user" $ \superUser -> do
       superUser <## "1 contacts connected (use /cs for the list)"
       test superUser dsLink
+
+runDirectory :: DirectoryOpts -> IO () -> IO ()
+runDirectory opts@DirectoryOpts {directoryLog} action = do
+  st <- restoreDirectoryStore directoryLog
+  t <- forkIO $ bot st
+  threadDelay 500000
+  action `finally` (mapM_ hClose (directoryLogFile st) >> killThread t)
   where
-    withDirectory :: DirectoryOpts -> IO () -> IO ()
-    withDirectory opts@DirectoryOpts {directoryLog} action = do
-      st <- getDirectoryStore directoryLog
-      t <- forkIO $ bot st
-      threadDelay 500000
-      action `finally` killThread t
-      where
-        bot st = simplexChatCore testCfg (mkChatOpts opts) Nothing $ directoryService st opts
+    bot st = simplexChatCore testCfg (mkChatOpts opts) Nothing $ directoryService st opts
 
 registerGroup :: TestCC -> TestCC -> String -> String -> IO ()
 registerGroup su u n fn = registerGroupId su u n fn 1 1