From be44632b0bc71df56d034d16ffdce0b41dedd171 Mon Sep 17 00:00:00 2001 From: Alexander Bondarenko <486682+dpwiz@users.noreply.github.com> Date: Mon, 30 Oct 2023 16:00:54 +0200 Subject: [PATCH] implement some of the robust discovery rfc (#3283) * implement robust discovery * remove qualified --------- Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> --- src/Simplex/Chat.hs | 6 +- src/Simplex/Chat/Controller.hs | 11 +- src/Simplex/Chat/Remote.hs | 88 ++++++------ src/Simplex/Chat/Remote/Discovery.hs | 196 +++++++++++++++++--------- src/Simplex/Chat/Remote/Multicast.hsc | 9 +- src/Simplex/Chat/Remote/Protocol.hs | 4 +- src/Simplex/Chat/Remote/Types.hs | 181 +++++++++++++++++++++++- src/Simplex/Chat/Store/Remote.hs | 10 +- src/Simplex/Chat/View.hs | 9 +- tests/RemoteTests.hs | 66 ++++++--- 10 files changed, 430 insertions(+), 150 deletions(-) diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index e46a426d8c..383e045f8b 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -213,6 +213,7 @@ newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agen rcvFiles <- newTVarIO M.empty currentCalls <- atomically TM.empty localDeviceName <- newTVarIO "" -- TODO set in config + multicastSubscribers <- newTMVarIO 0 remoteHostSessions <- atomically TM.empty remoteHostsFolder <- newTVarIO Nothing remoteCtrlSession <- newTVarIO Nothing @@ -247,6 +248,7 @@ newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agen rcvFiles, currentCalls, localDeviceName, + multicastSubscribers, remoteHostSessions, remoteHostsFolder, remoteCtrlSession, @@ -5861,8 +5863,8 @@ chatCommandP = "/store remote file " *> (StoreRemoteFile <$> A.decimal <*> optional (" encrypt=" *> onOffP) <* A.space <*> filePath), "/get remote file " *> (GetRemoteFile <$> A.decimal <* A.space <*> jsonP), "/start remote ctrl" $> StartRemoteCtrl, - "/register remote ctrl " *> (RegisterRemoteCtrl <$> (RemoteCtrlOOB <$> strP <* A.space <*> textP)), - "/_register remote ctrl " *> (RegisterRemoteCtrl <$> jsonP), + "/register remote ctrl " *> (RegisterRemoteCtrl <$> strP), + -- "/_register remote ctrl " *> (RegisterRemoteCtrl <$> jsonP), "/list remote ctrls" $> ListRemoteCtrls, "/accept remote ctrl " *> (AcceptRemoteCtrl <$> A.decimal), "/reject remote ctrl " *> (RejectRemoteCtrl <$> A.decimal), diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index bc4cfaaf89..19e8dc34dc 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -25,7 +25,7 @@ import Control.Monad.Reader import Crypto.Random (ChaChaDRG) import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.:?)) import qualified Data.Aeson as J -import qualified Data.Aeson.TH as JQ +import qualified Data.Aeson.TH as JQ import qualified Data.Aeson.Types as JT import qualified Data.Attoparsec.ByteString.Char8 as A import Data.ByteString.Char8 (ByteString) @@ -40,6 +40,7 @@ import Data.String import Data.Text (Text) import Data.Time (NominalDiffTime, UTCTime) import Data.Version (showVersion) +import Data.Word (Word16) import Language.Haskell.TH (Exp, Q, runIO) import Numeric.Natural import qualified Paths_simplex_chat as SC @@ -177,6 +178,7 @@ data ChatController = ChatController rcvFiles :: TVar (Map Int64 Handle), currentCalls :: TMap ContactId Call, localDeviceName :: TVar Text, + multicastSubscribers :: TMVar Int, remoteHostSessions :: TMap RemoteHostId RemoteHostSession, -- All the active remote hosts remoteHostsFolder :: TVar (Maybe FilePath), -- folder for remote hosts data remoteCtrlSession :: TVar (Maybe RemoteCtrlSession), -- Supervisor process for hosted controllers @@ -424,12 +426,12 @@ data ChatCommand | StoreRemoteFile {remoteHostId :: RemoteHostId, storeEncrypted :: Maybe Bool, localPath :: FilePath} | GetRemoteFile {remoteHostId :: RemoteHostId, file :: RemoteFile} | StartRemoteCtrl -- ^ Start listening for announcements from all registered controllers - | RegisterRemoteCtrl RemoteCtrlOOB -- ^ Register OOB data for satellite discovery and handshake + | RegisterRemoteCtrl SignedOOB -- ^ Register OOB data for remote controller discovery and handshake | ListRemoteCtrls | AcceptRemoteCtrl RemoteCtrlId -- ^ Accept discovered data and store confirmation | RejectRemoteCtrl RemoteCtrlId -- ^ Reject and blacklist discovered data | StopRemoteCtrl -- ^ Stop listening for announcements or terminate an active session - | DeleteRemoteCtrl RemoteCtrlId -- ^ Remove all local data associated with a satellite session + | DeleteRemoteCtrl RemoteCtrlId -- ^ Remove all local data associated with a remote controller session | QuitChat | ShowVersion | DebugLocks @@ -634,6 +636,7 @@ data ChatResponse | CRContactConnectionDeleted {user :: User, connection :: PendingContactConnection} | CRRemoteHostCreated {remoteHost :: RemoteHostInfo} | CRRemoteHostList {remoteHosts :: [RemoteHostInfo]} + | CRRemoteHostStarted {remoteHost :: RemoteHostInfo, sessionOOB :: Text} | CRRemoteHostConnected {remoteHost :: RemoteHostInfo} | CRRemoteHostStopped {remoteHostId :: RemoteHostId} | CRRemoteFileStored {remoteHostId :: RemoteHostId, remoteFileSource :: CryptoFile} @@ -1069,7 +1072,7 @@ data RemoteCtrlSession = RemoteCtrlSession discoverer :: Async (), supervisor :: Async (), hostServer :: Maybe (Async ()), - discovered :: TMap C.KeyHash TransportHost, + discovered :: TMap C.KeyHash (TransportHost, Word16), accepted :: TMVar RemoteCtrlId, remoteOutputQ :: TBQueue ChatResponse } diff --git a/src/Simplex/Chat/Remote.hs b/src/Simplex/Chat/Remote.hs index 5344c4bea6..d6ccd25961 100644 --- a/src/Simplex/Chat/Remote.hs +++ b/src/Simplex/Chat/Remote.hs @@ -12,6 +12,7 @@ module Simplex.Chat.Remote where +import Control.Applicative ((<|>)) import Control.Logger.Simple import Control.Monad import Control.Monad.Except @@ -24,15 +25,16 @@ 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.Functor (($>)) 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 (encodeUtf8) -import Data.Word (Word32) -import Network.HTTP2.Server (responseStreaming) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.Word (Word16, Word32) import qualified Network.HTTP.Types as N +import Network.HTTP2.Server (responseStreaming) import Network.Socket (SockAddr (..), hostAddressToTuple) import Simplex.Chat.Archive (archiveFilesFolder) import Simplex.Chat.Controller @@ -51,18 +53,17 @@ import Simplex.FileTransfer.Description (FileDigest (..)) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..)) import qualified Simplex.Messaging.Crypto.File as CF +import Simplex.Messaging.Encoding (smpDecode) import Simplex.Messaging.Encoding.String (StrEncoding (..)) +import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Transport.Client (TransportHost (..)) import Simplex.Messaging.Transport.Credentials (genCredentials, tlsCredentials) import Simplex.Messaging.Transport.HTTP2.File (hSendFile) import Simplex.Messaging.Transport.HTTP2.Server (HTTP2Request (..)) -import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Util (ifM, liftEitherError, liftEitherWith, liftError, liftIOEither, tryAllErrors, tshow, ($>>=), (<$$>)) -import System.FilePath ((), takeFileName) +import System.FilePath (takeFileName, ()) import UnliftIO import UnliftIO.Directory (copyFile, createDirectoryIfMissing, renameFile) -import Data.Functor (($>)) -import Control.Applicative ((<|>)) -- * Desktop side @@ -108,11 +109,14 @@ startRemoteHost rhId = do 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 + localAddr <- asks multicastSubscribers >>= Discovery.getLocalAddress >>= maybe (throwError . ChatError $ CEInternalError "unable to get local address") pure + (dhKey, sigKey, ann, oob) <- Discovery.startSession (if rcName == "" then Nothing else Just rcName) (localAddr, read Discovery.DISCOVERY_PORT) fingerprint + toView CRRemoteHostStarted {remoteHost = remoteHostInfo rh True, sessionOOB = decodeUtf8 $ strEncode oob} + httpClient <- liftEitherError (ChatErrorRemoteCtrl . RCEHTTP2Error . show) $ Discovery.announceRevHTTP2 tasks (sigKey, ann) credentials cleanupIO + logInfo $ "Remote host session connected for " <> tshow rhId -- test connection and establish a protocol layer - remoteHostClient <- liftRH rhId $ createRemoteHostClient httpClient rcName + remoteHostClient <- liftRH rhId $ createRemoteHostClient httpClient dhKey rcName -- set up message polling oq <- asks outputQ asyncRegistered tasks . forever $ do @@ -125,7 +129,6 @@ startRemoteHost rhId = do { remoteHostId = rhId, storePath = storePath, displayName = hostDeviceName remoteHostClient, - remoteCtrlOOB = RemoteCtrlOOB {fingerprint, displayName=rcName}, sessionActive = True } @@ -159,10 +162,9 @@ createRemoteHost = do ((_, caKey), caCert) <- liftIO $ genCredentials Nothing (-25, 24 * 365) "Host" storePath <- liftIO randomStorePath 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} + rhId <- withStore' $ \db -> insertRemoteHost db storePath remoteName caKey caCert + rh <- withStore $ \db -> getRemoteHost db rhId + pure $ remoteHostInfo rh False -- | Generate a random 16-char filepath without / in it by using base64url encoding. randomStorePath :: IO FilePath @@ -171,16 +173,14 @@ randomStorePath = B.unpack . B64U.encode <$> getRandomBytes 12 listRemoteHosts :: ChatMonad m => m [RemoteHostInfo] listRemoteHosts = do active <- chatReadVar remoteHostSessions - rcName <- chatReadVar localDeviceName - map (rhInfo active rcName) <$> withStore' getRemoteHosts + map (rhInfo active) <$> withStore' getRemoteHosts where - rhInfo active rcName rh@RemoteHost {remoteHostId} = - remoteHostInfo rh (M.member remoteHostId active) rcName + rhInfo active rh@RemoteHost {remoteHostId} = + remoteHostInfo rh (M.member remoteHostId active) -remoteHostInfo :: RemoteHost -> Bool -> Text -> RemoteHostInfo -remoteHostInfo RemoteHost {remoteHostId, storePath, displayName, caCert} sessionActive rcName = - let remoteCtrlOOB = RemoteCtrlOOB {fingerprint = C.certificateFingerprint caCert, displayName = rcName} - in RemoteHostInfo {remoteHostId, storePath, displayName, remoteCtrlOOB, sessionActive} +remoteHostInfo :: RemoteHost -> Bool -> RemoteHostInfo +remoteHostInfo RemoteHost {remoteHostId, storePath, displayName} sessionActive = + RemoteHostInfo {remoteHostId, storePath, displayName, sessionActive} deleteRemoteHost :: ChatMonad m => RemoteHostId -> m () deleteRemoteHost rhId = do @@ -231,7 +231,7 @@ getRemoteFile rhId rf = do processRemoteCommand :: ChatMonad m => RemoteHostId -> RemoteHostSession -> ChatCommand -> ByteString -> m ChatResponse processRemoteCommand remoteHostId RemoteHostSession {remoteHostClient = Just rhc} cmd s = case cmd of SendFile chatName f -> sendFile "/f" chatName f - SendImage chatName f -> sendFile "/img" chatName f + SendImage chatName f -> sendFile "/img" chatName f _ -> liftRH remoteHostId $ remoteSend rhc s where sendFile cmdName chatName (CryptoFile path cfArgs) = do @@ -262,14 +262,14 @@ startRemoteCtrl execChatCommand = do 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 :: ChatMonad m => TM.TMap C.KeyHash (TransportHost, Word16) -> 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 + serviceAddress <- atomically $ TM.lookup fingerprint discovered >>= maybe retry pure -- wait for location of the matching fingerprint toView $ CRRemoteCtrlConnecting $ remoteCtrlInfo rc False atomically $ writeTVar discovered mempty -- flush unused sources - server <- async $ Discovery.connectRevHTTP2 source fingerprint handleHttp -- spawn server for remote protocol commands + server <- async $ Discovery.connectRevHTTP2 serviceAddress 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 @@ -369,34 +369,38 @@ handleGetFile User {userId} RemoteFile{userId = commandUserId, fileId, sent, fil withFile path ReadMode $ \h -> reply RRFile {fileSize, fileDigest} $ \send -> hSendFile h send fileSize -discoverRemoteCtrls :: ChatMonad m => TM.TMap C.KeyHash TransportHost -> m () -discoverRemoteCtrls discovered = Discovery.withListener $ receive >=> process +discoverRemoteCtrls :: ChatMonad m => TM.TMap C.KeyHash (TransportHost, Word16) -> m () +discoverRemoteCtrls discovered = do + subscribers <- asks multicastSubscribers + Discovery.withListener subscribers run where - -- TODO how would it receive more than one fingerprint? + run sock = receive sock >>= process sock + receive sock = Discovery.recvAnnounce sock >>= \case - (SockAddrInet _sockPort sockAddr, invite) -> case strDecode invite of - -- TODO it is probably better to report errors to view here - Left _ -> receive sock - Right fingerprint -> pure (sockAddr, fingerprint) + (SockAddrInet _sockPort sockAddr, sigAnnBytes) -> case smpDecode sigAnnBytes of + Right (SignedAnnounce ann _sig) -> pure (sockAddr, ann) + Left _ -> receive sock -- TODO it is probably better to report errors to view here _nonV4 -> receive sock - process (sockAddr, fingerprint) = do + + process sock (sockAddr, Announce {caFingerprint, serviceAddress=(annAddr, port)}) = do + unless (annAddr == sockAddr) $ logError "Announced address doesn't match socket address" let addr = THIPv4 (hostAddressToTuple sockAddr) ifM - (atomically $ TM.member fingerprint discovered) - (logDebug $ "Fingerprint already known: " <> tshow (addr, fingerprint)) + (atomically $ TM.member caFingerprint discovered) + (logDebug $ "Fingerprint already known: " <> tshow (addr, caFingerprint)) ( do - logInfo $ "New fingerprint announced: " <> tshow (addr, fingerprint) - atomically $ TM.insert fingerprint addr discovered + logInfo $ "New fingerprint announced: " <> tshow (addr, caFingerprint) + atomically $ TM.insert caFingerprint (addr, port) discovered ) -- TODO we check fingerprint for duplicate where id doesn't matter - to prevent re-insert - and don't check to prevent duplicate events, -- so UI now will have to check for duplicates again - withStore' (`getRemoteCtrlByFingerprint` fingerprint) >>= \case - Nothing -> toView $ CRRemoteCtrlAnnounce fingerprint -- unknown controller, ui "register" action required + withStore' (`getRemoteCtrlByFingerprint` caFingerprint) >>= \case + Nothing -> toView $ CRRemoteCtrlAnnounce caFingerprint -- unknown controller, ui "register" action required -- TODO Maybe Bool is very confusing - the intent is very unclear here Just found@RemoteCtrl {remoteCtrlId, accepted = storedChoice} -> case storedChoice of Nothing -> toView $ CRRemoteCtrlFound $ remoteCtrlInfo found False -- first-time controller, ui "accept" action required - Just False -> pure () -- skipping a rejected item + Just False -> run sock -- restart, skipping a rejected item Just True -> chatReadVar remoteCtrlSession >>= \case Nothing -> toView . CRChatError Nothing . ChatError $ CEInternalError "Remote host found without running a session" diff --git a/src/Simplex/Chat/Remote/Discovery.hs b/src/Simplex/Chat/Remote/Discovery.hs index babc65e6a8..1ede108b07 100644 --- a/src/Simplex/Chat/Remote/Discovery.hs +++ b/src/Simplex/Chat/Remote/Discovery.hs @@ -1,37 +1,33 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} -module Simplex.Chat.Remote.Discovery - ( -- * Announce - announceRevHTTP2, - runAnnouncer, - startTLSServer, - runHTTP2Client, - - -- * Discovery - connectRevHTTP2, - withListener, - openListener, - recvAnnounce, - connectTLSClient, - attachHTTP2Server, - ) -where +module Simplex.Chat.Remote.Discovery where import Control.Logger.Simple import Control.Monad +import Crypto.Random (getRandomBytes) import Data.ByteString (ByteString) +import qualified Data.ByteString.Base64.URL as B64U import Data.Default (def) import Data.String (IsString) +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8) +import Data.Time.Clock.System (getSystemTime) +import Data.Word (Word16) import qualified Network.Socket as N import qualified Network.TLS as TLS import qualified Network.UDP as UDP import Simplex.Chat.Remote.Multicast (setMembership) -import Simplex.Chat.Remote.Types (Tasks, registerAsync) +import Simplex.Chat.Remote.Types import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Encoding (Encoding (..)) import Simplex.Messaging.Encoding.String (StrEncoding (..)) import Simplex.Messaging.Transport (supportedParameters) import qualified Simplex.Messaging.Transport as Transport @@ -39,8 +35,9 @@ import Simplex.Messaging.Transport.Client (TransportHost (..), defaultTransportC import Simplex.Messaging.Transport.HTTP2 (defaultHTTP2BufferSize, getHTTP2Body) import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client, HTTP2ClientError (..), attachHTTP2Client, bodyHeadSize, connTimeout, defaultHTTP2ClientConfig) import Simplex.Messaging.Transport.HTTP2.Server (HTTP2Request (..), runHTTP2ServerWith) -import Simplex.Messaging.Transport.Server (defaultTransportServerConfig, runTransportServer) -import Simplex.Messaging.Util (ifM, tshow, whenM) +import Simplex.Messaging.Transport.Server (defaultTransportServerConfig, runTransportServerSocket, startTCPServer) +import Simplex.Messaging.Util (ifM, tshow) +import Simplex.Messaging.Version (mkVersionRange) import UnliftIO import UnliftIO.Concurrent @@ -52,54 +49,107 @@ pattern ANY_ADDR_V4 :: (IsString a, Eq a) => a pattern ANY_ADDR_V4 = "0.0.0.0" pattern DISCOVERY_PORT :: (IsString a, Eq a) => a -pattern DISCOVERY_PORT = "5226" +pattern DISCOVERY_PORT = "5227" + +startSession :: MonadIO m => Maybe Text -> (N.HostAddress, Word16) -> C.KeyHash -> m ((C.APublicDhKey, C.APrivateDhKey), C.PrivateKeyEd25519, Announce, SignedOOB) +startSession deviceName serviceAddress caFingerprint = liftIO $ do + sessionStart <- getSystemTime + dh@(C.APublicDhKey C.SX25519 sessionDH, _) <- C.generateDhKeyPair C.SX25519 + (C.APublicVerifyKey C.SEd25519 sigPubKey, C.APrivateSignKey C.SEd25519 sigSecretKey) <- C.generateSignatureKeyPair C.SEd25519 + let + announce = + Announce + { versionRange = announceVersionRange, + sessionStart, + announceCounter = 0, + serviceAddress, + caFingerprint, + sessionDH, + announceKey = sigPubKey + } + authToken <- decodeUtf8 . B64U.encode <$> getRandomBytes 12 + let + oob = + OOB + { caFingerprint, + authToken, + host = decodeUtf8 . strEncode $ THIPv4 . N.hostAddressToTuple $ fst serviceAddress, + port = snd serviceAddress, + version = mkVersionRange 1 1, + appName = "simplex-chat", + sigPubKey, + deviceName + } + pure (dh, sigSecretKey, announce, signOOB sigSecretKey oob) + +getLocalAddress :: MonadIO m => TMVar Int -> m (Maybe N.HostAddress) +getLocalAddress subscribers = liftIO $ do + probe <- mkIpProbe + let bytes = smpEncode probe + withListener subscribers $ \receiver -> + withSender $ \sender -> do + UDP.send sender bytes + let expect = do + UDP.recvFrom receiver >>= \case + (p, _) | p /= bytes -> expect + (_, UDP.ClientSockAddr (N.SockAddrInet _port host) _cmsg) -> pure host + (_, UDP.ClientSockAddr _badAddr _) -> error "receiving from IPv4 socket" + timeout 1000000 expect + +mkIpProbe :: MonadIO m => m IpProbe +mkIpProbe = do + randomNonce <- liftIO $ getRandomBytes 32 + pure IpProbe {versionRange = ipProbeVersionRange, randomNonce} -- | 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 => Tasks -> a -> TLS.Credentials -> IO () -> IO (Either HTTP2ClientError HTTP2Client) -announceRevHTTP2 tasks invite credentials finishAction = do +announceRevHTTP2 :: Tasks -> (C.PrivateKeyEd25519, Announce) -> TLS.Credentials -> IO () -> IO (Either HTTP2ClientError HTTP2Client) +announceRevHTTP2 tasks (sigKey, announce@Announce {caFingerprint, serviceAddress=(host, _port)}) credentials finishAction = do httpClient <- newEmptyMVar started <- newEmptyTMVarIO finished <- newEmptyMVar _ <- 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) + announcer <- async . liftIO $ atomically (takeTMVar started) >>= \case + Nothing -> pure () -- TLS server failed to start, skipping announcer + Just givenPort -> do + logInfo $ "Starting announcer for " <> ident <> " at " <> tshow (host, givenPort) + runAnnouncer (sigKey, announce {serviceAddress = (host, fromIntegral givenPort)}) tasks `registerAsync` announcer tlsServer <- startTLSServer started credentials $ \tls -> do - logInfo $ "Incoming connection for " <> tshow (strEncode invite) + logInfo $ "Incoming connection for " <> ident cancel announcer 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 () + logInfo $ "Client finished for " <> ident + -- BUG: this should be handled in HTTP2Client wrapper, partially handled in startTLSServer + _ <- forkIO $ waitCatch tlsServer >> void (tryPutMVar finished ()) tasks `registerAsync` tlsServer - logInfo $ "Waiting for client for " <> tshow (strEncode invite) + logInfo $ "Waiting for client for " <> ident readMVar httpClient + where + ident = decodeUtf8 $ strEncode caFingerprint --- | Broadcast invite with link-local datagrams -runAnnouncer :: ByteString -> IO () -runAnnouncer inviteBS = do - bracket (UDP.clientSocket MULTICAST_ADDR_V4 DISCOVERY_PORT False) UDP.close $ \sock -> do - let raw = UDP.udpSocket sock - N.setSocketOption raw N.Broadcast 1 - N.setSocketOption raw N.ReuseAddr 1 - forever $ do - UDP.send sock inviteBS +-- | Send replay-proof announce datagrams +runAnnouncer :: (C.PrivateKeyEd25519, Announce) -> IO () +runAnnouncer (announceKey, initialAnnounce) = withSender $ loop initialAnnounce + where + loop announce sock = do + UDP.send sock $ smpEncode (signAnnounce announceKey announce) threadDelay 1000000 + loop announce {announceCounter = announceCounter announce + 1} sock --- 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 DISCOVERY_PORT serverParams defaultTransportServerConfig +startTLSServer :: (MonadUnliftIO m) => TMVar (Maybe N.PortNumber) -> TLS.Credentials -> (Transport.TLS -> IO ()) -> m (Async ()) +startTLSServer started credentials server = async . liftIO $ do + startedOk <- newEmptyTMVarIO + bracketOnError (startTCPServer startedOk "0") (\_e -> void . atomically $ tryPutTMVar started Nothing) $ \socket -> + ifM + (atomically $ readTMVar startedOk) + do + port <- N.socketPort socket + logInfo $ "System-assigned port: " <> tshow port + atomically $ putTMVar started (Just port) + runTransportServerSocket startedOk (pure socket) "RCP TLS" serverParams defaultTransportServerConfig server + (void . atomically $ tryPutTMVar started Nothing) where serverParams = def @@ -123,22 +173,40 @@ runHTTP2Client finishedVar clientVar tls = -- TODO connection timeout config = defaultHTTP2ClientConfig {bodyHeadSize = doNotPrefetchHead, connTimeout = maxBound} -withListener :: (MonadUnliftIO m) => (UDP.ListenSocket -> m a) -> m a -withListener = bracket openListener closeListener +withSender :: MonadUnliftIO m => (UDP.UDPSocket -> m a) -> m a +withSender = bracket (liftIO $ UDP.clientSocket MULTICAST_ADDR_V4 DISCOVERY_PORT False) (liftIO . UDP.close) -openListener :: (MonadIO m) => m UDP.ListenSocket -openListener = liftIO $ do +withListener :: MonadUnliftIO m => TMVar Int -> (UDP.ListenSocket -> m a) -> m a +withListener subscribers = bracket (openListener subscribers) (closeListener subscribers) + +openListener :: MonadIO m => TMVar Int -> m UDP.ListenSocket +openListener subscribers = liftIO $ do sock <- UDP.serverSocket (MULTICAST_ADDR_V4, read DISCOVERY_PORT) logDebug $ "Discovery listener socket: " <> tshow sock let raw = UDP.listenSocket sock - N.setSocketOption raw N.Broadcast 1 - void $ setMembership raw (listenerHostAddr4 sock) True + -- N.setSocketOption raw N.Broadcast 1 + joinMulticast subscribers raw (listenerHostAddr4 sock) pure sock -closeListener :: MonadIO m => UDP.ListenSocket -> m () -closeListener sock = liftIO $ do - UDP.stop sock - void $ setMembership (UDP.listenSocket sock) (listenerHostAddr4 sock) False +closeListener :: MonadIO m => TMVar Int -> UDP.ListenSocket -> m () +closeListener subscribers sock = liftIO $ + partMulticast subscribers (UDP.listenSocket sock) (listenerHostAddr4 sock) `finally` UDP.stop sock + +joinMulticast :: TMVar Int -> N.Socket -> N.HostAddress -> IO () +joinMulticast subscribers sock group = do + now <- atomically $ takeTMVar subscribers + when (now == 0) $ do + setMembership sock group True >>= \case + Left e -> atomically (putTMVar subscribers now) >> logError ("setMembership failed " <> tshow e) + Right () -> atomically $ putTMVar subscribers (now + 1) + +partMulticast :: TMVar Int -> N.Socket -> N.HostAddress -> IO () +partMulticast subscribers sock group = do + now <- atomically $ takeTMVar subscribers + when (now == 1) $ + setMembership sock group False >>= \case + Left e -> atomically (putTMVar subscribers now) >> logError ("setMembership failed " <> tshow e) + Right () -> atomically $ putTMVar subscribers (now - 1) listenerHostAddr4 :: UDP.ListenSocket -> N.HostAddress listenerHostAddr4 sock = case UDP.mySockAddr sock of @@ -150,11 +218,11 @@ recvAnnounce sock = liftIO $ do (invite, UDP.ClientSockAddr source _cmsg) <- UDP.recvFrom sock pure (source, invite) -connectRevHTTP2 :: (MonadUnliftIO m) => TransportHost -> C.KeyHash -> (HTTP2Request -> m ()) -> m () -connectRevHTTP2 host fingerprint = connectTLSClient host fingerprint . attachHTTP2Server +connectRevHTTP2 :: (MonadUnliftIO m) => (TransportHost, Word16) -> C.KeyHash -> (HTTP2Request -> m ()) -> m () +connectRevHTTP2 serviceAddress fingerprint = connectTLSClient serviceAddress fingerprint . attachHTTP2Server -connectTLSClient :: (MonadUnliftIO m) => TransportHost -> C.KeyHash -> (Transport.TLS -> m a) -> m a -connectTLSClient host caFingerprint = runTransportClient defaultTransportClientConfig Nothing host DISCOVERY_PORT (Just caFingerprint) +connectTLSClient :: (MonadUnliftIO m) => (TransportHost, Word16) -> C.KeyHash -> (Transport.TLS -> m a) -> m a +connectTLSClient (host, port) caFingerprint = runTransportClient defaultTransportClientConfig Nothing host (show port) (Just caFingerprint) attachHTTP2Server :: (MonadUnliftIO m) => (HTTP2Request -> m ()) -> Transport.TLS -> m () attachHTTP2Server processRequest tls = do diff --git a/src/Simplex/Chat/Remote/Multicast.hsc b/src/Simplex/Chat/Remote/Multicast.hsc index ea015c18e3..3919b4423f 100644 --- a/src/Simplex/Chat/Remote/Multicast.hsc +++ b/src/Simplex/Chat/Remote/Multicast.hsc @@ -10,12 +10,15 @@ import Network.Socket NB: Group membership is per-host, not per-process. A socket is only used to access system interface for groups. -} -setMembership :: Socket -> HostAddress -> Bool -> IO Bool +setMembership :: Socket -> HostAddress -> Bool -> IO (Either CInt ()) setMembership sock group membership = allocaBytes #{size struct ip_mreq} $ \mReqPtr -> do #{poke struct ip_mreq, imr_multiaddr} mReqPtr group #{poke struct ip_mreq, imr_interface} mReqPtr (0 :: HostAddress) -- attempt to contact the group on ANY interface - withFdSocket sock $ \fd -> - (/= 0) <$> c_setsockopt fd c_IPPROTO_IP flag (castPtr mReqPtr) (#{size struct ip_mreq}) + withFdSocket sock $ \fd -> do + rc <- c_setsockopt fd c_IPPROTO_IP flag (castPtr mReqPtr) (#{size struct ip_mreq}) + if rc == 0 + then pure $ Right () + else pure $ Left rc where flag = if membership then c_IP_ADD_MEMBERSHIP else c_IP_DROP_MEMBERSHIP diff --git a/src/Simplex/Chat/Remote/Protocol.hs b/src/Simplex/Chat/Remote/Protocol.hs index 2deb177775..45bea60663 100644 --- a/src/Simplex/Chat/Remote/Protocol.hs +++ b/src/Simplex/Chat/Remote/Protocol.hs @@ -66,8 +66,8 @@ $(deriveJSON (taggedObjectJSON $ dropPrefix "RR") ''RemoteResponse) -- * Client side / desktop -createRemoteHostClient :: HTTP2Client -> Text -> ExceptT RemoteProtocolError IO RemoteHostClient -createRemoteHostClient httpClient desktopName = do +createRemoteHostClient :: HTTP2Client -> dh -> Text -> ExceptT RemoteProtocolError IO RemoteHostClient +createRemoteHostClient httpClient todo'dhKey desktopName = do logDebug "Sending initial hello" sendRemoteCommand' httpClient localEncoding Nothing RCHello {deviceName = desktopName} >>= \case RRHello {encoding, deviceName = mobileName, encryptFiles} -> do diff --git a/src/Simplex/Chat/Remote/Types.hs b/src/Simplex/Chat/Remote/Types.hs index 6611d04471..4507c3de79 100644 --- a/src/Simplex/Chat/Remote/Types.hs +++ b/src/Simplex/Chat/Remote/Types.hs @@ -1,18 +1,39 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE GADTs #-} module Simplex.Chat.Remote.Types where import Control.Exception +import Control.Monad +import Crypto.Error (eitherCryptoError) +import qualified Crypto.PubKey.Ed25519 as Ed25519 import qualified Data.Aeson.TH as J +import qualified Data.Attoparsec.ByteString.Char8 as A +import Data.ByteArray (convert) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.Foldable (toList) import Data.Int (Int64) import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8Lenient, encodeUtf8) +import Data.Time.Clock.System (SystemTime) +import Data.Word (Word16) +import Network.HTTP.Types (parseSimpleQuery) +import Network.HTTP.Types.URI (renderSimpleQuery, urlDecode, urlEncode) +import qualified Network.Socket as N import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.File (CryptoFile) -import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client) +import Simplex.Messaging.Encoding (Encoding (..)) +import Simplex.Messaging.Encoding.String (StrEncoding (..)) import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, sumTypeJSON) +import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client) +import Simplex.Messaging.Version (VersionRange, mkVersionRange) import UnliftIO data RemoteHostClient = RemoteHostClient @@ -66,7 +87,6 @@ data RemoteHostInfo = RemoteHostInfo { remoteHostId :: RemoteHostId, storePath :: FilePath, displayName :: Text, - remoteCtrlOOB :: RemoteCtrlOOB, sessionActive :: Bool } deriving (Show) @@ -98,6 +118,161 @@ data RemoteFile = RemoteFile } deriving (Show) +ipProbeVersionRange :: VersionRange +ipProbeVersionRange = mkVersionRange 1 1 + +data IpProbe = IpProbe + { versionRange :: VersionRange, + randomNonce :: ByteString + } deriving (Show) + +instance Encoding IpProbe where + smpEncode IpProbe {versionRange, randomNonce} = smpEncode (versionRange, 'I', randomNonce) + + smpP = IpProbe <$> (smpP <* "I") *> smpP + +announceVersionRange :: VersionRange +announceVersionRange = mkVersionRange 1 1 + +data Announce = Announce + { versionRange :: VersionRange, + sessionStart :: SystemTime, + announceCounter :: Word16, + serviceAddress :: (N.HostAddress, Word16), + caFingerprint :: C.KeyHash, + sessionDH :: C.PublicKeyX25519, + announceKey :: C.PublicKeyEd25519 + } deriving (Show) + +instance Encoding Announce where + smpEncode Announce {versionRange, sessionStart, announceCounter, serviceAddress, caFingerprint, sessionDH, announceKey} = + smpEncode (versionRange, 'A', sessionStart, announceCounter, serviceAddress) + <> smpEncode (caFingerprint, sessionDH, announceKey) + + smpP = Announce <$> (smpP <* "A") <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP + +data SignedAnnounce = SignedAnnounce Announce (C.Signature 'C.Ed25519) + +instance Encoding SignedAnnounce where + smpEncode (SignedAnnounce ann (C.SignatureEd25519 sig)) = smpEncode (ann, convert sig :: ByteString) + + smpP = do + sa <- SignedAnnounce <$> smpP <*> signatureP + unless (verifySignedAnnounce sa) $ fail "bad announce signature" + pure sa + where + signatureP = do + bs <- smpP :: A.Parser ByteString + case eitherCryptoError (Ed25519.signature bs) of + Left ce -> fail $ show ce + Right ok -> pure $ C.SignatureEd25519 ok + +signAnnounce :: C.PrivateKey C.Ed25519 -> Announce -> SignedAnnounce +signAnnounce announceSecret ann = SignedAnnounce ann sig + where + sig = + case C.sign (C.APrivateSignKey C.SEd25519 announceSecret) (smpEncode ann) of + C.ASignature C.SEd25519 s -> s + _ -> error "signing with ed25519" + +verifySignedAnnounce :: SignedAnnounce -> Bool +verifySignedAnnounce (SignedAnnounce ann@Announce {announceKey} sig) = C.verify aKey aSig (smpEncode ann) + where + aKey = C.APublicVerifyKey C.SEd25519 announceKey + aSig = C.ASignature C.SEd25519 sig + +data OOB = OOB + { -- authority part + caFingerprint :: C.KeyHash, + authToken :: Text, + host :: Text, + port :: Word16, + -- query part + version :: VersionRange, -- v= + appName :: Text, -- app= + sigPubKey :: C.PublicKeyEd25519, -- key= + deviceName :: Maybe Text -- device= + } + deriving (Eq, Show) + +instance StrEncoding OOB where + strEncode OOB {caFingerprint, authToken, host, port, version, appName, sigPubKey, deviceName} = + schema <> "://" <> authority <> "#/?" <> renderSimpleQuery False query + where + schema = "xrcp" + authority = + mconcat + [ strEncode caFingerprint, + ":", + encodeUtf8 authToken, + "@", + encodeUtf8 host, + ":", + strEncode port + ] + query = + [ ("v", strEncode version), + ("app", encodeUtf8 appName), + ("key", strEncode $ C.encodePubKey sigPubKey) + ] + ++ [("device", urlEncode True $ encodeUtf8 name) | name <- toList deviceName] + + strP = do + _ <- A.string "xrcp://" + caFingerprint <- strP + _ <- A.char ':' + authToken <- decodeUtf8Lenient <$> A.takeWhile (/= '@') + _ <- A.char '@' + host <- decodeUtf8Lenient <$> A.takeWhile (/= ':') + _ <- A.char ':' + port <- strP + + _ <- A.string "#/?" + q <- parseSimpleQuery <$> A.takeByteString + version <- maybe (fail "missing version") (either fail pure . strDecode) (lookup "v" q) + appName <- maybe (fail "missing appName") (pure . decodeUtf8Lenient) (lookup "app" q) + sigPubKeyB64 <- maybe (fail "missing key") pure (lookup "key" q) + sigPubKey <- either fail pure $ strDecode sigPubKeyB64 >>= C.decodePubKey + let deviceName = fmap (decodeUtf8Lenient . urlDecode True) (lookup "device" q) + pure OOB {caFingerprint, authToken, host, port, version, appName, sigPubKey, deviceName} + +data SignedOOB = SignedOOB OOB (C.Signature 'C.Ed25519) + deriving (Eq, Show) + +instance StrEncoding SignedOOB where + strEncode (SignedOOB oob sig) = strEncode oob <> "&sig=" <> strEncode (C.signatureBytes sig) + + strDecode s = do + unless (B.length sig == sigLen) $ Left "bad size" + unless ("&sig=" `B.isPrefixOf` sig) $ Left "bad signature prefix" + signedOOB <- SignedOOB <$> strDecode oob <*> (strDecode (B.drop 5 sig) >>= C.decodeSignature) + unless (verifySignedOOB signedOOB) $ Left "bad signature" + pure signedOOB + where + l = B.length s + (oob, sig) = B.splitAt (l - sigLen) s + sigLen = 93 -- &sig= + ed25519 sig size in base64 (88) + + -- XXX: strP is used in chat command parser, but default strP assumes bas64url-encoded bytestring, where OOB is an URL-like + strP = A.takeWhile (/= ' ') >>= either fail pure . strDecode + +signOOB :: C.PrivateKey C.Ed25519 -> OOB -> SignedOOB +signOOB key oob = SignedOOB oob sig + where + sig = + case C.sign (C.APrivateSignKey C.SEd25519 key) (strEncode oob) of + C.ASignature C.SEd25519 s -> s + _ -> error "signing with ed25519" + +verifySignedOOB :: SignedOOB -> Bool +verifySignedOOB (SignedOOB oob@OOB {sigPubKey} sig) = C.verify aKey aSig (strEncode oob) + where + aKey = C.APublicVerifyKey C.SEd25519 sigPubKey + aSig = C.ASignature C.SEd25519 sig + +decodeOOBLink :: Text -> Either String OOB +decodeOOBLink = fmap (\(SignedOOB oob _verified) -> oob) . strDecode . encodeUtf8 + data PlatformEncoding = PESwift | PEKotlin @@ -125,8 +300,6 @@ $(J.deriveJSON (sumTypeJSON $ dropPrefix "RPE") ''RemoteProtocolError) $(J.deriveJSON (enumJSON $ dropPrefix "PE") ''PlatformEncoding) -$(J.deriveJSON defaultJSON ''RemoteCtrlOOB) - $(J.deriveJSON defaultJSON ''RemoteHostInfo) $(J.deriveJSON defaultJSON ''RemoteCtrl) diff --git a/src/Simplex/Chat/Store/Remote.hs b/src/Simplex/Chat/Store/Remote.hs index a4c2ef85e1..0dfe665b2f 100644 --- a/src/Simplex/Chat/Store/Remote.hs +++ b/src/Simplex/Chat/Store/Remote.hs @@ -6,13 +6,14 @@ module Simplex.Chat.Store.Remote where import Control.Monad.Except import Data.Int (Int64) +import Data.Maybe (fromMaybe) import Data.Text (Text) import Database.SQLite.Simple (Only (..)) import qualified Database.SQLite.Simple as SQL -import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB -import Simplex.Chat.Store.Shared import Simplex.Chat.Remote.Types +import Simplex.Chat.Store.Shared import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow) +import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB import qualified Simplex.Messaging.Crypto as C insertRemoteHost :: DB.Connection -> FilePath -> Text -> C.APrivateSignKey -> C.SignedCertificate -> IO RemoteHostId @@ -39,8 +40,9 @@ toRemoteHost (remoteHostId, storePath, displayName, caKey, C.SignedObject caCert deleteRemoteHostRecord :: DB.Connection -> RemoteHostId -> IO () deleteRemoteHostRecord db remoteHostId = DB.execute db "DELETE FROM remote_hosts WHERE remote_host_id = ?" (Only remoteHostId) -insertRemoteCtrl :: DB.Connection -> RemoteCtrlOOB -> IO RemoteCtrlInfo -insertRemoteCtrl db RemoteCtrlOOB {fingerprint, displayName} = do +insertRemoteCtrl :: DB.Connection -> SignedOOB -> IO RemoteCtrlInfo +insertRemoteCtrl db (SignedOOB OOB {deviceName, caFingerprint = fingerprint} _) = do + let displayName = fromMaybe "" deviceName DB.execute db "INSERT INTO remote_controllers (display_name, fingerprint) VALUES (?,?)" (displayName, fingerprint) remoteCtrlId <- insertedRowId db pure RemoteCtrlInfo {remoteCtrlId, displayName, fingerprint, accepted = Nothing, sessionActive = False} diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 9ae00159b7..1810b62189 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -269,8 +269,9 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe CRNtfTokenStatus status -> ["device token status: " <> plain (smpEncode status)] CRNtfToken _ status mode -> ["device token status: " <> plain (smpEncode status) <> ", notifications mode: " <> plain (strEncode mode)] CRNtfMessages {} -> [] - CRRemoteHostCreated RemoteHostInfo {remoteHostId, remoteCtrlOOB} -> ("remote host " <> sShow remoteHostId <> " created") : viewRemoteCtrlOOBData remoteCtrlOOB + CRRemoteHostCreated RemoteHostInfo {remoteHostId} -> ["remote host " <> sShow remoteHostId <> " created"] CRRemoteHostList hs -> viewRemoteHosts hs + CRRemoteHostStarted {remoteHost = RemoteHostInfo {remoteHostId = rhId}, sessionOOB} -> ["remote host " <> sShow rhId <> " started", "connection code:", plain sessionOOB] CRRemoteHostConnected RemoteHostInfo {remoteHostId = rhId} -> ["remote host " <> sShow rhId <> " connected"] CRRemoteHostStopped rhId -> ["remote host " <> sShow rhId <> " stopped"] CRRemoteFileStored rhId (CryptoFile filePath cfArgs_) -> @@ -447,7 +448,7 @@ viewGroupSubscribed :: GroupInfo -> [StyledString] viewGroupSubscribed g = [membershipIncognito g <> ttyFullGroup g <> ": connected to server(s)"] showSMPServer :: SMPServer -> String -showSMPServer = B.unpack . strEncode . host +showSMPServer srv = B.unpack $ strEncode srv.host viewHostEvent :: AProtocolType -> TransportHost -> String viewHostEvent p h = map toUpper (B.unpack $ strEncode p) <> " host " <> B.unpack (strEncode h) @@ -1659,10 +1660,6 @@ viewVersionInfo logLevel CoreVersionInfo {version, simplexmqVersion, simplexmqCo where parens s = " (" <> s <> ")" -viewRemoteCtrlOOBData :: RemoteCtrlOOB -> [StyledString] -viewRemoteCtrlOOBData RemoteCtrlOOB {fingerprint} = - ["connection code:", plain $ strEncode fingerprint] - viewRemoteHosts :: [RemoteHostInfo] -> [StyledString] viewRemoteHosts = \case [] -> ["No remote hosts"] diff --git a/tests/RemoteTests.hs b/tests/RemoteTests.hs index be1d3c1a2e..ccbd543e9a 100644 --- a/tests/RemoteTests.hs +++ b/tests/RemoteTests.hs @@ -8,12 +8,12 @@ module RemoteTests where import ChatClient import ChatTests.Utils import Control.Logger.Simple -import Control.Monad 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 Data.String (fromString) import Network.HTTP.Types (ok200) import qualified Network.HTTP2.Client as C import qualified Network.HTTP2.Server as S @@ -23,11 +23,12 @@ 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.Chat.Remote.Discovery as Discovery +import Simplex.Chat.Remote.Types import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.File (CryptoFileArgs (..)) -import Simplex.Messaging.Encoding.String +import Simplex.Messaging.Encoding (smpDecode) +import Simplex.Messaging.Encoding.String (strDecode, strEncode) import qualified Simplex.Messaging.Transport as Transport import Simplex.Messaging.Transport.Client (TransportHost (..)) import Simplex.Messaging.Transport.Credentials (genCredentials, tlsCredentials) @@ -44,6 +45,7 @@ remoteTests :: SpecWith FilePath remoteTests = describe "Remote" $ do it "generates usable credentials" genCredentialsTest it "connects announcer with discoverer over reverse-http2" announceDiscoverHttp2Test + it "OOB encoding, decoding, and signatures are correct" oobCodecTest it "performs protocol handshake" remoteHandshakeTest it "performs protocol handshake (again)" remoteHandshakeTest -- leaking servers regression check it "sends messages" remoteMessageTest @@ -59,8 +61,9 @@ genCredentialsTest _tmp = do started <- newEmptyTMVarIO bracket (Discovery.startTLSServer started credentials serverHandler) cancel $ \_server -> do ok <- atomically (readTMVar started) - unless ok $ error "TLS server failed to start" - Discovery.connectTLSClient "127.0.0.1" fingerprint clientHandler + port <- maybe (error "TLS server failed to start") pure ok + logNote $ "Assigned port: " <> tshow port + Discovery.connectTLSClient ("127.0.0.1", fromIntegral port) fingerprint clientHandler where serverHandler serverTls = do logNote "Sending from server" @@ -75,15 +78,28 @@ genCredentialsTest _tmp = do -- * UDP discovery and rever HTTP2 +oobCodecTest :: (HasCallStack) => FilePath -> IO () +oobCodecTest _tmp = do + subscribers <- newTMVarIO 0 + localAddr <- Discovery.getLocalAddress subscribers >>= maybe (fail "unable to get local address") pure + (fingerprint, _credentials) <- genTestCredentials + (_dhKey, _sigKey, _ann, signedOOB@(SignedOOB oob _sig)) <- Discovery.startSession (Just "Desktop") (localAddr, read Discovery.DISCOVERY_PORT) fingerprint + verifySignedOOB signedOOB `shouldBe` True + strDecode (strEncode oob) `shouldBe` Right oob + strDecode (strEncode signedOOB) `shouldBe` Right signedOOB + announceDiscoverHttp2Test :: (HasCallStack) => FilePath -> IO () announceDiscoverHttp2Test _tmp = do + subscribers <- newTMVarIO 0 + localAddr <- Discovery.getLocalAddress subscribers >>= maybe (fail "unable to get local address") pure (fingerprint, credentials) <- genTestCredentials + (_dhKey, sigKey, ann, _oob) <- Discovery.startSession (Just "Desktop") (localAddr, read Discovery.DISCOVERY_PORT) fingerprint tasks <- newTVarIO [] finished <- newEmptyMVar controller <- async $ do logNote "Controller: starting" bracket - (Discovery.announceRevHTTP2 tasks fingerprint credentials (putMVar finished ()) >>= either (fail . show) pure) + (Discovery.announceRevHTTP2 tasks (sigKey, ann) credentials (putMVar finished ()) >>= either (fail . show) pure) closeHTTP2Client ( \http -> do logNote "Controller: got client" @@ -94,11 +110,14 @@ announceDiscoverHttp2Test _tmp = do Right HTTP2Response {} -> logNote "Controller: got response" ) - host <- async $ Discovery.withListener $ \sock -> do - (N.SockAddrInet _port addr, invite) <- Discovery.recvAnnounce sock - strDecode invite `shouldBe` Right fingerprint - logNote "Host: connecting" - server <- async $ Discovery.connectTLSClient (THIPv4 $ N.hostAddressToTuple addr) fingerprint $ \tls -> do + host <- async $ Discovery.withListener subscribers $ \sock -> do + (N.SockAddrInet _port addr, sigAnn) <- Discovery.recvAnnounce sock + SignedAnnounce Announce {caFingerprint, serviceAddress=(hostAddr, port)} _sig <- either fail pure $ smpDecode sigAnn + caFingerprint `shouldBe` fingerprint + addr `shouldBe` hostAddr + let service = (THIPv4 $ N.hostAddressToTuple hostAddr, port) + logNote $ "Host: connecting to " <> tshow service + server <- async $ Discovery.connectTLSClient service fingerprint $ \tls -> do logNote "Host: got tls" flip Discovery.attachHTTP2Server tls $ \HTTP2Request {sendResponse} -> do logNote "Host: got request" @@ -213,7 +232,7 @@ remoteStoreFileTest = -- 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 <# "/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)" @@ -242,7 +261,7 @@ remoteStoreFileTest = -- 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 <# "/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 [/ | ] to receive it" @@ -372,21 +391,30 @@ remoteCLIFileTest = testChatCfg3 cfg aliceProfile aliceDesktopProfile bobProfile startRemote :: TestCC -> TestCC -> IO () startRemote mobile desktop = do + desktop ##> "/set device name My desktop" + desktop <## "ok" desktop ##> "/create remote host" desktop <## "remote host 1 created" - desktop <## "connection code:" - fingerprint <- getTermLine desktop - + -- A new host is started [automatically] by UI desktop ##> "/start remote host 1" desktop <## "ok" + desktop <## "remote host 1 started" + desktop <## "connection code:" + oobLink <- getTermLine desktop + OOB {caFingerprint = oobFingerprint} <- either (fail . mappend "OOB link failed: ") pure $ decodeOOBLink (fromString oobLink) + -- Desktop displays OOB QR code + mobile ##> "/set device name Mobile" + mobile <## "ok" mobile ##> "/start remote ctrl" mobile <## "ok" mobile <## "remote controller announced" mobile <## "connection code:" - fingerprint' <- getTermLine mobile - fingerprint' `shouldBe` fingerprint - mobile ##> ("/register remote ctrl " <> fingerprint' <> " " <> "My desktop") + annFingerprint <- getTermLine mobile + -- The user scans OOB QR code and confirms it matches the announced stuff + fromString annFingerprint `shouldBe` strEncode oobFingerprint + + mobile ##> ("/register remote ctrl " <> oobLink) mobile <## "remote controller 1 registered" mobile ##> "/accept remote ctrl 1" mobile <## "ok" -- alternative scenario: accepted before controller start