mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-03-30 16:26:02 +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
528
src/Simplex/RemoteControl/Client.hs
Normal file
528
src/Simplex/RemoteControl/Client.hs
Normal file
@@ -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
|
||||
|
||||
176
src/Simplex/RemoteControl/Invitation.hs
Normal file
176
src/Simplex/RemoteControl/Invitation.hs
Normal file
@@ -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)
|
||||
@@ -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