Add commands for remote session credentials (#3161)

* Add remote host commands * Make startRemoteHost async * Add tests * Trim randomStorePath to 16 chars * Add chat command tests * add view, use view output in test * enable all tests * Fix discovery listener host Must use any, not broadcast on macos. * Fix missing do * address, names * Fix session host flow * fix test --------- Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
2025-03-14 09:45:42 +00:00 · 2023-10-04 18:36:10 +03:00 · 2023-10-04 18:36:10 +03:00 · 0bcf5c9c66
commit 0bcf5c9c66
parent bf7917bd67
13 changed files with 515 additions and 197 deletions
--- a/cabal.project
+++ b/cabal.project
@ -9,7 +9,7 @@ constraints: zip +disable-bzip2 +disable-zstd
 source-repository-package
    type: git
    location: https://github.com/simplex-chat/simplexmq.git
-    tag: ec1b72cb8013a65a5d9783104a47ae44f5730089
+    tag: 753a6c7542c3764fda9ce3f4c4cdc9f2329816d3

 source-repository-package
    type: git
--- a/simplex-chat.cabal
+++ b/simplex-chat.cabal
@ -490,6 +490,7 @@ test-suite simplex-chat-test
      MarkdownTests
      MobileTests
      ProtocolTests
+      RemoteTests
      SchemaDump
      ViewTests
      WebRTCTests
--- a/src/Simplex/Chat.hs
+++ b/src/Simplex/Chat.hs
@ -1835,18 +1835,18 @@ 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 _displayName -> pure $ chatCmdError Nothing "not supported"
-  ListRemoteHosts -> pure $ chatCmdError Nothing "not supported"
+  CreateRemoteHost -> createRemoteHost
+  ListRemoteHosts -> listRemoteHosts
  StartRemoteHost rh -> startRemoteHost rh
-  StopRemoteHost rh -> closeRemoteHostSession rh $> CRRemoteHostStopped rh
-  DisposeRemoteHost _rh -> pure $ chatCmdError Nothing "not supported"
+  StopRemoteHost rh -> closeRemoteHostSession rh
+  DeleteRemoteHost rh -> deleteRemoteHost rh
  StartRemoteCtrl -> startRemoteCtrl
-  ConfirmRemoteCtrl rc -> confirmRemoteCtrl rc
+  AcceptRemoteCtrl rc -> acceptRemoteCtrl rc
  RejectRemoteCtrl rc -> rejectRemoteCtrl rc
  StopRemoteCtrl rc -> stopRemoteCtrl rc
-  RegisterRemoteCtrl _displayName _oobData -> pure $ chatCmdError Nothing "not supported"
-  ListRemoteCtrls -> pure $ chatCmdError Nothing "not supported"
-  DisposeRemoteCtrl rc -> disposeRemoteCtrl rc
+  RegisterRemoteCtrl oob -> registerRemoteCtrl oob
+  ListRemoteCtrls -> listRemoteCtrls
+  DeleteRemoteCtrl rc -> deleteRemoteCtrl rc
  QuitChat -> liftIO exitSuccess
  ShowVersion -> do
    let versionInfo = coreVersionInfo $(simplexmqCommitQ)
@ -5609,17 +5609,19 @@ chatCommandP =
      "/set disappear @" *> (SetContactTimedMessages <$> displayName <*> optional (A.space *> timedMessagesEnabledP)),
      "/set disappear " *> (SetUserTimedMessages <$> (("yes" $> True) <|> ("no" $> False))),
      ("/incognito" <* optional (A.space *> onOffP)) $> ChatHelp HSIncognito,
-      "/create remote host" *> (CreateRemoteHost <$> textP),
+      "/create remote host" $> CreateRemoteHost,
      "/list remote hosts" $> ListRemoteHosts,
      "/start remote host " *> (StartRemoteHost <$> A.decimal),
      "/stop remote host " *> (StopRemoteHost <$> A.decimal),
-      "/dispose remote host " *> (DisposeRemoteHost <$> A.decimal),
+      "/delete remote host " *> (DeleteRemoteHost <$> A.decimal),
      "/start remote ctrl" $> StartRemoteCtrl,
-      "/register remote ctrl " *> (RegisterRemoteCtrl <$> textP <*> remoteHostOOBP),
-      "/confirm remote ctrl " *> (ConfirmRemoteCtrl <$> A.decimal),
+      -- TODO *** you need to pass multiple parameters here
+      "/register remote ctrl " *> (RegisterRemoteCtrl <$> (RemoteCtrlOOB <$> strP)),
+      "/list remote ctrls" $> ListRemoteCtrls,
+      "/accept remote ctrl " *> (AcceptRemoteCtrl <$> A.decimal),
      "/reject remote ctrl " *> (RejectRemoteCtrl <$> A.decimal),
      "/stop remote ctrl " *> (StopRemoteCtrl <$> A.decimal),
-      "/dispose remote ctrl " *> (DisposeRemoteCtrl <$> A.decimal),
+      "/delete remote ctrl " *> (DeleteRemoteCtrl <$> A.decimal),
      ("/quit" <|> "/q" <|> "/exit") $> QuitChat,
      ("/version" <|> "/v") $> ShowVersion,
      "/debug locks" $> DebugLocks,
@ -5737,7 +5739,6 @@ chatCommandP =
    srvCfgP = strP >>= \case AProtocolType p -> APSC p <$> (A.space *> jsonP)
    toServerCfg server = ServerCfg {server, preset = False, tested = Nothing, enabled = True}
    char_ = optional . A.char
-    remoteHostOOBP = RemoteHostOOB <$> textP

 adminContactReq :: ConnReqContact
 adminContactReq =
--- a/src/Simplex/Chat/Controller.hs
+++ b/src/Simplex/Chat/Controller.hs
@ -414,18 +414,18 @@ data ChatCommand
  | SetUserTimedMessages Bool -- UserId (not used in UI)
  | SetContactTimedMessages ContactName (Maybe TimedMessagesEnabled)
  | SetGroupTimedMessages GroupName (Maybe Int)
-  | CreateRemoteHost Text -- ^ Configure a new remote host
+  | CreateRemoteHost -- ^ Configure a new remote host
  | ListRemoteHosts
  | StartRemoteHost RemoteHostId -- ^ Start and announce a remote host
  | StopRemoteHost RemoteHostId -- ^ Shut down a running session
-  | DisposeRemoteHost RemoteHostId -- ^ Unregister remote host and remove its data
-  | RegisterRemoteCtrl Text RemoteHostOOB -- ^ Register OOB data for satellite discovery and handshake
+  | DeleteRemoteHost RemoteHostId -- ^ Unregister remote host and remove its data
+  | RegisterRemoteCtrl RemoteCtrlOOB -- ^ Register OOB data for satellite discovery and handshake
  | StartRemoteCtrl -- ^ Start listening for announcements from all registered controllers
  | ListRemoteCtrls
-  | ConfirmRemoteCtrl RemoteCtrlId -- ^ Confirm discovered data and store confirmation
+  | AcceptRemoteCtrl RemoteCtrlId -- ^ Accept discovered data and store confirmation
  | RejectRemoteCtrl RemoteCtrlId -- ^ Reject and blacklist discovered data
  | StopRemoteCtrl RemoteCtrlId -- ^ Stop listening for announcements or terminate an active session
-  | DisposeRemoteCtrl RemoteCtrlId -- ^ Remove all local data associated with a satellite session
+  | DeleteRemoteCtrl RemoteCtrlId -- ^ Remove all local data associated with a satellite session
  | QuitChat
  | ShowVersion
  | DebugLocks
@ -597,22 +597,23 @@ 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 :: RemoteHostOOB}
+  | CRRemoteHostCreated {remoteHostId :: RemoteHostId, oobData :: RemoteCtrlOOB}
  | CRRemoteHostList {remoteHosts :: [RemoteHostInfo]} -- XXX: RemoteHostInfo is mostly concerned with session setup
  | CRRemoteHostStarted {remoteHostId :: RemoteHostId}
