mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-04-05 02:26:03 +00:00
Extract public RC types (#887)
This commit is contained in:
Alexander Bondarenko
committed by
GitHub
GitHub
parent
c0566d37a0
commit
ecb23c66e0
@@ -5,25 +5,16 @@
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedRecordDot #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
||||
|
||||
module Simplex.RemoteControl.Client
|
||||
( RCHostPairing (..),
|
||||
RCHostClient (action),
|
||||
RCHostSession (..),
|
||||
RCHostHello (..),
|
||||
HostSessKeys (..),
|
||||
( RCHostClient (action),
|
||||
RCHostConnection,
|
||||
SessionCode,
|
||||
newRCHostPairing,
|
||||
connectRCHost,
|
||||
cancelHostClient,
|
||||
RCCtrlPairing (..),
|
||||
RCCtrlClient (action),
|
||||
RCCtrlSession (..),
|
||||
CtrlSessKeys (..),
|
||||
RCCtrlConnection,
|
||||
connectRCCtrlURI,
|
||||
connectKnownRCCtrlMulticast,
|
||||
@@ -40,7 +31,6 @@ import Control.Monad.IO.Class
|
||||
import Crypto.Random (ChaChaDRG)
|
||||
import qualified Data.Aeson as J
|
||||
import qualified Data.Aeson.TH as JQ
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Lazy as LB
|
||||
@@ -59,7 +49,6 @@ import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Crypto.SNTRUP761
|
||||
import Simplex.Messaging.Crypto.SNTRUP761.Bindings
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Parsers (defaultJSON)
|
||||
import Simplex.Messaging.Transport (TLS (tlsUniq), cGet, cPut)
|
||||
import Simplex.Messaging.Transport.Client (TransportClientConfig (..), TransportHost, defaultTransportClientConfig, runTransportClient)
|
||||
import Simplex.Messaging.Transport.Credentials (genCredentials, tlsCredentials)
|
||||
@@ -83,21 +72,6 @@ xrcpBlockSize = 16384
|
||||
helloBlockSize :: Int
|
||||
helloBlockSize = 12288
|
||||
|
||||
data RCHostHello = RCHostHello
|
||||
{ v :: Version,
|
||||
ca :: C.KeyHash,
|
||||
app :: J.Value,
|
||||
kem :: KEMPublicKey
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
$(JQ.deriveJSON defaultJSON ''RCHostHello)
|
||||
|
||||
data RCCtrlHello = RCCtrlHello {}
|
||||
deriving (Show)
|
||||
|
||||
$(JQ.deriveJSON defaultJSON {J.nullaryToObject = True} ''RCCtrlHello)
|
||||
|
||||
newRCHostPairing :: IO RCHostPairing
|
||||
newRCHostPairing = do
|
||||
((_, caKey), caCert) <- genCredentials Nothing (-25, 24 * 999999) "ca"
|
||||
@@ -116,13 +90,8 @@ data RCHClient_ = RCHClient_
|
||||
tlsEnded :: TMVar (Either RCErrorType ())
|
||||
}
|
||||
|
||||
-- tlsunique channel binding
|
||||
type SessionCode = ByteString
|
||||
|
||||
type RCHostConnection = (RCSignedInvitation, RCHostClient, RCStepTMVar (SessionCode, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)))
|
||||
|
||||
type RCStepTMVar a = TMVar (Either RCErrorType a)
|
||||
|
||||
connectRCHost :: TVar ChaChaDRG -> RCHostPairing -> J.Value -> ExceptT RCErrorType IO RCHostConnection
|
||||
connectRCHost drg pairing@RCHostPairing {caKey, caCert, idPrivKey, knownHost} ctrlAppInfo = do
|
||||
r <- newEmptyTMVarIO
|
||||
@@ -430,99 +399,3 @@ cancelCtrlClient :: RCCtrlClient -> IO ()
|
||||
cancelCtrlClient RCCtrlClient {action, client_ = RCCClient_ {endSession}} = do
|
||||
atomically $ putTMVar endSession ()
|
||||
uninterruptibleCancel action
|
||||
|
||||
-- | Long-term part of controller (desktop) connection to host (mobile)
|
||||
data RCHostPairing = RCHostPairing
|
||||
{ caKey :: C.APrivateSignKey,
|
||||
caCert :: C.SignedCertificate,
|
||||
idPrivKey :: C.PrivateKeyEd25519,
|
||||
knownHost :: Maybe KnownHostPairing
|
||||
}
|
||||
|
||||
data KnownHostPairing = KnownHostPairing
|
||||
{ hostFingerprint :: C.KeyHash, -- this is only changed in the first session, long-term identity of connected remote host
|
||||
storedSessKeys :: StoredHostSessKeys
|
||||
}
|
||||
|
||||
data StoredHostSessKeys = StoredHostSessKeys
|
||||
{ hostDHPublicKey :: C.PublicKeyX25519, -- sent by host in HELLO block. Matches one of the DH keys in RCCtrlPairing
|
||||
kemSharedKey :: KEMSharedKey
|
||||
}
|
||||
|
||||
-- | Long-term part of host (mobile) connection to controller (desktop)
|
||||
data RCCtrlPairing = RCCtrlPairing
|
||||
{ caKey :: C.APrivateSignKey,
|
||||
caCert :: C.SignedCertificate,
|
||||
ctrlFingerprint :: C.KeyHash, -- long-term identity of connected remote controller
|
||||
idPubKey :: C.PublicKeyEd25519,
|
||||
storedSessKeys :: StoredCtrlSessKeys,
|
||||
prevStoredSessKeys :: Maybe StoredCtrlSessKeys
|
||||
}
|
||||
|
||||
data StoredCtrlSessKeys = StoredCtrlSessKeys
|
||||
{ dhPrivKey :: C.PrivateKeyX25519,
|
||||
kemSharedKey :: Maybe KEMSharedKey -- this is Nothing only for a new pairing, and once connected it is always Just.
|
||||
}
|
||||
|
||||
data RCHostKeys = RCHostKeys
|
||||
{ sessKeys :: C.KeyPair 'C.Ed25519,
|
||||
dhKeys :: C.KeyPair 'C.X25519
|
||||
}
|
||||
|
||||
-- Connected session with Host
|
||||
data RCHostSession = RCHostSession
|
||||
{ tls :: TLS,
|
||||
sessionKeys :: HostSessKeys
|
||||
}
|
||||
|
||||
data HostSessKeys = HostSessKeys
|
||||
{ hybridKey :: KEMHybridSecret,
|
||||
idPrivKey :: C.PrivateKeyEd25519,
|
||||
sessPrivKey :: C.PrivateKeyEd25519
|
||||
}
|
||||
|
||||
-- Host: RCCtrlPairing + RCInvitation => (RCCtrlSession, RCCtrlPairing)
|
||||
|
||||
data RCCtrlSession = RCCtrlSession
|
||||
{ tls :: TLS,
|
||||
sessionKeys :: CtrlSessKeys
|
||||
}
|
||||
|
||||
data CtrlSessKeys = CtrlSessKeys
|
||||
{ hybridKey :: KEMHybridSecret,
|
||||
idPubKey :: C.PublicKeyEd25519,
|
||||
sessPubKey :: C.PublicKeyEd25519
|
||||
}
|
||||
|
||||
data RCHostEncHello = RCHostEncHello
|
||||
{ dhPubKey :: C.PublicKeyX25519,
|
||||
nonce :: C.CbNonce,
|
||||
encBody :: ByteString
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
instance Encoding RCHostEncHello where
|
||||
smpEncode RCHostEncHello {dhPubKey, nonce, encBody} =
|
||||
"HELLO " <> smpEncode (dhPubKey, nonce, Tail encBody)
|
||||
smpP = do
|
||||
(dhPubKey, nonce, Tail encBody) <- "HELLO " *> smpP
|
||||
pure RCHostEncHello {dhPubKey, nonce, encBody}
|
||||
|
||||
data RCCtrlEncHello
|
||||
= RCCtrlEncHello {kem :: KEMCiphertext, nonce :: C.CbNonce, encBody :: ByteString}
|
||||
| RCCtrlEncError {nonce :: C.CbNonce, encMessage :: ByteString}
|
||||
deriving (Show)
|
||||
|
||||
instance Encoding RCCtrlEncHello where
|
||||
smpEncode = \case
|
||||
RCCtrlEncHello {kem, nonce, encBody} -> "HELLO " <> smpEncode (kem, nonce, Tail encBody)
|
||||
RCCtrlEncError {nonce, encMessage} -> "ERROR " <> smpEncode (nonce, Tail encMessage)
|
||||
smpP =
|
||||
A.takeTill (== ' ') >>= \case
|
||||
"HELLO" -> do
|
||||
(kem, nonce, Tail encBody) <- _smpP
|
||||
pure RCCtrlEncHello {kem, nonce, encBody}
|
||||
"ERROR" -> do
|
||||
(nonce, Tail encMessage) <- _smpP
|
||||
pure RCCtrlEncError {nonce, encMessage}
|
||||
_ -> fail "bad RCCtrlEncHello"
|
||||
|
||||
Reference in New Issue
Block a user