core: add set display name (#3216)

* core: add set display name

* enable all tests

src/Simplex/Chat.hs

@@ -205,6 +205,7 @@ newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agen
   sndFiles <- newTVarIO M.empty
   rcvFiles <- newTVarIO M.empty
   currentCalls <- atomically TM.empty
+  localDeviceName <- newTVarIO "" -- TODO set in config
   remoteHostSessions <- atomically TM.empty
   remoteCtrlSession <- newTVarIO Nothing
   filesFolder <- newTVarIO optFilesFolder
@@ -236,6 +237,7 @@ newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agen
         sndFiles,
         rcvFiles,
         currentCalls,
+        localDeviceName,
         remoteHostSessions,
         remoteCtrlSession,
         config,
@@ -1891,16 +1893,17 @@ processChatCommand = \case
     let pref = uncurry TimedMessagesGroupPreference $ maybe (FEOff, Just 86400) (\ttl -> (FEOn, Just ttl)) ttl_
     updateGroupProfileByName gName $ \p ->
       p {groupPreferences = Just . setGroupPreference' SGFTimedMessages pref $ groupPreferences p}
-  CreateRemoteHost -> uncurry CRRemoteHostCreated <$> createRemoteHost
+  SetLocalDeviceName name -> withUser $ \_ -> chatWriteVar localDeviceName name >> ok_
+  CreateRemoteHost -> CRRemoteHostCreated <$> createRemoteHost
   ListRemoteHosts -> CRRemoteHostList <$> listRemoteHosts
   StartRemoteHost rh -> startRemoteHost rh >> ok_
   StopRemoteHost rh -> closeRemoteHostSession rh >> ok_
   DeleteRemoteHost rh -> deleteRemoteHost rh >> ok_
   StartRemoteCtrl -> startRemoteCtrl (execChatCommand Nothing) >> ok_
+  RegisterRemoteCtrl oob -> CRRemoteCtrlRegistered <$> registerRemoteCtrl oob
   AcceptRemoteCtrl rc -> acceptRemoteCtrl rc >> ok_
   RejectRemoteCtrl rc -> rejectRemoteCtrl rc >> ok_
   StopRemoteCtrl -> stopRemoteCtrl >> ok_
-  RegisterRemoteCtrl oob -> CRRemoteCtrlRegistered <$> registerRemoteCtrl oob
   ListRemoteCtrls -> CRRemoteCtrlList <$> listRemoteCtrls
   DeleteRemoteCtrl rc -> deleteRemoteCtrl rc >> ok_
   QuitChat -> liftIO exitSuccess
@@ -5810,14 +5813,15 @@ chatCommandP =
       "/set disappear @" *> (SetContactTimedMessages <$> displayName <*> optional (A.space *> timedMessagesEnabledP)),
       "/set disappear " *> (SetUserTimedMessages <$> (("yes" $> True) <|> ("no" $> False))),
       ("/incognito" <* optional (A.space *> onOffP)) $> ChatHelp HSIncognito,
+      "/set device name " *> (SetLocalDeviceName <$> textP),
       "/create remote host" $> CreateRemoteHost,
       "/list remote hosts" $> ListRemoteHosts,
       "/start remote host " *> (StartRemoteHost <$> A.decimal),
       "/stop remote host " *> (StopRemoteHost <$> A.decimal),
       "/delete remote host " *> (DeleteRemoteHost <$> A.decimal),
       "/start remote ctrl" $> StartRemoteCtrl,
-      -- TODO *** you need to pass multiple parameters here
-      "/register remote ctrl " *> (RegisterRemoteCtrl <$> (RemoteCtrlOOB <$> strP)),
+      "/register remote ctrl " *> (RegisterRemoteCtrl <$> (RemoteCtrlOOB <$> strP <* A.space <*> textP)),
+      "/_register remote ctrl " *> (RegisterRemoteCtrl <$> jsonP),
       "/list remote ctrls" $> ListRemoteCtrls,
       "/accept remote ctrl " *> (AcceptRemoteCtrl <$> A.decimal),
       "/reject remote ctrl " *> (RejectRemoteCtrl <$> A.decimal),

src/Simplex/Chat/Controller.hs

@@ -179,6 +179,7 @@ data ChatController = ChatController
     sndFiles :: TVar (Map Int64 Handle),
     rcvFiles :: TVar (Map Int64 Handle),
     currentCalls :: TMap ContactId Call,
+    localDeviceName :: TVar Text,
     remoteHostSessions :: TMap RemoteHostId RemoteHostSession, -- All the active remote hosts
     remoteCtrlSession :: TVar (Maybe RemoteCtrlSession), -- Supervisor process for hosted controllers
     config :: ChatConfig,
@@ -419,6 +420,7 @@ data ChatCommand
   | SetUserTimedMessages Bool -- UserId (not used in UI)
   | SetContactTimedMessages ContactName (Maybe TimedMessagesEnabled)
   | SetGroupTimedMessages GroupName (Maybe Int)
+  | SetLocalDeviceName Text
   | CreateRemoteHost -- ^ Configure a new remote host
   | ListRemoteHosts
   | StartRemoteHost RemoteHostId -- ^ Start and announce a remote host
@@ -629,9 +631,9 @@ data ChatResponse
   | CRNtfMessages {user_ :: Maybe User, connEntity :: Maybe ConnectionEntity, msgTs :: Maybe UTCTime, ntfMessages :: [NtfMsgInfo]}
   | CRNewContactConnection {user :: User, connection :: PendingContactConnection}
   | CRContactConnectionDeleted {user :: User, connection :: PendingContactConnection}
-  | CRRemoteHostCreated {remoteHostId :: RemoteHostId, oobData :: RemoteCtrlOOB}
-  | CRRemoteHostList {remoteHosts :: [RemoteHostInfo]} -- XXX: RemoteHostInfo is mostly concerned with session setup
-  | CRRemoteHostConnected {remoteHostId :: RemoteHostId}
+  | CRRemoteHostCreated {remoteHost :: RemoteHostInfo}
+  | CRRemoteHostList {remoteHosts :: [RemoteHostInfo]}
+  | CRRemoteHostConnected {remoteHostId :: RemoteHostId} -- TODO add displayName
   | CRRemoteHostStopped {remoteHostId :: RemoteHostId}
   | CRRemoteCtrlList {remoteCtrls :: [RemoteCtrlInfo]}
   | CRRemoteCtrlRegistered {remoteCtrlId :: RemoteCtrlId}
@@ -692,7 +694,8 @@ logResponseToFile = \case
   _ -> False
 
 data RemoteCtrlOOB = RemoteCtrlOOB
-  { caFingerprint :: C.KeyHash
+  { caFingerprint :: C.KeyHash,
+    displayName :: Text
   }
   deriving (Show, Generic, FromJSON)
 
@@ -702,6 +705,7 @@ data RemoteHostInfo = RemoteHostInfo
   { remoteHostId :: RemoteHostId,
     storePath :: FilePath,
     displayName :: Text,
+    remoteCtrlOOB :: RemoteCtrlOOB,
     sessionActive :: Bool
   }
   deriving (Show, Generic, FromJSON)

src/Simplex/Chat/Remote.hs

@@ -62,7 +62,7 @@ import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..), defaultHTTP2BufferSize
 import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client)
 import qualified Simplex.Messaging.Transport.HTTP2.Client as HTTP2
 import qualified Simplex.Messaging.Transport.HTTP2.Server as HTTP2
-import Simplex.Messaging.Util (bshow, ifM, tshow)
+import Simplex.Messaging.Util (bshow, ifM, tshow, ($>>=))
 import System.FilePath (isPathSeparator, takeFileName, (</>))
 import UnliftIO
 import UnliftIO.Directory (createDirectoryIfMissing, getFileSize)
@@ -153,14 +153,15 @@ cancelRemoteHostSession = \case
   RemoteHostSessionStarting {announcer} -> cancel announcer
   RemoteHostSessionStarted {ctrlClient} -> liftIO $ HTTP2.closeHTTP2Client ctrlClient
 
-createRemoteHost :: (ChatMonad m) => m (RemoteHostId, RemoteCtrlOOB)
+createRemoteHost :: (ChatMonad m) => m RemoteHostInfo
 createRemoteHost = do
-  let displayName = "TODO" -- you don't have remote host name here, it will be passed from remote host
-  ((_, caKey), caCert) <- liftIO $ genCredentials Nothing (-25, 24 * 365) displayName
+  let hostDisplayName = "TODO" -- you don't have remote host name here, it will be passed from remote host
+  ((_, caKey), caCert) <- liftIO $ genCredentials Nothing (-25, 24 * 365) hostDisplayName
   storePath <- liftIO randomStorePath
-  remoteHostId <- withStore' $ \db -> insertRemoteHost db storePath displayName caKey caCert
-  let oobData = RemoteCtrlOOB {caFingerprint = C.certificateFingerprint caCert}
-  pure (remoteHostId, oobData)
+  remoteHostId <- withStore' $ \db -> insertRemoteHost db storePath hostDisplayName caKey caCert
+  displayName <- chatReadVar localDeviceName
+  let remoteCtrlOOB = RemoteCtrlOOB {caFingerprint = C.certificateFingerprint caCert, displayName}
+  pure RemoteHostInfo {remoteHostId, storePath, displayName, remoteCtrlOOB, sessionActive = False}
 
 -- | Generate a random 16-char filepath without / in it by using base64url encoding.
 randomStorePath :: IO FilePath
@@ -168,12 +169,14 @@ randomStorePath = B.unpack . B64U.encode <$> getRandomBytes 12
 
 listRemoteHosts :: (ChatMonad m) => m [RemoteHostInfo]
 listRemoteHosts = do
-  stored <- withStore' getRemoteHosts
   active <- chatReadVar remoteHostSessions
-  pure $ do
-    RemoteHost {remoteHostId, storePath, displayName} <- stored
-    let sessionActive = M.member remoteHostId active
-    pure RemoteHostInfo {remoteHostId, storePath, displayName, sessionActive}
+  rcName <- chatReadVar localDeviceName
+  map (rhInfo active rcName) <$> withStore' getRemoteHosts
+  where
+    rhInfo active rcName RemoteHost {remoteHostId, storePath, displayName, caCert} =
+      let sessionActive = M.member remoteHostId active
+          remoteCtrlOOB = RemoteCtrlOOB {caFingerprint = C.certificateFingerprint caCert, displayName = rcName}
+       in RemoteHostInfo {remoteHostId, storePath, displayName, remoteCtrlOOB, sessionActive}
 
 deleteRemoteHost :: (ChatMonad m) => RemoteHostId -> m ()
 deleteRemoteHost remoteHostId = withRemoteHost remoteHostId $ \RemoteHost {storePath} -> do
@@ -442,22 +445,20 @@ discoverRemoteCtrls discovered = Discovery.withListener go
         _nonV4 -> go sock
 
 registerRemoteCtrl :: (ChatMonad m) => RemoteCtrlOOB -> m RemoteCtrlId
-registerRemoteCtrl RemoteCtrlOOB {caFingerprint} = do
-  let displayName = "TODO" -- maybe include into OOB data
+registerRemoteCtrl RemoteCtrlOOB {caFingerprint, displayName} = do
   remoteCtrlId <- withStore' $ \db -> insertRemoteCtrl db displayName caFingerprint
   pure remoteCtrlId
 
 listRemoteCtrls :: (ChatMonad m) => m [RemoteCtrlInfo]
 listRemoteCtrls = do
-  stored <- withStore' getRemoteCtrls
   active <-
-    chatReadVar remoteCtrlSession >>= \case
-      Nothing -> pure Nothing
-      Just RemoteCtrlSession {accepted} -> atomically (tryReadTMVar accepted)
-  pure $ do
-    RemoteCtrl {remoteCtrlId, displayName} <- stored
-    let sessionActive = active == Just remoteCtrlId
-    pure RemoteCtrlInfo {remoteCtrlId, displayName, sessionActive}
+    chatReadVar remoteCtrlSession
+      $>>= \RemoteCtrlSession {accepted} -> atomically $ tryReadTMVar accepted
+  map (rcInfo active) <$> withStore' getRemoteCtrls
+  where
+    rcInfo active RemoteCtrl {remoteCtrlId, displayName} =
+      let sessionActive = active == Just remoteCtrlId
+       in RemoteCtrlInfo {remoteCtrlId, displayName, sessionActive}
 
 acceptRemoteCtrl :: (ChatMonad m) => RemoteCtrlId -> m ()
 acceptRemoteCtrl remoteCtrlId = do
@@ -479,10 +480,7 @@ stopRemoteCtrl :: (ChatMonad m) => m ()
 stopRemoteCtrl =
   chatReadVar remoteCtrlSession >>= \case
     Nothing -> throwError $ ChatErrorRemoteCtrl RCEInactive
-    Just rcs -> do
-      cancelRemoteCtrlSession rcs $ do
-        chatWriteVar remoteCtrlSession Nothing
-        toView CRRemoteCtrlStopped
+    Just rcs -> cancelRemoteCtrlSession rcs $ chatWriteVar remoteCtrlSession Nothing
 
 cancelRemoteCtrlSession_ :: (MonadUnliftIO m) => RemoteCtrlSession -> m ()
 cancelRemoteCtrlSession_ rcs = cancelRemoteCtrlSession rcs $ pure ()

src/Simplex/Chat/View.hs

@@ -262,7 +262,7 @@ responseToView (currentRH, user_) ChatConfig {logLevel, showReactions, showRecei
   CRNtfTokenStatus status -> ["device token status: " <> plain (smpEncode status)]
   CRNtfToken _ status mode -> ["device token status: " <> plain (smpEncode status) <> ", notifications mode: " <> plain (strEncode mode)]
   CRNtfMessages {} -> []
-  CRRemoteHostCreated rhId oobData -> ("remote host " <> sShow rhId <> " created") : viewRemoteCtrlOOBData oobData
+  CRRemoteHostCreated RemoteHostInfo {remoteHostId, remoteCtrlOOB} -> ("remote host " <> sShow remoteHostId <> " created") : viewRemoteCtrlOOBData remoteCtrlOOB
   CRRemoteHostList hs -> viewRemoteHosts hs
   CRRemoteHostConnected rhId -> ["remote host " <> sShow rhId <> " connected"]
   CRRemoteHostStopped rhId -> ["remote host " <> sShow rhId <> " stopped"]
@@ -320,14 +320,14 @@ responseToView (currentRH, user_) ChatConfig {logLevel, showReactions, showRecei
       | otherwise = []
     ttyUserPrefix :: User -> [StyledString] -> [StyledString]
     ttyUserPrefix _ [] = []
-    ttyUserPrefix User {userId, localDisplayName = u} ss = prependFirst prefix ss
+    ttyUserPrefix User {userId, localDisplayName = u} ss
+      | null prefix = ss
+      | otherwise = prependFirst ("[" <> mconcat prefix <> "] ") ss
       where
-        prefix = if outputRH /= currentRH then r else userPrefix
-        r = case outputRH of
-          Nothing -> "[local] " <> userPrefix
-          Just rh -> "[remote: ]" <> highlight (show rh) <> "] "
-        userPrefix = if Just userId /= currentUserId then "[user: " <> highlight u <> "] " else ""
-        currentUserId = fmap (\User {userId} -> userId) user_
+        prefix = intersperse ", " $ remotePrefix <> userPrefix
+        remotePrefix = [maybe "local" (("remote: " <>) . highlight . show) outputRH | outputRH /= currentRH]
+        userPrefix = ["user: " <> highlight u | Just userId /= currentUserId]
+        currentUserId = (\User {userId = uId} -> uId) <$> user_
     ttyUser' :: Maybe User -> [StyledString] -> [StyledString]
     ttyUser' = maybe id ttyUser
     ttyUserPrefix' :: Maybe User -> [StyledString] -> [StyledString]

tests/RemoteTests.hs

@@ -120,15 +120,15 @@ remoteHandshakeTest = testChat2 aliceProfile bobProfile $ \desktop mobile -> do
   fingerprint' `shouldBe` fingerprint
   mobile ##> "/list remote ctrls"
   mobile <## "No remote controllers"
-  mobile ##> ("/register remote ctrl " <> fingerprint')
+  mobile ##> ("/register remote ctrl " <> fingerprint' <> " " <> "My desktop")
   mobile <## "remote controller 1 registered"
   mobile ##> "/list remote ctrls"
   mobile <## "Remote controllers:"
-  mobile <## "1. TODO"
+  mobile <## "1. My desktop"
   mobile ##> "/accept remote ctrl 1"
   mobile <## "ok" -- alternative scenario: accepted before controller start
-  mobile <## "remote controller 1 connecting to TODO"
-  mobile <## "remote controller 1 connected, TODO"
+  mobile <## "remote controller 1 connecting to My desktop"
+  mobile <## "remote controller 1 connected, My desktop"
 
   traceM "    - Session active"
   desktop ##> "/list remote hosts"
@@ -136,7 +136,7 @@ remoteHandshakeTest = testChat2 aliceProfile bobProfile $ \desktop mobile -> do
   desktop <## "1. TODO (active)"
   mobile ##> "/list remote ctrls"
   mobile <## "Remote controllers:"
-  mobile <## "1. TODO (active)"
+  mobile <## "1. My desktop (active)"
 
   traceM "    - Shutting desktop"
   desktop ##> "/stop remote host 1"
@@ -181,12 +181,12 @@ remoteCommandTest = testChat3 aliceProfile aliceDesktopProfile bobProfile $ \mob
   mobile <## "connection code:"
   fingerprint' <- getTermLine mobile
   fingerprint' `shouldBe` fingerprint
-  mobile ##> ("/register remote ctrl " <> fingerprint')
+  mobile ##> ("/register remote ctrl " <> fingerprint' <> " " <> "My desktop")
   mobile <## "remote controller 1 registered"
   mobile ##> "/accept remote ctrl 1"
   mobile <## "ok" -- alternative scenario: accepted before controller start
-  mobile <## "remote controller 1 connecting to TODO"
-  mobile <## "remote controller 1 connected, TODO"
+  mobile <## "remote controller 1 connecting to My desktop"
+  mobile <## "remote controller 1 connected, My desktop"
   desktop <## "remote host 1 connected"
 
   traceM "    - exchanging contacts"

tests/Test.hs

@@ -33,7 +33,7 @@ main = do
       describe "SimpleX chat client" chatTests
       xdescribe'' "SimpleX Broadcast bot" broadcastBotTests
       xdescribe'' "SimpleX Directory service bot" directoryServiceTests
-      fdescribe "Remote session" remoteTests
+      describe "Remote session" remoteTests
   where
     testBracket test = do
       t <- getSystemTime