+  | CRRemoteHostConnected {remoteHostId :: RemoteHostId}
  | CRRemoteHostStopped {remoteHostId :: RemoteHostId}
-  | CRRemoteHostDisposed {remoteHostId :: RemoteHostId}
+  | CRRemoteHostDeleted {remoteHostId :: RemoteHostId}
  | CRRemoteCtrlList {remoteCtrls :: [RemoteCtrlInfo]}
  | CRRemoteCtrlRegistered {remoteCtrlId :: RemoteCtrlId}
  | CRRemoteCtrlStarted
  | CRRemoteCtrlAnnounce {fingerprint :: C.KeyHash} -- unregistered fingerprint, needs confirmation
-  | CRRemoteCtrlFound {remoteCtrl::RemoteCtrl} -- registered fingerprint, may connect
-  -- | CRRemoteCtrlFirstContact {remoteCtrlId :: RemoteCtrlId, displayName :: Text}
+  | CRRemoteCtrlFound {remoteCtrl :: RemoteCtrl} -- registered fingerprint, may connect
  | CRRemoteCtrlAccepted {remoteCtrlId :: RemoteCtrlId}
  | CRRemoteCtrlRejected {remoteCtrlId :: RemoteCtrlId}
+  | CRRemoteCtrlConnecting {remoteCtrlId :: RemoteCtrlId, displayName :: Text}
  | CRRemoteCtrlConnected {remoteCtrlId :: RemoteCtrlId, displayName :: Text}
  | CRRemoteCtrlStopped {remoteCtrlId :: RemoteCtrlId}
-  | CRRemoteCtrlDisposed {remoteCtrlId :: RemoteCtrlId}
+  | CRRemoteCtrlDeleted {remoteCtrlId :: RemoteCtrlId}
  | CRSQLResult {rows :: [Text]}
  | CRSlowSQLQueries {chatQueries :: [SlowSQLQuery], agentQueries :: [SlowSQLQuery]}
  | CRDebugLocks {chatLockName :: Maybe String, agentLocks :: AgentLocks}
@ -656,13 +657,14 @@ instance ToJSON ChatResponse where
  toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "CR"
  toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "CR"

-data RemoteHostOOB = RemoteHostOOB
-  { fingerprint :: Text -- CA key fingerprint
+data RemoteCtrlOOB = RemoteCtrlOOB
+  { caFingerprint :: C.KeyHash
  }
  deriving (Show, Generic, ToJSON)

 data RemoteHostInfo = RemoteHostInfo
  { remoteHostId :: RemoteHostId,
+    storePath :: FilePath,
    displayName :: Text,
    sessionActive :: Bool
  }
@ -673,7 +675,7 @@ data RemoteCtrlInfo = RemoteCtrlInfo
    displayName :: Text,
    sessionActive :: Bool
  }
-  deriving (Show, Generic, ToJSON)
+  deriving (Eq, Show, Generic, ToJSON)

 newtype UserPwd = UserPwd {unUserPwd :: Text}
  deriving (Eq, Show)
@ -1052,6 +1054,7 @@ data RemoteCtrlError
  | RCEConnectionLost {remoteCtrlId :: RemoteCtrlId, reason :: Text} -- ^ A session disconnected due to transport issues
  | RCECertificateExpired {remoteCtrlId :: RemoteCtrlId} -- ^ A connection or CA certificate in a chain have bad validity period
  | RCECertificateUntrusted {remoteCtrlId :: RemoteCtrlId} -- ^ TLS is unable to validate certificate chain presented for a connection
+  | RCEBadFingerprint -- ^ Bad fingerprint data provided in OOB
  deriving (Show, Exception, Generic)

 instance FromJSON RemoteCtrlError where
--- a/src/Simplex/Chat/Migrations/M20230922_remote_controller.hs
+++ b/src/Simplex/Chat/Migrations/M20230922_remote_controller.hs
@ -9,18 +9,19 @@ m20230922_remote_controller :: Query
 m20230922_remote_controller =
  [sql|
 CREATE TABLE remote_hosts ( -- hosts known to a controlling app
-  remote_host_id INTEGER PRIMARY KEY,
-  display_name TEXT NOT NULL,
-  store_path TEXT NOT NULL,
-  ca_cert BLOB NOT NULL,
-  ca_key BLOB NOT NULL
+  remote_host_id INTEGER PRIMARY KEY AUTOINCREMENT,
+  store_path TEXT NOT NULL,            -- file path relative to app store (must not contain "/")
+  display_name TEXT NOT NULL,          -- user-provided name for a remote host
+  ca_key BLOB NOT NULL,                -- private key for signing session certificates
+  ca_cert BLOB NOT NULL,               -- root certificate, whose fingerprint is pinned on a remote
+  contacted INTEGER NOT NULL DEFAULT 0 -- 0 (first time), 1 (connected before)
 );

 CREATE TABLE remote_controllers ( -- controllers known to a hosting app
-  remote_controller_id INTEGER PRIMARY KEY,
-  display_name TEXT NOT NULL,
-  fingerprint BLOB NOT NULL,
-  accepted INTEGER -- unknown/rejected/confirmed
+  remote_controller_id INTEGER PRIMARY KEY AUTOINCREMENT,
+  display_name TEXT NOT NULL, -- user-provided name for a remote controller
+  fingerprint BLOB NOT NULL,  -- remote controller CA fingerprint
+  accepted INTEGER            -- NULL (unknown), 0 (rejected), 1 (confirmed)
 );
 |]

--- a/src/Simplex/Chat/Migrations/chat_schema.sql
+++ b/src/Simplex/Chat/Migrations/chat_schema.sql
@ -518,17 +518,19 @@ CREATE TABLE IF NOT EXISTS "received_probes"(
 );
 CREATE TABLE remote_hosts(
  -- hosts known to a controlling app
-  remote_host_id INTEGER PRIMARY KEY,
-  display_name TEXT NOT NULL,
-  store_path TEXT NOT NULL,
-  ca_cert BLOB NOT NULL,
-  ca_key BLOB NOT NULL
+  remote_host_id INTEGER PRIMARY KEY AUTOINCREMENT,
+  store_path TEXT NOT NULL, -- file path relative to app store(must not contain "/")
+  display_name TEXT NOT NULL, -- user-provided name for a remote host
+  ca_key BLOB NOT NULL, -- private key for signing session certificates
+  ca_cert BLOB NOT NULL, -- root certificate, whose fingerprint is pinned on a remote
+  contacted INTEGER NOT NULL DEFAULT 0 -- 0(first time), 1(connected before)
 );
 CREATE TABLE remote_controllers(
  -- controllers known to a hosting app
-  remote_controller_id INTEGER PRIMARY KEY,
-  display_name TEXT NOT NULL,
-  fingerprint BLOB NOT NULL
+  remote_controller_id INTEGER PRIMARY KEY AUTOINCREMENT,
+  display_name TEXT NOT NULL, -- user-provided name for a remote controller
+  fingerprint BLOB NOT NULL, -- remote controller CA fingerprint
+  accepted INTEGER -- NULL(unknown), 0(rejected), 1(confirmed)
 );
 CREATE INDEX contact_profiles_index ON contact_profiles(
  display_name,
--- a/src/Simplex/Chat/Remote.hs
+++ b/src/Simplex/Chat/Remote.hs
@ -7,11 +7,17 @@

 module Simplex.Chat.Remote where

+import Control.Monad
 import Control.Monad.Except
 import Control.Monad.IO.Class
+import Control.Monad.STM (retry)
+import Crypto.Random (getRandomBytes)
 import qualified Data.Aeson as J
 import qualified Data.Binary.Builder as Binary
-import Data.ByteString.Char8 (ByteString)
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Base64.URL as B64U
+import qualified Data.ByteString.Char8 as B
+import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.Map.Strict as M
 import qualified Network.HTTP.Types as HTTP
 import qualified Network.HTTP2.Client as HTTP2Client
@ -21,12 +27,13 @@ import qualified Simplex.Chat.Remote.Discovery as Discovery
 import Simplex.Chat.Remote.Types
 import Simplex.Chat.Store.Remote
 import Simplex.Chat.Types
-import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String (StrEncoding (..))
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport.Client (TransportHost (..))
+import Simplex.Messaging.Transport.Credentials (genCredentials, tlsCredentials)
 import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..))
