Merge branch 'master' into master-ghc8107

tests/ChatClient.hs

@@ -89,7 +89,7 @@ termSettings :: VirtualTerminalSettings
 termSettings =
   VirtualTerminalSettings
     { virtualType = "xterm",
-      virtualWindowSize = pure C.Size {height = 24, width = 1000},
+      virtualWindowSize = pure C.Size {height = 24, width = 2250},
       virtualEvent = retry,
       virtualInterrupt = retry
     }

tests/ChatTests/Utils.hs

@@ -36,6 +36,9 @@ import Test.Hspec
 defaultPrefs :: Maybe Preferences
 defaultPrefs = Just $ toChatPrefs defaultChatPrefs
 
+aliceDesktopProfile :: Profile
+aliceDesktopProfile = Profile {displayName = "alice_desktop", fullName = "Alice Desktop", image = Nothing, contactLink = Nothing, preferences = defaultPrefs}
+
 aliceProfile :: Profile
 aliceProfile = Profile {displayName = "alice", fullName = "Alice", image = Nothing, contactLink = Nothing, preferences = defaultPrefs}
 
@@ -324,6 +327,9 @@ cc ?<# line = (dropTime <$> getTermLine cc) `shouldReturn` "i " <> line
 ($<#) :: HasCallStack => (TestCC, String) -> String -> Expectation
 (cc, uName) $<# line = (dropTime . dropUser uName <$> getTermLine cc) `shouldReturn` line
 
+(^<#) :: HasCallStack => (TestCC, String) -> String -> Expectation
+(cc, p) ^<# line = (dropTime . dropStrPrefix p <$> getTermLine cc) `shouldReturn` line
+
 (⩗) :: HasCallStack => TestCC -> String -> Expectation
 cc ⩗ line = (dropTime . dropReceipt <$> getTermLine cc) `shouldReturn` line
 

tests/JSONTests.hs

@@ -0,0 +1,86 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module JSONTests where
+
+import Control.Monad (join)
+import Data.Aeson (FromJSON, ToJSON)
+import qualified Data.Aeson as J
+import qualified Data.Aeson.TH as JQ
+import qualified Data.Aeson.Types as JT
+import Data.ByteString.Builder (toLazyByteString)
+import qualified Data.ByteString.Lazy.Char8 as LB
+import GHC.Generics (Generic)
+import Generic.Random (genericArbitraryU)
+import MobileTests
+import Simplex.Chat.Remote.Protocol (owsf2tagged)
+import Simplex.Messaging.Parsers
+import Test.Hspec
+import Test.Hspec.QuickCheck (modifyMaxSuccess)
+import Test.QuickCheck (Arbitrary (..), property)
+
+owsf2TaggedJSONTest :: IO ()
+owsf2TaggedJSONTest = do
+  noActiveUserSwift `to` noActiveUserTagged
+  activeUserExistsSwift `to` activeUserExistsTagged
+  activeUserSwift `to` activeUserTagged
+  chatStartedSwift `to` chatStartedTagged
+  networkStatusesSwift `to` networkStatusesTagged
+  memberSubSummarySwift `to` memberSubSummaryTagged
+  userContactSubSummarySwift `to` userContactSubSummaryTagged
+  pendingSubSummarySwift `to` pendingSubSummaryTagged
+  parsedMarkdownSwift `to` parsedMarkdownTagged
+  where
+    to :: LB.ByteString -> LB.ByteString -> IO ()
+    owsf `to` tagged =
+      case J.eitherDecode owsf of
+        Right json -> Right (owsf2tagged json) `shouldBe` J.eitherDecode tagged
+        Left e -> expectationFailure e
+
+data SomeType
+  = Nullary
+  | Unary (Maybe SomeType)
+  | Product String (Maybe SomeType)
+  | Record
+      { testOne :: Int,
+        testTwo :: Maybe Bool,
+        testThree :: Maybe SomeType
+      }
+  | List [Int]
+  deriving (Eq, Show, Generic)
+
+$(pure [])
+
+thToJSON :: SomeType -> J.Value
+thToJSON = $(JQ.mkToJSON (singleFieldJSON_ (Just SingleFieldJSONTag) id) ''SomeType)
+
+thToEncoding :: SomeType -> J.Encoding
+thToEncoding = $(JQ.mkToEncoding (singleFieldJSON_ (Just SingleFieldJSONTag) id) ''SomeType)
+
+thParseJSON :: J.Value -> JT.Parser SomeType
+thParseJSON = $(JQ.mkParseJSON (taggedObjectJSON id) ''SomeType)
+
+instance Arbitrary SomeType where arbitrary = genericArbitraryU
+
+instance ToJSON SomeType where
+  toJSON = J.genericToJSON $ singleFieldJSON_ (Just SingleFieldJSONTag) id
+  toEncoding = J.genericToEncoding $ singleFieldJSON_ (Just SingleFieldJSONTag) id
+
+instance FromJSON SomeType where
+  parseJSON = J.genericParseJSON $ taggedObjectJSON id
+
+owsf2TaggedSomeTypeTests :: Spec
+owsf2TaggedSomeTypeTests = modifyMaxSuccess (const 10000) $ do
+  it "should convert to tagged" $ property $ \x ->
+    (JT.parseMaybe J.parseJSON . owsf2tagged . J.toJSON) x == Just (x :: SomeType)
+  it "should convert to tagged via encoding" $ property $ \x ->
+    (join . fmap (JT.parseMaybe J.parseJSON . owsf2tagged) . J.decode . J.encode) x == Just (x :: SomeType)
+  it "should convert to tagged via TH" $ property $ \x ->
+    (JT.parseMaybe thParseJSON . owsf2tagged . thToJSON) x == Just (x :: SomeType)
+  it "should convert to tagged via TH encoding" $ property $ \x ->
+    (join . fmap (JT.parseMaybe thParseJSON . owsf2tagged) . J.decode . toLazyByteString . J.fromEncoding . thToEncoding) x == Just (x :: SomeType)
+
+jsonTests :: Spec
+jsonTests = describe "owsf2tagged" $ do
+  it "should convert chat types" owsf2TaggedJSONTest
+  describe "SomeType" owsf2TaggedSomeTypeTests

tests/MobileTests.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
@@ -9,8 +10,9 @@ module MobileTests where
 import ChatTests.Utils
 import Control.Monad.Except
 import Crypto.Random (getRandomBytes)
-import Data.Aeson (FromJSON (..))
+import Data.Aeson (FromJSON)
 import qualified Data.Aeson as J
+import qualified Data.Aeson.TH as JQ
 import Data.ByteString (ByteString)
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Char8 as BS
@@ -256,9 +258,11 @@ testMediaCApi _ = do
       (f cKeyStr ptr cLen >>= peekCAString) `shouldReturn` ""
       getByteString ptr cLen
 
-instance FromJSON WriteFileResult where parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "WF"
+instance FromJSON WriteFileResult where
+  parseJSON = $(JQ.mkParseJSON (sumTypeJSON $ dropPrefix "WF") ''WriteFileResult)
 
-instance FromJSON ReadFileResult where parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "RF"
+instance FromJSON ReadFileResult where
+  parseJSON = $(JQ.mkParseJSON (sumTypeJSON $ dropPrefix "RF") ''ReadFileResult)
 
 testFileCApi :: FilePath -> FilePath -> IO ()
 testFileCApi fileName tmp = do

tests/RemoteTests.hs

@@ -0,0 +1,519 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module RemoteTests where
+
+import ChatClient
+import ChatTests.Utils
+import Control.Logger.Simple
+import qualified Data.Aeson as J
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy.Char8 as LB
+import Data.List.NonEmpty (NonEmpty (..))
+import qualified Data.Map.Strict as M
+import qualified Network.TLS as TLS
+import Simplex.Chat.Archive (archiveFilesFolder)
+import Simplex.Chat.Controller (ChatConfig (..), XFTPFileConfig (..))
+import qualified Simplex.Chat.Controller as Controller
+import Simplex.Chat.Mobile.File
+import Simplex.Chat.Remote.Types
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Crypto.File (CryptoFileArgs (..))
+import Simplex.Messaging.Encoding.String (strEncode)
+import Simplex.Messaging.Transport.Credentials (genCredentials, tlsCredentials)
+import Simplex.Messaging.Util
+import System.FilePath ((</>))
+import Test.Hspec
+import UnliftIO
+import UnliftIO.Concurrent
+import UnliftIO.Directory
+
+remoteTests :: SpecWith FilePath
+remoteTests = describe "Remote" $ do
+  describe "protocol handshake" $ do
+    it "connects with new pairing (stops mobile)" $ remoteHandshakeTest False
+    it "connects with new pairing (stops desktop)" $ remoteHandshakeTest True
+    it "connects with stored pairing" remoteHandshakeStoredTest
+    it "connects with multicast discovery" remoteHandshakeDiscoverTest
+    it "refuses invalid client cert" remoteHandshakeRejectTest
+  it "sends messages" remoteMessageTest
+  describe "remote files" $ do
+    it "store/get/send/receive files" remoteStoreFileTest
+    it "should send files from CLI without /store" remoteCLIFileTest
+  it "switches remote hosts" switchRemoteHostTest
+  it "indicates remote hosts" indicateRemoteHostTest
+
+-- * Chat commands
+
+remoteHandshakeTest :: HasCallStack => Bool -> FilePath -> IO ()
+remoteHandshakeTest viaDesktop = testChat2 aliceProfile aliceDesktopProfile $ \mobile desktop -> do
+  desktop ##> "/list remote hosts"
+  desktop <## "No remote hosts"
+  mobile ##> "/list remote ctrls"
+  mobile <## "No remote controllers"
+
+  startRemote mobile desktop
+
+  desktop ##> "/list remote hosts"
+  desktop <## "Remote hosts:"
+  desktop <## "1. Mobile (connected)"
+
+  mobile ##> "/list remote ctrls"
+  mobile <## "Remote controllers:"
+  mobile <## "1. My desktop (connected)"
+
+  if viaDesktop then stopDesktop mobile desktop else stopMobile mobile desktop
+
+  desktop ##> "/delete remote host 1"
+  desktop <## "ok"
+  desktop ##> "/list remote hosts"
+  desktop <## "No remote hosts"
+
+  mobile ##> "/delete remote ctrl 1"
+  mobile <## "ok"
+  mobile ##> "/list remote ctrls"
+  mobile <## "No remote controllers"
+
+remoteHandshakeStoredTest :: HasCallStack => FilePath -> IO ()
+remoteHandshakeStoredTest = testChat2 aliceProfile aliceDesktopProfile $ \mobile desktop -> do
+  logNote "Starting new session"
+  startRemote mobile desktop
+  stopMobile mobile desktop `catchAny` (logError . tshow)
+
+  logNote "Starting stored session"
+  startRemoteStored mobile desktop
+  stopDesktop mobile desktop `catchAny` (logError . tshow)
+
+  desktop ##> "/list remote hosts"
+  desktop <## "Remote hosts:"
+  desktop <## "1. Mobile"
+  mobile ##> "/list remote ctrls"
+  mobile <## "Remote controllers:"
+  mobile <## "1. My desktop"
+
+  logNote "Starting stored session again"
+  startRemoteStored mobile desktop
+  stopMobile mobile desktop `catchAny` (logError . tshow)
+
+remoteHandshakeDiscoverTest :: HasCallStack => FilePath -> IO ()
+remoteHandshakeDiscoverTest = testChat2 aliceProfile aliceDesktopProfile $ \mobile desktop -> do
+  logNote "Preparing new session"
+  startRemote mobile desktop
+  stopMobile mobile desktop `catchAny` (logError . tshow)
+
+  logNote "Starting stored session with multicast"
+  startRemoteDiscover mobile desktop
+  stopMobile mobile desktop `catchAny` (logError . tshow)
+
+remoteHandshakeRejectTest :: HasCallStack => FilePath -> IO ()
+remoteHandshakeRejectTest = testChat3 aliceProfile aliceDesktopProfile bobProfile $ \mobile desktop mobileBob -> do
+  logNote "Starting new session"
+  startRemote mobile desktop
+  stopMobile mobile desktop
+
+  mobileBob ##> "/set device name MobileBob"
+  mobileBob <## "ok"
+  desktop ##> "/start remote host 1"
+  desktop <## "remote host 1 started"
+  desktop <## "Remote session invitation:"
+  inv <- getTermLine desktop
+  mobileBob ##> ("/connect remote ctrl " <> inv)
+  mobileBob <## "connecting new remote controller: My desktop, v5.4.0.3"
+  mobileBob <## "remote controller stopped"
+
+  -- the server remains active after rejecting invalid client
+  mobile ##> ("/connect remote ctrl " <> inv)
+  mobile <## "connecting remote controller 1: My desktop, v5.4.0.3"
+  desktop <## "remote host 1 connecting"
+  desktop <## "Compare session code with host:"
+  sessId <- getTermLine desktop
+  mobile <## "remote controller 1 connected"
+  mobile <## "Compare session code with controller and use:"
+  mobile <## ("/verify remote ctrl " <> sessId)
+  mobile ##> ("/verify remote ctrl " <> sessId)
+  mobile <## "remote controller 1 session started with My desktop"
+  desktop <## "remote host 1 connected"
+  stopMobile mobile desktop
+
+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"
+
+remoteStoreFileTest :: HasCallStack => FilePath -> IO ()
+remoteStoreFileTest =
+  testChatCfg3 cfg aliceProfile aliceDesktopProfile bobProfile $ \mobile desktop bob ->
+    withXFTPServer $ do
+      let mobileFiles = "./tests/tmp/mobile_files"
+      mobile ##> ("/_files_folder " <> mobileFiles)
+      mobile <## "ok"
+      let desktopFiles = "./tests/tmp/desktop_files"
+      desktop ##> ("/_files_folder " <> desktopFiles)
+      desktop <## "ok"
+      let desktopHostFiles = "./tests/tmp/remote_hosts_data"
+      desktop ##> ("/remote_hosts_folder " <> desktopHostFiles)
+      desktop <## "ok"
+      let bobFiles = "./tests/tmp/bob_files"
+      bob ##> ("/_files_folder " <> bobFiles)
+      bob <## "ok"
+
+      startRemote mobile desktop
+      contactBob desktop bob
+
+      rhs <- readTVarIO (Controller.remoteHostSessions $ chatController desktop)
+      desktopHostStore <- case M.lookup (RHId 1) rhs of
+        Just (_, RHSessionConnected {storePath}) -> pure $ desktopHostFiles </> storePath </> archiveFilesFolder
+        _ -> fail "Host session 1 should be started"
+      desktop ##> "/store remote file 1 tests/fixtures/test.pdf"
+      desktop <## "file test.pdf stored on remote host 1"
+      src <- B.readFile "tests/fixtures/test.pdf"
+      B.readFile (mobileFiles </> "test.pdf") `shouldReturn` src
+      B.readFile (desktopHostStore </> "test.pdf") `shouldReturn` src
+      desktop ##> "/store remote file 1 tests/fixtures/test.pdf"
+      desktop <## "file test_1.pdf stored on remote host 1"
+      B.readFile (mobileFiles </> "test_1.pdf") `shouldReturn` src
+      B.readFile (desktopHostStore </> "test_1.pdf") `shouldReturn` src
+      desktop ##> "/store remote file 1 encrypt=on tests/fixtures/test.pdf"
+      desktop <## "file test_2.pdf stored on remote host 1"
+      Just cfArgs@(CFArgs key nonce) <- J.decode . LB.pack <$> getTermLine desktop
+      chatReadFile (mobileFiles </> "test_2.pdf") (strEncode key) (strEncode nonce) `shouldReturn` Right (LB.fromStrict src)
+      chatReadFile (desktopHostStore </> "test_2.pdf") (strEncode key) (strEncode nonce) `shouldReturn` Right (LB.fromStrict src)
+
+      removeFile (desktopHostStore </> "test_1.pdf")
+      removeFile (desktopHostStore </> "test_2.pdf")
+
+      -- cannot get file before it is used
+      desktop ##> "/get remote file 1 {\"userId\": 1, \"fileId\": 1, \"sent\": true, \"fileSource\": {\"filePath\": \"test_1.pdf\"}}"
+      hostError desktop "SEFileNotFound"
+      -- send file not encrypted locally on mobile host
+      desktop ##> "/_send @2 json {\"filePath\": \"test_1.pdf\", \"msgContent\": {\"type\": \"file\", \"text\": \"sending a file\"}}"
+      desktop <# "@bob sending a file"
+      desktop <# "/f @bob test_1.pdf"
+      desktop <## "use /fc 1 to cancel sending"
+      bob <# "alice> sending a file"
+      bob <# "alice> sends file test_1.pdf (266.0 KiB / 272376 bytes)"
+      bob <## "use /fr 1 [<dir>/ | <path>] to receive it"
+      bob ##> "/fr 1"
+      concurrentlyN_
+        [ do
+            desktop <## "completed uploading file 1 (test_1.pdf) for bob",
+          do
+            bob <## "saving file 1 from alice to test_1.pdf"
+            bob <## "started receiving file 1 (test_1.pdf) from alice"
+            bob <## "completed receiving file 1 (test_1.pdf) from alice"
+        ]
+      B.readFile (bobFiles </> "test_1.pdf") `shouldReturn` src
+      -- returns error for inactive user
+      desktop ##> "/get remote file 1 {\"userId\": 2, \"fileId\": 1, \"sent\": true, \"fileSource\": {\"filePath\": \"test_1.pdf\"}}"
+      hostError desktop "CEDifferentActiveUser"
+      -- returns error with incorrect file ID
+      desktop ##> "/get remote file 1 {\"userId\": 1, \"fileId\": 2, \"sent\": true, \"fileSource\": {\"filePath\": \"test_1.pdf\"}}"
+      hostError desktop "SEFileNotFound"
+      -- gets file
+      doesFileExist (desktopHostStore </> "test_1.pdf") `shouldReturn` False
+      desktop ##> "/get remote file 1 {\"userId\": 1, \"fileId\": 1, \"sent\": true, \"fileSource\": {\"filePath\": \"test_1.pdf\"}}"
+      desktop <## "ok"
+      B.readFile (desktopHostStore </> "test_1.pdf") `shouldReturn` src
+
+      -- send file encrypted locally on mobile host
+      desktop ##> ("/_send @2 json {\"fileSource\": {\"filePath\":\"test_2.pdf\", \"cryptoArgs\": " <> LB.unpack (J.encode cfArgs) <> "}, \"msgContent\": {\"type\": \"file\", \"text\": \"\"}}")
+      desktop <# "/f @bob test_2.pdf"
+      desktop <## "use /fc 2 to cancel sending"
+      bob <# "alice> sends file test_2.pdf (266.0 KiB / 272376 bytes)"
+      bob <## "use /fr 2 [<dir>/ | <path>] to receive it"
+      bob ##> "/fr 2"
+      concurrentlyN_
+        [ do
+            desktop <## "completed uploading file 2 (test_2.pdf) for bob",
+          do
+            bob <## "saving file 2 from alice to test_2.pdf"
+            bob <## "started receiving file 2 (test_2.pdf) from alice"
+            bob <## "completed receiving file 2 (test_2.pdf) from alice"
+        ]
+      B.readFile (bobFiles </> "test_2.pdf") `shouldReturn` src
+
+      -- receive file via remote host
+      copyFile "./tests/fixtures/test.jpg" (bobFiles </> "test.jpg")
+      bob #> "/f @alice test.jpg"
+      bob <## "use /fc 3 to cancel sending"
+      desktop <# "bob> sends file test.jpg (136.5 KiB / 139737 bytes)"
+      desktop <## "use /fr 3 [<dir>/ | <path>] to receive it"
+      desktop ##> "/fr 3 encrypt=on"
+      concurrentlyN_
+        [ do
+            bob <## "completed uploading file 3 (test.jpg) for alice",
+          do
+            desktop <## "saving file 3 from bob to test.jpg"
+            desktop <## "started receiving file 3 (test.jpg) from bob"
+            desktop <## "completed receiving file 3 (test.jpg) from bob"
+        ]
+      Just cfArgs'@(CFArgs key' nonce') <- J.decode . LB.pack <$> getTermLine desktop
+      desktop <## "File received to connected remote host 1"
+      desktop <## "To download to this device use:"
+      getCmd <- getTermLine desktop
+      getCmd `shouldBe` ("/get remote file 1 {\"userId\":1,\"fileId\":3,\"sent\":false,\"fileSource\":{\"filePath\":\"test.jpg\",\"cryptoArgs\":" <> LB.unpack (J.encode cfArgs') <> "}}")
+      src' <- B.readFile (bobFiles </> "test.jpg")
+      chatReadFile (mobileFiles </> "test.jpg") (strEncode key') (strEncode nonce') `shouldReturn` Right (LB.fromStrict src')
+      doesFileExist (desktopHostStore </> "test.jpg") `shouldReturn` False
+      -- returns error with incorrect key
+      desktop ##> "/get remote file 1 {\"userId\": 1, \"fileId\": 3, \"sent\": false, \"fileSource\": {\"filePath\": \"test.jpg\", \"cryptoArgs\": null}}"
+      hostError desktop "SEFileNotFound"
+      doesFileExist (desktopHostStore </> "test.jpg") `shouldReturn` False
+      desktop ##> getCmd
+      desktop <## "ok"
+      chatReadFile (desktopHostStore </> "test.jpg") (strEncode key') (strEncode nonce') `shouldReturn` Right (LB.fromStrict src')
+
+      stopMobile mobile desktop
+  where
+    cfg = testCfg {xftpFileConfig = Just $ XFTPFileConfig {minFileSize = 0}, tempDir = Just "./tests/tmp/tmp"}
+    hostError cc err = do
+      r <- getTermLine cc
+      r `shouldStartWith` "remote host 1 error"
+      r `shouldContain` err
+
+remoteCLIFileTest :: HasCallStack => FilePath -> IO ()
+remoteCLIFileTest = testChatCfg3 cfg aliceProfile aliceDesktopProfile bobProfile $ \mobile desktop bob -> withXFTPServer $ do
+  createDirectoryIfMissing True "./tests/tmp/tmp/"
+  let mobileFiles = "./tests/tmp/mobile_files"
+  mobile ##> ("/_files_folder " <> mobileFiles)
+  mobile <## "ok"
+  let bobFiles = "./tests/tmp/bob_files/"
+  createDirectoryIfMissing True bobFiles
+  let desktopHostFiles = "./tests/tmp/remote_hosts_data"
+  desktop ##> ("/remote_hosts_folder " <> desktopHostFiles)
+  desktop <## "ok"
+
+  startRemote mobile desktop
+  contactBob desktop bob
+
+  rhs <- readTVarIO (Controller.remoteHostSessions $ chatController desktop)
+  desktopHostStore <- case M.lookup (RHId 1) rhs of
+    Just (_, RHSessionConnected {storePath}) -> pure $ desktopHostFiles </> storePath </> archiveFilesFolder
+    _ -> fail "Host session 1 should be started"
+
+  mobileName <- userName mobile
+
+  bob #> ("/f @" <> mobileName <> " " <> "tests/fixtures/test.pdf")
+  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 <## "completed uploading file 1 (test.pdf) for alice",
+      do
+        desktop <## "saving file 1 from bob to test.pdf"
+        desktop <## "started receiving file 1 (test.pdf) from bob"
+        desktop <## "completed receiving file 1 (test.pdf) from bob"
+    ]
+
+  desktop <## "File received to connected remote host 1"
+  desktop <## "To download to this device use:"
+  getCmd <- getTermLine desktop
+  src <- B.readFile "tests/fixtures/test.pdf"
+  B.readFile (mobileFiles </> "test.pdf") `shouldReturn` src
+  doesFileExist (desktopHostStore </> "test.pdf") `shouldReturn` False
+  desktop ##> getCmd
+  desktop <## "ok"
+  B.readFile (desktopHostStore </> "test.pdf") `shouldReturn` src
+
+  desktop `send` "/f @bob tests/fixtures/test.jpg"
+  desktop <# "/f @bob test.jpg"
+  desktop <## "use /fc 2 to cancel sending"
+
+  bob <# "alice> sends file test.jpg (136.5 KiB / 139737 bytes)"
+  bob <## "use /fr 2 [<dir>/ | <path>] to receive it"
+  bob ##> ("/fr 2 " <> bobFiles)
+  concurrentlyN_
+    [ do
+        desktop <## "completed uploading file 2 (test.jpg) for bob",
+      do
+        bob <## "saving file 2 from alice to ./tests/tmp/bob_files/test.jpg"
+        bob <## "started receiving file 2 (test.jpg) from alice"
+        bob <## "completed receiving file 2 (test.jpg) from alice"
+    ]
+
+  src' <- B.readFile "tests/fixtures/test.jpg"
+  B.readFile (mobileFiles </> "test.jpg") `shouldReturn` src'
+  B.readFile (desktopHostStore </> "test.jpg") `shouldReturn` src'
+  B.readFile (bobFiles </> "test.jpg") `shouldReturn` src'
+
+  stopMobile mobile desktop
+  where
+    cfg = testCfg {xftpFileConfig = Just $ XFTPFileConfig {minFileSize = 0}, tempDir = Just "./tests/tmp/tmp"}
+
+switchRemoteHostTest :: FilePath -> IO ()
+switchRemoteHostTest = testChat3 aliceProfile aliceDesktopProfile bobProfile $ \mobile desktop bob -> do
+  startRemote mobile desktop
+  contactBob desktop bob
+
+  desktop ##> "/contacts"
+  desktop <## "bob (Bob)"
+
+  desktop ##> "/switch remote host local"
+  desktop <## "Using local profile"
+  desktop ##> "/contacts"
+
+  desktop ##> "/switch remote host 1"
+  desktop <## "Using remote host 1 (Mobile)"
+  desktop ##> "/contacts"
+  desktop <## "bob (Bob)"
+
+  desktop ##> "/switch remote host 123"
+  desktop <## "no remote host 123"
+
+  stopDesktop mobile desktop
+  desktop ##> "/contacts"
+  desktop ##> "/switch remote host 1"
+  desktop <## "remote host 1 error: RHEInactive"
+  desktop ##> "/contacts"
+
+indicateRemoteHostTest :: FilePath -> IO ()
+indicateRemoteHostTest = testChat4 aliceProfile aliceDesktopProfile bobProfile cathProfile $ \mobile desktop bob cath -> do
+  connectUsers desktop cath
+  startRemote mobile desktop
+  contactBob desktop bob
+  -- remote contact -> remote host
+  bob #> "@alice hi"
+  desktop <#. "bob> hi"
+  -- local -> remote
+  cath #> "@alice_desktop hello"
+  (desktop, "[local] ") ^<# "cath> hello"
+  -- local -> local
+  desktop ##> "/switch remote host local"
+  desktop <## "Using local profile"
+  desktop <##> cath
+  -- local -> remote
+  bob #> "@alice what's up?"
+  (desktop, "[remote: 1] ") ^<# "bob> what's up?"
+
+  -- local -> local after disconnect
+  stopDesktop mobile desktop
+  desktop <##> cath
+  cath <##> desktop
+
+-- * Utils
+
+startRemote :: TestCC -> TestCC -> IO ()
+startRemote mobile desktop = do
+  desktop ##> "/set device name My desktop"
+  desktop <## "ok"
+  mobile ##> "/set device name Mobile"
+  mobile <## "ok"
+  desktop ##> "/start remote host new"
+  desktop <## "new remote host started"
+  desktop <## "Remote session invitation:"
+  inv <- getTermLine desktop
+  mobile ##> ("/connect remote ctrl " <> inv)
+  mobile <## "connecting new remote controller: My desktop, v5.4.0.3"
+  desktop <## "new remote host connecting"
+  mobile <## "new remote controller connected"
+  verifyRemoteCtrl mobile desktop
+  mobile <## "remote controller 1 session started with My desktop"
+  desktop <## "new remote host 1 added: Mobile"
+  desktop <## "remote host 1 connected"
+
+startRemoteStored :: TestCC -> TestCC -> IO ()
+startRemoteStored mobile desktop = do
+  desktop ##> "/start remote host 1"
+  desktop <## "remote host 1 started"
+  desktop <## "Remote session invitation:"
+  inv <- getTermLine desktop
+  mobile ##> ("/connect remote ctrl " <> inv)
+  mobile <## "connecting remote controller 1: My desktop, v5.4.0.3"
+  desktop <## "remote host 1 connecting"
+  mobile <## "remote controller 1 connected"
+  verifyRemoteCtrl mobile desktop
+  mobile <## "remote controller 1 session started with My desktop"
+  desktop <## "remote host 1 connected"
+
+startRemoteDiscover :: TestCC -> TestCC -> IO ()
+startRemoteDiscover mobile desktop = do
+  desktop ##> "/start remote host 1 multicast=on"
+  desktop <## "remote host 1 started"
+  desktop <## "Remote session invitation:"
+  _inv <- getTermLine desktop -- will use multicast instead
+  mobile ##> "/find remote ctrl"
+  mobile <## "ok"
+  mobile <## "remote controller found:"
+  mobile <## "1. My desktop"
+  mobile ##> "/confirm remote ctrl 1"
+
+  mobile <## "connecting remote controller 1: My desktop, v5.4.0.3"
+  desktop <## "remote host 1 connecting"
+  mobile <## "remote controller 1 connected"
+  verifyRemoteCtrl mobile desktop
+  mobile <## "remote controller 1 session started with My desktop"
+  desktop <## "remote host 1 connected"
+
+verifyRemoteCtrl :: TestCC -> TestCC -> IO ()
+verifyRemoteCtrl mobile desktop = do
+  desktop <## "Compare session code with host:"
+  sessId <- getTermLine desktop
+  mobile <## "Compare session code with controller and use:"
+  mobile <## ("/verify remote ctrl " <> sessId)
+  mobile ##> ("/verify remote ctrl " <> sessId)
+
+contactBob :: TestCC -> TestCC -> IO ()
+contactBob desktop bob = do
+  logNote "exchanging contacts"
+  bob ##> "/c"
+  inv' <- getInvitation bob
+  desktop ##> ("/c " <> inv')
+  desktop <## "confirmation sent!"
+  concurrently_
+    (desktop <## "bob (Bob): contact is connected")
+    (bob <## "alice (Alice): contact is connected")
+
+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"
+  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"
+  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

tests/Test.hs

@@ -5,9 +5,11 @@ import ChatTests
 import ChatTests.Utils (xdescribe'')
 import Control.Logger.Simple
 import Data.Time.Clock.System
+import JSONTests
 import MarkdownTests
 import MobileTests
 import ProtocolTests
+import RemoteTests
 import SchemaDump
 import Test.Hspec
 import UnliftIO.Temporary (withTempDirectory)
@@ -17,10 +19,11 @@ import WebRTCTests
 
 main :: IO ()
 main = do
-  setLogLevel LogError -- LogDebug
+  setLogLevel LogError
   withGlobalLogging logCfg . hspec $ do
     describe "Schema dump" schemaDumpTest
     describe "SimpleX chat markdown" markdownTests
+    describe "JSON Tests" jsonTests
     describe "SimpleX chat view" viewTests
     describe "SimpleX chat protocol" protocolTests
     describe "WebRTC encryption" webRTCTests
@@ -30,6 +33,7 @@ main = do
       describe "SimpleX chat client" chatTests
       xdescribe'' "SimpleX Broadcast bot" broadcastBotTests
       xdescribe'' "SimpleX Directory service bot" directoryServiceTests
+      describe "Remote session" remoteTests
   where
     testBracket test = do
       t <- getSystemTime

tests/ViewTests.hs

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