From 02c0cd5619e1683e6cbfc40c1a7ac99f5c6e88de Mon Sep 17 00:00:00 2001 From: Alexander Bondarenko <486682+dpwiz@users.noreply.github.com> Date: Wed, 1 Nov 2023 12:48:58 +0200 Subject: [PATCH] Cut at attaching http server/client (#3299) * Cut at attaching http server/client * switch to xrcp branch --- cabal.project | 2 +- package.yaml | 1 - simplex-chat.cabal | 11 +- src/Simplex/Chat/Controller.hs | 1 + src/Simplex/Chat/Remote.hs | 8 +- src/Simplex/Chat/Remote/Discovery.hs | 236 --------------------------- src/Simplex/Chat/Remote/RevHTTP.hs | 54 ++++++ src/Simplex/Chat/Remote/Types.hs | 219 +++---------------------- src/Simplex/Chat/Store/Remote.hs | 1 + tests/RemoteTests.hs | 72 ++++---- 10 files changed, 121 insertions(+), 484 deletions(-) delete mode 100644 src/Simplex/Chat/Remote/Discovery.hs create mode 100644 src/Simplex/Chat/Remote/RevHTTP.hs diff --git a/cabal.project b/cabal.project index 9522fe2337..b693f6c88f 100644 --- a/cabal.project +++ b/cabal.project @@ -9,7 +9,7 @@ constraints: zip +disable-bzip2 +disable-zstd source-repository-package type: git location: https://github.com/simplex-chat/simplexmq.git - tag: 0410948b56ea630dfa86441bbcf8ec97aeb1df01 + tag: db1b2f77cd1c172fab26b68c507cdd2c1b7b0e63 source-repository-package type: git diff --git a/package.yaml b/package.yaml index 095d2c1342..2bfb36d18d 100644 --- a/package.yaml +++ b/package.yaml @@ -36,7 +36,6 @@ dependencies: - 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.* - random >= 1.1 && < 1.3 diff --git a/simplex-chat.cabal b/simplex-chat.cabal index db03249312..2dc77c3c22 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.2. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack @@ -130,9 +130,9 @@ library Simplex.Chat.ProfileGenerator Simplex.Chat.Protocol Simplex.Chat.Remote - Simplex.Chat.Remote.Discovery Simplex.Chat.Remote.Multicast Simplex.Chat.Remote.Protocol + Simplex.Chat.Remote.RevHTTP Simplex.Chat.Remote.Transport Simplex.Chat.Remote.Types Simplex.Chat.Store @@ -184,7 +184,6 @@ library , 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.* , random >=1.1 && <1.3 @@ -237,7 +236,6 @@ executable simplex-bot , 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.* , random >=1.1 && <1.3 @@ -291,7 +289,6 @@ executable simplex-bot-advanced , 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.* , random >=1.1 && <1.3 @@ -347,7 +344,6 @@ executable simplex-broadcast-bot , 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.* , random >=1.1 && <1.3 @@ -402,7 +398,6 @@ executable simplex-chat , mtl ==2.3.* , network ==3.1.* , network-transport ==0.5.6 - , network-udp ==0.0.* , optparse-applicative >=0.15 && <0.17 , process ==1.6.* , random >=1.1 && <1.3 @@ -461,7 +456,6 @@ executable simplex-directory-service , 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.* , random >=1.1 && <1.3 @@ -546,7 +540,6 @@ test-suite simplex-chat-test , mtl ==2.3.* , network ==3.1.* , network-transport ==0.5.6 - , network-udp ==0.0.* , optparse-applicative >=0.15 && <0.17 , process ==1.6.* , random >=1.1 && <1.3 diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index a54c6320e8..25fe9294c6 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -73,6 +73,7 @@ import Simplex.Messaging.Transport (simplexMQVersion) import Simplex.Messaging.Transport.Client (TransportHost) import Simplex.Messaging.Util (allFinally, catchAllErrors, liftEitherError, tryAllErrors, (<$$>)) import Simplex.Messaging.Version +import Simplex.RemoteControl.Types import System.IO (Handle) import System.Mem.Weak (Weak) import UnliftIO.STM diff --git a/src/Simplex/Chat/Remote.hs b/src/Simplex/Chat/Remote.hs index d6ccd25961..cc3eb9f199 100644 --- a/src/Simplex/Chat/Remote.hs +++ b/src/Simplex/Chat/Remote.hs @@ -40,8 +40,8 @@ import Simplex.Chat.Archive (archiveFilesFolder) import Simplex.Chat.Controller import Simplex.Chat.Files import Simplex.Chat.Messages (chatNameStr) -import qualified Simplex.Chat.Remote.Discovery as Discovery import Simplex.Chat.Remote.Protocol +import Simplex.Chat.Remote.RevHTTP (announceRevHTTP2, connectRevHTTP2) import Simplex.Chat.Remote.Transport import Simplex.Chat.Remote.Types import Simplex.Chat.Store.Files @@ -61,6 +61,8 @@ import Simplex.Messaging.Transport.Credentials (genCredentials, tlsCredentials) import Simplex.Messaging.Transport.HTTP2.File (hSendFile) import Simplex.Messaging.Transport.HTTP2.Server (HTTP2Request (..)) import Simplex.Messaging.Util (ifM, liftEitherError, liftEitherWith, liftError, liftIOEither, tryAllErrors, tshow, ($>>=), (<$$>)) +import qualified Simplex.RemoteControl.Discovery as Discovery +import Simplex.RemoteControl.Types import System.FilePath (takeFileName, ()) import UnliftIO import UnliftIO.Directory (copyFile, createDirectoryIfMissing, renameFile) @@ -113,7 +115,7 @@ startRemoteHost rhId = do 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 + httpClient <- liftEitherError (ChatErrorRemoteCtrl . RCEHTTP2Error . show) $ 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 dhKey rcName @@ -269,7 +271,7 @@ runHost discovered accepted handleHttp = do 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 serviceAddress fingerprint handleHttp -- spawn server for remote protocol commands + server <- async $ 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 diff --git a/src/Simplex/Chat/Remote/Discovery.hs b/src/Simplex/Chat/Remote/Discovery.hs deleted file mode 100644 index 1ede108b07..0000000000 --- a/src/Simplex/Chat/Remote/Discovery.hs +++ /dev/null @@ -1,236 +0,0 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} - -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 -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 -import Simplex.Messaging.Transport.Client (TransportHost (..), defaultTransportClientConfig, runTransportClient) -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, runTransportServerSocket, startTCPServer) -import Simplex.Messaging.Util (ifM, tshow) -import Simplex.Messaging.Version (mkVersionRange) -import UnliftIO -import UnliftIO.Concurrent - --- | mDNS multicast group -pattern MULTICAST_ADDR_V4 :: (IsString a, Eq a) => a -pattern MULTICAST_ADDR_V4 = "224.0.0.251" - -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 = "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 :: 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 $ 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 " <> ident - cancel announcer - runHTTP2Client finished httpClient tls `catchAny` (logError . tshow) - 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 " <> ident - readMVar httpClient - where - ident = decodeUtf8 $ strEncode caFingerprint - --- | 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 - -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 - { TLS.serverWantClientCert = False, - TLS.serverShared = def {TLS.sharedCredentials = credentials}, - TLS.serverHooks = def, - TLS.serverSupported = supportedParameters - } - --- | 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 = - ifM (isEmptyMVar clientVar) - attachClient - (logError "HTTP2 session already started on this listener") - where - attachClient = do - client <- attachHTTP2Client config ANY_ADDR_V4 DISCOVERY_PORT (putMVar finishedVar ()) defaultHTTP2BufferSize tls - putMVar clientVar client - readMVar finishedVar - -- TODO connection timeout - config = defaultHTTP2ClientConfig {bodyHeadSize = doNotPrefetchHead, connTimeout = maxBound} - -withSender :: MonadUnliftIO m => (UDP.UDPSocket -> m a) -> m a -withSender = bracket (liftIO $ UDP.clientSocket MULTICAST_ADDR_V4 DISCOVERY_PORT False) (liftIO . UDP.close) - -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 - joinMulticast subscribers raw (listenerHostAddr4 sock) - pure sock - -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 - N.SockAddrInet _port host -> host - _ -> error "MULTICAST_ADDR_V4 is V4" - -recvAnnounce :: (MonadIO m) => UDP.ListenSocket -> m (N.SockAddr, ByteString) -recvAnnounce sock = liftIO $ do - (invite, UDP.ClientSockAddr source _cmsg) <- UDP.recvFrom sock - pure (source, invite) - -connectRevHTTP2 :: (MonadUnliftIO m) => (TransportHost, Word16) -> C.KeyHash -> (HTTP2Request -> m ()) -> m () -connectRevHTTP2 serviceAddress fingerprint = connectTLSClient serviceAddress fingerprint . attachHTTP2Server - -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 - withRunInIO $ \unlift -> - runHTTP2ServerWith defaultHTTP2BufferSize ($ tls) $ \sessionId r sendResponse -> do - 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 diff --git a/src/Simplex/Chat/Remote/RevHTTP.hs b/src/Simplex/Chat/Remote/RevHTTP.hs new file mode 100644 index 0000000000..c6c777596a --- /dev/null +++ b/src/Simplex/Chat/Remote/RevHTTP.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Simplex.Chat.Remote.RevHTTP where + +import Simplex.RemoteControl.Discovery +import Simplex.RemoteControl.Types +import Control.Logger.Simple +import Data.Word (Word16) +import qualified Network.TLS as TLS +import qualified Simplex.Messaging.Crypto as C +import qualified Simplex.Messaging.Transport as Transport +import Simplex.Messaging.Transport.Client (TransportHost (..)) +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.Util (ifM) +import UnliftIO + +announceRevHTTP2 :: MonadUnliftIO m => Tasks -> (C.PrivateKeyEd25519, Announce) -> TLS.Credentials -> m () -> m (Either HTTP2ClientError HTTP2Client) +announceRevHTTP2 = announceCtrl runHTTP2Client + +-- | 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 = + ifM (isEmptyMVar clientVar) + attachClient + (logError "HTTP2 session already started on this listener") + where + attachClient = do + client <- attachHTTP2Client config ANY_ADDR_V4 DISCOVERY_PORT (putMVar finishedVar ()) defaultHTTP2BufferSize tls + putMVar clientVar client + readMVar finishedVar + -- TODO connection timeout + config = defaultHTTP2ClientConfig {bodyHeadSize = doNotPrefetchHead, connTimeout = maxBound} + +connectRevHTTP2 :: (MonadUnliftIO m) => (TransportHost, Word16) -> C.KeyHash -> (HTTP2Request -> m ()) -> m () +connectRevHTTP2 serviceAddress fingerprint = connectTLSClient serviceAddress fingerprint . attachHTTP2Server + +attachHTTP2Server :: (MonadUnliftIO m) => (HTTP2Request -> m ()) -> Transport.TLS -> m () +attachHTTP2Server processRequest tls = do + withRunInIO $ \unlift -> + runHTTP2ServerWith defaultHTTP2BufferSize ($ tls) $ \sessionId r sendResponse -> do + 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 diff --git a/src/Simplex/Chat/Remote/Types.hs b/src/Simplex/Chat/Remote/Types.hs index 4507c3de79..dcf70ab714 100644 --- a/src/Simplex/Chat/Remote/Types.hs +++ b/src/Simplex/Chat/Remote/Types.hs @@ -2,39 +2,22 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} {-# 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 Control.Exception (Exception) 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.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 +import Simplex.RemoteControl.Types (Tasks) +import Simplex.Messaging.Crypto.File (CryptoFile) data RemoteHostClient = RemoteHostClient { hostEncoding :: PlatformEncoding, @@ -50,15 +33,19 @@ data RemoteHostSession = RemoteHostSession } data RemoteProtocolError - = RPEInvalidSize -- ^ size prefix is malformed - | RPEInvalidJSON {invalidJSON :: Text} -- ^ failed to parse RemoteCommand or RemoteResponse + = -- | size prefix is malformed + RPEInvalidSize + | -- | failed to parse RemoteCommand or RemoteResponse + RPEInvalidJSON {invalidJSON :: Text} | RPEIncompatibleEncoding | RPEUnexpectedFile | RPENoFile | RPEFileSize | RPEFileDigest - | RPEUnexpectedResponse {response :: Text} -- ^ Wrong response received for the command sent - | RPEStoredFileExists -- ^ A file already exists in the destination position + | -- | Wrong response received for the command sent + RPEUnexpectedResponse {response :: Text} + | -- | A file already exists in the destination position + RPEStoredFileExists | RPEHTTP2 {http2Error :: Text} | RPEException {someException :: Text} deriving (Show, Exception) @@ -110,169 +97,6 @@ data RemoteCtrlInfo = RemoteCtrlInfo } deriving (Show) -data RemoteFile = RemoteFile - { userId :: Int64, - fileId :: Int64, - sent :: Bool, - fileSource :: CryptoFile - } - 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 @@ -285,16 +109,15 @@ localEncoding = PESwift localEncoding = PEKotlin #endif -type Tasks = TVar [Async ()] +data RemoteFile = RemoteFile + { userId :: Int64, + fileId :: Int64, + sent :: Bool, + fileSource :: CryptoFile + } + deriving (Show) -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 defaultJSON ''RemoteFile) $(J.deriveJSON (sumTypeJSON $ dropPrefix "RPE") ''RemoteProtocolError) @@ -305,5 +128,3 @@ $(J.deriveJSON defaultJSON ''RemoteHostInfo) $(J.deriveJSON defaultJSON ''RemoteCtrl) $(J.deriveJSON defaultJSON ''RemoteCtrlInfo) - -$(J.deriveJSON defaultJSON ''RemoteFile) diff --git a/src/Simplex/Chat/Store/Remote.hs b/src/Simplex/Chat/Store/Remote.hs index 0dfe665b2f..df7ccd499b 100644 --- a/src/Simplex/Chat/Store/Remote.hs +++ b/src/Simplex/Chat/Store/Remote.hs @@ -15,6 +15,7 @@ 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 +import Simplex.RemoteControl.Types insertRemoteHost :: DB.Connection -> FilePath -> Text -> C.APrivateSignKey -> C.SignedCertificate -> IO RemoteHostId insertRemoteHost db storePath displayName caKey caCert = do diff --git a/tests/RemoteTests.hs b/tests/RemoteTests.hs index ccbd543e9a..7c62333d66 100644 --- a/tests/RemoteTests.hs +++ b/tests/RemoteTests.hs @@ -5,6 +5,9 @@ module RemoteTests where +import Simplex.Chat.Remote.RevHTTP +import qualified Simplex.RemoteControl.Discovery as Discovery +import Simplex.RemoteControl.Types import ChatClient import ChatTests.Utils import Control.Logger.Simple @@ -23,13 +26,11 @@ import Simplex.Chat.Archive (archiveFilesFolder) import Simplex.Chat.Controller (ChatConfig (..), XFTPFileConfig (..)) import qualified Simplex.Chat.Controller as Controller import Simplex.Chat.Mobile.File -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 (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) import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Response (..), closeHTTP2Client, sendRequest) @@ -43,9 +44,9 @@ import UnliftIO.Directory remoteTests :: SpecWith FilePath remoteTests = describe "Remote" $ do - it "generates usable credentials" genCredentialsTest + -- it "generates usable credentials" genCredentialsTest + -- it "OOB encoding, decoding, and signatures are correct" oobCodecTest 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 @@ -55,38 +56,39 @@ remoteTests = describe "Remote" $ do -- * Low-level TLS with ephemeral credentials -genCredentialsTest :: (HasCallStack) => FilePath -> IO () -genCredentialsTest _tmp = do - (fingerprint, credentials) <- genTestCredentials - started <- newEmptyTMVarIO - bracket (Discovery.startTLSServer started credentials serverHandler) cancel $ \_server -> do - ok <- atomically (readTMVar started) - 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" - Transport.putLn serverTls "hi client" - logNote "Reading from server" - Transport.getLn serverTls `shouldReturn` "hi server" - clientHandler clientTls = do - logNote "Sending from client" - Transport.putLn clientTls "hi server" - logNote "Reading from client" - Transport.getLn clientTls `shouldReturn` "hi client" +-- -- XXX: extract +-- genCredentialsTest :: (HasCallStack) => FilePath -> IO () +-- genCredentialsTest _tmp = do +-- (fingerprint, credentials) <- genTestCredentials +-- started <- newEmptyTMVarIO +-- bracket (startTLSServer started credentials serverHandler) cancel $ \_server -> do +-- ok <- atomically (readTMVar started) +-- port <- maybe (error "TLS server failed to start") pure ok +-- logNote $ "Assigned port: " <> tshow port +-- connectTLSClient ("127.0.0.1", fromIntegral port) fingerprint clientHandler +-- where +-- serverHandler serverTls = do +-- logNote "Sending from server" +-- Transport.putLn serverTls "hi client" +-- logNote "Reading from server" +-- Transport.getLn serverTls `shouldReturn` "hi server" +-- clientHandler clientTls = do +-- logNote "Sending from client" +-- Transport.putLn clientTls "hi server" +-- logNote "Reading from client" +-- Transport.getLn clientTls `shouldReturn` "hi client" -- * 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 +-- 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 @@ -99,7 +101,7 @@ announceDiscoverHttp2Test _tmp = do controller <- async $ do logNote "Controller: starting" bracket - (Discovery.announceRevHTTP2 tasks (sigKey, ann) credentials (putMVar finished ()) >>= either (fail . show) pure) + (announceRevHTTP2 tasks (sigKey, ann) credentials (putMVar finished ()) >>= either (fail . show) pure) closeHTTP2Client ( \http -> do logNote "Controller: got client" @@ -119,7 +121,7 @@ announceDiscoverHttp2Test _tmp = do 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 + flip attachHTTP2Server tls $ \HTTP2Request {sendResponse} -> do logNote "Host: got request" sendResponse $ S.responseNoBody ok200 [] logNote "Host: sent response"