core: remote host/controller types (#3104)

* Start sprinkling ZoneId everywhere

* Draft zone/satellite/host api

* Add zone dispatching

* Add command relaying handler

* Parse commands and begin DB

* Implement discussed things

* Resolve some comments

* Resolve more stuff

* Make bots ignore remoteHostId from queues

* Fix tests and stub more

* Untangle cmd relaying

* Resolve comments

* Add more http2 client funs

* refactor, rename

* rename

* remove empty tests

---------

Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>

apps/simplex-bot-advanced/Main.hs

@@ -41,7 +41,7 @@ mySquaringBot :: User -> ChatController -> IO ()
 mySquaringBot _user cc = do
   initializeBotAddress cc
   race_ (forever $ void getLine) . forever $ do
-    (_, resp) <- atomically . readTBQueue $ outputQ cc
+    (_, _, resp) <- atomically . readTBQueue $ outputQ cc
     case resp of
       CRContactConnected _ contact _ -> do
         contactConnected contact

apps/simplex-broadcast-bot/src/Broadcast/Bot.hs

@@ -35,7 +35,7 @@ broadcastBot :: BroadcastBotOpts -> User -> ChatController -> IO ()
 broadcastBot BroadcastBotOpts {publishers, welcomeMessage, prohibitedMessage} _user cc = do
   initializeBotAddress cc
   race_ (forever $ void getLine) . forever $ do
-    (_, resp) <- atomically . readTBQueue $ outputQ cc
+    (_, _, resp) <- atomically . readTBQueue $ outputQ cc
     case resp of
       CRContactConnected _ ct _ -> do
         contactConnected ct

apps/simplex-chat/Server.hs

@@ -84,7 +84,7 @@ runChatServer ChatServerConfig {chatPort, clientQSize} cc = do
         >>= processCommand
         >>= atomically . writeTBQueue sndQ
     output ChatClient {sndQ} = forever $ do
-      (_, resp) <- atomically . readTBQueue $ outputQ cc
+      (_, _, resp) <- atomically . readTBQueue $ outputQ cc
       atomically $ writeTBQueue sndQ ChatSrvResponse {corrId = Nothing, resp}
     receive ws ChatClient {rcvQ, sndQ} = forever $ do
       s <- WS.receiveData ws

apps/simplex-directory-service/src/Directory/Service.hs

@@ -59,7 +59,7 @@ welcomeGetOpts :: IO DirectoryOpts
 welcomeGetOpts = do
   appDir <- getAppUserDataDirectory "simplex"
   opts@DirectoryOpts {coreOptions = CoreChatOpts {dbFilePrefix}, testing} <- getDirectoryOpts appDir "simplex_directory_service"
-  unless testing $ do  
+  unless testing $ do
     putStrLn $ "SimpleX Directory Service Bot v" ++ versionNumber
     putStrLn $ "db: " <> dbFilePrefix <> "_chat.db, " <> dbFilePrefix <> "_agent.db"
   pure opts
@@ -68,7 +68,7 @@ directoryService :: DirectoryStore -> DirectoryOpts -> User -> ChatController ->
 directoryService st DirectoryOpts {superUsers, serviceName, testing} user@User {userId} cc = do
   initializeBotAddress' (not testing) cc
   race_ (forever $ void getLine) . forever $ do
-    (_, resp) <- atomically . readTBQueue $ outputQ cc
+    (_, _, resp) <- atomically . readTBQueue $ outputQ cc
     forM_ (crDirectoryEvent resp) $ \case
       DEContactConnected ct -> deContactConnected ct
       DEGroupInvitation {contact = ct, groupInfo = g, fromMemberRole, memberRole} -> deGroupInvitation ct g fromMemberRole memberRole
@@ -161,7 +161,7 @@ directoryService st DirectoryOpts {superUsers, serviceName, testing} user@User {
     badRolesMsg :: GroupRolesStatus -> Maybe String
     badRolesMsg = \case
       GRSOk -> Nothing
-      GRSServiceNotAdmin -> Just "You must have a group *owner* role to register the group" 
+      GRSServiceNotAdmin -> Just "You must have a group *owner* role to register the group"
       GRSContactNotOwner -> Just "You must grant directory service *admin* role to register the group"
       GRSBadRoles -> Just "You must have a group *owner* role and you must grant directory service *admin* role to register the group"
 
@@ -352,7 +352,7 @@ directoryService st DirectoryOpts {superUsers, serviceName, testing} user@User {
         groupRef = groupReference g
         srvRole = "*" <> B.unpack (strEncode serviceRole) <> "*"
         suSrvRole = "(" <> serviceName <> " role is changed to " <> srvRole <> ")."
-        whenContactIsOwner gr action = 
+        whenContactIsOwner gr action =
           getGroupMember gr >>=
             mapM_ (\cm@GroupMember {memberRole} -> when (memberRole == GROwner && memberActive cm) action)
 

package.yaml

@@ -19,6 +19,7 @@ dependencies:
   - attoparsec == 0.14.*
   - base >= 4.7 && < 5
   - base64-bytestring >= 1.0 && < 1.3
+  - binary >= 0.8 && < 0.9
   - bytestring == 0.11.*
   - composition == 1.0.*
   - constraints >= 0.12 && < 0.14
@@ -30,6 +31,7 @@ dependencies:
   - exceptions == 0.10.*
   - filepath == 1.4.*
   - http-types == 0.12.*
+  - http2
   - memory == 0.18.*
   - mtl == 2.3.*
   - network >= 3.1.2.7 && < 3.2

simplex-chat.cabal

@@ -113,6 +113,7 @@ library
       Simplex.Chat.Migrations.M20230903_connections_to_subscribe
       Simplex.Chat.Migrations.M20230913_member_contacts
       Simplex.Chat.Migrations.M20230914_member_probes
+      Simplex.Chat.Migrations.M20230922_remote_controller
       Simplex.Chat.Mobile
       Simplex.Chat.Mobile.File
       Simplex.Chat.Mobile.Shared
@@ -120,6 +121,8 @@ library
       Simplex.Chat.Options
       Simplex.Chat.ProfileGenerator
       Simplex.Chat.Protocol
+      Simplex.Chat.Remote
+      Simplex.Chat.Remote.Types
       Simplex.Chat.Store
       Simplex.Chat.Store.Connections
       Simplex.Chat.Store.Direct
@@ -128,6 +131,7 @@ library
       Simplex.Chat.Store.Messages
       Simplex.Chat.Store.Migrations
       Simplex.Chat.Store.Profiles
+      Simplex.Chat.Store.Remote
       Simplex.Chat.Store.Shared
       Simplex.Chat.Styled
       Simplex.Chat.Terminal
@@ -151,6 +155,7 @@ library
     , attoparsec ==0.14.*
     , base >=4.7 && <5
     , base64-bytestring >=1.0 && <1.3
+    , binary ==0.8.*
     , bytestring ==0.11.*
     , composition ==1.0.*
     , constraints >=0.12 && <0.14
@@ -162,6 +167,7 @@ library
     , exceptions ==0.10.*
     , filepath ==1.4.*
     , http-types ==0.12.*
+    , http2
     , memory ==0.18.*
     , mtl ==2.3.*
     , network >=3.1.2.7 && <3.2
@@ -199,6 +205,7 @@ executable simplex-bot
     , attoparsec ==0.14.*
     , base >=4.7 && <5
     , base64-bytestring >=1.0 && <1.3
+    , binary ==0.8.*
     , bytestring ==0.11.*
     , composition ==1.0.*
     , constraints >=0.12 && <0.14
@@ -210,6 +217,7 @@ executable simplex-bot
     , exceptions ==0.10.*
     , filepath ==1.4.*
     , http-types ==0.12.*
+    , http2
     , memory ==0.18.*
     , mtl ==2.3.*
     , network >=3.1.2.7 && <3.2
@@ -248,6 +256,7 @@ executable simplex-bot-advanced
     , attoparsec ==0.14.*
     , base >=4.7 && <5
     , base64-bytestring >=1.0 && <1.3
+    , binary ==0.8.*
     , bytestring ==0.11.*
     , composition ==1.0.*
     , constraints >=0.12 && <0.14
@@ -259,6 +268,7 @@ executable simplex-bot-advanced
     , exceptions ==0.10.*
     , filepath ==1.4.*
     , http-types ==0.12.*
+    , http2
     , memory ==0.18.*
     , mtl ==2.3.*
     , network >=3.1.2.7 && <3.2
@@ -299,6 +309,7 @@ executable simplex-broadcast-bot
     , attoparsec ==0.14.*
     , base >=4.7 && <5
     , base64-bytestring >=1.0 && <1.3
+    , binary ==0.8.*
     , bytestring ==0.11.*
     , composition ==1.0.*
     , constraints >=0.12 && <0.14
@@ -310,6 +321,7 @@ executable simplex-broadcast-bot
     , exceptions ==0.10.*
     , filepath ==1.4.*
     , http-types ==0.12.*
+    , http2
     , memory ==0.18.*
     , mtl ==2.3.*
     , network >=3.1.2.7 && <3.2
@@ -349,6 +361,7 @@ executable simplex-chat
     , attoparsec ==0.14.*
     , base >=4.7 && <5
     , base64-bytestring >=1.0 && <1.3
+    , binary ==0.8.*
     , bytestring ==0.11.*
     , composition ==1.0.*
     , constraints >=0.12 && <0.14
@@ -360,6 +373,7 @@ executable simplex-chat
     , exceptions ==0.10.*
     , filepath ==1.4.*
     , http-types ==0.12.*
+    , http2
     , memory ==0.18.*
     , mtl ==2.3.*
     , network ==3.1.*
@@ -403,6 +417,7 @@ executable simplex-directory-service
     , attoparsec ==0.14.*
     , base >=4.7 && <5
     , base64-bytestring >=1.0 && <1.3
+    , binary ==0.8.*
     , bytestring ==0.11.*
     , composition ==1.0.*
     , constraints >=0.12 && <0.14
@@ -414,6 +429,7 @@ executable simplex-directory-service
     , exceptions ==0.10.*
     , filepath ==1.4.*
     , http-types ==0.12.*
+    , http2
     , memory ==0.18.*
     , mtl ==2.3.*
     , network >=3.1.2.7 && <3.2
@@ -476,6 +492,7 @@ test-suite simplex-chat-test
     , attoparsec ==0.14.*
     , base >=4.7 && <5
     , base64-bytestring >=1.0 && <1.3
+    , binary ==0.8.*
     , bytestring ==0.11.*
     , composition ==1.0.*
     , constraints >=0.12 && <0.14
@@ -489,6 +506,7 @@ test-suite simplex-chat-test
     , filepath ==1.4.*
     , hspec ==2.11.*
     , http-types ==0.12.*
+    , http2
     , memory ==0.18.*
     , mtl ==2.3.*
     , network ==3.1.*

src/Simplex/Chat.hs

@@ -62,6 +62,8 @@ import Simplex.Chat.Messages.CIContent
 import Simplex.Chat.Options
 import Simplex.Chat.ProfileGenerator (generateRandomProfile)
 import Simplex.Chat.Protocol
+import Simplex.Chat.Remote
+import Simplex.Chat.Remote.Types
 import Simplex.Chat.Store
 import Simplex.Chat.Store.Connections
 import Simplex.Chat.Store.Direct
@@ -204,6 +206,8 @@ newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agen
   sndFiles <- newTVarIO M.empty
   rcvFiles <- newTVarIO M.empty
   currentCalls <- atomically TM.empty
+  remoteHostSessions <- atomically TM.empty
+  remoteCtrlSession <- newTVarIO Nothing
   filesFolder <- newTVarIO optFilesFolder
   chatStoreChanged <- newTVarIO False
   expireCIThreads <- newTVarIO M.empty
@@ -213,7 +217,7 @@ newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agen
   showLiveItems <- newTVarIO False
   userXFTPFileConfig <- newTVarIO $ xftpFileConfig cfg
   tempDirectory <- newTVarIO tempDir
-  pure ChatController {activeTo, firstTime, currentUser, smpAgent, agentAsync, chatStore, chatStoreChanged, idsDrg, inputQ, outputQ, notifyQ, subscriptionMode, chatLock, sndFiles, rcvFiles, currentCalls, config, sendNotification, filesFolder, expireCIThreads, expireCIFlags, cleanupManagerAsync, timedItemThreads, showLiveItems, userXFTPFileConfig, tempDirectory, logFilePath = logFile}
+  pure ChatController {activeTo, firstTime, currentUser, smpAgent, agentAsync, chatStore, chatStoreChanged, idsDrg, inputQ, outputQ, notifyQ, subscriptionMode, chatLock, sndFiles, rcvFiles, currentCalls, remoteHostSessions, remoteCtrlSession, config, sendNotification, filesFolder, expireCIThreads, expireCIFlags, cleanupManagerAsync, timedItemThreads, showLiveItems, userXFTPFileConfig, tempDirectory, logFilePath = logFile}
   where
     configServers :: DefaultAgentServers
     configServers =
@@ -340,12 +344,14 @@ stopChatController ChatController {smpAgent, agentAsync = s, sndFiles, rcvFiles,
       mapM_ hClose fs
       atomically $ writeTVar files M.empty
 
-execChatCommand :: ChatMonad' m => ByteString -> m ChatResponse
+execChatCommand :: ChatMonad' m => Maybe RemoteHostId -> ByteString -> m ChatResponse
-execChatCommand s = do
+execChatCommand rh s = do
   u <- readTVarIO =<< asks currentUser
   case parseChatCommand s of
     Left e -> pure $ chatCmdError u e
-    Right cmd -> execChatCommand_ u cmd
+    Right cmd -> case rh of
+      Nothing -> execChatCommand_ u cmd
+      Just remoteHostId -> execRemoteCommand u remoteHostId (s, cmd)
 
 execChatCommand' :: ChatMonad' m => ChatCommand -> m ChatResponse
 execChatCommand' cmd = asks currentUser >>= readTVarIO >>= (`execChatCommand_` cmd)
@@ -353,14 +359,26 @@ execChatCommand' cmd = asks currentUser >>= readTVarIO >>= (`execChatCommand_` c
 execChatCommand_ :: ChatMonad' m => Maybe User -> ChatCommand -> m ChatResponse
 execChatCommand_ u cmd = either (CRChatCmdError u) id <$> runExceptT (processChatCommand cmd)
 
+execRemoteCommand :: ChatMonad' m => Maybe User -> RemoteHostId -> (ByteString, ChatCommand) -> m ChatResponse
+execRemoteCommand u rh scmd = either (CRChatCmdError u) id <$> runExceptT (withRemoteHostSession rh $ \rhs -> processRemoteCommand rhs scmd)
+
 parseChatCommand :: ByteString -> Either String ChatCommand
 parseChatCommand = A.parseOnly chatCommandP . B.dropWhileEnd isSpace
 
+-- | Emit local events.
 toView :: ChatMonad' m => ChatResponse -> m ()
-toView event = do
+toView = toView_ Nothing
-  q <- asks outputQ
-  atomically $ writeTBQueue q (Nothing, event)
 
+-- | Used by transport to mark remote events with source.
+toViewRemote :: ChatMonad' m => RemoteHostId -> ChatResponse -> m ()
+toViewRemote = toView_ . Just
+
+toView_ :: ChatMonad' m => Maybe RemoteHostId -> ChatResponse -> m ()
+toView_ rh event = do
+  q <- asks outputQ
+  atomically $ writeTBQueue q (Nothing, rh, event)
+
+-- | Chat API commands interpreted in context of a local zone
 processChatCommand :: forall m. ChatMonad m => ChatCommand -> m ChatResponse
 processChatCommand = \case
   ShowActiveUser -> withUser' $ pure . CRActiveUser
@@ -1830,6 +1848,24 @@ 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"
+  StartRemoteHost rh -> do
+    RemoteHost {displayName = _, storePath, caKey, caCert} <- error "TODO: get from DB"
+    (fingerprint, sessionCreds) <- error "TODO: derive session creds" (caKey, caCert)
+    _announcer <- async $ error "TODO: run announcer" fingerprint
+    hostAsync <- async $ error "TODO: runServer" storePath sessionCreds
+    chatModifyVar remoteHostSessions $ M.insert rh RemoteHostSession {hostAsync, storePath, ctrlClient = undefined}
+    pure $ chatCmdError Nothing "not supported"
+  StopRemoteHost _rh -> pure $ chatCmdError Nothing "not supported"
+  DisposeRemoteHost _rh -> pure $ chatCmdError Nothing "not supported"
+  RegisterRemoteCtrl _displayName _oobData -> pure $ chatCmdError Nothing "not supported"
+  ListRemoteCtrls -> pure $ chatCmdError Nothing "not supported"
+  StartRemoteCtrl -> pure $ chatCmdError Nothing "not supported"
+  ConfirmRemoteCtrl _rc -> pure $ chatCmdError Nothing "not supported"
+  RejectRemoteCtrl _rc -> pure $ chatCmdError Nothing "not supported"
+  StopRemoteCtrl _rc -> pure $ chatCmdError Nothing "not supported"
+  DisposeRemoteCtrl _rc -> pure $ chatCmdError Nothing "not supported"
   QuitChat -> liftIO exitSuccess
   ShowVersion -> do
     let versionInfo = coreVersionInfo $(simplexmqCommitQ)
@@ -5599,6 +5635,17 @@ 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),
+      "/list remote hosts" $> ListRemoteHosts,
+      "/start remote host " *> (StartRemoteHost <$> A.decimal),
+      "/stop remote host " *> (StopRemoteHost <$> A.decimal),
+      "/dispose remote host " *> (DisposeRemoteHost <$> A.decimal),
+      "/register remote ctrl " *> (RegisterRemoteCtrl <$> textP <*> remoteHostOOBP),
+      "/start remote ctrl" $> StartRemoteCtrl,
+      "/confirm remote ctrl " *> (ConfirmRemoteCtrl <$> A.decimal),
+      "/reject remote ctrl " *> (RejectRemoteCtrl <$> A.decimal),
+      "/stop remote ctrl " *> (StopRemoteCtrl <$> A.decimal),
+      "/dispose remote ctrl " *> (DisposeRemoteCtrl <$> A.decimal),
       ("/quit" <|> "/q" <|> "/exit") $> QuitChat,
       ("/version" <|> "/v") $> ShowVersion,
       "/debug locks" $> DebugLocks,
@@ -5716,6 +5763,7 @@ 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 =

src/Simplex/Chat/Bot.hs

@@ -25,7 +25,7 @@ chatBotRepl :: String -> (Contact -> String -> IO String) -> User -> ChatControl
 chatBotRepl welcome answer _user cc = do
   initializeBotAddress cc
   race_ (forever $ void getLine) . forever $ do
-    (_, resp) <- atomically . readTBQueue $ outputQ cc
+    (_, _, resp) <- atomically . readTBQueue $ outputQ cc
     case resp of
       CRContactConnected _ contact _ -> do
         contactConnected contact

src/Simplex/Chat/Controller.hs

@@ -46,6 +46,7 @@ import Simplex.Chat.Markdown (MarkdownList)
 import Simplex.Chat.Messages
 import Simplex.Chat.Messages.CIContent
 import Simplex.Chat.Protocol
+import Simplex.Chat.Remote.Types
 import Simplex.Chat.Store (AutoAccept, StoreError, UserContactLink, UserMsgReceiptSettings)
 import Simplex.Chat.Types
 import Simplex.Chat.Types.Preferences
@@ -173,7 +174,7 @@ data ChatController = ChatController
     chatStoreChanged :: TVar Bool, -- if True, chat should be fully restarted
     idsDrg :: TVar ChaChaDRG,
     inputQ :: TBQueue String,
-    outputQ :: TBQueue (Maybe CorrId, ChatResponse),
+    outputQ :: TBQueue (Maybe CorrId, Maybe RemoteHostId, ChatResponse),
     notifyQ :: TBQueue Notification,
     sendNotification :: Notification -> IO (),
     subscriptionMode :: TVar SubscriptionMode,
@@ -181,6 +182,8 @@ data ChatController = ChatController
     sndFiles :: TVar (Map Int64 Handle),
     rcvFiles :: TVar (Map Int64 Handle),
     currentCalls :: TMap ContactId Call,
+    remoteHostSessions :: TMap RemoteHostId RemoteHostSession, -- All the active remote hosts
+    remoteCtrlSession :: TVar (Maybe RemoteCtrlSession), -- Supervisor process for hosted controllers
     config :: ChatConfig,
     filesFolder :: TVar (Maybe FilePath), -- path to files folder for mobile apps,
     expireCIThreads :: TMap UserId (Maybe (Async ())),
@@ -410,6 +413,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
+  | 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
+  | StartRemoteCtrl -- ^ Start listening for announcements from all registered controllers
+  | ListRemoteCtrls
+  | ConfirmRemoteCtrl RemoteCtrlId -- ^ Confirm discovered data and store confirmation
+  | RejectRemoteCtrl RemoteCtrlId -- ^ Reject discovered data (and blacklist?)
+  | StopRemoteCtrl RemoteCtrlId -- ^ Stop listening for announcements or terminate an active session
+  | DisposeRemoteCtrl RemoteCtrlId -- ^ Remove all local data associated with a satellite session
   | QuitChat
   | ShowVersion
   | DebugLocks
@@ -580,6 +595,17 @@ 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}
+  | CRRemoteHostList {remoteHosts :: [RemoteHostInfo]} -- XXX: RemoteHostInfo is mostly concerned with session setup
+  | CRRemoteHostStarted {remoteHostId :: RemoteHostId}
+  | CRRemoteHostStopped {remoteHostId :: RemoteHostId}
+  | CRRemoteHostDisposed {remoteHostId :: RemoteHostId}
+  | CRRemoteCtrlList {remoteCtrls :: [RemoteCtrlInfo]}
+  | CRRemoteCtrlRegistered {remoteCtrlId :: RemoteCtrlId}
+  | CRRemoteCtrlAccepted {remoteCtrlId :: RemoteCtrlId}
+  | CRRemoteCtrlRejected {remoteCtrlId :: RemoteCtrlId}
+  | CRRemoteCtrlConnected {remoteCtrlId :: RemoteCtrlId}
+  | CRRemoteCtrlDisconnected {remoteCtrlId :: RemoteCtrlId}
   | CRSQLResult {rows :: [Text]}
   | CRSlowSQLQueries {chatQueries :: [SlowSQLQuery], agentQueries :: [SlowSQLQuery]}
   | CRDebugLocks {chatLockName :: Maybe String, agentLocks :: AgentLocks}
@@ -616,10 +642,32 @@ logResponseToFile = \case
   CRMessageError {} -> True
   _ -> False
 
+instance FromJSON ChatResponse where
+  parseJSON todo = pure $ CRCmdOk Nothing -- TODO: actually use the instances
+
 instance ToJSON ChatResponse where
   toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "CR"
   toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "CR"
 
+data RemoteHostOOB = RemoteHostOOB
+  { fingerprint :: Text -- CA key fingerprint
+  }
+  deriving (Show, Generic, ToJSON)
+
+data RemoteHostInfo = RemoteHostInfo
+  { remoteHostId :: RemoteHostId,
+    displayName :: Text,
+    sessionActive :: Bool
+  }
+  deriving (Show, Generic, ToJSON)
+
+data RemoteCtrlInfo = RemoteCtrlInfo
+  { remoteCtrlId :: RemoteCtrlId,
+    displayName :: Text,
+    sessionActive :: Bool
+  }
+  deriving (Show, Generic, ToJSON)
+
 newtype UserPwd = UserPwd {unUserPwd :: Text}
   deriving (Eq, Show)
 
@@ -858,6 +906,8 @@ data ChatError
   | ChatErrorAgent {agentError :: AgentErrorType, connectionEntity_ :: Maybe ConnectionEntity}
   | ChatErrorStore {storeError :: StoreError}
   | ChatErrorDatabase {databaseError :: DatabaseError}
+  | ChatErrorRemoteCtrl {remoteCtrlId :: RemoteCtrlId, remoteControllerError :: RemoteCtrlError}
+  | ChatErrorRemoteHost {remoteHostId :: RemoteHostId, remoteHostError :: RemoteHostError}
   deriving (Show, Exception, Generic)
 
 instance ToJSON ChatError where
@@ -967,6 +1017,41 @@ instance ToJSON SQLiteError where
 throwDBError :: ChatMonad m => DatabaseError -> m ()
 throwDBError = throwError . ChatErrorDatabase
 
+-- TODO review errors, some of it can be covered by HTTP2 errors
+data RemoteHostError
+  = RHMissing -- ^ No remote session matches this identifier
+  | RHBusy -- ^ A session is already running
+  | RHRejected -- ^ A session attempt was rejected by a host
+  | RHTimeout -- ^ A discovery or a remote operation has timed out
+  | RHDisconnected {reason :: Text} -- ^ A session disconnected by a host
+  | RHConnectionLost {reason :: Text} -- ^ A session disconnected due to transport issues
+  deriving (Show, Exception, Generic)
+
+instance FromJSON RemoteHostError where
+  parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "RH"
+
+instance ToJSON RemoteHostError where
+  toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "RH"
+  toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "RH"
+
+-- TODO review errors, some of it can be covered by HTTP2 errors
+data RemoteCtrlError
+  = RCEMissing -- ^ No remote session matches this identifier
+  | RCEBusy -- ^ A session is already running
+  | RCETimeout -- ^ Remote operation timed out
+  | RCEDisconnected {reason :: Text} -- ^ A session disconnected by a controller
+  | RCEConnectionLost {reason :: Text} -- ^ A session disconnected due to transport issues
+  | RCECertificateExpired -- ^ A connection or CA certificate in a chain have bad validity period
+  | RCECertificateUntrusted -- ^ TLS is unable to validate certificate chain presented for a connection
+  deriving (Show, Exception, Generic)
+
+instance FromJSON RemoteCtrlError where
+  parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "RCE"
+
+instance ToJSON RemoteCtrlError where
+  toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "RCE"
+  toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "RCE"
+
 type ChatMonad' m = (MonadUnliftIO m, MonadReader ChatController m)
 
 type ChatMonad m = (ChatMonad' m, MonadError ChatError m)
@@ -979,6 +1064,10 @@ chatWriteVar :: ChatMonad' m => (ChatController -> TVar a) -> a -> m ()
 chatWriteVar f value = asks f >>= atomically . (`writeTVar` value)
 {-# INLINE chatWriteVar #-}
 
+chatModifyVar :: ChatMonad' m => (ChatController -> TVar a) -> (a -> a) -> m ()
+chatModifyVar f newValue = asks f >>= atomically . (`modifyTVar'` newValue)
+{-# INLINE chatModifyVar #-}
+
 tryChatError :: ChatMonad m => m a -> m (Either ChatError a)
 tryChatError = tryAllErrors mkChatError
 {-# INLINE tryChatError #-}

src/Simplex/Chat/Core.hs

@@ -40,7 +40,7 @@ runSimplexChat ChatOpts {maintenance} u cc chat
     waitEither_ a1 a2
 
 sendChatCmdStr :: ChatController -> String -> IO ChatResponse
-sendChatCmdStr cc s = runReaderT (execChatCommand . encodeUtf8 $ T.pack s) cc
+sendChatCmdStr cc s = runReaderT (execChatCommand Nothing . encodeUtf8 $ T.pack s) cc
 
 sendChatCmd :: ChatController -> ChatCommand -> IO ChatResponse
 sendChatCmd cc cmd = runReaderT (execChatCommand' cmd) cc

src/Simplex/Chat/Migrations/M20230922_remote_controller.hs

@@ -0,0 +1,31 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Chat.Migrations.M20230922_remote_controller where
+
+import Database.SQLite.Simple (Query)
+import Database.SQLite.Simple.QQ (sql)
+
+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
+);
+
+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
+);
+|]
+
+down_m20230922_remote_controller :: Query
+down_m20230922_remote_controller =
+  [sql|
+DROP TABLE remote_hosts;
+DROP TABLE remote_controllers;
+|]

src/Simplex/Chat/Migrations/chat_schema.sql

@@ -515,6 +515,20 @@ CREATE TABLE IF NOT EXISTS "received_probes"(
   created_at TEXT CHECK(created_at NOT NULL),
   updated_at TEXT CHECK(updated_at NOT NULL)
 );
+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
+);
+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
+);
 CREATE INDEX contact_profiles_index ON contact_profiles(
   display_name,
   full_name

src/Simplex/Chat/Mobile.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fobject-code #-}
 
 module Simplex.Chat.Mobile where
 
@@ -37,6 +38,7 @@ import Simplex.Chat.Mobile.File
 import Simplex.Chat.Mobile.Shared
 import Simplex.Chat.Mobile.WebRTC
 import Simplex.Chat.Options
+import Simplex.Chat.Remote.Types
 import Simplex.Chat.Store
 import Simplex.Chat.Store.Profiles
 import Simplex.Chat.Types
@@ -55,6 +57,8 @@ foreign export ccall "chat_migrate_init" cChatMigrateInit :: CString -> CString
 
 foreign export ccall "chat_send_cmd" cChatSendCmd :: StablePtr ChatController -> CString -> IO CJSONString
 
+foreign export ccall "chat_send_remote_cmd" cChatSendRemoteCmd :: StablePtr ChatController -> CInt -> CString -> IO CJSONString
+
 foreign export ccall "chat_recv_msg" cChatRecvMsg :: StablePtr ChatController -> IO CJSONString
 
 foreign export ccall "chat_recv_msg_wait" cChatRecvMsgWait :: StablePtr ChatController -> CInt -> IO CJSONString
@@ -102,6 +106,14 @@ cChatSendCmd cPtr cCmd = do
   cmd <- B.packCString cCmd
   newCStringFromLazyBS =<< chatSendCmd c cmd
 
+-- | send command to chat (same syntax as in terminal for now)
+cChatSendRemoteCmd :: StablePtr ChatController -> CInt -> CString -> IO CJSONString
+cChatSendRemoteCmd cPtr cRemoteHostId cCmd = do
+  c <- deRefStablePtr cPtr
+  cmd <- B.packCString cCmd
+  let rhId = Just $ fromIntegral cRemoteHostId
+  newCStringFromLazyBS =<< chatSendRemoteCmd c rhId cmd
+
 -- | receive message from chat (blocking)
 cChatRecvMsg :: StablePtr ChatController -> IO CJSONString
 cChatRecvMsg cc = deRefStablePtr cc >>= chatRecvMsg >>= newCStringFromLazyBS
@@ -195,13 +207,16 @@ chatMigrateInit dbFilePrefix dbKey confirm = runExceptT $ do
           _ -> dbError e
         dbError e = Left . DBMErrorSQL dbFile $ show e
 
-chatSendCmd :: ChatController -> ByteString -> IO JSONByteString
+chatSendCmd :: ChatController -> B.ByteString -> IO JSONByteString
-chatSendCmd cc s = J.encode . APIResponse Nothing <$> runReaderT (execChatCommand s) cc
+chatSendCmd cc = chatSendRemoteCmd cc Nothing
+
+chatSendRemoteCmd :: ChatController -> Maybe RemoteHostId -> B.ByteString -> IO JSONByteString
+chatSendRemoteCmd cc rh s = J.encode . APIResponse Nothing rh <$> runReaderT (execChatCommand rh s) cc
 
 chatRecvMsg :: ChatController -> IO JSONByteString
 chatRecvMsg ChatController {outputQ} = json <$> atomically (readTBQueue outputQ)
   where
-    json (corr, resp) = J.encode APIResponse {corr, resp}
+    json (corr, remoteHostId, resp) = J.encode APIResponse {corr, remoteHostId, resp}
 
 chatRecvMsgWait :: ChatController -> Int -> IO JSONByteString
 chatRecvMsgWait cc time = fromMaybe "" <$> timeout time (chatRecvMsg cc)
@@ -227,7 +242,7 @@ chatPasswordHash pwd salt = either (const "") passwordHash salt'
     salt' = U.decode salt
     passwordHash = U.encode . C.sha512Hash . (pwd <>)
 
-data APIResponse = APIResponse {corr :: Maybe CorrId, resp :: ChatResponse}
+data APIResponse = APIResponse {corr :: Maybe CorrId, remoteHostId :: Maybe RemoteHostId, resp :: ChatResponse}
   deriving (Generic)
 
 instance ToJSON APIResponse where

src/Simplex/Chat/Remote.hs

@@ -0,0 +1,92 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Simplex.Chat.Remote where
+
+import Control.Monad.Except
+import Control.Monad.IO.Class
+import qualified Data.Aeson as J
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.Map.Strict as M
+import qualified Data.Binary.Builder as Binary
+import qualified Network.HTTP.Types as HTTP
+import qualified Network.HTTP2.Client as HTTP2Client
+import Simplex.Chat.Controller
+import Simplex.Chat.Remote.Types
+import Simplex.Chat.Types
+import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..))
+import qualified Simplex.Messaging.Transport.HTTP2.Client as HTTP2
+import Simplex.Messaging.Util	(bshow)
+import System.Directory (getFileSize)
+
+withRemoteHostSession :: ChatMonad m => RemoteHostId -> (RemoteHostSession -> m a) -> m a
+withRemoteHostSession remoteHostId action = do
+  chatReadVar remoteHostSessions >>= maybe err action . M.lookup remoteHostId
+  where
+    err = throwError $ ChatErrorRemoteHost remoteHostId RHMissing
+
+processRemoteCommand :: ChatMonad m => RemoteHostSession -> (ByteString, ChatCommand) -> m ChatResponse
+processRemoteCommand rhs = \case
+  -- XXX: intercept and filter some commands
+  -- TODO: store missing files on remote host
+  (s, _cmd) -> relayCommand rhs s
+
+relayCommand :: ChatMonad m => RemoteHostSession -> ByteString -> m ChatResponse
+relayCommand RemoteHostSession {ctrlClient} s = postBytestring Nothing ctrlClient "/relay" mempty s >>= \case
+  Left e -> error "TODO: http2chatError"
+  Right HTTP2.HTTP2Response {respBody = HTTP2Body {bodyHead}} -> do
+    remoteChatResponse <-
+      if iTax then
+        case J.eitherDecodeStrict bodyHead of -- XXX: large JSONs can overflow into buffered chunks
+          Left e -> error "TODO: json2chatError" e
+          Right (raw :: J.Value) -> case J.fromJSON (sum2tagged raw) of
+            J.Error e -> error "TODO: json2chatError" e
+            J.Success cr -> pure cr
+      else
+        case J.eitherDecodeStrict bodyHead of -- XXX: large JSONs can overflow into buffered chunks
+          Left e -> error "TODO: json2chatError" e
+          Right cr -> pure cr
+    case remoteChatResponse of
+      -- TODO: intercept file responses and fetch files when needed
+      -- XXX: is that even possible, to have a file response to a command?
+      _ -> pure remoteChatResponse
+  where
+    iTax = True -- TODO: get from RemoteHost
+    -- XXX: extract to http2 transport
+    postBytestring timeout c path hs body = liftIO $ HTTP2.sendRequest c req timeout
+      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
+    Left e -> error "TODO: http2chatError"
+    Right HTTP2.HTTP2Response { response } -> case HTTP.statusCode <$> HTTP2Client.responseStatus response of
+      Just 200 -> pure $ CRCmdOk Nothing
+      unexpected -> error "TODO: http2chatError"
+  where
+    postFile timeout c path hs file = liftIO $ do
+      fileSize <- fromIntegral <$> getFileSize file
+      HTTP2.sendRequest c (req fileSize) timeout
+      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
+    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?
+  where
+    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

src/Simplex/Chat/Remote/Types.hs

@@ -0,0 +1,46 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+
+module Simplex.Chat.Remote.Types where
+
+import Control.Concurrent.Async (Async)
+import Data.ByteString.Char8 (ByteString)
+import Data.Int (Int64)
+import Data.Text (Text)
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client)
+
+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,
+    -- | Credentials signing key for root and session certs
+    caKey :: C.Key
+  }
+
+type RemoteCtrlId = Int
+
+data RemoteCtrl = RemoteCtrl
+  { remoteCtrlId :: RemoteCtrlId,
+    displayName :: Text,
+    fingerprint :: Text
+  }
+
+data RemoteHostSession = RemoteHostSession
+  { -- | process to communicate with the host
+    hostAsync :: Async (),
+    -- | Path for local resources to be synchronized with host
+    storePath :: FilePath,
+    ctrlClient :: HTTP2Client
+  }
+
+-- | Host-side dual to RemoteHostSession, on-methods represent HTTP API.
+data RemoteCtrlSession = RemoteCtrlSession
+  { -- | process to communicate with the remote controller
+    ctrlAsync :: Async ()
+    -- server :: HTTP2Server
+  }

