From 96a1d920174b24b488ae7ecb53d149e5364ae97b Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Sat, 6 Jan 2024 11:24:01 +0000 Subject: [PATCH] core: only skip creating agent user when app is first started --- src/Simplex/Chat.hs | 78 ++++------------------------ src/Simplex/Chat/Controller.hs | 2 +- src/Simplex/Chat/Core.hs | 92 ++++++++++++++++++++++++++++++++-- src/Simplex/Chat/Terminal.hs | 5 +- src/Simplex/Chat/View.hs | 4 +- tests/ChatClient.hs | 31 ++++++------ tests/ChatTests/Direct.hs | 13 +++++ 7 files changed, 134 insertions(+), 91 deletions(-) diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index bbb34c570e..b574a5cd0c 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -108,9 +108,9 @@ import Simplex.Messaging.Util import Simplex.Messaging.Version import Simplex.RemoteControl.Invitation (RCInvitation (..), RCSignedInvitation (..)) import Simplex.RemoteControl.Types (RCCtrlAddress (..)) -import System.Exit (ExitCode, exitFailure, exitSuccess) +import System.Exit (ExitCode, exitSuccess) import System.FilePath (takeFileName, ()) -import System.IO (Handle, IOMode (..), SeekMode (..), hFlush, stdout) +import System.IO (Handle, IOMode (..), SeekMode (..), hFlush) import System.Random (randomRIO) import Text.Read (readMaybe) import UnliftIO.Async @@ -208,7 +208,7 @@ newChatController backgroundMode = do let inlineFiles' = if allowInstantFiles || autoAcceptFileSize > 0 then inlineFiles else inlineFiles {sendChunks = 0, receiveInstant = False} config = cfg {logLevel, showReactions, tbqSize, subscriptionEvents = logConnections, hostEvents = logServerHosts, defaultServers = configServers, inlineFiles = inlineFiles', autoAcceptFileSize, highlyAvailable} - firstTime = dbNew chatStore + firstTime <- newTVarIO $ dbNew chatStore currentUser <- newTVarIO user currentRemoteHost <- newTVarIO Nothing servers <- agentServers config @@ -452,17 +452,20 @@ processChatCommand' vr = \case u <- asks currentUser (smp, smpServers) <- chooseServers SPSMP (xftp, xftpServers) <- chooseServers SPXFTP + fstTime <- chatReadVar firstTime + users <- withStore' getUsers auId <- - withStore' getUsers >>= \case - [] -> pure 1 - users -> do + case users of + [] | fstTime -> pure 1 + _ -> do forM_ users $ \User {localDisplayName = n, activeUser, viewPwdHash} -> when (n == displayName) . throwChatError $ if activeUser || isNothing viewPwdHash then CEUserExists displayName else CEInvalidDisplayName {displayName, validName = ""} withAgent (\a -> createUser a smp xftp) ts <- liftIO $ getCurrentTime >>= if pastTimestamp then coupleDaysAgo else pure user <- withStore $ \db -> createUserRecordAt db (AgentUserId auId) p True ts - when (auId == 1) $ withStore (\db -> createContact db user simplexContactProfile) `catchChatError` \_ -> pure () + chatWriteVar firstTime False + when (null users && fstTime) $ withStore (\db -> createContact db user simplexContactProfile) `catchChatError` \_ -> pure () storeServers user smpServers storeServers user xftpServers atomically . writeTVar u $ Just user @@ -2202,6 +2205,7 @@ processChatCommand' vr = \case pure $ CRGroupUpdated user g g' Nothing checkValidName :: GroupName -> m () checkValidName displayName = do + when (T.null displayName) $ throwChatError CEInvalidDisplayName {displayName, validName = ""} let validName = T.pack $ mkValidName $ T.unpack displayName when (displayName /= validName) $ throwChatError CEInvalidDisplayName {displayName, validName} assertUserGroupRole :: GroupInfo -> GroupMemberRole -> m () @@ -6118,66 +6122,6 @@ createInternalItemsForChats user itemTs_ dirsCIContents = do let ci = mkChatItem cd ciId content Nothing Nothing Nothing Nothing False itemTs Nothing createdAt pure $ AChatItem (chatTypeI @c) (msgDirection @d) (toChatInfo cd) ci -getCreateActiveUser :: SQLiteStore -> Bool -> IO User -getCreateActiveUser st testView = do - user <- - withTransaction st getUsers >>= \case - [] -> newUser - users -> maybe (selectUser users) pure (find activeUser users) - unless testView $ putStrLn $ "Current user: " <> userStr user - pure user - where - newUser :: IO User - newUser = do - putStrLn - "No user profiles found, it will be created now.\n\ - \Please choose your display name and your full name.\n\ - \They will be sent to your contacts when you connect.\n\ - \They are only stored on your device and you can change them later." - loop - where - loop = do - displayName <- getContactName - withTransaction st (\db -> runExceptT $ createUserRecord db (AgentUserId 1) (profileFromName displayName) True) >>= \case - Left SEDuplicateName -> do - putStrLn "chosen display name is already used by another profile on this device, choose another one" - loop - Left e -> putStrLn ("database error " <> show e) >> exitFailure - Right user -> pure user - selectUser :: [User] -> IO User - selectUser [user@User {userId}] = do - withTransaction st (`setActiveUser` userId) - pure user - selectUser users = do - putStrLn "Select user profile:" - forM_ (zip [1 ..] users) $ \(n :: Int, user) -> putStrLn $ show n <> " - " <> userStr user - loop - where - loop = do - nStr <- getWithPrompt $ "user profile number (1 .. " <> show (length users) <> ")" - case readMaybe nStr :: Maybe Int of - Nothing -> putStrLn "invalid user number" >> loop - Just n - | n <= 0 || n > length users -> putStrLn "invalid user number" >> loop - | otherwise -> do - let user@User {userId} = users !! (n - 1) - withTransaction st (`setActiveUser` userId) - pure user - userStr :: User -> String - userStr User {localDisplayName, profile = LocalProfile {fullName}} = - T.unpack $ localDisplayName <> if T.null fullName || localDisplayName == fullName then "" else " (" <> fullName <> ")" - getContactName :: IO ContactName - getContactName = do - displayName <- getWithPrompt "display name" - let validName = mkValidName displayName - if - | null displayName -> putStrLn "display name can't be empty" >> getContactName - | null validName -> putStrLn "display name is invalid, please choose another" >> getContactName - | displayName /= validName -> putStrLn ("display name is invalid, you could use this one: " <> validName) >> getContactName - | otherwise -> pure $ T.pack displayName - getWithPrompt :: String -> IO String - getWithPrompt s = putStr (s <> ": ") >> hFlush stdout >> getLine - withUser' :: ChatMonad m => (User -> m ChatResponse) -> m ChatResponse withUser' action = asks currentUser diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 0a8c32dd29..4f24c63934 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -175,7 +175,7 @@ data ChatDatabase = ChatDatabase {chatStore :: SQLiteStore, agentStore :: SQLite data ChatController = ChatController { currentUser :: TVar (Maybe User), currentRemoteHost :: TVar (Maybe RemoteHostId), - firstTime :: Bool, + firstTime :: TVar Bool, smpAgent :: AgentClient, agentAsync :: TVar (Maybe (Async (), Maybe (Async ()))), chatStore :: SQLiteStore, diff --git a/src/Simplex/Chat/Core.hs b/src/Simplex/Chat/Core.hs index 1d870bf381..ba74f98830 100644 --- a/src/Simplex/Chat/Core.hs +++ b/src/Simplex/Chat/Core.hs @@ -1,21 +1,44 @@ {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} -module Simplex.Chat.Core where +module Simplex.Chat.Core + ( simplexChatCore, + simplexChatCore', + runSimplexChat, + sendChatCmdStr, + sendChatCmd, + ) +where +import Control.Concurrent.STM import Control.Logger.Simple +import Control.Monad import Control.Monad.Reader +import Data.List (find) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) +import Data.Time.Clock (getCurrentTime) +import Data.Time.LocalTime (getCurrentTimeZone) import Simplex.Chat import Simplex.Chat.Controller import Simplex.Chat.Options (ChatOpts (..), CoreChatOpts (..)) +import Simplex.Chat.Store.Profiles import Simplex.Chat.Types +import Simplex.Chat.View (serializeChatResponse) +import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore, withTransaction) import System.Exit (exitFailure) +import System.IO (hFlush, stdout) +import Text.Read (readMaybe) import UnliftIO.Async simplexChatCore :: ChatConfig -> ChatOpts -> (User -> ChatController -> IO ()) -> IO () -simplexChatCore cfg@ChatConfig {confirmMigrations, testView} opts@ChatOpts {coreOptions = CoreChatOpts {dbFilePrefix, dbKey, logAgent}} chat = +simplexChatCore cfg opts = simplexChatCore' cfg opts . const + +simplexChatCore' :: ChatConfig -> ChatOpts -> (Bool -> User -> ChatController -> IO ()) -> IO () +simplexChatCore' cfg@ChatConfig {confirmMigrations, testView} opts@ChatOpts {coreOptions = CoreChatOpts {dbFilePrefix, dbKey, logAgent}} chat = case logAgent of Just level -> do setLogLevel level @@ -27,9 +50,12 @@ simplexChatCore cfg@ChatConfig {confirmMigrations, testView} opts@ChatOpts {core putStrLn $ "Error opening database: " <> show e exitFailure run db@ChatDatabase {chatStore} = do - u <- getCreateActiveUser chatStore testView - cc <- newChatController db (Just u) cfg opts False - runSimplexChat opts u cc chat + u_ <- getSelectActiveUser chatStore + cc <- newChatController db u_ cfg opts False + fstTime <- readTVarIO $ firstTime cc + u <- maybe (createActiveUser cc) pure u_ + unless testView $ putStrLn $ "Current user: " <> userStr u + runSimplexChat opts u cc $ chat fstTime runSimplexChat :: ChatOpts -> User -> ChatController -> (User -> ChatController -> IO ()) -> IO () runSimplexChat ChatOpts {maintenance} u cc chat @@ -44,3 +70,59 @@ sendChatCmdStr cc s = runReaderT (execChatCommand Nothing . encodeUtf8 $ T.pack sendChatCmd :: ChatController -> ChatCommand -> IO ChatResponse sendChatCmd cc cmd = runReaderT (execChatCommand' cmd) cc + +getSelectActiveUser :: SQLiteStore -> IO (Maybe User) +getSelectActiveUser st = do + users <- withTransaction st getUsers + case find activeUser users of + Just u -> pure $ Just u + Nothing -> selectUser users + where + selectUser :: [User] -> IO (Maybe User) + selectUser = \case + [] -> pure Nothing + [user@User {userId}] -> do + withTransaction st (`setActiveUser` userId) + pure $ Just user + users -> do + putStrLn "Select user profile:" + forM_ (zip [1 :: Int ..] users) $ \(n, user) -> putStrLn $ show n <> ": " <> userStr user + loop + where + loop = do + nStr <- getWithPrompt $ "user number (1 .. " <> show (length users) <> ")" + case readMaybe nStr :: Maybe Int of + Nothing -> putStrLn "not a number" >> loop + Just n + | n <= 0 || n > length users -> putStrLn "invalid user number" >> loop + | otherwise -> do + let user@User {userId} = users !! (n - 1) + withTransaction st (`setActiveUser` userId) + pure $ Just user + +createActiveUser :: ChatController -> IO User +createActiveUser cc = do + putStrLn + "No user profiles found, it will be created now.\n\ + \Please choose your display name and your full name.\n\ + \They will be sent to your contacts when you connect.\n\ + \They are only stored on your device and you can change them later." + loop + where + loop = do + displayName <- T.pack <$> getWithPrompt "display name" + let profile = Just Profile {displayName, fullName = "", image = Nothing, contactLink = Nothing, preferences = Nothing} + execChatCommand' (CreateActiveUser NewUser {profile, sameServers = False, pastTimestamp = False}) `runReaderT` cc >>= \case + CRActiveUser user -> pure user + r -> do + ts <- getCurrentTime + tz <- getCurrentTimeZone + putStrLn $ serializeChatResponse (Nothing, Nothing) ts tz Nothing r + loop + +getWithPrompt :: String -> IO String +getWithPrompt s = putStr (s <> ": ") >> hFlush stdout >> getLine + +userStr :: User -> String +userStr User {localDisplayName, profile = LocalProfile {fullName}} = + T.unpack $ localDisplayName <> if T.null fullName || localDisplayName == fullName then "" else " (" <> fullName <> ")" diff --git a/src/Simplex/Chat/Terminal.hs b/src/Simplex/Chat/Terminal.hs index 2060e529eb..87c8d5d13e 100644 --- a/src/Simplex/Chat/Terminal.hs +++ b/src/Simplex/Chat/Terminal.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} module Simplex.Chat.Terminal where @@ -47,9 +48,9 @@ simplexChatTerminal :: WithTerminal t => ChatConfig -> ChatOpts -> t -> IO () simplexChatTerminal cfg options t = run options where run opts@ChatOpts {coreOptions = coreOptions@CoreChatOpts {dbKey}} = - handle checkDBKeyError . simplexChatCore cfg opts $ \u cc -> do + handle checkDBKeyError . simplexChatCore' cfg opts $ \fstTime u cc -> do ct <- newChatTerminal t opts - when (firstTime cc) . printToTerminal ct $ chatWelcome u + when fstTime . printToTerminal ct $ chatWelcome u runChatTerminal ct cc opts where checkDBKeyError :: SQLError -> IO () diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index bc17432760..7457db943a 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -1777,7 +1777,7 @@ viewChatError logLevel testView = \case CEUserNotHidden _ -> ["user is not hidden"] CEInvalidDisplayName {displayName, validName} -> map plain $ - ["invalid display name: " <> viewName displayName] + [if T.null displayName then "display name can't be empty" else "invalid display name: " <> viewName displayName] <> ["you could use this one: " <> viewName validName | not (T.null validName)] CEChatNotStarted -> ["error: chat not started"] CEChatNotStopped -> ["error: chat not stopped"] @@ -1889,6 +1889,8 @@ viewChatError logLevel testView = \case AGENT A_DUPLICATE -> [withConnEntity <> "error: AGENT A_DUPLICATE" | logLevel == CLLDebug] AGENT A_PROHIBITED -> [withConnEntity <> "error: AGENT A_PROHIBITED" | logLevel <= CLLWarning] CONN NOT_FOUND -> [withConnEntity <> "error: CONN NOT_FOUND" | logLevel <= CLLWarning] + CRITICAL restart e -> [plain $ "critical error: " <> e] <> ["please restart the app" | restart] + INTERNAL e -> [plain $ "internal error: " <> e] e -> [withConnEntity <> "smp agent error: " <> sShow e | logLevel <= CLLWarning] where withConnEntity = case entity_ of diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs index 234087166c..c04d99f9ee 100644 --- a/tests/ChatClient.hs +++ b/tests/ChatClient.hs @@ -73,21 +73,22 @@ testOpts = } testCoreOpts :: CoreChatOpts -testCoreOpts = CoreChatOpts - { dbFilePrefix = undefined, - dbKey = "", - -- dbKey = "this is a pass-phrase to encrypt the database", - smpServers = ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001"], - xftpServers = ["xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002"], - networkConfig = defaultNetworkConfig, - logLevel = CLLImportant, - logConnections = False, - logServerHosts = False, - logAgent = Nothing, - logFile = Nothing, - tbqSize = 16, - highlyAvailable = False - } +testCoreOpts = + CoreChatOpts + { dbFilePrefix = undefined, + dbKey = "", + -- dbKey = "this is a pass-phrase to encrypt the database", + smpServers = ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001"], + xftpServers = ["xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002"], + networkConfig = defaultNetworkConfig, + logLevel = CLLImportant, + logConnections = False, + logServerHosts = False, + logAgent = Nothing, + logFile = Nothing, + tbqSize = 16, + highlyAvailable = False + } getTestOpts :: Bool -> ScrubbedBytes -> ChatOpts getTestOpts maintenance dbKey = testOpts {maintenance, coreOptions = testCoreOpts {dbKey}} diff --git a/tests/ChatTests/Direct.hs b/tests/ChatTests/Direct.hs index 64fa6ff3bf..b06eddcd12 100644 --- a/tests/ChatTests/Direct.hs +++ b/tests/ChatTests/Direct.hs @@ -1559,6 +1559,19 @@ testDeleteUser = alice ##> "/create user alisa3" showActiveUser alice "alisa3" + alice ##> "/delete user alisa3 del_smp=on" + alice <### ["ok", "completed deleting user"] + alice ##> "/users" + alice <## "no users" + + alice ##> "/create user alisa4" + showActiveUser alice "alisa4" + connectUsers alice bob + alice <##> bob + alice ##> "/delete user alisa4 del_smp=on" + alice <### ["ok", "completed deleting user"] + alice ##> "/users" + alice <## "no users" testUsersDifferentCIExpirationTTL :: HasCallStack => FilePath -> IO () testUsersDifferentCIExpirationTTL tmp = do