+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)
@ -39,29 +46,82 @@ withRemoteHostSession remoteHostId action = do
  where
    err = throwError $ ChatErrorRemoteHost remoteHostId RHMissing

+withRemoteHost :: (ChatMonad m) => RemoteHostId -> (RemoteHost -> m a) -> m a
+withRemoteHost remoteHostId action =
+  withStore' (`getRemoteHost` remoteHostId) >>= \case
+    Nothing -> throwError $ ChatErrorRemoteHost remoteHostId RHMissing
+    Just rh -> action rh
+
 startRemoteHost :: (ChatMonad m) => RemoteHostId -> m ChatResponse
 startRemoteHost remoteHostId = do
-  RemoteHost {displayName = _, storePath, caKey, caCert} <- error "TODO: get from DB"
-  (fingerprint :: ByteString, sessionCreds) <- error "TODO: derive session creds" (caKey, caCert)
-  cleanup <- toIO $ chatModifyVar remoteHostSessions (M.delete remoteHostId)
-  Discovery.runAnnouncer cleanup fingerprint sessionCreds >>= \case
-    Left todo'err -> pure $ chatCmdError Nothing "TODO: Some HTTP2 error"
-    Right ctrlClient -> do
-      chatModifyVar remoteHostSessions $ M.insert remoteHostId RemoteHostSession {storePath, ctrlClient}
-      pure $ CRRemoteHostStarted remoteHostId
+  M.lookup remoteHostId <$> chatReadVar remoteHostSessions >>= \case
+    Just _ -> throwError $ ChatErrorRemoteHost remoteHostId RHBusy
+    Nothing -> withRemoteHost remoteHostId run
+  where
+    run RemoteHost {storePath, caKey, caCert} = do
+      announcer <- async $ do
+        cleanup <- toIO $ closeRemoteHostSession remoteHostId >>= toView
+        let parent = (C.signatureKeyPair caKey, caCert)
+        sessionCreds <- liftIO $ genCredentials (Just parent) (0, 24) "Session"
+        let (fingerprint, credentials) = tlsCredentials $ sessionCreds :| [parent]
+        Discovery.announceRevHTTP2 cleanup fingerprint credentials >>= \case
+          Left todo'err -> liftIO cleanup -- TODO: log error
+          Right ctrlClient -> do
+            chatModifyVar remoteHostSessions $ M.insert remoteHostId RemoteHostSessionStarted {storePath, ctrlClient}
+            -- TODO: start streaming outputQ
+            toView CRRemoteHostConnected {remoteHostId}
+      chatModifyVar remoteHostSessions $ M.insert remoteHostId RemoteHostSessionStarting {announcer}
+      pure CRRemoteHostStarted {remoteHostId}

-closeRemoteHostSession :: (ChatMonad m) => RemoteHostId -> m ()
-closeRemoteHostSession rh = withRemoteHostSession rh (liftIO . HTTP2.closeHTTP2Client . ctrlClient)
+closeRemoteHostSession :: (ChatMonad m) => RemoteHostId -> m ChatResponse
+closeRemoteHostSession remoteHostId = withRemoteHostSession remoteHostId $ \session -> do
+  case session of
+    RemoteHostSessionStarting {announcer} -> cancel announcer
+    RemoteHostSessionStarted {ctrlClient} -> liftIO (HTTP2.closeHTTP2Client ctrlClient)
+  chatModifyVar remoteHostSessions $ M.delete remoteHostId
+  pure CRRemoteHostStopped { remoteHostId }
+
+createRemoteHost :: (ChatMonad m) => m ChatResponse
+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
+  storePath <- liftIO randomStorePath
+  remoteHostId <- withStore' $ \db -> insertRemoteHost db storePath displayName caKey caCert
+  let oobData =
+        RemoteCtrlOOB
+          { caFingerprint = C.certificateFingerprint caCert
+          }
+  pure CRRemoteHostCreated {remoteHostId, oobData}
+
+-- | Generate a random 16-char filepath without / in it by using base64url encoding.
+randomStorePath :: IO FilePath
+randomStorePath = B.unpack . B64U.encode <$> getRandomBytes 12
+
+listRemoteHosts :: (ChatMonad m) => m ChatResponse
+listRemoteHosts = do
+  stored <- withStore' getRemoteHosts
+  active <- chatReadVar remoteHostSessions
+  pure $ CRRemoteHostList $ do
+    RemoteHost {remoteHostId, storePath, displayName} <- stored
+    let sessionActive = M.member remoteHostId active
+    pure RemoteHostInfo {remoteHostId, storePath, displayName, sessionActive}
+
+deleteRemoteHost :: (ChatMonad m) => RemoteHostId -> m ChatResponse
+deleteRemoteHost remoteHostId = withRemoteHost remoteHostId $ \rh -> do
+  -- TODO: delete files
+  withStore' $ \db -> deleteRemoteHostRecord db remoteHostId
+  pure CRRemoteHostDeleted {remoteHostId}

 processRemoteCommand :: (ChatMonad m) => RemoteHostSession -> (ByteString, ChatCommand) -> m ChatResponse
-processRemoteCommand rhs = \case
+processRemoteCommand RemoteHostSessionStarting {} _ = error "TODO: sending remote commands before session started"
+processRemoteCommand RemoteHostSessionStarted {ctrlClient} (s, cmd) =
  -- XXX: intercept and filter some commands
  -- TODO: store missing files on remote host
-  (s, _cmd) -> relayCommand rhs s
+  relayCommand ctrlClient s

-relayCommand :: (ChatMonad m) => RemoteHostSession -> ByteString -> m ChatResponse
-relayCommand RemoteHostSession {ctrlClient} s =
-  postBytestring Nothing ctrlClient "/relay" mempty s >>= \case
+relayCommand :: (ChatMonad m) => HTTP2Client -> ByteString -> m ChatResponse
+relayCommand http s =
+  postBytestring Nothing http "/relay" mempty s >>= \case
    Left e -> error "TODO: http2chatError"
    Right HTTP2.HTTP2Response {respBody = HTTP2Body {bodyHead}} -> do
      remoteChatResponse <-
@ -85,9 +145,15 @@ relayCommand RemoteHostSession {ctrlClient} s =
      where
        req = HTTP2Client.requestBuilder "POST" path hs (Binary.fromByteString body)

-storeRemoteFile :: (ChatMonad m) => RemoteHostSession -> FilePath -> m ChatResponse
-storeRemoteFile RemoteHostSession {ctrlClient} localFile = do
-  postFile Nothing ctrlClient "/store" mempty localFile >>= \case
+-- | Convert swift single-field sum encoding into tagged/discriminator-field
+sum2tagged :: J.Value -> J.Value
+sum2tagged = \case
+  J.Object todo'convert -> J.Object todo'convert
+  skip -> skip
+
+storeRemoteFile :: (ChatMonad m) => HTTP2Client -> FilePath -> m ChatResponse
+storeRemoteFile http localFile = do
+  postFile Nothing http "/store" mempty localFile >>= \case
    Left todo'err -> error "TODO: http2chatError"
    Right HTTP2.HTTP2Response {response} -> case HTTP.statusCode <$> HTTP2Client.responseStatus response of
      Just 200 -> pure $ CRCmdOk Nothing
@ -99,9 +165,9 @@ storeRemoteFile RemoteHostSession {ctrlClient} localFile = do
      where
        req size = HTTP2Client.requestFile "POST" path hs (HTTP2Client.FileSpec file 0 size)

