mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-06-05 10:12:59 +00:00
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>
This commit is contained in:
Alexander Bondarenko
committed by
GitHub
GitHub
parent
50d624ef6b
commit
3e29c664ac
@@ -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
|
||||
|
||||
@@ -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 #-}
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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;
|
||||
|]
|
||||
@@ -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
|
||||
|
||||
@@ -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 cc s = J.encode . APIResponse Nothing <$> runReaderT (execChatCommand s) cc
|
||||
chatSendCmd :: ChatController -> B.ByteString -> IO JSONByteString
|
||||
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
|
||||
|
||||
@@ -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
|
||||
@@ -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
|
||||
}
|
||||
@@ -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
|
||||
|
||||
@@ -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}
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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 #-}
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user