From cccb3e33fb2388cc7d76f92e515f4808e51a3bf7 Mon Sep 17 00:00:00 2001 From: IC Rainbow Date: Wed, 27 Sep 2023 18:24:38 +0300 Subject: [PATCH] Plug discovery into remote controller UI --- src/Simplex/Chat.hs | 56 ++++++++++-- src/Simplex/Chat/Controller.hs | 19 ++-- .../Migrations/M20230922_remote_controller.hs | 3 +- src/Simplex/Chat/Remote.hs | 64 +++++++------ src/Simplex/Chat/Remote/Discovery.hs | 89 +++++++------------ src/Simplex/Chat/Remote/Types.hs | 13 +-- src/Simplex/Chat/Store/Remote.hs | 27 +++++- src/Simplex/Chat/View.hs | 2 +- 8 files changed, 167 insertions(+), 106 deletions(-) diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index afcd95443e..849bff97fd 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -72,6 +72,7 @@ import Simplex.Chat.Store.Files import Simplex.Chat.Store.Groups import Simplex.Chat.Store.Messages import Simplex.Chat.Store.Profiles +import Simplex.Chat.Store.Remote import Simplex.Chat.Store.Shared import Simplex.Chat.Types import Simplex.Chat.Types.Preferences @@ -1864,11 +1865,56 @@ processChatCommand = \case 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" + StartRemoteCtrl -> + chatReadVar remoteCtrlSession >>= \case + Just _busy -> throwError $ ChatErrorRemoteCtrl RCEBusy + Nothing -> do + uio <- askUnliftIO + accepted <- newEmptyTMVarIO + let getControllers = unliftIO uio $ withStore' $ \db -> + map (\RemoteCtrl{remoteCtrlId, fingerprint} -> (fingerprint, remoteCtrlId)) <$> getRemoteCtrls (DB.conn db) + let started remoteCtrlId = unliftIO uio $ do + withStore' (\db -> getRemoteCtrl (DB.conn db) remoteCtrlId) >>= \case + Nothing -> pure False + Just RemoteCtrl{displayName, accepted=resolution} -> case resolution of + Nothing -> do + -- started/finished wrapper is synchronous, running HTTP server can be delayed here until UI processes the first contact dialogue + toView $ CRRemoteCtrlFirstContact {remoteCtrlId, displayName} + atomically $ takeTMVar accepted + Just known -> atomically $ putTMVar accepted known $> known + let finished remoteCtrlId todo'error = unliftIO uio $ do + chatWriteVar remoteCtrlSession Nothing + toView $ CRRemoteCtrlDisconnected {remoteCtrlId} + let process rc req = unliftIO uio $ processControllerCommand rc req + ctrlAsync <- async . liftIO $ Discovery.runDiscoverer getControllers started finished process + chatWriteVar remoteCtrlSession $ Just RemoteCtrlSession {ctrlAsync, accepted} + pure CRRemoteCtrlStarted + ConfirmRemoteCtrl remoteCtrlId -> do + chatReadVar remoteCtrlSession >>= \case + Nothing -> throwError $ ChatErrorRemoteCtrl RCEInactive + Just RemoteCtrlSession {accepted} -> do + withStore' $ \db -> markRemoteCtrlResolution (DB.conn db) remoteCtrlId True + atomically $ putTMVar accepted True + pure $ CRRemoteCtrlAccepted {remoteCtrlId} + RejectRemoteCtrl remoteCtrlId -> do + chatReadVar remoteCtrlSession >>= \case + Nothing -> throwError $ ChatErrorRemoteCtrl RCEInactive + Just RemoteCtrlSession {accepted} -> do + withStore' $ \db -> markRemoteCtrlResolution (DB.conn db) remoteCtrlId False + atomically $ putTMVar accepted False + pure $ CRRemoteCtrlRejected {remoteCtrlId} + StopRemoteCtrl remoteCtrlId -> + chatReadVar remoteCtrlSession >>= \case + Nothing -> throwError $ ChatErrorRemoteCtrl RCEInactive + Just RemoteCtrlSession {ctrlAsync} -> do + cancel ctrlAsync + pure $ CRRemoteCtrlDisconnected {remoteCtrlId} + DisposeRemoteCtrl remoteCtrlId -> + chatReadVar remoteCtrlSession >>= \case + Nothing -> do + withStore' $ \db -> deleteRemoteCtrl (DB.conn db) remoteCtrlId + pure $ CRRemoteCtrlDisposed {remoteCtrlId} + Just _ -> throwError $ ChatErrorRemoteCtrl RCEBusy QuitChat -> liftIO exitSuccess ShowVersion -> do let versionInfo = coreVersionInfo $(simplexmqCommitQ) diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index c6405990a3..82a1cbcede 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -422,7 +422,7 @@ data ChatCommand | 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?) + | 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 | QuitChat @@ -602,9 +602,11 @@ data ChatResponse | CRRemoteHostDisposed {remoteHostId :: RemoteHostId} | CRRemoteCtrlList {remoteCtrls :: [RemoteCtrlInfo]} | CRRemoteCtrlRegistered {remoteCtrlId :: RemoteCtrlId} + | CRRemoteCtrlStarted + | CRRemoteCtrlFirstContact {remoteCtrlId :: RemoteCtrlId, displayName :: Text} | CRRemoteCtrlAccepted {remoteCtrlId :: RemoteCtrlId} | CRRemoteCtrlRejected {remoteCtrlId :: RemoteCtrlId} - | CRRemoteCtrlConnected {remoteCtrlId :: RemoteCtrlId} + | CRRemoteCtrlConnected {remoteCtrlId :: RemoteCtrlId, displayName :: Text} | CRRemoteCtrlDisconnected {remoteCtrlId :: RemoteCtrlId} | CRSQLResult {rows :: [Text]} | CRSlowSQLQueries {chatQueries :: [SlowSQLQuery], agentQueries :: [SlowSQLQuery]} @@ -906,7 +908,7 @@ data ChatError | ChatErrorAgent {agentError :: AgentErrorType, connectionEntity_ :: Maybe ConnectionEntity} | ChatErrorStore {storeError :: StoreError} | ChatErrorDatabase {databaseError :: DatabaseError} - | ChatErrorRemoteCtrl {remoteCtrlId :: RemoteCtrlId, remoteControllerError :: RemoteCtrlError} + | ChatErrorRemoteCtrl {remoteControllerError :: RemoteCtrlError} | ChatErrorRemoteHost {remoteHostId :: RemoteHostId, remoteHostError :: RemoteHostError} deriving (Show, Exception, Generic) @@ -1036,13 +1038,14 @@ instance ToJSON RemoteHostError where -- TODO review errors, some of it can be covered by HTTP2 errors data RemoteCtrlError - = RCEMissing -- ^ No remote session matches this identifier + = RCEMissing {remoteCtrlId :: RemoteCtrlId} -- ^ No remote session matches this identifier + | RCEInactive -- ^ No session is running | 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 + | RCEDisconnected {remoteCtrlId :: RemoteCtrlId, reason :: Text} -- ^ A session disconnected by a controller + | 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 deriving (Show, Exception, Generic) instance FromJSON RemoteCtrlError where diff --git a/src/Simplex/Chat/Migrations/M20230922_remote_controller.hs b/src/Simplex/Chat/Migrations/M20230922_remote_controller.hs index 070a4e35cb..4890bfc22a 100644 --- a/src/Simplex/Chat/Migrations/M20230922_remote_controller.hs +++ b/src/Simplex/Chat/Migrations/M20230922_remote_controller.hs @@ -19,7 +19,8 @@ CREATE TABLE remote_hosts ( -- hosts known to a controlling app 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 + fingerprint BLOB NOT NULL, + accepted INTEGER ); |] diff --git a/src/Simplex/Chat/Remote.hs b/src/Simplex/Chat/Remote.hs index 34c6b31a46..8e2bedc979 100644 --- a/src/Simplex/Chat/Remote.hs +++ b/src/Simplex/Chat/Remote.hs @@ -10,9 +10,9 @@ module Simplex.Chat.Remote where import Control.Monad.Except import Control.Monad.IO.Class import qualified Data.Aeson as J +import qualified Data.Binary.Builder as Binary 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 @@ -20,43 +20,44 @@ 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 qualified Simplex.Messaging.Transport.HTTP2.Server as HTTP2 +import Simplex.Messaging.Util (bshow) import System.Directory (getFileSize) -withRemoteHostSession :: ChatMonad m => RemoteHostId -> (RemoteHostSession -> m a) -> m a +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 -closeRemoteHostSession :: ChatMonad m => RemoteHostId -> m () +closeRemoteHostSession :: (ChatMonad m) => RemoteHostId -> m () closeRemoteHostSession rh = withRemoteHostSession rh (liftIO . HTTP2.closeHTTP2Client . ctrlClient) -processRemoteCommand :: ChatMonad m => RemoteHostSession -> (ByteString, ChatCommand) -> m ChatResponse +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 +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 @@ -64,11 +65,11 @@ relayCommand RemoteHostSession {ctrlClient} s = postBytestring Nothing ctrlClien where req = HTTP2Client.requestBuilder "POST" path hs (Binary.fromByteString body) -storeRemoteFile :: ChatMonad m => RemoteHostSession -> FilePath -> m ChatResponse +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 + Right HTTP2.HTTP2Response {response} -> case HTTP.statusCode <$> HTTP2Client.responseStatus response of Just 200 -> pure $ CRCmdOk Nothing unexpected -> error "TODO: http2chatError" where @@ -78,7 +79,7 @@ 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 :: (ChatMonad m) => RemoteHostSession -> FileTransferId -> m ChatResponse fetchRemoteFile RemoteHostSession {ctrlClient, storePath} remoteFileId = do liftIO (HTTP2.sendRequest ctrlClient req Nothing) >>= \case Left e -> error "TODO: http2chatError" @@ -93,3 +94,12 @@ sum2tagged :: J.Value -> J.Value sum2tagged = \case J.Object todo'convert -> J.Object todo'convert skip -> skip + +-- withRemoteCtrlSession :: (ChatMonad m) => RemoteCtrlId -> (RemoteCtrlSession -> m a) -> m a +-- withRemoteCtrlSession remoteCtrlId action = do +-- chatReadVar remoteHostSessions >>= maybe err action . M.lookup remoteCtrlId +-- where +-- err = throwError $ ChatErrorRemoteCtrl (Just remoteCtrlId) RCMissing + +processControllerCommand :: (ChatMonad m) => RemoteCtrlId -> HTTP2.HTTP2Request -> m () +processControllerCommand rc req = error "TODO: processControllerCommand" diff --git a/src/Simplex/Chat/Remote/Discovery.hs b/src/Simplex/Chat/Remote/Discovery.hs index ace1ced313..cb668677f5 100644 --- a/src/Simplex/Chat/Remote/Discovery.hs +++ b/src/Simplex/Chat/Remote/Discovery.hs @@ -10,19 +10,13 @@ module Simplex.Chat.Remote.Discovery where import Control.Monad -import Data.ByteString.Builder (Builder, intDec) import Data.Default (def) import Data.String (IsString) -import Data.Text (Text) -import Data.Text.Encoding (encodeUtf8) import Debug.Trace -import qualified Network.HTTP.Types as HTTP -import qualified Network.HTTP2.Server as HTTP2 import qualified Network.Socket as N import qualified Network.TLS as TLS import qualified Network.UDP as UDP -import Simplex.Chat.Controller (ChatMonad) -import Simplex.Chat.Types () +import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String (StrEncoding (..)) import Simplex.Messaging.Transport (supportedParameters) import qualified Simplex.Messaging.Transport as Transport @@ -34,7 +28,7 @@ import Simplex.Messaging.Transport.Server (defaultTransportServerConfig, runTran import UnliftIO import UnliftIO.Concurrent -runAnnouncer :: (StrEncoding invite, ChatMonad m) => IO () -> invite -> TLS.Credentials -> m (Either HTTP2ClientError HTTP2Client) +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) @@ -76,57 +70,38 @@ broadcastAddrV4 = "255.255.255.255" partyPort :: (IsString a) => a partyPort = "5226" -- XXX: should be `0` or something, to get a random port and announce it -runDiscoverer :: (ChatMonad m) => Text -> m () -runDiscoverer oobData = - case strDecode (encodeUtf8 oobData) of - Left err -> traceM $ "oobData decode error: " <> err - Right expected -> liftIO $ do - traceM $ "runDiscoverer: locating " <> show oobData - sock <- UDP.serverSocket (broadcastAddrV4, read partyPort) - N.setSocketOption (UDP.listenSocket sock) N.Broadcast 1 - traceM $ "runDiscoverer: " <> show sock - go sock expected +runDiscoverer :: IO [(C.KeyHash, ctx)] -> (ctx -> IO Bool) -> (ctx -> Maybe SomeException -> IO ()) -> (ctx -> HTTP2Request -> IO ()) -> IO () +runDiscoverer getFingerprints started finished processRequest = do + sock <- UDP.serverSocket (broadcastAddrV4, read partyPort) + N.setSocketOption (UDP.listenSocket sock) N.Broadcast 1 + traceM $ "runDiscoverer: " <> show sock + go sock where - go sock expected = do + go sock = do (invite, UDP.ClientSockAddr source _cmsg) <- UDP.recvFrom sock - traceShowM (invite, source) - let expect hash = hash `elem` [expected] -- XXX: can be a callback to fetch actual invite list just in time case strDecode invite of Left err -> do traceM $ "Inivite decode error: " <> err - go sock expected - Right inviteHash | not (expect inviteHash) -> do - traceM $ "Skipping unexpected invite " <> show (strEncode inviteHash) - go sock expected - Right _expected -> do - host <- case source of - N.SockAddrInet _port addr -> do - pure $ THIPv4 (N.hostAddressToTuple addr) - unexpected -> - -- TODO: actually, Apple mandates IPv6 support - fail $ "Discoverer: expected an IPv4 party, got " <> show unexpected - traceM $ "Discoverer: go connect " <> show host - runTransportClient defaultTransportClientConfig Nothing host partyPort (Just expected) $ \tls -> do - traceM "2PTTH server starting" - run tls - traceM "2PTTH server finished" - - run tls = runHTTP2ServerWith defaultHTTP2BufferSize ($ tls) $ \sessionId r sendResponse -> do - reqBody <- getHTTP2Body r 16384 - processRequest HTTP2Request {sessionId, request = r, reqBody, sendResponse} - - processRequest req = do - traceM $ "Got request: " <> show (request req) - -- TODO: sendResponse req . HTTP2.promiseResponse $ HTTP2.pushPromise path response weight - sendResponse req $ HTTP2.responseStreaming HTTP.ok200 sseHeaders sseExample - - sseHeaders = [(HTTP.hContentType, "text/event-stream")] - - sseExample :: (Builder -> IO ()) -> IO () -> IO () - sseExample write flush = forM_ [1 .. 10] $ \i -> do - let payload = "[" <> intDec i <> ", \"blah\"]" - write "event: message\n" -- XXX: SSE header line - write $ "data: " <> payload <> "\n" -- XXX: SSE payload line - write "\n" -- XXX: SSE delimiter - flush - threadDelay 1000000 + go sock + Right inviteHash -> do + expected <- getFingerprints + case lookup inviteHash expected of + Nothing -> do + traceM $ "Unexpected invite: " <> show (invite, source) + go sock + Just ctx -> do + host <- case source of + N.SockAddrInet _port addr -> do + pure $ THIPv4 (N.hostAddressToTuple addr) + unexpected -> + -- TODO: actually, Apple mandates IPv6 support + fail $ "Discoverer: expected an IPv4 party, got " <> show unexpected + runTransportClient defaultTransportClientConfig Nothing host partyPort (Just inviteHash) $ \tls -> do + accepted <- started ctx + if not accepted + then go sock -- Ignore rejected invites and wait for another + else do + res <- try $ runHTTP2ServerWith defaultHTTP2BufferSize ($ tls) $ \sessionId r sendResponse -> do + reqBody <- getHTTP2Body r 16384 + processRequest ctx HTTP2Request {sessionId, request = r, reqBody, sendResponse} + finished ctx $ either Just (\() -> Nothing) res diff --git a/src/Simplex/Chat/Remote/Types.hs b/src/Simplex/Chat/Remote/Types.hs index 9f28eab551..53f73c3389 100644 --- a/src/Simplex/Chat/Remote/Types.hs +++ b/src/Simplex/Chat/Remote/Types.hs @@ -8,6 +8,7 @@ import Data.Int (Int64) import Data.Text (Text) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client) +import UnliftIO.STM type RemoteHostId = Int64 @@ -22,12 +23,13 @@ data RemoteHost = RemoteHost caKey :: C.Key } -type RemoteCtrlId = Int +type RemoteCtrlId = Int64 data RemoteCtrl = RemoteCtrl { remoteCtrlId :: RemoteCtrlId, displayName :: Text, - fingerprint :: Text + fingerprint :: C.KeyHash, + accepted :: Maybe Bool } data RemoteHostSession = RemoteHostSession @@ -36,9 +38,8 @@ data RemoteHostSession = RemoteHostSession 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 + { -- | Server side of transport to process remote commands and forward notifications + ctrlAsync :: Async (), + accepted :: TMVar Bool } diff --git a/src/Simplex/Chat/Store/Remote.hs b/src/Simplex/Chat/Store/Remote.hs index 12fcb6c081..f185000d88 100644 --- a/src/Simplex/Chat/Store/Remote.hs +++ b/src/Simplex/Chat/Store/Remote.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -7,7 +8,7 @@ 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.Chat.Remote.Types (RemoteCtrl (..), RemoteCtrlId, RemoteHost (..), RemoteHostId) import Simplex.Messaging.Agent.Store.SQLite (maybeFirstRow) import qualified Simplex.Messaging.Crypto as C @@ -26,3 +27,27 @@ remoteHostQuery = "SELECT remote_host_id, display_name, store_path, ca_cert, ca_ toRemoteHost :: (Int64, Text, FilePath, ByteString, C.Key) -> RemoteHost toRemoteHost (remoteHostId, displayName, storePath, caCert, caKey) = RemoteHost {remoteHostId, displayName, storePath, caCert, caKey} + +getRemoteCtrls :: DB.Connection -> IO [RemoteCtrl] +getRemoteCtrls db = + map toRemoteCtrl <$> DB.query_ db remoteCtrlQuery + +getRemoteCtrl :: DB.Connection -> RemoteCtrlId -> IO (Maybe RemoteCtrl) +getRemoteCtrl db remoteCtrlId = + maybeFirstRow toRemoteCtrl $ + DB.query db (remoteCtrlQuery <> "WHERE remote_controller_id = ?") (DB.Only remoteCtrlId) + +remoteCtrlQuery :: DB.Query +remoteCtrlQuery = "SELECT remote_controller_id, display_name, fingerprint, accepted FROM remote_controllers" + +toRemoteCtrl :: (Int64, Text, C.KeyHash, Maybe Bool) -> RemoteCtrl +toRemoteCtrl (remoteCtrlId, displayName, fingerprint, accepted) = + RemoteCtrl {remoteCtrlId, displayName, fingerprint, accepted} + +markRemoteCtrlResolution :: DB.Connection -> RemoteCtrlId -> Bool -> IO () +markRemoteCtrlResolution db remoteCtrlId accepted = + DB.execute db "UPDATE remote_controllers SET accepted = ? WHERE remote_controller_id = ?" (accepted, remoteCtrlId) + +deleteRemoteCtrl :: DB.Connection -> RemoteCtrlId -> IO () +deleteRemoteCtrl db remoteCtrlId = + DB.execute db "DELETE FROM remote_controllers WHERE remote_controller_id = ?" (DB.Only remoteCtrlId) diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 1f110fc951..1761b384ac 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -1678,7 +1678,7 @@ viewChatError logLevel = \case Nothing -> "" cId :: Connection -> StyledString cId conn = sShow conn.connId - ChatErrorRemoteCtrl remoteCtrlId todo'rc -> [sShow remoteCtrlId, sShow todo'rc] + ChatErrorRemoteCtrl todo'rc -> [sShow todo'rc] ChatErrorRemoteHost remoteHostId todo'rh -> [sShow remoteHostId, sShow todo'rh] where fileNotFound fileId = ["file " <> sShow fileId <> " not found"]