android-apps-mirrors/SimpleX-Chat
0
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2025-06-28 20:29:53 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

Cut at attaching http server/client (#3299)

Browse source 
* Cut at attaching http server/client

* switch to xrcp branch
This commit is contained in:
Alexander Bondarenko 2023-11-01 12:48:58 +02:00 • committed by GitHub
parent b1fdc936a6
commit 02c0cd5619
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
10 changed files with 121 additions and 484 deletions
Download patch file Download diff file Expand all files Collapse all files

2
cabal.project
View file

@ -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

1
package.yaml
View file

@ -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

11
simplex-chat.cabal
View file

@ -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

1
src/Simplex/Chat/Controller.hs
View file

@ -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

8
src/Simplex/Chat/Remote.hs
View file

@ -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

236
src/Simplex/Chat/Remote/Discovery.hs
View file

@ -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

54
src/Simplex/Chat/Remote/RevHTTP.hs Normal file
View file

@ -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

219
src/Simplex/Chat/Remote/Types.hs
View file

@ -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)

1
src/Simplex/Chat/Store/Remote.hs
View file

@ -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

72
tests/RemoteTests.hs
View file

@ -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"