dandri/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-03-30 16:25:57 +00:00
Code Issues Packages Projects Releases Wiki Activity

core: fix remote handshake test (#3209)

Browse Source 
* Fix remoteHandshakeTest

Sidesteps some yet to be uncovered bug when
mobile stops its side before the desktop.

* remove ambiguous update warning

---------

Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
This commit is contained in:
Alexander Bondarenko
2023-10-13 20:53:04 +03:00
committed by GitHub
parent 392447ea33
commit 193361c09a
2 changed files with 35 additions and 14 deletions
Download Patch File Download Diff File Expand all files Collapse all files

22
src/Simplex/Chat/Remote.hs
View File

@@ -1,6 +1,7 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
@@ -53,7 +54,7 @@ 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 TaggedObjectJSONTag, pattern TaggedObjectJSONData)
import Simplex.Messaging.Parsers (pattern SingleFieldJSONTag, pattern TaggedObjectJSONData, pattern TaggedObjectJSONTag)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport.Client (TransportHost (..))
import Simplex.Messaging.Transport.Credentials (genCredentials, tlsCredentials)
@@ -64,7 +65,7 @@ import qualified Simplex.Messaging.Transport.HTTP2.Server as HTTP2
import Simplex.Messaging.Util (bshow, ifM, tshow)
import System.FilePath (isPathSeparator, takeFileName, (</>))
import UnliftIO
import UnliftIO.Directory (createDirectoryIfMissing, getFileSize, makeAbsolute)
import UnliftIO.Directory (createDirectoryIfMissing, getFileSize)
withRemoteHostSession :: (ChatMonad m) => RemoteHostId -> (RemoteHostSession -> m a) -> m a
withRemoteHostSession remoteHostId action = do
@@ -90,7 +91,9 @@ startRemoteHost remoteHostId = do
cleanup finished = do
logInfo "Remote host http2 client fininshed"
atomically $ writeTVar finished True
closeRemoteHostSession remoteHostId >>= toView
M.lookup remoteHostId <$> chatReadVar remoteHostSessions >>= \case
Nothing -> logInfo $ "Session already closed for remote host " <> tshow remoteHostId
Just _ -> closeRemoteHostSession remoteHostId >>= toView
run RemoteHost {storePath, caKey, caCert} = do
finished <- newTVarIO False
let parent = (C.signatureKeyPair caKey, caCert)
@@ -141,6 +144,7 @@ pollRemote finished http path action = loop
closeRemoteHostSession :: (ChatMonad m) => RemoteHostId -> m ChatResponse
closeRemoteHostSession remoteHostId = withRemoteHostSession remoteHostId $ \session -> do
logInfo $ "Closing remote host session for " <> tshow remoteHostId
liftIO $ cancelRemoteHostSession session
chatWriteVar currentRemoteHost Nothing
chatModifyVar remoteHostSessions $ M.delete remoteHostId
@@ -174,8 +178,12 @@ listRemoteHosts = do
pure RemoteHostInfo {remoteHostId, storePath, displayName, sessionActive}
deleteRemoteHost :: (ChatMonad m) => RemoteHostId -> m ChatResponse
deleteRemoteHost remoteHostId = withRemoteHost remoteHostId $ \rh -> do
-- TODO: delete files
deleteRemoteHost remoteHostId = withRemoteHost remoteHostId $ \RemoteHost {storePath} -> do
chatReadVar filesFolder >>= \case
Just baseDir -> do
let hostStore = baseDir </> storePath
logError $ "TODO: remove " <> tshow hostStore
Nothing -> logWarn "Local file store not available while deleting remote host"
withStore' $ \db -> deleteRemoteHostRecord db remoteHostId
pure CRRemoteHostDeleted {remoteHostId}
@@ -234,7 +242,9 @@ handleRcvFileComplete http storePath remoteUser cif@CIFile {fileId, fileName, fi
createDirectoryIfMissing True hostStore
localPath <- uniqueCombine hostStore fileName
ok <- fetchRemoteFile http remoteUser fileId localPath
pure $ Just (cif {fileName = localPath} :: CIFile 'MDRcv)
if ok
then pure $ Just (cif {fileName = localPath} :: CIFile 'MDRcv)
else Nothing <$ logError "fetchRemoteFile failed"
Nothing -> Nothing <$ logError "Local file store not available while fetching remote file"
_ -> Nothing <$ logDebug ("Ingoring invalid file notification for file (" <> tshow fileId <> ") " <> tshow fileName)

27
tests/RemoteTests.hs
View File

@@ -36,7 +36,7 @@ remoteTests :: SpecWith FilePath
remoteTests = describe "Handshake" $ do
it "generates usable credentials" genCredentialsTest
it "connects announcer with discoverer over reverse-http2" announceDiscoverHttp2Test
xit "connects desktop and mobile" remoteHandshakeTest
it "connects desktop and mobile" remoteHandshakeTest
it "send messages via remote desktop" remoteCommandTest
-- * Low-level TLS with ephemeral credentials
@@ -129,6 +129,24 @@ remoteHandshakeTest = testChat2 aliceProfile bobProfile $ \desktop mobile -> do
mobile <## "remote controller 1 accepted" -- alternative scenario: accepted before controller start
mobile <## "remote controller 1 connecting to TODO"
mobile <## "remote controller 1 connected, TODO"
traceM " - Session active"
desktop ##> "/list remote hosts"
desktop <## "Remote hosts:"
desktop <## "1. TODO (active)"
mobile ##> "/list remote ctrls"
mobile <## "Remote controllers:"
mobile <## "1. TODO (active)"
traceM " - Shutting desktop"
desktop ##> "/stop remote host 1"
desktop <## "remote host 1 stopped"
desktop ##> "/delete remote host 1"
desktop <## "remote host 1 deleted"
desktop ##> "/list remote hosts"
desktop <## "No remote hosts"
traceM " - Shutting mobile"
mobile ##> "/stop remote ctrl"
mobile <## "ok"
mobile <## "remote controller stopped"
@@ -137,13 +155,6 @@ remoteHandshakeTest = testChat2 aliceProfile bobProfile $ \desktop mobile -> do
mobile ##> "/list remote ctrls"
mobile <## "No remote controllers"
desktop ##> "/stop remote host 1"
desktop <## "remote host 1 stopped"
desktop ##> "/delete remote host 1"
desktop <## "remote host 1 deleted"
desktop ##> "/list remote hosts"
desktop <## "No remote hosts"
remoteCommandTest :: (HasCallStack) => FilePath -> IO ()
remoteCommandTest = testChat3 aliceProfile aliceDesktopProfile bobProfile $ \mobile desktop bob -> do
let mobileFiles = "./tests/tmp/mobile_files"