-fetchRemoteFile :: (ChatMonad m) => RemoteHostSession -> FileTransferId -> m ChatResponse
-fetchRemoteFile RemoteHostSession {ctrlClient, storePath} remoteFileId = do
-  liftIO (HTTP2.sendRequest ctrlClient req Nothing) >>= \case
+fetchRemoteFile :: (ChatMonad m) => HTTP2Client -> FilePath -> FileTransferId -> m ChatResponse
+fetchRemoteFile http storePath remoteFileId = do
+  liftIO (HTTP2.sendRequest http req Nothing) >>= \case
    Left e -> error "TODO: http2chatError"
    Right HTTP2.HTTP2Response {respBody} -> do
      error "TODO: stream body into a local file" -- XXX: consult headers for a file name?
@ -109,14 +175,8 @@ fetchRemoteFile RemoteHostSession {ctrlClient, storePath} remoteFileId = do
    req = HTTP2Client.requestNoBody "GET" path mempty
    path = "/fetch/" <> bshow remoteFileId

-- | Convert swift single-field sum encoding into tagged/discriminator-field
-sum2tagged :: J.Value -> J.Value
-sum2tagged = \case
-  J.Object todo'convert -> J.Object todo'convert
-  skip -> skip
-
-processControllerCommand :: (ChatMonad m) => RemoteCtrlId -> HTTP2.HTTP2Request -> m ()
-processControllerCommand rc req = error "TODO: processControllerCommand"
+processControllerRequest :: (ChatMonad m) => RemoteCtrlId -> HTTP2.HTTP2Request -> m ()
+processControllerRequest rc req = error "TODO: processControllerRequest"

 -- * ChatRequest handlers

@ -127,27 +187,23 @@ startRemoteCtrl =
    Nothing -> do
      accepted <- newEmptyTMVarIO
      discovered <- newTVarIO mempty
-      listener <- async $ discoverRemoteCtrls discovered
-      _supervisor <- async $ do
-        uiEvent <- async $ atomically $ readTMVar accepted
-        waitEitherCatchCancel listener uiEvent >>= \case
-          Left _ -> pure () -- discover got cancelled or crashed on some UDP error
-          Right (Left _) -> toView . CRChatError Nothing . ChatError $ CEException "Crashed while waiting for remote session confirmation"
-          Right (Right remoteCtrlId) ->
-            -- got connection confirmation
-            atomically (TM.lookup remoteCtrlId discovered) >>= \case
-              Nothing -> toView . CRChatError Nothing . ChatError $ CEInternalError "Remote session accepted without getting discovered first"
-              Just (source, fingerprint) -> do
-                atomically $ writeTVar discovered mempty -- flush unused sources
-                host <- async $ runRemoteHost remoteCtrlId source fingerprint
-                chatWriteVar remoteCtrlSession $ Just RemoteCtrlSession {ctrlAsync = host, accepted}
-                _ <- waitCatch host
-                chatWriteVar remoteCtrlSession Nothing
-                toView $ CRRemoteCtrlStopped {remoteCtrlId}
-      chatWriteVar remoteCtrlSession $ Just RemoteCtrlSession {ctrlAsync = listener, accepted}
+      discoverer <- async $ discoverRemoteCtrls discovered
+      supervisor <- async $ do
+        remoteCtrlId <- atomically (readTMVar accepted)
+        withRemoteCtrl remoteCtrlId $ \RemoteCtrl {displayName, fingerprint} -> do
+          source <- atomically $ TM.lookup fingerprint discovered >>= maybe retry pure
+          toView $ CRRemoteCtrlConnecting {remoteCtrlId, displayName}
+          atomically $ writeTVar discovered mempty -- flush unused sources
+          server <- async $ Discovery.connectRevHTTP2 source fingerprint (processControllerRequest remoteCtrlId)
+          chatModifyVar remoteCtrlSession $ fmap $ \s -> s {hostServer = Just server}
+          toView $ CRRemoteCtrlConnected {remoteCtrlId, displayName}
+          _ <- waitCatch server
+          chatWriteVar remoteCtrlSession Nothing
+          toView $ CRRemoteCtrlStopped {remoteCtrlId}
+      chatWriteVar remoteCtrlSession $ Just RemoteCtrlSession {discoverer, supervisor, hostServer = Nothing, discovered, accepted}
      pure CRRemoteCtrlStarted

-discoverRemoteCtrls :: (ChatMonad m) => TM.TMap RemoteCtrlId (TransportHost, C.KeyHash) -> m ()
+discoverRemoteCtrls :: (ChatMonad m) => TM.TMap C.KeyHash TransportHost -> m ()
 discoverRemoteCtrls discovered = Discovery.openListener >>= go
  where
    go sock =
@ -155,47 +211,77 @@ discoverRemoteCtrls discovered = Discovery.openListener >>= go
        (SockAddrInet _port addr, invite) -> case strDecode invite of
          Left _ -> go sock -- ignore malformed datagrams
          Right fingerprint -> do
-            withStore' (\db -> getRemoteCtrlByFingerprint (DB.conn db) fingerprint) >>= \case
-              Nothing -> toView $ CRRemoteCtrlAnnounce fingerprint
-              Just found@RemoteCtrl {remoteCtrlId} -> do
-                atomically $ TM.insert remoteCtrlId (THIPv4 (hostAddressToTuple addr), fingerprint) discovered
-                toView $ CRRemoteCtrlFound found
+            atomically $ TM.insert fingerprint (THIPv4 $ hostAddressToTuple addr) discovered
+            withStore' (`getRemoteCtrlByFingerprint` fingerprint) >>= \case
+              Nothing -> toView $ CRRemoteCtrlAnnounce fingerprint -- unknown controller, ui action required
+              Just found@RemoteCtrl {remoteCtrlId, accepted=storedChoice} -> case storedChoice of
+                Nothing -> toView $ CRRemoteCtrlFound found -- first-time controller, ui action required
+                Just False -> pure () -- skipping a rejected item
+                Just True -> chatReadVar remoteCtrlSession >>= \case
+                  Nothing -> toView . CRChatError Nothing . ChatError $ CEInternalError "Remote host found without running a session"
+                  Just RemoteCtrlSession {accepted} -> atomically $ void $ tryPutTMVar accepted remoteCtrlId -- previously accepted controller, connect automatically
        _nonV4 -> go sock

-runRemoteHost :: (ChatMonad m) => RemoteCtrlId -> TransportHost -> C.KeyHash -> m ()
-runRemoteHost remoteCtrlId remoteCtrlHost fingerprint =
-  Discovery.connectSessionHost remoteCtrlHost fingerprint $ Discovery.attachServer (processControllerCommand remoteCtrlId)
+registerRemoteCtrl :: (ChatMonad m) => RemoteCtrlOOB -> m ChatResponse
+registerRemoteCtrl RemoteCtrlOOB {caFingerprint} = do
+  let displayName = "TODO" -- maybe include into OOB data
+  remoteCtrlId <- withStore' $ \db -> insertRemoteCtrl db displayName caFingerprint
+  pure $ CRRemoteCtrlRegistered {remoteCtrlId}

-confirmRemoteCtrl :: (ChatMonad m) => RemoteCtrlId -> m ChatResponse
-confirmRemoteCtrl remoteCtrlId =
+listRemoteCtrls :: (ChatMonad m) => m ChatResponse
+listRemoteCtrls = do
+  stored <- withStore' getRemoteCtrls
+  active <-
+    chatReadVar remoteCtrlSession >>= \case
+      Nothing -> pure Nothing
+      Just RemoteCtrlSession {accepted} -> atomically (tryReadTMVar accepted)
+  pure $ CRRemoteCtrlList $ do
+    RemoteCtrl {remoteCtrlId, displayName} <- stored
+    let sessionActive = active == Just remoteCtrlId
+    pure RemoteCtrlInfo {remoteCtrlId, displayName, sessionActive}
+
+acceptRemoteCtrl :: (ChatMonad m) => RemoteCtrlId -> m ChatResponse
+acceptRemoteCtrl remoteCtrlId = do
+  withStore' $ \db -> markRemoteCtrlResolution db remoteCtrlId True
  chatReadVar remoteCtrlSession >>= \case
    Nothing -> throwError $ ChatErrorRemoteCtrl RCEInactive
