core: update api (#3221)

2026-05-25 04:15:31 +00:00 · 2023-10-15 00:18:04 +01:00
parent f5e9bd4f8b
commit 41b86e07f1
9 changed files with 199 additions and 126 deletions
@@ -70,6 +70,7 @@ import Simplex.Chat.Store.Files
 import Simplex.Chat.Store.Groups
 import Simplex.Chat.Store.Messages
 import Simplex.Chat.Store.Profiles
+import Simplex.Chat.Store.Remote
 import Simplex.Chat.Store.Shared
 import Simplex.Chat.Types
 import Simplex.Chat.Types.Preferences
@@ -1900,7 +1901,7 @@ processChatCommand = \case
  StopRemoteHost rh -> closeRemoteHostSession rh >> ok_
  DeleteRemoteHost rh -> deleteRemoteHost rh >> ok_
  StartRemoteCtrl -> startRemoteCtrl (execChatCommand Nothing) >> ok_
-  RegisterRemoteCtrl oob -> CRRemoteCtrlRegistered <$> registerRemoteCtrl oob
+  RegisterRemoteCtrl oob -> CRRemoteCtrlRegistered <$> withStore' (`insertRemoteCtrl` oob)
  AcceptRemoteCtrl rc -> acceptRemoteCtrl rc >> ok_
  RejectRemoteCtrl rc -> rejectRemoteCtrl rc >> ok_
  StopRemoteCtrl -> stopRemoteCtrl >> ok_
@@ -633,14 +633,14 @@ data ChatResponse
  | CRContactConnectionDeleted {user :: User, connection :: PendingContactConnection}
  | CRRemoteHostCreated {remoteHost :: RemoteHostInfo}
  | CRRemoteHostList {remoteHosts :: [RemoteHostInfo]}
-  | CRRemoteHostConnected {remoteHostId :: RemoteHostId} -- TODO add displayName
+  | CRRemoteHostConnected {remoteHost :: RemoteHostInfo}
  | CRRemoteHostStopped {remoteHostId :: RemoteHostId}
  | CRRemoteCtrlList {remoteCtrls :: [RemoteCtrlInfo]}
-  | CRRemoteCtrlRegistered {remoteCtrlId :: RemoteCtrlId}
+  | CRRemoteCtrlRegistered {remoteCtrl :: RemoteCtrlInfo}
  | CRRemoteCtrlAnnounce {fingerprint :: C.KeyHash} -- unregistered fingerprint, needs confirmation
-  | CRRemoteCtrlFound {remoteCtrl :: RemoteCtrl} -- registered fingerprint, may connect
-  | CRRemoteCtrlConnecting {remoteCtrlId :: RemoteCtrlId, displayName :: Text}
-  | CRRemoteCtrlConnected {remoteCtrlId :: RemoteCtrlId, displayName :: Text}
+  | CRRemoteCtrlFound {remoteCtrl :: RemoteCtrlInfo} -- registered fingerprint, may connect
+  | CRRemoteCtrlConnecting {remoteCtrl :: RemoteCtrlInfo}
+  | CRRemoteCtrlConnected {remoteCtrl :: RemoteCtrlInfo}
  | CRRemoteCtrlStopped
  | CRSQLResult {rows :: [Text]}
  | CRSlowSQLQueries {chatQueries :: [SlowSQLQuery], agentQueries :: [SlowSQLQuery]}
@@ -693,34 +693,6 @@ logResponseToFile = \case
  CRMessageError {} -> True
  _ -> False

-data RemoteCtrlOOB = RemoteCtrlOOB
-  { caFingerprint :: C.KeyHash,
-    displayName :: Text
-  }
-  deriving (Show, Generic, FromJSON)
-
-instance ToJSON RemoteCtrlOOB where toEncoding = J.genericToEncoding J.defaultOptions
-
-data RemoteHostInfo = RemoteHostInfo
-  { remoteHostId :: RemoteHostId,
-    storePath :: FilePath,
-    displayName :: Text,
-    remoteCtrlOOB :: RemoteCtrlOOB,
-    sessionActive :: Bool
-  }
-  deriving (Show, Generic, FromJSON)
-
-instance ToJSON RemoteHostInfo where toEncoding = J.genericToEncoding J.defaultOptions
-
-data RemoteCtrlInfo = RemoteCtrlInfo
-  { remoteCtrlId :: RemoteCtrlId,
-    displayName :: Text,
-    sessionActive :: Bool
-  }
-  deriving (Eq, Show, Generic, FromJSON)
-
-instance ToJSON RemoteCtrlInfo where toEncoding = J.genericToEncoding J.defaultOptions
-
 data ConnectionPlan
  = CPInvitationLink {invitationLinkPlan :: InvitationLinkPlan}
  | CPContactAddress {contactAddressPlan :: ContactAddressPlan}
@@ -33,6 +33,7 @@ import Data.Int (Int64)
 import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.Map.Strict as M
 import Data.Maybe (fromMaybe)
+import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding (decodeUtf8, encodeUtf8)
 import qualified Network.HTTP.Types as HTTP
@@ -93,7 +94,7 @@ startRemoteHost remoteHostId = do
      M.lookup remoteHostId <$> chatReadVar remoteHostSessions >>= \case
        Nothing -> logInfo $ "Session already closed for remote host " <> tshow remoteHostId
        Just _ -> closeRemoteHostSession remoteHostId >> toView (CRRemoteHostStopped remoteHostId)
-    run RemoteHost {storePath, caKey, caCert} = do
+    run rh@RemoteHost {storePath, caKey, caCert} = do
      finished <- newTVarIO False
      let parent = (C.signatureKeyPair caKey, caCert)
      sessionCreds <- liftIO $ genCredentials (Just parent) (0, 24) "Session"
@@ -120,7 +121,9 @@ startRemoteHost remoteHostId = do
                      Nothing -> toViewRemote chatResponse
                      Just localFile -> toViewRemote CRRcvFileComplete {user = ru, chatItem = AChatItem c d i ci {file = Just localFile}}
                  _ -> toViewRemote chatResponse
-              toView CRRemoteHostConnected {remoteHostId}
+              rcName <- chatReadVar localDeviceName
+              -- TODO what sets session active?
+              toView CRRemoteHostConnected {remoteHost = remoteHostInfo rh True rcName}

 sendHello :: (ChatMonad m) => HTTP2Client -> m (Either HTTP2.HTTP2ClientError HTTP2.HTTP2Response)
 sendHello http = liftIO (HTTP2.sendRequestDirect http req Nothing)
@@ -155,13 +158,13 @@ cancelRemoteHostSession = \case

 createRemoteHost :: (ChatMonad m) => m RemoteHostInfo
 createRemoteHost = do
-  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
+  let rhName = "TODO" -- you don't have remote host name here, it will be passed from remote host
+  ((_, caKey), caCert) <- liftIO $ genCredentials Nothing (-25, 24 * 365) rhName
  storePath <- liftIO randomStorePath
-  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}
+  remoteHostId <- withStore' $ \db -> insertRemoteHost db storePath rhName caKey caCert
+  rcName <- chatReadVar localDeviceName
+  let remoteCtrlOOB = RemoteCtrlOOB {fingerprint = C.certificateFingerprint caCert, displayName = rcName}
+  pure RemoteHostInfo {remoteHostId, storePath, displayName = rhName, remoteCtrlOOB, sessionActive = False}

 -- | Generate a random 16-char filepath without / in it by using base64url encoding.
 randomStorePath :: IO FilePath
