mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2024-12-17 17:20:21 +01:00
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>
This commit is contained in:
Alexander Bondarenko
committed by
GitHub
GitHub
parent
3839267f88
commit
b729144773
@@ -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)
|
||||
|
||||
@@ -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
|
||||
);
|
||||
|]
|
||||
|
||||
|
||||
@@ -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,
|
||||
|
||||
+287
-240
@@ -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 #-}
|
||||
|
||||
@@ -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)
|
||||
@@ -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 ()
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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)
|
||||
|
||||
+27
-16
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user