mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-05-24 14:35:22 +00:00
agent: xrcp implementation for connection via link (no multicast) (#884)
* WIP: start working on connection invites startSession/OOB is broken now - the port isn't coming from the actualy assigned one. * Add invite types * clean old invite-related types * apply renames * Move SessionKeys from Invitation * Stub host-side keys and handle * move keys and handles to Types * add Simplex.RemoteControl.Client * more keys * progress * crypto for sessions * progress to multicast * multicast crypto * add RC TLS server * agent api for remote control * WIP: tls client * fix test * update encoding to include nonce * add TODO * update * Use network-info to find TransportHost * request and submit tls client certificate * WIP: add missing bits for testing RC client * RCEncryptedHello encoding * add block encoding * refactor * validate known host certificate * remove some spaghetti * functional API to host/ctrl clients * refactor connectRCCtrl_ * refactor connectRCHost * question * add type * fix RC session * update doc * update doc 2 * add block on confirmation * remove unused parameter * export CtrlSessKeys * export * fix parsing * move test of xrcp handshake * move KEM to HELLO step * fix JSON * type --------- Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
This commit is contained in:
Alexander Bondarenko
committed by
GitHub
GitHub
parent
1a0c4b73de
commit
1a8dfb4cbe
@@ -51,7 +51,6 @@ import Simplex.Messaging.Protocol
|
||||
tEncode,
|
||||
tEncodeBatch,
|
||||
tParse,
|
||||
_smpP,
|
||||
)
|
||||
import Simplex.Messaging.Transport (SessionId, TransportError (..))
|
||||
import Simplex.Messaging.Util (bshow, (<$?>))
|
||||
|
||||
@@ -93,6 +93,10 @@ module Simplex.Messaging.Agent
|
||||
xftpSendFile,
|
||||
xftpDeleteSndFileInternal,
|
||||
xftpDeleteSndFileRemote,
|
||||
rcNewHostPairing,
|
||||
rcConnectHost,
|
||||
rcConnectCtrlURI,
|
||||
rcConnectCtrlMulticast,
|
||||
foregroundAgent,
|
||||
suspendAgent,
|
||||
execAgentStoreSQL,
|
||||
@@ -111,6 +115,7 @@ import Control.Monad.Except
|
||||
import Control.Monad.IO.Unlift (MonadUnliftIO)
|
||||
import Control.Monad.Reader
|
||||
import Crypto.Random (MonadRandom)
|
||||
import qualified Data.Aeson as J
|
||||
import Data.Bifunctor (bimap, first, second)
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
@@ -156,6 +161,8 @@ import qualified Simplex.Messaging.Protocol as SMP
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Util
|
||||
import Simplex.Messaging.Version
|
||||
import Simplex.RemoteControl.Client
|
||||
import Simplex.RemoteControl.Invitation
|
||||
import UnliftIO.Async (async, race_)
|
||||
import UnliftIO.Concurrent (forkFinally, forkIO, threadDelay)
|
||||
import UnliftIO.STM
|
||||
@@ -379,6 +386,38 @@ xftpDeleteSndFileInternal c = withAgentEnv c . deleteSndFileInternal c
|
||||
xftpDeleteSndFileRemote :: AgentErrorMonad m => AgentClient -> UserId -> SndFileId -> ValidFileDescription 'FSender -> m ()
|
||||
xftpDeleteSndFileRemote c = withAgentEnv c .:. deleteSndFileRemote c
|
||||
|
||||
-- | Create new remote host pairing
|
||||
rcNewHostPairing :: MonadIO m => m RCHostPairing
|
||||
rcNewHostPairing = liftIO newRCHostPairing
|
||||
|
||||
-- | start TLS server for remote host with optional multicast
|
||||
rcConnectHost :: AgentErrorMonad m => AgentClient -> RCHostPairing -> J.Value -> Bool -> m RCHostConnection
|
||||
rcConnectHost c = withAgentEnv c .:. rcConnectHost'
|
||||
|
||||
rcConnectHost' :: AgentMonad m => RCHostPairing -> J.Value -> Bool -> m RCHostConnection
|
||||
rcConnectHost' pairing ctrlAppInfo _multicast = do
|
||||
drg <- asks random
|
||||
liftError RCP $ connectRCHost drg pairing ctrlAppInfo
|
||||
|
||||
-- | connect to remote controller via URI
|
||||
rcConnectCtrlURI :: AgentErrorMonad m => AgentClient -> RCSignedInvitation -> Maybe RCCtrlPairing -> J.Value -> m RCCtrlConnection
|
||||
rcConnectCtrlURI c = withAgentEnv c .:. rcConnectCtrlURI'
|
||||
|
||||
rcConnectCtrlURI' :: AgentMonad m => RCSignedInvitation -> Maybe RCCtrlPairing -> J.Value -> m RCCtrlConnection
|
||||
rcConnectCtrlURI' signedInv pairing_ hostAppInfo = do
|
||||
drg <- asks random
|
||||
liftError RCP $ connectRCCtrlURI drg signedInv pairing_ hostAppInfo
|
||||
|
||||
-- | connect to known remote controller via multicast
|
||||
rcConnectCtrlMulticast :: AgentErrorMonad m => AgentClient -> NonEmpty RCCtrlPairing -> J.Value -> m RCCtrlConnection
|
||||
rcConnectCtrlMulticast c = withAgentEnv c .: rcConnectCtrlMulticast'
|
||||
|
||||
rcConnectCtrlMulticast' :: AgentMonad m => NonEmpty RCCtrlPairing -> J.Value -> m RCCtrlConnection
|
||||
rcConnectCtrlMulticast' pairings hostAppInfo = do
|
||||
drg <- asks random
|
||||
subscribers <- newTVarIO 0 -- TODO: get from agent
|
||||
liftError RCP $ connectKnownRCCtrlMulticast drg subscribers pairings hostAppInfo
|
||||
|
||||
-- | Activate operations
|
||||
foregroundAgent :: MonadUnliftIO m => AgentClient -> m ()
|
||||
foregroundAgent c = withAgentEnv c $ foregroundAgent' c
|
||||
|
||||
@@ -211,6 +211,7 @@ import Simplex.Messaging.Transport (Transport (..), TransportError, serializeTra
|
||||
import Simplex.Messaging.Transport.Client (TransportHost, TransportHosts_ (..))
|
||||
import Simplex.Messaging.Util
|
||||
import Simplex.Messaging.Version
|
||||
import Simplex.RemoteControl.Types
|
||||
import Text.Read
|
||||
import UnliftIO.Exception (Exception)
|
||||
|
||||
@@ -1419,6 +1420,8 @@ data AgentErrorType
|
||||
NTF {ntfErr :: ErrorType}
|
||||
| -- | XFTP protocol errors forwarded to agent clients
|
||||
XFTP {xftpErr :: XFTPErrorType}
|
||||
| -- | XRCP protocol errors forwarded to agent clients
|
||||
RCP {rcpErr :: RCErrorType}
|
||||
| -- | SMP server errors
|
||||
BROKER {brokerAddress :: String, brokerErr :: BrokerErrorType}
|
||||
| -- | errors of other agents
|
||||
@@ -1524,6 +1527,7 @@ instance StrEncoding AgentErrorType where
|
||||
<|> "SMP " *> (SMP <$> strP)
|
||||
<|> "NTF " *> (NTF <$> strP)
|
||||
<|> "XFTP " *> (XFTP <$> strP)
|
||||
<|> "RCP " *> (RCP <$> strP)
|
||||
<|> "BROKER " *> (BROKER <$> textP <* " RESPONSE " <*> (RESPONSE <$> textP))
|
||||
<|> "BROKER " *> (BROKER <$> textP <* " TRANSPORT " <*> (TRANSPORT <$> transportErrorP))
|
||||
<|> "BROKER " *> (BROKER <$> textP <* A.space <*> parseRead1)
|
||||
@@ -1540,6 +1544,7 @@ instance StrEncoding AgentErrorType where
|
||||
SMP e -> "SMP " <> strEncode e
|
||||
NTF e -> "NTF " <> strEncode e
|
||||
XFTP e -> "XFTP " <> strEncode e
|
||||
RCP e -> "RCP " <> strEncode e
|
||||
BROKER srv (RESPONSE e) -> "BROKER " <> text srv <> " RESPONSE " <> text e
|
||||
BROKER srv (TRANSPORT e) -> "BROKER " <> text srv <> " TRANSPORT " <> serializeTransportError e
|
||||
BROKER srv e -> "BROKER " <> text srv <> " " <> bshow e
|
||||
|
||||
@@ -237,7 +237,7 @@ defaultNetworkConfig =
|
||||
|
||||
transportClientConfig :: NetworkConfig -> TransportClientConfig
|
||||
transportClientConfig NetworkConfig {socksProxy, tcpKeepAlive, logTLSErrors} =
|
||||
TransportClientConfig {socksProxy, tcpKeepAlive, logTLSErrors}
|
||||
TransportClientConfig {socksProxy, tcpKeepAlive, logTLSErrors, clientCredentials = Nothing}
|
||||
|
||||
-- | protocol client configuration.
|
||||
data ProtocolClientConfig = ProtocolClientConfig
|
||||
|
||||
@@ -3,6 +3,7 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
@@ -678,6 +679,10 @@ class CryptoSignature s where
|
||||
signatureBytes :: s -> ByteString
|
||||
decodeSignature :: ByteString -> Either String s
|
||||
|
||||
instance CryptoSignature (Signature s) => StrEncoding (Signature s) where
|
||||
strEncode = serializeSignature
|
||||
strDecode = decodeSignature
|
||||
|
||||
instance CryptoSignature ASignature where
|
||||
signatureBytes (ASignature _ sig) = signatureBytes sig
|
||||
decodeSignature s
|
||||
|
||||
@@ -1,5 +1,6 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
|
||||
module Simplex.Messaging.Crypto.SNTRUP761 where
|
||||
|
||||
@@ -8,21 +9,36 @@ import Data.ByteArray (ScrubbedBytes)
|
||||
import qualified Data.ByteArray as BA
|
||||
import Data.ByteString (ByteString)
|
||||
import Simplex.Messaging.Crypto
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Crypto.SNTRUP761.Bindings
|
||||
|
||||
-- Hybrid shared secret for crypto_box is defined as SHA256(DHSecret || KEMSharedKey),
|
||||
-- similar to https://datatracker.ietf.org/doc/draft-josefsson-ntruprime-hybrid/
|
||||
|
||||
class KEMSharedSecret kem where kemSecretBytes :: kem -> ScrubbedBytes
|
||||
|
||||
newtype KEMHybridSecret = KEMHybridSecret ScrubbedBytes
|
||||
|
||||
newtype KEMHybridOrDHSecret = KEMHybridOrDHSecret ScrubbedBytes
|
||||
|
||||
instance KEMSharedSecret KEMHybridSecret where kemSecretBytes (KEMHybridSecret secret) = secret
|
||||
|
||||
instance KEMSharedSecret KEMHybridOrDHSecret where kemSecretBytes (KEMHybridOrDHSecret secret) = secret
|
||||
|
||||
-- | NaCl @crypto_box@ decrypt with a shared hybrid DH + KEM secret and 192-bit nonce.
|
||||
kcbDecrypt :: KEMHybridSecret -> CbNonce -> ByteString -> Either CryptoError ByteString
|
||||
kcbDecrypt (KEMHybridSecret secret) = sbDecrypt_ secret
|
||||
kcbDecrypt :: KEMSharedSecret kem => kem -> CbNonce -> ByteString -> Either CryptoError ByteString
|
||||
kcbDecrypt = sbDecrypt_ . kemSecretBytes
|
||||
|
||||
-- | NaCl @crypto_box@ encrypt with a shared hybrid DH + KEM secret and 192-bit nonce.
|
||||
kcbEncrypt :: KEMHybridSecret -> CbNonce -> ByteString -> Int -> Either CryptoError ByteString
|
||||
kcbEncrypt (KEMHybridSecret secret) = sbEncrypt_ secret
|
||||
kcbEncrypt :: KEMSharedSecret kem => kem -> CbNonce -> ByteString -> Int -> Either CryptoError ByteString
|
||||
kcbEncrypt = sbEncrypt_ . kemSecretBytes
|
||||
|
||||
kemHybridSecret :: DhSecret 'X25519 -> KEMSharedKey -> KEMHybridSecret
|
||||
kemHybridSecret (DhSecretX25519 k1) (KEMSharedKey k2) =
|
||||
KEMHybridSecret $ BA.convert (hash $ BA.convert k1 <> k2 :: Digest SHA256)
|
||||
kemHybridSecret :: PublicKeyX25519 -> PrivateKeyX25519 -> KEMSharedKey -> KEMHybridSecret
|
||||
kemHybridSecret k pk (KEMSharedKey kem) =
|
||||
let DhSecretX25519 dh = C.dh' k pk
|
||||
in KEMHybridSecret $ BA.convert (hash $ BA.convert dh <> kem :: Digest SHA256)
|
||||
|
||||
kemHybridOrDHSecret :: PublicKeyX25519 -> PrivateKeyX25519 -> Maybe KEMSharedKey -> KEMHybridOrDHSecret
|
||||
kemHybridOrDHSecret k pk = \case
|
||||
Just kem -> KEMHybridOrDHSecret $ kemSecretBytes $ kemHybridSecret k pk kem
|
||||
Nothing -> let DhSecretX25519 dh = C.dh' k pk in KEMHybridOrDHSecret $ BA.convert dh
|
||||
|
||||
@@ -4,6 +4,7 @@ module Simplex.Messaging.Crypto.SNTRUP761.Bindings where
|
||||
|
||||
import Control.Concurrent.STM
|
||||
import Crypto.Random (ChaChaDRG)
|
||||
import Data.Aeson (FromJSON (..), ToJSON (..))
|
||||
import Data.Bifunctor (bimap)
|
||||
import Data.ByteArray (ScrubbedBytes)
|
||||
import qualified Data.ByteArray as BA
|
||||
@@ -16,14 +17,20 @@ import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
|
||||
newtype KEMPublicKey = KEMPublicKey ByteString
|
||||
deriving (Show)
|
||||
|
||||
newtype KEMSecretKey = KEMSecretKey ScrubbedBytes
|
||||
deriving (Show)
|
||||
|
||||
newtype KEMCiphertext = KEMCiphertext ByteString
|
||||
deriving (Show)
|
||||
|
||||
newtype KEMSharedKey = KEMSharedKey ScrubbedBytes
|
||||
deriving (Show)
|
||||
|
||||
sntrup761Keypair :: TVar ChaChaDRG -> IO (KEMPublicKey, KEMSecretKey)
|
||||
type KEMKeyPair = (KEMPublicKey, KEMSecretKey)
|
||||
|
||||
sntrup761Keypair :: TVar ChaChaDRG -> IO KEMKeyPair
|
||||
sntrup761Keypair drg =
|
||||
bimap KEMPublicKey KEMSecretKey
|
||||
<$> BA.allocRet
|
||||
@@ -51,14 +58,17 @@ sntrup761Dec (KEMCiphertext c) (KEMSecretKey sk) =
|
||||
KEMSharedKey
|
||||
<$> BA.alloc c_SNTRUP761_SIZE (\kPtr -> c_sntrup761_dec kPtr cPtr skPtr)
|
||||
|
||||
instance Encoding KEMPublicKey where
|
||||
smpEncode (KEMPublicKey pk) = smpEncode (BA.convert pk :: ByteString)
|
||||
smpP = KEMPublicKey . BA.convert <$> smpP @ByteString
|
||||
|
||||
instance StrEncoding KEMPublicKey where
|
||||
strEncode (KEMPublicKey pk) = strEncode (BA.convert pk :: ByteString)
|
||||
strP = KEMPublicKey . BA.convert <$> strP @ByteString
|
||||
|
||||
instance Encoding KEMCiphertext where
|
||||
smpEncode (KEMCiphertext c) = smpEncode (BA.convert c :: ByteString)
|
||||
smpP = KEMCiphertext . BA.convert <$> smpP @ByteString
|
||||
smpEncode (KEMCiphertext c) = smpEncode . Large $ BA.convert c
|
||||
smpP = KEMCiphertext . BA.convert . unLarge <$> smpP
|
||||
|
||||
instance ToJSON KEMPublicKey where
|
||||
toJSON = strToJSON
|
||||
toEncoding = strToJEncoding
|
||||
|
||||
instance FromJSON KEMPublicKey where
|
||||
parseJSON = strParseJSON "KEMPublicKey"
|
||||
|
||||
@@ -11,6 +11,7 @@ module Simplex.Messaging.Encoding
|
||||
( Encoding (..),
|
||||
Tail (..),
|
||||
Large (..),
|
||||
_smpP,
|
||||
smpEncodeList,
|
||||
smpListP,
|
||||
lenEncode,
|
||||
@@ -143,6 +144,9 @@ instance Encoding SystemTime where
|
||||
smpP = MkSystemTime <$> smpP <*> pure 0
|
||||
{-# INLINE smpP #-}
|
||||
|
||||
_smpP :: Encoding a => Parser a
|
||||
_smpP = A.space *> smpP
|
||||
|
||||
-- lists encode/parse as a sequence of items prefixed with list length (as 1 byte)
|
||||
smpEncodeList :: Encoding a => [a] -> ByteString
|
||||
smpEncodeList xs = B.cons (lenEncode $ length xs) . B.concat $ map smpEncode xs
|
||||
|
||||
@@ -1203,9 +1203,6 @@ instance ProtocolEncoding ErrorType BrokerMsg where
|
||||
| B.null queueId -> Left $ CMD NO_ENTITY
|
||||
| otherwise -> Right cmd
|
||||
|
||||
_smpP :: Encoding a => Parser a
|
||||
_smpP = A.space *> smpP
|
||||
|
||||
-- | Parse SMP protocol commands and broker messages
|
||||
parseProtocol :: forall err msg. ProtocolEncoding err msg => Version -> ByteString -> Either err msg
|
||||
parseProtocol v s =
|
||||
|
||||
@@ -110,12 +110,13 @@ instance IsString (NonEmpty TransportHost) where fromString = parseString strDec
|
||||
data TransportClientConfig = TransportClientConfig
|
||||
{ socksProxy :: Maybe SocksProxy,
|
||||
tcpKeepAlive :: Maybe KeepAliveOpts,
|
||||
logTLSErrors :: Bool
|
||||
logTLSErrors :: Bool,
|
||||
clientCredentials :: Maybe (X.CertificateChain, T.PrivKey)
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
defaultTransportClientConfig :: TransportClientConfig
|
||||
defaultTransportClientConfig = TransportClientConfig Nothing (Just defaultKeepAliveOpts) True
|
||||
defaultTransportClientConfig = TransportClientConfig Nothing (Just defaultKeepAliveOpts) True Nothing
|
||||
|
||||
clientTransportConfig :: TransportClientConfig -> TransportConfig
|
||||
clientTransportConfig TransportClientConfig {logTLSErrors} =
|
||||
@@ -126,9 +127,9 @@ runTransportClient :: (Transport c, MonadUnliftIO m) => TransportClientConfig ->
|
||||
runTransportClient = runTLSTransportClient supportedParameters Nothing
|
||||
|
||||
runTLSTransportClient :: (Transport c, MonadUnliftIO m) => T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> Maybe ByteString -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c -> m a) -> m a
|
||||
runTLSTransportClient tlsParams caStore_ cfg@TransportClientConfig {socksProxy, tcpKeepAlive} proxyUsername host port keyHash client = do
|
||||
runTLSTransportClient tlsParams caStore_ cfg@TransportClientConfig {socksProxy, tcpKeepAlive, clientCredentials} proxyUsername host port keyHash client = do
|
||||
let hostName = B.unpack $ strEncode host
|
||||
clientParams = mkTLSClientParams tlsParams caStore_ hostName port keyHash
|
||||
clientParams = mkTLSClientParams tlsParams caStore_ hostName port keyHash clientCredentials
|
||||
connectTCP = case socksProxy of
|
||||
Just proxy -> connectSocksClient proxy proxyUsername $ hostAddr host
|
||||
_ -> connectTCPClient hostName
|
||||
@@ -205,14 +206,19 @@ instance ToJSON SocksProxy where
|
||||
instance FromJSON SocksProxy where
|
||||
parseJSON = strParseJSON "SocksProxy"
|
||||
|
||||
mkTLSClientParams :: T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe C.KeyHash -> T.ClientParams
|
||||
mkTLSClientParams supported caStore_ host port keyHash_ = do
|
||||
let p = B.pack port
|
||||
mkTLSClientParams :: T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe C.KeyHash -> Maybe (X.CertificateChain, T.PrivKey) -> T.ClientParams
|
||||
mkTLSClientParams supported caStore_ host port cafp_ clientCreds_ =
|
||||
(T.defaultParamsClient host p)
|
||||
{ T.clientShared = maybe def (\caStore -> def {T.sharedCAStore = caStore}) caStore_,
|
||||
T.clientHooks = maybe def (\keyHash -> def {T.onServerCertificate = \_ _ _ -> validateCertificateChain keyHash host p}) keyHash_,
|
||||
{ T.clientShared = def {T.sharedCAStore = fromMaybe (T.sharedCAStore def) caStore_},
|
||||
T.clientHooks =
|
||||
def
|
||||
{ T.onServerCertificate = maybe def (\cafp _ _ _ -> validateCertificateChain cafp host p) cafp_,
|
||||
T.onCertificateRequest = maybe def (const . pure . Just) clientCreds_
|
||||
},
|
||||
T.clientSupported = supported
|
||||
}
|
||||
where
|
||||
p = B.pack port
|
||||
|
||||
validateCertificateChain :: C.KeyHash -> HostName -> ByteString -> X.CertificateChain -> IO [XV.FailedReason]
|
||||
validateCertificateChain _ _ _ (X.CertificateChain []) = pure [XV.EmptyChain]
|
||||
|
||||
@@ -13,7 +13,7 @@ import Data.ASN1.Types (getObjectID)
|
||||
import Data.ASN1.Types.String (ASN1StringEncoding (UTF8))
|
||||
import Data.Hourglass (Hours (..), timeAdd)
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import qualified Data.X509 as X509
|
||||
@@ -34,9 +34,9 @@ tlsCredentials :: NonEmpty Credentials -> (C.KeyHash, TLS.Credentials)
|
||||
tlsCredentials credentials = (C.KeyHash rootFP, TLS.Credentials [(X509.CertificateChain certs, privateToTls $ snd leafKey)])
|
||||
where
|
||||
Fingerprint rootFP = getFingerprint root X509.HashSHA256
|
||||
leafKey = fst $ NE.head credentials
|
||||
root = snd $ NE.last credentials
|
||||
certs = map snd $ NE.toList credentials
|
||||
leafKey = fst $ L.head credentials
|
||||
root = snd $ L.last credentials
|
||||
certs = map snd $ L.toList credentials
|
||||
|
||||
privateToTls :: C.APrivateSignKey -> TLS.PrivKey
|
||||
privateToTls (C.APrivateSignKey _ k) = case k of
|
||||
|
||||
@@ -66,7 +66,7 @@ defaultHTTP2ClientConfig =
|
||||
HTTP2ClientConfig
|
||||
{ qSize = 64,
|
||||
connTimeout = 10000000,
|
||||
transportConfig = TransportClientConfig Nothing Nothing True,
|
||||
transportConfig = TransportClientConfig Nothing Nothing True Nothing,
|
||||
bufferSize = defaultHTTP2BufferSize,
|
||||
bodyHeadSize = 16384,
|
||||
suportedTLSParams = http2TLSParams
|
||||
|
||||
@@ -0,0 +1,528 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# 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 (..),
|
||||
RCHostConnection,
|
||||
SessionCode,
|
||||
newRCHostPairing,
|
||||
connectRCHost,
|
||||
cancelHostClient,
|
||||
RCCtrlPairing (..),
|
||||
RCCtrlClient (action),
|
||||
RCCtrlSession (..),
|
||||
CtrlSessKeys (..),
|
||||
RCCtrlConnection,
|
||||
connectRCCtrlURI,
|
||||
connectKnownRCCtrlMulticast,
|
||||
confirmCtrlSession,
|
||||
cancelCtrlClient,
|
||||
RCStepTMVar,
|
||||
) where
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.Logger.Simple
|
||||
import Control.Monad
|
||||
import Control.Monad.Except
|
||||
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
|
||||
import Data.Default (def)
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import Data.Maybe (isNothing)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Clock.System (getSystemTime)
|
||||
import qualified Data.X509 as X509
|
||||
import Data.X509.Validation (Fingerprint (..), getFingerprint)
|
||||
import Network.Socket (PortNumber)
|
||||
import qualified Network.TLS as TLS
|
||||
import Simplex.Messaging.Agent.Client ()
|
||||
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)
|
||||
import Simplex.Messaging.Util (eitherToMaybe, ifM, liftEitherWith, safeDecodeUtf8, tshow)
|
||||
import Simplex.Messaging.Version
|
||||
import Simplex.RemoteControl.Discovery (getLocalAddress, startTLSServer)
|
||||
import Simplex.RemoteControl.Invitation
|
||||
import Simplex.RemoteControl.Types
|
||||
import UnliftIO
|
||||
import UnliftIO.Concurrent (forkIO)
|
||||
|
||||
currentRCVersion :: Version
|
||||
currentRCVersion = 1
|
||||
|
||||
supportedRCVRange :: VersionRange
|
||||
supportedRCVRange = mkVersionRange 1 currentRCVersion
|
||||
|
||||
xrcpBlockSize :: Int
|
||||
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"
|
||||
(_, idPrivKey) <- C.generateKeyPair'
|
||||
pure RCHostPairing {caKey, caCert, idPrivKey, knownHost = Nothing}
|
||||
|
||||
data RCHostClient = RCHostClient
|
||||
{ action :: Async (),
|
||||
client_ :: RCHClient_
|
||||
}
|
||||
|
||||
data RCHClient_ = RCHClient_
|
||||
{ startedPort :: TMVar (Maybe PortNumber),
|
||||
hostCAHash :: TMVar C.KeyHash,
|
||||
endSession :: TMVar (),
|
||||
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
|
||||
host <- getLocalAddress >>= maybe (throwError RCENoLocalAddress) pure
|
||||
c@RCHClient_ {startedPort, tlsEnded} <- liftIO mkClient
|
||||
hostKeys <- liftIO genHostKeys
|
||||
action <- liftIO $ runClient c r hostKeys
|
||||
void . forkIO $ do
|
||||
res <- atomically $ takeTMVar tlsEnded
|
||||
either (logError . ("XRCP session ended with error: " <>) . tshow) (\() -> logInfo "XRCP session ended") res
|
||||
uninterruptibleCancel action
|
||||
-- wait for the port to make invitation
|
||||
-- TODO can't we actually find to which interface the server got connected to get host there?
|
||||
portNum <- atomically $ readTMVar startedPort
|
||||
signedInv <- maybe (throwError RCETLSStartFailed) (liftIO . mkInvitation hostKeys host) portNum
|
||||
pure (signedInv, RCHostClient {action, client_ = c}, r)
|
||||
where
|
||||
mkClient :: IO RCHClient_
|
||||
mkClient = do
|
||||
startedPort <- newEmptyTMVarIO
|
||||
endSession <- newEmptyTMVarIO
|
||||
tlsEnded <- newEmptyTMVarIO
|
||||
hostCAHash <- newEmptyTMVarIO
|
||||
pure RCHClient_ {startedPort, hostCAHash, endSession, tlsEnded}
|
||||
runClient :: RCHClient_ -> RCStepTMVar (ByteString, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)) -> RCHostKeys -> IO (Async ())
|
||||
runClient RCHClient_ {startedPort, hostCAHash, endSession, tlsEnded} r hostKeys = do
|
||||
tlsCreds <- genTLSCredentials caKey caCert
|
||||
startTLSServer startedPort tlsCreds (tlsHooks r knownHost hostCAHash) $ \tls -> do
|
||||
res <- handleAny (pure . Left . RCEException . show) . runExceptT $ do
|
||||
logDebug "Incoming TLS connection"
|
||||
r' <- newEmptyTMVarIO
|
||||
atomically $ putTMVar r $ Right (tlsUniq tls, r')
|
||||
-- TODO lock session
|
||||
hostEncHello <- receiveRCPacket tls
|
||||
logDebug "Received host HELLO"
|
||||
hostCA <- atomically $ takeTMVar hostCAHash
|
||||
(ctrlEncHello, sessionKeys, helloBody, pairing') <- prepareHostSession drg hostCA pairing hostKeys hostEncHello
|
||||
sendRCPacket tls ctrlEncHello
|
||||
logDebug "Sent ctrl HELLO"
|
||||
atomically $ putTMVar r' $ Right (RCHostSession {tls, sessionKeys}, helloBody, pairing')
|
||||
-- can use `RCHostSession` until `endSession` is signalled
|
||||
logDebug "Holding session"
|
||||
atomically $ takeTMVar endSession
|
||||
logDebug $ "TLS connection finished with " <> tshow res
|
||||
atomically $ putTMVar tlsEnded res
|
||||
tlsHooks :: TMVar a -> Maybe KnownHostPairing -> TMVar C.KeyHash -> TLS.ServerHooks
|
||||
tlsHooks r knownHost_ hostCAHash =
|
||||
def
|
||||
{ TLS.onUnverifiedClientCert = pure True,
|
||||
TLS.onNewHandshake = \_ -> atomically $ isNothing <$> tryReadTMVar r,
|
||||
TLS.onClientCertificate = \(X509.CertificateChain chain) ->
|
||||
case chain of
|
||||
[_leaf, ca] -> do
|
||||
let Fingerprint fp = getFingerprint ca X509.HashSHA256
|
||||
kh = C.KeyHash fp
|
||||
atomically $ putTMVar hostCAHash kh
|
||||
let accept = maybe True (\h -> h.hostFingerprint == kh) knownHost_
|
||||
pure $ if accept then TLS.CertificateUsageAccept else TLS.CertificateUsageReject TLS.CertificateRejectUnknownCA
|
||||
_ ->
|
||||
pure $ TLS.CertificateUsageReject TLS.CertificateRejectUnknownCA
|
||||
}
|
||||
genHostKeys :: IO RCHostKeys
|
||||
genHostKeys = do
|
||||
sessKeys <- C.generateKeyPair'
|
||||
dhKeys <- C.generateKeyPair'
|
||||
pure RCHostKeys {sessKeys, dhKeys}
|
||||
mkInvitation :: RCHostKeys -> TransportHost -> PortNumber -> IO RCSignedInvitation
|
||||
mkInvitation RCHostKeys {sessKeys, dhKeys} host portNum = do
|
||||
ts <- getSystemTime
|
||||
let inv =
|
||||
RCInvitation
|
||||
{ ca = certFingerprint caCert,
|
||||
host,
|
||||
port = fromIntegral portNum,
|
||||
v = supportedRCVRange,
|
||||
app = ctrlAppInfo,
|
||||
ts,
|
||||
skey = fst sessKeys,
|
||||
idkey = C.publicKey idPrivKey,
|
||||
dh = fst dhKeys
|
||||
}
|
||||
signedInv = signInviteURL (snd sessKeys) idPrivKey inv
|
||||
pure signedInv
|
||||
|
||||
genTLSCredentials :: C.APrivateSignKey -> C.SignedCertificate -> IO TLS.Credentials
|
||||
genTLSCredentials caKey caCert = do
|
||||
let caCreds = (C.signatureKeyPair caKey, caCert)
|
||||
leaf <- genCredentials (Just caCreds) (0, 24 * 999999) "localhost" -- session-signing cert
|
||||
pure . snd $ tlsCredentials (leaf :| [caCreds])
|
||||
|
||||
certFingerprint :: X509.SignedCertificate -> C.KeyHash
|
||||
certFingerprint caCert = C.KeyHash fp
|
||||
where
|
||||
Fingerprint fp = getFingerprint caCert X509.HashSHA256
|
||||
|
||||
cancelHostClient :: RCHostClient -> IO ()
|
||||
cancelHostClient RCHostClient {action, client_ = RCHClient_ {endSession}} = do
|
||||
atomically $ putTMVar endSession ()
|
||||
uninterruptibleCancel action
|
||||
|
||||
prepareHostSession :: TVar ChaChaDRG -> C.KeyHash -> RCHostPairing -> RCHostKeys -> RCHostEncHello -> ExceptT RCErrorType IO (RCCtrlEncHello, HostSessKeys, RCHostHello, RCHostPairing)
|
||||
prepareHostSession
|
||||
drg
|
||||
tlsHostFingerprint
|
||||
pairing@RCHostPairing {idPrivKey, knownHost = knownHost_}
|
||||
RCHostKeys {sessKeys = (_, sessPrivKey), dhKeys = (_, dhPrivKey)}
|
||||
RCHostEncHello {dhPubKey, nonce, encBody} = do
|
||||
let sharedKey = kemHybridOrDHSecret dhPubKey dhPrivKey $ (\h -> h.storedSessKeys.kemSharedKey) <$> knownHost_
|
||||
helloBody <- liftEitherWith (const RCEDecrypt) $ kcbDecrypt sharedKey nonce encBody
|
||||
hostHello@RCHostHello {v, ca, kem = kemPubKey} <- liftEitherWith RCESyntax $ J.eitherDecodeStrict helloBody
|
||||
(kemCiphertext, kemSharedKey) <- liftIO $ sntrup761Enc drg kemPubKey
|
||||
let hybridKey = kemHybridSecret dhPubKey dhPrivKey kemSharedKey
|
||||
unless (isCompatible v supportedRCVRange) $ throwError RCEVersion
|
||||
let keys = HostSessKeys {hybridKey, idPrivKey, sessPrivKey}
|
||||
storedSessKeys = StoredHostSessKeys {hostDHPublicKey = dhPubKey, kemSharedKey}
|
||||
knownHost' <- updateKnownHost ca storedSessKeys
|
||||
let ctrlHello = RCCtrlHello {}
|
||||
-- TODO send error response if something fails
|
||||
nonce' <- liftIO . atomically $ C.pseudoRandomCbNonce drg
|
||||
encBody' <- liftEitherWith (const RCEBlockSize) $ kcbEncrypt hybridKey nonce' (LB.toStrict $ J.encode ctrlHello) helloBlockSize
|
||||
let ctrlEncHello = RCCtrlEncHello {kem = kemCiphertext, nonce = nonce', encBody = encBody'}
|
||||
pure (ctrlEncHello, keys, hostHello, pairing {knownHost = Just knownHost'})
|
||||
where
|
||||
updateKnownHost :: C.KeyHash -> StoredHostSessKeys -> ExceptT RCErrorType IO KnownHostPairing
|
||||
updateKnownHost ca storedSessKeys = case knownHost_ of
|
||||
Just h -> do
|
||||
unless (h.hostFingerprint == tlsHostFingerprint) . throwError $
|
||||
RCEInternal "TLS host CA is different from host pairing, should be caught in TLS handshake"
|
||||
unless (ca == tlsHostFingerprint) $ throwError RCEIdentity
|
||||
pure (h :: KnownHostPairing) {storedSessKeys}
|
||||
Nothing -> pure KnownHostPairing {hostFingerprint = ca, storedSessKeys}
|
||||
|
||||
data RCCtrlClient = RCCtrlClient
|
||||
{ action :: Async (),
|
||||
client_ :: RCCClient_
|
||||
}
|
||||
|
||||
data RCCClient_ = RCCClient_
|
||||
{ confirmSession :: TMVar Bool,
|
||||
endSession :: TMVar (),
|
||||
tlsEnded :: TMVar (Either RCErrorType ())
|
||||
}
|
||||
|
||||
type RCCtrlConnection = (RCCtrlClient, RCStepTMVar (SessionCode, RCStepTMVar (RCCtrlSession, RCCtrlPairing)))
|
||||
|
||||
connectRCCtrlURI :: TVar ChaChaDRG -> RCSignedInvitation -> Maybe RCCtrlPairing -> J.Value -> ExceptT RCErrorType IO RCCtrlConnection
|
||||
connectRCCtrlURI drg signedInv@RCSignedInvitation {invitation} pairing_ hostAppInfo = do
|
||||
unless (verifySignedInviteURI signedInv) $ throwError RCECtrlAuth
|
||||
connectRCCtrl drg invitation pairing_ hostAppInfo
|
||||
|
||||
-- app should determine whether it is a new or known pairing based on CA fingerprint in the invitation
|
||||
connectRCCtrl :: TVar ChaChaDRG -> RCInvitation -> Maybe RCCtrlPairing -> J.Value -> ExceptT RCErrorType IO RCCtrlConnection
|
||||
connectRCCtrl drg inv@RCInvitation {ca, idkey} pairing_ hostAppInfo = do
|
||||
pairing' <- maybe (liftIO newCtrlPairing) updateCtrlPairing pairing_
|
||||
connectRCCtrl_ drg pairing' inv hostAppInfo
|
||||
where
|
||||
newCtrlPairing :: IO RCCtrlPairing
|
||||
newCtrlPairing = do
|
||||
((_, caKey), caCert) <- genCredentials Nothing (0, 24 * 999999) "ca"
|
||||
(_, dhPrivKey) <- C.generateKeyPair'
|
||||
let storedSessKeys = StoredCtrlSessKeys dhPrivKey Nothing
|
||||
pure RCCtrlPairing {caKey, caCert, ctrlFingerprint = ca, idPubKey = idkey, storedSessKeys, prevStoredSessKeys = Nothing}
|
||||
updateCtrlPairing :: RCCtrlPairing -> ExceptT RCErrorType IO RCCtrlPairing
|
||||
updateCtrlPairing pairing@RCCtrlPairing {ctrlFingerprint, idPubKey, storedSessKeys = currSSK} = do
|
||||
unless (ca == ctrlFingerprint && idPubKey == idkey) $ throwError RCEIdentity
|
||||
(_, dhPrivKey) <- liftIO C.generateKeyPair'
|
||||
pure pairing {storedSessKeys = currSSK {dhPrivKey}, prevStoredSessKeys = Just currSSK}
|
||||
|
||||
connectRCCtrl_ :: TVar ChaChaDRG -> RCCtrlPairing -> RCInvitation -> J.Value -> ExceptT RCErrorType IO RCCtrlConnection
|
||||
connectRCCtrl_ drg pairing'@RCCtrlPairing {caKey, caCert} inv@RCInvitation {ca, host, port} hostAppInfo = do
|
||||
r <- newEmptyTMVarIO
|
||||
c <- liftIO mkClient
|
||||
action <- async $ runClient c r
|
||||
pure (RCCtrlClient {action, client_ = c}, r)
|
||||
where
|
||||
mkClient :: IO RCCClient_
|
||||
mkClient = do
|
||||
tlsEnded <- newEmptyTMVarIO
|
||||
confirmSession <- newEmptyTMVarIO
|
||||
endSession <- newEmptyTMVarIO
|
||||
pure RCCClient_ {confirmSession, endSession, tlsEnded}
|
||||
runClient :: RCCClient_ -> RCStepTMVar (SessionCode, RCStepTMVar (RCCtrlSession, RCCtrlPairing)) -> ExceptT RCErrorType IO ()
|
||||
runClient RCCClient_ {confirmSession, endSession, tlsEnded} r = do
|
||||
clientCredentials <-
|
||||
liftIO (genTLSCredentials caKey caCert) >>= \case
|
||||
TLS.Credentials [one] -> pure $ Just one
|
||||
_ -> throwError $ RCEInternal "genTLSCredentials must generate only one set of credentials"
|
||||
let clientConfig = defaultTransportClientConfig {clientCredentials}
|
||||
liftIO $ runTransportClient clientConfig Nothing host (show port) (Just ca) $ \tls -> do
|
||||
logDebug "Got TLS connection"
|
||||
-- TODO this seems incorrect still
|
||||
res <- handleAny (pure . Left . RCEException . show) . runExceptT $ do
|
||||
logDebug "Waiting for session confirmation"
|
||||
r' <- newEmptyTMVarIO
|
||||
atomically $ putTMVar r $ Right (tlsUniq tls, r') -- (RCCtrlSession {tls, sessionKeys = ctrlSessKeys}, pairing')
|
||||
ifM
|
||||
(atomically $ readTMVar confirmSession)
|
||||
(runSession tls r')
|
||||
(logDebug "Session rejected")
|
||||
atomically $ putTMVar tlsEnded res
|
||||
where
|
||||
runSession tls r' = do
|
||||
(sharedKey, kemPrivKey, hostEncHello) <- prepareHostHello drg pairing' inv hostAppInfo
|
||||
sendRCPacket tls hostEncHello
|
||||
ctrlEncHello <- receiveRCPacket tls
|
||||
logDebug "Received ctrl HELLO"
|
||||
(ctrlSessKeys, pairing'') <- prepareCtrlSession pairing' inv sharedKey kemPrivKey ctrlEncHello
|
||||
atomically $ putTMVar r' $ Right (RCCtrlSession {tls, sessionKeys = ctrlSessKeys}, pairing'')
|
||||
-- TODO receive OK response
|
||||
logDebug "Session started"
|
||||
-- release second putTMVar in confirmCtrlSession
|
||||
void . atomically $ takeTMVar confirmSession
|
||||
atomically $ takeTMVar endSession
|
||||
logDebug "Session ended"
|
||||
|
||||
sendRCPacket :: Encoding a => TLS -> a -> ExceptT RCErrorType IO ()
|
||||
sendRCPacket tls pkt = do
|
||||
b <- liftEitherWith (const RCEBlockSize) $ C.pad (smpEncode pkt) xrcpBlockSize
|
||||
liftIO $ cPut tls b
|
||||
|
||||
receiveRCPacket :: Encoding a => TLS -> ExceptT RCErrorType IO a
|
||||
receiveRCPacket tls = do
|
||||
b <- liftIO $ cGet tls xrcpBlockSize
|
||||
when (B.length b /= xrcpBlockSize) $ throwError RCEBlockSize
|
||||
b' <- liftEitherWith (const RCEBlockSize) $ C.unPad b
|
||||
liftEitherWith RCESyntax $ smpDecode b'
|
||||
|
||||
prepareHostHello :: TVar ChaChaDRG -> RCCtrlPairing -> RCInvitation -> J.Value -> ExceptT RCErrorType IO (KEMHybridOrDHSecret, KEMSecretKey, RCHostEncHello)
|
||||
prepareHostHello
|
||||
drg
|
||||
RCCtrlPairing {caCert, storedSessKeys = StoredCtrlSessKeys {dhPrivKey, kemSharedKey}}
|
||||
RCInvitation {v, dh = dhPubKey}
|
||||
hostAppInfo = do
|
||||
logDebug "Preparing session"
|
||||
case compatibleVersion v supportedRCVRange of
|
||||
Nothing -> throwError RCEVersion
|
||||
Just (Compatible v') -> do
|
||||
nonce <- liftIO . atomically $ C.pseudoRandomCbNonce drg
|
||||
(kemPubKey, kemPrivKey) <- liftIO $ sntrup761Keypair drg
|
||||
let Fingerprint fp = getFingerprint caCert X509.HashSHA256
|
||||
helloBody = RCHostHello {v = v', ca = C.KeyHash fp, app = hostAppInfo, kem = kemPubKey}
|
||||
sharedKey = kemHybridOrDHSecret dhPubKey dhPrivKey kemSharedKey
|
||||
encBody <- liftEitherWith (const RCEBlockSize) $ kcbEncrypt sharedKey nonce (LB.toStrict $ J.encode helloBody) helloBlockSize
|
||||
-- let sessKeys = CtrlSessKeys {hybridKey, idPubKey, sessPubKey = skey}
|
||||
let hostEncHello = RCHostEncHello {dhPubKey = C.publicKey dhPrivKey, nonce, encBody}
|
||||
pure (sharedKey, kemPrivKey, hostEncHello)
|
||||
|
||||
prepareCtrlSession :: RCCtrlPairing -> RCInvitation -> KEMHybridOrDHSecret -> KEMSecretKey -> RCCtrlEncHello -> ExceptT RCErrorType IO (CtrlSessKeys, RCCtrlPairing)
|
||||
prepareCtrlSession
|
||||
pairing@RCCtrlPairing {idPubKey, storedSessKeys = ssk@StoredCtrlSessKeys {dhPrivKey}}
|
||||
RCInvitation {skey, dh = dhPubKey}
|
||||
sharedKey
|
||||
kemPrivKey = \case
|
||||
RCCtrlEncHello {kem = kemCiphertext, nonce, encBody} -> do
|
||||
kemSharedKey <- liftIO $ sntrup761Dec kemCiphertext kemPrivKey
|
||||
let hybridKey = kemHybridSecret dhPubKey dhPrivKey kemSharedKey
|
||||
helloBody <- liftEitherWith (const RCEDecrypt) $ kcbDecrypt hybridKey nonce encBody
|
||||
logDebug "Decrypted ctrl HELLO"
|
||||
RCCtrlHello {} <- liftEitherWith RCESyntax $ J.eitherDecodeStrict helloBody
|
||||
let sessKeys = CtrlSessKeys {hybridKey, idPubKey, sessPubKey = skey}
|
||||
pairing' = (pairing :: RCCtrlPairing) {storedSessKeys = ssk {kemSharedKey = Just kemSharedKey}}
|
||||
pure (sessKeys, pairing')
|
||||
RCCtrlEncError {nonce, encMessage} -> do
|
||||
message <- liftEitherWith (const RCEDecrypt) $ kcbDecrypt sharedKey nonce encMessage
|
||||
throwError $ RCECtrlError $ T.unpack $ safeDecodeUtf8 message
|
||||
|
||||
-- The application should save updated RCHostPairing after user confirmation of the session
|
||||
-- TMVar resolves when TLS is connected
|
||||
connectKnownRCCtrlMulticast :: TVar ChaChaDRG -> TVar Int -> NonEmpty RCCtrlPairing -> J.Value -> ExceptT RCErrorType IO RCCtrlConnection
|
||||
connectKnownRCCtrlMulticast drg _subscribers pairings hostAppInfo = do
|
||||
-- start multicast
|
||||
-- receive packets
|
||||
let loop = undefined -- catch and log errors, fail on timeout
|
||||
receive = undefined
|
||||
parse = undefined
|
||||
(pairing, inv) <- loop $ receive >>= parse >>= findRCCtrlPairing pairings
|
||||
connectRCCtrl drg inv pairing hostAppInfo
|
||||
|
||||
findRCCtrlPairing :: NonEmpty RCCtrlPairing -> RCEncInvitation -> ExceptT RCErrorType IO (RCCtrlPairing, RCInvitation)
|
||||
findRCCtrlPairing pairings RCEncInvitation {dhPubKey, nonce, encInvitation} = do
|
||||
(pairing, signedInvStr) <- liftEither $ decrypt (L.toList pairings)
|
||||
signedInv@RCSignedInvitation {invitation} <- liftEitherWith RCESyntax $ smpDecode signedInvStr
|
||||
unless (verifySignedInvitationMulticast signedInv) $ throwError RCECtrlAuth
|
||||
pure (pairing, invitation)
|
||||
where
|
||||
decrypt :: [RCCtrlPairing] -> Either RCErrorType (RCCtrlPairing, ByteString)
|
||||
decrypt [] = Left RCECtrlNotFound
|
||||
decrypt (pairing@RCCtrlPairing {storedSessKeys, prevStoredSessKeys} : rest) =
|
||||
let r = decrypt_ storedSessKeys <|> (decrypt_ =<< prevStoredSessKeys)
|
||||
in maybe (decrypt rest) (Right . (pairing,)) r
|
||||
decrypt_ :: StoredCtrlSessKeys -> Maybe ByteString
|
||||
decrypt_ StoredCtrlSessKeys {dhPrivKey, kemSharedKey} =
|
||||
let key = kemHybridOrDHSecret dhPubKey dhPrivKey kemSharedKey
|
||||
in eitherToMaybe $ kcbDecrypt key nonce encInvitation
|
||||
|
||||
-- application should call this function when TMVar resolves
|
||||
confirmCtrlSession :: RCCtrlClient -> Bool -> IO ()
|
||||
confirmCtrlSession RCCtrlClient {client_ = RCCClient_ {confirmSession}} res = do
|
||||
atomically $ putTMVar confirmSession res
|
||||
-- controler does takeTMVar, freeing the slot
|
||||
-- TODO add timeout
|
||||
atomically $ putTMVar confirmSession res -- wait for Ctrl to take the var
|
||||
|
||||
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"
|
||||
@@ -1,4 +1,3 @@
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
@@ -8,24 +7,23 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
|
||||
-- XXX: remove non-discovery functions
|
||||
module Simplex.RemoteControl.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.Maybe (listToMaybe, mapMaybe)
|
||||
import Data.String (IsString)
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding (decodeUtf8)
|
||||
import Data.Time.Clock.System (getSystemTime)
|
||||
import Data.Word (Word16)
|
||||
import Network.Info (IPv4 (..), NetworkInterface (..), getNetworkInterfaces)
|
||||
import qualified Network.Socket as N
|
||||
import qualified Network.TLS as TLS
|
||||
import qualified Network.UDP as UDP
|
||||
import Simplex.RemoteControl.Discovery.Multicast (setMembership)
|
||||
import Simplex.RemoteControl.Types
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding (Encoding (..))
|
||||
import Simplex.Messaging.Encoding.String (StrEncoding (..))
|
||||
@@ -34,7 +32,9 @@ import qualified Simplex.Messaging.Transport as Transport
|
||||
import Simplex.Messaging.Transport.Client (TransportHost (..), defaultTransportClientConfig, runTransportClient)
|
||||
import Simplex.Messaging.Transport.Server (defaultTransportServerConfig, runTransportServerSocket, startTCPServer)
|
||||
import Simplex.Messaging.Util (ifM, tshow)
|
||||
import Simplex.Messaging.Version (mkVersionRange)
|
||||
import Simplex.Messaging.Version (VersionRange)
|
||||
import Simplex.RemoteControl.Discovery.Multicast (setMembership)
|
||||
import Simplex.RemoteControl.Types
|
||||
import UnliftIO
|
||||
import UnliftIO.Concurrent
|
||||
|
||||
@@ -48,39 +48,18 @@ 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 => m (Maybe TransportHost)
|
||||
getLocalAddress = listToMaybe . mapMaybe usable <$> liftIO getNetworkInterfaces
|
||||
where
|
||||
usable NetworkInterface {ipv4 = IPv4 ha} = case N.hostAddressToTuple ha of
|
||||
(0, 0, 0, 0) -> Nothing -- "no" address
|
||||
(255, 255, 255, 255) -> Nothing -- broadcast
|
||||
(127, _, _, _) -> Nothing -- localhost
|
||||
(169, 254, _, _) -> Nothing -- link-local
|
||||
ok -> Just $ THIPv4 ok
|
||||
|
||||
getLocalAddress :: MonadIO m => TMVar Int -> m (Maybe N.HostAddress)
|
||||
getLocalAddress subscribers = liftIO $ do
|
||||
getLocalAddressMulticast :: MonadIO m => TMVar Int -> m (Maybe TransportHost)
|
||||
getLocalAddressMulticast subscribers = liftIO $ do
|
||||
probe <- mkIpProbe
|
||||
let bytes = smpEncode probe
|
||||
withListener subscribers $ \receiver ->
|
||||
@@ -89,7 +68,7 @@ getLocalAddress subscribers = liftIO $ do
|
||||
let expect = do
|
||||
UDP.recvFrom receiver >>= \case
|
||||
(p, _) | p /= bytes -> expect
|
||||
(_, UDP.ClientSockAddr (N.SockAddrInet _port host) _cmsg) -> pure host
|
||||
(_, UDP.ClientSockAddr (N.SockAddrInet _port host) _cmsg) -> pure $ THIPv4 (N.hostAddressToTuple host)
|
||||
(_, UDP.ClientSockAddr _badAddr _) -> error "receiving from IPv4 socket"
|
||||
timeout 1000000 expect
|
||||
|
||||
@@ -101,57 +80,77 @@ mkIpProbe = do
|
||||
-- | 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.
|
||||
announceCtrl :: MonadUnliftIO m => (MVar () -> MVar rc -> Transport.TLS -> IO ()) -> Tasks -> (C.PrivateKeyEd25519, Announce) -> TLS.Credentials -> m () -> m rc
|
||||
announceCtrl runCtrl tasks (sigKey, announce@Announce {caFingerprint, serviceAddress=(host, _port)}) credentials finishAction = do
|
||||
announceCtrl ::
|
||||
MonadUnliftIO m =>
|
||||
(MVar rc -> MVar () -> Transport.TLS -> IO ()) ->
|
||||
Tasks ->
|
||||
TMVar (Maybe N.PortNumber) ->
|
||||
Maybe (Text, VersionRange) ->
|
||||
Maybe Text ->
|
||||
C.PrivateKeyEd25519 ->
|
||||
CtrlSessionKeys ->
|
||||
-- | Session address to announce
|
||||
TransportHost ->
|
||||
m () ->
|
||||
m rc
|
||||
announceCtrl runCtrl tasks started app_ device_ idkey sk@CtrlSessionKeys {ca, credentials} host finishAction = do
|
||||
ctrlStarted <- newEmptyMVar
|
||||
started <- newEmptyTMVarIO
|
||||
ctrlFinished <- newEmptyMVar
|
||||
_ <- forkIO $ readMVar ctrlFinished >> 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)})
|
||||
announcer <-
|
||||
async . liftIO $
|
||||
atomically (readTMVar started) >>= \case
|
||||
Nothing -> pure () -- TLS server failed to start, skipping announcer
|
||||
Just givenPort -> do
|
||||
logInfo $ "Starting announcer for " <> ident <> " at " <> tshow (host, givenPort)
|
||||
runAnnouncer app_ device_ idkey sk (host, givenPort) -- (sigKey, announce {serviceAddress = (host, fromIntegral givenPort)})
|
||||
tasks `registerAsync` announcer
|
||||
tlsServer <- startTLSServer started credentials $ \tls -> do
|
||||
let hooks = undefined -- TODO
|
||||
tlsServer <- startTLSServer started credentials hooks $ \tls -> do
|
||||
logInfo $ "Incoming connection for " <> ident
|
||||
cancel announcer
|
||||
runCtrl ctrlFinished ctrlStarted tls `catchAny` (logError . tshow)
|
||||
runCtrl ctrlStarted ctrlFinished tls `catchAny` (logError . tshow)
|
||||
logInfo $ "Client finished for " <> ident
|
||||
_ <- forkIO $ waitCatch tlsServer >> void (tryPutMVar ctrlFinished ())
|
||||
tasks `registerAsync` tlsServer
|
||||
logInfo $ "Waiting for client for " <> ident
|
||||
readMVar ctrlStarted
|
||||
where
|
||||
ident = decodeUtf8 $ strEncode caFingerprint
|
||||
ident = decodeUtf8 $ strEncode ca
|
||||
|
||||
runAnnouncer :: Maybe (Text, VersionRange) -> Maybe Text -> C.PrivateKeyEd25519 -> CtrlSessionKeys -> (TransportHost, N.PortNumber) -> IO ()
|
||||
runAnnouncer app_ device_ idSigKey sk (host, port) = error "runAnnouncer: make invites, encrypt and send"
|
||||
|
||||
-- | 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
|
||||
-- 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 ->
|
||||
-- XXX: move to RemoteControl.Client
|
||||
startTLSServer :: MonadUnliftIO m => TMVar (Maybe N.PortNumber) -> TLS.Credentials -> TLS.ServerHooks -> (Transport.TLS -> IO ()) -> m (Async ())
|
||||
startTLSServer startedOnPort credentials hooks server = async . liftIO $ do
|
||||
started <- newEmptyTMVarIO
|
||||
bracketOnError (startTCPServer started "0") (\_e -> setPort 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)
|
||||
(atomically $ readTMVar started)
|
||||
(runServer started socket)
|
||||
(setPort Nothing)
|
||||
where
|
||||
runServer started socket = do
|
||||
port <- N.socketPort socket
|
||||
logInfo $ "System-assigned port: " <> tshow port
|
||||
setPort $ Just port
|
||||
runTransportServerSocket started (pure socket) "RCP TLS" serverParams defaultTransportServerConfig server
|
||||
setPort = void . atomically . tryPutTMVar startedOnPort
|
||||
serverParams =
|
||||
def
|
||||
{ TLS.serverWantClientCert = False,
|
||||
{ TLS.serverWantClientCert = True,
|
||||
TLS.serverShared = def {TLS.sharedCredentials = credentials},
|
||||
TLS.serverHooks = def,
|
||||
TLS.serverHooks = hooks,
|
||||
TLS.serverSupported = supportedParameters
|
||||
}
|
||||
|
||||
@@ -171,8 +170,9 @@ openListener subscribers = liftIO $ do
|
||||
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
|
||||
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
|
||||
@@ -195,10 +195,19 @@ 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 :: MonadIO m => UDP.ListenSocket -> m (N.SockAddr, ByteString)
|
||||
recvAnnounce sock = liftIO $ do
|
||||
(invite, UDP.ClientSockAddr source _cmsg) <- UDP.recvFrom sock
|
||||
pure (source, invite)
|
||||
|
||||
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)
|
||||
connectTLSClient ::
|
||||
MonadUnliftIO m =>
|
||||
(TransportHost, Word16) ->
|
||||
HostSessionKeys ->
|
||||
(HostCryptoHandle -> Transport.TLS -> m a) ->
|
||||
m a
|
||||
connectTLSClient (host, port) HostSessionKeys {ca} client =
|
||||
runTransportClient defaultTransportClientConfig Nothing host (show port) (Just ca) $ \tls -> do
|
||||
-- TODO: set up host side using
|
||||
let hch = HostCryptoHandle
|
||||
client hch tls
|
||||
|
||||
@@ -0,0 +1,176 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module Simplex.RemoteControl.Invitation where
|
||||
|
||||
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
|
||||
import Data.Time.Clock.System (SystemTime)
|
||||
import Data.Word (Word16)
|
||||
import Network.HTTP.Types (parseSimpleQuery)
|
||||
import Network.HTTP.Types.URI (SimpleQuery, renderSimpleQuery, urlDecode)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers (defaultJSON, parseAll)
|
||||
import Simplex.Messaging.Transport.Client (TransportHost)
|
||||
import Simplex.Messaging.Version (VersionRange)
|
||||
|
||||
data RCInvitation = RCInvitation
|
||||
{ -- | CA TLS certificate fingerprint of the controller.
|
||||
--
|
||||
-- This is part of long term identity of the controller established during the first session, and repeated in the subsequent session announcements.
|
||||
ca :: C.KeyHash,
|
||||
host :: TransportHost,
|
||||
port :: Word16,
|
||||
-- | Supported version range for remote control protocol
|
||||
v :: VersionRange,
|
||||
-- | Application information
|
||||
app :: J.Value,
|
||||
-- | Session start time in seconds since epoch
|
||||
ts :: SystemTime,
|
||||
-- | Session Ed25519 public key used to verify the announcement and commands
|
||||
--
|
||||
-- This mitigates the compromise of the long term signature key, as the controller will have to sign each command with this key first.
|
||||
skey :: C.PublicKeyEd25519,
|
||||
-- | Long-term Ed25519 public key used to verify the announcement and commands.
|
||||
--
|
||||
-- Is apart of the long term controller identity.
|
||||
idkey :: C.PublicKeyEd25519,
|
||||
-- | Session X25519 DH key
|
||||
dh :: C.PublicKeyX25519
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
instance StrEncoding RCInvitation where
|
||||
strEncode RCInvitation {ca, host, port, v, app, ts, skey, idkey, dh} =
|
||||
mconcat
|
||||
[ "xrcp:/",
|
||||
strEncode ca,
|
||||
"@",
|
||||
strEncode host,
|
||||
":",
|
||||
strEncode port,
|
||||
"#/?",
|
||||
renderSimpleQuery False query
|
||||
]
|
||||
where
|
||||
query =
|
||||
[ ("v", strEncode v),
|
||||
("app", LB.toStrict $ J.encode app),
|
||||
("ts", strEncode ts),
|
||||
("skey", strEncode skey),
|
||||
("idkey", strEncode idkey),
|
||||
("dh", strEncode dh)
|
||||
]
|
||||
|
||||
strP = do
|
||||
_ <- A.string "xrcp:/"
|
||||
ca <- strP
|
||||
_ <- A.char '@'
|
||||
host <- A.takeWhile (/= ':') >>= either fail pure . strDecode . urlDecode True
|
||||
_ <- A.char ':'
|
||||
port <- strP
|
||||
_ <- A.string "#/?"
|
||||
|
||||
q <- parseSimpleQuery <$> A.takeWhile (/= ' ')
|
||||
v <- requiredP q "v" strDecode
|
||||
app <- requiredP q "app" $ J.eitherDecodeStrict . urlDecode True
|
||||
ts <- requiredP q "ts" $ strDecode . urlDecode True
|
||||
skey <- requiredP q "skey" $ parseAll strP
|
||||
idkey <- requiredP q "idkey" $ parseAll strP
|
||||
dh <- requiredP q "dh" $ parseAll strP
|
||||
pure RCInvitation {ca, host, port, v, app, ts, skey, idkey, dh}
|
||||
|
||||
data RCSignedInvitation = RCSignedInvitation
|
||||
{ invitation :: RCInvitation,
|
||||
ssig :: C.Signature 'C.Ed25519,
|
||||
idsig :: C.Signature 'C.Ed25519
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
-- | URL-encoded and signed for showing in QR code
|
||||
instance StrEncoding RCSignedInvitation where
|
||||
strEncode RCSignedInvitation {invitation, ssig, idsig} =
|
||||
mconcat
|
||||
[ strEncode invitation,
|
||||
"&ssig=",
|
||||
strEncode $ C.signatureBytes ssig,
|
||||
"&idsig=",
|
||||
strEncode $ C.signatureBytes idsig
|
||||
]
|
||||
|
||||
strP = do
|
||||
-- TODO this assumes some order or parameters, can be made independent
|
||||
(url, invitation) <- A.match strP
|
||||
sigs <- case B.breakSubstring "&ssig=" url of
|
||||
(_, sigs) | B.null sigs -> fail "missing signatures"
|
||||
(_, sigs) -> pure $ parseSimpleQuery $ B.drop 1 sigs
|
||||
ssig <- requiredP sigs "ssig" $ parseAll strP
|
||||
idsig <- requiredP sigs "idsig" $ parseAll strP
|
||||
pure RCSignedInvitation {invitation, ssig, idsig}
|
||||
|
||||
signInviteURL :: C.PrivateKey C.Ed25519 -> C.PrivateKey C.Ed25519 -> RCInvitation -> RCSignedInvitation
|
||||
signInviteURL sKey idKey invitation = RCSignedInvitation {invitation, ssig, idsig}
|
||||
where
|
||||
inviteUrl = strEncode invitation
|
||||
ssig =
|
||||
case C.sign (C.APrivateSignKey C.SEd25519 sKey) inviteUrl of
|
||||
C.ASignature C.SEd25519 s -> s
|
||||
_ -> error "signing with ed25519"
|
||||
inviteUrlSigned = mconcat [inviteUrl, "&ssig=", strEncode ssig]
|
||||
idsig =
|
||||
case C.sign (C.APrivateSignKey C.SEd25519 idKey) inviteUrlSigned of
|
||||
C.ASignature C.SEd25519 s -> s
|
||||
_ -> error "signing with ed25519"
|
||||
|
||||
verifySignedInviteURI :: RCSignedInvitation -> Bool
|
||||
verifySignedInviteURI RCSignedInvitation {invitation, ssig, idsig} =
|
||||
C.verify aSKey aSSig inviteURL && C.verify aIdKey aIdSig inviteURLS
|
||||
where
|
||||
RCInvitation {skey, idkey} = invitation
|
||||
inviteURL = strEncode invitation
|
||||
inviteURLS = mconcat [inviteURL, "&ssig=", strEncode ssig]
|
||||
aSKey = C.APublicVerifyKey C.SEd25519 skey
|
||||
aSSig = C.ASignature C.SEd25519 ssig
|
||||
aIdKey = C.APublicVerifyKey C.SEd25519 idkey
|
||||
aIdSig = C.ASignature C.SEd25519 idsig
|
||||
|
||||
instance Encoding RCSignedInvitation where
|
||||
smpEncode RCSignedInvitation {} = error "TODO: RCSignedInvitation.smpEncode"
|
||||
smpP = error "TODO: RCSignedInvitation.smpP"
|
||||
|
||||
verifySignedInvitationMulticast :: RCSignedInvitation -> Bool
|
||||
verifySignedInvitationMulticast RCSignedInvitation {invitation, ssig, idsig} = undefined
|
||||
|
||||
data RCEncInvitation = RCEncInvitation
|
||||
{ dhPubKey :: C.PublicKeyX25519,
|
||||
nonce :: C.CbNonce,
|
||||
encInvitation :: ByteString
|
||||
}
|
||||
|
||||
instance Encoding RCEncInvitation where
|
||||
smpEncode RCEncInvitation {dhPubKey, nonce, encInvitation} =
|
||||
smpEncode (dhPubKey, nonce, Tail encInvitation)
|
||||
smpP = do
|
||||
(dhPubKey, nonce, Tail encInvitation) <- smpP
|
||||
pure RCEncInvitation {dhPubKey, nonce, encInvitation}
|
||||
|
||||
-- * Utils
|
||||
|
||||
requiredP :: MonadFail m => SimpleQuery -> ByteString -> (ByteString -> Either String a) -> m a
|
||||
requiredP q k f = maybe (fail $ "missing " <> show k) (either fail pure . f) $ lookup k q
|
||||
|
||||
-- optionalP :: MonadFail m => SimpleQuery -> ByteString -> (ByteString -> Either String a) -> m (Maybe a)
|
||||
-- optionalP q k f = maybe (pure Nothing) (either fail (pure . Just) . f) $ lookup k q
|
||||
|
||||
$(JQ.deriveJSON defaultJSON ''RCInvitation)
|
||||
+100
-148
@@ -2,190 +2,140 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
|
||||
module Simplex.RemoteControl.Types where
|
||||
|
||||
import Control.Monad
|
||||
import Crypto.Error (eitherCryptoError)
|
||||
import qualified Crypto.PubKey.Ed25519 as Ed25519
|
||||
import Crypto.Random (ChaChaDRG)
|
||||
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.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 Data.List.NonEmpty (NonEmpty (..))
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import Data.Time.Clock.System (SystemTime, getSystemTime)
|
||||
import qualified Network.TLS as TLS
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding (Encoding (..))
|
||||
import Simplex.Messaging.Encoding.String (StrEncoding (..))
|
||||
import Simplex.Messaging.Crypto.SNTRUP761.Bindings (KEMPublicKey, KEMSecretKey, sntrup761Keypair)
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
|
||||
import Simplex.Messaging.Transport.Credentials (genCredentials, tlsCredentials)
|
||||
import Simplex.Messaging.Util (safeDecodeUtf8)
|
||||
import Simplex.Messaging.Version (VersionRange, mkVersionRange)
|
||||
import UnliftIO
|
||||
|
||||
data RCErrorType
|
||||
= RCEInternal {internalErr :: String}
|
||||
| RCEIdentity
|
||||
| RCENoLocalAddress
|
||||
| RCETLSStartFailed
|
||||
| RCEException {exception :: String}
|
||||
| RCECtrlAuth
|
||||
| RCECtrlNotFound
|
||||
| RCECtrlError {ctrlErr :: String}
|
||||
| RCEVersion
|
||||
| RCEDecrypt
|
||||
| RCEBlockSize
|
||||
| RCESyntax {syntaxErr :: String}
|
||||
deriving (Eq, Show, Exception)
|
||||
|
||||
instance StrEncoding RCErrorType where
|
||||
strEncode = \case
|
||||
RCEInternal err -> "INTERNAL" <> text err
|
||||
RCEIdentity -> "IDENTITY"
|
||||
RCENoLocalAddress -> "NO_LOCAL_ADDR"
|
||||
RCETLSStartFailed -> "CTRL_TLS_START"
|
||||
RCEException err -> "EXCEPTION" <> text err
|
||||
RCECtrlAuth -> "CTRL_AUTH"
|
||||
RCECtrlNotFound -> "CTRL_NOT_FOUND"
|
||||
RCECtrlError err -> "CTRL_ERROR" <> text err
|
||||
RCEVersion -> "VERSION"
|
||||
RCEDecrypt -> "DECRYPT"
|
||||
RCEBlockSize -> "BLOCK_SIZE"
|
||||
RCESyntax err -> "SYNTAX" <> text err
|
||||
where
|
||||
text = (" " <>) . encodeUtf8 . T.pack
|
||||
strP =
|
||||
A.takeTill (== ' ') >>= \case
|
||||
"INTERNAL" -> RCEInternal <$> textP
|
||||
"IDENTITY" -> pure RCEIdentity
|
||||
"NO_LOCAL_ADDR" -> pure RCENoLocalAddress
|
||||
"CTRL_TLS_START" -> pure RCETLSStartFailed
|
||||
"EXCEPTION" -> RCEException <$> textP
|
||||
"CTRL_AUTH" -> pure RCECtrlAuth
|
||||
"CTRL_NOT_FOUND" -> pure RCECtrlNotFound
|
||||
"CTRL_ERROR" -> RCECtrlError <$> textP
|
||||
"VERSION" -> pure RCEVersion
|
||||
"DECRYPT" -> pure RCEDecrypt
|
||||
"BLOCK_SIZE" -> pure RCEBlockSize
|
||||
"SYNTAX" -> RCESyntax <$> textP
|
||||
_ -> fail "bad RCErrorType"
|
||||
where
|
||||
textP = T.unpack . safeDecodeUtf8 <$> (A.space *> A.takeByteString)
|
||||
|
||||
-- * Discovery
|
||||
|
||||
ipProbeVersionRange :: VersionRange
|
||||
ipProbeVersionRange = mkVersionRange 1 1
|
||||
|
||||
data IpProbe = IpProbe
|
||||
{ versionRange :: VersionRange,
|
||||
randomNonce :: ByteString
|
||||
} deriving (Show)
|
||||
}
|
||||
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
|
||||
-- * Controller
|
||||
|
||||
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=
|
||||
-- | A bunch of keys that should be generated by a controller to start a new remote session and produce invites
|
||||
data CtrlSessionKeys = CtrlSessionKeys
|
||||
{ ts :: SystemTime,
|
||||
ca :: C.KeyHash,
|
||||
credentials :: TLS.Credentials,
|
||||
sSigKey :: C.PrivateKeyEd25519,
|
||||
dhKey :: C.PrivateKeyX25519,
|
||||
kem :: (KEMPublicKey, KEMSecretKey)
|
||||
}
|
||||
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]
|
||||
newCtrlSessionKeys :: TVar ChaChaDRG -> (C.APrivateSignKey, C.SignedCertificate) -> IO CtrlSessionKeys
|
||||
newCtrlSessionKeys rng (caKey, caCert) = do
|
||||
ts <- getSystemTime
|
||||
(_, C.APrivateDhKey C.SX25519 dhKey) <- C.generateDhKeyPair C.SX25519
|
||||
(_, C.APrivateSignKey C.SEd25519 sSigKey) <- C.generateSignatureKeyPair C.SEd25519
|
||||
|
||||
strP = do
|
||||
_ <- A.string "xrcp://"
|
||||
caFingerprint <- strP
|
||||
_ <- A.char ':'
|
||||
authToken <- decodeUtf8Lenient <$> A.takeWhile (/= '@')
|
||||
_ <- A.char '@'
|
||||
host <- decodeUtf8Lenient <$> A.takeWhile (/= ':')
|
||||
_ <- A.char ':'
|
||||
port <- strP
|
||||
let parent = (C.signatureKeyPair caKey, caCert)
|
||||
sessionCreds <- genCredentials (Just parent) (0, 24) "Session"
|
||||
let (ca, credentials) = tlsCredentials $ sessionCreds :| [parent]
|
||||
kem <- sntrup761Keypair rng
|
||||
|
||||
_ <- 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}
|
||||
pure CtrlSessionKeys {ts, ca, credentials, sSigKey, dhKey, kem}
|
||||
|
||||
data SignedOOB = SignedOOB OOB (C.Signature 'C.Ed25519)
|
||||
deriving (Eq, Show)
|
||||
data CtrlCryptoHandle = CtrlCryptoHandle
|
||||
|
||||
instance StrEncoding SignedOOB where
|
||||
strEncode (SignedOOB oob sig) = strEncode oob <> "&sig=" <> strEncode (C.signatureBytes sig)
|
||||
-- TODO
|
||||
|
||||
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)
|
||||
-- * Host
|
||||
|
||||
-- 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
|
||||
data HostSessionKeys = HostSessionKeys
|
||||
{ ca :: C.KeyHash
|
||||
-- TODO
|
||||
}
|
||||
|
||||
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"
|
||||
data HostCryptoHandle = HostCryptoHandle
|
||||
|
||||
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
|
||||
-- TODO
|
||||
|
||||
decodeOOBLink :: Text -> Either String OOB
|
||||
decodeOOBLink = fmap (\(SignedOOB oob _verified) -> oob) . strDecode . encodeUtf8
|
||||
-- * Utils
|
||||
|
||||
-- XXX: Move to utils?
|
||||
type Tasks = TVar [Async ()]
|
||||
|
||||
asyncRegistered :: MonadUnliftIO m => Tasks -> m () -> m ()
|
||||
@@ -194,5 +144,7 @@ asyncRegistered tasks action = async action >>= registerAsync tasks
|
||||
registerAsync :: MonadIO m => Tasks -> Async () -> m ()
|
||||
registerAsync tasks = atomically . modifyTVar tasks . (:)
|
||||
|
||||
cancelTasks :: (MonadIO m) => Tasks -> m ()
|
||||
cancelTasks :: MonadIO m => Tasks -> m ()
|
||||
cancelTasks tasks = readTVarIO tasks >>= mapM_ cancel
|
||||
|
||||
$(J.deriveJSON (sumTypeJSON $ dropPrefix "RCE") ''RCErrorType)
|
||||
|
||||
Reference in New Issue
Block a user