diff --git a/apps/simplex-directory-service/Main.hs b/apps/simplex-directory-service/Main.hs index 103f382461..434e42d851 100644 --- a/apps/simplex-directory-service/Main.hs +++ b/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 diff --git a/apps/simplex-directory-service/src/Directory/Events.hs b/apps/simplex-directory-service/src/Directory/Events.hs index bdf76e80d2..8ab6bea805 100644 --- a/apps/simplex-directory-service/src/Directory/Events.hs +++ b/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) diff --git a/apps/simplex-directory-service/src/Directory/Options.hs b/apps/simplex-directory-service/src/Directory/Options.hs index 1bdde35923..1f06afe116 100644 --- a/apps/simplex-directory-service/src/Directory/Options.hs +++ b/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 diff --git a/apps/simplex-directory-service/src/Directory/Service.hs b/apps/simplex-directory-service/src/Directory/Service.hs index 6f3ac92fc8..570aa57817 100644 --- a/apps/simplex-directory-service/src/Directory/Service.hs +++ b/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." diff --git a/apps/simplex-directory-service/src/Directory/Store.hs b/apps/simplex-directory-service/src/Directory/Store.hs index 9a91d21e8a..5082cab2ce 100644 --- a/apps/simplex-directory-service/src/Directory/Store.hs +++ b/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 diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index cdb15a46d0..7eacbe378c 100644 --- a/src/Simplex/Chat.hs +++ b/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 diff --git a/src/Simplex/Chat/Bot.hs b/src/Simplex/Chat/Bot.hs index 34e752ec21..234963b44c 100644 --- a/src/Simplex/Chat/Bot.hs +++ b/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 () diff --git a/src/Simplex/Chat/Core.hs b/src/Simplex/Chat/Core.hs index 2ec6ddb7f9..4af161ab41 100644 --- a/src/Simplex/Chat/Core.hs +++ b/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 diff --git a/tests/Bots/DirectoryTests.hs b/tests/Bots/DirectoryTests.hs index f1a5676bec..e074587ad5 100644 --- a/tests/Bots/DirectoryTests.hs +++ b/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 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