IntenseFinance/simplex-chat
3
0 Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

implement some of the robust discovery rfc (#3283)

Browse Source 
* implement robust discovery

* remove qualified

---------

Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
This commit is contained in:
Alexander BondarenkoandEvgeny Poberezkin authored and GitHub committed 2023-10-30 14:00:54 +00:00
1 parent b48690dee6
commit be44632b0b
10 files changed
+427 -147
Download Patch File Download Diff File Expand all files Collapse all files

No files matched your search

src/Simplex/Chat.hs
+4 -2
View File
@@ -213,6 +213,7 @@ newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agen
rcvFiles <- newTVarIO M.empty rcvFiles <- newTVarIO M.empty
currentCalls <- atomically TM.empty currentCalls <- atomically TM.empty
localDeviceName <- newTVarIO "" -- TODO set in config localDeviceName <- newTVarIO "" -- TODO set in config
multicastSubscribers <- newTMVarIO 0
remoteHostSessions <- atomically TM.empty remoteHostSessions <- atomically TM.empty
remoteHostsFolder <- newTVarIO Nothing remoteHostsFolder <- newTVarIO Nothing
remoteCtrlSession <- newTVarIO Nothing remoteCtrlSession <- newTVarIO Nothing
@@ -247,6 +248,7 @@ newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agen
rcvFiles, rcvFiles,
currentCalls, currentCalls,
localDeviceName, localDeviceName,
multicastSubscribers,
remoteHostSessions, remoteHostSessions,
remoteHostsFolder, remoteHostsFolder,
remoteCtrlSession, remoteCtrlSession,
@@ -5861,8 +5863,8 @@ chatCommandP =
"/store remote file " *> (StoreRemoteFile <$> A.decimal <*> optional (" encrypt=" *> onOffP) <* A.space <*> filePath), "/store remote file " *> (StoreRemoteFile <$> A.decimal <*> optional (" encrypt=" *> onOffP) <* A.space <*> filePath),
"/get remote file " *> (GetRemoteFile <$> A.decimal <* A.space <*> jsonP), "/get remote file " *> (GetRemoteFile <$> A.decimal <* A.space <*> jsonP),
"/start remote ctrl" $> StartRemoteCtrl, "/start remote ctrl" $> StartRemoteCtrl,
"/register remote ctrl " *> (RegisterRemoteCtrl <$> (RemoteCtrlOOB <$> strP <* A.space <*> textP)), "/register remote ctrl " *> (RegisterRemoteCtrl <$> strP),
"/_register remote ctrl " *> (RegisterRemoteCtrl <$> jsonP), -- "/_register remote ctrl " *> (RegisterRemoteCtrl <$> jsonP),
"/list remote ctrls" $> ListRemoteCtrls, "/list remote ctrls" $> ListRemoteCtrls,
"/accept remote ctrl " *> (AcceptRemoteCtrl <$> A.decimal), "/accept remote ctrl " *> (AcceptRemoteCtrl <$> A.decimal),
"/reject remote ctrl " *> (RejectRemoteCtrl <$> A.decimal), "/reject remote ctrl " *> (RejectRemoteCtrl <$> A.decimal),
src/Simplex/Chat/Controller.hs
+7 -4
View File
@@ -25,7 +25,7 @@ import Control.Monad.Reader
import Crypto.Random (ChaChaDRG) import Crypto.Random (ChaChaDRG)
import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.:?)) import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.:?))
import qualified Data.Aeson as J 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.Aeson.Types as JT
import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.ByteString.Char8 (ByteString) import Data.ByteString.Char8 (ByteString)
@@ -40,6 +40,7 @@ import Data.String
import Data.Text (Text) import Data.Text (Text)
import Data.Time (NominalDiffTime, UTCTime) import Data.Time (NominalDiffTime, UTCTime)
import Data.Version (showVersion) import Data.Version (showVersion)
import Data.Word (Word16)
import Language.Haskell.TH (Exp, Q, runIO) import Language.Haskell.TH (Exp, Q, runIO)
import Numeric.Natural import Numeric.Natural
import qualified Paths_simplex_chat as SC import qualified Paths_simplex_chat as SC
@@ -177,6 +178,7 @@ data ChatController = ChatController
rcvFiles :: TVar (Map Int64 Handle), rcvFiles :: TVar (Map Int64 Handle),
currentCalls :: TMap ContactId Call, currentCalls :: TMap ContactId Call,
localDeviceName :: TVar Text, localDeviceName :: TVar Text,
multicastSubscribers :: TMVar Int,
remoteHostSessions :: TMap RemoteHostId RemoteHostSession, -- All the active remote hosts remoteHostSessions :: TMap RemoteHostId RemoteHostSession, -- All the active remote hosts
remoteHostsFolder :: TVar (Maybe FilePath), -- folder for remote hosts data remoteHostsFolder :: TVar (Maybe FilePath), -- folder for remote hosts data
remoteCtrlSession :: TVar (Maybe RemoteCtrlSession), -- Supervisor process for hosted controllers remoteCtrlSession :: TVar (Maybe RemoteCtrlSession), -- Supervisor process for hosted controllers
@@ -424,12 +426,12 @@ data ChatCommand
| StoreRemoteFile {remoteHostId :: RemoteHostId, storeEncrypted :: Maybe Bool, localPath :: FilePath} | StoreRemoteFile {remoteHostId :: RemoteHostId, storeEncrypted :: Maybe Bool, localPath :: FilePath}
| GetRemoteFile {remoteHostId :: RemoteHostId, file :: RemoteFile} | GetRemoteFile {remoteHostId :: RemoteHostId, file :: RemoteFile}
| StartRemoteCtrl -- ^ Start listening for announcements from all registered controllers | 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 | ListRemoteCtrls
| AcceptRemoteCtrl RemoteCtrlId -- ^ Accept discovered data and store confirmation | AcceptRemoteCtrl RemoteCtrlId -- ^ Accept discovered data and store confirmation
| RejectRemoteCtrl RemoteCtrlId -- ^ Reject and blacklist discovered data | RejectRemoteCtrl RemoteCtrlId -- ^ Reject and blacklist discovered data
| StopRemoteCtrl -- ^ Stop listening for announcements or terminate an active session | 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 | QuitChat
| ShowVersion | ShowVersion
| DebugLocks | DebugLocks
@@ -634,6 +636,7 @@ data ChatResponse
| CRContactConnectionDeleted {user :: User, connection :: PendingContactConnection} | CRContactConnectionDeleted {user :: User, connection :: PendingContactConnection}
| CRRemoteHostCreated {remoteHost :: RemoteHostInfo} | CRRemoteHostCreated {remoteHost :: RemoteHostInfo}
| CRRemoteHostList {remoteHosts :: [RemoteHostInfo]} | CRRemoteHostList {remoteHosts :: [RemoteHostInfo]}
| CRRemoteHostStarted {remoteHost :: RemoteHostInfo, sessionOOB :: Text}
| CRRemoteHostConnected {remoteHost :: RemoteHostInfo} | CRRemoteHostConnected {remoteHost :: RemoteHostInfo}
| CRRemoteHostStopped {remoteHostId :: RemoteHostId} | CRRemoteHostStopped {remoteHostId :: RemoteHostId}
| CRRemoteFileStored {remoteHostId :: RemoteHostId, remoteFileSource :: CryptoFile} | CRRemoteFileStored {remoteHostId :: RemoteHostId, remoteFileSource :: CryptoFile}
@@ -1069,7 +1072,7 @@ data RemoteCtrlSession = RemoteCtrlSession
discoverer :: Async (), discoverer :: Async (),
supervisor :: Async (), supervisor :: Async (),
hostServer :: Maybe (Async ()), hostServer :: Maybe (Async ()),
discovered :: TMap C.KeyHash TransportHost, discovered :: TMap C.KeyHash (TransportHost, Word16),
accepted :: TMVar RemoteCtrlId, accepted :: TMVar RemoteCtrlId,
remoteOutputQ :: TBQueue ChatResponse remoteOutputQ :: TBQueue ChatResponse
} }
src/Simplex/Chat/Remote.hs
+45 -41
View File
@@ -12,6 +12,7 @@
module Simplex.Chat.Remote where module Simplex.Chat.Remote where
import Control.Applicative ((<|>))
import Control.Logger.Simple import Control.Logger.Simple
import Control.Monad import Control.Monad
import Control.Monad.Except import Control.Monad.Except
@@ -24,15 +25,16 @@ import Data.ByteString (ByteString)
import qualified Data.ByteString.Base64.URL as B64U import qualified Data.ByteString.Base64.URL as B64U
import Data.ByteString.Builder (Builder) import Data.ByteString.Builder (Builder)
import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Char8 as B
import Data.Functor (($>))
import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8) import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Data.Word (Word32) import Data.Word (Word16, Word32)
import Network.HTTP2.Server (responseStreaming)
import qualified Network.HTTP.Types as N import qualified Network.HTTP.Types as N
import Network.HTTP2.Server (responseStreaming)
import Network.Socket (SockAddr (..), hostAddressToTuple) import Network.Socket (SockAddr (..), hostAddressToTuple)
import Simplex.Chat.Archive (archiveFilesFolder) import Simplex.Chat.Archive (archiveFilesFolder)
import Simplex.Chat.Controller import Simplex.Chat.Controller
@@ -51,18 +53,17 @@ import Simplex.FileTransfer.Description (FileDigest (..))
import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..)) import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
import qualified Simplex.Messaging.Crypto.File as CF import qualified Simplex.Messaging.Crypto.File as CF
import Simplex.Messaging.Encoding (smpDecode)
import Simplex.Messaging.Encoding.String (StrEncoding (..)) import Simplex.Messaging.Encoding.String (StrEncoding (..))
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport.Client (TransportHost (..)) import Simplex.Messaging.Transport.Client (TransportHost (..))
import Simplex.Messaging.Transport.Credentials (genCredentials, tlsCredentials) import Simplex.Messaging.Transport.Credentials (genCredentials, tlsCredentials)
import Simplex.Messaging.Transport.HTTP2.File (hSendFile) import Simplex.Messaging.Transport.HTTP2.File (hSendFile)
import Simplex.Messaging.Transport.HTTP2.Server (HTTP2Request (..)) 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 Simplex.Messaging.Util (ifM, liftEitherError, liftEitherWith, liftError, liftIOEither, tryAllErrors, tshow, ($>>=), (<$$>))
import System.FilePath ((</>), takeFileName) import System.FilePath (takeFileName, (</>))
import UnliftIO import UnliftIO
import UnliftIO.Directory (copyFile, createDirectoryIfMissing, renameFile) import UnliftIO.Directory (copyFile, createDirectoryIfMissing, renameFile)
import Data.Functor (($>))
import Control.Applicative ((<|>))
-- * Desktop side -- * Desktop side
@@ -108,11 +109,14 @@ startRemoteHost rhId = do
toView (CRRemoteHostStopped rhId) -- only signal "stopped" when the session is unregistered cleanly toView (CRRemoteHostStopped rhId) -- only signal "stopped" when the session is unregistered cleanly
-- block until some client is connected or an error happens -- block until some client is connected or an error happens
logInfo $ "Remote host session connecting for " <> tshow rhId 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 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 -- test connection and establish a protocol layer
remoteHostClient <- liftRH rhId $ createRemoteHostClient httpClient rcName remoteHostClient <- liftRH rhId $ createRemoteHostClient httpClient dhKey rcName
-- set up message polling -- set up message polling
oq <- asks outputQ oq <- asks outputQ
asyncRegistered tasks . forever $ do asyncRegistered tasks . forever $ do
@@ -125,7 +129,6 @@ startRemoteHost rhId = do
{ remoteHostId = rhId, { remoteHostId = rhId,
storePath = storePath, storePath = storePath,
displayName = hostDeviceName remoteHostClient, displayName = hostDeviceName remoteHostClient,
remoteCtrlOOB = RemoteCtrlOOB {fingerprint, displayName=rcName},
sessionActive = True sessionActive = True
} }
@@ -159,10 +162,9 @@ createRemoteHost = do
((_, caKey), caCert) <- liftIO $ genCredentials Nothing (-25, 24 * 365) "Host" ((_, caKey), caCert) <- liftIO $ genCredentials Nothing (-25, 24 * 365) "Host"
storePath <- liftIO randomStorePath storePath <- liftIO randomStorePath
let remoteName = "" -- will be passed from remote host in hello let remoteName = "" -- will be passed from remote host in hello
remoteHostId <- withStore' $ \db -> insertRemoteHost db storePath remoteName caKey caCert rhId <- withStore' $ \db -> insertRemoteHost db storePath remoteName caKey caCert
localName <- chatReadVar localDeviceName rh <- withStore $ \db -> getRemoteHost db rhId
let remoteCtrlOOB = RemoteCtrlOOB {fingerprint = C.certificateFingerprint caCert, displayName = localName} pure $ remoteHostInfo rh False
pure RemoteHostInfo {remoteHostId, storePath, displayName = remoteName, remoteCtrlOOB, sessionActive = False}
-- | Generate a random 16-char filepath without / in it by using base64url encoding. -- | Generate a random 16-char filepath without / in it by using base64url encoding.
randomStorePath :: IO FilePath randomStorePath :: IO FilePath
@@ -171,16 +173,14 @@ randomStorePath = B.unpack . B64U.encode <$> getRandomBytes 12
listRemoteHosts :: ChatMonad m => m [RemoteHostInfo] listRemoteHosts :: ChatMonad m => m [RemoteHostInfo]
listRemoteHosts = do listRemoteHosts = do
active <- chatReadVar remoteHostSessions active <- chatReadVar remoteHostSessions
rcName <- chatReadVar localDeviceName map (rhInfo active) <$> withStore' getRemoteHosts
map (rhInfo active rcName) <$> withStore' getRemoteHosts
where where
rhInfo active rcName rh@RemoteHost {remoteHostId} = rhInfo active rh@RemoteHost {remoteHostId} =
remoteHostInfo rh (M.member remoteHostId active) rcName remoteHostInfo rh (M.member remoteHostId active)
remoteHostInfo :: RemoteHost -> Bool -> Text -> RemoteHostInfo remoteHostInfo :: RemoteHost -> Bool -> RemoteHostInfo
remoteHostInfo RemoteHost {remoteHostId, storePath, displayName, caCert} sessionActive rcName = remoteHostInfo RemoteHost {remoteHostId, storePath, displayName} sessionActive =
let remoteCtrlOOB = RemoteCtrlOOB {fingerprint = C.certificateFingerprint caCert, displayName = rcName} RemoteHostInfo {remoteHostId, storePath, displayName, sessionActive}
in RemoteHostInfo {remoteHostId, storePath, displayName, remoteCtrlOOB, sessionActive}
deleteRemoteHost :: ChatMonad m => RemoteHostId -> m () deleteRemoteHost :: ChatMonad m => RemoteHostId -> m ()
deleteRemoteHost rhId = do deleteRemoteHost rhId = do
@@ -262,14 +262,14 @@ startRemoteCtrl execChatCommand = do
chatWriteVar remoteCtrlSession $ Just RemoteCtrlSession {discoverer, supervisor, hostServer = Nothing, discovered, accepted, remoteOutputQ} 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 -- | 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 runHost discovered accepted handleHttp = do
remoteCtrlId <- atomically (readTMVar accepted) -- wait for ??? remoteCtrlId <- atomically (readTMVar accepted) -- wait for ???
rc@RemoteCtrl {fingerprint} <- withStore (`getRemoteCtrl` remoteCtrlId) 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 toView $ CRRemoteCtrlConnecting $ remoteCtrlInfo rc False
atomically $ writeTVar discovered mempty -- flush unused sources 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} chatModifyVar remoteCtrlSession $ fmap $ \s -> s {hostServer = Just server}
toView $ CRRemoteCtrlConnected $ remoteCtrlInfo rc True toView $ CRRemoteCtrlConnected $ remoteCtrlInfo rc True
_ <- waitCatch server -- wait for the server to finish _ <- 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 -> withFile path ReadMode $ \h ->
reply RRFile {fileSize, fileDigest} $ \send -> hSendFile h send fileSize reply RRFile {fileSize, fileDigest} $ \send -> hSendFile h send fileSize
discoverRemoteCtrls :: ChatMonad m => TM.TMap C.KeyHash TransportHost -> m () discoverRemoteCtrls :: ChatMonad m => TM.TMap C.KeyHash (TransportHost, Word16) -> m ()
discoverRemoteCtrls discovered = Discovery.withListener $ receive >=> process discoverRemoteCtrls discovered = do
subscribers <- asks multicastSubscribers
Discovery.withListener subscribers run
where where
-- TODO how would it receive more than one fingerprint? run sock = receive sock >>= process sock
receive sock = receive sock =
Discovery.recvAnnounce sock >>= \case Discovery.recvAnnounce sock >>= \case
(SockAddrInet _sockPort sockAddr, invite) -> case strDecode invite of (SockAddrInet _sockPort sockAddr, sigAnnBytes) -> case smpDecode sigAnnBytes of
-- TODO it is probably better to report errors to view here Right (SignedAnnounce ann _sig) -> pure (sockAddr, ann)
Left _ -> receive sock Left _ -> receive sock -- TODO it is probably better to report errors to view here
Right fingerprint -> pure (sockAddr, fingerprint)
_nonV4 -> receive sock _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) let addr = THIPv4 (hostAddressToTuple sockAddr)
ifM ifM
(atomically $ TM.member fingerprint discovered) (atomically $ TM.member caFingerprint discovered)
(logDebug $ "Fingerprint already known: " <> tshow (addr, fingerprint)) (logDebug $ "Fingerprint already known: " <> tshow (addr, caFingerprint))
( do ( do
logInfo $ "New fingerprint announced: " <> tshow (addr, fingerprint) logInfo $ "New fingerprint announced: " <> tshow (addr, caFingerprint)
atomically $ TM.insert fingerprint addr discovered 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, -- 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 -- so UI now will have to check for duplicates again
withStore' (`getRemoteCtrlByFingerprint` fingerprint) >>= \case withStore' (`getRemoteCtrlByFingerprint` caFingerprint) >>= \case
Nothing -> toView $ CRRemoteCtrlAnnounce fingerprint -- unknown controller, ui "register" action required Nothing -> toView $ CRRemoteCtrlAnnounce caFingerprint -- unknown controller, ui "register" action required
-- TODO Maybe Bool is very confusing - the intent is very unclear here -- TODO Maybe Bool is very confusing - the intent is very unclear here
Just found@RemoteCtrl {remoteCtrlId, accepted = storedChoice} -> case storedChoice of Just found@RemoteCtrl {remoteCtrlId, accepted = storedChoice} -> case storedChoice of
Nothing -> toView $ CRRemoteCtrlFound $ remoteCtrlInfo found False -- first-time controller, ui "accept" action required 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 -> Just True ->
chatReadVar remoteCtrlSession >>= \case chatReadVar remoteCtrlSession >>= \case
Nothing -> toView . CRChatError Nothing . ChatError $ CEInternalError "Remote host found without running a session" Nothing -> toView . CRChatError Nothing . ChatError $ CEInternalError "Remote host found without running a session"
src/Simplex/Chat/Remote/Discovery.hs
+132 -64
View File
@@ -1,37 +1,33 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PatternSynonyms #-}
module Simplex.Chat.Remote.Discovery module Simplex.Chat.Remote.Discovery where
( -- * Announce
announceRevHTTP2,
runAnnouncer,
startTLSServer,
runHTTP2Client,
-- * Discovery
connectRevHTTP2,
withListener,
openListener,
recvAnnounce,
connectTLSClient,
attachHTTP2Server,
)
where
import Control.Logger.Simple import Control.Logger.Simple
import Control.Monad import Control.Monad
import Crypto.Random (getRandomBytes)
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import qualified Data.ByteString.Base64.URL as B64U
import Data.Default (def) import Data.Default (def)
import Data.String (IsString) 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.Socket as N
import qualified Network.TLS as TLS import qualified Network.TLS as TLS
import qualified Network.UDP as UDP import qualified Network.UDP as UDP
import Simplex.Chat.Remote.Multicast (setMembership) 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 qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding (Encoding (..))
import Simplex.Messaging.Encoding.String (StrEncoding (..)) import Simplex.Messaging.Encoding.String (StrEncoding (..))
import Simplex.Messaging.Transport (supportedParameters) import Simplex.Messaging.Transport (supportedParameters)
import qualified Simplex.Messaging.Transport as Transport 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 (defaultHTTP2BufferSize, getHTTP2Body)
import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client, HTTP2ClientError (..), attachHTTP2Client, bodyHeadSize, connTimeout, defaultHTTP2ClientConfig) import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client, HTTP2ClientError (..), attachHTTP2Client, bodyHeadSize, connTimeout, defaultHTTP2ClientConfig)
import Simplex.Messaging.Transport.HTTP2.Server (HTTP2Request (..), runHTTP2ServerWith) import Simplex.Messaging.Transport.HTTP2.Server (HTTP2Request (..), runHTTP2ServerWith)
import Simplex.Messaging.Transport.Server (defaultTransportServerConfig, runTransportServer) import Simplex.Messaging.Transport.Server (defaultTransportServerConfig, runTransportServerSocket, startTCPServer)
import Simplex.Messaging.Util (ifM, tshow, whenM) import Simplex.Messaging.Util (ifM, tshow)
import Simplex.Messaging.Version (mkVersionRange)
import UnliftIO import UnliftIO
import UnliftIO.Concurrent 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 ANY_ADDR_V4 = "0.0.0.0"
pattern DISCOVERY_PORT :: (IsString a, Eq a) => a 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. -- | 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. -- 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 -> (C.PrivateKeyEd25519, Announce) -> TLS.Credentials -> IO () -> IO (Either HTTP2ClientError HTTP2Client)
announceRevHTTP2 tasks invite credentials finishAction = do announceRevHTTP2 tasks (sigKey, announce@Announce {caFingerprint, serviceAddress=(host, _port)}) credentials finishAction = do
httpClient <- newEmptyMVar httpClient <- newEmptyMVar
started <- newEmptyTMVarIO started <- newEmptyTMVarIO
finished <- newEmptyMVar finished <- newEmptyMVar
_ <- forkIO $ readMVar finished >> finishAction -- attach external cleanup action to session lock _ <- forkIO $ readMVar finished >> finishAction -- attach external cleanup action to session lock
announcer <- async . liftIO . whenM (atomically $ takeTMVar started) $ do announcer <- async . liftIO $ atomically (takeTMVar started) >>= \case
logInfo $ "Starting announcer for " <> tshow (strEncode invite) Nothing -> pure () -- TLS server failed to start, skipping announcer
runAnnouncer (strEncode invite) Just givenPort -> do
logInfo $ "Starting announcer for " <> ident <> " at " <> tshow (host, givenPort)
runAnnouncer (sigKey, announce {serviceAddress = (host, fromIntegral givenPort)})
tasks `registerAsync` announcer tasks `registerAsync` announcer
tlsServer <- startTLSServer started credentials $ \tls -> do tlsServer <- startTLSServer started credentials $ \tls -> do
logInfo $ "Incoming connection for " <> tshow (strEncode invite) logInfo $ "Incoming connection for " <> ident
cancel announcer cancel announcer
runHTTP2Client finished httpClient tls `catchAny` (logError . tshow) runHTTP2Client finished httpClient tls `catchAny` (logError . tshow)
logInfo $ "Client finished for " <> tshow (strEncode invite) logInfo $ "Client finished for " <> ident
-- BUG: this should be handled in HTTP2Client wrapper -- BUG: this should be handled in HTTP2Client wrapper, partially handled in startTLSServer
_ <- forkIO $ do _ <- forkIO $ waitCatch tlsServer >> void (tryPutMVar finished ())
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 ()
tasks `registerAsync` tlsServer tasks `registerAsync` tlsServer
logInfo $ "Waiting for client for " <> tshow (strEncode invite) logInfo $ "Waiting for client for " <> ident
readMVar httpClient readMVar httpClient
where
ident = decodeUtf8 $ strEncode caFingerprint
-- | Broadcast invite with link-local datagrams -- | Send replay-proof announce datagrams
runAnnouncer :: ByteString -> IO () runAnnouncer :: (C.PrivateKeyEd25519, Announce) -> IO ()
runAnnouncer inviteBS = do runAnnouncer (announceKey, initialAnnounce) = withSender $ loop initialAnnounce
bracket (UDP.clientSocket MULTICAST_ADDR_V4 DISCOVERY_PORT False) UDP.close $ \sock -> do where
let raw = UDP.udpSocket sock loop announce sock = do
N.setSocketOption raw N.Broadcast 1 UDP.send sock $ smpEncode (signAnnounce announceKey announce)
N.setSocketOption raw N.ReuseAddr 1
forever $ do
UDP.send sock inviteBS
threadDelay 1000000 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 (Maybe N.PortNumber) -> TLS.Credentials -> (Transport.TLS -> IO ()) -> m (Async ())
startTLSServer :: (MonadUnliftIO m) => TMVar Bool -> TLS.Credentials -> (Transport.TLS -> IO ()) -> m (Async ()) startTLSServer started credentials server = async . liftIO $ do
startTLSServer started credentials = async . liftIO . runTransportServer started DISCOVERY_PORT serverParams defaultTransportServerConfig 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 where
serverParams = serverParams =
def def
@@ -123,22 +173,40 @@ runHTTP2Client finishedVar clientVar tls =
-- TODO connection timeout -- TODO connection timeout
config = defaultHTTP2ClientConfig {bodyHeadSize = doNotPrefetchHead, connTimeout = maxBound} config = defaultHTTP2ClientConfig {bodyHeadSize = doNotPrefetchHead, connTimeout = maxBound}
withListener :: (MonadUnliftIO m) => (UDP.ListenSocket -> m a) -> m a withSender :: MonadUnliftIO m => (UDP.UDPSocket -> m a) -> m a
withListener = bracket openListener closeListener withSender = bracket (liftIO $ UDP.clientSocket MULTICAST_ADDR_V4 DISCOVERY_PORT False) (liftIO . UDP.close)
openListener :: (MonadIO m) => m UDP.ListenSocket withListener :: MonadUnliftIO m => TMVar Int -> (UDP.ListenSocket -> m a) -> m a
openListener = liftIO $ do 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) sock <- UDP.serverSocket (MULTICAST_ADDR_V4, read DISCOVERY_PORT)
logDebug $ "Discovery listener socket: " <> tshow sock logDebug $ "Discovery listener socket: " <> tshow sock
let raw = UDP.listenSocket sock let raw = UDP.listenSocket sock
N.setSocketOption raw N.Broadcast 1 -- N.setSocketOption raw N.Broadcast 1
void $ setMembership raw (listenerHostAddr4 sock) True joinMulticast subscribers raw (listenerHostAddr4 sock)
pure sock pure sock
closeListener :: MonadIO m => UDP.ListenSocket -> m () closeListener :: MonadIO m => TMVar Int -> UDP.ListenSocket -> m ()
closeListener sock = liftIO $ do closeListener subscribers sock = liftIO $
UDP.stop sock partMulticast subscribers (UDP.listenSocket sock) (listenerHostAddr4 sock) `finally` UDP.stop sock
void $ setMembership (UDP.listenSocket sock) (listenerHostAddr4 sock) False
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 :: UDP.ListenSocket -> N.HostAddress
listenerHostAddr4 sock = case UDP.mySockAddr sock of listenerHostAddr4 sock = case UDP.mySockAddr sock of
@@ -150,11 +218,11 @@ recvAnnounce sock = liftIO $ do
(invite, UDP.ClientSockAddr source _cmsg) <- UDP.recvFrom sock (invite, UDP.ClientSockAddr source _cmsg) <- UDP.recvFrom sock
pure (source, invite) pure (source, invite)
connectRevHTTP2 :: (MonadUnliftIO m) => TransportHost -> C.KeyHash -> (HTTP2Request -> m ()) -> m () connectRevHTTP2 :: (MonadUnliftIO m) => (TransportHost, Word16) -> C.KeyHash -> (HTTP2Request -> m ()) -> m ()
connectRevHTTP2 host fingerprint = connectTLSClient host fingerprint . attachHTTP2Server connectRevHTTP2 serviceAddress fingerprint = connectTLSClient serviceAddress fingerprint . attachHTTP2Server
connectTLSClient :: (MonadUnliftIO m) => TransportHost -> C.KeyHash -> (Transport.TLS -> m a) -> m a connectTLSClient :: (MonadUnliftIO m) => (TransportHost, Word16) -> C.KeyHash -> (Transport.TLS -> m a) -> m a
connectTLSClient host caFingerprint = runTransportClient defaultTransportClientConfig Nothing host DISCOVERY_PORT (Just caFingerprint) connectTLSClient (host, port) caFingerprint = runTransportClient defaultTransportClientConfig Nothing host (show port) (Just caFingerprint)
attachHTTP2Server :: (MonadUnliftIO m) => (HTTP2Request -> m ()) -> Transport.TLS -> m () attachHTTP2Server :: (MonadUnliftIO m) => (HTTP2Request -> m ()) -> Transport.TLS -> m ()
attachHTTP2Server processRequest tls = do attachHTTP2Server processRequest tls = do
src/Simplex/Chat/Remote/Multicast.hsc
+6 -3
View File
@@ -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. 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 setMembership sock group membership = allocaBytes #{size struct ip_mreq} $ \mReqPtr -> do
#{poke struct ip_mreq, imr_multiaddr} mReqPtr group #{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 #{poke struct ip_mreq, imr_interface} mReqPtr (0 :: HostAddress) -- attempt to contact the group on ANY interface
withFdSocket sock $ \fd -> withFdSocket sock $ \fd -> do
(/= 0) <$> c_setsockopt fd c_IPPROTO_IP flag (castPtr mReqPtr) (#{size struct ip_mreq}) 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 where
flag = if membership then c_IP_ADD_MEMBERSHIP else c_IP_DROP_MEMBERSHIP flag = if membership then c_IP_ADD_MEMBERSHIP else c_IP_DROP_MEMBERSHIP
src/Simplex/Chat/Remote/Protocol.hs
+2 -2
View File
@@ -66,8 +66,8 @@ $(deriveJSON (taggedObjectJSON $ dropPrefix "RR") ''RemoteResponse)
-- * Client side / desktop -- * Client side / desktop
createRemoteHostClient :: HTTP2Client -> Text -> ExceptT RemoteProtocolError IO RemoteHostClient createRemoteHostClient :: HTTP2Client -> dh -> Text -> ExceptT RemoteProtocolError IO RemoteHostClient
createRemoteHostClient httpClient desktopName = do createRemoteHostClient httpClient todo'dhKey desktopName = do
logDebug "Sending initial hello" logDebug "Sending initial hello"
sendRemoteCommand' httpClient localEncoding Nothing RCHello {deviceName = desktopName} >>= \case sendRemoteCommand' httpClient localEncoding Nothing RCHello {deviceName = desktopName} >>= \case
RRHello {encoding, deviceName = mobileName, encryptFiles} -> do RRHello {encoding, deviceName = mobileName, encryptFiles} -> do
src/Simplex/Chat/Remote/Types.hs
+177 -4
View File
@@ -1,18 +1,39 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE GADTs #-}
module Simplex.Chat.Remote.Types where module Simplex.Chat.Remote.Types where
import Control.Exception 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.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.Int (Int64)
import Data.Text (Text) 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 qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile) 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.Parsers (defaultJSON, dropPrefix, enumJSON, sumTypeJSON)
import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client)
import Simplex.Messaging.Version (VersionRange, mkVersionRange)
import UnliftIO import UnliftIO
data RemoteHostClient = RemoteHostClient data RemoteHostClient = RemoteHostClient
@@ -66,7 +87,6 @@ data RemoteHostInfo = RemoteHostInfo
{ remoteHostId :: RemoteHostId, { remoteHostId :: RemoteHostId,
storePath :: FilePath, storePath :: FilePath,
displayName :: Text, displayName :: Text,
remoteCtrlOOB :: RemoteCtrlOOB,
sessionActive :: Bool sessionActive :: Bool
} }
deriving (Show) deriving (Show)
@@ -98,6 +118,161 @@ data RemoteFile = RemoteFile
} }
deriving (Show) 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 data PlatformEncoding
= PESwift = PESwift
| PEKotlin | PEKotlin
@@ -125,8 +300,6 @@ $(J.deriveJSON (sumTypeJSON $ dropPrefix "RPE") ''RemoteProtocolError)
$(J.deriveJSON (enumJSON $ dropPrefix "PE") ''PlatformEncoding) $(J.deriveJSON (enumJSON $ dropPrefix "PE") ''PlatformEncoding)
$(J.deriveJSON defaultJSON ''RemoteCtrlOOB)
$(J.deriveJSON defaultJSON ''RemoteHostInfo) $(J.deriveJSON defaultJSON ''RemoteHostInfo)
$(J.deriveJSON defaultJSON ''RemoteCtrl) $(J.deriveJSON defaultJSON ''RemoteCtrl)
src/Simplex/Chat/Store/Remote.hs
+6 -4
View File
@@ -6,13 +6,14 @@ module Simplex.Chat.Store.Remote where
import Control.Monad.Except import Control.Monad.Except
import Data.Int (Int64) import Data.Int (Int64)
import Data.Maybe (fromMaybe)
import Data.Text (Text) import Data.Text (Text)
import Database.SQLite.Simple (Only (..)) import Database.SQLite.Simple (Only (..))
import qualified Database.SQLite.Simple as SQL 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.Remote.Types
import Simplex.Chat.Store.Shared
import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow) 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 qualified Simplex.Messaging.Crypto as C
insertRemoteHost :: DB.Connection -> FilePath -> Text -> C.APrivateSignKey -> C.SignedCertificate -> IO RemoteHostId 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.Connection -> RemoteHostId -> IO ()
deleteRemoteHostRecord db remoteHostId = DB.execute db "DELETE FROM remote_hosts WHERE remote_host_id = ?" (Only remoteHostId) deleteRemoteHostRecord db remoteHostId = DB.execute db "DELETE FROM remote_hosts WHERE remote_host_id = ?" (Only remoteHostId)
insertRemoteCtrl :: DB.Connection -> RemoteCtrlOOB -> IO RemoteCtrlInfo insertRemoteCtrl :: DB.Connection -> SignedOOB -> IO RemoteCtrlInfo
insertRemoteCtrl db RemoteCtrlOOB {fingerprint, displayName} = do 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) DB.execute db "INSERT INTO remote_controllers (display_name, fingerprint) VALUES (?,?)" (displayName, fingerprint)
remoteCtrlId <- insertedRowId db remoteCtrlId <- insertedRowId db
pure RemoteCtrlInfo {remoteCtrlId, displayName, fingerprint, accepted = Nothing, sessionActive = False} pure RemoteCtrlInfo {remoteCtrlId, displayName, fingerprint, accepted = Nothing, sessionActive = False}
src/Simplex/Chat/View.hs
+3 -6
View File
@@ -269,8 +269,9 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe
CRNtfTokenStatus status -> ["device token status: " <> plain (smpEncode status)] CRNtfTokenStatus status -> ["device token status: " <> plain (smpEncode status)]
CRNtfToken _ status mode -> ["device token status: " <> plain (smpEncode status) <> ", notifications mode: " <> plain (strEncode mode)] CRNtfToken _ status mode -> ["device token status: " <> plain (smpEncode status) <> ", notifications mode: " <> plain (strEncode mode)]
CRNtfMessages {} -> [] CRNtfMessages {} -> []
CRRemoteHostCreated RemoteHostInfo {remoteHostId, remoteCtrlOOB} -> ("remote host " <> sShow remoteHostId <> " created") : viewRemoteCtrlOOBData remoteCtrlOOB CRRemoteHostCreated RemoteHostInfo {remoteHostId} -> ["remote host " <> sShow remoteHostId <> " created"]
CRRemoteHostList hs -> viewRemoteHosts hs 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"] CRRemoteHostConnected RemoteHostInfo {remoteHostId = rhId} -> ["remote host " <> sShow rhId <> " connected"]
CRRemoteHostStopped rhId -> ["remote host " <> sShow rhId <> " stopped"] CRRemoteHostStopped rhId -> ["remote host " <> sShow rhId <> " stopped"]
CRRemoteFileStored rhId (CryptoFile filePath cfArgs_) -> CRRemoteFileStored rhId (CryptoFile filePath cfArgs_) ->
@@ -447,7 +448,7 @@ viewGroupSubscribed :: GroupInfo -> [StyledString]
viewGroupSubscribed g = [membershipIncognito g <> ttyFullGroup g <> ": connected to server(s)"] viewGroupSubscribed g = [membershipIncognito g <> ttyFullGroup g <> ": connected to server(s)"]
showSMPServer :: SMPServer -> String showSMPServer :: SMPServer -> String
showSMPServer = B.unpack . strEncode . host showSMPServer srv = B.unpack $ strEncode srv.host
viewHostEvent :: AProtocolType -> TransportHost -> String viewHostEvent :: AProtocolType -> TransportHost -> String
viewHostEvent p h = map toUpper (B.unpack $ strEncode p) <> " host " <> B.unpack (strEncode h) 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 where
parens s = " (" <> s <> ")" parens s = " (" <> s <> ")"
viewRemoteCtrlOOBData :: RemoteCtrlOOB -> [StyledString]
viewRemoteCtrlOOBData RemoteCtrlOOB {fingerprint} =
["connection code:", plain $ strEncode fingerprint]
viewRemoteHosts :: [RemoteHostInfo] -> [StyledString] viewRemoteHosts :: [RemoteHostInfo] -> [StyledString]
viewRemoteHosts = \case viewRemoteHosts = \case
[] -> ["No remote hosts"] [] -> ["No remote hosts"]
tests/RemoteTests.hs
+45 -17
View File
@@ -8,12 +8,12 @@ module RemoteTests where
import ChatClient import ChatClient
import ChatTests.Utils import ChatTests.Utils
import Control.Logger.Simple import Control.Logger.Simple
import Control.Monad
import qualified Data.Aeson as J import qualified Data.Aeson as J
import qualified Data.ByteString as B import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy.Char8 as LB import qualified Data.ByteString.Lazy.Char8 as LB
import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import Data.String (fromString)
import Network.HTTP.Types (ok200) import Network.HTTP.Types (ok200)
import qualified Network.HTTP2.Client as C import qualified Network.HTTP2.Client as C
import qualified Network.HTTP2.Server as S import qualified Network.HTTP2.Server as S
@@ -23,11 +23,12 @@ import Simplex.Chat.Archive (archiveFilesFolder)
import Simplex.Chat.Controller (ChatConfig (..), XFTPFileConfig (..)) import Simplex.Chat.Controller (ChatConfig (..), XFTPFileConfig (..))
import qualified Simplex.Chat.Controller as Controller import qualified Simplex.Chat.Controller as Controller
import Simplex.Chat.Mobile.File import Simplex.Chat.Mobile.File
import Simplex.Chat.Remote.Types
import qualified Simplex.Chat.Remote.Discovery as Discovery import qualified Simplex.Chat.Remote.Discovery as Discovery
import Simplex.Chat.Remote.Types
import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFileArgs (..)) 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 qualified Simplex.Messaging.Transport as Transport
import Simplex.Messaging.Transport.Client (TransportHost (..)) import Simplex.Messaging.Transport.Client (TransportHost (..))
import Simplex.Messaging.Transport.Credentials (genCredentials, tlsCredentials) import Simplex.Messaging.Transport.Credentials (genCredentials, tlsCredentials)
@@ -44,6 +45,7 @@ remoteTests :: SpecWith FilePath
remoteTests = describe "Remote" $ do remoteTests = describe "Remote" $ do
it "generates usable credentials" genCredentialsTest it "generates usable credentials" genCredentialsTest
it "connects announcer with discoverer over reverse-http2" announceDiscoverHttp2Test 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" remoteHandshakeTest
it "performs protocol handshake (again)" remoteHandshakeTest -- leaking servers regression check it "performs protocol handshake (again)" remoteHandshakeTest -- leaking servers regression check
it "sends messages" remoteMessageTest it "sends messages" remoteMessageTest
@@ -59,8 +61,9 @@ genCredentialsTest _tmp = do
started <- newEmptyTMVarIO started <- newEmptyTMVarIO
bracket (Discovery.startTLSServer started credentials serverHandler) cancel $ \_server -> do bracket (Discovery.startTLSServer started credentials serverHandler) cancel $ \_server -> do
ok <- atomically (readTMVar started) ok <- atomically (readTMVar started)
unless ok $ error "TLS server failed to start" port <- maybe (error "TLS server failed to start") pure ok
Discovery.connectTLSClient "127.0.0.1" fingerprint clientHandler logNote $ "Assigned port: " <> tshow port
Discovery.connectTLSClient ("127.0.0.1", fromIntegral port) fingerprint clientHandler
where where
serverHandler serverTls = do serverHandler serverTls = do
logNote "Sending from server" logNote "Sending from server"
@@ -75,15 +78,28 @@ genCredentialsTest _tmp = do
-- * UDP discovery and rever HTTP2 -- * 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 :: (HasCallStack) => FilePath -> IO ()
announceDiscoverHttp2Test _tmp = do announceDiscoverHttp2Test _tmp = do
subscribers <- newTMVarIO 0
localAddr <- Discovery.getLocalAddress subscribers >>= maybe (fail "unable to get local address") pure
(fingerprint, credentials) <- genTestCredentials (fingerprint, credentials) <- genTestCredentials
(_dhKey, sigKey, ann, _oob) <- Discovery.startSession (Just "Desktop") (localAddr, read Discovery.DISCOVERY_PORT) fingerprint
tasks <- newTVarIO [] tasks <- newTVarIO []
finished <- newEmptyMVar finished <- newEmptyMVar
controller <- async $ do controller <- async $ do
logNote "Controller: starting" logNote "Controller: starting"
bracket 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 closeHTTP2Client
( \http -> do ( \http -> do
logNote "Controller: got client" logNote "Controller: got client"
@@ -94,11 +110,14 @@ announceDiscoverHttp2Test _tmp = do
Right HTTP2Response {} -> Right HTTP2Response {} ->
logNote "Controller: got response" logNote "Controller: got response"
) )
host <- async $ Discovery.withListener $ \sock -> do host <- async $ Discovery.withListener subscribers $ \sock -> do
(N.SockAddrInet _port addr, invite) <- Discovery.recvAnnounce sock (N.SockAddrInet _port addr, sigAnn) <- Discovery.recvAnnounce sock
strDecode invite `shouldBe` Right fingerprint SignedAnnounce Announce {caFingerprint, serviceAddress=(hostAddr, port)} _sig <- either fail pure $ smpDecode sigAnn
logNote "Host: connecting" caFingerprint `shouldBe` fingerprint
server <- async $ Discovery.connectTLSClient (THIPv4 $ N.hostAddressToTuple addr) fingerprint $ \tls -> do 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" logNote "Host: got tls"
flip Discovery.attachHTTP2Server tls $ \HTTP2Request {sendResponse} -> do flip Discovery.attachHTTP2Server tls $ \HTTP2Request {sendResponse} -> do
logNote "Host: got request" logNote "Host: got request"
@@ -372,21 +391,30 @@ remoteCLIFileTest = testChatCfg3 cfg aliceProfile aliceDesktopProfile bobProfile
startRemote :: TestCC -> TestCC -> IO () startRemote :: TestCC -> TestCC -> IO ()
startRemote mobile desktop = do startRemote mobile desktop = do
desktop ##> "/set device name My desktop"
desktop <## "ok"
desktop ##> "/create remote host" desktop ##> "/create remote host"
desktop <## "remote host 1 created" desktop <## "remote host 1 created"
desktop <## "connection code:" -- A new host is started [automatically] by UI
fingerprint <- getTermLine desktop
desktop ##> "/start remote host 1" desktop ##> "/start remote host 1"
desktop <## "ok" 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 ##> "/start remote ctrl"
mobile <## "ok" mobile <## "ok"
mobile <## "remote controller announced" mobile <## "remote controller announced"
mobile <## "connection code:" mobile <## "connection code:"
fingerprint' <- getTermLine mobile annFingerprint <- getTermLine mobile
fingerprint' `shouldBe` fingerprint -- The user scans OOB QR code and confirms it matches the announced stuff
mobile ##> ("/register remote ctrl " <> fingerprint' <> " " <> "My desktop") fromString annFingerprint `shouldBe` strEncode oobFingerprint
mobile ##> ("/register remote ctrl " <> oobLink)
mobile <## "remote controller 1 registered" mobile <## "remote controller 1 registered"
mobile ##> "/accept remote ctrl 1" mobile ##> "/accept remote ctrl 1"
mobile <## "ok" -- alternative scenario: accepted before controller start mobile <## "ok" -- alternative scenario: accepted before controller start