@@ -173,10 +176,13 @@ listRemoteHosts = do
  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}
+    rhInfo active rcName rh@RemoteHost {remoteHostId} =
+      remoteHostInfo rh (M.member remoteHostId active) rcName
+
+remoteHostInfo :: RemoteHost -> Bool -> Text -> RemoteHostInfo
+remoteHostInfo RemoteHost {remoteHostId, storePath, displayName, caCert} sessionActive rcName =
+  let remoteCtrlOOB = RemoteCtrlOOB {fingerprint = C.certificateFingerprint caCert, displayName = rcName}
+   in RemoteHostInfo {remoteHostId, storePath, displayName, remoteCtrlOOB, sessionActive}

 deleteRemoteHost :: (ChatMonad m) => RemoteHostId -> m ()
 deleteRemoteHost remoteHostId = withRemoteHost remoteHostId $ \RemoteHost {storePath} -> do
@@ -405,13 +411,13 @@ startRemoteCtrl execChatCommand =
      accepted <- newEmptyTMVarIO
      supervisor <- async $ do
        remoteCtrlId <- atomically (readTMVar accepted)
-        withRemoteCtrl remoteCtrlId $ \RemoteCtrl {displayName, fingerprint} -> do
+        withRemoteCtrl remoteCtrlId $ \rc@RemoteCtrl {fingerprint} -> do
          source <- atomically $ TM.lookup fingerprint discovered >>= maybe retry pure