-    Just RemoteCtrlSession {accepted} -> do
-      withStore' $ \db -> markRemoteCtrlResolution (DB.conn db) remoteCtrlId True
-      atomically $ putTMVar accepted remoteCtrlId -- the remote host can now proceed with connection
-      pure $ CRRemoteCtrlAccepted {remoteCtrlId}
+    Just RemoteCtrlSession {accepted} -> atomically . void $ tryPutTMVar accepted remoteCtrlId -- the remote host can now proceed with connection
+  pure $ CRRemoteCtrlAccepted {remoteCtrlId}

 rejectRemoteCtrl :: (ChatMonad m) => RemoteCtrlId -> m ChatResponse
-rejectRemoteCtrl remoteCtrlId =
+rejectRemoteCtrl remoteCtrlId = do
+  withStore' $ \db -> markRemoteCtrlResolution db remoteCtrlId False
  chatReadVar remoteCtrlSession >>= \case
    Nothing -> throwError $ ChatErrorRemoteCtrl RCEInactive
-    Just RemoteCtrlSession {ctrlAsync} -> do
-      withStore' $ \db -> markRemoteCtrlResolution (DB.conn db) remoteCtrlId False
-      cancel ctrlAsync
-      pure $ CRRemoteCtrlRejected {remoteCtrlId}
+    Just RemoteCtrlSession {discoverer, supervisor} -> do
+      cancel discoverer
+      cancel supervisor
+  pure $ CRRemoteCtrlRejected {remoteCtrlId}

 stopRemoteCtrl :: (ChatMonad m) => RemoteCtrlId -> m ChatResponse
 stopRemoteCtrl remoteCtrlId =
  chatReadVar remoteCtrlSession >>= \case
    Nothing -> throwError $ ChatErrorRemoteCtrl RCEInactive
-    Just RemoteCtrlSession {ctrlAsync} -> do
-      cancel ctrlAsync
-      pure CRRemoteCtrlStopped {remoteCtrlId}
+    Just RemoteCtrlSession {discoverer, supervisor, hostServer} -> do
+      cancel discoverer -- may be gone by now
+      case hostServer of
+        Just host -> cancel host -- supervisor will clean up
+        Nothing -> do
+          cancel supervisor -- supervisor is blocked until session progresses
+          chatWriteVar remoteCtrlSession Nothing
+          toView $ CRRemoteCtrlStopped {remoteCtrlId}
+      pure $ CRCmdOk Nothing

-disposeRemoteCtrl :: (ChatMonad m) => RemoteCtrlId -> m ChatResponse
-disposeRemoteCtrl remoteCtrlId =
+deleteRemoteCtrl :: (ChatMonad m) => RemoteCtrlId -> m ChatResponse
+deleteRemoteCtrl remoteCtrlId =
  chatReadVar remoteCtrlSession >>= \case
    Nothing -> do
-      withStore' $ \db -> deleteRemoteCtrl (DB.conn db) remoteCtrlId
-      pure $ CRRemoteCtrlDisposed {remoteCtrlId}
+      withStore' $ \db -> deleteRemoteCtrlRecord db remoteCtrlId
+      pure $ CRRemoteCtrlDeleted {remoteCtrlId}
    Just _ -> throwError $ ChatErrorRemoteCtrl RCEBusy
+
+withRemoteCtrl :: (ChatMonad m) => RemoteCtrlId -> (RemoteCtrl -> m a) -> m a
+withRemoteCtrl remoteCtrlId action =
+  withStore' (`getRemoteCtrl` remoteCtrlId) >>= \case
+    Nothing -> throwError $ ChatErrorRemoteCtrl RCEMissing {remoteCtrlId}
+    Just rc -> action rc
--- a/src/Simplex/Chat/Remote/Discovery.hs
+++ b/src/Simplex/Chat/Remote/Discovery.hs
@ -1,18 +1,21 @@
 {-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}

 module Simplex.Chat.Remote.Discovery
  ( -- * Announce
+    announceRevHTTP2,
    runAnnouncer,
+    startTLSServer,
+    runHTTP2Client,

    -- * Discovery
+    connectRevHTTP2,
    openListener,
    recvAnnounce,
-    connectSessionHost,
-    attachServer,
+    connectTLSClient,
+    attachHTTP2Server,
  )
 where

@ -20,7 +23,6 @@ import Control.Monad
 import Data.ByteString (ByteString)
 import Data.Default (def)
 import Data.String (IsString)
-import Debug.Trace
 import qualified Network.Socket as N
 import qualified Network.TLS as TLS
 import qualified Network.UDP as UDP
@ -33,54 +35,65 @@ import Simplex.Messaging.Transport.HTTP2 (defaultHTTP2BufferSize, getHTTP2Body)
 import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client, HTTP2ClientError, attachHTTP2Client, defaultHTTP2ClientConfig)
 import Simplex.Messaging.Transport.HTTP2.Server (HTTP2Request (..), runHTTP2ServerWith)
 import Simplex.Messaging.Transport.Server (defaultTransportServerConfig, runTransportServer)
+import Simplex.Messaging.Util (whenM)
 import UnliftIO
 import UnliftIO.Concurrent

 -- | Link-local broadcast address.
 pattern BROADCAST_ADDR_V4 :: (IsString a, Eq a) => a
-pattern BROADCAST_ADDR_V4 = "255.255.255.255"
+pattern BROADCAST_ADDR_V4 = "0.0.0.0"
+
+pattern ANY_ADDR_V4 :: (IsString a, Eq a) => a
+pattern ANY_ADDR_V4 = "0.0.0.0"

 pattern BROADCAST_PORT :: (IsString a, Eq a) => a
 pattern BROADCAST_PORT = "5226"

-runAnnouncer :: (StrEncoding invite, MonadUnliftIO m) => IO () -> invite -> TLS.Credentials -> m (Either HTTP2ClientError HTTP2Client)
-runAnnouncer finished invite credentials = do
-  started <- newEmptyTMVarIO
-  aPid <- async $ announcer started (strEncode invite)
-  let serverParams =
-        def
-          { TLS.serverWantClientCert = False,
-            TLS.serverShared = def {TLS.sharedCredentials = credentials},
-            TLS.serverHooks = def,
-            TLS.serverSupported = supportedParameters
-          }
+-- | Announce tls server, wait for connection and attach http2 client to it.
+--
+-- Announcer is started when TLS server is started and stopped when a connection is made.
+announceRevHTTP2 :: (StrEncoding invite, MonadUnliftIO m) => IO () -> invite -> TLS.Credentials -> m (Either HTTP2ClientError HTTP2Client)
+announceRevHTTP2 finishAction invite credentials = do
  httpClient <- newEmptyMVar
-  liftIO $ runTransportServer started BROADCAST_PORT serverParams defaultTransportServerConfig (run aPid httpClient)
-  takeMVar httpClient
-  where
-    announcer started inviteBS = do
-      atomically (takeTMVar started) >>= \case
-        False ->
-          error "Server not started?.."
-        True -> liftIO $ do
-          traceM $ "TCP server started at " <> BROADCAST_PORT
-          sock <- UDP.clientSocket BROADCAST_ADDR_V4 BROADCAST_PORT False
-          N.setSocketOption (UDP.udpSocket sock) N.Broadcast 1
-          traceM $ "UDP announce started at " <> BROADCAST_ADDR_V4 <> ":" <> BROADCAST_PORT
-          traceM $ "Server invite: " <> show inviteBS
-          forever $ do
-            UDP.send sock inviteBS
-            threadDelay 1000000
+  started <- newEmptyTMVarIO
+  finished <- newEmptyMVar
+  announcer <- async . liftIO . whenM (atomically $ takeTMVar started) $ runAnnouncer (strEncode invite)
+  tlsServer <- startTLSServer started credentials $ \tls -> cancel announcer >> runHTTP2Client finished httpClient tls
+  _ <- forkIO . liftIO $ do
+    readMVar finished
+    cancel tlsServer
+    finishAction
+  readMVar httpClient

