core: add set display name (#3216)

* core: add set display name * enable all tests
2026-06-05 05:53:12 +00:00 · 2023-10-14 13:10:06 +01:00
parent 5e6aaffb09
commit f5e9bd4f8b
6 changed files with 57 additions and 51 deletions
@@ -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)
@@ -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 ()
@@ -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]