-          toView $ CRRemoteCtrlConnecting {remoteCtrlId, displayName}
+          toView $ CRRemoteCtrlConnecting $ remoteCtrlInfo rc False
          atomically $ writeTVar discovered mempty -- flush unused sources
          server <- async $ Discovery.connectRevHTTP2 source fingerprint (processControllerRequest execChatCommand)
          chatModifyVar remoteCtrlSession $ fmap $ \s -> s {hostServer = Just server}
-          toView $ CRRemoteCtrlConnected {remoteCtrlId, displayName}
+          toView $ CRRemoteCtrlConnected $ remoteCtrlInfo rc True
          _ <- waitCatch server
          chatWriteVar remoteCtrlSession Nothing
          toView CRRemoteCtrlStopped
@@ -436,7 +442,7 @@ discoverRemoteCtrls discovered = Discovery.withListener go
            withStore' (`getRemoteCtrlByFingerprint` fingerprint) >>= \case
              Nothing -> toView $ CRRemoteCtrlAnnounce fingerprint -- unknown controller, ui "register" action required
              Just found@RemoteCtrl {remoteCtrlId, accepted = storedChoice} -> case storedChoice of
-                Nothing -> toView $ CRRemoteCtrlFound found -- first-time controller, ui "accept" action required
+                Nothing -> toView $ CRRemoteCtrlFound $ remoteCtrlInfo found False -- first-time controller, ui "accept" action required
                Just False -> pure () -- skipping a rejected item
                Just True ->
                  chatReadVar remoteCtrlSession >>= \case
@@ -444,11 +450,6 @@ discoverRemoteCtrls discovered = Discovery.withListener go
                    Just RemoteCtrlSession {accepted} -> atomically $ void $ tryPutTMVar accepted remoteCtrlId -- previously accepted controller, connect automatically
        _nonV4 -> go sock

-registerRemoteCtrl :: (ChatMonad m) => RemoteCtrlOOB -> m RemoteCtrlId
-registerRemoteCtrl RemoteCtrlOOB {caFingerprint, displayName} = do
-  remoteCtrlId <- withStore' $ \db -> insertRemoteCtrl db displayName caFingerprint
-  pure remoteCtrlId
-
 listRemoteCtrls :: (ChatMonad m) => m [RemoteCtrlInfo]
 listRemoteCtrls = do
  active <-
@@ -456,9 +457,12 @@ listRemoteCtrls = do
      $>>= \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}
+    rcInfo active rc@RemoteCtrl {remoteCtrlId} =
+      remoteCtrlInfo rc $ active == Just remoteCtrlId
+
+remoteCtrlInfo :: RemoteCtrl -> Bool -> RemoteCtrlInfo
+remoteCtrlInfo RemoteCtrl {remoteCtrlId, displayName, fingerprint, accepted} sessionActive =
+  RemoteCtrlInfo {remoteCtrlId, displayName, fingerprint, accepted, sessionActive}

 acceptRemoteCtrl :: (ChatMonad m) => RemoteCtrlId -> m ()
 acceptRemoteCtrl remoteCtrlId = do