-    run :: Async () -> MVar (Either HTTP2ClientError HTTP2Client) -> Transport.TLS -> IO ()
-    run aPid clientVar tls = do
-      cancel aPid
-      let partyHost = "255.255.255.255" -- XXX: get from tls somehow? not required as host verification is disabled.
-      attachHTTP2Client defaultHTTP2ClientConfig partyHost BROADCAST_PORT finished defaultHTTP2BufferSize tls >>= putMVar clientVar
+-- | Broadcast invite with link-local datagrams
+runAnnouncer :: ByteString -> IO ()
+runAnnouncer inviteBS = do
+  sock <- UDP.clientSocket BROADCAST_ADDR_V4 BROADCAST_PORT False
+  N.setSocketOption (UDP.udpSocket sock) N.Broadcast 1
+  forever $ do
+    UDP.send sock inviteBS
+    threadDelay 1000000
+
+startTLSServer :: (MonadUnliftIO m) => TMVar Bool -> TLS.Credentials -> (Transport.TLS -> IO ()) -> m (Async ())
+startTLSServer started credentials = async . liftIO . runTransportServer started BROADCAST_PORT serverParams defaultTransportServerConfig
+  where
+    serverParams =
+      def
+        { TLS.serverWantClientCert = False,
+          TLS.serverShared = def {TLS.sharedCredentials = credentials},
+          TLS.serverHooks = def,
+          TLS.serverSupported = supportedParameters
+        }
+
+-- | Attach HTTP2 client and hold the TLS until the attached client finishes.
+runHTTP2Client :: MVar () -> MVar (Either HTTP2ClientError HTTP2Client) -> Transport.TLS -> IO ()
+runHTTP2Client finishedVar clientVar tls = do
+  attachHTTP2Client defaultHTTP2ClientConfig ANY_ADDR_V4 BROADCAST_PORT (putMVar finishedVar ()) defaultHTTP2BufferSize tls >>= putMVar clientVar
+  readMVar finishedVar

 openListener :: (MonadIO m) => m UDP.ListenSocket
 openListener = liftIO $ do
-  sock <- UDP.serverSocket (BROADCAST_ADDR_V4, read BROADCAST_PORT)
+  sock <- UDP.serverSocket (ANY_ADDR_V4, read BROADCAST_PORT)
  N.setSocketOption (UDP.listenSocket sock) N.Broadcast 1
  pure sock

@ -89,11 +102,14 @@ recvAnnounce sock = liftIO $ do
  (invite, UDP.ClientSockAddr source _cmsg) <- UDP.recvFrom sock
  pure (source, invite)

-connectSessionHost :: (MonadUnliftIO m) => TransportHost -> C.KeyHash -> (Transport.TLS -> m a) -> m a
-connectSessionHost host caFingerprint = runTransportClient defaultTransportClientConfig Nothing host BROADCAST_PORT (Just caFingerprint)
+connectRevHTTP2 :: (MonadUnliftIO m) => TransportHost -> C.KeyHash -> (HTTP2Request -> m ()) -> m ()
+connectRevHTTP2 host fingerprint = connectTLSClient host fingerprint . attachHTTP2Server

-attachServer :: (MonadUnliftIO m) => (HTTP2Request -> m ()) -> Transport.TLS -> m ()
-attachServer processRequest tls = do
+connectTLSClient :: (MonadUnliftIO m) => TransportHost -> C.KeyHash -> (Transport.TLS -> m a) -> m a
+connectTLSClient host caFingerprint = runTransportClient defaultTransportClientConfig Nothing host BROADCAST_PORT (Just caFingerprint)
+
+attachHTTP2Server :: (MonadUnliftIO m) => (HTTP2Request -> m ()) -> Transport.TLS -> m ()
+attachHTTP2Server processRequest tls = do
  withRunInIO $ \unlift ->
    runHTTP2ServerWith defaultHTTP2BufferSize ($ tls) $ \sessionId r sendResponse -> do
      reqBody <- getHTTP2Body r defaultHTTP2BufferSize
--- a/src/Simplex/Chat/Remote/Types.hs
+++ b/src/Simplex/Chat/Remote/Types.hs
@ -6,26 +6,26 @@ module Simplex.Chat.Remote.Types where

 import Control.Concurrent.Async (Async)
 import Data.Aeson (ToJSON (..))
-import Data.ByteString.Char8 (ByteString)
 import Data.Int (Int64)
 import Data.Text (Text)
 import GHC.Generics (Generic)
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.TMap (TMap)
+import Simplex.Messaging.Transport.Client (TransportHost)
 import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client)
 import UnliftIO.STM
-import Simplex.Messaging.Encoding.String (strToJEncoding, strToJSON)

 type RemoteHostId = Int64

 data RemoteHost = RemoteHost
  { remoteHostId :: RemoteHostId,
-    displayName :: Text,
-    -- | Path to store replicated files
    storePath :: FilePath,
-    -- | A stable part of X509 credentials used to access the host
-    caCert :: ByteString,
+    displayName :: Text,
    -- | Credentials signing key for root and session certs
-    caKey :: C.Key
+    caKey :: C.APrivateSignKey,
+    -- | A stable part of TLS credentials used in remote session
+    caCert :: C.SignedCertificate,
+    contacted :: Bool
  }
  deriving (Show)

@ -39,19 +39,21 @@ data RemoteCtrl = RemoteCtrl
  }
  deriving (Show, Generic, ToJSON)

-- XXX: until fixed in master
-instance ToJSON C.KeyHash where
-  toEncoding = strToJEncoding
-  toJSON = strToJSON
-
-data RemoteHostSession = RemoteHostSession
-  { -- | Path for local resources to be synchronized with host
-    storePath :: FilePath,
-    ctrlClient :: HTTP2Client
-  }
+data RemoteHostSession
+  = RemoteHostSessionStarting
+      { announcer :: Async ()
+      }
+  | RemoteHostSessionStarted
+      { -- | Path for local resources to be synchronized with host
+        storePath :: FilePath,
+        ctrlClient :: HTTP2Client
+      }

 data RemoteCtrlSession = RemoteCtrlSession
  { -- | Server side of transport to process remote commands and forward notifications
-    ctrlAsync :: Async (),
+    discoverer :: Async (),
+    supervisor :: Async (),
+    hostServer :: Maybe (Async ()),
+    discovered :: TMap C.KeyHash TransportHost,
    accepted :: TMVar RemoteCtrlId
  }
--- a/src/Simplex/Chat/Store/Remote.hs
+++ b/src/Simplex/Chat/Store/Remote.hs
@ -4,14 +4,20 @@

 module Simplex.Chat.Store.Remote where

-import Data.ByteString.Char8 (ByteString)
 import Data.Int (Int64)
 import Data.Text (Text)
-import qualified Database.SQLite.Simple as DB
+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.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()"
+
 getRemoteHosts :: DB.Connection -> IO [RemoteHost]
 getRemoteHosts db =
  map toRemoteHost <$> DB.query_ db remoteHostQuery
@ -19,14 +25,22 @@ getRemoteHosts db =
 getRemoteHost :: DB.Connection -> RemoteHostId -> IO (Maybe RemoteHost)
 getRemoteHost db remoteHostId =
  maybeFirstRow toRemoteHost $
-    DB.query db (remoteHostQuery <> "WHERE remote_host_id = ?") (DB.Only remoteHostId)
+    DB.query db (remoteHostQuery <> " WHERE remote_host_id = ?") (Only remoteHostId)