src/Simplex/Chat/Store/Migrations.hs

@@ -81,6 +81,7 @@ import Simplex.Chat.Migrations.M20230829_connections_chat_vrange
 import Simplex.Chat.Migrations.M20230903_connections_to_subscribe
 import Simplex.Chat.Migrations.M20230913_member_contacts
 import Simplex.Chat.Migrations.M20230914_member_probes
+import Simplex.Chat.Migrations.M20230922_remote_controller
 import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..))
 
 schemaMigrations :: [(String, Query, Maybe Query)]
@@ -161,7 +162,8 @@ schemaMigrations =
     ("20230829_connections_chat_vrange", m20230829_connections_chat_vrange, Just down_m20230829_connections_chat_vrange),
     ("20230903_connections_to_subscribe", m20230903_connections_to_subscribe, Just down_m20230903_connections_to_subscribe),
     ("20230913_member_contacts", m20230913_member_contacts, Just down_m20230913_member_contacts),
-    ("20230914_member_probes", m20230914_member_probes, Just down_m20230914_member_probes)
+    ("20230914_member_probes", m20230914_member_probes, Just down_m20230914_member_probes),
+    ("20230922_remote_controller", m20230922_remote_controller, Just down_m20230922_remote_controller)
   ]
 
 -- | The list of migrations in ascending order by date