@@ -24,6 +24,25 @@ data RemoteHost = RemoteHost
  }
  deriving (Show)

+data RemoteCtrlOOB = RemoteCtrlOOB
+  { fingerprint :: C.KeyHash,
+    displayName :: Text
+  }
+  deriving (Show)
+
+$(J.deriveJSON J.defaultOptions ''RemoteCtrlOOB)
+
+data RemoteHostInfo = RemoteHostInfo
+  { remoteHostId :: RemoteHostId,
+    storePath :: FilePath,
+    displayName :: Text,
+    remoteCtrlOOB :: RemoteCtrlOOB,
+    sessionActive :: Bool
+  }
+  deriving (Show)
+
+$(J.deriveJSON J.defaultOptions ''RemoteHostInfo)
+
 type RemoteCtrlId = Int64

 data RemoteCtrl = RemoteCtrl
@@ -34,4 +53,15 @@ data RemoteCtrl = RemoteCtrl
  }
  deriving (Show)

-$(J.deriveJSON J.defaultOptions ''RemoteCtrl)
+$(J.deriveJSON J.defaultOptions {J.omitNothingFields = True} ''RemoteCtrl)
+
+data RemoteCtrlInfo = RemoteCtrlInfo
+  { remoteCtrlId :: RemoteCtrlId,
+    displayName :: Text,
+    fingerprint :: C.KeyHash,
+    accepted :: Maybe Bool,
+    sessionActive :: Bool
+  }
+  deriving (Show)
+
+$(J.deriveJSON J.defaultOptions {J.omitNothingFields = True} ''RemoteCtrlInfo)
@@ -9,14 +9,15 @@ import Data.Text (Text)
 import Database.SQLite.Simple (Only (..))
 import qualified Database.SQLite.Simple as SQL
 import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
-import Simplex.Chat.Remote.Types (RemoteCtrl (..), RemoteCtrlId, RemoteHost (..), RemoteHostId)
+import Simplex.Chat.Store.Shared (insertedRowId)
+import Simplex.Chat.Remote.Types
 import Simplex.Messaging.Agent.Store.SQLite (maybeFirstRow)
 import qualified Simplex.Messaging.Crypto as C

 insertRemoteHost :: DB.Connection -> FilePath -> Text -> C.APrivateSignKey -> C.SignedCertificate -> IO RemoteHostId
 insertRemoteHost db storePath displayName caKey caCert = do
  DB.execute db "INSERT INTO remote_hosts (store_path, display_name, ca_key, ca_cert) VALUES (?,?,?,?)" (storePath, displayName, caKey, C.SignedObject caCert)
-  fromOnly . head <$> DB.query_ db "SELECT last_insert_rowid()"
+  insertedRowId db

 getRemoteHosts :: DB.Connection -> IO [RemoteHost]
 getRemoteHosts db =
