remote protocol (#3225)

* draft remote protocol types and external api

* types (it compiles)

* add error

* move remote controller from http to remote host client protocol

* refactor (doesnt compile)

* fix compile

* Connect remote session

* WIP: wire in remote protocol

* add commands and events

* cleanup

* fix desktop shutdown

* prepare for testing remote files

* Add file IO

* update simplexmq to master

with http2 to 4.1.4

* use json transcoder

* update simplexmq

* collapse RemoteHostSession states

* fold RemoteHello back into the protocol command
move http-command-response-http wrapper to protocol

* use sendRemoteCommand with optional attachments
use streaming request/response

* ditch lazy body streaming

* fix formatting

* put body builder/processor closer together

* wrap handleRemoteCommand around sending files

* handle ChatError's too

* remove binary, use 32-bit encoding for JSON bodies

* enable tests

* refactor

* refactor request handling

* return ChatError

* Flatten remote host

---------

Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
This commit is contained in:
Alexander Bondarenko 2023-10-22 11:42:19 +03:00 committed by GitHub
parent 0444367002
commit 0d1a080a6e
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
15 changed files with 693 additions and 537 deletions

View file

@ -9,7 +9,7 @@ constraints: zip +disable-bzip2 +disable-zstd
source-repository-package
type: git
location: https://github.com/simplex-chat/simplexmq.git
tag: 1ad69cf74f18f25713ce564e1629d2538313b9e0
tag: deb3fc73595ceae34902d3402d075e3a531d5221
source-repository-package
type: git
@ -19,7 +19,7 @@ source-repository-package
source-repository-package
type: git
location: https://github.com/kazu-yamamoto/http2.git
tag: b5a1b7200cf5bc7044af34ba325284271f6dff25
tag: 804fa283f067bd3fd89b8c5f8d25b3047813a517
source-repository-package
type: git

View file

@ -19,7 +19,6 @@ dependencies:
- attoparsec == 0.14.*
- base >= 4.7 && < 5
- base64-bytestring >= 1.0 && < 1.3
- binary >= 0.8 && < 0.9
- bytestring == 0.11.*
- composition == 1.0.*
- constraints >= 0.12 && < 0.14
@ -36,6 +35,7 @@ dependencies:
- memory == 0.18.*
- mtl == 2.3.*
- network >= 3.1.2.7 && < 3.2
- network-transport == 0.5.6
- network-udp >= 0.0 && < 0.1
- optparse-applicative >= 0.15 && < 0.17
- process == 1.6.*

View file

@ -1,7 +1,7 @@
{
"https://github.com/simplex-chat/simplexmq.git"."1ad69cf74f18f25713ce564e1629d2538313b9e0" = "1kil0962pn3ksnxh7dcwcbnkidz95yl31rm4m585ps7wnh6fp0l9";
"https://github.com/simplex-chat/simplexmq.git"."deb3fc73595ceae34902d3402d075e3a531d5221" = "031zrk32p8ji8hlvk8aj1v99g5zpcsran8qhq36sgi34sy6864z6";
"https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38";
"https://github.com/kazu-yamamoto/http2.git"."b5a1b7200cf5bc7044af34ba325284271f6dff25" = "0dqb50j57an64nf4qcf5vcz4xkd1vzvghvf8bk529c1k30r9nfzb";
"https://github.com/kazu-yamamoto/http2.git"."804fa283f067bd3fd89b8c5f8d25b3047813a517" = "1j67wp7rfybfx3ryx08z6gqmzj85j51hmzhgx47ihgmgr47sl895";
"https://github.com/simplex-chat/direct-sqlcipher.git"."f814ee68b16a9447fbb467ccc8f29bdd3546bfd9" = "0kiwhvml42g9anw4d2v0zd1fpc790pj9syg5x3ik4l97fnkbbwpp";
"https://github.com/simplex-chat/sqlcipher-simple.git"."a46bd361a19376c5211f1058908fc0ae6bf42446" = "1z0r78d8f0812kxbgsm735qf6xx8lvaz27k1a0b4a2m0sshpd5gl";
"https://github.com/simplex-chat/aeson.git"."aab7b5a14d6c5ea64c64dcaee418de1bb00dcc2b" = "0jz7kda8gai893vyvj96fy962ncv8dcsx71fbddyy8zrvc88jfrr";

View file

@ -127,6 +127,7 @@ library
Simplex.Chat.Protocol
Simplex.Chat.Remote
Simplex.Chat.Remote.Discovery
Simplex.Chat.Remote.Protocol
Simplex.Chat.Remote.Types
Simplex.Chat.Store
Simplex.Chat.Store.Connections
@ -160,7 +161,6 @@ library
, attoparsec ==0.14.*
, base >=4.7 && <5
, base64-bytestring >=1.0 && <1.3
, binary ==0.8.*
, bytestring ==0.11.*
, composition ==1.0.*
, constraints >=0.12 && <0.14
@ -177,6 +177,7 @@ library
, memory ==0.18.*
, mtl ==2.3.*
, network >=3.1.2.7 && <3.2
, network-transport ==0.5.6
, network-udp ==0.0.*
, optparse-applicative >=0.15 && <0.17
, process ==1.6.*
@ -213,7 +214,6 @@ executable simplex-bot
, attoparsec ==0.14.*
, base >=4.7 && <5
, base64-bytestring >=1.0 && <1.3
, binary ==0.8.*
, bytestring ==0.11.*
, composition ==1.0.*
, constraints >=0.12 && <0.14
@ -230,6 +230,7 @@ executable simplex-bot
, memory ==0.18.*
, mtl ==2.3.*
, network >=3.1.2.7 && <3.2
, network-transport ==0.5.6
, network-udp ==0.0.*
, optparse-applicative >=0.15 && <0.17
, process ==1.6.*
@ -267,7 +268,6 @@ executable simplex-bot-advanced
, attoparsec ==0.14.*
, base >=4.7 && <5
, base64-bytestring >=1.0 && <1.3
, binary ==0.8.*
, bytestring ==0.11.*
, composition ==1.0.*
, constraints >=0.12 && <0.14
@ -284,6 +284,7 @@ executable simplex-bot-advanced
, memory ==0.18.*
, mtl ==2.3.*
, network >=3.1.2.7 && <3.2
, network-transport ==0.5.6
, network-udp ==0.0.*
, optparse-applicative >=0.15 && <0.17
, process ==1.6.*
@ -323,7 +324,6 @@ executable simplex-broadcast-bot
, attoparsec ==0.14.*
, base >=4.7 && <5
, base64-bytestring >=1.0 && <1.3
, binary ==0.8.*
, bytestring ==0.11.*
, composition ==1.0.*
, constraints >=0.12 && <0.14
@ -340,6 +340,7 @@ executable simplex-broadcast-bot
, memory ==0.18.*
, mtl ==2.3.*
, network >=3.1.2.7 && <3.2
, network-transport ==0.5.6
, network-udp ==0.0.*
, optparse-applicative >=0.15 && <0.17
, process ==1.6.*
@ -378,7 +379,6 @@ executable simplex-chat
, attoparsec ==0.14.*
, base >=4.7 && <5
, base64-bytestring >=1.0 && <1.3
, binary ==0.8.*
, bytestring ==0.11.*
, composition ==1.0.*
, constraints >=0.12 && <0.14
@ -395,6 +395,7 @@ executable simplex-chat
, memory ==0.18.*
, mtl ==2.3.*
, network ==3.1.*
, network-transport ==0.5.6
, network-udp ==0.0.*
, optparse-applicative >=0.15 && <0.17
, process ==1.6.*
@ -437,7 +438,6 @@ executable simplex-directory-service
, attoparsec ==0.14.*
, base >=4.7 && <5
, base64-bytestring >=1.0 && <1.3
, binary ==0.8.*
, bytestring ==0.11.*
, composition ==1.0.*
, constraints >=0.12 && <0.14
@ -454,6 +454,7 @@ executable simplex-directory-service
, memory ==0.18.*
, mtl ==2.3.*
, network >=3.1.2.7 && <3.2
, network-transport ==0.5.6
, network-udp ==0.0.*
, optparse-applicative >=0.15 && <0.17
, process ==1.6.*
@ -519,7 +520,6 @@ test-suite simplex-chat-test
, attoparsec ==0.14.*
, base >=4.7 && <5
, base64-bytestring >=1.0 && <1.3
, binary ==0.8.*
, bytestring ==0.11.*
, composition ==1.0.*
, constraints >=0.12 && <0.14
@ -539,6 +539,7 @@ test-suite simplex-chat-test
, memory ==0.18.*
, mtl ==2.3.*
, network ==3.1.*
, network-transport ==0.5.6
, network-udp ==0.0.*
, optparse-applicative >=0.15 && <0.17
, process ==1.6.*

View file

@ -109,6 +109,7 @@ import System.Random (randomRIO)
import Text.Read (readMaybe)
import UnliftIO.Async
import UnliftIO.Concurrent (forkFinally, forkIO, mkWeakThreadId, threadDelay)
import qualified UnliftIO.Exception as E
import UnliftIO.Directory
import UnliftIO.IO (hClose, hSeek, hTell, openFile)
import UnliftIO.STM
@ -389,17 +390,20 @@ execChatCommand rh s = do
case parseChatCommand s of
Left e -> pure $ chatCmdError u e
Right cmd -> case rh of
Just remoteHostId | allowRemoteCommand cmd -> execRemoteCommand u remoteHostId (s, cmd)
Just remoteHostId | allowRemoteCommand cmd -> execRemoteCommand u remoteHostId s
_ -> execChatCommand_ u cmd
execChatCommand' :: ChatMonad' m => ChatCommand -> m ChatResponse
execChatCommand' cmd = asks currentUser >>= readTVarIO >>= (`execChatCommand_` cmd)
execChatCommand_ :: ChatMonad' m => Maybe User -> ChatCommand -> m ChatResponse
execChatCommand_ u cmd = either (CRChatCmdError u) id <$> runExceptT (processChatCommand cmd)
execChatCommand_ u cmd = handleCommandError u $ processChatCommand cmd
execRemoteCommand :: ChatMonad' m => Maybe User -> RemoteHostId -> (ByteString, ChatCommand) -> m ChatResponse
execRemoteCommand u rhId scmd = either (CRChatCmdError u) id <$> runExceptT (getRemoteHostSession rhId >>= (`processRemoteCommand` scmd))
execRemoteCommand :: ChatMonad' m => Maybe User -> RemoteHostId -> ByteString -> m ChatResponse
execRemoteCommand u rhId s = handleCommandError u $ getRemoteHostSession rhId >>= \rh -> processRemoteCommand rhId rh s
handleCommandError :: ChatMonad' m => Maybe User -> ExceptT ChatError m ChatResponse -> m ChatResponse
handleCommandError u a = either (CRChatCmdError u) id <$> (runExceptT a `E.catch` (pure . Left . mkChatError))
parseChatCommand :: ByteString -> Either String ChatCommand
parseChatCommand = A.parseOnly chatCommandP . B.dropWhileEnd isSpace

View file

@ -72,7 +72,6 @@ import Simplex.Messaging.Protocol (AProtoServerWithAuth, AProtocolType (..), Cor
import Simplex.Messaging.TMap (TMap)
import Simplex.Messaging.Transport (simplexMQVersion)
import Simplex.Messaging.Transport.Client (TransportHost)
import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client)
import Simplex.Messaging.Util (allFinally, catchAllErrors, liftEitherError, tryAllErrors, (<$$>))
import Simplex.Messaging.Version
import System.IO (Handle)
@ -1153,6 +1152,7 @@ data RemoteHostError
| 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
deriving (Show, Exception, Generic)
instance FromJSON RemoteHostError where
@ -1175,6 +1175,7 @@ data RemoteCtrlError
| RCEHTTP2Error {http2Error :: String}
| RCEHTTP2RespStatus {statusCode :: Maybe Int} -- TODO remove
| RCEInvalidResponse {responseError :: String}
| RCEProtocolError {protocolError :: RemoteProtocolError}
deriving (Show, Exception, Generic)
instance FromJSON RemoteCtrlError where
@ -1196,16 +1197,6 @@ instance ToJSON ArchiveError where
toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "AE"
toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "AE"
data RemoteHostSession
= RemoteHostSessionStarting
{ announcer :: Async ()
}
| RemoteHostSessionStarted
{ -- | Path for local resources to be synchronized with host
storePath :: FilePath,
ctrlClient :: HTTP2Client
}
data RemoteCtrlSession = RemoteCtrlSession
{ -- | Host (mobile) side of transport to process remote commands and forward notifications
discoverer :: Async (),

View file

@ -5,7 +5,6 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
@ -20,148 +19,136 @@ import Control.Monad.IO.Class
import Control.Monad.Reader (asks)
import Control.Monad.STM (retry)
import Crypto.Random (getRandomBytes)
import Data.Aeson ((.=))
import qualified Data.Aeson as J
import qualified Data.Aeson.Key as JK
import qualified Data.Aeson.KeyMap as JM
import qualified Data.Attoparsec.ByteString.Char8 as A
import qualified Data.Binary.Builder as Binary
import Data.ByteString (ByteString, hPut)
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.Int (Int64)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import qualified Network.HTTP.Types as HTTP
import qualified Network.HTTP.Types.Status as Status
import qualified Network.HTTP2.Client as HC
import qualified Network.HTTP2.Server as HS
import Data.Text.Encoding (encodeUtf8)
import Data.Word (Word32)
import Network.HTTP2.Server (responseStreaming)
import qualified Network.HTTP.Types as N
import Network.Socket (SockAddr (..), hostAddressToTuple)
import Simplex.Chat.Controller
import Simplex.Chat.Messages (AChatItem (..), CIFile (..), CIFileStatus (..), ChatItem (..), chatNameStr)
import Simplex.Chat.Messages.CIContent (MsgDirection (..), SMsgDirection (..))
import qualified Simplex.Chat.Remote.Discovery as Discovery
import Simplex.Chat.Remote.Protocol
import Simplex.Chat.Remote.Types
import Simplex.Chat.Store.Files (getRcvFileTransfer)
import Simplex.Chat.Store.Profiles (getUser)
import Simplex.Chat.Store.Remote
import Simplex.Chat.Store.Shared (StoreError (..))
import Simplex.Chat.Types
import Simplex.FileTransfer.Util (uniqueCombine)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile (..))
import Simplex.Messaging.Encoding.String (StrEncoding (..))
import Simplex.Messaging.Parsers (pattern SingleFieldJSONTag, pattern TaggedObjectJSONData, pattern TaggedObjectJSONTag)
import Simplex.Messaging.Transport.HTTP2.Server (HTTP2Request (..))
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport.Client (TransportHost (..))
import Simplex.Messaging.Transport.Credentials (genCredentials, tlsCredentials)
import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..), defaultHTTP2BufferSize)
import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client, HTTP2ClientError, HTTP2Response (..))
import qualified Simplex.Messaging.Transport.HTTP2.Client as HTTP2
import qualified Simplex.Messaging.Transport.HTTP2.Server as HTTP2
import Simplex.Messaging.Util (bshow, ifM, liftEitherError, liftEitherWith, tshow, ($>>=))
import System.FilePath (isPathSeparator, takeFileName, (</>))
import Simplex.Messaging.Transport.HTTP2.File (hSendFile)
import Simplex.Messaging.Util (ifM, liftEitherError, liftEitherWith, liftError, liftIOEither, tryAllErrors, tshow, ($>>=))
import System.FilePath ((</>))
import UnliftIO
import UnliftIO.Directory (createDirectoryIfMissing, getFileSize)
-- * Desktop side
getRemoteHostSession :: ChatMonad m => RemoteHostId -> m RemoteHostSession
getRemoteHostSession rhId = chatReadVar remoteHostSessions >>= maybe err pure . M.lookup rhId
where
err = throwError $ ChatErrorRemoteHost rhId RHMissing
getRemoteHostSession rhId = withRemoteHostSession rhId $ \_ s -> pure $ Right s
checkNoRemoteHostSession :: ChatMonad m => RemoteHostId -> m ()
checkNoRemoteHostSession rhId = chatReadVar remoteHostSessions >>= maybe (pure ()) err . M.lookup rhId
withRemoteHostSession :: ChatMonad m => RemoteHostId -> (TM.TMap RemoteHostId RemoteHostSession -> RemoteHostSession -> STM (Either ChatError a)) -> m a
withRemoteHostSession rhId = withRemoteHostSession_ rhId missing
where
err _ = throwError $ ChatErrorRemoteHost rhId RHBusy
missing _ = pure . Left $ ChatErrorRemoteHost rhId RHMissing
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
-- | 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
sessions <- asks remoteHostSessions
liftIOEither . atomically $ TM.lookup rhId sessions >>= maybe (missing sessions) (present sessions)
startRemoteHost :: ChatMonad m => RemoteHostId -> m ()
startRemoteHost rhId = do
checkNoRemoteHostSession rhId
rh <- withStore (`getRemoteHost` rhId)
announcer <- async $ do
finished <- newTVarIO False
http <- start rh finished `onChatError` cleanup finished
run rh finished http
chatModifyVar remoteHostSessions $ M.insert rhId RemoteHostSessionStarting {announcer}
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
where
cleanup finished = do
logInfo "Remote host http2 client fininshed"
atomically $ writeTVar finished True
-- TODO why this is not an error?
M.lookup rhId <$> chatReadVar remoteHostSessions >>= \case
Nothing -> logInfo $ "Session already closed for remote host " <> tshow rhId
Just _ -> closeRemoteHostSession rhId >> toView (CRRemoteHostStopped rhId)
start rh@RemoteHost {storePath, caKey, caCert} finished = do
let parent = (C.signatureKeyPair caKey, caCert)
sessionCreds <- liftIO $ genCredentials (Just parent) (0, 24) "Session"
let (fingerprint, credentials) = tlsCredentials $ sessionCreds :| [parent]
u <- askUnliftIO
ctrlClient <- liftHTTP2 $ Discovery.announceRevHTTP2 fingerprint credentials $ unliftIO u (cleanup finished) -- >>= \case
chatModifyVar remoteHostSessions $ M.insert rhId RemoteHostSessionStarted {storePath, ctrlClient}
chatWriteVar currentRemoteHost $ Just rhId
HTTP2Response {respBody = HTTP2Body {bodyHead}} <- sendHello ctrlClient
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
httpClient <- liftEitherError (ChatErrorRemoteCtrl . RCEHTTP2Error . show) $ Discovery.announceRevHTTP2 tasks fingerprint credentials cleanupIO
logInfo $ "Remote host session connected for " <> tshow rhId
rcName <- chatReadVar localDeviceName
-- TODO what sets session active?
toView CRRemoteHostConnected {remoteHost = remoteHostInfo rh True rcName}
pure ctrlClient
run RemoteHost {storePath} finished ctrlClient = do
-- test connection and establish a protocol layer
remoteHostClient <- liftRH rhId $ createRemoteHostClient httpClient rcName
-- set up message polling
oq <- asks outputQ
let toViewRemote = atomically . writeTBQueue oq . (Nothing,Just rhId,)
-- TODO remove REST
void . async $ pollRemote finished ctrlClient "/recv" $ handleFile >=> toViewRemote
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 = remoteDeviceName remoteHostClient,
remoteCtrlOOB = RemoteCtrlOOB {fingerprint, displayName=rcName},
sessionActive = True
}
genSessionCredentials RemoteHost {caKey, caCert} = do
sessionCreds <- genCredentials (Just parent) (0, 24) "Session"
pure . tlsCredentials $ sessionCreds :| [parent]
where
-- TODO move to view / terminal
handleFile = \case
cr@CRRcvFileComplete {user, chatItem = AChatItem c SMDRcv i ci@ChatItem {file = Just ciFile@CIFile {fileStatus = CIFSRcvComplete}}} -> do
maybe cr update <$> handleRcvFileComplete ctrlClient storePath user ciFile
where
update localFile = cr {chatItem = AChatItem c SMDRcv i ci {file = Just localFile}}
cr -> pure cr
parent = (C.signatureKeyPair caKey, caCert)
sendHello :: ChatMonad m => HTTP2Client -> m HTTP2Response
sendHello http = liftHTTP2 $ HTTP2.sendRequestDirect http req Nothing
where
req = HC.requestNoBody "GET" "/" mempty
-- TODO how (on what condition) it would stop polling?
-- TODO add JSON translation
pollRemote :: ChatMonad m => TVar Bool -> HTTP2Client -> ByteString -> (ChatResponse -> m ()) -> m ()
pollRemote finished http path action = loop `catchChatError` \e -> action (CRChatError Nothing e) >> loop
where
loop = do
-- TODO this will never load full body
HTTP2Response {respBody = HTTP2Body {bodyHead}} <- liftHTTP2 $ HTTP2.sendRequestDirect http req Nothing
json <- liftEitherWith (ChatErrorRemoteCtrl . RCEInvalidResponse) $ J.eitherDecodeStrict' bodyHead -- of
action json
readTVarIO finished >>= (`unless` loop)
req = HC.requestNoBody "GET" path mempty
-- | 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 remoteHostId = do
session <- getRemoteHostSession remoteHostId
logInfo $ "Closing remote host session for " <> tshow remoteHostId
liftIO $ cancelRemoteHostSession session
chatWriteVar currentRemoteHost Nothing
chatModifyVar remoteHostSessions $ M.delete remoteHostId
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 = \case
RemoteHostSessionStarting {announcer} -> cancel announcer
RemoteHostSessionStarted {ctrlClient} -> liftIO $ HTTP2.closeHTTP2Client ctrlClient
cancelRemoteHostSession RemoteHostSession {remoteHostTasks, remoteHostClient} = do
cancelTasks remoteHostTasks
mapM_ closeRemoteHostClient remoteHostClient
createRemoteHost :: ChatMonad m => m RemoteHostInfo
createRemoteHost = do
let rhName = "TODO" -- you don't have remote host name here, it will be passed from remote host
((_, caKey), caCert) <- liftIO $ genCredentials Nothing (-25, 24 * 365) rhName
((_, caKey), caCert) <- liftIO $ genCredentials Nothing (-25, 24 * 365) "Host"
storePath <- liftIO randomStorePath
remoteHostId <- withStore' $ \db -> insertRemoteHost db storePath rhName caKey caCert
rcName <- chatReadVar localDeviceName
let remoteCtrlOOB = RemoteCtrlOOB {fingerprint = C.certificateFingerprint caCert, displayName = rcName}
pure RemoteHostInfo {remoteHostId, storePath, displayName = rhName, remoteCtrlOOB, sessionActive = False}
let remoteName = "" -- will be passed from remote host in hello
remoteHostId <- withStore' $ \db -> insertRemoteHost db storePath remoteName caKey caCert
localName <- chatReadVar localDeviceName
let remoteCtrlOOB = RemoteCtrlOOB {fingerprint = C.certificateFingerprint caCert, displayName = localName}
pure RemoteHostInfo {remoteHostId, storePath, displayName = remoteName, remoteCtrlOOB, sessionActive = False}
-- | Generate a random 16-char filepath without / in it by using base64url encoding.
randomStorePath :: IO FilePath
@ -191,241 +178,111 @@ deleteRemoteHost rhId = do
Nothing -> logWarn "Local file store not available while deleting remote host"
withStore' (`deleteRemoteHostRecord` rhId)
processRemoteCommand :: ChatMonad m => RemoteHostSession -> (ByteString, ChatCommand) -> m ChatResponse
processRemoteCommand RemoteHostSessionStarting {} _ = pure $ chatCmdError Nothing "remote command sent before session started"
processRemoteCommand RemoteHostSessionStarted {ctrlClient} (s, cmd) =
uploadFile cmd >>= relayCommand ctrlClient
where
fileCmd cmdPfx cn hostPath = utf8String $ unwords [cmdPfx, chatNameStr cn, hostPath]
uploadFile = \case
SendFile cn ctrlPath -> fileCmd "/file" cn <$> storeRemoteFile ctrlClient ctrlPath
SendImage cn ctrlPath -> fileCmd "/image" cn <$> storeRemoteFile ctrlClient ctrlPath
-- TODO APISendMessage should only be used with host path already, and UI has to upload file first.
-- The problem is that we cannot have different file names in host and controller, because it simply won't be able to show files.
-- So we need to ask the host to store files BEFORE storing them in the app storage and use host names in the command and to store the file locally if it has to be shown,
-- or don't even store it if it's not image/video.
-- The current approach won't work.
-- It also does not account for local file encryption.
-- Also, local file encryption setting should be tracked in the controller, as otherwise host won't be able to decide what to do having received the upload command.
APISendMessage {composedMessage = cm@ComposedMessage {fileSource = Just CryptoFile {filePath = ctrlPath, cryptoArgs}}} -> do
hostPath <- storeRemoteFile ctrlClient ctrlPath
let cm' = cm {fileSource = Just CryptoFile {filePath = hostPath, cryptoArgs}} :: ComposedMessage
-- TODO we shouldn't manipulate JSON like that
pure $ B.takeWhile (/= '{') s <> B.toStrict (J.encode cm')
_ -> pure s
processRemoteCommand :: ChatMonad m => RemoteHostId -> RemoteHostSession -> ByteString -> m ChatResponse
processRemoteCommand remoteHostId RemoteHostSession {remoteHostClient = Just rhc} s = liftRH remoteHostId $ remoteSend rhc s
processRemoteCommand _ _ _ = pure $ chatCmdError Nothing "remote command sent before session started"
relayCommand :: ChatMonad m => HTTP2Client -> ByteString -> m ChatResponse
relayCommand http s = do
-- TODO ExceptT
let timeout' = Nothing
HTTP2Response {respBody = HTTP2Body {bodyHead}} <-
liftHTTP2 $ HTTP2.sendRequestDirect http req timeout'
-- TODO: large JSONs can overflow into buffered chunks
json <- liftEitherWith (ChatErrorRemoteCtrl . RCEInvalidResponse) $ J.eitherDecodeStrict' bodyHead
case J.fromJSON $ toTaggedJSON json of
J.Error e -> err $ show e
J.Success cr -> pure cr
where
err = pure . CRChatError Nothing . ChatErrorRemoteCtrl . RCEInvalidResponse
toTaggedJSON :: J.Value -> J.Value
toTaggedJSON = id -- owsf2tagged TODO: get from RemoteHost
req = HC.requestBuilder "POST" "/send" mempty (Binary.fromByteString s)
liftRH :: ChatMonad m => RemoteHostId -> ExceptT RemoteProtocolError IO a -> m a
liftRH rhId = liftError (ChatErrorRemoteHost rhId . RHProtocolError)
-- TODO fileName is just metadata that does not determine the actual file location for UI, or whether it is encrypted or not
-- fileSource is the actual file location (with information whether it is locally encrypted)
handleRcvFileComplete :: ChatMonad m => HTTP2Client -> FilePath -> User -> CIFile 'MDRcv -> m (Maybe (CIFile 'MDRcv))
handleRcvFileComplete http storePath remoteUser f@CIFile {fileId, fileName} =
chatReadVar filesFolder >>= \case
Just baseDir -> do
let hostStore = baseDir </> storePath
createDirectoryIfMissing True hostStore
-- TODO the problem here is that the name may turn out to be different and nothing will work
-- file processing seems to work "accidentally", not "by design"
localPath <- uniqueCombine hostStore fileName
fetchRemoteFile http remoteUser fileId localPath
pure $ Just (f {fileName = localPath} :: CIFile 'MDRcv)
-- TODO below will not work with CLI, it should store file to download folder when not specified
-- It should not load all files when received, instead it should only load files received with /fr commands
Nothing -> Nothing <$ logError "Local file store not available while fetching remote file"
-- * Mobile side
-- | Convert swift single-field sum encoding into tagged/discriminator-field
owsf2tagged :: J.Value -> J.Value
owsf2tagged = fst . convert
where
convert val = case val of
J.Object o
| JM.size o == 2 ->
case JM.toList o of
[OwsfTag, o'] -> tagged o'
[o', OwsfTag] -> tagged o'
_ -> props
| otherwise -> props
where
props = (J.Object $ fmap owsf2tagged o, False)
J.Array a -> (J.Array $ fmap owsf2tagged a, False)
_ -> (val, False)
-- `tagged` converts the pair of single-field object encoding to tagged encoding.
-- It sets innerTag returned by `convert` to True to prevent the tag being overwritten.
tagged (k, v) = (J.Object pairs, True)
where
(v', innerTag) = convert v
pairs = case v' of
-- `innerTag` indicates that internal object already has tag,
-- so the current tag cannot be inserted into it.
J.Object o
| innerTag -> pair
| otherwise -> JM.insert TaggedObjectJSONTag tag o
_ -> pair
tag = J.String $ JK.toText k
pair = JM.fromList [TaggedObjectJSONTag .= tag, TaggedObjectJSONData .= v']
pattern OwsfTag :: (JK.Key, J.Value)
pattern OwsfTag = (SingleFieldJSONTag, J.Bool True)
storeRemoteFile :: ChatMonad m => HTTP2Client -> FilePath -> m FilePath
storeRemoteFile http localFile = do
fileSize <- liftIO $ fromIntegral <$> getFileSize localFile
-- TODO configure timeout
let timeout' = Nothing
r@HTTP2Response {respBody = HTTP2Body {bodyHead}} <-
liftHTTP2 $ HTTP2.sendRequestDirect http (req fileSize) timeout'
responseStatusOK r
-- TODO what if response doesn't fit in the head?
-- it'll be solved when processing moved to POST with Command/Response types
pure $ B.unpack bodyHead
where
-- TODO local file encryption?
uri = "/store?" <> HTTP.renderSimpleQuery False [("file_name", utf8String $ takeFileName localFile)]
req size = HC.requestFile "PUT" uri mempty (HC.FileSpec localFile 0 size)
liftHTTP2 :: ChatMonad m => IO (Either HTTP2ClientError a) -> m a
liftHTTP2 = liftEitherError $ ChatErrorRemoteCtrl . RCEHTTP2Error . show
responseStatusOK :: ChatMonad m => HTTP2Response -> m ()
responseStatusOK HTTP2Response {response} = do
let s = HC.responseStatus response
unless (s == Just Status.ok200) $
throwError $ ChatErrorRemoteCtrl $ RCEHTTP2RespStatus $ Status.statusCode <$> s
fetchRemoteFile :: ChatMonad m => HTTP2Client -> User -> Int64 -> FilePath -> m ()
fetchRemoteFile http User {userId = remoteUserId} remoteFileId localPath = do
r@HTTP2Response {respBody} <- liftHTTP2 $ HTTP2.sendRequestDirect http req Nothing
responseStatusOK r
writeBodyToFile localPath respBody
where
req = HC.requestNoBody "GET" path mempty
path = "/fetch?" <> HTTP.renderSimpleQuery False [("user_id", bshow remoteUserId), ("file_id", bshow remoteFileId)]
-- XXX: extract to Transport.HTTP2 ?
writeBodyToFile :: MonadUnliftIO m => FilePath -> HTTP2Body -> m ()
writeBodyToFile path HTTP2Body {bodyHead, bodySize, bodyPart} = do
logInfo $ "Receiving " <> tshow bodySize <> " bytes to " <> tshow path
liftIO . withFile path WriteMode $ \h -> do
hPut h bodyHead
mapM_ (hPutBodyChunks h) bodyPart
hPutBodyChunks :: Handle -> (Int -> IO ByteString) -> IO ()
hPutBodyChunks h getChunk = do
chunk <- getChunk defaultHTTP2BufferSize
unless (B.null chunk) $ do
hPut h chunk
hPutBodyChunks h getChunk
-- TODO command/response pattern, remove REST conventions
processControllerRequest :: forall m. ChatMonad m => (ByteString -> m ChatResponse) -> HTTP2.HTTP2Request -> m ()
processControllerRequest execChatCommand HTTP2.HTTP2Request {request, reqBody, sendResponse} = do
logDebug $ "Remote controller request: " <> tshow (method <> " " <> path)
res <- tryChatError $ case (method, ps) of
("GET", []) -> getHello
("POST", ["send"]) -> sendCommand
("GET", ["recv"]) -> recvMessage
("PUT", ["store"]) -> storeFile
("GET", ["fetch"]) -> fetchFile
unexpected -> respondWith Status.badRequest400 $ "unexpected method/path: " <> Binary.putStringUtf8 (show unexpected)
case res of
Left e -> logError $ "Error handling remote controller request: (" <> tshow (method <> " " <> path) <> "): " <> tshow e
Right () -> logDebug $ "Remote controller request: " <> tshow (method <> " " <> path) <> " OK"
where
method = fromMaybe "" $ HS.requestMethod request
path = fromMaybe "/" $ HS.requestPath request
(ps, query) = HTTP.decodePath path
getHello = respond "OK"
sendCommand = execChatCommand (bodyHead reqBody) >>= respondJSON
recvMessage =
chatReadVar remoteCtrlSession >>= \case
Nothing -> respondWith Status.internalServerError500 "session not active"
Just rcs -> atomically (readTBQueue $ remoteOutputQ rcs) >>= respondJSON
-- TODO liftEither storeFileQuery
storeFile = case storeFileQuery of
Left err -> respondWith Status.badRequest400 (Binary.putStringUtf8 err)
Right fileName -> do
baseDir <- fromMaybe "." <$> chatReadVar filesFolder
localPath <- uniqueCombine baseDir fileName
logDebug $ "Storing controller file to " <> tshow (baseDir, localPath)
writeBodyToFile localPath reqBody
let storeRelative = takeFileName localPath
respond $ Binary.putStringUtf8 storeRelative
where
storeFileQuery = parseField "file_name" $ A.many1 (A.satisfy $ not . isPathSeparator)
-- TODO move to ExceptT monad, catch errors in one place, convert errors to responses
fetchFile = case fetchFileQuery of
Left err -> respondWith Status.badRequest400 (Binary.putStringUtf8 err)
Right (userId, fileId) -> do
logInfo $ "Fetching file " <> tshow fileId <> " from user " <> tshow userId
x <- withStore' $ \db -> runExceptT $ do
user <- getUser db userId
getRcvFileTransfer db user fileId
-- TODO this error handling is very ad-hoc, there is no separation between Chat errors and responses
case x of
Right RcvFileTransfer {fileStatus = RFSComplete RcvFileInfo {filePath}} -> do
baseDir <- fromMaybe "." <$> chatReadVar filesFolder
let fullPath = baseDir </> filePath
size <- fromInteger <$> getFileSize fullPath
liftIO . sendResponse . HS.responseFile Status.ok200 mempty $ HS.FileSpec fullPath 0 size
Right _ -> respondWith Status.internalServerError500 "The requested file is not complete"
Left SEUserNotFound {} -> respondWith Status.notFound404 "User not found"
Left SERcvFileNotFound {} -> respondWith Status.notFound404 "File not found"
_ -> respondWith Status.internalServerError500 "Store error"
where
fetchFileQuery =
(,)
<$> parseField "user_id" A.decimal
<*> parseField "file_id" A.decimal
parseField :: ByteString -> A.Parser a -> Either String a
parseField field p = maybe (Left $ "missing " <> B.unpack field) (A.parseOnly $ p <* A.endOfInput) (join $ lookup field query)
respondJSON :: (J.ToJSON a) => a -> m ()
respondJSON = respond . Binary.fromLazyByteString . J.encode
respond = respondWith Status.ok200
respondWith status = liftIO . sendResponse . HS.responseBuilder status []
-- * ChatRequest handlers
startRemoteCtrl :: ChatMonad m => (ByteString -> m ChatResponse) -> m ()
startRemoteCtrl :: forall m . ChatMonad m => (ByteString -> m ChatResponse) -> m ()
startRemoteCtrl execChatCommand = do
checkNoRemoteCtrlSession
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
discovered <- newTVarIO mempty
discoverer <- async $ discoverRemoteCtrls discovered
accepted <- newEmptyTMVarIO
supervisor <- async $ runSupervisor discovered accepted
supervisor <- async $ runHost discovered accepted $ handleRemoteCommand execChatCommand remoteOutputQ
chatWriteVar remoteCtrlSession $ Just RemoteCtrlSession {discoverer, supervisor, hostServer = Nothing, discovered, accepted, remoteOutputQ}
-- | Track remote host lifecycle in controller session state and signal UI on its progress
runHost :: ChatMonad m => TM.TMap C.KeyHash TransportHost -> TMVar RemoteCtrlId -> (HTTP2Request -> m ()) -> m ()
runHost discovered accepted handleHttp = do
remoteCtrlId <- atomically (readTMVar accepted) -- wait for ???
rc@RemoteCtrl {fingerprint} <- withStore (`getRemoteCtrl` remoteCtrlId)
source <- 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 $ Discovery.connectRevHTTP2 source fingerprint handleHttp -- spawn server for remote protocol commands
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 execChatCommand remoteOutputQ HTTP2Request {request, reqBody, sendResponse} = do
logDebug "handleRemoteCommand"
liftRC (tryRemoteError parseRequest) >>= \case
Right (getNext, rc) -> processCommand getNext rc `catchAny` (reply . RRProtocolError . RPEException . tshow)
Left e -> reply $ RRProtocolError e
where
runSupervisor discovered accepted = do
remoteCtrlId <- atomically (readTMVar accepted)
rc@RemoteCtrl {fingerprint} <- withStore (`getRemoteCtrl` remoteCtrlId)
source <- atomically $ TM.lookup fingerprint discovered >>= maybe retry pure
toView $ CRRemoteCtrlConnecting $ remoteCtrlInfo rc False
atomically $ writeTVar discovered mempty -- flush unused sources
server <- async $ Discovery.connectRevHTTP2 source fingerprint (processControllerRequest execChatCommand)
chatModifyVar remoteCtrlSession $ fmap $ \s -> s {hostServer = Just server}
toView $ CRRemoteCtrlConnected $ remoteCtrlInfo rc True
_ <- waitCatch server
chatWriteVar remoteCtrlSession Nothing
toView CRRemoteCtrlStopped
parseRequest :: ExceptT RemoteProtocolError IO (GetChunk, RemoteCommand)
parseRequest = do
(header, getNext) <- parseHTTP2Body request reqBody
(getNext,) <$> liftEitherWith (RPEInvalidJSON . T.pack) (J.eitherDecodeStrict' header)
processCommand :: GetChunk -> RemoteCommand -> m ()
processCommand getNext = \case
RCHello {deviceName = desktopName} -> handleHello desktopName >>= reply
RCSend {command} -> handleSend execChatCommand command >>= reply
RCRecv {wait = time} -> handleRecv time remoteOutputQ >>= reply
RCStoreFile {fileSize, encrypt} -> handleStoreFile fileSize encrypt getNext >>= reply
RCGetFile {filePath} -> handleGetFile filePath replyWith
reply :: RemoteResponse -> m ()
reply = (`replyWith` \_ -> pure ())
replyWith :: Respond m
replyWith rr attach =
liftIO . sendResponse . responseStreaming N.status200 [] $ \send flush -> do
send $ sizePrefixedEncode rr
attach send
flush
type GetChunk = Int -> IO ByteString
type SendChunk = Builder -> IO ()
type Respond m = RemoteResponse -> (SendChunk -> IO ()) -> m ()
liftRC :: ChatMonad m => ExceptT RemoteProtocolError IO a -> m a
liftRC = liftError (ChatErrorRemoteCtrl . RCEProtocolError)
tryRemoteError :: ExceptT RemoteProtocolError IO a -> ExceptT RemoteProtocolError IO (Either RemoteProtocolError a)
tryRemoteError = tryAllErrors (RPEException . tshow)
{-# INLINE tryRemoteError #-}
handleHello :: ChatMonad m => Text -> m RemoteResponse
handleHello desktopName = do
logInfo $ "Hello from " <> tshow desktopName
mobileName <- chatReadVar localDeviceName
pure RRHello {encoding = localEncoding, deviceName = mobileName}
handleSend :: ChatMonad m => (ByteString -> m ChatResponse) -> Text -> m RemoteResponse
handleSend execChatCommand command = do
logDebug $ "Send: " <> tshow command
-- execChatCommand checks for remote-allowed commands
-- convert errors thrown in ChatMonad into error responses to prevent aborting the protocol wrapper
RRChatResponse <$> execChatCommand (encodeUtf8 command) `catchError` (pure . CRChatError Nothing)
handleRecv :: MonadUnliftIO m => Int -> TBQueue ChatResponse -> m RemoteResponse
handleRecv time events = do
logDebug $ "Recv: " <> tshow time
RRChatEvent <$> (timeout time . atomically $ readTBQueue events)
handleStoreFile :: ChatMonad m => Word32 -> Maybe Bool -> GetChunk -> m RemoteResponse
handleStoreFile _fileSize _encrypt _getNext = error "TODO" <$ logError "TODO: handleStoreFile"
handleGetFile :: ChatMonad m => FilePath -> Respond m -> m ()
handleGetFile path reply = do
logDebug $ "GetFile: " <> tshow path
withFile path ReadMode $ \h -> do
fileSize' <- hFileSize h
when (fileSize' > toInteger (maxBound :: Word32)) $ throwIO RPEFileTooLarge
let fileSize = fromInteger fileSize'
reply RRFile {fileSize} $ \send -> hSendFile h send fileSize
-- TODO the problem with this code was that it wasn't clear where the recursion can happen,
-- by splitting receiving and processing to two functions it becomes clear

View file

@ -1,4 +1,5 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
@ -20,6 +21,7 @@ module Simplex.Chat.Remote.Discovery
)
where
import Control.Logger.Simple
import Control.Monad
import Data.ByteString (ByteString)
import Data.Default (def)
@ -27,16 +29,17 @@ import Data.String (IsString)
import qualified Network.Socket as N
import qualified Network.TLS as TLS
import qualified Network.UDP as UDP
import Simplex.Chat.Remote.Types (Tasks, registerAsync)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding.String (StrEncoding (..))
import Simplex.Messaging.Transport (supportedParameters)
import qualified Simplex.Messaging.Transport as Transport
import Simplex.Messaging.Transport.Client (TransportHost (..), defaultTransportClientConfig, runTransportClient)
import Simplex.Messaging.Transport.HTTP2 (defaultHTTP2BufferSize, getHTTP2Body)
import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client, HTTP2ClientError, attachHTTP2Client, connTimeout, defaultHTTP2ClientConfig)
import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client, HTTP2ClientError (..), attachHTTP2Client, bodyHeadSize, connTimeout, defaultHTTP2ClientConfig)
import Simplex.Messaging.Transport.HTTP2.Server (HTTP2Request (..), runHTTP2ServerWith)
import Simplex.Messaging.Transport.Server (defaultTransportServerConfig, runTransportServer)
import Simplex.Messaging.Util (whenM)
import Simplex.Messaging.Util (ifM, tshow, whenM)
import UnliftIO
import UnliftIO.Concurrent
@ -53,18 +56,33 @@ pattern BROADCAST_PORT = "5226"
-- | Announce tls server, wait for connection and attach http2 client to it.
--
-- Announcer is started when TLS server is started and stopped when a connection is made.
announceRevHTTP2 :: StrEncoding a => a -> TLS.Credentials -> IO () -> IO (Either HTTP2ClientError HTTP2Client)
announceRevHTTP2 invite credentials finishAction = do
announceRevHTTP2 :: StrEncoding a => Tasks -> a -> TLS.Credentials -> IO () -> IO (Either HTTP2ClientError HTTP2Client)
announceRevHTTP2 tasks invite credentials finishAction = do
httpClient <- newEmptyMVar
started <- newEmptyTMVarIO
finished <- newEmptyMVar
announcer <- async . liftIO . whenM (atomically $ takeTMVar started) $ runAnnouncer (strEncode invite)
tlsServer <- startTLSServer started credentials $ \tls -> cancel announcer >> runHTTP2Client finished httpClient tls
_ <- forkIO $ do
readMVar finished
_ <- forkIO $ readMVar finished >> finishAction -- attach external cleanup action to session lock
announcer <- async . liftIO . whenM (atomically $ takeTMVar started) $ do
logInfo $ "Starting announcer for " <> tshow (strEncode invite)
runAnnouncer (strEncode invite)
tasks `registerAsync` announcer
tlsServer <- startTLSServer started credentials $ \tls -> do
logInfo $ "Incoming connection for " <> tshow (strEncode invite)
cancel announcer
cancel tlsServer
finishAction
runHTTP2Client finished httpClient tls `catchAny` (logError . tshow)
logInfo $ "Client finished for " <> tshow (strEncode invite)
-- BUG: this should be handled in HTTP2Client wrapper
_ <- forkIO $ do
waitCatch tlsServer >>= \case
Left err | fromException err == Just AsyncCancelled -> logDebug "tlsServer cancelled"
Left err -> do
logError $ "tlsServer failed to start: " <> tshow err
void $ tryPutMVar httpClient $ Left HCNetworkError
void . atomically $ tryPutTMVar started False
Right () -> pure ()
void $ tryPutMVar finished ()
tasks `registerAsync` tlsServer
logInfo $ "Waiting for client for " <> tshow (strEncode invite)
readMVar httpClient
-- | Broadcast invite with link-local datagrams
@ -77,8 +95,7 @@ runAnnouncer inviteBS = do
UDP.send sock inviteBS
threadDelay 1000000
-- TODO what prevents second client from connecting to the same server?
-- Do we need to start multiple TLS servers for different mobile hosts?
-- XXX: Do we need to start multiple TLS servers for different mobile hosts?
startTLSServer :: (MonadUnliftIO m) => TMVar Bool -> TLS.Credentials -> (Transport.TLS -> IO ()) -> m (Async ())
startTLSServer started credentials = async . liftIO . runTransportServer started BROADCAST_PORT serverParams defaultTransportServerConfig
where
@ -92,11 +109,17 @@ startTLSServer started credentials = async . liftIO . runTransportServer started
-- | 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 = do
attachHTTP2Client config ANY_ADDR_V4 BROADCAST_PORT (putMVar finishedVar ()) defaultHTTP2BufferSize tls >>= putMVar clientVar
readMVar finishedVar
runHTTP2Client finishedVar clientVar tls =
ifM (isEmptyMVar clientVar)
attachClient
(logError "HTTP2 session already started on this listener")
where
config = defaultHTTP2ClientConfig { connTimeout = 86400000000 }
attachClient = do
client <- attachHTTP2Client config ANY_ADDR_V4 BROADCAST_PORT (putMVar finishedVar ()) defaultHTTP2BufferSize tls
putMVar clientVar client
readMVar finishedVar
-- TODO connection timeout
config = defaultHTTP2ClientConfig {bodyHeadSize = doNotPrefetchHead, connTimeout = maxBound}
withListener :: (MonadUnliftIO m) => (UDP.ListenSocket -> m a) -> m a
withListener = bracket openListener (liftIO . UDP.stop)
@ -122,5 +145,9 @@ attachHTTP2Server :: (MonadUnliftIO m) => (HTTP2Request -> m ()) -> Transport.TL
attachHTTP2Server processRequest tls = do
withRunInIO $ \unlift ->
runHTTP2ServerWith defaultHTTP2BufferSize ($ tls) $ \sessionId r sendResponse -> do
reqBody <- getHTTP2Body r defaultHTTP2BufferSize
reqBody <- getHTTP2Body r doNotPrefetchHead
unlift $ processRequest HTTP2Request {sessionId, request = r, reqBody, sendResponse}
-- | Suppress storing initial chunk in bodyHead, forcing clients and servers to stream chunks
doNotPrefetchHead :: Int
doNotPrefetchHead = 0

View file

@ -0,0 +1,199 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TemplateHaskell #-}
module Simplex.Chat.Remote.Protocol where
import Control.Logger.Simple
import Control.Monad
import Control.Monad.Except
import Data.Aeson ((.=))
import qualified Data.Aeson as J
import qualified Data.Aeson.Key as JK
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 qualified Data.ByteString.Lazy as BL
import Data.String (fromString)
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8)
import Data.Word (Word32)
import qualified Network.HTTP.Types as N
import qualified Network.HTTP2.Client as H
import Network.Transport.Internal (decodeWord32)
import Simplex.Chat.Controller (ChatResponse)
import Simplex.Chat.Remote.Types
import Simplex.Messaging.Crypto.File (CryptoFile)
import Simplex.Messaging.Parsers (dropPrefix, taggedObjectJSON, pattern SingleFieldJSONTag, pattern TaggedObjectJSONData, pattern TaggedObjectJSONTag)
import Simplex.Messaging.Transport.Buffer (getBuffered)
import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..), HTTP2BodyChunk, getBodyChunk)
import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client, HTTP2Response (..), closeHTTP2Client, sendRequestDirect)
import Simplex.Messaging.Transport.HTTP2.File (hReceiveFile, hSendFile)
import Simplex.Messaging.Util (liftEitherError, liftEitherWith, tshow, whenM)
import System.FilePath ((</>))
import UnliftIO
import UnliftIO.Directory (doesFileExist, getFileSize)
data RemoteCommand
= RCHello {deviceName :: Text}
| RCSend {command :: Text} -- TODO maybe ChatCommand here?
| RCRecv {wait :: Int} -- this wait should be less than HTTP timeout
| -- local file encryption is determined by the host, but can be overridden for videos
RCStoreFile {fileSize :: Word32, encrypt :: Maybe Bool} -- requires attachment
| RCGetFile {filePath :: FilePath}
deriving (Show)
data RemoteResponse
= RRHello {encoding :: PlatformEncoding, deviceName :: Text}
| RRChatResponse {chatResponse :: ChatResponse}
| RRChatEvent {chatEvent :: Maybe ChatResponse} -- ^ 'Nothing' on poll timeout
| RRFileStored {fileSource :: CryptoFile}
| RRFile {fileSize :: Word32} -- provides attachment
| RRProtocolError {remoteProcotolError :: RemoteProtocolError} -- ^ The protocol error happened on the server side
deriving (Show)
-- Force platform-independent encoding as the types aren't UI-visible
$(deriveJSON (taggedObjectJSON $ dropPrefix "RC") ''RemoteCommand)
$(deriveJSON (taggedObjectJSON $ dropPrefix "RR") ''RemoteResponse)
-- * Client side / desktop
createRemoteHostClient :: HTTP2Client -> Text -> ExceptT RemoteProtocolError IO RemoteHostClient
createRemoteHostClient httpClient desktopName = do
logInfo "Sending initial hello"
(_getNext, rr) <- sendRemoteCommand httpClient localEncoding Nothing RCHello {deviceName = desktopName}
case rr of
rrh@RRHello {encoding, deviceName = mobileName} -> do
logInfo $ "Got initial hello: " <> tshow rrh
when (encoding == PEKotlin && localEncoding == PESwift) $ throwError RPEIncompatibleEncoding
pure RemoteHostClient {remoteEncoding = encoding, remoteDeviceName = mobileName, httpClient}
_ -> throwError $ RPEUnexpectedResponse $ tshow rr
closeRemoteHostClient :: MonadIO m => RemoteHostClient -> m ()
closeRemoteHostClient RemoteHostClient {httpClient} = liftIO $ closeHTTP2Client httpClient
-- ** Commands
remoteSend :: RemoteHostClient -> ByteString -> ExceptT RemoteProtocolError IO ChatResponse
remoteSend RemoteHostClient {httpClient, remoteEncoding} cmd = do
(_getNext, rr) <- sendRemoteCommand httpClient remoteEncoding Nothing RCSend {command = decodeUtf8 cmd}
case rr of
RRChatResponse cr -> pure cr
_ -> throwError $ RPEUnexpectedResponse $ tshow rr
remoteRecv :: RemoteHostClient -> Int -> ExceptT RemoteProtocolError IO (Maybe ChatResponse)
remoteRecv RemoteHostClient {httpClient, remoteEncoding} ms = do
(_getNext, rr) <- sendRemoteCommand httpClient remoteEncoding Nothing RCRecv {wait=ms}
case rr of
RRChatEvent cr_ -> pure cr_
_ -> throwError $ RPEUnexpectedResponse $ tshow rr
remoteStoreFile :: RemoteHostClient -> FilePath -> Maybe Bool -> ExceptT RemoteProtocolError IO CryptoFile
remoteStoreFile RemoteHostClient {httpClient, remoteEncoding} localPath encrypt = do
(_getNext, rr) <- withFile localPath ReadMode $ \h -> do
fileSize' <- hFileSize h
when (fileSize' > toInteger (maxBound :: Word32)) $ throwError RPEFileTooLarge
let fileSize = fromInteger fileSize'
sendRemoteCommand httpClient remoteEncoding (Just (h, fileSize)) RCStoreFile {encrypt, fileSize}
case rr of
RRFileStored {fileSource} -> pure fileSource
_ -> throwError $ RPEUnexpectedResponse $ tshow rr
-- TODO this should work differently for CLI and UI clients
-- CLI - potentially, create new unique names and report them as created
-- UI - always use the same names and report error if file already exists
-- alternatively, CLI should also use a fixed folder for remote session
-- Possibly, path in the database should be optional and CLI commands should allow configuring it per session or use temp or download folder
remoteGetFile :: RemoteHostClient -> FilePath -> FilePath -> ExceptT RemoteProtocolError IO FilePath
remoteGetFile RemoteHostClient {httpClient, remoteEncoding} baseDir filePath = do
(getNext, rr) <- sendRemoteCommand httpClient remoteEncoding Nothing RCGetFile {filePath}
expectedSize <- case rr of
RRFile {fileSize} -> pure fileSize
_ -> throwError $ RPEUnexpectedResponse $ tshow rr
whenM (liftIO $ doesFileExist localFile) $ throwError RPEStoredFileExists
rc <- liftIO $ withFile localFile WriteMode $ \h -> hReceiveFile getNext h expectedSize
when (rc /= 0) $ throwError RPEInvalidSize
whenM ((== expectedSize) . fromIntegral <$> getFileSize localFile) $ throwError RPEInvalidSize
pure localFile
where
localFile = baseDir </> filePath
sendRemoteCommand :: HTTP2Client -> PlatformEncoding -> Maybe (Handle, Word32) -> RemoteCommand -> ExceptT RemoteProtocolError IO (Int -> IO ByteString, RemoteResponse)
sendRemoteCommand http remoteEncoding attachment_ rc = do
HTTP2Response {response, respBody} <- liftEitherError (RPEHTTP2 . tshow) $ sendRequestDirect http httpRequest Nothing
(header, getNext) <- parseHTTP2Body response respBody
rr <- liftEitherWith (RPEInvalidJSON . fromString) $ J.eitherDecodeStrict header >>= JT.parseEither J.parseJSON . convertJSON remoteEncoding localEncoding
pure (getNext, rr)
where
httpRequest = H.requestStreaming N.methodPost "/" mempty $ \send flush -> do
send $ sizePrefixedEncode rc
case attachment_ of
Nothing -> pure ()
Just (h, sz) -> hSendFile h send sz
flush
-- * Transport-level wrappers
convertJSON :: PlatformEncoding -> PlatformEncoding -> J.Value -> J.Value
convertJSON _remote@PEKotlin _local@PEKotlin = id
convertJSON PESwift PESwift = id
convertJSON PESwift PEKotlin = owsf2tagged
convertJSON PEKotlin PESwift = error "unsupported convertJSON: K/S" -- guarded by createRemoteHostClient
-- | Convert swift single-field sum encoding into tagged/discriminator-field
owsf2tagged :: J.Value -> J.Value
owsf2tagged = fst . convert
where
convert val = case val of
J.Object o
| JM.size o == 2 ->
case JM.toList o of
[OwsfTag, o'] -> tagged o'
[o', OwsfTag] -> tagged o'
_ -> props
| otherwise -> props
where
props = (J.Object $ fmap owsf2tagged o, False)
J.Array a -> (J.Array $ fmap owsf2tagged a, False)
_ -> (val, False)
-- `tagged` converts the pair of single-field object encoding to tagged encoding.
-- It sets innerTag returned by `convert` to True to prevent the tag being overwritten.
tagged (k, v) = (J.Object pairs, True)
where
(v', innerTag) = convert v
pairs = case v' of
-- `innerTag` indicates that internal object already has tag,
-- so the current tag cannot be inserted into it.
J.Object o
| innerTag -> pair
| otherwise -> JM.insert TaggedObjectJSONTag tag o
_ -> pair
tag = J.String $ JK.toText k
pair = JM.fromList [TaggedObjectJSONTag .= tag, TaggedObjectJSONData .= v']
pattern OwsfTag :: (JK.Key, J.Value)
pattern OwsfTag = (SingleFieldJSONTag, J.Bool True)
-- | Convert a command or a response into 'Builder'.
sizePrefixedEncode :: J.ToJSON a => a -> Builder
sizePrefixedEncode value = word32BE (fromIntegral $ BL.length json) <> lazyByteString json
where
json = J.encode value
-- | Parse HTTP request or response to a size-prefixed chunk and a function to read more.
parseHTTP2Body :: HTTP2BodyChunk a => a -> HTTP2Body -> ExceptT RemoteProtocolError IO (ByteString, Int -> IO ByteString)
parseHTTP2Body hr HTTP2Body {bodyBuffer} = do
rSize <- liftIO $ decodeWord32 <$> getNext 4
when (rSize > fromIntegral (maxBound :: Int)) $ throwError RPEInvalidSize
r <- liftIO $ getNext $ fromIntegral rSize
pure (r, getNext)
where
getNext sz = getBuffered bodyBuffer sz Nothing $ getBodyChunk hr

View file

@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
@ -5,10 +6,39 @@
module Simplex.Chat.Remote.Types where
import Control.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.Messaging.Transport.HTTP2.Client (HTTP2Client)
import Simplex.Messaging.Parsers (dropPrefix, enumJSON, sumTypeJSON)
import UnliftIO
data RemoteHostClient = RemoteHostClient
{ remoteEncoding :: PlatformEncoding,
remoteDeviceName :: Text,
httpClient :: HTTP2Client
}
data RemoteHostSession = RemoteHostSession
{ remoteHostTasks :: Tasks,
remoteHostClient :: Maybe RemoteHostClient,
storePath :: FilePath
}
data RemoteProtocolError
= RPEInvalidSize -- ^ size prefix is malformed
| RPEInvalidJSON {invalidJSON :: Text} -- ^ failed to parse RemoteCommand or RemoteResponse
| RPEIncompatibleEncoding
| RPEUnexpectedFile
| RPENoFile
| RPEFileTooLarge
| RPEUnexpectedResponse {response :: Text} -- ^ Wrong response received for the command sent
| RPEStoredFileExists -- ^ A file already exists in the destination position
| RPEHTTP2 {http2Error :: Text}
| RPEException {someException :: Text}
deriving (Show, Exception)
type RemoteHostId = Int64
@ -30,8 +60,6 @@ data RemoteCtrlOOB = RemoteCtrlOOB
}
deriving (Show)
$(J.deriveJSON J.defaultOptions ''RemoteCtrlOOB)
data RemoteHostInfo = RemoteHostInfo
{ remoteHostId :: RemoteHostId,
storePath :: FilePath,
@ -41,8 +69,6 @@ data RemoteHostInfo = RemoteHostInfo
}
deriving (Show)
$(J.deriveJSON J.defaultOptions ''RemoteHostInfo)
type RemoteCtrlId = Int64
data RemoteCtrl = RemoteCtrl
@ -53,8 +79,6 @@ data RemoteCtrl = RemoteCtrl
}
deriving (Show)
$(J.deriveJSON J.defaultOptions {J.omitNothingFields = True} ''RemoteCtrl)
data RemoteCtrlInfo = RemoteCtrlInfo
{ remoteCtrlId :: RemoteCtrlId,
displayName :: Text,
@ -64,4 +88,38 @@ data RemoteCtrlInfo = RemoteCtrlInfo
}
deriving (Show)
-- TODO: put into a proper place
data PlatformEncoding
= PESwift
| PEKotlin
deriving (Show, Eq)
localEncoding :: PlatformEncoding
#if defined(darwin_HOST_OS) && defined(swiftJSON)
localEncoding = PESwift
#else
localEncoding = PEKotlin
#endif
type Tasks = TVar [Async ()]
asyncRegistered :: MonadUnliftIO m => Tasks -> m () -> m ()
asyncRegistered tasks action = async action >>= registerAsync tasks
registerAsync :: MonadIO m => Tasks -> Async () -> m ()
registerAsync tasks = atomically . modifyTVar tasks . (:)
cancelTasks :: (MonadIO m) => Tasks -> m ()
cancelTasks tasks = readTVarIO tasks >>= mapM_ cancel
$(J.deriveJSON (sumTypeJSON $ dropPrefix "RPE") ''RemoteProtocolError)
$(J.deriveJSON (enumJSON $ dropPrefix "PE") ''PlatformEncoding)
$(J.deriveJSON J.defaultOptions ''RemoteCtrlOOB)
$(J.deriveJSON J.defaultOptions ''RemoteHostInfo)
$(J.deriveJSON J.defaultOptions {J.omitNothingFields = True} ''RemoteCtrl)
$(J.deriveJSON J.defaultOptions {J.omitNothingFields = True} ''RemoteCtrlInfo)

View file

@ -49,7 +49,7 @@ extra-deps:
# - simplexmq-1.0.0@sha256:34b2004728ae396e3ae449cd090ba7410781e2b3cefc59259915f4ca5daa9ea8,8561
# - ../simplexmq
- github: simplex-chat/simplexmq
commit: 1ad69cf74f18f25713ce564e1629d2538313b9e0
commit: deb3fc73595ceae34902d3402d075e3a531d5221
- github: kazu-yamamoto/http2
commit: b5a1b7200cf5bc7044af34ba325284271f6dff25
# - ../direct-sqlcipher

View file

@ -9,7 +9,7 @@ import qualified Data.ByteString.Lazy.Char8 as LB
import GHC.Generics (Generic)
import Generic.Random (genericArbitraryU)
import MobileTests
import Simplex.Chat.Remote (owsf2tagged)
import Simplex.Chat.Remote.Protocol (owsf2tagged)
import Simplex.Messaging.Parsers
import Test.Hspec
import Test.Hspec.QuickCheck (modifyMaxSuccess)

View file

@ -1,4 +1,3 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
@ -8,17 +7,18 @@ module RemoteTests where
import ChatClient
import ChatTests.Utils
import Control.Logger.Simple
import Control.Monad
import qualified Data.ByteString as B
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.Map.Strict as M
import Debug.Trace
import Network.HTTP.Types (ok200)
import qualified Network.HTTP2.Client as C
import qualified Network.HTTP2.Server as S
import qualified Network.Socket as N
import qualified Network.TLS as TLS
import qualified Simplex.Chat.Controller as Controller
import Simplex.Chat.Remote.Types
import qualified Simplex.Chat.Remote.Discovery as Discovery
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding.String
@ -27,17 +27,21 @@ import Simplex.Messaging.Transport.Client (TransportHost (..))
import Simplex.Messaging.Transport.Credentials (genCredentials, tlsCredentials)
import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Response (..), closeHTTP2Client, sendRequest)
import Simplex.Messaging.Transport.HTTP2.Server (HTTP2Request (..))
import Simplex.Messaging.Util
import System.FilePath (makeRelative, (</>))
import Test.Hspec
import UnliftIO
import UnliftIO.Concurrent
import UnliftIO.Directory
remoteTests :: SpecWith FilePath
remoteTests = fdescribe "Handshake" $ do
remoteTests = describe "Remote" $ do
it "generates usable credentials" genCredentialsTest
it "connects announcer with discoverer over reverse-http2" announceDiscoverHttp2Test
it "connects desktop and mobile" remoteHandshakeTest
it "send messages via remote desktop" remoteCommandTest
it "performs protocol handshake" remoteHandshakeTest
it "performs protocol handshake (again)" remoteHandshakeTest -- leaking servers regression check
it "sends messages" remoteMessageTest
xit "sends files" remoteFileTest
-- * Low-level TLS with ephemeral credentials
@ -51,14 +55,14 @@ genCredentialsTest _tmp = do
Discovery.connectTLSClient "127.0.0.1" fingerprint clientHandler
where
serverHandler serverTls = do
traceM " - Sending from server"
logNote "Sending from server"
Transport.putLn serverTls "hi client"
traceM " - Reading from server"
logNote "Reading from server"
Transport.getLn serverTls `shouldReturn` "hi server"
clientHandler clientTls = do
traceM " - Sending from client"
logNote "Sending from client"
Transport.putLn clientTls "hi server"
traceM " - Reading from client"
logNote "Reading from client"
Transport.getLn clientTls `shouldReturn` "hi client"
-- * UDP discovery and rever HTTP2
@ -66,34 +70,37 @@ genCredentialsTest _tmp = do
announceDiscoverHttp2Test :: (HasCallStack) => FilePath -> IO ()
announceDiscoverHttp2Test _tmp = do
(fingerprint, credentials) <- genTestCredentials
tasks <- newTVarIO []
finished <- newEmptyMVar
controller <- async $ do
traceM " - Controller: starting"
logNote "Controller: starting"
bracket
(Discovery.announceRevHTTP2 fingerprint credentials (putMVar finished ()) >>= either (fail . show) pure)
(Discovery.announceRevHTTP2 tasks fingerprint credentials (putMVar finished ()) >>= either (fail . show) pure)
closeHTTP2Client
( \http -> do
traceM " - Controller: got client"
logNote "Controller: got client"
sendRequest http (C.requestNoBody "GET" "/" []) (Just 10000000) >>= \case
Left err -> do
traceM " - Controller: got error"
logNote "Controller: got error"
fail $ show err
Right HTTP2Response {} ->
traceM " - Controller: got response"
logNote "Controller: got response"
)
host <- async $ Discovery.withListener $ \sock -> do
(N.SockAddrInet _port addr, invite) <- Discovery.recvAnnounce sock
strDecode invite `shouldBe` Right fingerprint
traceM " - Host: connecting"
logNote "Host: connecting"
server <- async $ Discovery.connectTLSClient (THIPv4 $ N.hostAddressToTuple addr) fingerprint $ \tls -> do
traceM " - Host: got tls"
logNote "Host: got tls"
flip Discovery.attachHTTP2Server tls $ \HTTP2Request {sendResponse} -> do
traceM " - Host: got request"
logNote "Host: got request"
sendResponse $ S.responseNoBody ok200 []
traceM " - Host: sent response"
logNote "Host: sent response"
takeMVar finished `finally` cancel server
traceM " - Host: finished"
(waitBoth host controller `shouldReturn` ((), ())) `onException` (cancel host >> cancel controller)
logNote "Host: finished"
tasks `registerAsync` controller
tasks `registerAsync` host
(waitBoth host controller `shouldReturn` ((), ())) `finally` cancelTasks tasks
-- * Chat commands
@ -101,62 +108,59 @@ remoteHandshakeTest :: (HasCallStack) => FilePath -> IO ()
remoteHandshakeTest = testChat2 aliceProfile bobProfile $ \desktop mobile -> do
desktop ##> "/list remote hosts"
desktop <## "No remote hosts"
desktop ##> "/create remote host"
desktop <## "remote host 1 created"
desktop <## "connection code:"
fingerprint <- getTermLine desktop
startRemote mobile desktop
logNote "Session active"
desktop ##> "/list remote hosts"
desktop <## "Remote hosts:"
desktop <## "1. TODO" -- TODO host name probably should be Maybe, as when host is created there is no name yet
desktop ##> "/start remote host 1"
desktop <## "ok"
mobile ##> "/start remote ctrl"
mobile <## "ok"
mobile <## "remote controller announced"
mobile <## "connection code:"
fingerprint' <- getTermLine mobile
fingerprint' `shouldBe` fingerprint
mobile ##> "/list remote ctrls"
mobile <## "No remote controllers"
mobile ##> ("/register remote ctrl " <> fingerprint' <> " " <> "My desktop")
mobile <## "remote controller 1 registered"
mobile ##> "/list remote ctrls"
mobile <## "Remote controllers:"
mobile <## "1. My desktop"
mobile ##> "/accept remote ctrl 1"
mobile <## "ok" -- alternative scenario: accepted before controller start
mobile <## "remote controller 1 connecting to My desktop"
mobile <## "remote controller 1 connected, My desktop"
traceM " - Session active"
desktop ##> "/list remote hosts"
desktop <## "Remote hosts:"
desktop <## "1. TODO (active)"
desktop <## "1. (active)"
mobile ##> "/list remote ctrls"
mobile <## "Remote controllers:"
mobile <## "1. My desktop (active)"
traceM " - Shutting desktop"
desktop ##> "/stop remote host 1"
desktop <## "ok"
stopMobile mobile desktop `catchAny` (logError . tshow)
-- TODO: add a case for 'stopDesktop'
desktop ##> "/delete remote host 1"
desktop <## "ok"
desktop ##> "/list remote hosts"
desktop <## "No remote hosts"
traceM " - Shutting mobile"
mobile ##> "/stop remote ctrl"
mobile <## "ok"
mobile <## "remote controller stopped"
mobile ##> "/delete remote ctrl 1"
mobile <## "ok"
mobile ##> "/list remote ctrls"
mobile <## "No remote controllers"
remoteCommandTest :: (HasCallStack) => FilePath -> IO ()
remoteCommandTest = testChat3 aliceProfile aliceDesktopProfile bobProfile $ \mobile desktop bob -> do
remoteMessageTest :: (HasCallStack) => FilePath -> IO ()
remoteMessageTest = testChat3 aliceProfile aliceDesktopProfile bobProfile $ \mobile desktop bob -> do
startRemote mobile desktop
contactBob desktop bob
logNote "sending messages"
desktop #> "@bob hello there 🙂"
bob <# "alice> hello there 🙂"
bob #> "@alice hi"
desktop <# "bob> hi"
logNote "post-remote checks"
stopMobile mobile desktop
mobile ##> "/contacts"
mobile <## "bob (Bob)"
bob ##> "/contacts"
bob <## "alice (Alice)"
desktop ##> "/contacts"
-- empty contact list on desktop-local
threadDelay 1000000
logNote "done"
remoteFileTest :: (HasCallStack) => FilePath -> IO ()
remoteFileTest = testChat3 aliceProfile aliceDesktopProfile bobProfile $ \mobile desktop bob -> do
let mobileFiles = "./tests/tmp/mobile_files"
mobile ##> ("/_files_folder " <> mobileFiles)
mobile <## "ok"
@ -167,6 +171,89 @@ remoteCommandTest = testChat3 aliceProfile aliceDesktopProfile bobProfile $ \mob
bob ##> ("/_files_folder " <> bobFiles)
bob <## "ok"
startRemote mobile desktop
contactBob desktop bob
rhs <- readTVarIO (Controller.remoteHostSessions $ chatController desktop)
desktopStore <- case M.lookup 1 rhs of
Just RemoteHostSession {storePath} -> pure storePath
_ -> fail "Host session 1 should be started"
doesFileExist "./tests/tmp/mobile_files/test.pdf" `shouldReturn` False
doesFileExist (desktopFiles </> desktopStore </> "test.pdf") `shouldReturn` False
mobileName <- userName mobile
bobsFile <- makeRelative bobFiles <$> makeAbsolute "tests/fixtures/test.pdf"
bob #> ("/f @" <> mobileName <> " " <> bobsFile)
bob <## "use /fc 1 to cancel sending"
desktop <# "bob> sends file test.pdf (266.0 KiB / 272376 bytes)"
desktop <## "use /fr 1 [<dir>/ | <path>] to receive it"
desktop ##> "/fr 1"
concurrentlyN_
[ do
bob <## "started sending file 1 (test.pdf) to alice"
bob <## "completed sending file 1 (test.pdf) to alice",
do
desktop <## "saving file 1 from bob to test.pdf"
desktop <## "started receiving file 1 (test.pdf) from bob"
]
let desktopReceived = desktopFiles </> desktopStore </> "test.pdf"
-- desktop <## ("completed receiving file 1 (" <> desktopReceived <> ") from bob")
desktop <## "completed receiving file 1 (test.pdf) from bob"
bobsFileSize <- getFileSize bobsFile
-- getFileSize desktopReceived `shouldReturn` bobsFileSize
bobsFileBytes <- B.readFile bobsFile
-- B.readFile desktopReceived `shouldReturn` bobsFileBytes
-- test file transit on mobile
mobile ##> "/fs 1"
mobile <## "receiving file 1 (test.pdf) complete, path: test.pdf"
getFileSize (mobileFiles </> "test.pdf") `shouldReturn` bobsFileSize
B.readFile (mobileFiles </> "test.pdf") `shouldReturn` bobsFileBytes
logNote "file received"
desktopFile <- makeRelative desktopFiles <$> makeAbsolute "tests/fixtures/logo.jpg" -- XXX: not necessary for _send, but required for /f
logNote $ "sending " <> tshow desktopFile
doesFileExist (bobFiles </> "logo.jpg") `shouldReturn` False
doesFileExist (mobileFiles </> "logo.jpg") `shouldReturn` False
desktop ##> "/_send @2 json {\"filePath\": \"./tests/fixtures/logo.jpg\", \"msgContent\": {\"type\": \"text\", \"text\": \"hi, sending a file\"}}"
desktop <# "@bob hi, sending a file"
desktop <# "/f @bob logo.jpg"
desktop <## "use /fc 2 to cancel sending"
bob <# "alice> hi, sending a file"
bob <# "alice> sends file logo.jpg (31.3 KiB / 32080 bytes)"
bob <## "use /fr 2 [<dir>/ | <path>] to receive it"
bob ##> "/fr 2"
concurrentlyN_
[ do
bob <## "saving file 2 from alice to logo.jpg"
bob <## "started receiving file 2 (logo.jpg) from alice"
bob <## "completed receiving file 2 (logo.jpg) from alice"
bob ##> "/fs 2"
bob <## "receiving file 2 (logo.jpg) complete, path: logo.jpg",
do
desktop <## "started sending file 2 (logo.jpg) to bob"
desktop <## "completed sending file 2 (logo.jpg) to bob"
]
desktopFileSize <- getFileSize desktopFile
getFileSize (bobFiles </> "logo.jpg") `shouldReturn` desktopFileSize
getFileSize (mobileFiles </> "logo.jpg") `shouldReturn` desktopFileSize
desktopFileBytes <- B.readFile desktopFile
B.readFile (bobFiles </> "logo.jpg") `shouldReturn` desktopFileBytes
B.readFile (mobileFiles </> "logo.jpg") `shouldReturn` desktopFileBytes
logNote "file sent"
stopMobile mobile desktop
-- * Utils
startRemote :: TestCC -> TestCC -> IO ()
startRemote mobile desktop = do
desktop ##> "/create remote host"
desktop <## "remote host 1 created"
desktop <## "connection code:"
@ -189,7 +276,9 @@ remoteCommandTest = testChat3 aliceProfile aliceDesktopProfile bobProfile $ \mob
mobile <## "remote controller 1 connected, My desktop"
desktop <## "remote host 1 connected"
traceM " - exchanging contacts"
contactBob :: TestCC -> TestCC -> IO ()
contactBob desktop bob = do
logNote "exchanging contacts"
bob ##> "/c"
inv' <- getInvitation bob
desktop ##> ("/c " <> inv')
@ -198,102 +287,33 @@ remoteCommandTest = testChat3 aliceProfile aliceDesktopProfile bobProfile $ \mob
(desktop <## "bob (Bob): contact is connected")
(bob <## "alice (Alice): contact is connected")
traceM " - sending messages"
desktop #> "@bob hello there 🙂"
bob <# "alice> hello there 🙂"
bob #> "@alice hi"
desktop <# "bob> hi"
withXFTPServer $ do
rhs <- readTVarIO (Controller.remoteHostSessions $ chatController desktop)
desktopStore <- case M.lookup 1 rhs of
Just Controller.RemoteHostSessionStarted {storePath} -> pure storePath
_ -> fail "Host session 1 should be started"
doesFileExist "./tests/tmp/mobile_files/test.pdf" `shouldReturn` False
doesFileExist (desktopFiles </> desktopStore </> "test.pdf") `shouldReturn` False
mobileName <- userName mobile
bobsFile <- makeRelative bobFiles <$> makeAbsolute "tests/fixtures/test.pdf"
bob #> ("/f @" <> mobileName <> " " <> bobsFile)
bob <## "use /fc 1 to cancel sending"
desktop <# "bob> sends file test.pdf (266.0 KiB / 272376 bytes)"
desktop <## "use /fr 1 [<dir>/ | <path>] to receive it"
desktop ##> "/fr 1"
concurrently_
do
bob <## "started sending file 1 (test.pdf) to alice"
bob <## "completed sending file 1 (test.pdf) to alice"
do
desktop <## "saving file 1 from bob to test.pdf"
desktop <## "started receiving file 1 (test.pdf) from bob"
let desktopReceived = desktopFiles </> desktopStore </> "test.pdf"
desktop <## ("completed receiving file 1 (" <> desktopReceived <> ") from bob")
bobsFileSize <- getFileSize bobsFile
getFileSize desktopReceived `shouldReturn` bobsFileSize
bobsFileBytes <- B.readFile bobsFile
B.readFile desktopReceived `shouldReturn` bobsFileBytes
-- test file transit on mobile
mobile ##> "/fs 1"
mobile <## "receiving file 1 (test.pdf) complete, path: test.pdf"
getFileSize (mobileFiles </> "test.pdf") `shouldReturn` bobsFileSize
B.readFile (mobileFiles </> "test.pdf") `shouldReturn` bobsFileBytes
traceM " - file received"
desktopFile <- makeRelative desktopFiles <$> makeAbsolute "tests/fixtures/logo.jpg" -- XXX: not necessary for _send, but required for /f
traceM $ " - sending " <> show desktopFile
doesFileExist (bobFiles </> "logo.jpg") `shouldReturn` False
doesFileExist (mobileFiles </> "logo.jpg") `shouldReturn` False
desktop ##> "/_send @2 json {\"filePath\": \"./tests/fixtures/logo.jpg\", \"msgContent\": {\"type\": \"text\", \"text\": \"hi, sending a file\"}}"
desktop <# "@bob hi, sending a file"
desktop <# "/f @bob logo.jpg"
desktop <## "use /fc 2 to cancel sending"
bob <# "alice> hi, sending a file"
bob <# "alice> sends file logo.jpg (31.3 KiB / 32080 bytes)"
bob <## "use /fr 2 [<dir>/ | <path>] to receive it"
bob ##> "/fr 2"
concurrently_
do
bob <## "saving file 2 from alice to logo.jpg"
bob <## "started receiving file 2 (logo.jpg) from alice"
bob <## "completed receiving file 2 (logo.jpg) from alice"
bob ##> "/fs 2"
bob <## "receiving file 2 (logo.jpg) complete, path: logo.jpg"
do
desktop <## "started sending file 2 (logo.jpg) to bob"
desktop <## "completed sending file 2 (logo.jpg) to bob"
desktopFileSize <- getFileSize desktopFile
getFileSize (bobFiles </> "logo.jpg") `shouldReturn` desktopFileSize
getFileSize (mobileFiles </> "logo.jpg") `shouldReturn` desktopFileSize
desktopFileBytes <- B.readFile desktopFile
B.readFile (bobFiles </> "logo.jpg") `shouldReturn` desktopFileBytes
B.readFile (mobileFiles </> "logo.jpg") `shouldReturn` desktopFileBytes
traceM " - file sent"
traceM " - post-remote checks"
mobile ##> "/stop remote ctrl"
mobile <## "ok"
concurrently_
(mobile <## "remote controller stopped")
(desktop <## "remote host 1 stopped")
mobile ##> "/contacts"
mobile <## "bob (Bob)"
traceM " - done"
-- * Utils
genTestCredentials :: IO (C.KeyHash, TLS.Credentials)
genTestCredentials = do
caCreds <- liftIO $ genCredentials Nothing (0, 24) "CA"
sessionCreds <- liftIO $ genCredentials (Just caCreds) (0, 24) "Session"
pure . tlsCredentials $ sessionCreds :| [caCreds]
stopDesktop :: HasCallStack => TestCC -> TestCC -> IO ()
stopDesktop mobile desktop = do
logWarn "stopping via desktop"
desktop ##> "/stop remote host 1"
-- desktop <## "ok"
concurrently_
(desktop <## "remote host 1 stopped")
(eventually 3 $ mobile <## "remote controller stopped")
stopMobile :: HasCallStack => TestCC -> TestCC -> IO ()
stopMobile mobile desktop = do
logWarn "stopping via mobile"
mobile ##> "/stop remote ctrl"
mobile <## "ok"
concurrently_
(mobile <## "remote controller stopped")
(eventually 3 $ desktop <## "remote host 1 stopped")
-- | Run action with extended timeout
eventually :: Int -> IO a -> IO a
eventually retries action = tryAny action >>= \case -- TODO: only catch timeouts
Left err | retries == 0 -> throwIO err
Left _ -> eventually (retries - 1) action
Right r -> pure r

View file

@ -19,7 +19,7 @@ import WebRTCTests
main :: IO ()
main = do
setLogLevel LogError -- LogDebug
setLogLevel LogError
withGlobalLogging logCfg . hspec $ do
describe "Schema dump" schemaDumpTest
describe "SimpleX chat markdown" markdownTests

View file

@ -1,4 +1,3 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE OverloadedStrings #-}
module ViewTests where