src/Simplex/Chat/Store/Remote.hs

@@ -0,0 +1,28 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+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 Simplex.Chat.Remote.Types (RemoteHostId, RemoteHost (..))
+import Simplex.Messaging.Agent.Store.SQLite (maybeFirstRow)
+import qualified Simplex.Messaging.Crypto as C
+
+getRemoteHosts :: DB.Connection -> IO [RemoteHost]
+getRemoteHosts db =
+  map toRemoteHost <$> DB.query_ db remoteHostQuery
+
+getRemoteHost :: DB.Connection -> RemoteHostId -> IO (Maybe RemoteHost)
+getRemoteHost db remoteHostId =
+  maybeFirstRow toRemoteHost $
+    DB.query db (remoteHostQuery <> "WHERE remote_host_id = ?") (DB.Only remoteHostId)
+
+remoteHostQuery :: DB.Query
+remoteHostQuery = "SELECT remote_host_id, display_name, store_path, ca_cert, ca_key FROM remote_hosts"
+
+toRemoteHost :: (Int64, Text, FilePath, ByteString, C.Key) -> RemoteHost
+toRemoteHost (remoteHostId, displayName, storePath, caCert, caKey) =
+  RemoteHost {remoteHostId, displayName, storePath, caCert, caKey}

src/Simplex/Chat/Terminal/Input.hs