@@ -37,10 +38,11 @@ toRemoteHost (remoteHostId, storePath, displayName, caKey, C.SignedObject caCert
 deleteRemoteHostRecord :: DB.Connection -> RemoteHostId -> IO ()
 deleteRemoteHostRecord db remoteHostId = DB.execute db "DELETE FROM remote_hosts WHERE remote_host_id = ?" (Only remoteHostId)

-insertRemoteCtrl :: DB.Connection -> Text -> C.KeyHash -> IO RemoteCtrlId
-insertRemoteCtrl db displayName fingerprint = do
+insertRemoteCtrl :: DB.Connection -> RemoteCtrlOOB -> IO RemoteCtrlInfo
+insertRemoteCtrl db RemoteCtrlOOB {fingerprint, displayName} = do
  DB.execute db "INSERT INTO remote_controllers (display_name, fingerprint) VALUES (?,?)" (displayName, fingerprint)
-  fromOnly . head <$> DB.query_ db "SELECT last_insert_rowid()"
+  remoteCtrlId <- insertedRowId db
+  pure RemoteCtrlInfo {remoteCtrlId, displayName, fingerprint, accepted = Nothing, sessionActive = False}

 getRemoteCtrls :: DB.Connection -> IO [RemoteCtrl]
 getRemoteCtrls db =
@@ -264,14 +264,14 @@ responseToView (currentRH, user_) ChatConfig {logLevel, showReactions, showRecei
  CRNtfMessages {} -> []
  CRRemoteHostCreated RemoteHostInfo {remoteHostId, remoteCtrlOOB} -> ("remote host " <> sShow remoteHostId <> " created") : viewRemoteCtrlOOBData remoteCtrlOOB
  CRRemoteHostList hs -> viewRemoteHosts hs
-  CRRemoteHostConnected rhId -> ["remote host " <> sShow rhId <> " connected"]
+  CRRemoteHostConnected RemoteHostInfo {remoteHostId = rhId} -> ["remote host " <> sShow rhId <> " connected"]
  CRRemoteHostStopped rhId -> ["remote host " <> sShow rhId <> " stopped"]
  CRRemoteCtrlList cs -> viewRemoteCtrls cs
-  CRRemoteCtrlRegistered rcId -> ["remote controller " <> sShow rcId <> " registered"]
+  CRRemoteCtrlRegistered RemoteCtrlInfo {remoteCtrlId = rcId} -> ["remote controller " <> sShow rcId <> " registered"]
  CRRemoteCtrlAnnounce fingerprint -> ["remote controller announced", "connection code:", plain $ strEncode fingerprint]
  CRRemoteCtrlFound rc -> ["remote controller found:", viewRemoteCtrl rc]
-  CRRemoteCtrlConnecting rcId rcName -> ["remote controller " <> sShow rcId <> " connecting to " <> plain rcName]
-  CRRemoteCtrlConnected rcId rcName -> ["remote controller " <> sShow rcId <> " connected, " <> plain rcName]
+  CRRemoteCtrlConnecting RemoteCtrlInfo {remoteCtrlId = rcId, displayName = rcName} -> ["remote controller " <> sShow rcId <> " connecting to " <> plain rcName]
+  CRRemoteCtrlConnected RemoteCtrlInfo {remoteCtrlId = rcId, displayName = rcName} -> ["remote controller " <> sShow rcId <> " connected, " <> plain rcName]
  CRRemoteCtrlStopped -> ["remote controller stopped"]
  CRSQLResult rows -> map plain rows
  CRSlowSQLQueries {chatQueries, agentQueries} ->
@@ -1633,8 +1633,8 @@ viewVersionInfo logLevel CoreVersionInfo {version, simplexmqVersion, simplexmqCo
    parens s = " (" <> s <> ")"

 viewRemoteCtrlOOBData :: RemoteCtrlOOB -> [StyledString]
-viewRemoteCtrlOOBData RemoteCtrlOOB {caFingerprint} =
-  ["connection code:", plain $ strEncode caFingerprint]
+viewRemoteCtrlOOBData RemoteCtrlOOB {fingerprint} =
+  ["connection code:", plain $ strEncode fingerprint]

 viewRemoteHosts :: [RemoteHostInfo] -> [StyledString]
 viewRemoteHosts = \case
@@ -1653,8 +1653,8 @@ viewRemoteCtrls = \case
      plain $ tshow remoteCtrlId <> ". " <> displayName <> if sessionActive then " (active)" else ""

 -- TODO fingerprint, accepted?
-viewRemoteCtrl :: RemoteCtrl -> StyledString
-viewRemoteCtrl RemoteCtrl {remoteCtrlId, displayName} =
+viewRemoteCtrl :: RemoteCtrlInfo -> StyledString
+viewRemoteCtrl RemoteCtrlInfo {remoteCtrlId, displayName} =
  plain $ tshow remoteCtrlId <> ". " <> displayName

 viewChatError :: ChatLogLevel -> ChatError -> [StyledString]