From 193361c09a236bc4a36ed275010f140d930d2bf5 Mon Sep 17 00:00:00 2001 From: Alexander Bondarenko <486682+dpwiz@users.noreply.github.com> Date: Fri, 13 Oct 2023 20:53:04 +0300 Subject: [PATCH] core: fix remote handshake test (#3209) * 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> --- src/Simplex/Chat/Remote.hs | 22 ++++++++++++++++------ tests/RemoteTests.hs | 27 +++++++++++++++++++-------- 2 files changed, 35 insertions(+), 14 deletions(-) diff --git a/src/Simplex/Chat/Remote.hs b/src/Simplex/Chat/Remote.hs index 49357763d2..26d4f4bfd2 100644 --- a/src/Simplex/Chat/Remote.hs +++ b/src/Simplex/Chat/Remote.hs @@ -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) diff --git a/tests/RemoteTests.hs b/tests/RemoteTests.hs index d2392adbbd..479febbcaf 100644 --- a/tests/RemoteTests.hs +++ b/tests/RemoteTests.hs @@ -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"