-remoteHostQuery :: DB.Query
-remoteHostQuery = "SELECT remote_host_id, display_name, store_path, ca_cert, ca_key FROM remote_hosts"
+remoteHostQuery :: SQL.Query
+remoteHostQuery = "SELECT remote_host_id, store_path, display_name, ca_key, ca_cert, contacted FROM remote_hosts"

-toRemoteHost :: (Int64, Text, FilePath, ByteString, C.Key) -> RemoteHost
-toRemoteHost (remoteHostId, displayName, storePath, caCert, caKey) =
-  RemoteHost {remoteHostId, displayName, storePath, caCert, caKey}
+toRemoteHost :: (Int64, FilePath, Text, C.APrivateSignKey, C.SignedObject C.Certificate, Bool) -> RemoteHost
+toRemoteHost (remoteHostId, storePath, displayName, caKey, C.SignedObject caCert, contacted) =
+  RemoteHost {remoteHostId, storePath, displayName, caKey, caCert, contacted}
+
+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
+  DB.execute db "INSERT INTO remote_controllers (display_name, fingerprint) VALUES (?,?)" (displayName, fingerprint)
+  fromOnly . head <$> DB.query_ db "SELECT last_insert_rowid()"

 getRemoteCtrls :: DB.Connection -> IO [RemoteCtrl]
 getRemoteCtrls db =
@ -35,14 +49,14 @@ getRemoteCtrls db =
 getRemoteCtrl :: DB.Connection -> RemoteCtrlId -> IO (Maybe RemoteCtrl)
 getRemoteCtrl db remoteCtrlId =
  maybeFirstRow toRemoteCtrl $
-    DB.query db (remoteCtrlQuery <> "WHERE remote_controller_id = ?") (DB.Only remoteCtrlId)
+    DB.query db (remoteCtrlQuery <> " WHERE remote_controller_id = ?") (Only remoteCtrlId)

 getRemoteCtrlByFingerprint :: DB.Connection -> C.KeyHash -> IO (Maybe RemoteCtrl)
 getRemoteCtrlByFingerprint db fingerprint =
  maybeFirstRow toRemoteCtrl $
-    DB.query db (remoteCtrlQuery <> "WHERE fingerprint = ?") (DB.Only fingerprint)
+    DB.query db (remoteCtrlQuery <> " WHERE fingerprint = ?") (Only fingerprint)

-remoteCtrlQuery :: DB.Query
+remoteCtrlQuery :: SQL.Query
 remoteCtrlQuery = "SELECT remote_controller_id, display_name, fingerprint, accepted FROM remote_controllers"

 toRemoteCtrl :: (Int64, Text, C.KeyHash, Maybe Bool) -> RemoteCtrl
@ -53,6 +67,6 @@ markRemoteCtrlResolution :: DB.Connection -> RemoteCtrlId -> Bool -> IO ()
 markRemoteCtrlResolution db remoteCtrlId accepted =
  DB.execute db "UPDATE remote_controllers SET accepted = ? WHERE remote_controller_id = ? AND accepted IS NULL" (accepted, remoteCtrlId)

-deleteRemoteCtrl :: DB.Connection -> RemoteCtrlId -> IO ()
-deleteRemoteCtrl db remoteCtrlId =
-  DB.execute db "DELETE FROM remote_controllers WHERE remote_controller_id = ?" (DB.Only remoteCtrlId)
+deleteRemoteCtrlRecord :: DB.Connection -> RemoteCtrlId -> IO ()
+deleteRemoteCtrlRecord db remoteCtrlId =
+  DB.execute db "DELETE FROM remote_controllers WHERE remote_controller_id = ?" (Only remoteCtrlId)
--- a/src/Simplex/Chat/View.hs
+++ b/src/Simplex/Chat/View.hs
@ -4,10 +4,10 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE OverloadedRecordDot #-}

 module Simplex.Chat.View where

@ -42,6 +42,7 @@ import Simplex.Chat.Markdown
 import Simplex.Chat.Messages hiding (NewChatItem (..))
 import Simplex.Chat.Messages.CIContent
 import Simplex.Chat.Protocol
+import Simplex.Chat.Remote.Types
 import Simplex.Chat.Store (AutoAccept (..), StoreError (..), UserContactLink (..))
 import Simplex.Chat.Styled
 import Simplex.Chat.Types
