core: only skip creating agent user when app is first started

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

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,

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 <> ")"

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 ()

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

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}}

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