From b72914477375c917efe406339a20ec9c7c7d4781 Mon Sep 17 00:00:00 2001 From: Alexander Bondarenko <486682+dpwiz@users.noreply.github.com> Date: Wed, 8 Nov 2023 22:13:52 +0200 Subject: [PATCH] core: use xrcp protocol for desktop/mobile connection (#3305) * WIP: start working on /connect remote ctrl OOB is broken, requires fixing simplexmq bits. * WIP: pull CtrlCryptoHandle from xrcp * place xrcp stubs * WIP: start switching to RemoteControl.Client types * fix http2 sha * fix sha256map.nix * fix cabal.project * update RC test * WIP: add new remote session * fix compilation * simplify * attach HTTP2 server to TLS * starting host session in controller (WIP) * more WIP * compiles * compiles2 * wip * pass startRemote' test * async to poll for events from host, test to send messages fails * move xrcp handshake test to simplexmq * detect session stops * fix connectRemoteCtrl * use step type * app info * WIP: pairing stores * plug in hello/appInfo/pairings * negotiate app version * update simplexmw, remove KEM secrets from DB * fix file tests * tone down http2 shutdown errors * Add stored session test * bump simplexmq tag * update simplexmq * refactor, fix * removed unused errors * rename fields, remove unused file * rename errors --------- Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> --- cabal.project | 2 +- scripts/nix/sha256map.nix | 2 +- simplex-chat.cabal | 1 + src/Simplex/Chat.hs | 44 +- src/Simplex/Chat/Controller.hs | 106 ++-- .../Migrations/M20231114_remote_controller.hs | 32 +- src/Simplex/Chat/Migrations/chat_schema.sql | 32 +- src/Simplex/Chat/Remote.hs | 527 ++++++++++-------- src/Simplex/Chat/Remote/AppVersion.hs | 69 +++ src/Simplex/Chat/Remote/Protocol.hs | 18 +- src/Simplex/Chat/Remote/RevHTTP.hs | 29 +- src/Simplex/Chat/Remote/Types.hs | 83 +-- src/Simplex/Chat/Store/Remote.hs | 120 +++- src/Simplex/Chat/Store/Shared.hs | 3 + src/Simplex/Chat/View.hs | 43 +- stack.yaml | 2 +- tests/ChatClient.hs | 2 +- tests/RemoteTests.hs | 227 +++----- 18 files changed, 761 insertions(+), 581 deletions(-) create mode 100644 src/Simplex/Chat/Remote/AppVersion.hs diff --git a/cabal.project b/cabal.project index 1c149d2015..fe74d21485 100644 --- 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: 1a0c4b73de5cda4ac6765dd47e0199238e498d5f + tag: 102487bc4fbb865aac4207d2ba6f2ea77eff3290 source-repository-package type: git diff --git a/scripts/nix/sha256map.nix b/scripts/nix/sha256map.nix index 3e3df9fdb6..26f7357a11 100644 --- a/scripts/nix/sha256map.nix +++ b/scripts/nix/sha256map.nix @@ -1,5 +1,5 @@ { - "https://github.com/simplex-chat/simplexmq.git"."1a0c4b73de5cda4ac6765dd47e0199238e498d5f" = "12xpr2lxw9rr3v2bz5m5g9bb0kj7c5yyan47w0nnp52gzfs4pff0"; + "https://github.com/simplex-chat/simplexmq.git"."102487bc4fbb865aac4207d2ba6f2ea77eff3290" = "1zay63ix9vh20p6843l1zry47zwb7lkirmxrrgdcc7qwl89js1bs"; "https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38"; "https://github.com/kazu-yamamoto/http2.git"."f5525b755ff2418e6e6ecc69e877363b0d0bcaeb" = "0fyx0047gvhm99ilp212mmz37j84cwrfnpmssib5dw363fyb88b6"; "https://github.com/simplex-chat/direct-sqlcipher.git"."f814ee68b16a9447fbb467ccc8f29bdd3546bfd9" = "1ql13f4kfwkbaq7nygkxgw84213i0zm7c1a8hwvramayxl38dq5d"; diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 32711d3858..ba5297e696 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -131,6 +131,7 @@ library Simplex.Chat.ProfileGenerator Simplex.Chat.Protocol Simplex.Chat.Remote + Simplex.Chat.Remote.AppVersion Simplex.Chat.Remote.Multicast Simplex.Chat.Remote.Protocol Simplex.Chat.Remote.RevHTTP diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index b9663bae1d..664661603b 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -46,7 +46,7 @@ import qualified Data.Map.Strict as M import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe, mapMaybe, maybeToList) import Data.Text (Text) import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8) +import Data.Text.Encoding (decodeLatin1, encodeUtf8) import Data.Time (NominalDiffTime, addUTCTime, defaultTimeLocale, formatTime) import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime, nominalDay, nominalDiffTimeToSeconds) import Data.Time.Clock.System (SystemTime, systemToUTCTime) @@ -72,7 +72,6 @@ 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 @@ -376,8 +375,8 @@ restoreCalls = do stopChatController :: forall m. MonadUnliftIO m => ChatController -> m () stopChatController ChatController {smpAgent, agentAsync = s, sndFiles, rcvFiles, expireCIFlags, remoteHostSessions, remoteCtrlSession} = do - readTVarIO remoteHostSessions >>= mapM_ cancelRemoteHostSession - readTVarIO remoteCtrlSession >>= mapM_ cancelRemoteCtrlSession_ + readTVarIO remoteHostSessions >>= mapM_ (liftIO . cancelRemoteHost) + atomically (stateTVar remoteCtrlSession (,Nothing)) >>= mapM_ (liftIO . cancelRemoteCtrl) disconnectAgentClient smpAgent readTVarIO s >>= mapM_ (\(a1, a2) -> uninterruptibleCancel a1 >> mapM_ uninterruptibleCancel a2) closeFiles sndFiles @@ -409,7 +408,7 @@ execChatCommand_ :: ChatMonad' m => Maybe User -> ChatCommand -> m ChatResponse execChatCommand_ u cmd = handleCommandError u $ processChatCommand cmd execRemoteCommand :: ChatMonad' m => Maybe User -> RemoteHostId -> ChatCommand -> ByteString -> m ChatResponse -execRemoteCommand u rhId cmd s = handleCommandError u $ getRemoteHostSession rhId >>= \rh -> processRemoteCommand rhId rh cmd s +execRemoteCommand u rhId cmd s = handleCommandError u $ getRemoteHostClient rhId >>= \rh -> processRemoteCommand rhId rh cmd s handleCommandError :: ChatMonad' m => Maybe User -> ExceptT ChatError m ChatResponse -> m ChatResponse handleCommandError u a = either (CRChatCmdError u) id <$> (runExceptT a `E.catch` (pure . Left . mkChatError)) @@ -1953,17 +1952,18 @@ processChatCommand = \case updateGroupProfileByName gName $ \p -> p {groupPreferences = Just . setGroupPreference' SGFTimedMessages pref $ groupPreferences p} SetLocalDeviceName name -> withUser_ $ chatWriteVar localDeviceName name >> ok_ - CreateRemoteHost -> CRRemoteHostCreated <$> createRemoteHost - ListRemoteHosts -> CRRemoteHostList <$> listRemoteHosts - StartRemoteHost rh -> startRemoteHost rh >> ok_ - StopRemoteHost rh -> closeRemoteHostSession rh >> ok_ - DeleteRemoteHost rh -> deleteRemoteHost rh >> ok_ - StoreRemoteFile rh encrypted_ localPath -> CRRemoteFileStored rh <$> storeRemoteFile rh encrypted_ localPath - GetRemoteFile rh rf -> getRemoteFile rh rf >> ok_ - ConnectRemoteCtrl oob -> withUser_ $ CRRemoteCtrlRegistered <$> withStore' (`insertRemoteCtrl` oob) - FindKnownRemoteCtrl -> withUser_ $ findKnownRemoteCtrl (execChatCommand Nothing) >> ok_ + ListRemoteHosts -> withUser_ $ CRRemoteHostList <$> listRemoteHosts + StartRemoteHost rh_ -> withUser_ $ do + (remoteHost_, inv) <- startRemoteHost' rh_ + pure CRRemoteHostStarted {remoteHost_, invitation = decodeLatin1 $ strEncode inv} + StopRemoteHost rh_ -> withUser_ $ closeRemoteHost rh_ >> ok_ + DeleteRemoteHost rh -> withUser_ $ deleteRemoteHost rh >> ok_ + StoreRemoteFile rh encrypted_ localPath -> withUser_ $ CRRemoteFileStored rh <$> storeRemoteFile rh encrypted_ localPath + GetRemoteFile rh rf -> withUser_ $ getRemoteFile rh rf >> ok_ + ConnectRemoteCtrl oob -> withUser_ $ connectRemoteCtrl oob >> ok_ + FindKnownRemoteCtrl -> withUser_ $ findKnownRemoteCtrl >> ok_ ConfirmRemoteCtrl rc -> withUser_ $ confirmRemoteCtrl rc >> ok_ - VerifyRemoteCtrlSession rc sessId -> withUser_ $ verifyRemoteCtrlSession rc sessId >> ok_ + VerifyRemoteCtrlSession sessId -> withUser_ $ CRRemoteCtrlConnected <$> verifyRemoteCtrlSession (execChatCommand Nothing) sessId StopRemoteCtrl -> withUser_ $ stopRemoteCtrl >> ok_ ListRemoteCtrls -> withUser_ $ CRRemoteCtrlList <$> listRemoteCtrls DeleteRemoteCtrl rc -> withUser_ $ deleteRemoteCtrl rc >> ok_ @@ -5717,12 +5717,6 @@ waitChatStarted = do agentStarted <- asks agentAsync atomically $ readTVar agentStarted >>= \a -> unless (isJust a) retry -withAgent :: ChatMonad m => (AgentClient -> ExceptT AgentErrorType m a) -> m a -withAgent action = - asks smpAgent - >>= runExceptT . action - >>= liftEither . first (`ChatErrorAgent` Nothing) - chatCommandP :: Parser ChatCommand chatCommandP = choice @@ -5981,17 +5975,17 @@ chatCommandP = "/set disappear " *> (SetUserTimedMessages <$> (("yes" $> True) <|> ("no" $> False))), ("/incognito" <* optional (A.space *> onOffP)) $> ChatHelp HSIncognito, "/set device name " *> (SetLocalDeviceName <$> textP), - "/create remote host" $> CreateRemoteHost, + -- "/create remote host" $> CreateRemoteHost, "/list remote hosts" $> ListRemoteHosts, - "/start remote host " *> (StartRemoteHost <$> A.decimal), - "/stop remote host " *> (StopRemoteHost <$> A.decimal), + "/start remote host " *> (StartRemoteHost <$> ("new" $> Nothing <|> (Just <$> ((,) <$> A.decimal <*> (" multicast=" *> onOffP <|> pure False))))), + "/stop remote host " *> (StopRemoteHost <$> ("new" $> RHNew <|> RHId <$> A.decimal)), "/delete remote host " *> (DeleteRemoteHost <$> A.decimal), "/store remote file " *> (StoreRemoteFile <$> A.decimal <*> optional (" encrypt=" *> onOffP) <* A.space <*> filePath), "/get remote file " *> (GetRemoteFile <$> A.decimal <* A.space <*> jsonP), "/connect remote ctrl " *> (ConnectRemoteCtrl <$> strP), "/find remote ctrl" $> FindKnownRemoteCtrl, "/confirm remote ctrl " *> (ConfirmRemoteCtrl <$> A.decimal), - "/verify remote ctrl " *> (VerifyRemoteCtrlSession <$> A.decimal <* A.space <*> textP), + "/verify remote ctrl " *> (VerifyRemoteCtrlSession <$> textP), "/list remote ctrls" $> ListRemoteCtrls, "/stop remote ctrl" $> StopRemoteCtrl, "/delete remote ctrl " *> (DeleteRemoteCtrl <$> A.decimal), diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 6ca541a718..4c38ca95d9 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -16,6 +16,7 @@ module Simplex.Chat.Controller where +import Simplex.RemoteControl.Invitation (RCSignedInvitation) import Control.Concurrent (ThreadId) import Control.Concurrent.Async (Async) import Control.Exception @@ -40,7 +41,6 @@ import Data.String import Data.Text (Text) import Data.Time (NominalDiffTime, UTCTime) import Data.Version (showVersion) -import Data.Word (Word16) import Language.Haskell.TH (Exp, Q, runIO) import Numeric.Natural import qualified Paths_simplex_chat as SC @@ -49,6 +49,7 @@ import Simplex.Chat.Markdown (MarkdownList) import Simplex.Chat.Messages import Simplex.Chat.Messages.CIContent import Simplex.Chat.Protocol +import Simplex.Chat.Remote.AppVersion import Simplex.Chat.Remote.Types import Simplex.Chat.Store (AutoAccept, StoreError (..), UserContactLink, UserMsgReceiptSettings) import Simplex.Chat.Types @@ -73,10 +74,12 @@ import Simplex.Messaging.Transport (simplexMQVersion) import Simplex.Messaging.Transport.Client (TransportHost) import Simplex.Messaging.Util (allFinally, catchAllErrors, liftEitherError, tryAllErrors, (<$$>)) import Simplex.Messaging.Version -import Simplex.RemoteControl.Types import System.IO (Handle) import System.Mem.Weak (Weak) import UnliftIO.STM +import Data.Bifunctor (first) +import Simplex.RemoteControl.Client +import Simplex.RemoteControl.Types versionNumber :: String versionNumber = showVersion SC.version @@ -180,7 +183,7 @@ data ChatController = ChatController currentCalls :: TMap ContactId Call, localDeviceName :: TVar Text, multicastSubscribers :: TMVar Int, - remoteHostSessions :: TMap RemoteHostId RemoteHostSession, -- All the active remote hosts + remoteHostSessions :: TMap RHKey RemoteHostSession, -- All the active remote hosts remoteHostsFolder :: TVar (Maybe FilePath), -- folder for remote hosts data remoteCtrlSession :: TVar (Maybe RemoteCtrlSession), -- Supervisor process for hosted controllers config :: ChatConfig, @@ -419,18 +422,18 @@ data ChatCommand | SetContactTimedMessages ContactName (Maybe TimedMessagesEnabled) | SetGroupTimedMessages GroupName (Maybe Int) | SetLocalDeviceName Text - | CreateRemoteHost -- ^ Configure a new remote host + -- | CreateRemoteHost -- ^ Configure a new remote host | ListRemoteHosts - | StartRemoteHost RemoteHostId -- ^ Start and announce a remote host + | StartRemoteHost (Maybe (RemoteHostId, Bool)) -- ^ Start new or known remote host with optional multicast for known host -- | SwitchRemoteHost (Maybe RemoteHostId) -- ^ Switch current remote host - | StopRemoteHost RemoteHostId -- ^ Shut down a running session + | StopRemoteHost RHKey -- ^ Shut down a running session | DeleteRemoteHost RemoteHostId -- ^ Unregister remote host and remove its data | StoreRemoteFile {remoteHostId :: RemoteHostId, storeEncrypted :: Maybe Bool, localPath :: FilePath} | GetRemoteFile {remoteHostId :: RemoteHostId, file :: RemoteFile} - | ConnectRemoteCtrl SignedOOB -- ^ Connect new or existing controller via OOB data + | ConnectRemoteCtrl RCSignedInvitation -- ^ Connect new or existing controller via OOB data | FindKnownRemoteCtrl -- ^ Start listening for announcements from all existing controllers | ConfirmRemoteCtrl RemoteCtrlId -- ^ Confirm the connection with found controller - | VerifyRemoteCtrlSession RemoteCtrlId Text -- ^ Verify remote controller session + | VerifyRemoteCtrlSession Text -- ^ Verify remote controller session | ListRemoteCtrls | StopRemoteCtrl -- ^ Stop listening for announcements or terminate an active session | DeleteRemoteCtrl RemoteCtrlId -- ^ Remove all local data associated with a remote controller session @@ -451,7 +454,6 @@ allowRemoteCommand = \case APISuspendChat _ -> False SetTempFolder _ -> False QuitChat -> False - CreateRemoteHost -> False ListRemoteHosts -> False StartRemoteHost _ -> False -- SwitchRemoteHost {} -> False @@ -642,8 +644,8 @@ data ChatResponse | CRContactConnectionDeleted {user :: User, connection :: PendingContactConnection} | CRRemoteHostCreated {remoteHost :: RemoteHostInfo} | CRRemoteHostList {remoteHosts :: [RemoteHostInfo]} - | CRRemoteHostStarted {remoteHost :: RemoteHostInfo, sessionOOB :: Text} - | CRRemoteHostSessionCode {remoteHost :: RemoteHostInfo, sessionCode :: Text} + | CRRemoteHostStarted {remoteHost_ :: Maybe RemoteHostInfo, invitation :: Text} + | CRRemoteHostSessionCode {remoteHost_ :: Maybe RemoteHostInfo, sessionCode :: Text} | CRRemoteHostConnected {remoteHost :: RemoteHostInfo} | CRRemoteHostStopped {remoteHostId :: RemoteHostId} | CRRemoteFileStored {remoteHostId :: RemoteHostId, remoteFileSource :: CryptoFile} @@ -652,7 +654,7 @@ data ChatResponse | CRRemoteCtrlAnnounce {fingerprint :: C.KeyHash} -- TODO remove, unregistered fingerprint, needs confirmation -- TODO is it needed? | CRRemoteCtrlFound {remoteCtrl :: RemoteCtrlInfo} -- registered fingerprint, may connect | CRRemoteCtrlConnecting {remoteCtrl :: RemoteCtrlInfo} -- TODO is remove - | CRRemoteCtrlSessionCode {remoteCtrl :: RemoteCtrlInfo, sessionCode :: Text, newCtrl :: Bool} + | CRRemoteCtrlSessionCode {remoteCtrl_ :: Maybe RemoteCtrlInfo, sessionCode :: Text} | CRRemoteCtrlConnected {remoteCtrl :: RemoteCtrlInfo} | CRRemoteCtrlStopped | CRSQLResult {rows :: [Text]} @@ -949,7 +951,7 @@ data ChatError | ChatErrorStore {storeError :: StoreError} | ChatErrorDatabase {databaseError :: DatabaseError} | ChatErrorRemoteCtrl {remoteCtrlError :: RemoteCtrlError} - | ChatErrorRemoteHost {remoteHostId :: RemoteHostId, remoteHostError :: RemoteHostError} + | ChatErrorRemoteHost {rhKey :: RHKey, remoteHostError :: RemoteHostError} deriving (Show, Exception) data ChatErrorType @@ -1048,29 +1050,24 @@ 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 - | RHProtocolError RemoteProtocolError + = RHEMissing -- ^ No remote session matches this identifier + | RHEBusy -- ^ A session is already running + | RHEBadState -- ^ Illegal state transition + | RHEBadVersion {appVersion :: AppVersion} + | RHEDisconnected {reason :: Text} -- TODO should be sent when disconnected? + | RHEProtocolError RemoteProtocolError deriving (Show, Exception) -- TODO review errors, some of it can be covered by HTTP2 errors data RemoteCtrlError = RCEInactive -- ^ No session is running + | RCEBadState -- ^ A session is in a wrong state for the current operation | RCEBusy -- ^ A session is already running - | RCETimeout -- ^ Remote operation timed out | 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 - | RCEBadFingerprint -- ^ Bad fingerprint data provided in OOB + | RCEBadInvitation + | RCEBadVersion {appVersion :: AppVersion} | RCEBadVerificationCode -- ^ The code submitted doesn't match session TLSunique - | RCEHTTP2Error {http2Error :: String} - | RCEHTTP2RespStatus {statusCode :: Maybe Int} -- TODO remove - | RCEInvalidResponse {responseError :: String} + | RCEHTTP2Error {http2Error :: Text} -- TODO currently not used | RCEProtocolError {protocolError :: RemoteProtocolError} deriving (Show, Exception) @@ -1080,15 +1077,26 @@ data ArchiveError deriving (Show, Exception) -- | Host (mobile) side of transport to process remote commands and forward notifications -data RemoteCtrlSession = RemoteCtrlSession - { discoverer :: Async (), -- multicast listener - supervisor :: Async (), -- session state/subprocess supervisor - hostServer :: Maybe (Async ()), -- a running session - discovered :: TMap C.KeyHash (TransportHost, Word16), -- multicast-announced services - confirmed :: TMVar RemoteCtrlId, -- connection fingerprint found/stored in DB - verified :: TMVar (RemoteCtrlId, Text), -- user confirmed the session - remoteOutputQ :: TBQueue ChatResponse - } +data RemoteCtrlSession + = RCSessionStarting + | RCSessionConnecting + { rcsClient :: RCCtrlClient, + rcsWaitSession :: Async () + } + | RCSessionPendingConfirmation + { ctrlName :: Text, + rcsClient :: RCCtrlClient, + sessionCode :: Text, + rcsWaitSession :: Async (), + rcsWaitConfirmation :: TMVar (Either RCErrorType (RCCtrlSession, RCCtrlPairing)) + } + | RCSessionConnected + { remoteCtrlId :: RemoteCtrlId, + rcsClient :: RCCtrlClient, + rcsSession :: RCCtrlSession, + http2Server :: Async (), + remoteOutputQ :: TBQueue ChatResponse + } type ChatMonad' m = (MonadUnliftIO m, MonadReader ChatController m) @@ -1140,17 +1148,13 @@ throwChatError = throwError . ChatError toView :: ChatMonad' m => ChatResponse -> m () toView event = do localQ <- asks outputQ - chatReadVar remoteCtrlSession >>= \case - Nothing -> atomically $ writeTBQueue localQ (Nothing, Nothing, event) - Just RemoteCtrlSession {remoteOutputQ} -> - if allowRemoteEvent event - then do - -- TODO: filter events or let the UI ignore trigger events by itself? - -- traceM $ "Sending event to remote Q: " <> show event - atomically $ writeTBQueue remoteOutputQ event -- TODO: check full? - else do - -- traceM $ "Sending event to local Q: " <> show event - atomically $ writeTBQueue localQ (Nothing, Nothing, event) + session <- asks remoteCtrlSession + atomically $ + readTVar session >>= \case + Just RCSessionConnected {remoteOutputQ} | allowRemoteEvent event -> + writeTBQueue remoteOutputQ event + -- TODO potentially, it should hold some events while connecting + _ -> writeTBQueue localQ (Nothing, Nothing, event) withStore' :: ChatMonad m => (DB.Connection -> IO a) -> m a withStore' action = withStore $ liftIO . action @@ -1179,6 +1183,12 @@ withStoreCtx ctx_ action = do handleInternal :: String -> SomeException -> IO (Either StoreError a) handleInternal ctxStr e = pure . Left . SEInternalError $ show e <> ctxStr +withAgent :: ChatMonad m => (AgentClient -> ExceptT AgentErrorType m a) -> m a +withAgent action = + asks smpAgent + >>= runExceptT . action + >>= liftEither . first (`ChatErrorAgent` Nothing) + $(JQ.deriveJSON (enumJSON $ dropPrefix "HS") ''HelpSection) $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "ILP") ''InvitationLinkPlan) diff --git a/src/Simplex/Chat/Migrations/M20231114_remote_controller.hs b/src/Simplex/Chat/Migrations/M20231114_remote_controller.hs index 5b7ea1c7b0..a8e92a9988 100644 --- a/src/Simplex/Chat/Migrations/M20231114_remote_controller.hs +++ b/src/Simplex/Chat/Migrations/M20231114_remote_controller.hs @@ -10,18 +10,32 @@ m20231114_remote_controller = [sql| CREATE TABLE remote_hosts ( -- hosts known to a controlling app 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) + host_device_name TEXT NOT NULL, + store_path TEXT NOT NULL, -- file path for host files relative to app storage (must not contain "/") + -- RCHostPairing + ca_key BLOB NOT NULL, -- private key to sign session certificates + ca_cert BLOB NOT NULL, -- root certificate + id_key BLOB NOT NULL, -- long-term/identity signing key + -- KnownHostPairing + host_fingerprint BLOB NOT NULL, -- pinned remote host CA, set when connected + -- stored host session key + host_dh_pub BLOB NOT NULL, -- session DH key + UNIQUE (host_fingerprint) ON CONFLICT FAIL ); CREATE TABLE remote_controllers ( -- controllers known to a hosting app - 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) + remote_ctrl_id INTEGER PRIMARY KEY AUTOINCREMENT, + ctrl_device_name TEXT NOT NULL, + -- RCCtrlPairing + ca_key BLOB NOT NULL, -- CA key + ca_cert BLOB NOT NULL, -- CA certificate for TLS clients + ctrl_fingerprint BLOB NOT NULL, -- remote controller CA, set when connected + id_pub BLOB NOT NULL, -- remote controller long-term/identity key to verify signatures + -- stored session key, commited on connection confirmation + dh_priv_key BLOB NOT NULL, -- session DH key + -- prev session key + prev_dh_priv_key BLOB, -- previous session DH key + UNIQUE (ctrl_fingerprint) ON CONFLICT FAIL ); |] diff --git a/src/Simplex/Chat/Migrations/chat_schema.sql b/src/Simplex/Chat/Migrations/chat_schema.sql index ebe3fc1112..bef0d3605f 100644 --- a/src/Simplex/Chat/Migrations/chat_schema.sql +++ b/src/Simplex/Chat/Migrations/chat_schema.sql @@ -523,18 +523,32 @@ CREATE TABLE IF NOT EXISTS "received_probes"( CREATE TABLE remote_hosts( -- hosts known to a controlling app 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) + host_device_name TEXT NOT NULL, + store_path TEXT NOT NULL, -- file path for host files relative to app storage(must not contain "/") + -- RCHostPairing + ca_key BLOB NOT NULL, -- private key to sign session certificates + ca_cert BLOB NOT NULL, -- root certificate + id_key BLOB NOT NULL, -- long-term/identity signing key + -- KnownHostPairing + host_fingerprint BLOB NOT NULL, -- pinned remote host CA, set when connected + -- stored host session key + host_dh_pub BLOB NOT NULL, -- session DH key + UNIQUE(host_fingerprint) ON CONFLICT FAIL ); CREATE TABLE remote_controllers( -- controllers known to a hosting app - 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) + remote_ctrl_id INTEGER PRIMARY KEY AUTOINCREMENT, + ctrl_device_name TEXT NOT NULL, + -- RCCtrlPairing + ca_key BLOB NOT NULL, -- CA key + ca_cert BLOB NOT NULL, -- CA certificate for TLS clients + ctrl_fingerprint BLOB NOT NULL, -- remote controller CA, set when connected + id_pub BLOB NOT NULL, -- remote controller long-term/identity key to verify signatures + -- stored session key, commited on connection confirmation + dh_priv_key BLOB NOT NULL, -- session DH key + -- prev session key + prev_dh_priv_key BLOB, -- previous session DH key + UNIQUE(ctrl_fingerprint) ON CONFLICT FAIL ); CREATE INDEX contact_profiles_index ON contact_profiles( display_name, diff --git a/src/Simplex/Chat/Remote.hs b/src/Simplex/Chat/Remote.hs index cb943ac2c5..8bb354c216 100644 --- a/src/Simplex/Chat/Remote.hs +++ b/src/Simplex/Chat/Remote.hs @@ -1,13 +1,14 @@ -{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} module Simplex.Chat.Remote where @@ -18,161 +19,202 @@ import Control.Monad import Control.Monad.Except import Control.Monad.IO.Class import Control.Monad.Reader -import Control.Monad.STM (retry) import Crypto.Random (getRandomBytes) import qualified Data.Aeson as J +import qualified Data.Aeson.Types as JT +import Data.Bifunctor (second) import Data.ByteString (ByteString) import qualified Data.ByteString.Base64.URL as B64U import Data.ByteString.Builder (Builder) import qualified Data.ByteString.Char8 as B import Data.Functor (($>)) -import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Map.Strict as M -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, isNothing) import Data.Text (Text) import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.Text.Encoding (encodeUtf8) import Data.Word (Word16, Word32) import qualified Network.HTTP.Types as N +import Network.HTTP2.Client (HTTP2Error (..)) import Network.HTTP2.Server (responseStreaming) -import Network.Socket (SockAddr (..), hostAddressToTuple) +import qualified Paths_simplex_chat as SC import Simplex.Chat.Archive (archiveFilesFolder) import Simplex.Chat.Controller import Simplex.Chat.Files import Simplex.Chat.Messages (chatNameStr) +import Simplex.Chat.Remote.AppVersion import Simplex.Chat.Remote.Protocol -import Simplex.Chat.Remote.RevHTTP (announceRevHTTP2, attachHTTP2Server) +import Simplex.Chat.Remote.RevHTTP (attachHTTP2Server, attachRevHTTP2Client) import Simplex.Chat.Remote.Transport import Simplex.Chat.Remote.Types import Simplex.Chat.Store.Files import Simplex.Chat.Store.Remote import Simplex.Chat.Store.Shared -import Simplex.Chat.Types (User (..)) +import Simplex.Chat.Types import Simplex.Chat.Util (encryptFile) import Simplex.FileTransfer.Description (FileDigest (..)) +import Simplex.Messaging.Agent +import Simplex.Messaging.Agent.Protocol (AgentErrorType (RCP)) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..)) import qualified Simplex.Messaging.Crypto.File as CF -import Simplex.Messaging.Encoding (smpDecode) import Simplex.Messaging.Encoding.String (StrEncoding (..)) import qualified Simplex.Messaging.TMap as TM -import Simplex.Messaging.Transport (tlsUniq) import Simplex.Messaging.Transport.Client (TransportHost (..)) -import Simplex.Messaging.Transport.Credentials (genCredentials, tlsCredentials) +import Simplex.Messaging.Transport.HTTP2.Client (HTTP2ClientError, closeHTTP2Client) import Simplex.Messaging.Transport.HTTP2.File (hSendFile) import Simplex.Messaging.Transport.HTTP2.Server (HTTP2Request (..)) -import Simplex.Messaging.Util (ifM, liftEitherError, liftEitherWith, liftError, liftIOEither, tryAllErrors, tshow, ($>>=), (<$$>)) -import qualified Simplex.RemoteControl.Discovery as Discovery +import Simplex.Messaging.Util +import Simplex.RemoteControl.Client +import Simplex.RemoteControl.Invitation (RCInvitation (..), RCSignedInvitation (..)) import Simplex.RemoteControl.Types import System.FilePath (takeFileName, ()) import UnliftIO -import UnliftIO.Concurrent (threadDelay) +import UnliftIO.Concurrent (forkIO) import UnliftIO.Directory (copyFile, createDirectoryIfMissing, renameFile) +-- when acting as host +minRemoteCtrlVersion :: AppVersion +minRemoteCtrlVersion = AppVersion [5, 4, 0, 2] + +-- when acting as controller +minRemoteHostVersion :: AppVersion +minRemoteHostVersion = AppVersion [5, 4, 0, 2] + +currentAppVersion :: AppVersion +currentAppVersion = AppVersion SC.version + +ctrlAppVersionRange :: AppVersionRange +ctrlAppVersionRange = mkAppVersionRange minRemoteHostVersion currentAppVersion + +hostAppVersionRange :: AppVersionRange +hostAppVersionRange = mkAppVersionRange minRemoteCtrlVersion currentAppVersion + -- * Desktop side -getRemoteHostSession :: ChatMonad m => RemoteHostId -> m RemoteHostSession -getRemoteHostSession rhId = withRemoteHostSession rhId $ \_ s -> pure $ Right s - -withRemoteHostSession :: ChatMonad m => RemoteHostId -> (TM.TMap RemoteHostId RemoteHostSession -> RemoteHostSession -> STM (Either ChatError a)) -> m a -withRemoteHostSession rhId = withRemoteHostSession_ rhId missing +getRemoteHostClient :: ChatMonad m => RemoteHostId -> m RemoteHostClient +getRemoteHostClient rhId = withRemoteHostSession rhKey $ \case + s@RHSessionConnected {rhClient} -> Right (rhClient, s) + _ -> Left $ ChatErrorRemoteHost rhKey RHEBadState where - missing _ = pure . Left $ ChatErrorRemoteHost rhId RHMissing + rhKey = RHId rhId -withNoRemoteHostSession :: ChatMonad m => RemoteHostId -> (TM.TMap RemoteHostId RemoteHostSession -> STM (Either ChatError a)) -> m a -withNoRemoteHostSession rhId action = withRemoteHostSession_ rhId action busy - where - busy _ _ = pure . Left $ ChatErrorRemoteHost rhId RHBusy +withRemoteHostSession :: ChatMonad m => RHKey -> (RemoteHostSession -> Either ChatError (a, RemoteHostSession)) -> m a +withRemoteHostSession rhKey state = withRemoteHostSession_ rhKey $ maybe (Left $ ChatErrorRemoteHost rhKey $ RHEMissing) ((second . second) Just . state) --- | Atomically process controller state wrt. specific remote host session -withRemoteHostSession_ :: ChatMonad m => RemoteHostId -> (TM.TMap RemoteHostId RemoteHostSession -> STM (Either ChatError a)) -> (TM.TMap RemoteHostId RemoteHostSession -> RemoteHostSession -> STM (Either ChatError a)) -> m a -withRemoteHostSession_ rhId missing present = do +withRemoteHostSession_ :: ChatMonad m => RHKey -> (Maybe RemoteHostSession -> Either ChatError (a, Maybe RemoteHostSession)) -> m a +withRemoteHostSession_ rhKey state = do sessions <- asks remoteHostSessions - liftIOEither . atomically $ TM.lookup rhId sessions >>= maybe (missing sessions) (present sessions) + r <- atomically $ do + s <- TM.lookup rhKey sessions + case state s of + Left e -> pure $ Left e + Right (a, s') -> Right a <$ maybe (TM.delete rhKey) (TM.insert rhKey) s' sessions + liftEither r -startRemoteHost :: ChatMonad m => RemoteHostId -> m () -startRemoteHost rhId = do - rh <- withStore (`getRemoteHost` rhId) - tasks <- startRemoteHostSession rh - logInfo $ "Remote host session starting for " <> tshow rhId - asyncRegistered tasks $ - run rh tasks `catchAny` \err -> do - logError $ "Remote host session startup failed for " <> tshow rhId <> ": " <> tshow err - cancelTasks tasks - chatModifyVar remoteHostSessions $ M.delete rhId - throwError $ fromMaybe (mkChatError err) $ fromException err +setNewRemoteHostId :: ChatMonad m => RHKey -> RemoteHostId -> m () +setNewRemoteHostId rhKey rhId = do + sessions <- asks remoteHostSessions + r <- atomically $ do + TM.lookupDelete rhKey sessions >>= \case + Nothing -> pure $ Left $ ChatErrorRemoteHost rhKey RHEMissing + Just s -> Right () <$ TM.insert (RHId rhId) s sessions + liftEither r + +startRemoteHost' :: ChatMonad m => Maybe (RemoteHostId, Bool) -> m (Maybe RemoteHostInfo, RCSignedInvitation) +startRemoteHost' rh_ = do + (rhKey, multicast, remoteHost_, pairing) <- case rh_ of + Just (rhId, multicast) -> do + rh@RemoteHost {hostPairing} <- withStore $ \db -> getRemoteHost db rhId + pure (RHId rhId, multicast, Just $ remoteHostInfo rh True, hostPairing) -- get from the database, start multicast if requested + Nothing -> (RHNew,False,Nothing,) <$> rcNewHostPairing + withRemoteHostSession_ rhKey $ maybe (Right ((), Just RHSessionStarting)) (\_ -> Left $ ChatErrorRemoteHost rhKey RHEBusy) + ctrlAppInfo <- mkCtrlAppInfo + (invitation, rchClient, vars) <- withAgent $ \a -> rcConnectHost a pairing (J.toJSON ctrlAppInfo) multicast + rhsWaitSession <- async $ waitForSession rhKey remoteHost_ rchClient vars + let rhs = RHPendingSession {rhKey, rchClient, rhsWaitSession, remoteHost_} + withRemoteHostSession rhKey $ \case + RHSessionStarting -> Right ((), RHSessionConnecting rhs) + _ -> Left $ ChatErrorRemoteHost rhKey RHEBadState + pure (remoteHost_, invitation) where - -- logInfo $ "Remote host session starting for " <> tshow rhId - - run :: ChatMonad m => RemoteHost -> Tasks -> m () - run rh@RemoteHost {storePath} tasks = do - (fingerprint, credentials) <- liftIO $ genSessionCredentials rh - cleanupIO <- toIO $ do - logNote $ "Remote host session stopping for " <> tshow rhId - cancelTasks tasks -- cancel our tasks anyway - chatModifyVar currentRemoteHost $ \cur -> if cur == Just rhId then Nothing else cur -- only wipe the closing RH - withRemoteHostSession rhId $ \sessions _ -> Right <$> TM.delete rhId sessions - toView (CRRemoteHostStopped rhId) -- only signal "stopped" when the session is unregistered cleanly - -- block until some client is connected or an error happens - logInfo $ "Remote host session connecting for " <> tshow rhId - rcName <- chatReadVar localDeviceName - localAddr <- asks multicastSubscribers >>= Discovery.getLocalAddress >>= maybe (throwError . ChatError $ CEInternalError "unable to get local address") pure - (dhKey, sigKey, ann, oob) <- Discovery.startSession (if rcName == "" then Nothing else Just rcName) (localAddr, read Discovery.DISCOVERY_PORT) fingerprint - toView CRRemoteHostStarted {remoteHost = remoteHostInfo rh True, sessionOOB = decodeUtf8 $ strEncode oob} - httpClient <- liftEitherError (ChatErrorRemoteCtrl . RCEHTTP2Error . show) $ announceRevHTTP2 tasks (sigKey, ann) credentials cleanupIO - logInfo $ "Remote host session connected for " <> tshow rhId - -- test connection and establish a protocol layer - remoteHostClient <- liftRH rhId $ createRemoteHostClient httpClient dhKey rcName - -- set up message polling + mkCtrlAppInfo = do + deviceName <- chatReadVar localDeviceName + pure CtrlAppInfo {appVersionRange = ctrlAppVersionRange, deviceName} + parseHostAppInfo RCHostHello {app = hostAppInfo} rhKey = do + HostAppInfo {deviceName, appVersion} <- + liftEitherWith (ChatErrorRemoteHost rhKey . RHEProtocolError . RPEInvalidJSON) $ JT.parseEither J.parseJSON hostAppInfo + unless (isAppCompatible appVersion ctrlAppVersionRange) $ throwError $ ChatErrorRemoteHost rhKey $ RHEBadVersion appVersion + pure deviceName + waitForSession :: ChatMonad m => RHKey -> Maybe RemoteHostInfo -> RCHostClient -> RCStepTMVar (ByteString, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)) -> m () + waitForSession rhKey remoteHost_ _rchClient_kill_on_error vars = do + -- TODO handle errors + (sessId, vars') <- takeRCStep vars + toView $ CRRemoteHostSessionCode {remoteHost_, sessionCode = verificationCode sessId} -- display confirmation code, wait for mobile to confirm + (RCHostSession {tls, sessionKeys}, rhHello, pairing') <- takeRCStep vars' + hostDeviceName <- parseHostAppInfo rhHello rhKey + withRemoteHostSession rhKey $ \case + RHSessionConnecting rhs' -> Right ((), RHSessionConfirmed rhs') -- TODO check it's the same session? + _ -> Left $ ChatErrorRemoteHost rhKey RHEBadState -- TODO kill client on error + -- update remoteHost with updated pairing + rhi@RemoteHostInfo {remoteHostId, storePath} <- upsertRemoteHost pairing' remoteHost_ hostDeviceName + let rhKey' = RHId remoteHostId + disconnected <- toIO $ onDisconnected remoteHostId + httpClient <- liftEitherError (httpError rhKey) $ attachRevHTTP2Client disconnected tls + rhClient <- liftRC $ createRemoteHostClient httpClient sessionKeys storePath hostDeviceName + pollAction <- async $ pollEvents remoteHostId rhClient + withRemoteHostSession rhKey' $ \case + RHSessionConfirmed RHPendingSession {} -> Right ((), RHSessionConnected {rhClient, pollAction, storePath}) + _ -> Left $ ChatErrorRemoteHost rhKey' RHEBadState -- TODO kill client on error + chatWriteVar currentRemoteHost $ Just remoteHostId -- this is required for commands to be passed to remote host + toView $ CRRemoteHostConnected rhi + upsertRemoteHost :: ChatMonad m => RCHostPairing -> Maybe RemoteHostInfo -> Text -> m RemoteHostInfo + upsertRemoteHost pairing'@RCHostPairing {knownHost = kh_} rh_ hostDeviceName = do + KnownHostPairing {hostDhPubKey = hostDhPubKey'} <- maybe (throwError . ChatError $ CEInternalError "KnownHost is known after verification") pure kh_ + case rh_ of + Nothing -> do + storePath <- liftIO randomStorePath + rh@RemoteHost {remoteHostId} <- withStore $ \db -> insertRemoteHost db hostDeviceName storePath pairing' >>= getRemoteHost db + setNewRemoteHostId RHNew remoteHostId + pure $ remoteHostInfo rh True + Just rhi@RemoteHostInfo {remoteHostId} -> do + withStore' $ \db -> updateHostPairing db remoteHostId hostDeviceName hostDhPubKey' + pure rhi + onDisconnected :: ChatMonad m => RemoteHostId -> m () + onDisconnected remoteHostId = do + logDebug "HTTP2 client disconnected" + chatModifyVar currentRemoteHost $ \cur -> if cur == Just remoteHostId then Nothing else cur -- only wipe the closing RH + sessions <- asks remoteHostSessions + void . atomically $ TM.lookupDelete (RHId remoteHostId) sessions + toView $ CRRemoteHostStopped remoteHostId + pollEvents :: ChatMonad m => RemoteHostId -> RemoteHostClient -> m () + pollEvents rhId rhClient = do oq <- asks outputQ - asyncRegistered tasks . forever $ do - liftRH rhId (remoteRecv remoteHostClient 1000000) >>= mapM_ (atomically . writeTBQueue oq . (Nothing,Just rhId,)) - -- update session state - logInfo $ "Remote host session started for " <> tshow rhId - chatModifyVar remoteHostSessions $ M.adjust (\rhs -> rhs {remoteHostClient = Just remoteHostClient}) rhId - chatWriteVar currentRemoteHost $ Just rhId - toView $ - CRRemoteHostConnected - RemoteHostInfo - { remoteHostId = rhId, - storePath = storePath, - displayName = hostDeviceName remoteHostClient, - sessionActive = True - } + forever $ do + r_ <- liftRH rhId $ remoteRecv rhClient 10000000 + forM r_ $ \r -> atomically $ writeTBQueue oq (Nothing, Just rhId, r) + httpError :: RHKey -> HTTP2ClientError -> ChatError + httpError rhKey = ChatErrorRemoteHost rhKey . RHEProtocolError . RPEHTTP2 . tshow - genSessionCredentials RemoteHost {caKey, caCert} = do - sessionCreds <- genCredentials (Just parent) (0, 24) "Session" - pure . tlsCredentials $ sessionCreds :| [parent] - where - parent = (C.signatureKeyPair caKey, caCert) +closeRemoteHost :: ChatMonad m => RHKey -> m () +closeRemoteHost rhKey = do + logNote $ "Closing remote host session for " <> tshow rhKey + chatModifyVar currentRemoteHost $ \cur -> if (RHId <$> cur) == Just rhKey then Nothing else cur -- only wipe the closing RH + join . withRemoteHostSession_ rhKey . maybe (Left $ ChatErrorRemoteCtrl RCEInactive) $ + \s -> Right (liftIO $ cancelRemoteHost s, Nothing) --- | Atomically check/register session and prepare its task list -startRemoteHostSession :: ChatMonad m => RemoteHost -> m Tasks -startRemoteHostSession RemoteHost {remoteHostId, storePath} = withNoRemoteHostSession remoteHostId $ \sessions -> do - remoteHostTasks <- newTVar [] - TM.insert remoteHostId RemoteHostSession {remoteHostTasks, storePath, remoteHostClient = Nothing} sessions - pure $ Right remoteHostTasks - -closeRemoteHostSession :: ChatMonad m => RemoteHostId -> m () -closeRemoteHostSession rhId = do - logNote $ "Closing remote host session for " <> tshow rhId - chatModifyVar currentRemoteHost $ \cur -> if cur == Just rhId then Nothing else cur -- only wipe the closing RH - session <- withRemoteHostSession rhId $ \sessions rhs -> Right rhs <$ TM.delete rhId sessions - cancelRemoteHostSession session - -cancelRemoteHostSession :: MonadUnliftIO m => RemoteHostSession -> m () -cancelRemoteHostSession RemoteHostSession {remoteHostTasks, remoteHostClient} = do - cancelTasks remoteHostTasks - mapM_ closeRemoteHostClient remoteHostClient - -createRemoteHost :: ChatMonad m => m RemoteHostInfo -createRemoteHost = do - ((_, caKey), caCert) <- liftIO $ genCredentials Nothing (-25, 24 * 365) "Host" - storePath <- liftIO randomStorePath - let remoteName = "" -- will be passed from remote host in hello - rhId <- withStore' $ \db -> insertRemoteHost db storePath remoteName caKey caCert - rh <- withStore $ \db -> getRemoteHost db rhId - pure $ remoteHostInfo rh False +cancelRemoteHost :: RemoteHostSession -> IO () +cancelRemoteHost = \case + RHSessionStarting -> pure () + RHSessionConnecting rhs -> cancelPendingSession rhs + RHSessionConfirmed rhs -> cancelPendingSession rhs + RHSessionConnected {rhClient = RemoteHostClient {httpClient}, pollAction} -> do + uninterruptibleCancel pollAction + closeHTTP2Client httpClient + where + cancelPendingSession RHPendingSession {rchClient, rhsWaitSession} = do + cancelHostClient rchClient + uninterruptibleCancel rhsWaitSession -- | Generate a random 16-char filepath without / in it by using base64url encoding. randomStorePath :: IO FilePath @@ -184,11 +226,12 @@ listRemoteHosts = do map (rhInfo active) <$> withStore' getRemoteHosts where rhInfo active rh@RemoteHost {remoteHostId} = - remoteHostInfo rh (M.member remoteHostId active) + remoteHostInfo rh (M.member (RHId remoteHostId) active) +-- XXX: replacing hostPairing replaced with sessionActive, could be a ($>) remoteHostInfo :: RemoteHost -> Bool -> RemoteHostInfo -remoteHostInfo RemoteHost {remoteHostId, storePath, displayName} sessionActive = - RemoteHostInfo {remoteHostId, storePath, displayName, sessionActive} +remoteHostInfo RemoteHost {remoteHostId, storePath, hostName} sessionActive = + RemoteHostInfo {remoteHostId, storePath, hostName, sessionActive} deleteRemoteHost :: ChatMonad m => RemoteHostId -> m () deleteRemoteHost rhId = do @@ -202,20 +245,17 @@ deleteRemoteHost rhId = do storeRemoteFile :: forall m. ChatMonad m => RemoteHostId -> Maybe Bool -> FilePath -> m CryptoFile storeRemoteFile rhId encrypted_ localPath = do - RemoteHostSession {remoteHostClient, storePath} <- getRemoteHostSession rhId - case remoteHostClient of - Nothing -> throwError $ ChatErrorRemoteHost rhId RHMissing - Just c@RemoteHostClient {encryptHostFiles} -> do - let encrypt = fromMaybe encryptHostFiles encrypted_ - cf@CryptoFile {filePath} <- if encrypt then encryptLocalFile else pure $ CF.plain localPath - filePath' <- liftRH rhId $ remoteStoreFile c filePath (takeFileName localPath) - hf_ <- chatReadVar remoteHostsFolder - forM_ hf_ $ \hf -> do - let rhf = hf storePath archiveFilesFolder - hPath = rhf takeFileName filePath' - createDirectoryIfMissing True rhf - (if encrypt then renameFile else copyFile) filePath hPath - pure (cf :: CryptoFile) {filePath = filePath'} + c@RemoteHostClient {encryptHostFiles, storePath} <- getRemoteHostClient rhId + let encrypt = fromMaybe encryptHostFiles encrypted_ + cf@CryptoFile {filePath} <- if encrypt then encryptLocalFile else pure $ CF.plain localPath + filePath' <- liftRH rhId $ remoteStoreFile c filePath (takeFileName localPath) + hf_ <- chatReadVar remoteHostsFolder + forM_ hf_ $ \hf -> do + let rhf = hf storePath archiveFilesFolder + hPath = rhf takeFileName filePath' + createDirectoryIfMissing True rhf + (if encrypt then renameFile else copyFile) filePath hPath + pure (cf :: CryptoFile) {filePath = filePath'} where encryptLocalFile :: m CryptoFile encryptLocalFile = do @@ -228,78 +268,69 @@ storeRemoteFile rhId encrypted_ localPath = do getRemoteFile :: ChatMonad m => RemoteHostId -> RemoteFile -> m () getRemoteFile rhId rf = do - RemoteHostSession {remoteHostClient, storePath} <- getRemoteHostSession rhId - case remoteHostClient of - Nothing -> throwError $ ChatErrorRemoteHost rhId RHMissing - Just c -> do - dir <- ( storePath archiveFilesFolder) <$> (maybe getDefaultFilesFolder pure =<< chatReadVar remoteHostsFolder) - createDirectoryIfMissing True dir - liftRH rhId $ remoteGetFile c dir rf + c@RemoteHostClient {storePath} <- getRemoteHostClient rhId + dir <- ( storePath archiveFilesFolder) <$> (maybe getDefaultFilesFolder pure =<< chatReadVar remoteHostsFolder) + createDirectoryIfMissing True dir + liftRH rhId $ remoteGetFile c dir rf -processRemoteCommand :: ChatMonad m => RemoteHostId -> RemoteHostSession -> ChatCommand -> ByteString -> m ChatResponse -processRemoteCommand remoteHostId RemoteHostSession {remoteHostClient = Just rhc} cmd s = case cmd of +processRemoteCommand :: ChatMonad m => RemoteHostId -> RemoteHostClient -> ChatCommand -> ByteString -> m ChatResponse +processRemoteCommand remoteHostId c cmd s = case cmd of SendFile chatName f -> sendFile "/f" chatName f SendImage chatName f -> sendFile "/img" chatName f - _ -> liftRH remoteHostId $ remoteSend rhc s + _ -> liftRH remoteHostId $ remoteSend c s where sendFile cmdName chatName (CryptoFile path cfArgs) = do -- don't encrypt in host if already encrypted locally CryptoFile path' cfArgs' <- storeRemoteFile remoteHostId (cfArgs $> False) path let f = CryptoFile path' (cfArgs <|> cfArgs') -- use local or host encryption - liftRH remoteHostId $ remoteSend rhc $ B.unwords [cmdName, B.pack (chatNameStr chatName), cryptoFileStr f] + liftRH remoteHostId $ remoteSend c $ B.unwords [cmdName, B.pack (chatNameStr chatName), cryptoFileStr f] cryptoFileStr CryptoFile {filePath, cryptoArgs} = maybe "" (\(CFArgs key nonce) -> "key=" <> strEncode key <> " nonce=" <> strEncode nonce <> " ") cryptoArgs <> encodeUtf8 (T.pack filePath) -processRemoteCommand _ _ _ _ = pure $ chatCmdError Nothing "remote command sent before session started" liftRH :: ChatMonad m => RemoteHostId -> ExceptT RemoteProtocolError IO a -> m a -liftRH rhId = liftError (ChatErrorRemoteHost rhId . RHProtocolError) +liftRH rhId = liftError (ChatErrorRemoteHost (RHId rhId) . RHEProtocolError) -- * Mobile side -findKnownRemoteCtrl :: forall m. ChatMonad m => (ByteString -> m ChatResponse) -> m () -findKnownRemoteCtrl execChatCommand = do - logInfo "Starting remote host" - checkNoRemoteCtrlSession -- tiny race with the final @chatWriteVar@ until the setup finishes and supervisor spawned - discovered <- newTVarIO mempty - discoverer <- async $ discoverRemoteCtrls discovered -- TODO extract to a controller service singleton - size <- asks $ tbqSize . config - remoteOutputQ <- newTBQueueIO size - confirmed <- newEmptyTMVarIO - verified <- newEmptyTMVarIO - supervisor <- async $ do - threadDelay 500000 -- give chat controller a chance to reply with "ok" to prevent flaking tests - runHost discovered confirmed verified $ handleRemoteCommand execChatCommand remoteOutputQ - chatWriteVar remoteCtrlSession $ Just RemoteCtrlSession {discoverer, supervisor, hostServer = Nothing, discovered, confirmed, verified, remoteOutputQ} +findKnownRemoteCtrl :: ChatMonad m => m () +findKnownRemoteCtrl = undefined -- do --- | Track remote host lifecycle in controller session state and signal UI on its progress -runHost :: ChatMonad m => TM.TMap C.KeyHash (TransportHost, Word16) -> TMVar RemoteCtrlId -> TMVar (RemoteCtrlId, Text) -> (HTTP2Request -> m ()) -> m () -runHost discovered confirmed verified handleHttp = do - remoteCtrlId <- atomically (readTMVar confirmed) -- wait for discoverRemoteCtrls.process or confirmRemoteCtrl to confirm fingerprint as a known RC - rc@RemoteCtrl {fingerprint} <- withStore (`getRemoteCtrl` remoteCtrlId) - serviceAddress <- atomically $ TM.lookup fingerprint discovered >>= maybe retry pure -- wait for location of the matching fingerprint - toView $ CRRemoteCtrlConnecting $ remoteCtrlInfo rc False - atomically $ writeTVar discovered mempty -- flush unused sources - server <- async $ - -- spawn server for remote protocol commands - Discovery.connectTLSClient serviceAddress fingerprint $ \tls -> do - let sessionCode = decodeUtf8 . strEncode $ tlsUniq tls - toView $ CRRemoteCtrlSessionCode {remoteCtrl = remoteCtrlInfo rc True, sessionCode, newCtrl = False} - userInfo <- atomically $ readTMVar verified - if userInfo == (remoteCtrlId, sessionCode) - then do - toView $ CRRemoteCtrlConnected $ remoteCtrlInfo rc True - attachHTTP2Server handleHttp tls - else do - toView $ CRChatCmdError Nothing $ ChatErrorRemoteCtrl RCEBadVerificationCode - -- the server doesn't enter its loop and waitCatch below falls through - chatModifyVar remoteCtrlSession $ fmap $ \s -> s {hostServer = Just server} - _ <- waitCatch server -- wait for the server to finish - chatWriteVar remoteCtrlSession Nothing - toView CRRemoteCtrlStopped +-- | Use provided OOB link as an annouce +connectRemoteCtrl :: ChatMonad m => RCSignedInvitation -> m () +connectRemoteCtrl inv@RCSignedInvitation {invitation = RCInvitation {ca, app}} = do + (ctrlDeviceName, v) <- parseCtrlAppInfo app + withRemoteCtrlSession_ $ maybe (Right ((), Just RCSessionStarting)) (\_ -> Left $ ChatErrorRemoteCtrl RCEBusy) + rc_ <- withStore' $ \db -> getRemoteCtrlByFingerprint db ca + hostAppInfo <- getHostAppInfo v + (rcsClient, vars) <- withAgent $ \a -> rcConnectCtrlURI a inv (ctrlPairing <$> rc_) (J.toJSON hostAppInfo) + rcsWaitSession <- async $ waitForSession rc_ ctrlDeviceName rcsClient vars + updateRemoteCtrlSession $ \case + RCSessionStarting -> Right RCSessionConnecting {rcsClient, rcsWaitSession} + _ -> Left $ ChatErrorRemoteCtrl RCEBadState -- TODO kill rcsClient + where + waitForSession :: ChatMonad m => Maybe RemoteCtrl -> Text -> RCCtrlClient -> RCStepTMVar (ByteString, RCStepTMVar (RCCtrlSession, RCCtrlPairing)) -> m () + waitForSession rc_ ctrlName rcsClient vars = do + (uniq, rcsWaitConfirmation) <- takeRCStep vars + let sessionCode = verificationCode uniq + toView CRRemoteCtrlSessionCode {remoteCtrl_ = (`remoteCtrlInfo` True) <$> rc_, sessionCode} + updateRemoteCtrlSession $ \case + RCSessionConnecting {rcsWaitSession} -> Right RCSessionPendingConfirmation {ctrlName, rcsClient, sessionCode, rcsWaitSession, rcsWaitConfirmation} + _ -> Left $ ChatErrorRemoteCtrl RCEBadState -- TODO kill rcsClient + parseCtrlAppInfo ctrlAppInfo = do + CtrlAppInfo {deviceName, appVersionRange} <- + liftEitherWith (const $ ChatErrorRemoteCtrl RCEBadInvitation) $ JT.parseEither J.parseJSON ctrlAppInfo + v <- case compatibleAppVersion hostAppVersionRange appVersionRange of + Just (AppCompatible v) -> pure v + Nothing -> throwError $ ChatErrorRemoteCtrl $ RCEBadVersion $ maxVersion appVersionRange + pure (deviceName, v) + getHostAppInfo appVersion = do + hostDeviceName <- chatReadVar localDeviceName + encryptFiles <- chatReadVar encryptLocalFiles + pure HostAppInfo {appVersion, deviceName = hostDeviceName, encoding = localEncoding, encryptFiles} -handleRemoteCommand :: forall m. ChatMonad m => (ByteString -> m ChatResponse) -> TBQueue ChatResponse -> HTTP2Request -> m () -handleRemoteCommand execChatCommand remoteOutputQ HTTP2Request {request, reqBody, sendResponse} = do +handleRemoteCommand :: forall m. ChatMonad m => (ByteString -> m ChatResponse) -> CtrlSessKeys -> TBQueue ChatResponse -> HTTP2Request -> m () +handleRemoteCommand execChatCommand _sessionKeys remoteOutputQ HTTP2Request {request, reqBody, sendResponse} = do logDebug "handleRemoteCommand" liftRC (tryRemoteError parseRequest) >>= \case Right (getNext, rc) -> do @@ -311,7 +342,7 @@ handleRemoteCommand execChatCommand remoteOutputQ HTTP2Request {request, reqBody parseRequest :: ExceptT RemoteProtocolError IO (GetChunk, RemoteCommand) parseRequest = do (header, getNext) <- parseHTTP2Body request reqBody - (getNext,) <$> liftEitherWith (RPEInvalidJSON . T.pack) (J.eitherDecodeStrict' header) + (getNext,) <$> liftEitherWith RPEInvalidJSON (J.eitherDecodeStrict' header) replyError = reply . RRChatResponse . CRChatCmdError Nothing processCommand :: User -> GetChunk -> RemoteCommand -> m () processCommand user getNext = \case @@ -329,6 +360,9 @@ handleRemoteCommand execChatCommand remoteOutputQ HTTP2Request {request, reqBody attach send flush +takeRCStep :: ChatMonad m => RCStepTMVar a -> m a +takeRCStep = liftEitherError (\e -> ChatErrorAgent {agentError = RCP e, connectionEntity_ = Nothing}) . atomically . takeTMVar + type GetChunk = Int -> IO ByteString type SendChunk = Builder -> IO () @@ -393,83 +427,79 @@ handleGetFile User {userId} RemoteFile {userId = commandUserId, fileId, sent, fi discoverRemoteCtrls :: ChatMonad m => TM.TMap C.KeyHash (TransportHost, Word16) -> m () discoverRemoteCtrls discovered = do - subscribers <- asks multicastSubscribers - Discovery.withListener subscribers run - where - run sock = receive sock >>= process sock - - receive sock = - Discovery.recvAnnounce sock >>= \case - (SockAddrInet _sockPort sockAddr, sigAnnBytes) -> case smpDecode sigAnnBytes of - Right (SignedAnnounce ann _sig) -> pure (sockAddr, ann) - Left _ -> receive sock -- TODO it is probably better to report errors to view here - _nonV4 -> receive sock - - process sock (sockAddr, Announce {caFingerprint, serviceAddress = (annAddr, port)}) = do - unless (annAddr == sockAddr) $ logError "Announced address doesn't match socket address" - let addr = THIPv4 (hostAddressToTuple sockAddr) - ifM - (atomically $ TM.member caFingerprint discovered) - (logDebug $ "Fingerprint already known: " <> tshow (addr, caFingerprint)) - ( do - logInfo $ "New fingerprint announced: " <> tshow (addr, caFingerprint) - atomically $ TM.insert caFingerprint (addr, port) discovered - ) - -- TODO we check fingerprint for duplicate where id doesn't matter - to prevent re-insert - and don't check to prevent duplicate events, - -- so UI now will have to check for duplicates again - withStore' (`getRemoteCtrlByFingerprint` caFingerprint) >>= \case - Nothing -> toView $ CRRemoteCtrlAnnounce caFingerprint -- unknown controller, ui "register" action required - -- TODO Maybe Bool is very confusing - the intent is very unclear here - Just found@RemoteCtrl {remoteCtrlId, accepted = storedChoice} -> case storedChoice of - Nothing -> toView $ CRRemoteCtrlFound $ remoteCtrlInfo found False -- first-time controller, ui "accept" action required - Just False -> run sock -- restart, skipping a rejected item - Just True -> - chatReadVar remoteCtrlSession >>= \case - Nothing -> toView . CRChatError Nothing . ChatError $ CEInternalError "Remote host found without running a session" - Just RemoteCtrlSession {confirmed} -> atomically $ void $ tryPutTMVar confirmed remoteCtrlId -- previously accepted controller, connect automatically + error "TODO: discoverRemoteCtrls" listRemoteCtrls :: ChatMonad m => m [RemoteCtrlInfo] listRemoteCtrls = do - active <- - chatReadVar remoteCtrlSession $>>= \RemoteCtrlSession {confirmed} -> - atomically $ tryReadTMVar confirmed + active <- chatReadVar remoteCtrlSession >>= \case + Just RCSessionConnected {remoteCtrlId} -> pure $ Just remoteCtrlId + _ -> pure Nothing map (rcInfo active) <$> withStore' getRemoteCtrls where rcInfo activeRcId rc@RemoteCtrl {remoteCtrlId} = remoteCtrlInfo rc $ activeRcId == Just remoteCtrlId remoteCtrlInfo :: RemoteCtrl -> Bool -> RemoteCtrlInfo -remoteCtrlInfo RemoteCtrl {remoteCtrlId, displayName, fingerprint, accepted} sessionActive = - RemoteCtrlInfo {remoteCtrlId, displayName, fingerprint, accepted, sessionActive} +remoteCtrlInfo RemoteCtrl {remoteCtrlId, ctrlName} sessionActive = + RemoteCtrlInfo {remoteCtrlId, ctrlName, sessionActive} +-- XXX: only used for multicast confirmRemoteCtrl :: ChatMonad m => RemoteCtrlId -> m () -confirmRemoteCtrl rcId = do +confirmRemoteCtrl _rcId = do -- TODO check it exists, check the ID is the same as in session - RemoteCtrlSession {confirmed} <- getRemoteCtrlSession - withStore' $ \db -> markRemoteCtrlResolution db rcId True - atomically . void $ tryPutTMVar confirmed rcId -- the remote host can now proceed with connection + -- RemoteCtrlSession {confirmed} <- getRemoteCtrlSession + -- withStore' $ \db -> markRemoteCtrlResolution db rcId True + -- atomically . void $ tryPutTMVar confirmed rcId -- the remote host can now proceed with connection + undefined -verifyRemoteCtrlSession :: ChatMonad m => RemoteCtrlId -> Text -> m () -verifyRemoteCtrlSession rcId sessId = do - RemoteCtrlSession {verified} <- getRemoteCtrlSession - void . atomically $ tryPutTMVar verified (rcId, sessId) +-- | Take a look at emoji of tlsunique, commit pairing, and start session server +verifyRemoteCtrlSession :: ChatMonad m => (ByteString -> m ChatResponse) -> Text -> m RemoteCtrlInfo +verifyRemoteCtrlSession execChatCommand sessCode' = do + (client, ctrlName, sessionCode, vars) <- + getRemoteCtrlSession >>= \case + RCSessionPendingConfirmation {rcsClient, ctrlName, sessionCode, rcsWaitConfirmation} -> pure (rcsClient, ctrlName, sessionCode, rcsWaitConfirmation) + _ -> throwError $ ChatErrorRemoteCtrl RCEBadState + let verified = sameVerificationCode sessCode' sessionCode + liftIO $ confirmCtrlSession client verified + unless verified $ throwError $ ChatErrorRemoteCtrl RCEBadVerificationCode + (rcsSession@RCCtrlSession {tls, sessionKeys}, rcCtrlPairing) <- takeRCStep vars + rc@RemoteCtrl {remoteCtrlId} <- withStore $ \db -> do + rc_ <- liftIO $ getRemoteCtrlByFingerprint db (ctrlFingerprint rcCtrlPairing) + case rc_ of + Nothing -> insertRemoteCtrl db ctrlName rcCtrlPairing >>= getRemoteCtrl db + Just rc@RemoteCtrl {remoteCtrlId} -> do + liftIO $ updateCtrlPairingKeys db remoteCtrlId (dhPrivKey rcCtrlPairing) + pure rc + remoteOutputQ <- asks (tbqSize . config) >>= newTBQueueIO + http2Server <- async $ attachHTTP2Server tls $ handleRemoteCommand execChatCommand sessionKeys remoteOutputQ + withRemoteCtrlSession $ \case + RCSessionPendingConfirmation {} -> Right ((), RCSessionConnected {remoteCtrlId, rcsClient = client, rcsSession, http2Server, remoteOutputQ}) + _ -> Left $ ChatErrorRemoteCtrl RCEBadState + void . forkIO $ do + waitCatch http2Server >>= \case + Left err | Just (BadThingHappen innerErr) <- fromException err -> logWarn $ "HTTP2 server crashed with internal " <> tshow innerErr + Left err | isNothing (fromException @AsyncCancelled err) -> logError $ "HTTP2 server crashed with " <> tshow err + _ -> logInfo "HTTP2 server stopped" + toView CRRemoteCtrlStopped + pure $ remoteCtrlInfo rc True stopRemoteCtrl :: ChatMonad m => m () -stopRemoteCtrl = do - rcs <- getRemoteCtrlSession - cancelRemoteCtrlSession rcs $ chatWriteVar remoteCtrlSession Nothing +stopRemoteCtrl = + join . withRemoteCtrlSession_ . maybe (Left $ ChatErrorRemoteCtrl RCEInactive) $ + \s -> Right (liftIO $ cancelRemoteCtrl s, Nothing) -cancelRemoteCtrlSession_ :: MonadUnliftIO m => RemoteCtrlSession -> m () -cancelRemoteCtrlSession_ rcs = cancelRemoteCtrlSession rcs $ pure () - -cancelRemoteCtrlSession :: MonadUnliftIO m => RemoteCtrlSession -> m () -> m () -cancelRemoteCtrlSession RemoteCtrlSession {discoverer, supervisor, hostServer} cleanup = 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 - cleanup +cancelRemoteCtrl :: RemoteCtrlSession -> IO () +cancelRemoteCtrl = \case + RCSessionStarting -> pure () + RCSessionConnecting {rcsClient, rcsWaitSession} -> do + cancelCtrlClient rcsClient + uninterruptibleCancel rcsWaitSession + RCSessionPendingConfirmation {rcsClient, rcsWaitSession} -> do + cancelCtrlClient rcsClient + uninterruptibleCancel rcsWaitSession + RCSessionConnected {rcsClient, http2Server} -> do + cancelCtrlClient rcsClient + uninterruptibleCancel http2Server deleteRemoteCtrl :: ChatMonad m => RemoteCtrlId -> m () deleteRemoteCtrl rcId = do @@ -485,6 +515,23 @@ checkNoRemoteCtrlSession :: ChatMonad m => m () checkNoRemoteCtrlSession = chatReadVar remoteCtrlSession >>= maybe (pure ()) (\_ -> throwError $ ChatErrorRemoteCtrl RCEBusy) +withRemoteCtrlSession :: ChatMonad m => (RemoteCtrlSession -> Either ChatError (a, RemoteCtrlSession)) -> m a +withRemoteCtrlSession state = withRemoteCtrlSession_ $ maybe (Left $ ChatErrorRemoteCtrl RCEInactive) ((second . second) Just . state) + +-- | Atomically process controller state wrt. specific remote ctrl session +withRemoteCtrlSession_ :: ChatMonad m => (Maybe RemoteCtrlSession -> Either ChatError (a, Maybe RemoteCtrlSession)) -> m a +withRemoteCtrlSession_ state = do + session <- asks remoteCtrlSession + r <- + atomically $ stateTVar session $ \s -> + case state s of + Left e -> (Left e, s) + Right (a, s') -> (Right a, s') + liftEither r + +updateRemoteCtrlSession :: ChatMonad m => (RemoteCtrlSession -> Either ChatError RemoteCtrlSession) -> m () +updateRemoteCtrlSession state = withRemoteCtrlSession $ fmap ((),) . state + utf8String :: [Char] -> ByteString utf8String = encodeUtf8 . T.pack {-# INLINE utf8String #-} diff --git a/src/Simplex/Chat/Remote/AppVersion.hs b/src/Simplex/Chat/Remote/AppVersion.hs new file mode 100644 index 0000000000..a8943968d5 --- /dev/null +++ b/src/Simplex/Chat/Remote/AppVersion.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} + +module Simplex.Chat.Remote.AppVersion + ( AppVersionRange (minVersion, maxVersion), + AppVersion (..), + pattern AppCompatible, + mkAppVersionRange, + compatibleAppVersion, + isAppCompatible, + ) + where + +import Data.Aeson (FromJSON (..), ToJSON (..)) +import qualified Data.Aeson as J +import qualified Data.Aeson.Encoding as JE +import qualified Data.Aeson.TH as JQ +import qualified Data.Text as T +import Data.Version (parseVersion, showVersion) +import qualified Data.Version as V +import Simplex.Messaging.Parsers (defaultJSON) +import Text.ParserCombinators.ReadP (readP_to_S) + +newtype AppVersion = AppVersion V.Version + deriving (Eq, Ord, Show) + +instance ToJSON AppVersion where + toJSON (AppVersion v) = J.String . T.pack $ showVersion v + toEncoding (AppVersion v) = JE.text . T.pack $ showVersion v + +instance FromJSON AppVersion where + parseJSON = J.withText "AppVersion" $ parse . T.unpack + where + parse s = case filter (null . snd) $ readP_to_S parseVersion s of + (v, _) : _ -> pure $ AppVersion v + _ -> fail $ "bad AppVersion: " <> s + +data AppVersionRange = AppVRange + { minVersion :: AppVersion, + maxVersion :: AppVersion + } + +mkAppVersionRange :: AppVersion -> AppVersion -> AppVersionRange +mkAppVersionRange v1 v2 + | v1 <= v2 = AppVRange v1 v2 + | otherwise = error "invalid version range" + +newtype AppCompatible a = AppCompatible_ a + +pattern AppCompatible :: a -> AppCompatible a +pattern AppCompatible a <- AppCompatible_ a + +{-# COMPLETE AppCompatible #-} + +isAppCompatible :: AppVersion -> AppVersionRange -> Bool +isAppCompatible v (AppVRange v1 v2) = v1 <= v && v <= v2 + +isCompatibleAppRange :: AppVersionRange -> AppVersionRange -> Bool +isCompatibleAppRange (AppVRange min1 max1) (AppVRange min2 max2) = min1 <= max2 && min2 <= max1 + +compatibleAppVersion :: AppVersionRange -> AppVersionRange -> Maybe (AppCompatible AppVersion) +compatibleAppVersion vr1 vr2 = + min (maxVersion vr1) (maxVersion vr2) `mkCompatibleIf` isCompatibleAppRange vr1 vr2 + +mkCompatibleIf :: AppVersion -> Bool -> Maybe (AppCompatible AppVersion) +v `mkCompatibleIf` cond = if cond then Just $ AppCompatible_ v else Nothing + +$(JQ.deriveJSON defaultJSON ''AppVersionRange) diff --git a/src/Simplex/Chat/Remote/Protocol.hs b/src/Simplex/Chat/Remote/Protocol.hs index 45bea60663..2868a45107 100644 --- a/src/Simplex/Chat/Remote/Protocol.hs +++ b/src/Simplex/Chat/Remote/Protocol.hs @@ -19,7 +19,7 @@ import qualified Data.Aeson.KeyMap as JM import Data.Aeson.TH (deriveJSON) import qualified Data.Aeson.Types as JT import Data.ByteString (ByteString) -import Data.ByteString.Builder (Builder, word32BE, lazyByteString) +import Data.ByteString.Builder (Builder, lazyByteString, word32BE) import qualified Data.ByteString.Lazy as LB import Data.String (fromString) import Data.Text (Text) @@ -39,7 +39,8 @@ import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..), HTTP2BodyChunk, getBod import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client, HTTP2Response (..), closeHTTP2Client, sendRequestDirect) import Simplex.Messaging.Transport.HTTP2.File (hSendFile) import Simplex.Messaging.Util (liftEitherError, liftEitherWith, tshow) -import System.FilePath ((), takeFileName) +import Simplex.RemoteControl.Types (HostSessKeys) +import System.FilePath (takeFileName, ()) import UnliftIO data RemoteCommand @@ -66,14 +67,21 @@ $(deriveJSON (taggedObjectJSON $ dropPrefix "RR") ''RemoteResponse) -- * Client side / desktop -createRemoteHostClient :: HTTP2Client -> dh -> Text -> ExceptT RemoteProtocolError IO RemoteHostClient -createRemoteHostClient httpClient todo'dhKey desktopName = do +createRemoteHostClient :: HTTP2Client -> HostSessKeys -> FilePath -> Text -> ExceptT RemoteProtocolError IO RemoteHostClient +createRemoteHostClient httpClient sessionKeys storePath desktopName = do logDebug "Sending initial hello" sendRemoteCommand' httpClient localEncoding Nothing RCHello {deviceName = desktopName} >>= \case RRHello {encoding, deviceName = mobileName, encryptFiles} -> do logDebug "Got initial hello" when (encoding == PEKotlin && localEncoding == PESwift) $ throwError RPEIncompatibleEncoding - pure RemoteHostClient {hostEncoding = encoding, hostDeviceName = mobileName, httpClient, encryptHostFiles = encryptFiles} + pure RemoteHostClient + { hostEncoding = encoding, + hostDeviceName = mobileName, + httpClient, + encryptHostFiles = encryptFiles, + sessionKeys, + storePath + } r -> badResponse r closeRemoteHostClient :: MonadIO m => RemoteHostClient -> m () diff --git a/src/Simplex/Chat/Remote/RevHTTP.hs b/src/Simplex/Chat/Remote/RevHTTP.hs index 08c844dcf0..a37d77e20a 100644 --- a/src/Simplex/Chat/Remote/RevHTTP.hs +++ b/src/Simplex/Chat/Remote/RevHTTP.hs @@ -8,37 +8,20 @@ module Simplex.Chat.Remote.RevHTTP where -import Simplex.RemoteControl.Discovery -import Simplex.RemoteControl.Types -import Control.Logger.Simple -import qualified Network.TLS as TLS -import qualified Simplex.Messaging.Crypto as C -import qualified Simplex.Messaging.Transport as Transport +import Simplex.Messaging.Transport (TLS) import Simplex.Messaging.Transport.HTTP2 (defaultHTTP2BufferSize, getHTTP2Body) import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client, HTTP2ClientError (..), attachHTTP2Client, bodyHeadSize, connTimeout, defaultHTTP2ClientConfig) import Simplex.Messaging.Transport.HTTP2.Server (HTTP2Request (..), runHTTP2ServerWith) -import Simplex.Messaging.Util (ifM) +import Simplex.RemoteControl.Discovery import UnliftIO -announceRevHTTP2 :: MonadUnliftIO m => Tasks -> (C.PrivateKeyEd25519, Announce) -> TLS.Credentials -> m () -> m (Either HTTP2ClientError HTTP2Client) -announceRevHTTP2 = announceCtrl runHTTP2Client - --- | 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 = - ifM (isEmptyMVar clientVar) - attachClient - (logError "HTTP2 session already started on this listener") +attachRevHTTP2Client :: IO () -> TLS -> IO (Either HTTP2ClientError HTTP2Client) +attachRevHTTP2Client disconnected = attachHTTP2Client config ANY_ADDR_V4 "0" disconnected defaultHTTP2BufferSize where - attachClient = do - client <- attachHTTP2Client config ANY_ADDR_V4 DISCOVERY_PORT (putMVar finishedVar ()) defaultHTTP2BufferSize tls - putMVar clientVar client - readMVar finishedVar - -- TODO connection timeout config = defaultHTTP2ClientConfig {bodyHeadSize = doNotPrefetchHead, connTimeout = maxBound} -attachHTTP2Server :: (MonadUnliftIO m) => (HTTP2Request -> m ()) -> Transport.TLS -> m () -attachHTTP2Server processRequest tls = do +attachHTTP2Server :: MonadUnliftIO m => TLS -> (HTTP2Request -> m ()) -> m () +attachHTTP2Server tls processRequest = do withRunInIO $ \unlift -> runHTTP2ServerWith defaultHTTP2BufferSize ($ tls) $ \sessionId r sendResponse -> do reqBody <- getHTTP2Body r doNotPrefetchHead diff --git a/src/Simplex/Chat/Remote/Types.hs b/src/Simplex/Chat/Remote/Types.hs index dcf70ab714..d9aa9d50bf 100644 --- a/src/Simplex/Chat/Remote/Types.hs +++ b/src/Simplex/Chat/Remote/Types.hs @@ -9,34 +9,45 @@ module Simplex.Chat.Remote.Types where +import Control.Concurrent.Async (Async) import Control.Exception (Exception) import qualified Data.Aeson.TH as J import Data.Int (Int64) import Data.Text (Text) -import qualified Simplex.Messaging.Crypto as C +import Simplex.Chat.Remote.AppVersion import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, sumTypeJSON) import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client) -import Simplex.RemoteControl.Types (Tasks) +import Simplex.RemoteControl.Client +import Simplex.RemoteControl.Types import Simplex.Messaging.Crypto.File (CryptoFile) data RemoteHostClient = RemoteHostClient { hostEncoding :: PlatformEncoding, hostDeviceName :: Text, httpClient :: HTTP2Client, - encryptHostFiles :: Bool - } - -data RemoteHostSession = RemoteHostSession - { remoteHostTasks :: Tasks, - remoteHostClient :: Maybe RemoteHostClient, + sessionKeys :: HostSessKeys, + encryptHostFiles :: Bool, storePath :: FilePath } +data RHPendingSession = RHPendingSession + { rhKey :: RHKey, + rchClient :: RCHostClient, + rhsWaitSession :: Async (), + remoteHost_ :: Maybe RemoteHostInfo + } + +data RemoteHostSession + = RHSessionStarting + | RHSessionConnecting {rhPendingSession :: RHPendingSession} + | RHSessionConfirmed {rhPendingSession :: RHPendingSession} + | RHSessionConnected {rhClient :: RemoteHostClient, pollAction :: Async (), storePath :: FilePath} + data RemoteProtocolError = -- | size prefix is malformed RPEInvalidSize | -- | failed to parse RemoteCommand or RemoteResponse - RPEInvalidJSON {invalidJSON :: Text} + RPEInvalidJSON {invalidJSON :: String} | RPEIncompatibleEncoding | RPEUnexpectedFile | RPENoFile @@ -52,47 +63,39 @@ data RemoteProtocolError type RemoteHostId = Int64 +data RHKey = RHNew | RHId {remoteHostId :: RemoteHostId} + deriving (Eq, Ord, Show) + +-- | Storable/internal remote host data data RemoteHost = RemoteHost { remoteHostId :: RemoteHostId, + hostName :: Text, storePath :: FilePath, - displayName :: Text, - -- | Credentials signing key for root and session certs - caKey :: C.APrivateSignKey, - -- | A stable part of TLS credentials used in remote session - caCert :: C.SignedCertificate, - contacted :: Bool + hostPairing :: RCHostPairing } - deriving (Show) - -data RemoteCtrlOOB = RemoteCtrlOOB - { fingerprint :: C.KeyHash, - displayName :: Text - } - deriving (Show) +-- | UI-accessible remote host information data RemoteHostInfo = RemoteHostInfo { remoteHostId :: RemoteHostId, + hostName :: Text, storePath :: FilePath, - displayName :: Text, sessionActive :: Bool } deriving (Show) type RemoteCtrlId = Int64 +-- | Storable/internal remote controller data data RemoteCtrl = RemoteCtrl { remoteCtrlId :: RemoteCtrlId, - displayName :: Text, - fingerprint :: C.KeyHash, - accepted :: Maybe Bool + ctrlName :: Text, + ctrlPairing :: RCCtrlPairing } - deriving (Show) +-- | UI-accessible remote controller information data RemoteCtrlInfo = RemoteCtrlInfo { remoteCtrlId :: RemoteCtrlId, - displayName :: Text, - fingerprint :: C.KeyHash, - accepted :: Maybe Bool, + ctrlName :: Text, sessionActive :: Bool } deriving (Show) @@ -117,14 +120,30 @@ data RemoteFile = RemoteFile } deriving (Show) +data CtrlAppInfo = CtrlAppInfo + { appVersionRange :: AppVersionRange, + deviceName :: Text + } + +data HostAppInfo = HostAppInfo + { appVersion :: AppVersion, + deviceName :: Text, + encoding :: PlatformEncoding, + encryptFiles :: Bool -- if the host encrypts files in app storage + } + $(J.deriveJSON defaultJSON ''RemoteFile) $(J.deriveJSON (sumTypeJSON $ dropPrefix "RPE") ''RemoteProtocolError) +$(J.deriveJSON (sumTypeJSON $ dropPrefix "RH") ''RHKey) + $(J.deriveJSON (enumJSON $ dropPrefix "PE") ''PlatformEncoding) $(J.deriveJSON defaultJSON ''RemoteHostInfo) -$(J.deriveJSON defaultJSON ''RemoteCtrl) - $(J.deriveJSON defaultJSON ''RemoteCtrlInfo) + +$(J.deriveJSON defaultJSON ''CtrlAppInfo) + +$(J.deriveJSON defaultJSON ''HostAppInfo) diff --git a/src/Simplex/Chat/Store/Remote.hs b/src/Simplex/Chat/Store/Remote.hs index df7ccd499b..e12b581252 100644 --- a/src/Simplex/Chat/Store/Remote.hs +++ b/src/Simplex/Chat/Store/Remote.hs @@ -1,26 +1,39 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} module Simplex.Chat.Store.Remote where import Control.Monad.Except import Data.Int (Int64) -import Data.Maybe (fromMaybe) import Data.Text (Text) import Database.SQLite.Simple (Only (..)) import qualified Database.SQLite.Simple as SQL +import Database.SQLite.Simple.QQ (sql) import Simplex.Chat.Remote.Types import Simplex.Chat.Store.Shared import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow) import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB import qualified Simplex.Messaging.Crypto as C import Simplex.RemoteControl.Types +import UnliftIO -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) - insertedRowId db +insertRemoteHost :: DB.Connection -> Text -> FilePath -> RCHostPairing -> ExceptT StoreError IO RemoteHostId +insertRemoteHost db hostDeviceName storePath RCHostPairing {caKey, caCert, idPrivKey, knownHost = kh_} = do + KnownHostPairing {hostFingerprint, hostDhPubKey} <- + maybe (throwError SERemoteHostUnknown) pure kh_ + checkConstraint SERemoteHostDuplicateCA . liftIO $ + DB.execute + db + [sql| + INSERT INTO remote_hosts + (host_device_name, store_path, ca_key, ca_cert, id_key, host_fingerprint, host_dh_pub) + VALUES + (?, ?, ?, ?, ?, ?, ?) + |] + (hostDeviceName, storePath, caKey, C.SignedObject caCert, idPrivKey, hostFingerprint, hostDhPubKey) + liftIO $ insertedRowId db getRemoteHosts :: DB.Connection -> IO [RemoteHost] getRemoteHosts db = @@ -31,22 +44,52 @@ getRemoteHost db remoteHostId = ExceptT . firstRow toRemoteHost (SERemoteHostNotFound remoteHostId) $ DB.query db (remoteHostQuery <> " WHERE remote_host_id = ?") (Only remoteHostId) -remoteHostQuery :: SQL.Query -remoteHostQuery = "SELECT remote_host_id, store_path, display_name, ca_key, ca_cert, contacted FROM remote_hosts" +getRemoteHostByFingerprint :: DB.Connection -> C.KeyHash -> IO (Maybe RemoteHost) +getRemoteHostByFingerprint db fingerprint = + maybeFirstRow toRemoteHost $ + DB.query db (remoteHostQuery <> " WHERE host_fingerprint = ?") (Only fingerprint) -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} +remoteHostQuery :: SQL.Query +remoteHostQuery = + [sql| + SELECT remote_host_id, host_device_name, store_path, ca_key, ca_cert, id_key, host_fingerprint, host_dh_pub + FROM remote_hosts + |] + +toRemoteHost :: (Int64, Text, FilePath, C.APrivateSignKey, C.SignedObject C.Certificate, C.PrivateKeyEd25519, C.KeyHash, C.PublicKeyX25519) -> RemoteHost +toRemoteHost (remoteHostId, hostName, storePath, caKey, C.SignedObject caCert, idPrivKey, hostFingerprint, hostDhPubKey) = + RemoteHost {remoteHostId, hostName, storePath, hostPairing} + where + hostPairing = RCHostPairing {caKey, caCert, idPrivKey, knownHost = Just knownHost} + knownHost = KnownHostPairing {hostFingerprint, hostDhPubKey} + +updateHostPairing :: DB.Connection -> RemoteHostId -> Text -> C.PublicKeyX25519 -> IO () +updateHostPairing db rhId hostName hostDhPubKey = + DB.execute + db + [sql| + UPDATE remote_hosts + SET host_device_name = ?, host_dh_pub = ? + WHERE remote_host_id = ? + |] + (hostName, hostDhPubKey, rhId) deleteRemoteHostRecord :: DB.Connection -> RemoteHostId -> IO () deleteRemoteHostRecord db remoteHostId = DB.execute db "DELETE FROM remote_hosts WHERE remote_host_id = ?" (Only remoteHostId) -insertRemoteCtrl :: DB.Connection -> SignedOOB -> IO RemoteCtrlInfo -insertRemoteCtrl db (SignedOOB OOB {deviceName, caFingerprint = fingerprint} _) = do - let displayName = fromMaybe "" deviceName - DB.execute db "INSERT INTO remote_controllers (display_name, fingerprint) VALUES (?,?)" (displayName, fingerprint) - remoteCtrlId <- insertedRowId db - pure RemoteCtrlInfo {remoteCtrlId, displayName, fingerprint, accepted = Nothing, sessionActive = False} +insertRemoteCtrl :: DB.Connection -> Text -> RCCtrlPairing -> ExceptT StoreError IO RemoteCtrlId +insertRemoteCtrl db ctrlDeviceName RCCtrlPairing {caKey, caCert, ctrlFingerprint, idPubKey, dhPrivKey, prevDhPrivKey} = do + checkConstraint SERemoteCtrlDuplicateCA . liftIO $ + DB.execute + db + [sql| + INSERT INTO remote_controllers + (ctrl_device_name, ca_key, ca_cert, ctrl_fingerprint, id_pub, dh_priv_key, prev_dh_priv_key) + VALUES + (?, ?, ?, ?, ?, ?, ?) + |] + (ctrlDeviceName, caKey, C.SignedObject caCert, ctrlFingerprint, idPubKey, dhPrivKey, prevDhPrivKey) + liftIO $ insertedRowId db getRemoteCtrls :: DB.Connection -> IO [RemoteCtrl] getRemoteCtrls db = @@ -55,24 +98,49 @@ getRemoteCtrls db = getRemoteCtrl :: DB.Connection -> RemoteCtrlId -> ExceptT StoreError IO RemoteCtrl getRemoteCtrl db remoteCtrlId = ExceptT . firstRow toRemoteCtrl (SERemoteCtrlNotFound remoteCtrlId) $ - DB.query db (remoteCtrlQuery <> " WHERE remote_controller_id = ?") (Only remoteCtrlId) + DB.query db (remoteCtrlQuery <> " WHERE remote_ctrl_id = ?") (Only remoteCtrlId) getRemoteCtrlByFingerprint :: DB.Connection -> C.KeyHash -> IO (Maybe RemoteCtrl) getRemoteCtrlByFingerprint db fingerprint = maybeFirstRow toRemoteCtrl $ - DB.query db (remoteCtrlQuery <> " WHERE fingerprint = ?") (Only fingerprint) + DB.query db (remoteCtrlQuery <> " WHERE ctrl_fingerprint = ?") (Only fingerprint) remoteCtrlQuery :: SQL.Query -remoteCtrlQuery = "SELECT remote_controller_id, display_name, fingerprint, accepted FROM remote_controllers" +remoteCtrlQuery = + [sql| + SELECT remote_ctrl_id, ctrl_device_name, ca_key, ca_cert, ctrl_fingerprint, id_pub, dh_priv_key, prev_dh_priv_key + FROM remote_controllers + |] -toRemoteCtrl :: (Int64, Text, C.KeyHash, Maybe Bool) -> RemoteCtrl -toRemoteCtrl (remoteCtrlId, displayName, fingerprint, accepted) = - RemoteCtrl {remoteCtrlId, displayName, fingerprint, accepted} +toRemoteCtrl :: + ( RemoteCtrlId, + Text, + C.APrivateSignKey, + C.SignedObject C.Certificate, + C.KeyHash, + C.PublicKeyEd25519, + C.PrivateKeyX25519, + Maybe C.PrivateKeyX25519 + ) -> + RemoteCtrl +toRemoteCtrl (remoteCtrlId, ctrlName, caKey, C.SignedObject caCert, ctrlFingerprint, idPubKey, dhPrivKey, prevDhPrivKey) = + RemoteCtrl + { remoteCtrlId, + ctrlName, + ctrlPairing = RCCtrlPairing {caKey, caCert, ctrlFingerprint, idPubKey, dhPrivKey, prevDhPrivKey} + } -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) +updateCtrlPairingKeys :: DB.Connection -> RemoteCtrlId -> C.PrivateKeyX25519 -> IO () +updateCtrlPairingKeys db rcId dhPrivKey = + DB.execute + db + [sql| + UPDATE remote_controllers + SET dh_priv_key = ?, prev_dh_priv_key = dh_priv_key + WHERE remote_ctrl_id = ? + |] + (dhPrivKey, rcId) deleteRemoteCtrlRecord :: DB.Connection -> RemoteCtrlId -> IO () deleteRemoteCtrlRecord db remoteCtrlId = - DB.execute db "DELETE FROM remote_controllers WHERE remote_controller_id = ?" (Only remoteCtrlId) + DB.execute db "DELETE FROM remote_controllers WHERE remote_ctrl_id = ?" (Only remoteCtrlId) diff --git a/src/Simplex/Chat/Store/Shared.hs b/src/Simplex/Chat/Store/Shared.hs index e72d68b8df..ab7330454e 100644 --- a/src/Simplex/Chat/Store/Shared.hs +++ b/src/Simplex/Chat/Store/Shared.hs @@ -100,7 +100,10 @@ data StoreError | SEContactNotFoundByFileId {fileId :: FileTransferId} | SENoGroupSndStatus {itemId :: ChatItemId, groupMemberId :: GroupMemberId} | SERemoteHostNotFound {remoteHostId :: RemoteHostId} + | SERemoteHostUnknown -- ^ attempting to store KnownHost without a known fingerprint + | SERemoteHostDuplicateCA | SERemoteCtrlNotFound {remoteCtrlId :: RemoteCtrlId} + | SERemoteCtrlDuplicateCA deriving (Show, Exception) $(J.deriveJSON (sumTypeJSON $ dropPrefix "SE") ''StoreError) diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 572403e595..ca47cb15e5 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -277,9 +277,16 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe CRNtfMessages {} -> [] CRRemoteHostCreated RemoteHostInfo {remoteHostId} -> ["remote host " <> sShow remoteHostId <> " created"] CRRemoteHostList hs -> viewRemoteHosts hs - CRRemoteHostStarted {remoteHost = RemoteHostInfo {remoteHostId = rhId}, sessionOOB} -> ["remote host " <> sShow rhId <> " started", "connection code:", plain sessionOOB] - CRRemoteHostSessionCode {remoteHost = RemoteHostInfo {remoteHostId = rhId}, sessionCode} -> - ["remote host " <> sShow rhId <> " is connecting", "Compare session code with host:", plain sessionCode] + CRRemoteHostStarted {remoteHost_, invitation} -> + [ maybe "new remote host started" (\RemoteHostInfo {remoteHostId = rhId} -> "remote host " <> sShow rhId <> " started") remoteHost_, + "Remote session invitation:", + plain invitation + ] + CRRemoteHostSessionCode {remoteHost_, sessionCode} -> + [ maybe "new remote host connecting" (\RemoteHostInfo {remoteHostId = rhId} -> "remote host " <> sShow rhId <> " connecting") remoteHost_, + "Compare session code with host:", + plain sessionCode + ] CRRemoteHostConnected RemoteHostInfo {remoteHostId = rhId} -> ["remote host " <> sShow rhId <> " connected"] CRRemoteHostStopped rhId -> ["remote host " <> sShow rhId <> " stopped"] CRRemoteFileStored rhId (CryptoFile filePath cfArgs_) -> @@ -292,12 +299,15 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe ["remote controller announced", "connection code:", plain $ strEncode fingerprint] CRRemoteCtrlFound rc -> ["remote controller found:", viewRemoteCtrl rc] - CRRemoteCtrlConnecting RemoteCtrlInfo {remoteCtrlId = rcId, displayName = rcName} -> - ["remote controller " <> sShow rcId <> " connecting to " <> plain rcName] - CRRemoteCtrlSessionCode {remoteCtrl = RemoteCtrlInfo {remoteCtrlId = rcId, displayName = rcName}, sessionCode} -> - ["remote controller " <> sShow rcId <> " connected to " <> plain rcName, "Compare session code with controller and use:", "/verify remote ctrl " <> sShow rcId <> " " <> plain sessionCode] - CRRemoteCtrlConnected RemoteCtrlInfo {remoteCtrlId = rcId, displayName = rcName} -> - ["remote controller " <> sShow rcId <> " session started with " <> plain rcName] + CRRemoteCtrlConnecting RemoteCtrlInfo {remoteCtrlId = rcId, ctrlName} -> + ["remote controller " <> sShow rcId <> " connecting to " <> plain ctrlName] + CRRemoteCtrlSessionCode {remoteCtrl_, sessionCode} -> + [ maybe "new remote controller connected" (\RemoteCtrlInfo {remoteCtrlId} -> "remote controller " <> sShow remoteCtrlId <> " connected") remoteCtrl_, + "Compare session code with controller and use:", + "/verify remote ctrl " <> plain sessionCode -- TODO maybe pass rcId + ] + CRRemoteCtrlConnected RemoteCtrlInfo {remoteCtrlId = rcId, ctrlName} -> + ["remote controller " <> sShow rcId <> " session started with " <> plain ctrlName] CRRemoteCtrlStopped -> ["remote controller stopped"] CRSQLResult rows -> map plain rows CRSlowSQLQueries {chatQueries, agentQueries} -> @@ -1681,21 +1691,21 @@ 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 "" + viewRemoteHostInfo RemoteHostInfo {remoteHostId, hostName, sessionActive} = + plain $ tshow remoteHostId <> ". " <> hostName <> 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 "" + viewRemoteCtrlInfo RemoteCtrlInfo {remoteCtrlId, ctrlName, sessionActive} = + plain $ tshow remoteCtrlId <> ". " <> ctrlName <> if sessionActive then " (active)" else "" -- TODO fingerprint, accepted? viewRemoteCtrl :: RemoteCtrlInfo -> StyledString -viewRemoteCtrl RemoteCtrlInfo {remoteCtrlId, displayName} = - plain $ tshow remoteCtrlId <> ". " <> displayName +viewRemoteCtrl RemoteCtrlInfo {remoteCtrlId, ctrlName} = + plain $ tshow remoteCtrlId <> ". " <> ctrlName viewChatError :: ChatLogLevel -> ChatError -> [StyledString] viewChatError logLevel = \case @@ -1843,7 +1853,8 @@ viewChatError logLevel = \case cId :: Connection -> StyledString cId conn = sShow conn.connId ChatErrorRemoteCtrl e -> [plain $ "remote controller error: " <> show e] - ChatErrorRemoteHost rhId e -> [plain $ "remote host " <> show rhId <> " error: " <> show e] + ChatErrorRemoteHost RHNew e -> [plain $ "new remote host error: " <> show e] + ChatErrorRemoteHost (RHId rhId) e -> [plain $ "remote host " <> show rhId <> " error: " <> show e] where fileNotFound fileId = ["file " <> sShow fileId <> " not found"] sqliteError' = \case diff --git a/stack.yaml b/stack.yaml index 9043a56952..4c26936c02 100644 --- a/stack.yaml +++ b/stack.yaml @@ -49,7 +49,7 @@ extra-deps: # - simplexmq-1.0.0@sha256:34b2004728ae396e3ae449cd090ba7410781e2b3cefc59259915f4ca5daa9ea8,8561 # - ../simplexmq - github: simplex-chat/simplexmq - commit: 1a0c4b73de5cda4ac6765dd47e0199238e498d5f + commit: 102487bc4fbb865aac4207d2ba6f2ea77eff3290 - github: kazu-yamamoto/http2 commit: f5525b755ff2418e6e6ecc69e877363b0d0bcaeb # - ../direct-sqlcipher diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs index ea455a0fc1..f9e24727cc 100644 --- a/tests/ChatClient.hs +++ b/tests/ChatClient.hs @@ -91,7 +91,7 @@ termSettings :: VirtualTerminalSettings termSettings = VirtualTerminalSettings { virtualType = "xterm", - virtualWindowSize = pure C.Size {height = 24, width = 1000}, + virtualWindowSize = pure C.Size {height = 24, width = 2250}, virtualEvent = retry, virtualInterrupt = retry } diff --git a/tests/RemoteTests.hs b/tests/RemoteTests.hs index b2e7aa5cb1..83f7eeee5a 100644 --- a/tests/RemoteTests.hs +++ b/tests/RemoteTests.hs @@ -1,13 +1,11 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} module RemoteTests where -import Simplex.Chat.Remote.RevHTTP -import qualified Simplex.RemoteControl.Discovery as Discovery -import Simplex.RemoteControl.Types import ChatClient import ChatTests.Utils import Control.Logger.Simple @@ -16,11 +14,6 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Lazy.Char8 as LB import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Map.Strict as M -import Data.String (fromString) -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 Simplex.Chat.Archive (archiveFilesFolder) import Simplex.Chat.Controller (ChatConfig (..), XFTPFileConfig (..)) @@ -29,12 +22,8 @@ import Simplex.Chat.Mobile.File import Simplex.Chat.Remote.Types import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.File (CryptoFileArgs (..)) -import Simplex.Messaging.Encoding (smpDecode) import Simplex.Messaging.Encoding.String (strEncode) -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 Simplex.Messaging.Util import System.FilePath (()) import Test.Hspec @@ -44,113 +33,35 @@ import UnliftIO.Directory remoteTests :: SpecWith FilePath remoteTests = describe "Remote" $ do - -- it "generates usable credentials" genCredentialsTest - -- it "OOB encoding, decoding, and signatures are correct" oobCodecTest - it "connects announcer with discoverer over reverse-http2" announceDiscoverHttp2Test - it "performs protocol handshake" remoteHandshakeTest - it "performs protocol handshake (again)" remoteHandshakeTest -- leaking servers regression check + describe "protocol handshake" $ do + it "connects with new pairing" remoteHandshakeTest + it "connects with new pairing (again)" remoteHandshakeTest -- leaking servers regression check + it "connects with stored pairing" remoteHandshakeStoredTest it "sends messages" remoteMessageTest describe "remote files" $ do it "store/get/send/receive files" remoteStoreFileTest - it "should sends files from CLI wihtout /store" remoteCLIFileTest - --- * Low-level TLS with ephemeral credentials - --- -- XXX: extract --- genCredentialsTest :: (HasCallStack) => FilePath -> IO () --- genCredentialsTest _tmp = do --- (fingerprint, credentials) <- genTestCredentials --- started <- newEmptyTMVarIO --- bracket (startTLSServer started credentials serverHandler) cancel $ \_server -> do --- ok <- atomically (readTMVar started) --- port <- maybe (error "TLS server failed to start") pure ok --- logNote $ "Assigned port: " <> tshow port --- connectTLSClient ("127.0.0.1", fromIntegral port) fingerprint clientHandler --- where --- serverHandler serverTls = do --- logNote "Sending from server" --- Transport.putLn serverTls "hi client" --- logNote "Reading from server" --- Transport.getLn serverTls `shouldReturn` "hi server" --- clientHandler clientTls = do --- logNote "Sending from client" --- Transport.putLn clientTls "hi server" --- logNote "Reading from client" --- Transport.getLn clientTls `shouldReturn` "hi client" - --- * UDP discovery and rever HTTP2 - --- oobCodecTest :: (HasCallStack) => FilePath -> IO () --- oobCodecTest _tmp = do --- subscribers <- newTMVarIO 0 --- localAddr <- Discovery.getLocalAddress subscribers >>= maybe (fail "unable to get local address") pure --- (fingerprint, _credentials) <- genTestCredentials --- (_dhKey, _sigKey, _ann, signedOOB@(SignedOOB oob _sig)) <- Discovery.startSession (Just "Desktop") (localAddr, read Discovery.DISCOVERY_PORT) fingerprint --- verifySignedOOB signedOOB `shouldBe` True --- strDecode (strEncode oob) `shouldBe` Right oob --- strDecode (strEncode signedOOB) `shouldBe` Right signedOOB - -announceDiscoverHttp2Test :: (HasCallStack) => FilePath -> IO () -announceDiscoverHttp2Test _tmp = do - subscribers <- newTMVarIO 0 - localAddr <- Discovery.getLocalAddress subscribers >>= maybe (fail "unable to get local address") pure - (fingerprint, credentials) <- genTestCredentials - (_dhKey, sigKey, ann, _oob) <- Discovery.startSession (Just "Desktop") (localAddr, read Discovery.DISCOVERY_PORT) fingerprint - tasks <- newTVarIO [] - finished <- newEmptyMVar - controller <- async $ do - logNote "Controller: starting" - bracket - (announceRevHTTP2 tasks (sigKey, ann) credentials (putMVar finished ()) >>= either (fail . show) pure) - closeHTTP2Client - ( \http -> do - logNote "Controller: got client" - sendRequest http (C.requestNoBody "GET" "/" []) (Just 10000000) >>= \case - Left err -> do - logNote "Controller: got error" - fail $ show err - Right HTTP2Response {} -> - logNote "Controller: got response" - ) - host <- async $ Discovery.withListener subscribers $ \sock -> do - (N.SockAddrInet _port addr, sigAnn) <- Discovery.recvAnnounce sock - SignedAnnounce Announce {caFingerprint, serviceAddress=(hostAddr, port)} _sig <- either fail pure $ smpDecode sigAnn - caFingerprint `shouldBe` fingerprint - addr `shouldBe` hostAddr - let service = (THIPv4 $ N.hostAddressToTuple hostAddr, port) - logNote $ "Host: connecting to " <> tshow service - server <- async $ Discovery.connectTLSClient service fingerprint $ \tls -> do - logNote "Host: got tls" - flip attachHTTP2Server tls $ \HTTP2Request {sendResponse} -> do - logNote "Host: got request" - sendResponse $ S.responseNoBody ok200 [] - logNote "Host: sent response" - takeMVar finished `finally` cancel server - logNote "Host: finished" - tasks `registerAsync` controller - tasks `registerAsync` host - (waitBoth host controller `shouldReturn` ((), ())) `finally` cancelTasks tasks + it "should send files from CLI wihtout /store" remoteCLIFileTest -- * Chat commands -remoteHandshakeTest :: (HasCallStack) => FilePath -> IO () -remoteHandshakeTest = testChat2 aliceProfile bobProfile $ \desktop mobile -> do +remoteHandshakeTest :: HasCallStack => FilePath -> IO () +remoteHandshakeTest = testChat2 aliceProfile aliceDesktopProfile $ \mobile desktop -> do desktop ##> "/list remote hosts" desktop <## "No remote hosts" + mobile ##> "/list remote ctrls" + mobile <## "No remote controllers" startRemote mobile desktop - logNote "Session active" - desktop ##> "/list remote hosts" desktop <## "Remote hosts:" - desktop <## "1. (active)" + desktop <## "1. Mobile (active)" + mobile ##> "/list remote ctrls" mobile <## "Remote controllers:" mobile <## "1. My desktop (active)" stopMobile mobile desktop `catchAny` (logError . tshow) - -- TODO: add a case for 'stopDesktop' desktop ##> "/delete remote host 1" desktop <## "ok" @@ -162,7 +73,28 @@ remoteHandshakeTest = testChat2 aliceProfile bobProfile $ \desktop mobile -> do mobile ##> "/list remote ctrls" mobile <## "No remote controllers" -remoteMessageTest :: (HasCallStack) => FilePath -> IO () +remoteHandshakeStoredTest :: HasCallStack => FilePath -> IO () +remoteHandshakeStoredTest = testChat2 aliceProfile aliceDesktopProfile $ \mobile desktop -> do + logNote "Starting new session" + startRemote mobile desktop + stopMobile mobile desktop `catchAny` (logError . tshow) + + logNote "Starting stored session" + startRemoteStored mobile desktop + stopMobile mobile desktop `catchAny` (logError . tshow) + + desktop ##> "/list remote hosts" + desktop <## "Remote hosts:" + desktop <## "1. Mobile" + mobile ##> "/list remote ctrls" + mobile <## "Remote controllers:" + mobile <## "1. My desktop" + + logNote "Starting stored session again" + startRemoteStored mobile desktop + stopMobile mobile desktop `catchAny` (logError . tshow) + +remoteMessageTest :: HasCallStack => FilePath -> IO () remoteMessageTest = testChat3 aliceProfile aliceDesktopProfile bobProfile $ \mobile desktop bob -> do startRemote mobile desktop contactBob desktop bob @@ -204,11 +136,13 @@ remoteStoreFileTest = let bobFiles = "./tests/tmp/bob_files" bob ##> ("/_files_folder " <> bobFiles) bob <## "ok" + startRemote mobile desktop contactBob desktop bob + rhs <- readTVarIO (Controller.remoteHostSessions $ chatController desktop) - desktopHostStore <- case M.lookup 1 rhs of - Just RemoteHostSession {storePath} -> pure $ desktopHostFiles storePath archiveFilesFolder + desktopHostStore <- case M.lookup (RHId 1) rhs of + Just RHSessionConnected {storePath} -> pure $ desktopHostFiles storePath archiveFilesFolder _ -> fail "Host session 1 should be started" desktop ##> "/store remote file 1 tests/fixtures/test.pdf" desktop <## "file test.pdf stored on remote host 1" @@ -317,7 +251,7 @@ remoteStoreFileTest = r `shouldStartWith` "remote host 1 error" r `shouldContain` err -remoteCLIFileTest :: (HasCallStack) => FilePath -> IO () +remoteCLIFileTest :: HasCallStack => FilePath -> IO () remoteCLIFileTest = testChatCfg3 cfg aliceProfile aliceDesktopProfile bobProfile $ \mobile desktop bob -> withXFTPServer $ do createDirectoryIfMissing True "./tests/tmp/tmp/" let mobileFiles = "./tests/tmp/mobile_files" @@ -333,8 +267,8 @@ remoteCLIFileTest = testChatCfg3 cfg aliceProfile aliceDesktopProfile bobProfile contactBob desktop bob rhs <- readTVarIO (Controller.remoteHostSessions $ chatController desktop) - desktopHostStore <- case M.lookup 1 rhs of - Just RemoteHostSession {storePath} -> pure $ desktopHostFiles storePath archiveFilesFolder + desktopHostStore <- case M.lookup (RHId 1) rhs of + Just RHSessionConnected {storePath} -> pure $ desktopHostFiles storePath archiveFilesFolder _ -> fail "Host session 1 should be started" mobileName <- userName mobile @@ -395,41 +329,41 @@ startRemote :: TestCC -> TestCC -> IO () startRemote mobile desktop = do desktop ##> "/set device name My desktop" desktop <## "ok" - desktop ##> "/create remote host" - desktop <## "remote host 1 created" - -- A new host is started [automatically] by UI - desktop ##> "/start remote host 1" - desktop <## "ok" - desktop <## "remote host 1 started" - desktop <## "connection code:" - oobLink <- getTermLine desktop - OOB {caFingerprint = oobFingerprint} <- either (fail . mappend "OOB link failed: ") pure $ decodeOOBLink (fromString oobLink) - -- Desktop displays OOB QR code - mobile ##> "/set device name Mobile" mobile <## "ok" - mobile ##> "/find remote ctrl" + desktop ##> "/start remote host new" + desktop <## "new remote host started" + desktop <## "Remote session invitation:" + inv <- getTermLine desktop + mobile ##> ("/connect remote ctrl " <> inv) mobile <## "ok" - mobile <## "remote controller announced" - mobile <## "connection code:" - annFingerprint <- getTermLine mobile - -- The user scans OOB QR code and confirms it matches the announced stuff - fromString annFingerprint `shouldBe` strEncode oobFingerprint - - mobile ##> ("/connect remote ctrl " <> oobLink) - mobile <## "remote controller 1 registered" - mobile ##> "/confirm remote ctrl 1" - mobile <## "ok" - mobile <## "remote controller 1 connecting to My desktop" - -- TODO: rework tls connection prelude - mobile <## "remote controller 1 connected to My desktop" + desktop <## "new remote host connecting" + desktop <## "Compare session code with host:" + sessId <- getTermLine desktop + mobile <## "new remote controller connected" mobile <## "Compare session code with controller and use:" - verifyCmd <- getTermLine mobile - mobile ##> verifyCmd + mobile <## ("/verify remote ctrl " <> sessId) + mobile ##> ("/verify remote ctrl " <> sessId) + mobile <## "remote controller 1 session started with My desktop" + desktop <## "remote host 1 connected" + +startRemoteStored :: TestCC -> TestCC -> IO () +startRemoteStored mobile desktop = do + desktop ##> "/start remote host 1" + desktop <## "remote host 1 started" + desktop <## "Remote session invitation:" + inv <- getTermLine desktop + mobile ##> ("/connect remote ctrl " <> inv) mobile <## "ok" - concurrently_ - (mobile <## "remote controller 1 session started with My desktop") - (desktop <## "remote host 1 connected") + desktop <## "remote host 1 connecting" + desktop <## "Compare session code with host:" + sessId <- getTermLine desktop + mobile <## "remote controller 1 connected" + mobile <## "Compare session code with controller and use:" + mobile <## ("/verify remote ctrl " <> sessId) + mobile ##> ("/verify remote ctrl " <> sessId) + mobile <## "remote controller 1 session started with My desktop" + desktop <## "remote host 1 connected" contactBob :: TestCC -> TestCC -> IO () contactBob desktop bob = do @@ -453,9 +387,12 @@ stopDesktop mobile desktop = do logWarn "stopping via desktop" desktop ##> "/stop remote host 1" -- desktop <## "ok" - concurrently_ - (desktop <## "remote host 1 stopped") - (eventually 3 $ mobile <## "remote controller stopped") + concurrentlyN_ + [ do + desktop <## "remote host 1 stopped" + desktop <## "ok", + eventually 3 $ mobile <## "remote controller stopped" + ] stopMobile :: HasCallStack => TestCC -> TestCC -> IO () stopMobile mobile desktop = do @@ -468,7 +405,9 @@ stopMobile mobile desktop = do -- | Run action with extended timeout eventually :: Int -> IO a -> IO a -eventually retries action = tryAny action >>= \case -- TODO: only catch timeouts - Left err | retries == 0 -> throwIO err - Left _ -> eventually (retries - 1) action - Right r -> pure r +eventually retries action = + tryAny action >>= \case + -- TODO: only catch timeouts + Left err | retries == 0 -> throwIO err + Left _ -> eventually (retries - 1) action + Right r -> pure r