@@ -56,7 +56,7 @@ runInputLoop ct@ChatTerminal {termState, liveMessageState} cc = forever $ do
   let bs = encodeUtf8 $ T.pack s
       cmd = parseChatCommand bs
   unless (isMessage cmd) $ echo s
-  r <- runReaderT (execChatCommand bs) cc
+  r <- runReaderT (execChatCommand Nothing bs) cc
   case r of
     CRChatCmdError _ _ -> when (isMessage cmd) $ echo s
     CRChatError _ _ -> when (isMessage cmd) $ echo s

src/Simplex/Chat/Terminal/Output.hs

@@ -112,7 +112,7 @@ withTermLock ChatTerminal {termLock} action = do
 runTerminalOutput :: ChatTerminal -> ChatController -> IO ()
 runTerminalOutput ct cc@ChatController {outputQ, showLiveItems, logFilePath} = do
   forever $ do
-    (_, r) <- atomically $ readTBQueue outputQ
+    (_, _, r) <- atomically $ readTBQueue outputQ
     case r of
       CRNewChatItem _ ci -> markChatItemRead ci
       CRChatItemUpdated _ ci -> markChatItemRead ci

src/Simplex/Chat/Types.hs

@@ -10,13 +10,13 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StrictData #-}
 {-# LANGUAGE TypeFamilyDependencies #-}
 {-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE OverloadedRecordDot #-}
 
 {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
 

src/Simplex/Chat/View.hs

@@ -297,6 +297,7 @@ 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
@@ -1677,6 +1678,8 @@ viewChatError logLevel = \case
         Nothing -> ""
       cId :: Connection -> StyledString
       cId conn = sShow conn.connId
+  ChatErrorRemoteCtrl remoteCtrlId todo'rc -> [sShow remoteCtrlId, sShow todo'rc]
+  ChatErrorRemoteHost remoteHostId todo'rh -> [sShow remoteHostId, sShow todo'rh]
   where
     fileNotFound fileId = ["file " <> sShow fileId <> " not found"]
     sqliteError' = \case