@ -258,6 +259,23 @@ responseToView user_ ChatConfig {logLevel, showReactions, showReceipts, testView
  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
+  CRRemoteHostList hs -> viewRemoteHosts hs
+  CRRemoteHostStarted rhId -> ["remote host " <> sShow rhId <> " started"]
+  CRRemoteHostConnected rhId -> ["remote host " <> sShow rhId <> " connected"]
+  CRRemoteHostStopped rhId -> ["remote host " <> sShow rhId <> " stopped"]
+  CRRemoteHostDeleted rhId -> ["remote host " <> sShow rhId <> " deleted"]
+  CRRemoteCtrlList cs -> viewRemoteCtrls cs
+  CRRemoteCtrlRegistered rcId -> ["remote controller " <> sShow rcId <> " registered"]
+  CRRemoteCtrlStarted -> ["remote controller started"]
+  CRRemoteCtrlAnnounce fingerprint -> ["remote controller announced", "connection code:", plain $ strEncode fingerprint]
+  CRRemoteCtrlFound rc -> ["remote controller found:", viewRemoteCtrl rc]
+  CRRemoteCtrlAccepted rcId -> ["remote controller " <> sShow rcId <> " accepted"]
+  CRRemoteCtrlRejected rcId -> ["remote controller " <> sShow rcId <> " rejected"]
+  CRRemoteCtrlConnecting rcId rcName -> ["remote controller " <> sShow rcId <> " connecting to " <> plain rcName]
+  CRRemoteCtrlConnected rcId rcName -> ["remote controller " <> sShow rcId <> " connected, " <> plain rcName]
+  CRRemoteCtrlStopped rcId -> ["remote controller " <> sShow rcId <> " stopped"]
+  CRRemoteCtrlDeleted rcId -> ["remote controller " <> sShow rcId <> " deleted"]
  CRSQLResult rows -> map plain rows
  CRSlowSQLQueries {chatQueries, agentQueries} ->
    let viewQuery SlowSQLQuery {query, queryStats = SlowQueryStats {count, timeMax, timeAvg}} =
@ -298,7 +316,6 @@ responseToView user_ ChatConfig {logLevel, showReactions, showReceipts, testView
  CRChatError u e -> ttyUser' u $ viewChatError logLevel e
  CRArchiveImported archiveErrs -> if null archiveErrs then ["ok"] else ["archive import errors: " <> plain (show archiveErrs)]
  CRTimedAction _ _ -> []
-  todo'cr -> ["TODO" <> sShow todo'cr]
  where
    ttyUser :: User -> [StyledString] -> [StyledString]
    ttyUser user@User {showNtfs, activeUser} ss
@ -1539,6 +1556,31 @@ viewVersionInfo logLevel CoreVersionInfo {version, simplexmqVersion, simplexmqCo
  where
    parens s = " (" <> s <> ")"

+viewRemoteCtrlOOBData :: RemoteCtrlOOB -> [StyledString]
+viewRemoteCtrlOOBData RemoteCtrlOOB {caFingerprint} =
+  ["connection code:", plain $ strEncode caFingerprint]
+
+viewRemoteHosts :: [RemoteHostInfo] -> [StyledString]
+viewRemoteHosts = \case
+  [] -> ["No remote hosts"]
+  hs -> "Remote hosts: " : map viewRemoteHostInfo hs
+  where
+    viewRemoteHostInfo RemoteHostInfo {remoteHostId, displayName, sessionActive} =
+      plain $ tshow remoteHostId <> ". " <> displayName <> if sessionActive then " (active)" else ""
+
+viewRemoteCtrls :: [RemoteCtrlInfo] -> [StyledString]
+viewRemoteCtrls = \case
+  [] -> ["No remote controllers"]
+  hs -> "Remote controllers: " : map viewRemoteCtrlInfo hs
+  where
+    viewRemoteCtrlInfo RemoteCtrlInfo {remoteCtrlId, displayName, sessionActive} =
+      plain $ tshow remoteCtrlId <> ". " <> displayName <> if sessionActive then " (active)" else ""
+
+-- TODO fingerprint, accepted?
+viewRemoteCtrl :: RemoteCtrl -> StyledString
+viewRemoteCtrl RemoteCtrl {remoteCtrlId, displayName} =
+  plain $ tshow remoteCtrlId <> ". " <> displayName
+
 viewChatError :: ChatLogLevel -> ChatError -> [StyledString]
 viewChatError logLevel = \case
  ChatError err -> case err of
--- a/tests/RemoteTests.hs
+++ b/tests/RemoteTests.hs
@ -0,0 +1,148 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module RemoteTests where
+
+import ChatClient
+import ChatTests.Utils
+import Control.Monad
+import Data.List.NonEmpty (NonEmpty (..))
+import Debug.Trace
+import Network.HTTP.Types (ok200)
+import qualified Network.HTTP2.Client as C
+import qualified Network.HTTP2.Server as S
+import qualified Network.Socket as N
+import qualified Network.TLS as TLS
+import qualified Simplex.Chat.Remote.Discovery as Discovery
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Encoding.String
+import qualified Simplex.Messaging.Transport as Transport
+import Simplex.Messaging.Transport.Client (TransportHost (..))
+import Simplex.Messaging.Transport.Credentials (genCredentials, tlsCredentials)
+import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Response (..), closeHTTP2Client, sendRequest)
+import Simplex.Messaging.Transport.HTTP2.Server (HTTP2Request (..))
+import Test.Hspec
+import UnliftIO
+
+remoteTests :: SpecWith FilePath
+remoteTests = describe "Handshake" $ do
+  it "generates usable credentials" genCredentialsTest
+  it "connects announcer with discoverer over reverse-http2" announceDiscoverHttp2Test
+  it "connects desktop and mobile" remoteHandshakeTest
+
+-- * Low-level TLS with ephemeral credentials
+
+genCredentialsTest :: (HasCallStack) => FilePath -> IO ()
+genCredentialsTest _tmp = do
+  (fingerprint, credentials) <- genTestCredentials
+  started <- newEmptyTMVarIO
+  server <- Discovery.startTLSServer started credentials serverHandler
+  ok <- atomically (readTMVar started)
+  unless ok $ cancel server >> error "TLS server failed to start"
+  Discovery.connectTLSClient "127.0.0.1" fingerprint clientHandler
+  cancel server
+  where
+    serverHandler serverTls = do
+      traceM "    - Sending from server"
+      Transport.putLn serverTls "hi client"
+      traceM "    - Reading from server"
+      Transport.getLn serverTls `shouldReturn` "hi server"
+    clientHandler clientTls = do
+      traceM "    - Sending from client"
+      Transport.putLn clientTls "hi server"
+      traceM "    - Reading from client"
+      Transport.getLn clientTls `shouldReturn` "hi client"
+
+-- * UDP discovery and rever HTTP2
+
+announceDiscoverHttp2Test :: (HasCallStack) => FilePath -> IO ()
+announceDiscoverHttp2Test _tmp = do
+  (fingerprint, credentials) <- genTestCredentials
+  finished <- newEmptyMVar
+  announcer <- async $ do
+    traceM "    - Controller: starting"
+    http <- Discovery.announceRevHTTP2 (putMVar finished ()) fingerprint credentials >>= either (fail . show) pure
+    traceM "    - Controller: got client"
+    sendRequest http (C.requestNoBody "GET" "/" []) (Just 10000000) >>= \case
+      Left err -> do
+        traceM "    - Controller: got error"
+        fail $ show err
+      Right HTTP2Response {} ->
+        traceM "    - Controller: got response"
+    closeHTTP2Client http
+  dis <- async $ do
+    sock <- Discovery.openListener
+    (N.SockAddrInet _port addr, invite) <- Discovery.recvAnnounce sock
+    strDecode invite `shouldBe` Right fingerprint
+    traceM "    - Host: connecting"
+    server <- async $ Discovery.connectTLSClient (THIPv4 $ N.hostAddressToTuple addr) fingerprint $ \tls -> do
+      traceM "    - Host: got tls"
+      flip Discovery.attachHTTP2Server tls $ \HTTP2Request {sendResponse} -> do
+        traceM "    - Host: got request"
+        sendResponse $ S.responseNoBody ok200 []
+        traceM "    - Host: sent response"
+    takeMVar finished
+    cancel server
+    traceM "    - Host: finished"
+  waitBoth dis announcer `shouldReturn` ((), ())
+
+-- * Chat commands
+
+remoteHandshakeTest :: HasCallStack => FilePath -> IO ()
+remoteHandshakeTest = testChat2 aliceProfile bobProfile $ \desktop mobile -> do
+  desktop ##> "/list remote hosts"
+  desktop <## "No remote hosts"
+  desktop ##> "/create remote host"
+  desktop <## "remote host 1 created"
+  desktop <## "connection code:"
+  fingerprint <- getTermLine desktop
+
+  desktop ##> "/list remote hosts"
+  desktop <## "Remote hosts:"
+  desktop <## "1. TODO" -- TODO host name probably should be Maybe, as when host is created there is no name yet
+
+  desktop ##> "/start remote host 1"
+  desktop <## "remote host 1 started"
+
+  mobile ##> "/start remote ctrl"
+  mobile <## "remote controller started"
+  mobile <## "remote controller announced"
+  mobile <## "connection code:"
+  fingerprint' <- getTermLine mobile
+  fingerprint' `shouldBe` fingerprint
+  mobile ##> "/list remote ctrls"
+  mobile <## "No remote controllers"
+  mobile ##> ("/register remote ctrl " <> fingerprint')
+  mobile <## "remote controller 1 registered"
+  mobile ##> "/list remote ctrls"
+  mobile <## "Remote controllers:"
+  mobile <## "1. TODO"
+  mobile ##> "/accept remote ctrl 1"
+  mobile <## "remote controller 1 accepted" -- alternative scenario: accepted before controller start
+  mobile <## "remote controller 1 connecting to TODO"
+  mobile <## "remote controller 1 connected, TODO"
+  mobile ##> "/stop remote ctrl 1"
+  mobile <## "ok"
+  mobile <## "remote controller 1 stopped" -- TODO two outputs
+  mobile ##> "/delete remote ctrl 1"
+  mobile <## "remote controller 1 deleted"
+  mobile ##> "/list remote ctrls"
+  mobile <## "No remote controllers"
+
+  desktop ##> "/stop remote host 1"
+  desktop <## "remote host 1 stopped"
+  desktop ##> "/delete remote host 1"
+  desktop <## "remote host 1 deleted"
+  desktop ##> "/list remote hosts"
+  desktop <## "No remote hosts"
+
+-- * Utils
+
+genTestCredentials :: IO (C.KeyHash, TLS.Credentials)
+genTestCredentials = do
+  caCreds <- liftIO $ genCredentials Nothing (0, 24) "CA"
+  sessionCreds <- liftIO $ genCredentials (Just caCreds) (0, 24) "Session"
+  pure . tlsCredentials $ sessionCreds :| [caCreds]
--- a/tests/Test.hs
+++ b/tests/Test.hs
@ -8,6 +8,7 @@ import Data.Time.Clock.System
 import MarkdownTests
 import MobileTests
 import ProtocolTests
+import RemoteTests
 import SchemaDump
 import Test.Hspec
 import UnliftIO.Temporary (withTempDirectory)
@ -28,6 +29,7 @@ main = do
      describe "SimpleX chat client" chatTests
      xdescribe'' "SimpleX Broadcast bot" broadcastBotTests
      xdescribe'' "SimpleX Directory service bot" directoryServiceTests
+      describe "Remote session" remoteTests
  where
    testBracket test = do
      t <- getSystemTime