mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-05-24 19:35:33 +00:00
core: update remote API commands/events (#3295)
* core: update remote API * Add session verification event between tls and http2 * roll back char_ '@' parsers * use more specific parser for verification codes * cabal.project.local for mac --------- Co-authored-by: IC Rainbow <aenor.realm@gmail.com>
This commit is contained in:
Evgeny Poberezkin
committed by
GitHub
GitHub
parent
b2f9270452
commit
8482dbfd99
+1
-1
@@ -9,7 +9,7 @@ constraints: zip +disable-bzip2 +disable-zstd
|
||||
source-repository-package
|
||||
type: git
|
||||
location: https://github.com/simplex-chat/simplexmq.git
|
||||
tag: db1b2f77cd1c172fab26b68c507cdd2c1b7b0e63
|
||||
tag: a5fed340e2814a226180ce1abe606ac79366fe5b
|
||||
|
||||
source-repository-package
|
||||
type: git
|
||||
|
||||
@@ -1,6 +1,11 @@
|
||||
ignore-project: False
|
||||
|
||||
-- amend to point to the actual openssl location
|
||||
|
||||
package simplexmq
|
||||
extra-include-dirs: /opt/homebrew/opt/openssl@1.1/include
|
||||
extra-lib-dirs: /opt/homebrew/opt/openssl@1.1/lib
|
||||
|
||||
package direct-sqlcipher
|
||||
extra-include-dirs: /opt/homebrew/opt/openssl@1.1/include
|
||||
extra-lib-dirs: /opt/homebrew/opt/openssl@1.1/lib
|
||||
|
||||
+14
-14
@@ -1922,10 +1922,10 @@ processChatCommand = \case
|
||||
DeleteRemoteHost rh -> deleteRemoteHost rh >> ok_
|
||||
StoreRemoteFile rh encrypted_ localPath -> CRRemoteFileStored rh <$> storeRemoteFile rh encrypted_ localPath
|
||||
GetRemoteFile rh rf -> getRemoteFile rh rf >> ok_
|
||||
StartRemoteCtrl -> withUser_ $ startRemoteCtrl (execChatCommand Nothing) >> ok_
|
||||
RegisterRemoteCtrl oob -> withUser_ $ CRRemoteCtrlRegistered <$> withStore' (`insertRemoteCtrl` oob)
|
||||
AcceptRemoteCtrl rc -> withUser_ $ acceptRemoteCtrl rc >> ok_
|
||||
RejectRemoteCtrl rc -> withUser_ $ rejectRemoteCtrl rc >> ok_
|
||||
ConnectRemoteCtrl oob -> withUser_ $ CRRemoteCtrlRegistered <$> withStore' (`insertRemoteCtrl` oob)
|
||||
FindKnownRemoteCtrl -> withUser_ $ findKnownRemoteCtrl (execChatCommand Nothing) >> ok_
|
||||
ConfirmRemoteCtrl rc -> withUser_ $ confirmRemoteCtrl rc >> ok_
|
||||
VerifyRemoteCtrlSession rc sessId -> withUser_ $ verifyRemoteCtrlSession rc sessId >> ok_
|
||||
StopRemoteCtrl -> withUser_ $ stopRemoteCtrl >> ok_
|
||||
ListRemoteCtrls -> withUser_ $ CRRemoteCtrlList <$> listRemoteCtrls
|
||||
DeleteRemoteCtrl rc -> withUser_ $ deleteRemoteCtrl rc >> ok_
|
||||
@@ -5798,14 +5798,14 @@ chatCommandP =
|
||||
"/sync " *> char_ '@' *> (SyncContactRatchet <$> displayName <*> (" force=on" $> True <|> pure False)),
|
||||
"/_get code @" *> (APIGetContactCode <$> A.decimal),
|
||||
"/_get code #" *> (APIGetGroupMemberCode <$> A.decimal <* A.space <*> A.decimal),
|
||||
"/_verify code @" *> (APIVerifyContact <$> A.decimal <*> optional (A.space *> textP)),
|
||||
"/_verify code #" *> (APIVerifyGroupMember <$> A.decimal <* A.space <*> A.decimal <*> optional (A.space *> textP)),
|
||||
"/_verify code @" *> (APIVerifyContact <$> A.decimal <*> optional (A.space *> verifyCodeP)),
|
||||
"/_verify code #" *> (APIVerifyGroupMember <$> A.decimal <* A.space <*> A.decimal <*> optional (A.space *> verifyCodeP)),
|
||||
"/_enable @" *> (APIEnableContact <$> A.decimal),
|
||||
"/_enable #" *> (APIEnableGroupMember <$> A.decimal <* A.space <*> A.decimal),
|
||||
"/code " *> char_ '@' *> (GetContactCode <$> displayName),
|
||||
"/code #" *> (GetGroupMemberCode <$> displayName <* A.space <* char_ '@' <*> displayName),
|
||||
"/verify " *> char_ '@' *> (VerifyContact <$> displayName <*> optional (A.space *> textP)),
|
||||
"/verify #" *> (VerifyGroupMember <$> displayName <* A.space <* char_ '@' <*> displayName <*> optional (A.space *> textP)),
|
||||
"/verify " *> char_ '@' *> (VerifyContact <$> displayName <*> optional (A.space *> verifyCodeP)),
|
||||
"/verify #" *> (VerifyGroupMember <$> displayName <* A.space <* char_ '@' <*> displayName <*> optional (A.space *> verifyCodeP)),
|
||||
"/enable " *> char_ '@' *> (EnableContact <$> displayName),
|
||||
"/enable #" *> (EnableGroupMember <$> displayName <* A.space <* char_ '@' <*> displayName),
|
||||
("/help files" <|> "/help file" <|> "/hf") $> ChatHelp HSFiles,
|
||||
@@ -5856,7 +5856,7 @@ chatCommandP =
|
||||
"/_connect " *> (APIConnect <$> A.decimal <*> incognitoOnOffP <* A.space <*> ((Just <$> strP) <|> A.takeByteString $> Nothing)),
|
||||
"/_connect " *> (APIAddContact <$> A.decimal <*> incognitoOnOffP),
|
||||
"/_set incognito :" *> (APISetConnectionIncognito <$> A.decimal <* A.space <*> onOffP),
|
||||
("/connect" <|> "/c") *> (Connect <$> incognitoP <* A.space <*> ((Just <$> strP) <|> A.takeByteString $> Nothing)),
|
||||
("/connect" <|> "/c") *> (Connect <$> incognitoP <* A.space <*> ((Just <$> strP) <|> A.takeTill isSpace $> Nothing)),
|
||||
("/connect" <|> "/c") *> (AddContact <$> incognitoP),
|
||||
SendMessage <$> chatNameP <* A.space <*> msgTextP,
|
||||
"@#" *> (SendMemberContactMessage <$> displayName <* A.space <* char_ '@' <*> displayName <* A.space <*> msgTextP),
|
||||
@@ -5926,12 +5926,11 @@ chatCommandP =
|
||||
"/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),
|
||||
"/start remote ctrl" $> StartRemoteCtrl,
|
||||
"/register remote ctrl " *> (RegisterRemoteCtrl <$> strP),
|
||||
-- "/_register remote ctrl " *> (RegisterRemoteCtrl <$> 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),
|
||||
"/list remote ctrls" $> ListRemoteCtrls,
|
||||
"/accept remote ctrl " *> (AcceptRemoteCtrl <$> A.decimal),
|
||||
"/reject remote ctrl " *> (RejectRemoteCtrl <$> A.decimal),
|
||||
"/stop remote ctrl" $> StopRemoteCtrl,
|
||||
"/delete remote ctrl " *> (DeleteRemoteCtrl <$> A.decimal),
|
||||
("/quit" <|> "/q" <|> "/exit") $> QuitChat,
|
||||
@@ -5997,6 +5996,7 @@ chatCommandP =
|
||||
fullNameP = A.space *> textP <|> pure ""
|
||||
textP = safeDecodeUtf8 <$> A.takeByteString
|
||||
pwdP = jsonP <|> (UserPwd . safeDecodeUtf8 <$> A.takeTill (== ' '))
|
||||
verifyCodeP = safeDecodeUtf8 <$> A.takeWhile (\c -> isDigit c || c == ' ')
|
||||
msgTextP = jsonP <|> textP
|
||||
stringP = T.unpack . safeDecodeUtf8 <$> A.takeByteString
|
||||
filePath = stringP
|
||||
|
||||
@@ -426,11 +426,11 @@ data ChatCommand
|
||||
| DeleteRemoteHost RemoteHostId -- ^ Unregister remote host and remove its data
|
||||
| StoreRemoteFile {remoteHostId :: RemoteHostId, storeEncrypted :: Maybe Bool, localPath :: FilePath}
|
||||
| GetRemoteFile {remoteHostId :: RemoteHostId, file :: RemoteFile}
|
||||
| StartRemoteCtrl -- ^ Start listening for announcements from all registered controllers
|
||||
| RegisterRemoteCtrl SignedOOB -- ^ Register OOB data for remote controller discovery and handshake
|
||||
| ConnectRemoteCtrl SignedOOB -- ^ 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
|
||||
| ListRemoteCtrls
|
||||
| AcceptRemoteCtrl RemoteCtrlId -- ^ Accept discovered data and store confirmation
|
||||
| RejectRemoteCtrl RemoteCtrlId -- ^ Reject and blacklist discovered data
|
||||
| StopRemoteCtrl -- ^ Stop listening for announcements or terminate an active session
|
||||
| DeleteRemoteCtrl RemoteCtrlId -- ^ Remove all local data associated with a remote controller session
|
||||
| QuitChat
|
||||
@@ -458,11 +458,11 @@ allowRemoteCommand = \case
|
||||
GetRemoteFile {} -> False
|
||||
StopRemoteHost _ -> False
|
||||
DeleteRemoteHost _ -> False
|
||||
RegisterRemoteCtrl {} -> False
|
||||
StartRemoteCtrl -> False
|
||||
ConnectRemoteCtrl {} -> False
|
||||
FindKnownRemoteCtrl -> False
|
||||
ConfirmRemoteCtrl _ -> False
|
||||
VerifyRemoteCtrlSession {} -> False
|
||||
ListRemoteCtrls -> False
|
||||
AcceptRemoteCtrl _ -> False
|
||||
RejectRemoteCtrl _ -> False
|
||||
StopRemoteCtrl -> False
|
||||
DeleteRemoteCtrl _ -> False
|
||||
ExecChatStoreSQL _ -> False
|
||||
@@ -641,14 +641,16 @@ data ChatResponse
|
||||
| CRRemoteHostCreated {remoteHost :: RemoteHostInfo}
|
||||
| CRRemoteHostList {remoteHosts :: [RemoteHostInfo]}
|
||||
| CRRemoteHostStarted {remoteHost :: RemoteHostInfo, sessionOOB :: Text}
|
||||
| CRRemoteHostSessionCode {remoteHost :: RemoteHostInfo, sessionCode :: Text}
|
||||
| CRRemoteHostConnected {remoteHost :: RemoteHostInfo}
|
||||
| CRRemoteHostStopped {remoteHostId :: RemoteHostId}
|
||||
| CRRemoteFileStored {remoteHostId :: RemoteHostId, remoteFileSource :: CryptoFile}
|
||||
| CRRemoteCtrlList {remoteCtrls :: [RemoteCtrlInfo]}
|
||||
| CRRemoteCtrlRegistered {remoteCtrl :: RemoteCtrlInfo}
|
||||
| CRRemoteCtrlAnnounce {fingerprint :: C.KeyHash} -- unregistered fingerprint, needs confirmation
|
||||
| CRRemoteCtrlRegistered {remoteCtrl :: RemoteCtrlInfo} -- TODO remove
|
||||
| CRRemoteCtrlAnnounce {fingerprint :: C.KeyHash} -- TODO remove, unregistered fingerprint, needs confirmation -- TODO is it needed?
|
||||
| CRRemoteCtrlFound {remoteCtrl :: RemoteCtrlInfo} -- registered fingerprint, may connect
|
||||
| CRRemoteCtrlConnecting {remoteCtrl :: RemoteCtrlInfo}
|
||||
| CRRemoteCtrlConnecting {remoteCtrl :: RemoteCtrlInfo} -- TODO is remove
|
||||
| CRRemoteCtrlSessionCode {remoteCtrl :: RemoteCtrlInfo, sessionCode :: Text, newCtrl :: Bool}
|
||||
| CRRemoteCtrlConnected {remoteCtrl :: RemoteCtrlInfo}
|
||||
| CRRemoteCtrlStopped
|
||||
| CRSQLResult {rows :: [Text]}
|
||||
@@ -679,8 +681,9 @@ allowRemoteEvent = \case
|
||||
CRRemoteCtrlAnnounce {} -> False
|
||||
CRRemoteCtrlFound {} -> False
|
||||
CRRemoteCtrlConnecting {} -> False
|
||||
CRRemoteCtrlSessionCode {} -> False
|
||||
CRRemoteCtrlConnected {} -> False
|
||||
CRRemoteCtrlStopped {} -> False
|
||||
CRRemoteCtrlStopped -> False
|
||||
_ -> True
|
||||
|
||||
logResponseToFile :: ChatResponse -> Bool
|
||||
@@ -1060,6 +1063,7 @@ data RemoteCtrlError
|
||||
| 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
|
||||
| RCEBadVerificationCode -- ^ The code submitted doesn't match session TLSunique
|
||||
| RCEHTTP2Error {http2Error :: String}
|
||||
| RCEHTTP2RespStatus {statusCode :: Maybe Int} -- TODO remove
|
||||
| RCEInvalidResponse {responseError :: String}
|
||||
@@ -1071,13 +1075,14 @@ data ArchiveError
|
||||
| AEImportFile {file :: String, chatError :: ChatError}
|
||||
deriving (Show, Exception)
|
||||
|
||||
-- | Host (mobile) side of transport to process remote commands and forward notifications
|
||||
data RemoteCtrlSession = RemoteCtrlSession
|
||||
{ -- | Host (mobile) side of transport to process remote commands and forward notifications
|
||||
discoverer :: Async (),
|
||||
supervisor :: Async (),
|
||||
hostServer :: Maybe (Async ()),
|
||||
discovered :: TMap C.KeyHash (TransportHost, Word16),
|
||||
accepted :: TMVar RemoteCtrlId,
|
||||
{ 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
|
||||
}
|
||||
|
||||
|
||||
+59
-41
@@ -1,3 +1,4 @@
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
@@ -7,7 +8,6 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
||||
|
||||
module Simplex.Chat.Remote where
|
||||
@@ -41,7 +41,7 @@ import Simplex.Chat.Controller
|
||||
import Simplex.Chat.Files
|
||||
import Simplex.Chat.Messages (chatNameStr)
|
||||
import Simplex.Chat.Remote.Protocol
|
||||
import Simplex.Chat.Remote.RevHTTP (announceRevHTTP2, connectRevHTTP2)
|
||||
import Simplex.Chat.Remote.RevHTTP (announceRevHTTP2, attachHTTP2Server)
|
||||
import Simplex.Chat.Remote.Transport
|
||||
import Simplex.Chat.Remote.Types
|
||||
import Simplex.Chat.Store.Files
|
||||
@@ -56,6 +56,7 @@ 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.File (hSendFile)
|
||||
@@ -65,6 +66,7 @@ import qualified Simplex.RemoteControl.Discovery as Discovery
|
||||
import Simplex.RemoteControl.Types
|
||||
import System.FilePath (takeFileName, (</>))
|
||||
import UnliftIO
|
||||
import UnliftIO.Concurrent (threadDelay)
|
||||
import UnliftIO.Directory (copyFile, createDirectoryIfMissing, renameFile)
|
||||
|
||||
-- * Desktop side
|
||||
@@ -93,13 +95,15 @@ 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
|
||||
-- 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
|
||||
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
|
||||
@@ -109,7 +113,7 @@ startRemoteHost rhId = do
|
||||
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
|
||||
-- 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
|
||||
@@ -127,12 +131,14 @@ startRemoteHost rhId = do
|
||||
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
|
||||
}
|
||||
toView $
|
||||
CRRemoteHostConnected
|
||||
RemoteHostInfo
|
||||
{ remoteHostId = rhId,
|
||||
storePath = storePath,
|
||||
displayName = hostDeviceName remoteHostClient,
|
||||
sessionActive = True
|
||||
}
|
||||
|
||||
genSessionCredentials RemoteHost {caKey, caCert} = do
|
||||
sessionCreds <- genCredentials (Just parent) (0, 24) "Session"
|
||||
@@ -251,34 +257,48 @@ liftRH rhId = liftError (ChatErrorRemoteHost rhId . RHProtocolError)
|
||||
|
||||
-- * Mobile side
|
||||
|
||||
startRemoteCtrl :: forall m . ChatMonad m => (ByteString -> m ChatResponse) -> m ()
|
||||
startRemoteCtrl execChatCommand = do
|
||||
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
|
||||
accepted <- newEmptyTMVarIO
|
||||
supervisor <- async $ runHost discovered accepted $ handleRemoteCommand execChatCommand remoteOutputQ
|
||||
chatWriteVar remoteCtrlSession $ Just RemoteCtrlSession {discoverer, supervisor, hostServer = Nothing, discovered, accepted, remoteOutputQ}
|
||||
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}
|
||||
|
||||
-- | 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 -> (HTTP2Request -> m ()) -> m ()
|
||||
runHost discovered accepted handleHttp = do
|
||||
remoteCtrlId <- atomically (readTMVar accepted) -- wait for ???
|
||||
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 $ connectRevHTTP2 serviceAddress fingerprint handleHttp -- spawn server for remote protocol commands
|
||||
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}
|
||||
toView $ CRRemoteCtrlConnected $ remoteCtrlInfo rc True
|
||||
_ <- waitCatch server -- wait for the server to finish
|
||||
chatWriteVar remoteCtrlSession Nothing
|
||||
toView CRRemoteCtrlStopped
|
||||
|
||||
handleRemoteCommand :: forall m . ChatMonad m => (ByteString -> m ChatResponse) -> TBQueue ChatResponse -> HTTP2Request -> m ()
|
||||
handleRemoteCommand :: forall m. ChatMonad m => (ByteString -> m ChatResponse) -> TBQueue ChatResponse -> HTTP2Request -> m ()
|
||||
handleRemoteCommand execChatCommand remoteOutputQ HTTP2Request {request, reqBody, sendResponse} = do
|
||||
logDebug "handleRemoteCommand"
|
||||
liftRC (tryRemoteError parseRequest) >>= \case
|
||||
@@ -358,7 +378,7 @@ handleStoreFile fileName fileSize fileDigest getChunk =
|
||||
pure filePath
|
||||
|
||||
handleGetFile :: ChatMonad m => User -> RemoteFile -> Respond m -> m ()
|
||||
handleGetFile User {userId} RemoteFile{userId = commandUserId, fileId, sent, fileSource = cf'@CryptoFile {filePath}} reply = do
|
||||
handleGetFile User {userId} RemoteFile {userId = commandUserId, fileId, sent, fileSource = cf'@CryptoFile {filePath}} reply = do
|
||||
logDebug $ "GetFile: " <> tshow filePath
|
||||
unless (userId == commandUserId) $ throwChatError $ CEDifferentActiveUser {commandUserId, activeUserId = userId}
|
||||
path <- maybe filePath (</> filePath) <$> chatReadVar filesFolder
|
||||
@@ -385,7 +405,7 @@ discoverRemoteCtrls discovered = do
|
||||
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
|
||||
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
|
||||
@@ -406,13 +426,13 @@ discoverRemoteCtrls discovered = do
|
||||
Just True ->
|
||||
chatReadVar remoteCtrlSession >>= \case
|
||||
Nothing -> toView . CRChatError Nothing . ChatError $ CEInternalError "Remote host found without running a session"
|
||||
Just RemoteCtrlSession {accepted} -> atomically $ void $ tryPutTMVar accepted remoteCtrlId -- previously accepted controller, connect automatically
|
||||
Just RemoteCtrlSession {confirmed} -> atomically $ void $ tryPutTMVar confirmed remoteCtrlId -- previously accepted controller, connect automatically
|
||||
|
||||
listRemoteCtrls :: ChatMonad m => m [RemoteCtrlInfo]
|
||||
listRemoteCtrls = do
|
||||
active <-
|
||||
chatReadVar remoteCtrlSession
|
||||
$>>= \RemoteCtrlSession {accepted} -> atomically $ tryReadTMVar accepted
|
||||
chatReadVar remoteCtrlSession $>>= \RemoteCtrlSession {confirmed} ->
|
||||
atomically $ tryReadTMVar confirmed
|
||||
map (rcInfo active) <$> withStore' getRemoteCtrls
|
||||
where
|
||||
rcInfo activeRcId rc@RemoteCtrl {remoteCtrlId} =
|
||||
@@ -422,19 +442,17 @@ remoteCtrlInfo :: RemoteCtrl -> Bool -> RemoteCtrlInfo
|
||||
remoteCtrlInfo RemoteCtrl {remoteCtrlId, displayName, fingerprint, accepted} sessionActive =
|
||||
RemoteCtrlInfo {remoteCtrlId, displayName, fingerprint, accepted, sessionActive}
|
||||
|
||||
acceptRemoteCtrl :: ChatMonad m => RemoteCtrlId -> m ()
|
||||
acceptRemoteCtrl rcId = do
|
||||
confirmRemoteCtrl :: ChatMonad m => RemoteCtrlId -> m ()
|
||||
confirmRemoteCtrl rcId = do
|
||||
-- TODO check it exists, check the ID is the same as in session
|
||||
RemoteCtrlSession {accepted} <- getRemoteCtrlSession
|
||||
RemoteCtrlSession {confirmed} <- getRemoteCtrlSession
|
||||
withStore' $ \db -> markRemoteCtrlResolution db rcId True
|
||||
atomically . void $ tryPutTMVar accepted rcId -- the remote host can now proceed with connection
|
||||
atomically . void $ tryPutTMVar confirmed rcId -- the remote host can now proceed with connection
|
||||
|
||||
rejectRemoteCtrl :: ChatMonad m => RemoteCtrlId -> m ()
|
||||
rejectRemoteCtrl rcId = do
|
||||
withStore' $ \db -> markRemoteCtrlResolution db rcId False
|
||||
RemoteCtrlSession {discoverer, supervisor} <- getRemoteCtrlSession
|
||||
cancel discoverer
|
||||
cancel supervisor
|
||||
verifyRemoteCtrlSession :: ChatMonad m => RemoteCtrlId -> Text -> m ()
|
||||
verifyRemoteCtrlSession rcId sessId = do
|
||||
RemoteCtrlSession {verified} <- getRemoteCtrlSession
|
||||
void . atomically $ tryPutTMVar verified (rcId, sessId)
|
||||
|
||||
stopRemoteCtrl :: ChatMonad m => m ()
|
||||
stopRemoteCtrl = do
|
||||
|
||||
@@ -11,11 +11,9 @@ module Simplex.Chat.Remote.RevHTTP where
|
||||
import Simplex.RemoteControl.Discovery
|
||||
import Simplex.RemoteControl.Types
|
||||
import Control.Logger.Simple
|
||||
import Data.Word (Word16)
|
||||
import qualified Network.TLS as TLS
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import qualified Simplex.Messaging.Transport as Transport
|
||||
import Simplex.Messaging.Transport.Client (TransportHost (..))
|
||||
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)
|
||||
@@ -39,9 +37,6 @@ runHTTP2Client finishedVar clientVar tls =
|
||||
-- TODO connection timeout
|
||||
config = defaultHTTP2ClientConfig {bodyHeadSize = doNotPrefetchHead, connTimeout = maxBound}
|
||||
|
||||
connectRevHTTP2 :: (MonadUnliftIO m) => (TransportHost, Word16) -> C.KeyHash -> (HTTP2Request -> m ()) -> m ()
|
||||
connectRevHTTP2 serviceAddress fingerprint = connectTLSClient serviceAddress fingerprint . attachHTTP2Server
|
||||
|
||||
attachHTTP2Server :: (MonadUnliftIO m) => (HTTP2Request -> m ()) -> Transport.TLS -> m ()
|
||||
attachHTTP2Server processRequest tls = do
|
||||
withRunInIO $ \unlift ->
|
||||
|
||||
@@ -275,17 +275,26 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe
|
||||
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]
|
||||
CRRemoteHostConnected RemoteHostInfo {remoteHostId = rhId} -> ["remote host " <> sShow rhId <> " connected"]
|
||||
CRRemoteHostStopped rhId -> ["remote host " <> sShow rhId <> " stopped"]
|
||||
CRRemoteFileStored rhId (CryptoFile filePath cfArgs_) ->
|
||||
[plain $ "file " <> filePath <> " stored on remote host " <> show rhId]
|
||||
<> maybe [] ((: []) . plain . cryptoFileArgsStr testView) cfArgs_
|
||||
CRRemoteCtrlList cs -> viewRemoteCtrls cs
|
||||
CRRemoteCtrlRegistered RemoteCtrlInfo {remoteCtrlId = rcId} -> ["remote controller " <> sShow rcId <> " registered"]
|
||||
CRRemoteCtrlAnnounce fingerprint -> ["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]
|
||||
CRRemoteCtrlConnected RemoteCtrlInfo {remoteCtrlId = rcId, displayName = rcName} -> ["remote controller " <> sShow rcId <> " connected, " <> plain rcName]
|
||||
CRRemoteCtrlRegistered RemoteCtrlInfo {remoteCtrlId = rcId} ->
|
||||
["remote controller " <> sShow rcId <> " registered"]
|
||||
CRRemoteCtrlAnnounce fingerprint ->
|
||||
["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]
|
||||
CRRemoteCtrlStopped -> ["remote controller stopped"]
|
||||
CRSQLResult rows -> map plain rows
|
||||
CRSlowSQLQueries {chatQueries, agentQueries} ->
|
||||
|
||||
+14
-7
@@ -30,7 +30,7 @@ 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 (strDecode, strEncode)
|
||||
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)
|
||||
@@ -408,7 +408,7 @@ startRemote mobile desktop = do
|
||||
|
||||
mobile ##> "/set device name Mobile"
|
||||
mobile <## "ok"
|
||||
mobile ##> "/start remote ctrl"
|
||||
mobile ##> "/find remote ctrl"
|
||||
mobile <## "ok"
|
||||
mobile <## "remote controller announced"
|
||||
mobile <## "connection code:"
|
||||
@@ -416,13 +416,20 @@ startRemote mobile desktop = do
|
||||
-- The user scans OOB QR code and confirms it matches the announced stuff
|
||||
fromString annFingerprint `shouldBe` strEncode oobFingerprint
|
||||
|
||||
mobile ##> ("/register remote ctrl " <> oobLink)
|
||||
mobile ##> ("/connect remote ctrl " <> oobLink)
|
||||
mobile <## "remote controller 1 registered"
|
||||
mobile ##> "/accept remote ctrl 1"
|
||||
mobile <## "ok" -- alternative scenario: accepted before controller start
|
||||
mobile ##> "/confirm remote ctrl 1"
|
||||
mobile <## "ok"
|
||||
mobile <## "remote controller 1 connecting to My desktop"
|
||||
mobile <## "remote controller 1 connected, My desktop"
|
||||
desktop <## "remote host 1 connected"
|
||||
-- TODO: rework tls connection prelude
|
||||
mobile <## "remote controller 1 connected to My desktop"
|
||||
mobile <## "Compare session code with controller and use:"
|
||||
verifyCmd <- getTermLine mobile
|
||||
mobile ##> verifyCmd
|
||||
mobile <## "ok"
|
||||
concurrently_
|
||||
(mobile <## "remote controller 1 session started with My desktop")
|
||||
(desktop <## "remote host 1 connected")
|
||||
|
||||
contactBob :: TestCC -> TestCC -> IO ()
|
||||
contactBob desktop bob = do
|
||||
|
||||
Reference in New Issue
Block a user