From 8e2ffcb2977070c86a7f0a0acb133145d0ccc8a6 Mon Sep 17 00:00:00 2001 From: Alexander Bondarenko <486682+dpwiz@users.noreply.github.com> Date: Tue, 31 Oct 2023 21:31:53 +0200 Subject: [PATCH 01/16] extract xrcp protocol (#878) * xrcp: files and folders * extract remote up to rev-http * Remove unused files --------- Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> --- package.yaml | 1 + simplexmq.cabal | 12 +- src/Simplex/RemoteControl/Discovery.hs | 204 ++++++++++++++++++ .../RemoteControl/Discovery/Multicast.hsc | 48 +++++ src/Simplex/RemoteControl/Types.hs | 198 +++++++++++++++++ 5 files changed, 462 insertions(+), 1 deletion(-) create mode 100644 src/Simplex/RemoteControl/Discovery.hs create mode 100644 src/Simplex/RemoteControl/Discovery/Multicast.hsc create mode 100644 src/Simplex/RemoteControl/Types.hs diff --git a/package.yaml b/package.yaml index 3b00c8552..9f2aa77cb 100644 --- a/package.yaml +++ b/package.yaml @@ -51,6 +51,7 @@ dependencies: - mtl == 2.3.* - network >= 3.1.2.7 && < 3.2 - network-transport == 0.5.6 + - network-udp >= 0.0 && < 0.1 - optparse-applicative >= 0.15 && < 0.17 - process == 1.6.* - random >= 1.1 && < 1.3 diff --git a/simplexmq.cabal b/simplexmq.cabal index 7ad59b427..84450caf7 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.2. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack @@ -141,6 +141,9 @@ library Simplex.Messaging.Transport.WebSockets Simplex.Messaging.Util Simplex.Messaging.Version + Simplex.RemoteControl.Discovery + Simplex.RemoteControl.Discovery.Multicast + Simplex.RemoteControl.Types other-modules: Paths_simplexmq hs-source-dirs: @@ -176,6 +179,7 @@ library , mtl ==2.3.* , network >=3.1.2.7 && <3.2 , network-transport ==0.5.6 + , network-udp ==0.0.* , optparse-applicative >=0.15 && <0.17 , process ==1.6.* , random >=1.1 && <1.3 @@ -239,6 +243,7 @@ executable ntf-server , mtl ==2.3.* , network >=3.1.2.7 && <3.2 , network-transport ==0.5.6 + , network-udp ==0.0.* , optparse-applicative >=0.15 && <0.17 , process ==1.6.* , random >=1.1 && <1.3 @@ -303,6 +308,7 @@ executable smp-agent , mtl ==2.3.* , network >=3.1.2.7 && <3.2 , network-transport ==0.5.6 + , network-udp ==0.0.* , optparse-applicative >=0.15 && <0.17 , process ==1.6.* , random >=1.1 && <1.3 @@ -367,6 +373,7 @@ executable smp-server , mtl ==2.3.* , network >=3.1.2.7 && <3.2 , network-transport ==0.5.6 + , network-udp ==0.0.* , optparse-applicative >=0.15 && <0.17 , process ==1.6.* , random >=1.1 && <1.3 @@ -431,6 +438,7 @@ executable xftp , mtl ==2.3.* , network >=3.1.2.7 && <3.2 , network-transport ==0.5.6 + , network-udp ==0.0.* , optparse-applicative >=0.15 && <0.17 , process ==1.6.* , random >=1.1 && <1.3 @@ -495,6 +503,7 @@ executable xftp-server , mtl ==2.3.* , network >=3.1.2.7 && <3.2 , network-transport ==0.5.6 + , network-udp ==0.0.* , optparse-applicative >=0.15 && <0.17 , process ==1.6.* , random >=1.1 && <1.3 @@ -594,6 +603,7 @@ test-suite simplexmq-test , mtl ==2.3.* , network >=3.1.2.7 && <3.2 , network-transport ==0.5.6 + , network-udp ==0.0.* , optparse-applicative >=0.15 && <0.17 , process ==1.6.* , random >=1.1 && <1.3 diff --git a/src/Simplex/RemoteControl/Discovery.hs b/src/Simplex/RemoteControl/Discovery.hs new file mode 100644 index 000000000..e085efa67 --- /dev/null +++ b/src/Simplex/RemoteControl/Discovery.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} + +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.String (IsString) +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8) +import Data.Time.Clock.System (getSystemTime) +import Data.Word (Word16) +import qualified Network.Socket as N +import qualified Network.TLS as TLS +import qualified Network.UDP as UDP +import Simplex.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 (..)) +import Simplex.Messaging.Transport (supportedParameters) +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 UnliftIO +import UnliftIO.Concurrent + +-- | mDNS multicast group +pattern MULTICAST_ADDR_V4 :: (IsString a, Eq a) => a +pattern MULTICAST_ADDR_V4 = "224.0.0.251" + +pattern ANY_ADDR_V4 :: (IsString a, Eq a) => a +pattern ANY_ADDR_V4 = "0.0.0.0" + +pattern DISCOVERY_PORT :: (IsString a, Eq a) => a +pattern DISCOVERY_PORT = "5227" + +startSession :: MonadIO m => Maybe Text -> (N.HostAddress, Word16) -> C.KeyHash -> m ((C.APublicDhKey, C.APrivateDhKey), C.PrivateKeyEd25519, Announce, SignedOOB) +startSession deviceName serviceAddress caFingerprint = liftIO $ do + sessionStart <- getSystemTime + dh@(C.APublicDhKey C.SX25519 sessionDH, _) <- C.generateDhKeyPair C.SX25519 + (C.APublicVerifyKey C.SEd25519 sigPubKey, C.APrivateSignKey C.SEd25519 sigSecretKey) <- C.generateSignatureKeyPair C.SEd25519 + let + announce = + Announce + { versionRange = announceVersionRange, + sessionStart, + announceCounter = 0, + serviceAddress, + caFingerprint, + sessionDH, + announceKey = sigPubKey + } + authToken <- decodeUtf8 . B64U.encode <$> getRandomBytes 12 + let + oob = + OOB + { caFingerprint, + authToken, + host = decodeUtf8 . strEncode $ THIPv4 . N.hostAddressToTuple $ fst serviceAddress, + port = snd serviceAddress, + version = mkVersionRange 1 1, + appName = "simplex-chat", + sigPubKey, + deviceName + } + pure (dh, sigSecretKey, announce, signOOB sigSecretKey oob) + +getLocalAddress :: MonadIO m => TMVar Int -> m (Maybe N.HostAddress) +getLocalAddress subscribers = liftIO $ do + probe <- mkIpProbe + let bytes = smpEncode probe + withListener subscribers $ \receiver -> + withSender $ \sender -> do + UDP.send sender bytes + let expect = do + UDP.recvFrom receiver >>= \case + (p, _) | p /= bytes -> expect + (_, UDP.ClientSockAddr (N.SockAddrInet _port host) _cmsg) -> pure host + (_, UDP.ClientSockAddr _badAddr _) -> error "receiving from IPv4 socket" + timeout 1000000 expect + +mkIpProbe :: MonadIO m => m IpProbe +mkIpProbe = do + randomNonce <- liftIO $ getRandomBytes 32 + pure IpProbe {versionRange = ipProbeVersionRange, randomNonce} + +-- | Announce tls server, wait for connection and attach http2 client to it. +-- +-- Announcer is started when TLS server is started and stopped when a connection is made. +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 + 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)}) + tasks `registerAsync` announcer + tlsServer <- startTLSServer started credentials $ \tls -> do + logInfo $ "Incoming connection for " <> ident + cancel announcer + runCtrl ctrlFinished ctrlStarted 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 + +-- | Send replay-proof announce datagrams +runAnnouncer :: (C.PrivateKeyEd25519, Announce) -> IO () +runAnnouncer (announceKey, initialAnnounce) = withSender $ loop initialAnnounce + where + loop announce sock = do + UDP.send sock $ smpEncode (signAnnounce announceKey announce) + threadDelay 1000000 + loop announce {announceCounter = announceCounter announce + 1} sock + +startTLSServer :: (MonadUnliftIO m) => TMVar (Maybe N.PortNumber) -> TLS.Credentials -> (Transport.TLS -> IO ()) -> m (Async ()) +startTLSServer started credentials server = async . liftIO $ do + startedOk <- newEmptyTMVarIO + bracketOnError (startTCPServer startedOk "0") (\_e -> void . atomically $ tryPutTMVar started Nothing) $ \socket -> + ifM + (atomically $ readTMVar startedOk) + do + port <- N.socketPort socket + logInfo $ "System-assigned port: " <> tshow port + atomically $ putTMVar started (Just port) + runTransportServerSocket startedOk (pure socket) "RCP TLS" serverParams defaultTransportServerConfig server + (void . atomically $ tryPutTMVar started Nothing) + where + serverParams = + def + { TLS.serverWantClientCert = False, + TLS.serverShared = def {TLS.sharedCredentials = credentials}, + TLS.serverHooks = def, + TLS.serverSupported = supportedParameters + } + +withSender :: MonadUnliftIO m => (UDP.UDPSocket -> m a) -> m a +withSender = bracket (liftIO $ UDP.clientSocket MULTICAST_ADDR_V4 DISCOVERY_PORT False) (liftIO . UDP.close) + +withListener :: MonadUnliftIO m => TMVar Int -> (UDP.ListenSocket -> m a) -> m a +withListener subscribers = bracket (openListener subscribers) (closeListener subscribers) + +openListener :: MonadIO m => TMVar Int -> m UDP.ListenSocket +openListener subscribers = liftIO $ do + sock <- UDP.serverSocket (MULTICAST_ADDR_V4, read DISCOVERY_PORT) + logDebug $ "Discovery listener socket: " <> tshow sock + let raw = UDP.listenSocket sock + -- N.setSocketOption raw N.Broadcast 1 + joinMulticast subscribers raw (listenerHostAddr4 sock) + pure sock + +closeListener :: MonadIO m => TMVar Int -> UDP.ListenSocket -> m () +closeListener subscribers sock = liftIO $ + partMulticast subscribers (UDP.listenSocket sock) (listenerHostAddr4 sock) `finally` UDP.stop sock + +joinMulticast :: TMVar Int -> N.Socket -> N.HostAddress -> IO () +joinMulticast subscribers sock group = do + now <- atomically $ takeTMVar subscribers + when (now == 0) $ do + setMembership sock group True >>= \case + Left e -> atomically (putTMVar subscribers now) >> logError ("setMembership failed " <> tshow e) + Right () -> atomically $ putTMVar subscribers (now + 1) + +partMulticast :: TMVar Int -> N.Socket -> N.HostAddress -> IO () +partMulticast subscribers sock group = do + now <- atomically $ takeTMVar subscribers + when (now == 1) $ + setMembership sock group False >>= \case + Left e -> atomically (putTMVar subscribers now) >> logError ("setMembership failed " <> tshow e) + Right () -> atomically $ putTMVar subscribers (now - 1) + +listenerHostAddr4 :: UDP.ListenSocket -> N.HostAddress +listenerHostAddr4 sock = case UDP.mySockAddr sock of + N.SockAddrInet _port host -> host + _ -> error "MULTICAST_ADDR_V4 is V4" + +recvAnnounce :: (MonadIO m) => UDP.ListenSocket -> m (N.SockAddr, ByteString) +recvAnnounce sock = liftIO $ do + (invite, UDP.ClientSockAddr source _cmsg) <- UDP.recvFrom sock + pure (source, invite) + +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) diff --git a/src/Simplex/RemoteControl/Discovery/Multicast.hsc b/src/Simplex/RemoteControl/Discovery/Multicast.hsc new file mode 100644 index 000000000..1a5260da3 --- /dev/null +++ b/src/Simplex/RemoteControl/Discovery/Multicast.hsc @@ -0,0 +1,48 @@ +module Simplex.RemoteControl.Discovery.Multicast + ( setMembership + ) where + +import Foreign (Ptr, allocaBytes, castPtr, pokeByteOff) +import Foreign.C.Types (CInt (..)) +import Network.Socket + +#include + +{- | Toggle multicast group membership. + +NB: Group membership is per-host, not per-process. A socket is only used to access system interface for groups. +-} +setMembership :: Socket -> HostAddress -> Bool -> IO (Either CInt ()) +setMembership sock group membership = allocaBytes #{size struct ip_mreq} $ \mReqPtr -> do + #{poke struct ip_mreq, imr_multiaddr} mReqPtr group + #{poke struct ip_mreq, imr_interface} mReqPtr (0 :: HostAddress) -- attempt to contact the group on ANY interface + withFdSocket sock $ \fd -> do + rc <- c_setsockopt fd c_IPPROTO_IP flag (castPtr mReqPtr) (#{size struct ip_mreq}) + if rc == 0 + then pure $ Right () + else pure $ Left rc + where + flag = if membership then c_IP_ADD_MEMBERSHIP else c_IP_DROP_MEMBERSHIP + +#ifdef mingw32_HOST_OS + +foreign import stdcall unsafe "setsockopt" + c_setsockopt :: CInt -> CInt -> CInt -> Ptr CInt -> CInt -> IO CInt + +c_IP_ADD_MEMBERSHIP, c_IP_DROP_MEMBERSHIP :: CInt +c_IP_ADD_MEMBERSHIP = 12 +c_IP_DROP_MEMBERSHIP = 13 + +#else + +foreign import ccall unsafe "setsockopt" + c_setsockopt :: CInt -> CInt -> CInt -> Ptr CInt -> CInt -> IO CInt + +c_IP_ADD_MEMBERSHIP, c_IP_DROP_MEMBERSHIP :: CInt +c_IP_ADD_MEMBERSHIP = #const IP_ADD_MEMBERSHIP +c_IP_DROP_MEMBERSHIP = #const IP_DROP_MEMBERSHIP + +#endif + +c_IPPROTO_IP :: CInt +c_IPPROTO_IP = #const IPPROTO_IP diff --git a/src/Simplex/RemoteControl/Types.hs b/src/Simplex/RemoteControl/Types.hs new file mode 100644 index 000000000..b01c47e9b --- /dev/null +++ b/src/Simplex/RemoteControl/Types.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# 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 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 qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Encoding (Encoding (..)) +import Simplex.Messaging.Encoding.String (StrEncoding (..)) +import Simplex.Messaging.Version (VersionRange, mkVersionRange) +import UnliftIO + +ipProbeVersionRange :: VersionRange +ipProbeVersionRange = mkVersionRange 1 1 + +data IpProbe = IpProbe + { versionRange :: VersionRange, + randomNonce :: ByteString + } deriving (Show) + +instance Encoding IpProbe where + smpEncode IpProbe {versionRange, randomNonce} = smpEncode (versionRange, 'I', randomNonce) + + smpP = IpProbe <$> (smpP <* "I") *> smpP + +announceVersionRange :: VersionRange +announceVersionRange = mkVersionRange 1 1 + +data Announce = Announce + { versionRange :: VersionRange, + sessionStart :: SystemTime, + announceCounter :: Word16, + serviceAddress :: (N.HostAddress, Word16), + caFingerprint :: C.KeyHash, + sessionDH :: C.PublicKeyX25519, + announceKey :: C.PublicKeyEd25519 + } deriving (Show) + +instance Encoding Announce where + smpEncode Announce {versionRange, sessionStart, announceCounter, serviceAddress, caFingerprint, sessionDH, announceKey} = + smpEncode (versionRange, 'A', sessionStart, announceCounter, serviceAddress) + <> smpEncode (caFingerprint, sessionDH, announceKey) + + smpP = Announce <$> (smpP <* "A") <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP + +data SignedAnnounce = SignedAnnounce Announce (C.Signature 'C.Ed25519) + +instance Encoding SignedAnnounce where + smpEncode (SignedAnnounce ann (C.SignatureEd25519 sig)) = smpEncode (ann, convert sig :: ByteString) + + smpP = do + sa <- SignedAnnounce <$> smpP <*> signatureP + unless (verifySignedAnnounce sa) $ fail "bad announce signature" + pure sa + where + signatureP = do + bs <- smpP :: A.Parser ByteString + case eitherCryptoError (Ed25519.signature bs) of + Left ce -> fail $ show ce + Right ok -> pure $ C.SignatureEd25519 ok + +signAnnounce :: C.PrivateKey C.Ed25519 -> Announce -> SignedAnnounce +signAnnounce announceSecret ann = SignedAnnounce ann sig + where + sig = + case C.sign (C.APrivateSignKey C.SEd25519 announceSecret) (smpEncode ann) of + C.ASignature C.SEd25519 s -> s + _ -> error "signing with ed25519" + +verifySignedAnnounce :: SignedAnnounce -> Bool +verifySignedAnnounce (SignedAnnounce ann@Announce {announceKey} sig) = C.verify aKey aSig (smpEncode ann) + where + aKey = C.APublicVerifyKey C.SEd25519 announceKey + aSig = C.ASignature C.SEd25519 sig + +data OOB = OOB + { -- authority part + caFingerprint :: C.KeyHash, + authToken :: Text, + host :: Text, + port :: Word16, + -- query part + version :: VersionRange, -- v= + appName :: Text, -- app= + sigPubKey :: C.PublicKeyEd25519, -- key= + deviceName :: Maybe Text -- device= + } + deriving (Eq, Show) + +instance StrEncoding OOB where + strEncode OOB {caFingerprint, authToken, host, port, version, appName, sigPubKey, deviceName} = + schema <> "://" <> authority <> "#/?" <> renderSimpleQuery False query + where + schema = "xrcp" + authority = + mconcat + [ strEncode caFingerprint, + ":", + encodeUtf8 authToken, + "@", + encodeUtf8 host, + ":", + strEncode port + ] + query = + [ ("v", strEncode version), + ("app", encodeUtf8 appName), + ("key", strEncode $ C.encodePubKey sigPubKey) + ] + ++ [("device", urlEncode True $ encodeUtf8 name) | name <- toList deviceName] + + strP = do + _ <- A.string "xrcp://" + caFingerprint <- strP + _ <- A.char ':' + authToken <- decodeUtf8Lenient <$> A.takeWhile (/= '@') + _ <- A.char '@' + host <- decodeUtf8Lenient <$> A.takeWhile (/= ':') + _ <- A.char ':' + port <- strP + + _ <- A.string "#/?" + q <- parseSimpleQuery <$> A.takeByteString + version <- maybe (fail "missing version") (either fail pure . strDecode) (lookup "v" q) + appName <- maybe (fail "missing appName") (pure . decodeUtf8Lenient) (lookup "app" q) + sigPubKeyB64 <- maybe (fail "missing key") pure (lookup "key" q) + sigPubKey <- either fail pure $ strDecode sigPubKeyB64 >>= C.decodePubKey + let deviceName = fmap (decodeUtf8Lenient . urlDecode True) (lookup "device" q) + pure OOB {caFingerprint, authToken, host, port, version, appName, sigPubKey, deviceName} + +data SignedOOB = SignedOOB OOB (C.Signature 'C.Ed25519) + deriving (Eq, Show) + +instance StrEncoding SignedOOB where + strEncode (SignedOOB oob sig) = strEncode oob <> "&sig=" <> strEncode (C.signatureBytes sig) + + strDecode s = do + unless (B.length sig == sigLen) $ Left "bad size" + unless ("&sig=" `B.isPrefixOf` sig) $ Left "bad signature prefix" + signedOOB <- SignedOOB <$> strDecode oob <*> (strDecode (B.drop 5 sig) >>= C.decodeSignature) + unless (verifySignedOOB signedOOB) $ Left "bad signature" + pure signedOOB + where + l = B.length s + (oob, sig) = B.splitAt (l - sigLen) s + sigLen = 93 -- &sig= + ed25519 sig size in base64 (88) + + -- XXX: strP is used in chat command parser, but default strP assumes bas64url-encoded bytestring, where OOB is an URL-like + strP = A.takeWhile (/= ' ') >>= either fail pure . strDecode + +signOOB :: C.PrivateKey C.Ed25519 -> OOB -> SignedOOB +signOOB key oob = SignedOOB oob sig + where + sig = + case C.sign (C.APrivateSignKey C.SEd25519 key) (strEncode oob) of + C.ASignature C.SEd25519 s -> s + _ -> error "signing with ed25519" + +verifySignedOOB :: SignedOOB -> Bool +verifySignedOOB (SignedOOB oob@OOB {sigPubKey} sig) = C.verify aKey aSig (strEncode oob) + where + aKey = C.APublicVerifyKey C.SEd25519 sigPubKey + aSig = C.ASignature C.SEd25519 sig + +decodeOOBLink :: Text -> Either String OOB +decodeOOBLink = fmap (\(SignedOOB oob _verified) -> oob) . strDecode . encodeUtf8 + +-- XXX: Move to utils? +type Tasks = TVar [Async ()] + +asyncRegistered :: MonadUnliftIO m => Tasks -> m () -> m () +asyncRegistered tasks action = async action >>= registerAsync tasks + +registerAsync :: MonadIO m => Tasks -> Async () -> m () +registerAsync tasks = atomically . modifyTVar tasks . (:) + +cancelTasks :: (MonadIO m) => Tasks -> m () +cancelTasks tasks = readTVarIO tasks >>= mapM_ cancel From db1b2f77cd1c172fab26b68c507cdd2c1b7b0e63 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Tue, 31 Oct 2023 19:39:42 +0000 Subject: [PATCH 02/16] rfc: SimpleX Remote Control protocol v2 (#874) * rfc: SimpleX Remote Control protocol * tweak rfc sections * rfc: SimpleX Remote Control protocol v2 * add session verification * add alternative design * add KEM to rfc * key agreement * add pad * pad * padding * remove marker from multicast packet * update --------- Co-authored-by: Alexander Bondarenko <486682+dpwiz@users.noreply.github.com> --- rfcs/2023-10-25-remote-control.md | 354 ++++++++++++++++++++++++++++++ 1 file changed, 354 insertions(+) create mode 100644 rfcs/2023-10-25-remote-control.md diff --git a/rfcs/2023-10-25-remote-control.md b/rfcs/2023-10-25-remote-control.md new file mode 100644 index 000000000..66ece9577 --- /dev/null +++ b/rfcs/2023-10-25-remote-control.md @@ -0,0 +1,354 @@ +# SimpleX Remote Control protocol + +Using profiles in SimpleX Chat mobile app from desktop app with minimal risk to the security model of SimpleX protocols. + +## Problem + +Synchronizing profiles that use double ratchet for e2e encryption is effectively impossible in a way that tolerates partitioning between devices. + +We are not considering replacing double ratchet to allow profile synchronization, as some other messengers did. We are also not considering Signal model, when profile is known to the server and adding devices results in changing security code and no visibility of conversation history, as it would be substantially different from the current model. + +## Solution + +The proposed option is remote access/control protocol, when the application on host device (usually mobile) acts as a server, and application on another device (usually desktop) acts as a controller usually running in the same local network. + +Service discovery and remote control protocols known to us are vulnerable to spoofing, spamming and MITM attacks. This design aims to solve these problems. + +## Requirements + +- Strong, cryptographically verified identity of the controller device, with the initial connection requiring out-of-band communication of public keys (QR code or link). +- Protection against malicious "controllers" trying to make host connect to them instead of valid controller on the same network. +- Protection against replay attacks, both during discovery and during control session. +- Additional encryption layer inside TLS. +- Protect host device from unauthorized access in case of controller compromise. +- Have post-compromised security - that is, even if long term secrets were copied from the controller, and host device was made to connect to malicious controller device, prevent malicious controller from accessing the host device data. +- Support general high-level interactions common for many applications: + - RPC pattern for commands executed by the host application. + - Events sent by host to update controller UI. + - Uploading and downloading files between host and controller, either to be processed by the host or to be presented in the controller UI. + +This design is quite close to how SimpleX Chat UI interacts with SimpleX Chat core - there is a similar RPC + events protocol and support for files. + +## Protocol phases + +Protocol consists of four phases: +- controller session announcement +- establishing session TLS connection +- session verification and protocol negotiation +- session operation + +### Session announcement + +The first session between host and controller pair MUST be announced out-of-band, to establish a long term identity keys/certificates of the controller to host device. + +The subsequent sessions will be announced via an application-defined site-local multicast group, e.g. `224.0.0.251` (also used in mDNS/bonjour) and an application-defined port (SimpleX Chat uses 5227). + +The session announcement contains this data: +- supported version range for remote control protocol +- application name +- device name +- session start time in seconds since epoch +- if multicast is used, counter of announce packets sent by controller +- network address (ipv4 address and port) of the controller +- 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. +- 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. +- Long-term Ed25519 public key used to verify the announcement and commands - this is part of the long term controller identity. +- Session X25519 DH key and sntrup761 KEM encapsulation key to agree session encryption (both for multicast announcement and for commands and responses in TLS), as described in https://datatracker.ietf.org/doc/draft-josefsson-ntruprime-hybrid/. The new keys are used for each session, and if client key is already available (from the previous session), the computed shared secret will be used to encrypt the announcement multicast packet. The initial out-of-band announcement is always unencrypted. These DH and KEM key are always sent unencrypted. NaCL Cryptobox is used for encryption. +- additional application specific parameters, e.g controller settings. + +Host device decrypts (except the first session) and validates the announcement: +- Session signature is valid. +- Timestamp is within some window from the current time. +- Long-term key signature is valid. +- Long-term CA and key are the same as in the first session. +- Some version in the range can be supported. + +OOB announcement is a URI with this syntax: + +```abnf +sessionAddressUri = "xrcp://" encodedCAFingerprint "@" host ":" port "#/?" qsParams +encodedCAFingerprint = base64url +qsParams = param *("&" param) +param = versionRangeParam / appNameParam / appVerionRangeParam / deviceNameParam / sessionTsParam / + sessPubKeyParam / idPubKeyParam / kemEncKeyParam / dhPubKeyParam / + sessSignatureParam / idSignatureParam +versionRangeParam = "v=" (versionParam / (versionParam "-" versionParam)) +versionParam = 1*DIGIT +appNameParam = "app=" 1*(ALPHA / DIGIT / "-" / "_") ; optional +appVerionRangeParam = "appv=" (versionParam / (versionParam "-" versionParam)) ; optional +deviceNameParam = "device=" 1*(ALPHA / DIGIT / "-" / "_") ; optional +sessionTsParam = "ts=" 1*DIGIT +sessPubKeyParam = "skey=" base64url ; required +idPubKeyParam = "idkey=" base64url ; required +kemEncKeyParam = "kem=" base64url ; required, can we have x509encoded? +dhPubKeyParam = "dh=" base64url ; required +sessSignatureParam = "ssig=" base64url ; required, signs the URI with this and idSignatureParam param removed +idSignatureParam = "idsig=" base64url ; required, signs the URI with this param removed +base64url = ; RFC4648, section 5 +``` + +Multicast announcement is a binary encoded packet with this syntax: + +```abnf +sessionAddressPacket = dhPubKey length encrypted(serviceAddress sessSignature idSignature) +dhPubKey = length x509encoded +serviceAddress = length addressJSON +sessSignature = length *OCTET ; signs the preceding announcement packet +idSignature = length *OCTET ; signs the preceding announcement packet including sessSignature +``` + +addressJSON is a JSON string valid against this JTD (RFC 8927) schema: + +```json +{ + "definitions": { + "versionRange": { + "type": "string", + "metadata": { + "format": "[0-9]+(-[0-9]+)?" + } + }, + "base64url": { + "type": "string", + "metadata": { + "format": "base64url" + } + } + }, + "properties": { + "ca": {"ref": "base64url"}, + "host": {"type": "string"}, + "port": {"type": "uint16"}, + "v": {"ref": "versionRange"}, + "ts": {"type": "uint64"}, + "skey": {"ref": "base64url"}, + "idkey": {"ref": "base64url"}, + "kem": {"ref": "base64url"} + }, + "optionalProperties": { + "app": {"type": "string"}, + "appv": {"ref": "versionRange"}, + "device": {"type": "string"} + }, + "additionalProperties": true +} +``` + +### Establishing session TLS connection + +Host connects to controller via TCP session and validates CA credentials during TLS handshake. Controller acts as a TCP server in this connection, to avoid host device listening on a port, which might create an attack vector. During TLS handshake the controller's TCP server presents a self-signed two-certificate chain where the fingerprint of the first certificate MUST be the same as in the announcement. + +Host device presents its own client certificate chain with CA representing a long-term identity of the host device. + +### Session verification and protocol negotiation + +Once TLS session is established, both the host and controller device present a "session security code" to the user who must match them (e.g., visually or via QR code scan) and confirm on the host device. The session security code must be a digest of tlsunique channel binding. As it is computed as a digest of the TLS handshake for both the controller and the host, it will validate that the same TLS certificates are used on both sides, and that the same TLS session is established. + +Once the session is confirmed by the user, the host device sends "hello" block to the controller. ALPN TLS extension is not used to obtain tlsunique prior to sending any packets. + +Block size should be 16384 bytes. + +Hello block must contain: +- KEM ciphertext with encapsulated secret and new session DH key - used to compute new shared secret with the controller keys from the announcement. +- encrypted part of hello block (JSON object), containing: + - chosen protocol version. + - host CA TLS certificate fingerprint - part of host long term identity - must match the one presented in TLS handshake and the previous sessions, otherwise the connection is terminated. + - host device name + - chosen application version. + - additional application specific parameters, e.g host settings or JSON encoding format. + +Hello block syntax: + +```abnf +helloBlock = unpaddedSize %s"HELLO " dhPubKey kemCiphertext length encrypted(length helloBlockJSON) pad +unpaddedSize = 2*2 OCTET +pad = +kemCiphertext = length base64url +``` + +Controller decrypts (including the first session) and validates the received hello block: +- Chosen versions are supported (must be within offered ranges). +- CA fingerprint matches the one presented in TLS handshake and the previous sessions - in subsequent sessions TLS connection should be rejected if the fingerprint is different. + +JTD schema for the encrypted part of hello block: + +```json +{ + "definitions": { + "version": { + "type": "string", + "metadata": { + "format": "[0-9]+" + } + }, + "base64url": { + "type": "string", + "metadata": { + "format": "base64url" + } + } + }, + "properties": { + "v": {"ref": "version"}, + "ca": {"ref": "base64url"}, + }, + "optionalProperties": { + "device": {"type": "string"}, + "appVersion": {"ref": "version"} + }, + "additionalProperties": true +} +``` + +Controller should reply with with `ok` or `err` block: + +``` +ok = unpaddedSize %s"OK" pad +err = unpaddedSize %s"ERR " length error pad +``` + +### Сontroller/host session operation + +The protocol for communication during the session is out of scope of this protocol. + +SimpleX Chat will use HTTP2 encoding, where host device acts as a server and controller acts as a client (these roles are reversed compared with TLS connection). + +Payloads in the protocol must be encrypted using NaCL cryptobox using the shared secret agreed during session establishment. + +Commands of the controller must be signed after the encryption using the controller's session and long term Ed25519 keys. + +tlsunique channel binding from TLS session MUST be included in commands (included in the signed body). + +The syntax for encrypted command and response body encoding: + +``` +commandBody = length encrypted(tlsunique counter length command) sessSignature idSignature +responseBody = length encrypted(tlsunique counter length response) ; should match counter in the command +tlsunique = length 1*OCTET +counter = 8*8 OCTET ; int64 +``` + +## Key agreement for announcement packet and for session + +Initial announcement is shared out-of-band, and it is not encrypted. + +This announcement contains DH and KEM keys, which are used to agree session encryption keys - the HELLO block will containt DH key and KEM ciphertext with encapsulated secret that will be used to determine the shared secret (using SHA512 over concatenated DH shared secret and KEM encapsulated secret). + +During the next session we send announcement via encrypted multicast block. The shared key for this secret is determined using the KEM shared secred from the previous session and DH shared secret computed using the host DH key from the previous session and the new controller DH key from the announcement. + +For the session, the shared secred is computed again using the KEM shared secret encapsulated using the new KEM key from the announcement and DH shared secret computed using the host DH key from HELLO block and the new controller DH key from the announcement. + +To describe it in pseudocode: + +``` +// session 1 +sessionSecret(1) = sha512(dhSecret(1) || kemSecret(1)) // to encrypt session 1 data, incl. hello +dhSecret(1) = dh(hostHelloDhKey(1), controllerAnnouncementDhKey(1)) +kemCiphertext(1) = enc(kemSecret(1), kemEncKey(1)) +kemSecret(1) = dec(kemCiphertext(1), kemDecKey(1)) + +// announcement for session n +announcementSecret(n) = sha512(dhSecret(n') || kemSecret(n - 1)) +dhSecret(n') = dh(hostHelloDhKey(n - 1), controllerAnnouncementDhKey(n)) + +// session n +sessionSecret(n) = sha512(dhSecret(n) || kemSecret(n)) +dhSecret(n) = dh(hostHelloDhKey(n), controllerAnnouncementDhKey(n)) +kemCiphertext(n) = enc(kemSecret(n), kemEncKey(n)) +kemSecret(n) = dec(kemCiphertext(n), kemDecKey(n)) +``` + +If controller fails to store the new host DH key after receiving HELLO block, the encryption will become out of sync and the host won't be able to decrypt the next announcement. To mitigate it, the host should keep the last session DH key and also previous session DH key to try to decrypt the next announcement computing shared secret using both keys (first the new one, and in case it fails - the previous). + +## Other options + +The proposed design has these pros/cons: + +Pros: +- mobile host that has sensitive data doesn't act as TLS server. +- multicast is optional - all sessions can happen via QR code only. + +Cons: +- reversing of client/server roles between TLS and HTTP2. +- in the first session mobile host TLS client credentials are verified after TLS connection is accepted. +- cannot be used with host that runs in VM. + +The alternative design will use mobile host device as TLS server. The session negotiation process: + +- desktop shares its initial credentials via QR code, only for the first session +- mobile sends encrypted multicast with session address, TLS CA fingerprint, DH key in clear text +- desktop connects to mobile +- session tlsunique presented to users on both devices - either user would have to confirm session on both devices or the mobile would have to send an additional "ready" block. + +Pros: +- no reversing server role between TLS and HTTP2 +- TLS credentials are exchanged before TLS, so invalid credentials can be rejected during the handshake of the first session. +- if some other way to pass data from host to controller is added, then it can be used with host running in VM. + +Cons: +- multicast is mandatory, as there is no efficient way to communicate from mobile to desktop. +- still needs hello or confirmation on both devices +- mobile is now acting as TLS server creating additional attack vector + +In both proposed and alternative design mobile host has chat data, acts as HTTP2 server, commands are signed with desktop key presented out-of–band, and both commands and responses are encrypted inside TLS session. + +Other considered options: +- SSH - more work integrating it. +- use SMP connection to negotiate TLS session - it seems wrong to require Internet connection to negotiate a local network connection between desktop and mobile. +- other multicast service discovery protocols - quite insecure. + +## Threat model + +#### A passive network adversary able to monitor the site-local traffic: + +*can:* +- observe session times, duration and volume of the transmitted data between host and controller. + +*cannot:* +- observe the content of the transmitted data. +- substitute the transmitted commands or responses. +- replay transmitted commands or events from the hosts. + +#### An active network adversary able to intercept and substitute the site-local traffic: + +*can:* +- prevent host and controller devices from establishing the session + +*cannot:* +- same as passive adversary, provided that user visually verified session code out-of-band. + +#### An active adversary with the access to the network: + +*can:* +- spam controller device. + +*cannot:* +- compromise host or controller devices. + +#### An active adversary with the access to the network who also observed OOB announcement: + +*can:* +- connect to controller instead of the host. +- present incorrect data to the controller. + +*cannot:* +- connect to the host or make host connect to itself. + +#### Compromised controller device: + +*can:* +- observe the content of the transmitted data. +- access any data of the controlled host application, within the capabilities of the provided API. + +*cannot:* +- access other data on the host device. +- compromise host device. + +#### Compromised host device: + +*can:* +- present incorrect data to the controller. +- incorrectly interpret controller commands. + +*cannot:* +- access controller data, even related to this host device. From c22c15a2e856d5c6a5d14de477256fb706e72deb Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Tue, 31 Oct 2023 22:40:15 +0000 Subject: [PATCH 03/16] sntrup761 (#865) * add sntrup761 source * it compiles * Wrap bindings in non-FFI types Test passes with a dummy RNG. * pass ChaChaDRG via FunPtr * Add iOS smoke test at createAgentStore * style * add "ssl" library dep Attempt to fix missing _SHA512 symbol on macos. * remove sha512 wrapper and use openssl directly * restore names, remove dummy RNG * Revert "remove sha512 wrapper and use openssl directly" This reverts commit f9f7781f097dcac6f4896656ef16a6c4af11dcdb. * restore code from RFC * shorter names * enable all tests * remove run test --------- Co-authored-by: IC Rainbow --- cbits/README.md | 3 + cbits/sha512.c | 9 + cbits/sha512.h | 3 + cbits/sntrup761.c | 1035 +++++++++++++++++ cbits/sntrup761.h | 33 + package.yaml | 7 + simplexmq.cabal | 13 + .../Messaging/Crypto/SNTRUP761/Bindings.hs | 38 + .../Crypto/SNTRUP761/Bindings/Defines.hsc | 17 + .../Crypto/SNTRUP761/Bindings/FFI.hs | 23 + .../Crypto/SNTRUP761/Bindings/RNG.hs | 48 + tests/CoreTests/CryptoTests.hs | 10 + 12 files changed, 1239 insertions(+) create mode 100644 cbits/README.md create mode 100644 cbits/sha512.c create mode 100644 cbits/sha512.h create mode 100644 cbits/sntrup761.c create mode 100644 cbits/sntrup761.h create mode 100644 src/Simplex/Messaging/Crypto/SNTRUP761/Bindings.hs create mode 100644 src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/Defines.hsc create mode 100644 src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/FFI.hs create mode 100644 src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/RNG.hs diff --git a/cbits/README.md b/cbits/README.md new file mode 100644 index 000000000..88e72d008 --- /dev/null +++ b/cbits/README.md @@ -0,0 +1,3 @@ +# Streamlined NTRU Prime: sntrup761 + +The implementation of sntrup761 is the _exact_ copy from this [Internet draft](https://www.ietf.org/archive/id/draft-josefsson-ntruprime-streamlined-00.html). diff --git a/cbits/sha512.c b/cbits/sha512.c new file mode 100644 index 000000000..54b838674 --- /dev/null +++ b/cbits/sha512.c @@ -0,0 +1,9 @@ +#include +#include "sha512.h" + +void crypto_hash_sha512 (unsigned char *out, + const unsigned char *in, + unsigned long long inlen) +{ + SHA512(in, inlen, out); +} diff --git a/cbits/sha512.h b/cbits/sha512.h new file mode 100644 index 000000000..af16f5888 --- /dev/null +++ b/cbits/sha512.h @@ -0,0 +1,3 @@ +void crypto_hash_sha512 (unsigned char *out, + const unsigned char *in, + unsigned long long inlen); diff --git a/cbits/sntrup761.c b/cbits/sntrup761.c new file mode 100644 index 000000000..7d64eeb08 --- /dev/null +++ b/cbits/sntrup761.c @@ -0,0 +1,1035 @@ +/* + * Derived from public domain source, written by (in alphabetical order): + * - Daniel J. Bernstein + * - Chitchanok Chuengsatiansup + * - Tanja Lange + * - Christine van Vredendaal + */ + +#include "sntrup761.h" + +#include "sha512.h" + +/* from supercop-20201130/crypto_sort/int32/portable4/int32_minmax.inc */ +#define int32_MINMAX(a,b) \ +do { \ + int64_t ab = (int64_t)b ^ (int64_t)a; \ + int64_t c = (int64_t)b - (int64_t)a; \ + c ^= ab & (c ^ b); \ + c >>= 31; \ + c &= ab; \ + a ^= c; \ + b ^= c; \ +} while(0) + +/* from supercop-20201130/crypto_sort/int32/portable4/sort.c */ +static void +crypto_sort_int32 (void *array, long long n) +{ + long long top, p, q, r, i, j; + int32_t *x = array; + + if (n < 2) + return; + top = 1; + while (top < n - top) + top += top; + + for (p = top; p >= 1; p >>= 1) + { + i = 0; + while (i + 2 * p <= n) + { + for (j = i; j < i + p; ++j) + int32_MINMAX (x[j], x[j + p]); + i += 2 * p; + } + for (j = i; j < n - p; ++j) + int32_MINMAX (x[j], x[j + p]); + + i = 0; + j = 0; + for (q = top; q > p; q >>= 1) + { + if (j != i) + for (;;) + { + if (j == n - q) + goto done; + int32_t a = x[j + p]; + for (r = q; r > p; r >>= 1) + int32_MINMAX (a, x[j + r]); + x[j + p] = a; + ++j; + if (j == i + p) + { + i += 2 * p; + break; + } + } + while (i + p <= n - q) + { + for (j = i; j < i + p; ++j) + { + int32_t a = x[j + p]; + for (r = q; r > p; r >>= 1) + int32_MINMAX (a, x[j + r]); + x[j + p] = a; + } + i += 2 * p; + } + /* now i + p > n - q */ + j = i; + while (j < n - q) + { + int32_t a = x[j + p]; + for (r = q; r > p; r >>= 1) + int32_MINMAX (a, x[j + r]); + x[j + p] = a; + ++j; + } + + done:; + } + } +} + +/* from supercop-20201130/crypto_sort/uint32/useint32/sort.c */ + +/* can save time by vectorizing xor loops */ +/* can save time by integrating xor loops with int32_sort */ + +static void +crypto_sort_uint32 (void *array, long long n) +{ + uint32_t *x = array; + long long j; + for (j = 0; j < n; ++j) + x[j] ^= 0x80000000; + crypto_sort_int32 (array, n); + for (j = 0; j < n; ++j) + x[j] ^= 0x80000000; +} + +/* from supercop-20201130/crypto_kem/sntrup761/ref/uint32.c */ + +/* +CPU division instruction typically takes time depending on x. +This software is designed to take time independent of x. +Time still varies depending on m; user must ensure that m is constant. +Time also varies on CPUs where multiplication is variable-time. +There could be more CPU issues. +There could also be compiler issues. +*/ + +static void +uint32_divmod_uint14 (uint32_t * q, uint16_t * r, uint32_t x, uint16_t m) +{ + uint32_t v = 0x80000000; + uint32_t qpart; + uint32_t mask; + + v /= m; + + /* caller guarantees m > 0 */ + /* caller guarantees m < 16384 */ + /* vm <= 2^31 <= vm+m-1 */ + /* xvm <= 2^31 x <= xvm+x(m-1) */ + + *q = 0; + + qpart = (x * (uint64_t) v) >> 31; + /* 2^31 qpart <= xv <= 2^31 qpart + 2^31-1 */ + /* 2^31 qpart m <= xvm <= 2^31 qpart m + (2^31-1)m */ + /* 2^31 qpart m <= 2^31 x <= 2^31 qpart m + (2^31-1)m + x(m-1) */ + /* 0 <= 2^31 newx <= (2^31-1)m + x(m-1) */ + /* 0 <= newx <= (1-1/2^31)m + x(m-1)/2^31 */ + /* 0 <= newx <= (1-1/2^31)(2^14-1) + (2^32-1)((2^14-1)-1)/2^31 */ + + x -= qpart * m; + *q += qpart; + /* x <= 49146 */ + + qpart = (x * (uint64_t) v) >> 31; + /* 0 <= newx <= (1-1/2^31)m + x(m-1)/2^31 */ + /* 0 <= newx <= m + 49146(2^14-1)/2^31 */ + /* 0 <= newx <= m + 0.4 */ + /* 0 <= newx <= m */ + + x -= qpart * m; + *q += qpart; + /* x <= m */ + + x -= m; + *q += 1; + mask = -(x >> 31); + x += mask & (uint32_t) m; + *q += mask; + /* x < m */ + + *r = x; +} + + +static uint16_t +uint32_mod_uint14 (uint32_t x, uint16_t m) +{ + uint32_t q; + uint16_t r; + uint32_divmod_uint14 (&q, &r, x, m); + return r; +} + +/* from supercop-20201130/crypto_kem/sntrup761/ref/int32.c */ + +static void +int32_divmod_uint14 (int32_t * q, uint16_t * r, int32_t x, uint16_t m) +{ + uint32_t uq, uq2; + uint16_t ur, ur2; + uint32_t mask; + + uint32_divmod_uint14 (&uq, &ur, 0x80000000 + (uint32_t) x, m); + uint32_divmod_uint14 (&uq2, &ur2, 0x80000000, m); + ur -= ur2; + uq -= uq2; + mask = -(uint32_t) (ur >> 15); + ur += mask & m; + uq += mask; + *r = ur; + *q = uq; +} + + +static uint16_t +int32_mod_uint14 (int32_t x, uint16_t m) +{ + int32_t q; + uint16_t r; + int32_divmod_uint14 (&q, &r, x, m); + return r; +} + +/* from supercop-20201130/crypto_kem/sntrup761/ref/paramsmenu.h */ +#define p 761 +#define q 4591 +#define Rounded_bytes 1007 +#define Rq_bytes 1158 +#define w 286 + +/* from supercop-20201130/crypto_kem/sntrup761/ref/Decode.h */ + +/* Decode(R,s,M,len) */ +/* assumes 0 < M[i] < 16384 */ +/* produces 0 <= R[i] < M[i] */ + +/* from supercop-20201130/crypto_kem/sntrup761/ref/Decode.c */ + +static void +Decode (uint16_t * out, const unsigned char *S, const uint16_t * M, + long long len) +{ + if (len == 1) + { + if (M[0] == 1) + *out = 0; + else if (M[0] <= 256) + *out = uint32_mod_uint14 (S[0], M[0]); + else + *out = uint32_mod_uint14 (S[0] + (((uint16_t) S[1]) << 8), M[0]); + } + if (len > 1) + { + uint16_t R2[(len + 1) / 2]; + uint16_t M2[(len + 1) / 2]; + uint16_t bottomr[len / 2]; + uint32_t bottomt[len / 2]; + long long i; + for (i = 0; i < len - 1; i += 2) + { + uint32_t m = M[i] * (uint32_t) M[i + 1]; + if (m > 256 * 16383) + { + bottomt[i / 2] = 256 * 256; + bottomr[i / 2] = S[0] + 256 * S[1]; + S += 2; + M2[i / 2] = (((m + 255) >> 8) + 255) >> 8; + } + else if (m >= 16384) + { + bottomt[i / 2] = 256; + bottomr[i / 2] = S[0]; + S += 1; + M2[i / 2] = (m + 255) >> 8; + } + else + { + bottomt[i / 2] = 1; + bottomr[i / 2] = 0; + M2[i / 2] = m; + } + } + if (i < len) + M2[i / 2] = M[i]; + Decode (R2, S, M2, (len + 1) / 2); + for (i = 0; i < len - 1; i += 2) + { + uint32_t r = bottomr[i / 2]; + uint32_t r1; + uint16_t r0; + r += bottomt[i / 2] * R2[i / 2]; + uint32_divmod_uint14 (&r1, &r0, r, M[i]); + r1 = uint32_mod_uint14 (r1, M[i + 1]); /* only needed for invalid inputs */ + *out++ = r0; + *out++ = r1; + } + if (i < len) + *out++ = R2[i / 2]; + } +} + +/* from supercop-20201130/crypto_kem/sntrup761/ref/Encode.h */ + +/* Encode(s,R,M,len) */ +/* assumes 0 <= R[i] < M[i] < 16384 */ + +/* from supercop-20201130/crypto_kem/sntrup761/ref/Encode.c */ + +/* 0 <= R[i] < M[i] < 16384 */ +static void +Encode (unsigned char *out, const uint16_t * R, const uint16_t * M, + long long len) +{ + if (len == 1) + { + uint16_t r = R[0]; + uint16_t m = M[0]; + while (m > 1) + { + *out++ = r; + r >>= 8; + m = (m + 255) >> 8; + } + } + if (len > 1) + { + uint16_t R2[(len + 1) / 2]; + uint16_t M2[(len + 1) / 2]; + long long i; + for (i = 0; i < len - 1; i += 2) + { + uint32_t m0 = M[i]; + uint32_t r = R[i] + R[i + 1] * m0; + uint32_t m = M[i + 1] * m0; + while (m >= 16384) + { + *out++ = r; + r >>= 8; + m = (m + 255) >> 8; + } + R2[i / 2] = r; + M2[i / 2] = m; + } + if (i < len) + { + R2[i / 2] = R[i]; + M2[i / 2] = M[i]; + } + Encode (out, R2, M2, (len + 1) / 2); + } +} + +/* from supercop-20201130/crypto_kem/sntrup761/ref/kem.c */ + +/* ----- masks */ + +/* return -1 if x!=0; else return 0 */ +static int +int16_t_nonzero_mask (int16_t x) +{ + uint16_t u = x; /* 0, else 1...65535 */ + uint32_t v = u; /* 0, else 1...65535 */ + v = -v; /* 0, else 2^32-65535...2^32-1 */ + v >>= 31; /* 0, else 1 */ + return -v; /* 0, else -1 */ +} + +/* return -1 if x<0; otherwise return 0 */ +static int +int16_t_negative_mask (int16_t x) +{ + uint16_t u = x; + u >>= 15; + return -(int) u; + /* alternative with gcc -fwrapv: */ + /* x>>15 compiles to CPU's arithmetic right shift */ +} + +/* ----- arithmetic mod 3 */ + +typedef int8_t small; + +/* F3 is always represented as -1,0,1 */ +/* so ZZ_fromF3 is a no-op */ + +/* x must not be close to top int16_t */ +static small +F3_freeze (int16_t x) +{ + return int32_mod_uint14 (x + 1, 3) - 1; +} + +/* ----- arithmetic mod q */ + +#define q12 ((q-1)/2) +typedef int16_t Fq; +/* always represented as -q12...q12 */ +/* so ZZ_fromFq is a no-op */ + +/* x must not be close to top int32 */ +static Fq +Fq_freeze (int32_t x) +{ + return int32_mod_uint14 (x + q12, q) - q12; +} + +static Fq +Fq_recip (Fq a1) +{ + int i = 1; + Fq ai = a1; + + while (i < q - 2) + { + ai = Fq_freeze (a1 * (int32_t) ai); + i += 1; + } + return ai; +} + +/* ----- small polynomials */ + +/* 0 if Weightw_is(r), else -1 */ +static int +Weightw_mask (small * r) +{ + int weight = 0; + int i; + + for (i = 0; i < p; ++i) + weight += r[i] & 1; + return int16_t_nonzero_mask (weight - w); +} + +/* R3_fromR(R_fromRq(r)) */ +static void +R3_fromRq (small * out, const Fq * r) +{ + int i; + for (i = 0; i < p; ++i) + out[i] = F3_freeze (r[i]); +} + +/* h = f*g in the ring R3 */ +static void +R3_mult (small * h, const small * f, const small * g) +{ + small fg[p + p - 1]; + small result; + int i, j; + + for (i = 0; i < p; ++i) + { + result = 0; + for (j = 0; j <= i; ++j) + result = F3_freeze (result + f[j] * g[i - j]); + fg[i] = result; + } + for (i = p; i < p + p - 1; ++i) + { + result = 0; + for (j = i - p + 1; j < p; ++j) + result = F3_freeze (result + f[j] * g[i - j]); + fg[i] = result; + } + + for (i = p + p - 2; i >= p; --i) + { + fg[i - p] = F3_freeze (fg[i - p] + fg[i]); + fg[i - p + 1] = F3_freeze (fg[i - p + 1] + fg[i]); + } + + for (i = 0; i < p; ++i) + h[i] = fg[i]; +} + +/* returns 0 if recip succeeded; else -1 */ +static int +R3_recip (small * out, const small * in) +{ + small f[p + 1], g[p + 1], v[p + 1], r[p + 1]; + int i, loop, delta; + int sign, swap, t; + + for (i = 0; i < p + 1; ++i) + v[i] = 0; + for (i = 0; i < p + 1; ++i) + r[i] = 0; + r[0] = 1; + for (i = 0; i < p; ++i) + f[i] = 0; + f[0] = 1; + f[p - 1] = f[p] = -1; + for (i = 0; i < p; ++i) + g[p - 1 - i] = in[i]; + g[p] = 0; + + delta = 1; + + for (loop = 0; loop < 2 * p - 1; ++loop) + { + for (i = p; i > 0; --i) + v[i] = v[i - 1]; + v[0] = 0; + + sign = -g[0] * f[0]; + swap = int16_t_negative_mask (-delta) & int16_t_nonzero_mask (g[0]); + delta ^= swap & (delta ^ -delta); + delta += 1; + + for (i = 0; i < p + 1; ++i) + { + t = swap & (f[i] ^ g[i]); + f[i] ^= t; + g[i] ^= t; + t = swap & (v[i] ^ r[i]); + v[i] ^= t; + r[i] ^= t; + } + + for (i = 0; i < p + 1; ++i) + g[i] = F3_freeze (g[i] + sign * f[i]); + for (i = 0; i < p + 1; ++i) + r[i] = F3_freeze (r[i] + sign * v[i]); + + for (i = 0; i < p; ++i) + g[i] = g[i + 1]; + g[p] = 0; + } + + sign = f[0]; + for (i = 0; i < p; ++i) + out[i] = sign * v[p - 1 - i]; + + return int16_t_nonzero_mask (delta); +} + +/* ----- polynomials mod q */ + +/* h = f*g in the ring Rq */ +static void +Rq_mult_small (Fq * h, const Fq * f, const small * g) +{ + Fq fg[p + p - 1]; + Fq result; + int i, j; + + for (i = 0; i < p; ++i) + { + result = 0; + for (j = 0; j <= i; ++j) + result = Fq_freeze (result + f[j] * (int32_t) g[i - j]); + fg[i] = result; + } + for (i = p; i < p + p - 1; ++i) + { + result = 0; + for (j = i - p + 1; j < p; ++j) + result = Fq_freeze (result + f[j] * (int32_t) g[i - j]); + fg[i] = result; + } + + for (i = p + p - 2; i >= p; --i) + { + fg[i - p] = Fq_freeze (fg[i - p] + fg[i]); + fg[i - p + 1] = Fq_freeze (fg[i - p + 1] + fg[i]); + } + + for (i = 0; i < p; ++i) + h[i] = fg[i]; +} + +/* h = 3f in Rq */ +static void +Rq_mult3 (Fq * h, const Fq * f) +{ + int i; + + for (i = 0; i < p; ++i) + h[i] = Fq_freeze (3 * f[i]); +} + +/* out = 1/(3*in) in Rq */ +/* returns 0 if recip succeeded; else -1 */ +static int +Rq_recip3 (Fq * out, const small * in) +{ + Fq f[p + 1], g[p + 1], v[p + 1], r[p + 1]; + int i, loop, delta; + int swap, t; + int32_t f0, g0; + Fq scale; + + for (i = 0; i < p + 1; ++i) + v[i] = 0; + for (i = 0; i < p + 1; ++i) + r[i] = 0; + r[0] = Fq_recip (3); + for (i = 0; i < p; ++i) + f[i] = 0; + f[0] = 1; + f[p - 1] = f[p] = -1; + for (i = 0; i < p; ++i) + g[p - 1 - i] = in[i]; + g[p] = 0; + + delta = 1; + + for (loop = 0; loop < 2 * p - 1; ++loop) + { + for (i = p; i > 0; --i) + v[i] = v[i - 1]; + v[0] = 0; + + swap = int16_t_negative_mask (-delta) & int16_t_nonzero_mask (g[0]); + delta ^= swap & (delta ^ -delta); + delta += 1; + + for (i = 0; i < p + 1; ++i) + { + t = swap & (f[i] ^ g[i]); + f[i] ^= t; + g[i] ^= t; + t = swap & (v[i] ^ r[i]); + v[i] ^= t; + r[i] ^= t; + } + + f0 = f[0]; + g0 = g[0]; + for (i = 0; i < p + 1; ++i) + g[i] = Fq_freeze (f0 * g[i] - g0 * f[i]); + for (i = 0; i < p + 1; ++i) + r[i] = Fq_freeze (f0 * r[i] - g0 * v[i]); + + for (i = 0; i < p; ++i) + g[i] = g[i + 1]; + g[p] = 0; + } + + scale = Fq_recip (f[0]); + for (i = 0; i < p; ++i) + out[i] = Fq_freeze (scale * (int32_t) v[p - 1 - i]); + + return int16_t_nonzero_mask (delta); +} + +/* ----- rounded polynomials mod q */ + +static void +Round (Fq * out, const Fq * a) +{ + int i; + for (i = 0; i < p; ++i) + out[i] = a[i] - F3_freeze (a[i]); +} + +/* ----- sorting to generate short polynomial */ + +static void +Short_fromlist (small * out, const uint32_t * in) +{ + uint32_t L[p]; + int i; + + for (i = 0; i < w; ++i) + L[i] = in[i] & (uint32_t) - 2; + for (i = w; i < p; ++i) + L[i] = (in[i] & (uint32_t) - 3) | 1; + crypto_sort_uint32 (L, p); + for (i = 0; i < p; ++i) + out[i] = (L[i] & 3) - 1; +} + +/* ----- underlying hash function */ + +#define Hash_bytes 32 + +/* e.g., b = 0 means out = Hash0(in) */ +static void +Hash_prefix (unsigned char *out, int b, const unsigned char *in, int inlen) +{ + unsigned char x[inlen + 1]; + unsigned char h[64]; + int i; + + x[0] = b; + for (i = 0; i < inlen; ++i) + x[i + 1] = in[i]; + crypto_hash_sha512 (h, x, inlen + 1); + for (i = 0; i < 32; ++i) + out[i] = h[i]; +} + +/* ----- higher-level randomness */ + +static uint32_t +urandom32 (void *random_ctx, sntrup761_random_func * random) +{ + unsigned char c[4]; + uint32_t out[4]; + + random (random_ctx, 4, c); + out[0] = (uint32_t) c[0]; + out[1] = ((uint32_t) c[1]) << 8; + out[2] = ((uint32_t) c[2]) << 16; + out[3] = ((uint32_t) c[3]) << 24; + return out[0] + out[1] + out[2] + out[3]; +} + +static void +Short_random (small * out, void *random_ctx, sntrup761_random_func * random) +{ + uint32_t L[p]; + int i; + + for (i = 0; i < p; ++i) + L[i] = urandom32 (random_ctx, random); + Short_fromlist (out, L); +} + +static void +Small_random (small * out, void *random_ctx, sntrup761_random_func * random) +{ + int i; + + for (i = 0; i < p; ++i) + out[i] = (((urandom32 (random_ctx, random) & 0x3fffffff) * 3) >> 30) - 1; +} + +/* ----- Streamlined NTRU Prime Core */ + +/* h,(f,ginv) = KeyGen() */ +static void +KeyGen (Fq * h, small * f, small * ginv, void *random_ctx, + sntrup761_random_func * random) +{ + small g[p]; + Fq finv[p]; + + for (;;) + { + Small_random (g, random_ctx, random); + if (R3_recip (ginv, g) == 0) + break; + } + Short_random (f, random_ctx, random); + Rq_recip3 (finv, f); /* always works */ + Rq_mult_small (h, finv, g); +} + +/* c = Encrypt(r,h) */ +static void +Encrypt (Fq * c, const small * r, const Fq * h) +{ + Fq hr[p]; + + Rq_mult_small (hr, h, r); + Round (c, hr); +} + +/* r = Decrypt(c,(f,ginv)) */ +static void +Decrypt (small * r, const Fq * c, const small * f, const small * ginv) +{ + Fq cf[p]; + Fq cf3[p]; + small e[p]; + small ev[p]; + int mask; + int i; + + Rq_mult_small (cf, c, f); + Rq_mult3 (cf3, cf); + R3_fromRq (e, cf3); + R3_mult (ev, e, ginv); + + mask = Weightw_mask (ev); /* 0 if weight w, else -1 */ + for (i = 0; i < w; ++i) + r[i] = ((ev[i] ^ 1) & ~mask) ^ 1; + for (i = w; i < p; ++i) + r[i] = ev[i] & ~mask; +} + +/* ----- encoding small polynomials (including short polynomials) */ + +#define Small_bytes ((p+3)/4) + +/* these are the only functions that rely on p mod 4 = 1 */ + +static void +Small_encode (unsigned char *s, const small * f) +{ + small x; + int i; + + for (i = 0; i < p / 4; ++i) + { + x = *f++ + 1; + x += (*f++ + 1) << 2; + x += (*f++ + 1) << 4; + x += (*f++ + 1) << 6; + *s++ = x; + } + x = *f++ + 1; + *s++ = x; +} + +static void +Small_decode (small * f, const unsigned char *s) +{ + unsigned char x; + int i; + + for (i = 0; i < p / 4; ++i) + { + x = *s++; + *f++ = ((small) (x & 3)) - 1; + x >>= 2; + *f++ = ((small) (x & 3)) - 1; + x >>= 2; + *f++ = ((small) (x & 3)) - 1; + x >>= 2; + *f++ = ((small) (x & 3)) - 1; + } + x = *s++; + *f++ = ((small) (x & 3)) - 1; +} + +/* ----- encoding general polynomials */ + +static void +Rq_encode (unsigned char *s, const Fq * r) +{ + uint16_t R[p], M[p]; + int i; + + for (i = 0; i < p; ++i) + R[i] = r[i] + q12; + for (i = 0; i < p; ++i) + M[i] = q; + Encode (s, R, M, p); +} + +static void +Rq_decode (Fq * r, const unsigned char *s) +{ + uint16_t R[p], M[p]; + int i; + + for (i = 0; i < p; ++i) + M[i] = q; + Decode (R, s, M, p); + for (i = 0; i < p; ++i) + r[i] = ((Fq) R[i]) - q12; +} + +/* ----- encoding rounded polynomials */ + +static void +Rounded_encode (unsigned char *s, const Fq * r) +{ + uint16_t R[p], M[p]; + int i; + + for (i = 0; i < p; ++i) + R[i] = ((r[i] + q12) * 10923) >> 15; + for (i = 0; i < p; ++i) + M[i] = (q + 2) / 3; + Encode (s, R, M, p); +} + +static void +Rounded_decode (Fq * r, const unsigned char *s) +{ + uint16_t R[p], M[p]; + int i; + + for (i = 0; i < p; ++i) + M[i] = (q + 2) / 3; + Decode (R, s, M, p); + for (i = 0; i < p; ++i) + r[i] = R[i] * 3 - q12; +} + +/* ----- Streamlined NTRU Prime Core plus encoding */ + +typedef small Inputs[p]; /* passed by reference */ +#define Inputs_random Short_random +#define Inputs_encode Small_encode +#define Inputs_bytes Small_bytes + +#define Ciphertexts_bytes Rounded_bytes +#define SecretKeys_bytes (2*Small_bytes) +#define PublicKeys_bytes Rq_bytes + +/* pk,sk = ZKeyGen() */ +static void +ZKeyGen (unsigned char *pk, unsigned char *sk, void *random_ctx, + sntrup761_random_func * random) +{ + Fq h[p]; + small f[p], v[p]; + + KeyGen (h, f, v, random_ctx, random); + Rq_encode (pk, h); + Small_encode (sk, f); + sk += Small_bytes; + Small_encode (sk, v); +} + +/* C = ZEncrypt(r,pk) */ +static void +ZEncrypt (unsigned char *C, const Inputs r, const unsigned char *pk) +{ + Fq h[p]; + Fq c[p]; + Rq_decode (h, pk); + Encrypt (c, r, h); + Rounded_encode (C, c); +} + +/* r = ZDecrypt(C,sk) */ +static void +ZDecrypt (Inputs r, const unsigned char *C, const unsigned char *sk) +{ + small f[p], v[p]; + Fq c[p]; + + Small_decode (f, sk); + sk += Small_bytes; + Small_decode (v, sk); + Rounded_decode (c, C); + Decrypt (r, c, f, v); +} + +/* ----- confirmation hash */ + +#define Confirm_bytes 32 + +/* h = HashConfirm(r,pk,cache); cache is Hash4(pk) */ +static void +HashConfirm (unsigned char *h, const unsigned char *r, + /* const unsigned char *pk, */ const unsigned char *cache) +{ + unsigned char x[Hash_bytes * 2]; + int i; + + Hash_prefix (x, 3, r, Inputs_bytes); + for (i = 0; i < Hash_bytes; ++i) + x[Hash_bytes + i] = cache[i]; + Hash_prefix (h, 2, x, sizeof x); +} + +/* ----- session-key hash */ + +/* k = HashSession(b,y,z) */ +static void +HashSession (unsigned char *k, int b, const unsigned char *y, + const unsigned char *z) +{ + unsigned char x[Hash_bytes + Ciphertexts_bytes + Confirm_bytes]; + int i; + + Hash_prefix (x, 3, y, Inputs_bytes); + for (i = 0; i < Ciphertexts_bytes + Confirm_bytes; ++i) + x[Hash_bytes + i] = z[i]; + Hash_prefix (k, b, x, sizeof x); +} + +/* ----- Streamlined NTRU Prime */ + +/* pk,sk = KEM_KeyGen() */ +void +sntrup761_keypair (unsigned char *pk, unsigned char *sk, void *random_ctx, + sntrup761_random_func * random) +{ + int i; + + ZKeyGen (pk, sk, random_ctx, random); + sk += SecretKeys_bytes; + for (i = 0; i < PublicKeys_bytes; ++i) + *sk++ = pk[i]; + random (random_ctx, Inputs_bytes, sk); + sk += Inputs_bytes; + Hash_prefix (sk, 4, pk, PublicKeys_bytes); +} + +/* c,r_enc = Hide(r,pk,cache); cache is Hash4(pk) */ +static void +Hide (unsigned char *c, unsigned char *r_enc, const Inputs r, + const unsigned char *pk, const unsigned char *cache) +{ + Inputs_encode (r_enc, r); + ZEncrypt (c, r, pk); + c += Ciphertexts_bytes; + HashConfirm (c, r_enc, cache); +} + +/* c,k = Encap(pk) */ +void +sntrup761_enc (unsigned char *c, unsigned char *k, const unsigned char *pk, + void *random_ctx, sntrup761_random_func * random) +{ + Inputs r; + unsigned char r_enc[Inputs_bytes]; + unsigned char cache[Hash_bytes]; + + Hash_prefix (cache, 4, pk, PublicKeys_bytes); + Inputs_random (r, random_ctx, random); + Hide (c, r_enc, r, pk, cache); + HashSession (k, 1, r_enc, c); +} + +/* 0 if matching ciphertext+confirm, else -1 */ +static int +Ciphertexts_diff_mask (const unsigned char *c, const unsigned char *c2) +{ + uint16_t differentbits = 0; + int len = Ciphertexts_bytes + Confirm_bytes; + + while (len-- > 0) + differentbits |= (*c++) ^ (*c2++); + return (1 & ((differentbits - 1) >> 8)) - 1; +} + +/* k = Decap(c,sk) */ +void +sntrup761_dec (unsigned char *k, const unsigned char *c, const unsigned char *sk) +{ + const unsigned char *pk = sk + SecretKeys_bytes; + const unsigned char *rho = pk + PublicKeys_bytes; + const unsigned char *cache = rho + Inputs_bytes; + Inputs r; + unsigned char r_enc[Inputs_bytes]; + unsigned char cnew[Ciphertexts_bytes + Confirm_bytes]; + int mask; + int i; + + ZDecrypt (r, c, sk); + Hide (cnew, r_enc, r, pk, cache); + mask = Ciphertexts_diff_mask (c, cnew); + for (i = 0; i < Inputs_bytes; ++i) + r_enc[i] ^= mask & (r_enc[i] ^ rho[i]); + HashSession (k, 1 + mask, r_enc, c); +} diff --git a/cbits/sntrup761.h b/cbits/sntrup761.h new file mode 100644 index 000000000..4b1a23bd9 --- /dev/null +++ b/cbits/sntrup761.h @@ -0,0 +1,33 @@ +/* + * Derived from public domain source, written by (in alphabetical order): + * - Daniel J. Bernstein + * - Chitchanok Chuengsatiansup + * - Tanja Lange + * - Christine van Vredendaal + */ + +#ifndef SNTRUP761_H +#define SNTRUP761_H + +#include +#include + +#define SNTRUP761_SECRETKEY_SIZE 1763 +#define SNTRUP761_PUBLICKEY_SIZE 1158 +#define SNTRUP761_CIPHERTEXT_SIZE 1039 +#define SNTRUP761_SIZE 32 + +typedef void sntrup761_random_func (void *ctx, size_t length, uint8_t *dst); + +void +sntrup761_keypair (uint8_t *pk, uint8_t *sk, + void *random_ctx, sntrup761_random_func *random); + +void +sntrup761_enc (uint8_t *c, uint8_t *k, const uint8_t *pk, + void *random_ctx, sntrup761_random_func *random); + +void +sntrup761_dec (uint8_t *k, const uint8_t *c, const uint8_t *sk); + +#endif /* SNTRUP761_H */ diff --git a/package.yaml b/package.yaml index 9f2aa77cb..8fe00fbfa 100644 --- a/package.yaml +++ b/package.yaml @@ -20,6 +20,8 @@ category: Chat, Network, Web, System, Cryptography extra-source-files: - README.md - CHANGELOG.md + - cbits/sha512.h + - cbits/sntrup761.h dependencies: - aeson == 2.2.* @@ -88,6 +90,11 @@ when: library: source-dirs: src + c-sources: + - cbits/sha512.c + - cbits/sntrup761.c + include-dirs: cbits + extra-libraries: crypto executables: smp-server: diff --git a/simplexmq.cabal b/simplexmq.cabal index 84450caf7..c8ed1f759 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -26,6 +26,8 @@ build-type: Simple extra-source-files: README.md CHANGELOG.md + cbits/sha512.h + cbits/sntrup761.h flag swift description: Enable swift JSON format @@ -99,6 +101,10 @@ library Simplex.Messaging.Crypto.File Simplex.Messaging.Crypto.Lazy Simplex.Messaging.Crypto.Ratchet + Simplex.Messaging.Crypto.SNTRUP761.Bindings + Simplex.Messaging.Crypto.SNTRUP761.Bindings.Defines + Simplex.Messaging.Crypto.SNTRUP761.Bindings.FFI + Simplex.Messaging.Crypto.SNTRUP761.Bindings.RNG Simplex.Messaging.Encoding Simplex.Messaging.Encoding.String Simplex.Messaging.Notifications.Client @@ -149,6 +155,13 @@ library hs-source-dirs: src ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns + include-dirs: + cbits + c-sources: + cbits/sha512.c + cbits/sntrup761.c + extra-libraries: + crypto build-depends: aeson ==2.2.* , ansi-terminal >=0.10 && <0.12 diff --git a/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings.hs b/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings.hs new file mode 100644 index 000000000..0da90fbc9 --- /dev/null +++ b/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE NamedFieldPuns #-} + +module Simplex.Messaging.Crypto.SNTRUP761.Bindings where + +import Data.ByteArray (ScrubbedBytes) +import qualified Data.ByteArray as BA +import Data.ByteString (ByteString) +import Simplex.Messaging.Crypto.SNTRUP761.Bindings.Defines +import Simplex.Messaging.Crypto.SNTRUP761.Bindings.FFI +import Simplex.Messaging.Crypto.SNTRUP761.Bindings.RNG (RNG (..)) + +type PublicKey = ByteString + +type SecretKey = ScrubbedBytes + +type Ciphertext = ByteString + +type Key = ScrubbedBytes + +sntrup761Keypair :: RNG -> IO (PublicKey, SecretKey) +sntrup761Keypair RNG {rngContext, rngFunc} = do + BA.allocRet c_SNTRUP761_SECRETKEY_SIZE $ \skPtr -> + BA.alloc c_SNTRUP761_PUBLICKEY_SIZE $ \pkPtr -> + c_sntrup761_keypair pkPtr skPtr rngContext rngFunc + +sntrup761Enc :: RNG -> PublicKey -> IO (Ciphertext, Key) +sntrup761Enc RNG {rngContext, rngFunc} pk = + BA.withByteArray pk $ \pkPtr -> + BA.allocRet c_SNTRUP761_SIZE $ \kPtr -> + BA.alloc c_SNTRUP761_CIPHERTEXT_SIZE $ \cPtr -> + c_sntrup761_enc cPtr kPtr pkPtr rngContext rngFunc + +sntrup761Dec :: Ciphertext -> SecretKey -> IO Key +sntrup761Dec c sk = + BA.withByteArray sk $ \skPtr -> + BA.withByteArray c $ \cPtr -> + BA.alloc c_SNTRUP761_SIZE $ \kPtr -> + c_sntrup761_dec kPtr cPtr skPtr diff --git a/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/Defines.hsc b/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/Defines.hsc new file mode 100644 index 000000000..a7ba2a09b --- /dev/null +++ b/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/Defines.hsc @@ -0,0 +1,17 @@ +module Simplex.Messaging.Crypto.SNTRUP761.Bindings.Defines where + +import Foreign.C + +#include "sntrup761.h" + +c_SNTRUP761_SECRETKEY_SIZE :: Int +c_SNTRUP761_SECRETKEY_SIZE = #{const SNTRUP761_SECRETKEY_SIZE} + +c_SNTRUP761_PUBLICKEY_SIZE :: Int +c_SNTRUP761_PUBLICKEY_SIZE = #{const SNTRUP761_PUBLICKEY_SIZE} + +c_SNTRUP761_CIPHERTEXT_SIZE :: Int +c_SNTRUP761_CIPHERTEXT_SIZE = #{const SNTRUP761_CIPHERTEXT_SIZE} + +c_SNTRUP761_SIZE :: Int +c_SNTRUP761_SIZE = #{const SNTRUP761_SIZE} diff --git a/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/FFI.hs b/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/FFI.hs new file mode 100644 index 000000000..922d54eae --- /dev/null +++ b/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/FFI.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +module Simplex.Messaging.Crypto.SNTRUP761.Bindings.FFI + ( c_sntrup761_keypair, + c_sntrup761_enc, + c_sntrup761_dec, + ) where + +import Foreign +import Foreign.C +import Simplex.Messaging.Crypto.SNTRUP761.Bindings.RNG (RNGContext, RNGFunc) + +-- void sntrup761_keypair (uint8_t *pk, uint8_t *sk, void *random_ctx, sntrup761_random_func *random); +foreign import ccall "sntrup761_keypair" + c_sntrup761_keypair :: Ptr Word8 -> Ptr Word8 -> RNGContext -> FunPtr RNGFunc -> IO () + +-- void sntrup761_enc (uint8_t *c, uint8_t *k, const uint8_t *pk, void *random_ctx, sntrup761_random_func *random); +foreign import ccall "sntrup761_enc" + c_sntrup761_enc :: Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> RNGContext -> FunPtr RNGFunc -> IO () + +-- void sntrup761_dec (uint8_t *k, const uint8_t *c, const uint8_t *sk); +foreign import ccall "sntrup761_dec" + c_sntrup761_dec :: Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> IO () diff --git a/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/RNG.hs b/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/RNG.hs new file mode 100644 index 000000000..4ed1d5ee0 --- /dev/null +++ b/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/RNG.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE NamedFieldPuns #-} + +module Simplex.Messaging.Crypto.SNTRUP761.Bindings.RNG + ( RNG (..), + withRNG, + createRNG, + freeRNG, + RNGContext, + RNGFunc, + mkRNGFunc, + ) where + +import Foreign +import Foreign.C + +import Crypto.Random (drgNew, randomBytesGenerate) +import Data.ByteArray (ByteArrayAccess (copyByteArrayToPtr), Bytes) +import Data.IORef (atomicModifyIORef', newIORef) +import UnliftIO (bracket) + +data RNG = RNG + { rngContext :: RNGContext, + rngFunc :: FunPtr RNGFunc + } + +withRNG :: (RNG -> IO c) -> IO c +withRNG = bracket createRNG freeRNG + +createRNG :: IO RNG +createRNG = do + chachaState <- drgNew >>= newIORef -- XXX: ctxPtr could be used to store drg state, but cryptonite doesn't provide ByteAccess for ChaChaDRG + rngFunc <- mkRNGFunc $ \_ctxPtr sz buf -> do + bs <- atomicModifyIORef' chachaState $ swap . randomBytesGenerate (fromIntegral sz) :: IO Bytes + copyByteArrayToPtr bs buf + pure RNG {rngContext = nullPtr, rngFunc} + where + swap (a, b) = (b, a) + +freeRNG :: RNG -> IO () +freeRNG RNG {rngFunc} = freeHaskellFunPtr rngFunc + +type RNGContext = Ptr RNG + +-- typedef void random_func (void *ctx, size_t length, uint8_t *dst); +type RNGFunc = Ptr RNGContext -> CSize -> Ptr Word8 -> IO () + +foreign import ccall "wrapper" + mkRNGFunc :: RNGFunc -> IO (FunPtr RNGFunc) diff --git a/tests/CoreTests/CryptoTests.hs b/tests/CoreTests/CryptoTests.hs index 6ecc865c1..af613fe84 100644 --- a/tests/CoreTests/CryptoTests.hs +++ b/tests/CoreTests/CryptoTests.hs @@ -15,6 +15,8 @@ import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Encoding as LE import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto.Lazy as LC +import Simplex.Messaging.Crypto.SNTRUP761.Bindings +import Simplex.Messaging.Crypto.SNTRUP761.Bindings.RNG import Test.Hspec import Test.Hspec.QuickCheck (modifyMaxSuccess) import Test.QuickCheck @@ -87,6 +89,8 @@ cryptoTests = do describe "Ed448" $ testEncoding C.SEd448 describe "X25519" $ testEncoding C.SX25519 describe "X448" $ testEncoding C.SX448 + describe "sntrup761" $ + it "should enc/dec key" testSNTRUP761 testPadUnpadFile :: IO () testPadUnpadFile = do @@ -197,3 +201,9 @@ testEncoding alg = it "should encode / decode key" . ioProperty $ do pure $ \(_ :: Int) -> C.decodePubKey (C.encodePubKey k) == Right k && C.decodePrivKey (C.encodePrivKey pk) == Right pk + +testSNTRUP761 :: IO () +testSNTRUP761 = withRNG $ \rng -> do + (pk, sk) <- sntrup761Keypair rng + (c, k) <- sntrup761Enc rng pk + sntrup761Dec c sk `shouldReturn` k From a5fed340e2814a226180ce1abe606ac79366fe5b Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Wed, 1 Nov 2023 10:33:15 +0000 Subject: [PATCH 04/16] hybrid shared secret X25519 + sntrup761 (#881) * hybrid shared secret X25519 + sntrup761 * use IORef * enable all tests * update * update * use newtype * move withDRG --- simplexmq.cabal | 1 + src/Simplex/Messaging/Crypto.hs | 2 + src/Simplex/Messaging/Crypto/SNTRUP761.hs | 28 ++++++++ .../Messaging/Crypto/SNTRUP761/Bindings.hs | 66 +++++++++++++------ .../Crypto/SNTRUP761/Bindings/Defines.hsc | 2 - .../Crypto/SNTRUP761/Bindings/FFI.hs | 4 +- .../Crypto/SNTRUP761/Bindings/RNG.hs | 44 ++++--------- tests/CoreTests/CryptoTests.hs | 14 ++-- 8 files changed, 100 insertions(+), 61 deletions(-) create mode 100644 src/Simplex/Messaging/Crypto/SNTRUP761.hs diff --git a/simplexmq.cabal b/simplexmq.cabal index c8ed1f759..9f8937e5b 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -101,6 +101,7 @@ library Simplex.Messaging.Crypto.File Simplex.Messaging.Crypto.Lazy Simplex.Messaging.Crypto.Ratchet + Simplex.Messaging.Crypto.SNTRUP761 Simplex.Messaging.Crypto.SNTRUP761.Bindings Simplex.Messaging.Crypto.SNTRUP761.Bindings.Defines Simplex.Messaging.Crypto.SNTRUP761.Bindings.FFI diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs index cfc8156cf..4370a247a 100644 --- a/src/Simplex/Messaging/Crypto.hs +++ b/src/Simplex/Messaging/Crypto.hs @@ -115,6 +115,8 @@ module Simplex.Messaging.Crypto cbEncrypt, cbEncryptMaxLenBS, cbDecrypt, + sbDecrypt_, + sbEncrypt_, cbNonce, randomCbNonce, pseudoRandomCbNonce, diff --git a/src/Simplex/Messaging/Crypto/SNTRUP761.hs b/src/Simplex/Messaging/Crypto/SNTRUP761.hs new file mode 100644 index 000000000..db29508e8 --- /dev/null +++ b/src/Simplex/Messaging/Crypto/SNTRUP761.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} + +module Simplex.Messaging.Crypto.SNTRUP761 where + +import Crypto.Hash (Digest, SHA256, hash) +import Data.ByteArray (ScrubbedBytes) +import qualified Data.ByteArray as BA +import Data.ByteString (ByteString) +import Simplex.Messaging.Crypto +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/ + +newtype KEMHybridSecret = KEMHybridSecret ScrubbedBytes + +-- | 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 + +-- | 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 + +kemHybridSecret :: DhSecret 'X25519 -> KEMSharedKey -> KEMHybridSecret +kemHybridSecret (DhSecretX25519 k1) (KEMSharedKey k2) = + KEMHybridSecret $ BA.convert (hash $ BA.convert k1 <> k2 :: Digest SHA256) diff --git a/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings.hs b/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings.hs index 0da90fbc9..3c430e76f 100644 --- a/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings.hs +++ b/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings.hs @@ -1,38 +1,64 @@ -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeApplications #-} module Simplex.Messaging.Crypto.SNTRUP761.Bindings where +import Control.Concurrent.STM +import Crypto.Random (ChaChaDRG) +import Data.Bifunctor (bimap) import Data.ByteArray (ScrubbedBytes) import qualified Data.ByteArray as BA import Data.ByteString (ByteString) +import Foreign (nullPtr) import Simplex.Messaging.Crypto.SNTRUP761.Bindings.Defines import Simplex.Messaging.Crypto.SNTRUP761.Bindings.FFI -import Simplex.Messaging.Crypto.SNTRUP761.Bindings.RNG (RNG (..)) +import Simplex.Messaging.Crypto.SNTRUP761.Bindings.RNG (withDRG) +import Simplex.Messaging.Encoding +import Simplex.Messaging.Encoding.String -type PublicKey = ByteString +newtype KEMPublicKey = KEMPublicKey ByteString -type SecretKey = ScrubbedBytes +newtype KEMSecretKey = KEMSecretKey ScrubbedBytes -type Ciphertext = ByteString +newtype KEMCiphertext = KEMCiphertext ByteString -type Key = ScrubbedBytes +newtype KEMSharedKey = KEMSharedKey ScrubbedBytes -sntrup761Keypair :: RNG -> IO (PublicKey, SecretKey) -sntrup761Keypair RNG {rngContext, rngFunc} = do - BA.allocRet c_SNTRUP761_SECRETKEY_SIZE $ \skPtr -> - BA.alloc c_SNTRUP761_PUBLICKEY_SIZE $ \pkPtr -> - c_sntrup761_keypair pkPtr skPtr rngContext rngFunc +sntrup761Keypair :: TVar ChaChaDRG -> IO (KEMPublicKey, KEMSecretKey) +sntrup761Keypair drg = + bimap KEMPublicKey KEMSecretKey + <$> BA.allocRet + c_SNTRUP761_SECRETKEY_SIZE + ( \skPtr -> + BA.alloc c_SNTRUP761_PUBLICKEY_SIZE $ \pkPtr -> + withDRG drg $ c_sntrup761_keypair pkPtr skPtr nullPtr + ) -sntrup761Enc :: RNG -> PublicKey -> IO (Ciphertext, Key) -sntrup761Enc RNG {rngContext, rngFunc} pk = +sntrup761Enc :: TVar ChaChaDRG -> KEMPublicKey -> IO (KEMCiphertext, KEMSharedKey) +sntrup761Enc drg (KEMPublicKey pk) = BA.withByteArray pk $ \pkPtr -> - BA.allocRet c_SNTRUP761_SIZE $ \kPtr -> - BA.alloc c_SNTRUP761_CIPHERTEXT_SIZE $ \cPtr -> - c_sntrup761_enc cPtr kPtr pkPtr rngContext rngFunc + bimap KEMCiphertext KEMSharedKey + <$> BA.allocRet + c_SNTRUP761_SIZE + ( \kPtr -> + BA.alloc c_SNTRUP761_CIPHERTEXT_SIZE $ \cPtr -> + withDRG drg $ c_sntrup761_enc cPtr kPtr pkPtr nullPtr + ) -sntrup761Dec :: Ciphertext -> SecretKey -> IO Key -sntrup761Dec c sk = +sntrup761Dec :: KEMCiphertext -> KEMSecretKey -> IO KEMSharedKey +sntrup761Dec (KEMCiphertext c) (KEMSecretKey sk) = BA.withByteArray sk $ \skPtr -> BA.withByteArray c $ \cPtr -> - BA.alloc c_SNTRUP761_SIZE $ \kPtr -> - c_sntrup761_dec kPtr cPtr skPtr + 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 diff --git a/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/Defines.hsc b/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/Defines.hsc index a7ba2a09b..1f18e16d0 100644 --- a/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/Defines.hsc +++ b/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/Defines.hsc @@ -1,7 +1,5 @@ module Simplex.Messaging.Crypto.SNTRUP761.Bindings.Defines where -import Foreign.C - #include "sntrup761.h" c_SNTRUP761_SECRETKEY_SIZE :: Int diff --git a/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/FFI.hs b/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/FFI.hs index 922d54eae..4983e9210 100644 --- a/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/FFI.hs +++ b/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/FFI.hs @@ -12,11 +12,11 @@ import Simplex.Messaging.Crypto.SNTRUP761.Bindings.RNG (RNGContext, RNGFunc) -- void sntrup761_keypair (uint8_t *pk, uint8_t *sk, void *random_ctx, sntrup761_random_func *random); foreign import ccall "sntrup761_keypair" - c_sntrup761_keypair :: Ptr Word8 -> Ptr Word8 -> RNGContext -> FunPtr RNGFunc -> IO () + c_sntrup761_keypair :: Ptr Word8 -> Ptr Word8 -> Ptr RNGContext -> FunPtr RNGFunc -> IO () -- void sntrup761_enc (uint8_t *c, uint8_t *k, const uint8_t *pk, void *random_ctx, sntrup761_random_func *random); foreign import ccall "sntrup761_enc" - c_sntrup761_enc :: Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> RNGContext -> FunPtr RNGFunc -> IO () + c_sntrup761_enc :: Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> Ptr RNGContext -> FunPtr RNGFunc -> IO () -- void sntrup761_dec (uint8_t *k, const uint8_t *c, const uint8_t *sk); foreign import ccall "sntrup761_dec" diff --git a/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/RNG.hs b/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/RNG.hs index 4ed1d5ee0..e776f610d 100644 --- a/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/RNG.hs +++ b/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/RNG.hs @@ -1,45 +1,27 @@ -{-# LANGUAGE NamedFieldPuns #-} - module Simplex.Messaging.Crypto.SNTRUP761.Bindings.RNG - ( RNG (..), - withRNG, - createRNG, - freeRNG, + ( withDRG, RNGContext, RNGFunc, - mkRNGFunc, ) where +import Control.Concurrent.STM +import Control.Exception (bracket) +import Crypto.Random (ChaChaDRG) +import Data.ByteArray (ByteArrayAccess (copyByteArrayToPtr)) import Foreign import Foreign.C +import qualified Simplex.Messaging.Crypto as C -import Crypto.Random (drgNew, randomBytesGenerate) -import Data.ByteArray (ByteArrayAccess (copyByteArrayToPtr), Bytes) -import Data.IORef (atomicModifyIORef', newIORef) -import UnliftIO (bracket) +withDRG :: TVar ChaChaDRG -> (FunPtr RNGFunc -> IO a) -> IO a +withDRG drg = bracket (createRNGFunc drg) freeHaskellFunPtr -data RNG = RNG - { rngContext :: RNGContext, - rngFunc :: FunPtr RNGFunc - } - -withRNG :: (RNG -> IO c) -> IO c -withRNG = bracket createRNG freeRNG - -createRNG :: IO RNG -createRNG = do - chachaState <- drgNew >>= newIORef -- XXX: ctxPtr could be used to store drg state, but cryptonite doesn't provide ByteAccess for ChaChaDRG - rngFunc <- mkRNGFunc $ \_ctxPtr sz buf -> do - bs <- atomicModifyIORef' chachaState $ swap . randomBytesGenerate (fromIntegral sz) :: IO Bytes +createRNGFunc :: TVar ChaChaDRG -> IO (FunPtr RNGFunc) +createRNGFunc drg = + mkRNGFunc $ \_ctx sz buf -> do + bs <- atomically $ C.pseudoRandomBytes (fromIntegral sz) drg copyByteArrayToPtr bs buf - pure RNG {rngContext = nullPtr, rngFunc} - where - swap (a, b) = (b, a) -freeRNG :: RNG -> IO () -freeRNG RNG {rngFunc} = freeHaskellFunPtr rngFunc - -type RNGContext = Ptr RNG +type RNGContext = () -- typedef void random_func (void *ctx, size_t length, uint8_t *dst); type RNGFunc = Ptr RNGContext -> CSize -> Ptr Word8 -> IO () diff --git a/tests/CoreTests/CryptoTests.hs b/tests/CoreTests/CryptoTests.hs index af613fe84..fb902a41e 100644 --- a/tests/CoreTests/CryptoTests.hs +++ b/tests/CoreTests/CryptoTests.hs @@ -3,8 +3,9 @@ module CoreTests.CryptoTests (cryptoTests) where +import Control.Concurrent.STM import Control.Monad.Except -import Crypto.Random (getRandomBytes) +import Crypto.Random (drgNew, getRandomBytes) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB import Data.Either (isRight) @@ -16,7 +17,6 @@ import qualified Data.Text.Lazy.Encoding as LE import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto.Lazy as LC import Simplex.Messaging.Crypto.SNTRUP761.Bindings -import Simplex.Messaging.Crypto.SNTRUP761.Bindings.RNG import Test.Hspec import Test.Hspec.QuickCheck (modifyMaxSuccess) import Test.QuickCheck @@ -203,7 +203,9 @@ testEncoding alg = it "should encode / decode key" . ioProperty $ do && C.decodePrivKey (C.encodePrivKey pk) == Right pk testSNTRUP761 :: IO () -testSNTRUP761 = withRNG $ \rng -> do - (pk, sk) <- sntrup761Keypair rng - (c, k) <- sntrup761Enc rng pk - sntrup761Dec c sk `shouldReturn` k +testSNTRUP761 = do + drg <- newTVarIO =<< drgNew + (pk, sk) <- sntrup761Keypair drg + (c, KEMSharedKey k) <- sntrup761Enc drg pk + KEMSharedKey k' <- sntrup761Dec c sk + k' `shouldBe` k From 1a8dfb4cbecdd22edbc902b3bbc9b5ec6046ab67 Mon Sep 17 00:00:00 2001 From: Alexander Bondarenko <486682+dpwiz@users.noreply.github.com> Date: Tue, 7 Nov 2023 15:05:18 +0200 Subject: [PATCH 05/16] 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> --- package.yaml | 1 + rfcs/2023-10-25-remote-control.md | 154 +++-- simplexmq.cabal | 10 + src/Simplex/FileTransfer/Protocol.hs | 1 - src/Simplex/Messaging/Agent.hs | 39 ++ src/Simplex/Messaging/Agent/Protocol.hs | 5 + src/Simplex/Messaging/Client.hs | 2 +- src/Simplex/Messaging/Crypto.hs | 5 + src/Simplex/Messaging/Crypto/SNTRUP761.hs | 30 +- .../Messaging/Crypto/SNTRUP761/Bindings.hs | 24 +- src/Simplex/Messaging/Encoding.hs | 4 + src/Simplex/Messaging/Protocol.hs | 3 - src/Simplex/Messaging/Transport/Client.hs | 24 +- .../Messaging/Transport/Credentials.hs | 8 +- .../Messaging/Transport/HTTP2/Client.hs | 2 +- src/Simplex/RemoteControl/Client.hs | 528 ++++++++++++++++++ src/Simplex/RemoteControl/Discovery.hs | 159 +++--- src/Simplex/RemoteControl/Invitation.hs | 176 ++++++ src/Simplex/RemoteControl/Types.hs | 248 ++++---- tests/CoreTests/ProtocolErrorTests.hs | 6 + tests/RemoteControl.hs | 66 +++ tests/Test.hs | 2 + 22 files changed, 1181 insertions(+), 316 deletions(-) create mode 100644 src/Simplex/RemoteControl/Client.hs create mode 100644 src/Simplex/RemoteControl/Invitation.hs create mode 100644 tests/RemoteControl.hs diff --git a/package.yaml b/package.yaml index f76d56313..90ac1af81 100644 --- a/package.yaml +++ b/package.yaml @@ -52,6 +52,7 @@ dependencies: - memory == 0.18.* - mtl == 2.3.* - network >= 3.1.2.7 && < 3.2 + - network-info >= 0.2 && < 0.3 - network-transport == 0.5.6 - network-udp >= 0.0 && < 0.1 - optparse-applicative >= 0.15 && < 0.17 diff --git a/rfcs/2023-10-25-remote-control.md b/rfcs/2023-10-25-remote-control.md index 66ece9577..ba731bc13 100644 --- a/rfcs/2023-10-25-remote-control.md +++ b/rfcs/2023-10-25-remote-control.md @@ -1,100 +1,101 @@ # SimpleX Remote Control protocol -Using profiles in SimpleX Chat mobile app from desktop app with minimal risk to the security model of SimpleX protocols. +Using profiles in SimpleX Chat mobile app from desktop app with minimal risk to the security/threat model of SimpleX protocols. ## Problem -Synchronizing profiles that use double ratchet for e2e encryption is effectively impossible in a way that tolerates partitioning between devices. +Synchronizing profiles that use double ratchet for e2e encryption is effectively impossible in a way that tolerates partitioning between devices without reducing security of double ratchet. -We are not considering replacing double ratchet to allow profile synchronization, as some other messengers did. We are also not considering Signal model, when profile is known to the server and adding devices results in changing security code and no visibility of conversation history, as it would be substantially different from the current model. +We are not considering replacing (or weakening) double ratchet to allow profile synchronization, as some other messengers did (e.g., Session). We are also not considering Signal model, when profile is known to the server and adding devices results in changing security code and no visibility of conversation history, as it would be substantially different from the current model, and also effectively weakens the security, as in practives most users don't revalidate security codes when they change. ## Solution -The proposed option is remote access/control protocol, when the application on host device (usually mobile) acts as a server, and application on another device (usually desktop) acts as a controller usually running in the same local network. +The proposed solution is a new remote access/control protocol, when the application on host device (usually mobile) acts as a server, and application on another device (usually desktop) acts as a controller usually running in the same local network. -Service discovery and remote control protocols known to us are vulnerable to spoofing, spamming and MITM attacks. This design aims to solve these problems. +Existing service discovery and remote control protocols known to us are vulnerable to spoofing, spamming and MITM attacks. This design aims to solve these problems. ## Requirements - Strong, cryptographically verified identity of the controller device, with the initial connection requiring out-of-band communication of public keys (QR code or link). +- Identity verification of the host device during session handshake. - Protection against malicious "controllers" trying to make host connect to them instead of valid controller on the same network. - Protection against replay attacks, both during discovery and during control session. -- Additional encryption layer inside TLS. +- Additional encryption layer inside TLS, with post-quantum algorithm in key agreement. - Protect host device from unauthorized access in case of controller compromise. -- Have post-compromised security - that is, even if long term secrets were copied from the controller, and host device was made to connect to malicious controller device, prevent malicious controller from accessing the host device data. -- Support general high-level interactions common for many applications: +- Post-compromised security - that is, even if long term secrets were copied from the controller, and host device was made to connect to malicious controller device, prevent malicious controller from accessing the host device data. +- Allow general high-level interactions common for many applications: - RPC pattern for commands executed by the host application. - Events sent by host to update controller UI. - Uploading and downloading files between host and controller, either to be processed by the host or to be presented in the controller UI. -This design is quite close to how SimpleX Chat UI interacts with SimpleX Chat core - there is a similar RPC + events protocol and support for files. +This design will allow application-level protocol that is quite close to how SimpleX Chat UI interacts with SimpleX Chat core - there is a similar RPC + events protocol and support for files. The application-level protocol is out of scope of this specification. ## Protocol phases Protocol consists of four phases: -- controller session announcement +- controller session invitation - establishing session TLS connection - session verification and protocol negotiation - session operation -### Session announcement +### Session invitation -The first session between host and controller pair MUST be announced out-of-band, to establish a long term identity keys/certificates of the controller to host device. +The invitation to the first session between host and controller pair MUST be shared out-of-band, to establish a long term identity keys/certificates of the controller to host device. -The subsequent sessions will be announced via an application-defined site-local multicast group, e.g. `224.0.0.251` (also used in mDNS/bonjour) and an application-defined port (SimpleX Chat uses 5227). +The subsequent sessions can be announced via an application-defined site-local multicast group, e.g. `224.0.0.251` (also used in mDNS/bonjour) and an application-defined port (SimpleX Chat uses 5227). -The session announcement contains this data: +The session invitation contains this data: - supported version range for remote control protocol -- application name -- device name +- application-specific information, e.g. device name, application name and supported version range, settings, etc. - session start time in seconds since epoch - if multicast is used, counter of announce packets sent by controller - network address (ipv4 address and port) of the controller - 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. - 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. - Long-term Ed25519 public key used to verify the announcement and commands - this is part of the long term controller identity. -- Session X25519 DH key and sntrup761 KEM encapsulation key to agree session encryption (both for multicast announcement and for commands and responses in TLS), as described in https://datatracker.ietf.org/doc/draft-josefsson-ntruprime-hybrid/. The new keys are used for each session, and if client key is already available (from the previous session), the computed shared secret will be used to encrypt the announcement multicast packet. The initial out-of-band announcement is always unencrypted. These DH and KEM key are always sent unencrypted. NaCL Cryptobox is used for encryption. -- additional application specific parameters, e.g controller settings. +- Session X25519 DH key and sntrup761 KEM encapsulation key to agree session encryption (both for multicast announcement and for commands and responses in TLS), as described in https://datatracker.ietf.org/doc/draft-josefsson-ntruprime-hybrid/. The new keys are used for each session, and if client key is already available (from the previous session), the computed shared secret will be used to encrypt the announcement multicast packet. The out-of-band invitation is unencrypted. These DH public key and KEM encapsulation key are always sent unencrypted. NaCL Cryptobox is used for encryption. -Host device decrypts (except the first session) and validates the announcement: +Host device decrypts (except the first session) and validates the invitation: - Session signature is valid. - Timestamp is within some window from the current time. - Long-term key signature is valid. -- Long-term CA and key are the same as in the first session. -- Some version in the range can be supported. +- Long-term CA and signature key are the same as in the first session. +- Some version in the offered range is supported. -OOB announcement is a URI with this syntax: +OOB session invitation is a URI with this syntax: ```abnf sessionAddressUri = "xrcp://" encodedCAFingerprint "@" host ":" port "#/?" qsParams encodedCAFingerprint = base64url qsParams = param *("&" param) -param = versionRangeParam / appNameParam / appVerionRangeParam / deviceNameParam / sessionTsParam / +param = versionRangeParam / appInfoParam / sessionTsParam / sessPubKeyParam / idPubKeyParam / kemEncKeyParam / dhPubKeyParam / sessSignatureParam / idSignatureParam versionRangeParam = "v=" (versionParam / (versionParam "-" versionParam)) versionParam = 1*DIGIT -appNameParam = "app=" 1*(ALPHA / DIGIT / "-" / "_") ; optional -appVerionRangeParam = "appv=" (versionParam / (versionParam "-" versionParam)) ; optional -deviceNameParam = "device=" 1*(ALPHA / DIGIT / "-" / "_") ; optional +appInfoParam = "app=" escapedJSON ; optional sessionTsParam = "ts=" 1*DIGIT sessPubKeyParam = "skey=" base64url ; required idPubKeyParam = "idkey=" base64url ; required -kemEncKeyParam = "kem=" base64url ; required, can we have x509encoded? dhPubKeyParam = "dh=" base64url ; required sessSignatureParam = "ssig=" base64url ; required, signs the URI with this and idSignatureParam param removed idSignatureParam = "idsig=" base64url ; required, signs the URI with this param removed base64url = ; RFC4648, section 5 ``` -Multicast announcement is a binary encoded packet with this syntax: +Multicast session announcement is a binary encoded packet with this syntax: ```abnf -sessionAddressPacket = dhPubKey length encrypted(serviceAddress sessSignature idSignature) +sessionAddressPacket = dhPubKey nonce encrypted(unpaddedSize serviceAddress sessSignature idSignature packetPad) dhPubKey = length x509encoded -serviceAddress = length addressJSON +nonce = length *OCTET +serviceAddress = largeLength serviceAddressJSON sessSignature = length *OCTET ; signs the preceding announcement packet idSignature = length *OCTET ; signs the preceding announcement packet including sessSignature +length = 1*1 OCTET ; for binary data up to 255 bytes +largeLength = 2*2 OCTET ; for binary data up to 65535 bytes +packetPad = ; possibly, we may need to move KEM agreement one step later, +; with encapsulation key in HELLO block and KEM ciphertext in reply to HELLO. ``` addressJSON is a JSON string valid against this JTD (RFC 8927) schema: @@ -122,13 +123,10 @@ addressJSON is a JSON string valid against this JTD (RFC 8927) schema: "v": {"ref": "versionRange"}, "ts": {"type": "uint64"}, "skey": {"ref": "base64url"}, - "idkey": {"ref": "base64url"}, - "kem": {"ref": "base64url"} + "idkey": {"ref": "base64url"} }, "optionalProperties": { - "app": {"type": "string"}, - "appv": {"ref": "versionRange"}, - "device": {"type": "string"} + "app": {"properties": {}, "additionalProperties": true} }, "additionalProperties": true } @@ -136,41 +134,42 @@ addressJSON is a JSON string valid against this JTD (RFC 8927) schema: ### Establishing session TLS connection -Host connects to controller via TCP session and validates CA credentials during TLS handshake. Controller acts as a TCP server in this connection, to avoid host device listening on a port, which might create an attack vector. During TLS handshake the controller's TCP server presents a self-signed two-certificate chain where the fingerprint of the first certificate MUST be the same as in the announcement. +Host connects to controller via TCP session and validates CA credentials during TLS handshake. Controller acts as a TCP server in this connection, to avoid host device listening on a port, which might create an attack vector. During TLS handshake the controller's TCP server MUST present a self-signed two-certificate chain where the fingerprint of the first certificate MUST be the same as in the announcement. Host device presents its own client certificate chain with CA representing a long-term identity of the host device. ### Session verification and protocol negotiation -Once TLS session is established, both the host and controller device present a "session security code" to the user who must match them (e.g., visually or via QR code scan) and confirm on the host device. The session security code must be a digest of tlsunique channel binding. As it is computed as a digest of the TLS handshake for both the controller and the host, it will validate that the same TLS certificates are used on both sides, and that the same TLS session is established. +Once TLS session is established, both the host and controller device present a "session security code" to the user who must match them (e.g., visually or via QR code scan) and confirm on the host device. The session security code must be a digest of tlsunique channel binding. As it is computed as a digest of the TLS handshake for both the controller and the host, it will validate that the same TLS certificates are used on both sides, and that the same TLS session is established, mitigating the possibility of MITM attack in the connection. Once the session is confirmed by the user, the host device sends "hello" block to the controller. ALPN TLS extension is not used to obtain tlsunique prior to sending any packets. Block size should be 16384 bytes. -Hello block must contain: -- KEM ciphertext with encapsulated secret and new session DH key - used to compute new shared secret with the controller keys from the announcement. +Host HELLO must contain: +- new session DH key - used to compute new shared secret with the controller keys from the announcement. - encrypted part of hello block (JSON object), containing: - chosen protocol version. - host CA TLS certificate fingerprint - part of host long term identity - must match the one presented in TLS handshake and the previous sessions, otherwise the connection is terminated. - - host device name - - chosen application version. - - additional application specific parameters, e.g host settings or JSON encoding format. + - KEM encapsulation key - used to compute new shared secret for the session. + - additional application specific parameters, e.g host device name, application version, host settings or JSON encoding format. Hello block syntax: - + ```abnf -helloBlock = unpaddedSize %s"HELLO " dhPubKey kemCiphertext length encrypted(length helloBlockJSON) pad -unpaddedSize = 2*2 OCTET +hostHello = unpaddedSize %s"HELLO " dhPubKey nonce encrypted(unpaddedSize hostHelloJSON helloPad) pad +unpaddedSize = largeLength +dhPubKey = length x509encoded pad = -kemCiphertext = length base64url +helloPad = +largeLength = 2*2 OCTET ``` Controller decrypts (including the first session) and validates the received hello block: - Chosen versions are supported (must be within offered ranges). - CA fingerprint matches the one presented in TLS handshake and the previous sessions - in subsequent sessions TLS connection should be rejected if the fingerprint is different. -JTD schema for the encrypted part of hello block: +JTD schema for the encrypted part of host HELLO block `hostHelloJSON`: ```json { @@ -191,29 +190,61 @@ JTD schema for the encrypted part of hello block: "properties": { "v": {"ref": "version"}, "ca": {"ref": "base64url"}, + "kem": {"ref": "base64url"} }, "optionalProperties": { - "device": {"type": "string"}, - "appVersion": {"ref": "version"} + "app": {"properties": {}, "additionalProperties": true} }, "additionalProperties": true } ``` -Controller should reply with with `ok` or `err` block: +Controller should reply with with `hello` or `error` response: +```abnf +ctrlHello = unpaddedSize %s"HELLO " kemCyphertext nonce encrypted(unpaddedSize ctrlHelloJSON helloPad) pad +; ctrlHelloJSON is encrypted with the hybrid secret, +; including both previously agreed DH secret and KEM secret from kemCyphertext +unpaddedSize = largeLength +kemCyphertext = largeLength *OCTET +pad = +helloPad = +largeLength = 2*2 OCTET + +ctrlError = unpaddedSize %s"ERROR " nonce encrypted(unpaddedSize ctrlErrorJSON helloPad) pad +; ctrlErrorJSON is encrypted using previously agreed DH secret. ``` -ok = unpaddedSize %s"OK" pad -err = unpaddedSize %s"ERR " length error pad + +JTD schema for the encrypted part of controller HELLO block `ctrlHelloJSON`: + +```json +{ + "properties": {}, + "additionalProperties": true +} ``` +JTD schema for the encrypted part of controller ERROR block `ctrlErrorJSON`: + +```json +{ + "properties": { + "message": {"type": "string"} + }, + "additionalProperties": true +} +``` + +Once controller replies HELLO to the valid host HELLO block, it should stop accepting new TCP connections. + + ### Сontroller/host session operation The protocol for communication during the session is out of scope of this protocol. SimpleX Chat will use HTTP2 encoding, where host device acts as a server and controller acts as a client (these roles are reversed compared with TLS connection). -Payloads in the protocol must be encrypted using NaCL cryptobox using the shared secret agreed during session establishment. +Payloads in the protocol must be encrypted using NaCL cryptobox using the hybrid shared secret agreed during session establishment. Commands of the controller must be signed after the encryption using the controller's session and long term Ed25519 keys. @@ -232,27 +263,30 @@ counter = 8*8 OCTET ; int64 Initial announcement is shared out-of-band, and it is not encrypted. -This announcement contains DH and KEM keys, which are used to agree session encryption keys - the HELLO block will containt DH key and KEM ciphertext with encapsulated secret that will be used to determine the shared secret (using SHA512 over concatenated DH shared secret and KEM encapsulated secret). +This announcement contains only DH keys, as KEM key is too large to include in QR code, which are used to agree encryption key for host HELLO block. The host HELLO block will containt DH key in plaintext part and KEM encapsulation (public) key in encrypted part, that will be used to determine the shared secret (using SHA256 over concatenated DH shared secret and KEM encapsulated secret) both for controller HELLO response (that contains KEM cyphertext in plaintext part) and subsequent session commands and responses. -During the next session we send announcement via encrypted multicast block. The shared key for this secret is determined using the KEM shared secred from the previous session and DH shared secret computed using the host DH key from the previous session and the new controller DH key from the announcement. +During the next session the announcement is sent via encrypted multicast block. The shared key for this announcement and for host HELLO block is determined using the KEM shared secred from the previous session and DH shared secret computed using the host DH key from the previous session and the new controller DH key from the announcement. -For the session, the shared secred is computed again using the KEM shared secret encapsulated using the new KEM key from the announcement and DH shared secret computed using the host DH key from HELLO block and the new controller DH key from the announcement. +For the session, the shared secred is computed again using the KEM shared secret encapsulated by the controller using the new KEM key from the HOST hello block and DH shared secret computed using the host DH key from HELLO block and the new controller DH key from the announcement. To describe it in pseudocode: ``` // session 1 -sessionSecret(1) = sha512(dhSecret(1) || kemSecret(1)) // to encrypt session 1 data, incl. hello +hostHelloSecret(1) = dhSecret(1) +sessionSecret(1) = sha256(dhSecret(1) || kemSecret(1)) // to encrypt session 1 data, incl. controller hello dhSecret(1) = dh(hostHelloDhKey(1), controllerAnnouncementDhKey(1)) kemCiphertext(1) = enc(kemSecret(1), kemEncKey(1)) +// kemEncKey is included in host HELLO, kemCiphertext - in controller HELLO kemSecret(1) = dec(kemCiphertext(1), kemDecKey(1)) // announcement for session n -announcementSecret(n) = sha512(dhSecret(n') || kemSecret(n - 1)) +announcementSecret(n) = sha256(dhSecret(n') || kemSecret(n - 1)) dhSecret(n') = dh(hostHelloDhKey(n - 1), controllerAnnouncementDhKey(n)) // session n -sessionSecret(n) = sha512(dhSecret(n) || kemSecret(n)) +hostHelloSecret(n) = sha256(dhSecret(n) || kemSecret(n - 1)) +sessionSecret(n) = sha256(dhSecret(n) || kemSecret(n)) // to encrypt session n data, incl. controller hello dhSecret(n) = dh(hostHelloDhKey(n), controllerAnnouncementDhKey(n)) kemCiphertext(n) = enc(kemSecret(n), kemEncKey(n)) kemSecret(n) = dec(kemCiphertext(n), kemDecKey(n)) @@ -283,7 +317,7 @@ The alternative design will use mobile host device as TLS server. The session ne Pros: - no reversing server role between TLS and HTTP2 - TLS credentials are exchanged before TLS, so invalid credentials can be rejected during the handshake of the first session. -- if some other way to pass data from host to controller is added, then it can be used with host running in VM. +- if some other way to pass data from host to controller is added, then it can be used with host running in VM. Cons: - multicast is mandatory, as there is no efficient way to communicate from mobile to desktop. diff --git a/simplexmq.cabal b/simplexmq.cabal index c88353845..793a30b80 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -148,8 +148,10 @@ library Simplex.Messaging.Transport.WebSockets Simplex.Messaging.Util Simplex.Messaging.Version + Simplex.RemoteControl.Client Simplex.RemoteControl.Discovery Simplex.RemoteControl.Discovery.Multicast + Simplex.RemoteControl.Invitation Simplex.RemoteControl.Types other-modules: Paths_simplexmq @@ -192,6 +194,7 @@ library , memory ==0.18.* , mtl ==2.3.* , network >=3.1.2.7 && <3.2 + , network-info ==0.2.* , network-transport ==0.5.6 , network-udp ==0.0.* , optparse-applicative >=0.15 && <0.17 @@ -256,6 +259,7 @@ executable ntf-server , memory ==0.18.* , mtl ==2.3.* , network >=3.1.2.7 && <3.2 + , network-info ==0.2.* , network-transport ==0.5.6 , network-udp ==0.0.* , optparse-applicative >=0.15 && <0.17 @@ -321,6 +325,7 @@ executable smp-agent , memory ==0.18.* , mtl ==2.3.* , network >=3.1.2.7 && <3.2 + , network-info ==0.2.* , network-transport ==0.5.6 , network-udp ==0.0.* , optparse-applicative >=0.15 && <0.17 @@ -386,6 +391,7 @@ executable smp-server , memory ==0.18.* , mtl ==2.3.* , network >=3.1.2.7 && <3.2 + , network-info ==0.2.* , network-transport ==0.5.6 , network-udp ==0.0.* , optparse-applicative >=0.15 && <0.17 @@ -451,6 +457,7 @@ executable xftp , memory ==0.18.* , mtl ==2.3.* , network >=3.1.2.7 && <3.2 + , network-info ==0.2.* , network-transport ==0.5.6 , network-udp ==0.0.* , optparse-applicative >=0.15 && <0.17 @@ -516,6 +523,7 @@ executable xftp-server , memory ==0.18.* , mtl ==2.3.* , network >=3.1.2.7 && <3.2 + , network-info ==0.2.* , network-transport ==0.5.6 , network-udp ==0.0.* , optparse-applicative >=0.15 && <0.17 @@ -569,6 +577,7 @@ test-suite simplexmq-test FileDescriptionTests NtfClient NtfServerTests + RemoteControl ServerTests SMPAgentClient SMPClient @@ -616,6 +625,7 @@ test-suite simplexmq-test , memory ==0.18.* , mtl ==2.3.* , network >=3.1.2.7 && <3.2 + , network-info ==0.2.* , network-transport ==0.5.6 , network-udp ==0.0.* , optparse-applicative >=0.15 && <0.17 diff --git a/src/Simplex/FileTransfer/Protocol.hs b/src/Simplex/FileTransfer/Protocol.hs index 9d87a8f52..58392d685 100644 --- a/src/Simplex/FileTransfer/Protocol.hs +++ b/src/Simplex/FileTransfer/Protocol.hs @@ -51,7 +51,6 @@ import Simplex.Messaging.Protocol tEncode, tEncodeBatch, tParse, - _smpP, ) import Simplex.Messaging.Transport (SessionId, TransportError (..)) import Simplex.Messaging.Util (bshow, (<$?>)) diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 04236a78d..9e0b140f2 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -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 diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index 481034e01..c4058b75a 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -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 diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index 11d75b7ee..1b11f6465 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -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 diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs index 4370a247a..3ecf9e214 100644 --- a/src/Simplex/Messaging/Crypto.hs +++ b/src/Simplex/Messaging/Crypto.hs @@ -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 diff --git a/src/Simplex/Messaging/Crypto/SNTRUP761.hs b/src/Simplex/Messaging/Crypto/SNTRUP761.hs index db29508e8..2dd63c434 100644 --- a/src/Simplex/Messaging/Crypto/SNTRUP761.hs +++ b/src/Simplex/Messaging/Crypto/SNTRUP761.hs @@ -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 diff --git a/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings.hs b/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings.hs index 3c430e76f..8b5e192b3 100644 --- a/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings.hs +++ b/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings.hs @@ -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" diff --git a/src/Simplex/Messaging/Encoding.hs b/src/Simplex/Messaging/Encoding.hs index f2b0609bd..814a536c4 100644 --- a/src/Simplex/Messaging/Encoding.hs +++ b/src/Simplex/Messaging/Encoding.hs @@ -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 diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index 3d5d44c7d..c130d117e 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -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 = diff --git a/src/Simplex/Messaging/Transport/Client.hs b/src/Simplex/Messaging/Transport/Client.hs index a8ccdd9c9..2cd2a8ded 100644 --- a/src/Simplex/Messaging/Transport/Client.hs +++ b/src/Simplex/Messaging/Transport/Client.hs @@ -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] diff --git a/src/Simplex/Messaging/Transport/Credentials.hs b/src/Simplex/Messaging/Transport/Credentials.hs index db03b5c3a..e935ba2ad 100644 --- a/src/Simplex/Messaging/Transport/Credentials.hs +++ b/src/Simplex/Messaging/Transport/Credentials.hs @@ -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 diff --git a/src/Simplex/Messaging/Transport/HTTP2/Client.hs b/src/Simplex/Messaging/Transport/HTTP2/Client.hs index 595ab411e..17ddb9807 100644 --- a/src/Simplex/Messaging/Transport/HTTP2/Client.hs +++ b/src/Simplex/Messaging/Transport/HTTP2/Client.hs @@ -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 diff --git a/src/Simplex/RemoteControl/Client.hs b/src/Simplex/RemoteControl/Client.hs new file mode 100644 index 000000000..a58283b3e --- /dev/null +++ b/src/Simplex/RemoteControl/Client.hs @@ -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" diff --git a/src/Simplex/RemoteControl/Discovery.hs b/src/Simplex/RemoteControl/Discovery.hs index e085efa67..7e1f992f4 100644 --- a/src/Simplex/RemoteControl/Discovery.hs +++ b/src/Simplex/RemoteControl/Discovery.hs @@ -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 diff --git a/src/Simplex/RemoteControl/Invitation.hs b/src/Simplex/RemoteControl/Invitation.hs new file mode 100644 index 000000000..224417ea0 --- /dev/null +++ b/src/Simplex/RemoteControl/Invitation.hs @@ -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) diff --git a/src/Simplex/RemoteControl/Types.hs b/src/Simplex/RemoteControl/Types.hs index b01c47e9b..757119950 100644 --- a/src/Simplex/RemoteControl/Types.hs +++ b/src/Simplex/RemoteControl/Types.hs @@ -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) diff --git a/tests/CoreTests/ProtocolErrorTests.hs b/tests/CoreTests/ProtocolErrorTests.hs index cc6da7b6c..6dc6f2c02 100644 --- a/tests/CoreTests/ProtocolErrorTests.hs +++ b/tests/CoreTests/ProtocolErrorTests.hs @@ -2,6 +2,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-orphans #-} module CoreTests.ProtocolErrorTests where @@ -17,6 +18,7 @@ import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol (CommandError (..), ErrorType (..)) import Simplex.Messaging.Transport (HandshakeError (..), TransportError (..)) +import Simplex.RemoteControl.Types (RCErrorType (..)) import Test.Hspec import Test.Hspec.QuickCheck (modifyMaxSuccess) import Test.QuickCheck @@ -58,6 +60,8 @@ deriving instance Generic HandshakeError deriving instance Generic XFTPErrorType +deriving instance Generic RCErrorType + instance Arbitrary AgentErrorType where arbitrary = genericArbitraryU instance Arbitrary CommandErrorType where arbitrary = genericArbitraryU @@ -79,3 +83,5 @@ instance Arbitrary TransportError where arbitrary = genericArbitraryU instance Arbitrary HandshakeError where arbitrary = genericArbitraryU instance Arbitrary XFTPErrorType where arbitrary = genericArbitraryU + +instance Arbitrary RCErrorType where arbitrary = genericArbitraryU diff --git a/tests/RemoteControl.hs b/tests/RemoteControl.hs new file mode 100644 index 000000000..c4b49289e --- /dev/null +++ b/tests/RemoteControl.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} + +module RemoteControl where + +import AgentTests.FunctionalAPITests (runRight_) +import Control.Logger.Simple +import Crypto.Random (drgNew) +import qualified Data.Aeson as J +import qualified Simplex.RemoteControl.Client as RC +import Test.Hspec +import UnliftIO +import UnliftIO.Concurrent + +remoteControlTests :: Spec +remoteControlTests = do + describe "New controller/host pairing" $ do + it "should connect" testNewPairing + +testNewPairing :: IO () +testNewPairing = do + drg <- drgNew >>= newTVarIO + hp <- RC.newRCHostPairing + invVar <- newEmptyMVar + ctrl <- async . runRight_ $ do + logNote "c 1" + (inv, hc, r) <- RC.connectRCHost drg hp (J.String "app") + logNote "c 2" + putMVar invVar (inv, hc) + logNote "c 3" + Right (_sessId, r') <- atomically $ takeTMVar r + logNote "c 4" + Right (_rcHostSession, _rcHelloBody, _hp') <- atomically $ takeTMVar r' + logNote "c 5" + threadDelay 1000000 + logNote "ctrl: ciao" + liftIO $ RC.cancelHostClient hc + + (inv, hc) <- takeMVar invVar + -- logNote $ decodeUtf8 $ strEncode inv + + host <- async . runRight_ $ do + logNote "h 1" + (rcCtrlClient, r) <- RC.connectRCCtrlURI drg inv Nothing (J.String "app") + logNote "h 2" + Right (_sessId', r') <- atomically $ takeTMVar r + logNote "h 3" + liftIO $ RC.confirmCtrlSession rcCtrlClient True + logNote "h 4" + Right (_rcCtrlSession, _rcCtrlPairing) <- atomically $ takeTMVar r' + logNote "h 5" + threadDelay 1000000 + logNote "ctrl: adios" + + timeout 10000000 (waitCatch ctrl) >>= \case + Just (Right ()) -> pure () + err -> fail $ "Unexpected controller result: " <> show err + + waitCatch hc.action >>= \case + Left err -> fromException err `shouldBe` Just AsyncCancelled + Right () -> fail "Unexpected controller finish" + + timeout 10000000 (waitCatch host) >>= \case + Just (Right ()) -> pure () + err -> fail $ "Unexpected host result: " <> show err diff --git a/tests/Test.hs b/tests/Test.hs index 5c07cde1e..6493ba860 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -14,6 +14,7 @@ import CoreTests.UtilTests import CoreTests.VersionRangeTests import FileDescriptionTests (fileDescriptionTests) import NtfServerTests (ntfServerTests) +import RemoteControl (remoteControlTests) import ServerTests import Simplex.Messaging.Transport (TLS, Transport (..)) import Simplex.Messaging.Transport.WebSockets (WS) @@ -56,4 +57,5 @@ main = do describe "XFTP file description" fileDescriptionTests describe "XFTP CLI" xftpCLITests describe "XFTP agent" xftpAgentTests + describe "XRCP" remoteControlTests describe "Server CLIs" cliTests From c0566d37a00fe179284a2b45dc1cefeafe00cd5d Mon Sep 17 00:00:00 2001 From: Alexander Bondarenko <486682+dpwiz@users.noreply.github.com> Date: Tue, 7 Nov 2023 19:09:38 +0200 Subject: [PATCH 06/16] add To/FromField instance to KEMShardKey (#886) --- src/Simplex/Messaging/Crypto/SNTRUP761/Bindings.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings.hs b/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings.hs index 8b5e192b3..0940c53ba 100644 --- a/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings.hs +++ b/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings.hs @@ -9,6 +9,8 @@ import Data.Bifunctor (bimap) import Data.ByteArray (ScrubbedBytes) import qualified Data.ByteArray as BA import Data.ByteString (ByteString) +import Database.SQLite.Simple.FromField +import Database.SQLite.Simple.ToField import Foreign (nullPtr) import Simplex.Messaging.Crypto.SNTRUP761.Bindings.Defines import Simplex.Messaging.Crypto.SNTRUP761.Bindings.FFI @@ -72,3 +74,9 @@ instance ToJSON KEMPublicKey where instance FromJSON KEMPublicKey where parseJSON = strParseJSON "KEMPublicKey" + +instance ToField KEMSharedKey where + toField (KEMSharedKey k) = toField (BA.convert k :: ByteString) + +instance FromField KEMSharedKey where + fromField f = KEMSharedKey . BA.convert @ByteString <$> fromField f From ecb23c66e007cef40e3eb3194e130a3458e6fd57 Mon Sep 17 00:00:00 2001 From: Alexander Bondarenko <486682+dpwiz@users.noreply.github.com> Date: Tue, 7 Nov 2023 22:30:28 +0200 Subject: [PATCH 07/16] Extract public RC types (#887) --- src/Simplex/Messaging/Agent.hs | 1 + src/Simplex/RemoteControl/Client.hs | 129 +------------------- src/Simplex/RemoteControl/Discovery.hs | 65 +--------- src/Simplex/RemoteControl/Types.hs | 160 ++++++++++++++++++------- 4 files changed, 121 insertions(+), 234 deletions(-) diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 9e0b140f2..195c93833 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -163,6 +163,7 @@ import Simplex.Messaging.Util import Simplex.Messaging.Version import Simplex.RemoteControl.Client import Simplex.RemoteControl.Invitation +import Simplex.RemoteControl.Types import UnliftIO.Async (async, race_) import UnliftIO.Concurrent (forkFinally, forkIO, threadDelay) import UnliftIO.STM diff --git a/src/Simplex/RemoteControl/Client.hs b/src/Simplex/RemoteControl/Client.hs index a58283b3e..dd7142c9b 100644 --- a/src/Simplex/RemoteControl/Client.hs +++ b/src/Simplex/RemoteControl/Client.hs @@ -5,25 +5,16 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} module Simplex.RemoteControl.Client - ( RCHostPairing (..), - RCHostClient (action), - RCHostSession (..), - RCHostHello (..), - HostSessKeys (..), + ( RCHostClient (action), RCHostConnection, - SessionCode, newRCHostPairing, connectRCHost, cancelHostClient, - RCCtrlPairing (..), RCCtrlClient (action), - RCCtrlSession (..), - CtrlSessKeys (..), RCCtrlConnection, connectRCCtrlURI, connectKnownRCCtrlMulticast, @@ -40,7 +31,6 @@ import Control.Monad.IO.Class import Crypto.Random (ChaChaDRG) import qualified Data.Aeson as J import qualified Data.Aeson.TH as JQ -import qualified Data.Attoparsec.ByteString.Char8 as A import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as LB @@ -59,7 +49,6 @@ import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.SNTRUP761 import Simplex.Messaging.Crypto.SNTRUP761.Bindings import Simplex.Messaging.Encoding -import Simplex.Messaging.Parsers (defaultJSON) import Simplex.Messaging.Transport (TLS (tlsUniq), cGet, cPut) import Simplex.Messaging.Transport.Client (TransportClientConfig (..), TransportHost, defaultTransportClientConfig, runTransportClient) import Simplex.Messaging.Transport.Credentials (genCredentials, tlsCredentials) @@ -83,21 +72,6 @@ xrcpBlockSize = 16384 helloBlockSize :: Int helloBlockSize = 12288 -data RCHostHello = RCHostHello - { v :: Version, - ca :: C.KeyHash, - app :: J.Value, - kem :: KEMPublicKey - } - deriving (Show) - -$(JQ.deriveJSON defaultJSON ''RCHostHello) - -data RCCtrlHello = RCCtrlHello {} - deriving (Show) - -$(JQ.deriveJSON defaultJSON {J.nullaryToObject = True} ''RCCtrlHello) - newRCHostPairing :: IO RCHostPairing newRCHostPairing = do ((_, caKey), caCert) <- genCredentials Nothing (-25, 24 * 999999) "ca" @@ -116,13 +90,8 @@ data RCHClient_ = RCHClient_ tlsEnded :: TMVar (Either RCErrorType ()) } --- tlsunique channel binding -type SessionCode = ByteString - type RCHostConnection = (RCSignedInvitation, RCHostClient, RCStepTMVar (SessionCode, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing))) -type RCStepTMVar a = TMVar (Either RCErrorType a) - connectRCHost :: TVar ChaChaDRG -> RCHostPairing -> J.Value -> ExceptT RCErrorType IO RCHostConnection connectRCHost drg pairing@RCHostPairing {caKey, caCert, idPrivKey, knownHost} ctrlAppInfo = do r <- newEmptyTMVarIO @@ -430,99 +399,3 @@ cancelCtrlClient :: RCCtrlClient -> IO () cancelCtrlClient RCCtrlClient {action, client_ = RCCClient_ {endSession}} = do atomically $ putTMVar endSession () uninterruptibleCancel action - --- | Long-term part of controller (desktop) connection to host (mobile) -data RCHostPairing = RCHostPairing - { caKey :: C.APrivateSignKey, - caCert :: C.SignedCertificate, - idPrivKey :: C.PrivateKeyEd25519, - knownHost :: Maybe KnownHostPairing - } - -data KnownHostPairing = KnownHostPairing - { hostFingerprint :: C.KeyHash, -- this is only changed in the first session, long-term identity of connected remote host - storedSessKeys :: StoredHostSessKeys - } - -data StoredHostSessKeys = StoredHostSessKeys - { hostDHPublicKey :: C.PublicKeyX25519, -- sent by host in HELLO block. Matches one of the DH keys in RCCtrlPairing - kemSharedKey :: KEMSharedKey - } - --- | Long-term part of host (mobile) connection to controller (desktop) -data RCCtrlPairing = RCCtrlPairing - { caKey :: C.APrivateSignKey, - caCert :: C.SignedCertificate, - ctrlFingerprint :: C.KeyHash, -- long-term identity of connected remote controller - idPubKey :: C.PublicKeyEd25519, - storedSessKeys :: StoredCtrlSessKeys, - prevStoredSessKeys :: Maybe StoredCtrlSessKeys - } - -data StoredCtrlSessKeys = StoredCtrlSessKeys - { dhPrivKey :: C.PrivateKeyX25519, - kemSharedKey :: Maybe KEMSharedKey -- this is Nothing only for a new pairing, and once connected it is always Just. - } - -data RCHostKeys = RCHostKeys - { sessKeys :: C.KeyPair 'C.Ed25519, - dhKeys :: C.KeyPair 'C.X25519 - } - --- Connected session with Host -data RCHostSession = RCHostSession - { tls :: TLS, - sessionKeys :: HostSessKeys - } - -data HostSessKeys = HostSessKeys - { hybridKey :: KEMHybridSecret, - idPrivKey :: C.PrivateKeyEd25519, - sessPrivKey :: C.PrivateKeyEd25519 - } - --- Host: RCCtrlPairing + RCInvitation => (RCCtrlSession, RCCtrlPairing) - -data RCCtrlSession = RCCtrlSession - { tls :: TLS, - sessionKeys :: CtrlSessKeys - } - -data CtrlSessKeys = CtrlSessKeys - { hybridKey :: KEMHybridSecret, - idPubKey :: C.PublicKeyEd25519, - sessPubKey :: C.PublicKeyEd25519 - } - -data RCHostEncHello = RCHostEncHello - { dhPubKey :: C.PublicKeyX25519, - nonce :: C.CbNonce, - encBody :: ByteString - } - deriving (Show) - -instance Encoding RCHostEncHello where - smpEncode RCHostEncHello {dhPubKey, nonce, encBody} = - "HELLO " <> smpEncode (dhPubKey, nonce, Tail encBody) - smpP = do - (dhPubKey, nonce, Tail encBody) <- "HELLO " *> smpP - pure RCHostEncHello {dhPubKey, nonce, encBody} - -data RCCtrlEncHello - = RCCtrlEncHello {kem :: KEMCiphertext, nonce :: C.CbNonce, encBody :: ByteString} - | RCCtrlEncError {nonce :: C.CbNonce, encMessage :: ByteString} - deriving (Show) - -instance Encoding RCCtrlEncHello where - smpEncode = \case - RCCtrlEncHello {kem, nonce, encBody} -> "HELLO " <> smpEncode (kem, nonce, Tail encBody) - RCCtrlEncError {nonce, encMessage} -> "ERROR " <> smpEncode (nonce, Tail encMessage) - smpP = - A.takeTill (== ' ') >>= \case - "HELLO" -> do - (kem, nonce, Tail encBody) <- _smpP - pure RCCtrlEncHello {kem, nonce, encBody} - "ERROR" -> do - (nonce, Tail encMessage) <- _smpP - pure RCCtrlEncError {nonce, encMessage} - _ -> fail "bad RCCtrlEncHello" diff --git a/src/Simplex/RemoteControl/Discovery.hs b/src/Simplex/RemoteControl/Discovery.hs index 7e1f992f4..ab4400ed3 100644 --- a/src/Simplex/RemoteControl/Discovery.hs +++ b/src/Simplex/RemoteControl/Discovery.hs @@ -17,26 +17,19 @@ import Data.ByteString (ByteString) import Data.Default (def) import Data.Maybe (listToMaybe, mapMaybe) import Data.String (IsString) -import Data.Text (Text) -import Data.Text.Encoding (decodeUtf8) -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 qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding (Encoding (..)) -import Simplex.Messaging.Encoding.String (StrEncoding (..)) import Simplex.Messaging.Transport (supportedParameters) import qualified Simplex.Messaging.Transport as Transport -import Simplex.Messaging.Transport.Client (TransportHost (..), defaultTransportClientConfig, runTransportClient) +import Simplex.Messaging.Transport.Client (TransportHost (..)) import Simplex.Messaging.Transport.Server (defaultTransportServerConfig, runTransportServerSocket, startTCPServer) import Simplex.Messaging.Util (ifM, tshow) -import Simplex.Messaging.Version (VersionRange) import Simplex.RemoteControl.Discovery.Multicast (setMembership) import Simplex.RemoteControl.Types import UnliftIO -import UnliftIO.Concurrent -- | mDNS multicast group pattern MULTICAST_ADDR_V4 :: (IsString a, Eq a) => a @@ -77,50 +70,6 @@ mkIpProbe = do randomNonce <- liftIO $ getRandomBytes 32 pure IpProbe {versionRange = ipProbeVersionRange, randomNonce} --- | Announce tls server, wait for connection and attach http2 client to it. --- --- Announcer is started when TLS server is started and stopped when a connection is made. -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 - ctrlFinished <- newEmptyMVar - _ <- forkIO $ readMVar ctrlFinished >> finishAction -- attach external cleanup action to session lock - 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 - let hooks = undefined -- TODO - tlsServer <- startTLSServer started credentials hooks $ \tls -> do - logInfo $ "Incoming connection for " <> ident - cancel announcer - 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 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 @@ -199,15 +148,3 @@ 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) -> - 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 diff --git a/src/Simplex/RemoteControl/Types.hs b/src/Simplex/RemoteControl/Types.hs index 757119950..7d7db0d3b 100644 --- a/src/Simplex/RemoteControl/Types.hs +++ b/src/Simplex/RemoteControl/Types.hs @@ -10,23 +10,21 @@ module Simplex.RemoteControl.Types where -import Crypto.Random (ChaChaDRG) -import qualified Data.Aeson.TH as J +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 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.Crypto.SNTRUP761.Bindings (KEMPublicKey, KEMSecretKey, sntrup761Keypair) +import Simplex.Messaging.Crypto.SNTRUP761 +import Simplex.Messaging.Crypto.SNTRUP761.Bindings 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.Parsers (defaultJSON, dropPrefix, sumTypeJSON) +import Simplex.Messaging.Transport (TLS) import Simplex.Messaging.Util (safeDecodeUtf8) -import Simplex.Messaging.Version (VersionRange, mkVersionRange) +import Simplex.Messaging.Version (Version, VersionRange, mkVersionRange) import UnliftIO data RCErrorType @@ -94,48 +92,126 @@ instance Encoding IpProbe where smpP = IpProbe <$> (smpP <* "I") *> smpP --- * Controller +-- * Session --- | 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, +data RCHostHello = RCHostHello + { v :: Version, ca :: C.KeyHash, - credentials :: TLS.Credentials, - sSigKey :: C.PrivateKeyEd25519, - dhKey :: C.PrivateKeyX25519, - kem :: (KEMPublicKey, KEMSecretKey) + app :: J.Value, + kem :: KEMPublicKey + } + deriving (Show) + +$(JQ.deriveJSON defaultJSON ''RCHostHello) + +data RCCtrlHello = RCCtrlHello {} + deriving (Show) + +$(JQ.deriveJSON defaultJSON {J.nullaryToObject = True} ''RCCtrlHello) + +-- | 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 } -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 - - let parent = (C.signatureKeyPair caKey, caCert) - sessionCreds <- genCredentials (Just parent) (0, 24) "Session" - let (ca, credentials) = tlsCredentials $ sessionCreds :| [parent] - kem <- sntrup761Keypair rng - - pure CtrlSessionKeys {ts, ca, credentials, sSigKey, dhKey, kem} - -data CtrlCryptoHandle = CtrlCryptoHandle - --- TODO - --- * Host - -data HostSessionKeys = HostSessionKeys - { ca :: C.KeyHash - -- TODO +data KnownHostPairing = KnownHostPairing + { hostFingerprint :: C.KeyHash, -- this is only changed in the first session, long-term identity of connected remote host + storedSessKeys :: StoredHostSessKeys } -data HostCryptoHandle = HostCryptoHandle +data StoredHostSessKeys = StoredHostSessKeys + { hostDHPublicKey :: C.PublicKeyX25519, -- sent by host in HELLO block. Matches one of the DH keys in RCCtrlPairing + kemSharedKey :: KEMSharedKey + } --- TODO +-- | 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" -- * Utils +-- | tlsunique channel binding +type SessionCode = ByteString + +type RCStepTMVar a = TMVar (Either RCErrorType a) + type Tasks = TVar [Async ()] asyncRegistered :: MonadUnliftIO m => Tasks -> m () -> m () @@ -147,4 +223,4 @@ registerAsync tasks = atomically . modifyTVar tasks . (:) cancelTasks :: MonadIO m => Tasks -> m () cancelTasks tasks = readTVarIO tasks >>= mapM_ cancel -$(J.deriveJSON (sumTypeJSON $ dropPrefix "RCE") ''RCErrorType) +$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "RCE") ''RCErrorType) From 248144f3de2a87740bd7e9b75c1ee10b3cecc5c3 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Wed, 8 Nov 2023 12:06:10 +0000 Subject: [PATCH 08/16] do not use previous KEM shared secret in multicast packets and in host HELLO (#888) * do not use previous KEM shared secret in multicast packets and in host HELLO * simplify --- rfcs/2023-10-25-remote-control.md | 2 +- src/Simplex/Messaging/Crypto/SNTRUP761.hs | 21 ++----- src/Simplex/RemoteControl/Client.hs | 57 ++++++++--------- src/Simplex/RemoteControl/Types.hs | 16 +---- tests/AgentTests/FunctionalAPITests.hs | 2 +- tests/RemoteControl.hs | 76 ++++++++++++++++++----- 6 files changed, 96 insertions(+), 78 deletions(-) diff --git a/rfcs/2023-10-25-remote-control.md b/rfcs/2023-10-25-remote-control.md index ba731bc13..b97cb591e 100644 --- a/rfcs/2023-10-25-remote-control.md +++ b/rfcs/2023-10-25-remote-control.md @@ -285,7 +285,7 @@ announcementSecret(n) = sha256(dhSecret(n') || kemSecret(n - 1)) dhSecret(n') = dh(hostHelloDhKey(n - 1), controllerAnnouncementDhKey(n)) // session n -hostHelloSecret(n) = sha256(dhSecret(n) || kemSecret(n - 1)) +hostHelloSecret(n) = dhSecret(n) sessionSecret(n) = sha256(dhSecret(n) || kemSecret(n)) // to encrypt session n data, incl. controller hello dhSecret(n) = dh(hostHelloDhKey(n), controllerAnnouncementDhKey(n)) kemCiphertext(n) = enc(kemSecret(n), kemEncKey(n)) diff --git a/src/Simplex/Messaging/Crypto/SNTRUP761.hs b/src/Simplex/Messaging/Crypto/SNTRUP761.hs index 2dd63c434..99b2771f6 100644 --- a/src/Simplex/Messaging/Crypto/SNTRUP761.hs +++ b/src/Simplex/Messaging/Crypto/SNTRUP761.hs @@ -15,30 +15,17 @@ 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 :: KEMSharedSecret kem => kem -> CbNonce -> ByteString -> Either CryptoError ByteString -kcbDecrypt = sbDecrypt_ . kemSecretBytes +kcbDecrypt :: KEMHybridSecret -> CbNonce -> ByteString -> Either CryptoError ByteString +kcbDecrypt (KEMHybridSecret k) = sbDecrypt_ k -- | NaCl @crypto_box@ encrypt with a shared hybrid DH + KEM secret and 192-bit nonce. -kcbEncrypt :: KEMSharedSecret kem => kem -> CbNonce -> ByteString -> Int -> Either CryptoError ByteString -kcbEncrypt = sbEncrypt_ . kemSecretBytes +kcbEncrypt :: KEMHybridSecret -> CbNonce -> ByteString -> Int -> Either CryptoError ByteString +kcbEncrypt (KEMHybridSecret k) = sbEncrypt_ k 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 diff --git a/src/Simplex/RemoteControl/Client.hs b/src/Simplex/RemoteControl/Client.hs index dd7142c9b..d2221956d 100644 --- a/src/Simplex/RemoteControl/Client.hs +++ b/src/Simplex/RemoteControl/Client.hs @@ -30,7 +30,6 @@ 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 Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as LB @@ -199,15 +198,14 @@ prepareHostSession 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 + let sharedKey = C.dh' dhPubKey dhPrivKey + helloBody <- liftEitherWith (const RCEDecrypt) $ C.cbDecrypt 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 + knownHost' <- updateKnownHost ca dhPubKey let ctrlHello = RCCtrlHello {} -- TODO send error response if something fails nonce' <- liftIO . atomically $ C.pseudoRandomCbNonce drg @@ -215,14 +213,14 @@ prepareHostSession 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 + updateKnownHost :: C.KeyHash -> C.PublicKeyX25519 -> ExceptT RCErrorType IO KnownHostPairing + updateKnownHost ca hostDhPubKey = 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} + pure (h :: KnownHostPairing) {hostDhPubKey} + Nothing -> pure KnownHostPairing {hostFingerprint = ca, hostDhPubKey} data RCCtrlClient = RCCtrlClient { action :: Async (), @@ -252,13 +250,12 @@ connectRCCtrl drg inv@RCInvitation {ca, idkey} pairing_ hostAppInfo = do 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} + pure RCCtrlPairing {caKey, caCert, ctrlFingerprint = ca, idPubKey = idkey, dhPrivKey, prevDhPrivKey = Nothing} updateCtrlPairing :: RCCtrlPairing -> ExceptT RCErrorType IO RCCtrlPairing - updateCtrlPairing pairing@RCCtrlPairing {ctrlFingerprint, idPubKey, storedSessKeys = currSSK} = do + updateCtrlPairing pairing@RCCtrlPairing {ctrlFingerprint, idPubKey, dhPrivKey = currDhPrivKey} = do unless (ca == ctrlFingerprint && idPubKey == idkey) $ throwError RCEIdentity (_, dhPrivKey) <- liftIO C.generateKeyPair' - pure pairing {storedSessKeys = currSSK {dhPrivKey}, prevStoredSessKeys = Just currSSK} + pure pairing {dhPrivKey, prevDhPrivKey = Just currDhPrivKey} connectRCCtrl_ :: TVar ChaChaDRG -> RCCtrlPairing -> RCInvitation -> J.Value -> ExceptT RCErrorType IO RCCtrlConnection connectRCCtrl_ drg pairing'@RCCtrlPairing {caKey, caCert} inv@RCInvitation {ca, host, port} hostAppInfo = do @@ -298,8 +295,8 @@ connectRCCtrl_ drg pairing'@RCCtrlPairing {caKey, caCert} inv@RCInvitation {ca, 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'') + ctrlSessKeys <- 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 @@ -319,10 +316,10 @@ receiveRCPacket tls = do 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 :: TVar ChaChaDRG -> RCCtrlPairing -> RCInvitation -> J.Value -> ExceptT RCErrorType IO (C.DhSecretX25519, KEMSecretKey, RCHostEncHello) prepareHostHello drg - RCCtrlPairing {caCert, storedSessKeys = StoredCtrlSessKeys {dhPrivKey, kemSharedKey}} + RCCtrlPairing {caCert, dhPrivKey} RCInvitation {v, dh = dhPubKey} hostAppInfo = do logDebug "Preparing session" @@ -333,15 +330,15 @@ prepareHostHello (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 + sharedKey = C.dh' dhPubKey dhPrivKey + encBody <- liftEitherWith (const RCEBlockSize) $ C.cbEncrypt 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 :: RCCtrlPairing -> RCInvitation -> C.DhSecretX25519 -> KEMSecretKey -> RCCtrlEncHello -> ExceptT RCErrorType IO CtrlSessKeys prepareCtrlSession - pairing@RCCtrlPairing {idPubKey, storedSessKeys = ssk@StoredCtrlSessKeys {dhPrivKey}} + RCCtrlPairing {idPubKey, dhPrivKey} RCInvitation {skey, dh = dhPubKey} sharedKey kemPrivKey = \case @@ -351,11 +348,9 @@ prepareCtrlSession 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') + pure CtrlSessKeys {hybridKey, idPubKey, sessPubKey = skey} RCCtrlEncError {nonce, encMessage} -> do - message <- liftEitherWith (const RCEDecrypt) $ kcbDecrypt sharedKey nonce encMessage + message <- liftEitherWith (const RCEDecrypt) $ C.cbDecrypt sharedKey nonce encMessage throwError $ RCECtrlError $ T.unpack $ safeDecodeUtf8 message -- The application should save updated RCHostPairing after user confirmation of the session @@ -379,13 +374,13 @@ findRCCtrlPairing pairings RCEncInvitation {dhPubKey, nonce, encInvitation} = do where decrypt :: [RCCtrlPairing] -> Either RCErrorType (RCCtrlPairing, ByteString) decrypt [] = Left RCECtrlNotFound - decrypt (pairing@RCCtrlPairing {storedSessKeys, prevStoredSessKeys} : rest) = - let r = decrypt_ storedSessKeys <|> (decrypt_ =<< prevStoredSessKeys) + decrypt (pairing@RCCtrlPairing {dhPrivKey, prevDhPrivKey} : rest) = + let r = decrypt_ dhPrivKey <|> (decrypt_ =<< prevDhPrivKey) 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 + decrypt_ :: C.PrivateKeyX25519 -> Maybe ByteString + decrypt_ dhPrivKey = + let key = C.dh' dhPubKey dhPrivKey + in eitherToMaybe $ C.cbDecrypt key nonce encInvitation -- application should call this function when TMVar resolves confirmCtrlSession :: RCCtrlClient -> Bool -> IO () diff --git a/src/Simplex/RemoteControl/Types.hs b/src/Simplex/RemoteControl/Types.hs index 7d7db0d3b..1c83389f7 100644 --- a/src/Simplex/RemoteControl/Types.hs +++ b/src/Simplex/RemoteControl/Types.hs @@ -119,12 +119,7 @@ data RCHostPairing = RCHostPairing 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 + hostDhPubKey :: C.PublicKeyX25519 } -- | Long-term part of host (mobile) connection to controller (desktop) @@ -133,13 +128,8 @@ data RCCtrlPairing = RCCtrlPairing 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. + dhPrivKey :: C.PrivateKeyX25519, + prevDhPrivKey :: Maybe C.PrivateKeyX25519 } data RCHostKeys = RCHostKeys diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 8f19c776e..8c37579fc 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -143,7 +143,7 @@ prevRange vr = vr {maxVersion = maxVersion vr - 1} runRight_ :: (Eq e, Show e, HasCallStack) => ExceptT e IO () -> Expectation runRight_ action = runExceptT action `shouldReturn` Right () -runRight :: HasCallStack => ExceptT AgentErrorType IO a -> IO a +runRight :: (Show e, HasCallStack) => ExceptT e IO a -> IO a runRight action = runExceptT action >>= \case Right x -> pure x diff --git a/tests/RemoteControl.hs b/tests/RemoteControl.hs index c4b49289e..cb7bec71b 100644 --- a/tests/RemoteControl.hs +++ b/tests/RemoteControl.hs @@ -4,7 +4,7 @@ module RemoteControl where -import AgentTests.FunctionalAPITests (runRight_) +import AgentTests.FunctionalAPITests (runRight) import Control.Logger.Simple import Crypto.Random (drgNew) import qualified Data.Aeson as J @@ -16,51 +16,97 @@ import UnliftIO.Concurrent remoteControlTests :: Spec remoteControlTests = do describe "New controller/host pairing" $ do - it "should connect" testNewPairing + it "should connect to new pairing" testNewPairing + it "should connect to existing pairing" testExistingPairing testNewPairing :: IO () testNewPairing = do drg <- drgNew >>= newTVarIO hp <- RC.newRCHostPairing invVar <- newEmptyMVar - ctrl <- async . runRight_ $ do + ctrlSessId <- async . runRight $ do logNote "c 1" (inv, hc, r) <- RC.connectRCHost drg hp (J.String "app") logNote "c 2" putMVar invVar (inv, hc) logNote "c 3" - Right (_sessId, r') <- atomically $ takeTMVar r + Right (sessId, r') <- atomically $ takeTMVar r logNote "c 4" Right (_rcHostSession, _rcHelloBody, _hp') <- atomically $ takeTMVar r' logNote "c 5" - threadDelay 1000000 + threadDelay 250000 logNote "ctrl: ciao" liftIO $ RC.cancelHostClient hc + pure sessId (inv, hc) <- takeMVar invVar -- logNote $ decodeUtf8 $ strEncode inv - host <- async . runRight_ $ do + hostSessId <- async . runRight $ do logNote "h 1" (rcCtrlClient, r) <- RC.connectRCCtrlURI drg inv Nothing (J.String "app") logNote "h 2" - Right (_sessId', r') <- atomically $ takeTMVar r + Right (sessId', r') <- atomically $ takeTMVar r logNote "h 3" liftIO $ RC.confirmCtrlSession rcCtrlClient True logNote "h 4" Right (_rcCtrlSession, _rcCtrlPairing) <- atomically $ takeTMVar r' logNote "h 5" - threadDelay 1000000 + threadDelay 250000 logNote "ctrl: adios" - - timeout 10000000 (waitCatch ctrl) >>= \case - Just (Right ()) -> pure () - err -> fail $ "Unexpected controller result: " <> show err + pure sessId' waitCatch hc.action >>= \case Left err -> fromException err `shouldBe` Just AsyncCancelled Right () -> fail "Unexpected controller finish" - timeout 10000000 (waitCatch host) >>= \case - Just (Right ()) -> pure () - err -> fail $ "Unexpected host result: " <> show err + timeout 5000000 (waitBoth ctrlSessId hostSessId) >>= \case + Just (sessId, sessId') -> sessId `shouldBe` sessId' + _ -> fail "timeout" + +testExistingPairing :: IO () +testExistingPairing = do + drg <- drgNew >>= newTVarIO + invVar <- newEmptyMVar + hp <- liftIO $ RC.newRCHostPairing + ctrl <- runCtrl drg hp invVar + inv <- takeMVar invVar + let cp_ = Nothing + host <- runHost drg cp_ inv + timeout 5000000 (waitBoth ctrl host) >>= \case + Nothing -> fail "timeout" + Just (hp', cp') -> do + ctrl' <- runCtrl drg hp' invVar + inv' <- takeMVar invVar + host' <- runHost drg (Just cp') inv' + timeout 5000000 (waitBoth ctrl' host') >>= \case + Nothing -> fail "timeout" + Just (_hp2, cp2) -> do + ctrl2 <- runCtrl drg hp' invVar -- old host pairing used to test controller not updating state + inv2 <- takeMVar invVar + host2 <- runHost drg (Just cp2) inv2 + timeout 5000000 (waitBoth ctrl2 host2) >>= \case + Nothing -> fail "timeout" + Just (hp3, cp3) -> do + ctrl3 <- runCtrl drg hp3 invVar + inv3 <- takeMVar invVar + host3 <- runHost drg (Just cp3) inv3 + timeout 5000000 (waitBoth ctrl3 host3) >>= \case + Nothing -> fail "timeout" + Just _ -> pure () + where + runCtrl drg hp invVar = async . runRight $ do + (inv, hc, r) <- RC.connectRCHost drg hp (J.String "app") + putMVar invVar inv + Right (_sessId, r') <- atomically $ takeTMVar r + Right (_rcHostSession, _rcHelloBody, hp') <- atomically $ takeTMVar r' + threadDelay 250000 + liftIO $ RC.cancelHostClient hc + pure hp' + runHost drg cp_ inv = async . runRight $ do + (rcCtrlClient, r) <- RC.connectRCCtrlURI drg inv cp_ (J.String "app") + Right (_sessId', r') <- atomically $ takeTMVar r + liftIO $ RC.confirmCtrlSession rcCtrlClient True + Right (_rcCtrlSession, cp') <- atomically $ takeTMVar r' + threadDelay 250000 + pure cp' From 102487bc4fbb865aac4207d2ba6f2ea77eff3290 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Wed, 8 Nov 2023 16:34:56 +0000 Subject: [PATCH 09/16] xrcp: error handling (#889) * xrcp: error handling * rename * dont lock on STM * move catch * controller error handling * fail sooner on incorrect CA in host HELLO * remove TODO lock session * refactor --- src/Simplex/RemoteControl/Client.hs | 112 +++++++++++++--------------- 1 file changed, 52 insertions(+), 60 deletions(-) diff --git a/src/Simplex/RemoteControl/Client.hs b/src/Simplex/RemoteControl/Client.hs index d2221956d..bf0f3780d 100644 --- a/src/Simplex/RemoteControl/Client.hs +++ b/src/Simplex/RemoteControl/Client.hs @@ -34,6 +34,7 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as LB import Data.Default (def) +import Data.Functor (($>)) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as L import Data.Maybe (isNothing) @@ -51,13 +52,12 @@ import Simplex.Messaging.Encoding 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.Util 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 @@ -85,8 +85,7 @@ data RCHostClient = RCHostClient data RCHClient_ = RCHClient_ { startedPort :: TMVar (Maybe PortNumber), hostCAHash :: TMVar C.KeyHash, - endSession :: TMVar (), - tlsEnded :: TMVar (Either RCErrorType ()) + endSession :: TMVar () } type RCHostConnection = (RCSignedInvitation, RCHostClient, RCStepTMVar (SessionCode, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing))) @@ -95,13 +94,9 @@ connectRCHost :: TVar ChaChaDRG -> RCHostPairing -> J.Value -> ExceptT RCErrorTy connectRCHost drg pairing@RCHostPairing {caKey, caCert, idPrivKey, knownHost} ctrlAppInfo = do r <- newEmptyTMVarIO host <- getLocalAddress >>= maybe (throwError RCENoLocalAddress) pure - c@RCHClient_ {startedPort, tlsEnded} <- liftIO mkClient + c@RCHClient_ {startedPort} <- 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 + action <- runClient c r hostKeys `putRCError` r -- 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 @@ -112,30 +107,29 @@ connectRCHost drg pairing@RCHostPairing {caKey, caCert, idPrivKey, knownHost} ct 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" + pure RCHClient_ {startedPort, hostCAHash, endSession} + runClient :: RCHClient_ -> RCStepTMVar (ByteString, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)) -> RCHostKeys -> ExceptT RCErrorType IO (Async ()) + runClient RCHClient_ {startedPort, hostCAHash, endSession} r hostKeys = do + tlsCreds <- liftIO $ genTLSCredentials caKey caCert + startTLSServer startedPort tlsCreds (tlsHooks r knownHost hostCAHash) $ \tls -> + void . runExceptT $ do r' <- newEmptyTMVarIO - atomically $ putTMVar r $ Right (tlsUniq tls, r') - -- TODO lock session + whenM (atomically $ tryPutTMVar r $ Right (tlsUniq tls, r')) $ + runSession tls r' `putRCError` r' + where + runSession tls r' = do + logDebug "Incoming TLS connection" 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 + whenM (atomically $ tryPutTMVar r' $ Right (RCHostSession {tls, sessionKeys}, helloBody, pairing')) $ do + -- can use `RCHostSession` until `endSession` is signalled + logDebug "Holding session" + atomically $ takeTMVar endSession tlsHooks :: TMVar a -> Maybe KnownHostPairing -> TMVar C.KeyHash -> TLS.ServerHooks tlsHooks r knownHost_ hostCAHash = def @@ -144,11 +138,11 @@ connectRCHost drg pairing@RCHostPairing {caKey, caCert, idPrivKey, knownHost} ct 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 + let kh = certFingerprint ca + accept = maybe True (\h -> h.hostFingerprint == kh) knownHost_ + if accept + then atomically (putTMVar hostCAHash kh) $> TLS.CertificateUsageAccept + else pure $ TLS.CertificateUsageReject TLS.CertificateRejectUnknownCA _ -> pure $ TLS.CertificateUsageReject TLS.CertificateRejectUnknownCA } @@ -201,6 +195,7 @@ prepareHostSession let sharedKey = C.dh' dhPubKey dhPrivKey helloBody <- liftEitherWith (const RCEDecrypt) $ C.cbDecrypt sharedKey nonce encBody hostHello@RCHostHello {v, ca, kem = kemPubKey} <- liftEitherWith RCESyntax $ J.eitherDecodeStrict helloBody + unless (ca == tlsHostFingerprint) $ throwError RCEIdentity (kemCiphertext, kemSharedKey) <- liftIO $ sntrup761Enc drg kemPubKey let hybridKey = kemHybridSecret dhPubKey dhPrivKey kemSharedKey unless (isCompatible v supportedRCVRange) $ throwError RCEVersion @@ -218,7 +213,6 @@ prepareHostSession 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) {hostDhPubKey} Nothing -> pure KnownHostPairing {hostFingerprint = ca, hostDhPubKey} @@ -229,8 +223,7 @@ data RCCtrlClient = RCCtrlClient data RCCClient_ = RCCClient_ { confirmSession :: TMVar Bool, - endSession :: TMVar (), - tlsEnded :: TMVar (Either RCErrorType ()) + endSession :: TMVar () } type RCCtrlConnection = (RCCtrlClient, RCStepTMVar (SessionCode, RCStepTMVar (RCCtrlSession, RCCtrlPairing))) @@ -261,34 +254,28 @@ connectRCCtrl_ :: TVar ChaChaDRG -> RCCtrlPairing -> RCInvitation -> J.Value -> connectRCCtrl_ drg pairing'@RCCtrlPairing {caKey, caCert} inv@RCInvitation {ca, host, port} hostAppInfo = do r <- newEmptyTMVarIO c <- liftIO mkClient - action <- async $ runClient c r + action <- async $ runClient c r `putRCError` r pure (RCCtrlClient {action, client_ = c}, r) where mkClient :: IO RCCClient_ mkClient = do - tlsEnded <- newEmptyTMVarIO confirmSession <- newEmptyTMVarIO endSession <- newEmptyTMVarIO - pure RCCClient_ {confirmSession, endSession, tlsEnded} + pure RCCClient_ {confirmSession, endSession} runClient :: RCCClient_ -> RCStepTMVar (SessionCode, RCStepTMVar (RCCtrlSession, RCCtrlPairing)) -> ExceptT RCErrorType IO () - runClient RCCClient_ {confirmSession, endSession, tlsEnded} r = do + runClient RCCClient_ {confirmSession, endSession} r = do clientCredentials <- liftIO (genTLSCredentials caKey caCert) >>= \case - TLS.Credentials [one] -> pure $ Just one - _ -> throwError $ RCEInternal "genTLSCredentials must generate only one set of credentials" + TLS.Credentials (creds : _) -> pure $ Just creds + _ -> throwError $ RCEInternal "genTLSCredentials must generate 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" + liftIO . runTransportClient clientConfig Nothing host (show port) (Just ca) $ \tls -> + void . runExceptT $ do + logDebug "Got TLS connection" 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 + whenM (atomically $ tryPutTMVar r $ Right (tlsUniq tls, r')) $ do + logDebug "Waiting for session confirmation" + whenM (atomically $ readTMVar confirmSession) (runSession tls r') `putRCError` r' where runSession tls r' = do (sharedKey, kemPrivKey, hostEncHello) <- prepareHostHello drg pairing' inv hostAppInfo @@ -296,13 +283,19 @@ connectRCCtrl_ drg pairing'@RCCtrlPairing {caKey, caCert} inv@RCInvitation {ca, ctrlEncHello <- receiveRCPacket tls logDebug "Received ctrl HELLO" ctrlSessKeys <- 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" + whenM (atomically $ tryPutTMVar r' $ Right (RCCtrlSession {tls, sessionKeys = ctrlSessKeys}, pairing')) $ do + logDebug "Session started" + -- release second putTMVar in confirmCtrlSession + void . atomically $ takeTMVar confirmSession + atomically $ takeTMVar endSession + logDebug "Session ended" + +catchRCError :: ExceptT RCErrorType IO a -> (RCErrorType -> ExceptT RCErrorType IO a) -> ExceptT RCErrorType IO a +catchRCError = catchAllErrors (RCEException . show) +{-# INLINE catchRCError #-} + +putRCError :: ExceptT RCErrorType IO a -> TMVar (Either RCErrorType b) -> ExceptT RCErrorType IO a +a `putRCError` r = a `catchRCError` \e -> atomically (tryPutTMVar r $ Left e) >> throwError e sendRCPacket :: Encoding a => TLS -> a -> ExceptT RCErrorType IO () sendRCPacket tls pkt = do @@ -328,8 +321,7 @@ prepareHostHello 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} + let helloBody = RCHostHello {v = v', ca = certFingerprint caCert, app = hostAppInfo, kem = kemPubKey} sharedKey = C.dh' dhPubKey dhPrivKey encBody <- liftEitherWith (const RCEBlockSize) $ C.cbEncrypt sharedKey nonce (LB.toStrict $ J.encode helloBody) helloBlockSize -- let sessKeys = CtrlSessKeys {hybridKey, idPubKey, sessPubKey = skey} From bd06b47a9df13506ee77251868a5a1d1e7cadafe Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Thu, 9 Nov 2023 22:27:30 +0000 Subject: [PATCH 10/16] return TLS session on remote connection step (#891) --- src/Simplex/RemoteControl/Client.hs | 6 +++--- tests/RemoteControl.hs | 4 ++-- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Simplex/RemoteControl/Client.hs b/src/Simplex/RemoteControl/Client.hs index bf0f3780d..2b488de2a 100644 --- a/src/Simplex/RemoteControl/Client.hs +++ b/src/Simplex/RemoteControl/Client.hs @@ -226,7 +226,7 @@ data RCCClient_ = RCCClient_ endSession :: TMVar () } -type RCCtrlConnection = (RCCtrlClient, RCStepTMVar (SessionCode, RCStepTMVar (RCCtrlSession, RCCtrlPairing))) +type RCCtrlConnection = (RCCtrlClient, RCStepTMVar (SessionCode, TLS, RCStepTMVar (RCCtrlSession, RCCtrlPairing))) connectRCCtrlURI :: TVar ChaChaDRG -> RCSignedInvitation -> Maybe RCCtrlPairing -> J.Value -> ExceptT RCErrorType IO RCCtrlConnection connectRCCtrlURI drg signedInv@RCSignedInvitation {invitation} pairing_ hostAppInfo = do @@ -262,7 +262,7 @@ connectRCCtrl_ drg pairing'@RCCtrlPairing {caKey, caCert} inv@RCInvitation {ca, confirmSession <- newEmptyTMVarIO endSession <- newEmptyTMVarIO pure RCCClient_ {confirmSession, endSession} - runClient :: RCCClient_ -> RCStepTMVar (SessionCode, RCStepTMVar (RCCtrlSession, RCCtrlPairing)) -> ExceptT RCErrorType IO () + runClient :: RCCClient_ -> RCStepTMVar (SessionCode, TLS, RCStepTMVar (RCCtrlSession, RCCtrlPairing)) -> ExceptT RCErrorType IO () runClient RCCClient_ {confirmSession, endSession} r = do clientCredentials <- liftIO (genTLSCredentials caKey caCert) >>= \case @@ -273,7 +273,7 @@ connectRCCtrl_ drg pairing'@RCCtrlPairing {caKey, caCert} inv@RCInvitation {ca, void . runExceptT $ do logDebug "Got TLS connection" r' <- newEmptyTMVarIO - whenM (atomically $ tryPutTMVar r $ Right (tlsUniq tls, r')) $ do + whenM (atomically $ tryPutTMVar r $ Right (tlsUniq tls, tls, r')) $ do logDebug "Waiting for session confirmation" whenM (atomically $ readTMVar confirmSession) (runSession tls r') `putRCError` r' where diff --git a/tests/RemoteControl.hs b/tests/RemoteControl.hs index cb7bec71b..26b9cdb11 100644 --- a/tests/RemoteControl.hs +++ b/tests/RemoteControl.hs @@ -46,7 +46,7 @@ testNewPairing = do logNote "h 1" (rcCtrlClient, r) <- RC.connectRCCtrlURI drg inv Nothing (J.String "app") logNote "h 2" - Right (sessId', r') <- atomically $ takeTMVar r + Right (sessId', _tls, r') <- atomically $ takeTMVar r logNote "h 3" liftIO $ RC.confirmCtrlSession rcCtrlClient True logNote "h 4" @@ -105,7 +105,7 @@ testExistingPairing = do pure hp' runHost drg cp_ inv = async . runRight $ do (rcCtrlClient, r) <- RC.connectRCCtrlURI drg inv cp_ (J.String "app") - Right (_sessId', r') <- atomically $ takeTMVar r + Right (_sessId', _tls, r') <- atomically $ takeTMVar r liftIO $ RC.confirmCtrlSession rcCtrlClient True Right (_rcCtrlSession, cp') <- atomically $ takeTMVar r' threadDelay 250000 From 6a2e6b040ec8566de2f4cf97bae6700a6a5cbeda Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Fri, 10 Nov 2023 11:16:43 +0000 Subject: [PATCH 11/16] additional lazy crypto for XRCP (#890) --- rfcs/2023-10-25-remote-control.md | 25 ++++++++++++++------- src/Simplex/Messaging/Agent/Client.hs | 6 ++++- src/Simplex/Messaging/Crypto.hs | 1 + src/Simplex/Messaging/Crypto/Lazy.hs | 32 +++++++++++++++++++++++++-- src/Simplex/RemoteControl/Client.hs | 22 ++++++++++++++++++ src/Simplex/RemoteControl/Types.hs | 3 +++ 6 files changed, 78 insertions(+), 11 deletions(-) diff --git a/rfcs/2023-10-25-remote-control.md b/rfcs/2023-10-25-remote-control.md index b97cb591e..097377322 100644 --- a/rfcs/2023-10-25-remote-control.md +++ b/rfcs/2023-10-25-remote-control.md @@ -253,15 +253,21 @@ tlsunique channel binding from TLS session MUST be included in commands (include The syntax for encrypted command and response body encoding: ``` -commandBody = length encrypted(tlsunique counter length command) sessSignature idSignature -responseBody = length encrypted(tlsunique counter length response) ; should match counter in the command +commandBody = encBody sessSignature idSignature (attachment / noAttachment) +responseBody = encBody attachment; should match counter in the command +encBody = nonce encLength32 encrypted(tlsunique counter body) +attachment = %x01 nonce encLength32 encrypted(attachment) +noAttachment = %x00 tlsunique = length 1*OCTET counter = 8*8 OCTET ; int64 +encLength32 = 4*4 OCTET ; uint32, includes authTag ``` +If the command or response includes attachment, it's hash must be included in command/response and validated. + ## Key agreement for announcement packet and for session -Initial announcement is shared out-of-band, and it is not encrypted. +Initial announcement is shared out-of-band (URI with xrcp scheme), and it is not encrypted. This announcement contains only DH keys, as KEM key is too large to include in QR code, which are used to agree encryption key for host HELLO block. The host HELLO block will containt DH key in plaintext part and KEM encapsulation (public) key in encrypted part, that will be used to determine the shared secret (using SHA256 over concatenated DH shared secret and KEM encapsulated secret) both for controller HELLO response (that contains KEM cyphertext in plaintext part) and subsequent session commands and responses. @@ -275,25 +281,28 @@ To describe it in pseudocode: // session 1 hostHelloSecret(1) = dhSecret(1) sessionSecret(1) = sha256(dhSecret(1) || kemSecret(1)) // to encrypt session 1 data, incl. controller hello -dhSecret(1) = dh(hostHelloDhKey(1), controllerAnnouncementDhKey(1)) +dhSecret(1) = dh(hostHelloDhKey(1), controllerInvitationDhKey(1)) kemCiphertext(1) = enc(kemSecret(1), kemEncKey(1)) // kemEncKey is included in host HELLO, kemCiphertext - in controller HELLO kemSecret(1) = dec(kemCiphertext(1), kemDecKey(1)) -// announcement for session n -announcementSecret(n) = sha256(dhSecret(n') || kemSecret(n - 1)) -dhSecret(n') = dh(hostHelloDhKey(n - 1), controllerAnnouncementDhKey(n)) +// multicast announcement for session n +announcementSecret(n) = sha256(dhSecret(n')) +dhSecret(n') = dh(hostHelloDhKey(n - 1), controllerDhKey(n)) // session n hostHelloSecret(n) = dhSecret(n) sessionSecret(n) = sha256(dhSecret(n) || kemSecret(n)) // to encrypt session n data, incl. controller hello -dhSecret(n) = dh(hostHelloDhKey(n), controllerAnnouncementDhKey(n)) +dhSecret(n) = dh(hostHelloDhKey(n), controllerDhKey(n)) +// controllerDhKey(n) is either from invitation or from multicast announcement kemCiphertext(n) = enc(kemSecret(n), kemEncKey(n)) kemSecret(n) = dec(kemCiphertext(n), kemDecKey(n)) ``` If controller fails to store the new host DH key after receiving HELLO block, the encryption will become out of sync and the host won't be able to decrypt the next announcement. To mitigate it, the host should keep the last session DH key and also previous session DH key to try to decrypt the next announcement computing shared secret using both keys (first the new one, and in case it fails - the previous). +To decrypt multicast announcement, the host should try to decrypt it using the keys of all known (paired) remote controllers. + ## Other options The proposed design has these pros/cons: diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 23ba9f8be..190a4bf12 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -74,6 +74,7 @@ module Simplex.Messaging.Agent.Client removeSubscription, hasActiveSubscription, agentClientStore, + agentDRG, getAgentSubscriptions, SubscriptionsInfo (..), SubInfo (..), @@ -117,7 +118,7 @@ import Control.Monad import Control.Monad.Except import Control.Monad.IO.Unlift import Control.Monad.Reader -import Crypto.Random (getRandomBytes) +import Crypto.Random (ChaChaDRG, getRandomBytes) import qualified Data.Aeson.TH as J import Data.Bifunctor (bimap, first, second) import Data.ByteString.Base64 @@ -380,6 +381,9 @@ newAgentClient InitialAgentServers {smp, ntf, xftp, netCfg} agentEnv = do agentClientStore :: AgentClient -> SQLiteStore agentClientStore AgentClient {agentEnv = Env {store}} = store +agentDRG :: AgentClient -> TVar ChaChaDRG +agentDRG AgentClient {agentEnv = Env {random}} = random + class (Encoding err, Show err) => ProtocolServerClient err msg | msg -> err where type Client msg = c | c -> msg getProtocolServerClient :: AgentMonad m => AgentClient -> TransportSession msg -> m (Client msg) diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs index 3ecf9e214..65c58919c 100644 --- a/src/Simplex/Messaging/Crypto.hs +++ b/src/Simplex/Messaging/Crypto.hs @@ -85,6 +85,7 @@ module Simplex.Messaging.Crypto SignatureAlgorithm, AlgorithmI (..), sign, + sign', verify, verify', validSignatureSize, diff --git a/src/Simplex/Messaging/Crypto/Lazy.hs b/src/Simplex/Messaging/Crypto/Lazy.hs index e0117108c..ebb3692c1 100644 --- a/src/Simplex/Messaging/Crypto/Lazy.hs +++ b/src/Simplex/Messaging/Crypto/Lazy.hs @@ -14,13 +14,16 @@ module Simplex.Messaging.Crypto.Lazy sbEncrypt, sbDecrypt, sbEncryptTailTag, + kcbEncryptTailTag, sbDecryptTailTag, + kcbDecryptTailTag, fastReplicate, secretBox, secretBoxTailTag, SbState, cbInit, sbInit, + kcbInit, sbEncryptChunk, sbDecryptChunk, sbEncryptChunkLazy, @@ -48,6 +51,7 @@ import Data.Int (Int64) import Data.List.NonEmpty (NonEmpty (..)) import Foreign (sizeOf) import Simplex.Messaging.Crypto (CbNonce, CryptoError (..), DhSecret (..), DhSecretX25519, SbKey, pattern CbNonce, pattern SbKey) +import Simplex.Messaging.Crypto.SNTRUP761 (KEMHybridSecret (..)) import Simplex.Messaging.Encoding type LazyByteString = LB.ByteString @@ -127,13 +131,33 @@ secretBox sbProcess secret nonce msg = run <$> sbInit_ secret nonce -- | NaCl @secret_box@ lazy encrypt with a symmetric 256-bit key and 192-bit nonce with appended auth tag (more efficient with large files). sbEncryptTailTag :: SbKey -> CbNonce -> LazyByteString -> Int64 -> Int64 -> Either CryptoError LazyByteString -sbEncryptTailTag (SbKey key) (CbNonce nonce) msg len paddedLen = +sbEncryptTailTag (SbKey key) = sbEncryptTailTag_ key +{-# INLINE sbEncryptTailTag #-} + +-- | NaCl @crypto_box@ lazy encrypt with with a shared hybrid KEM+DH 256-bit secret and 192-bit nonce with appended auth tag (more efficient with large strings/files). +kcbEncryptTailTag :: KEMHybridSecret -> CbNonce -> LazyByteString -> Int64 -> Int64 -> Either CryptoError LazyByteString +kcbEncryptTailTag (KEMHybridSecret key) = sbEncryptTailTag_ key +{-# INLINE kcbEncryptTailTag #-} + +sbEncryptTailTag_ :: ByteArrayAccess key => key -> CbNonce -> LazyByteString -> Int64 -> Int64 -> Either CryptoError LazyByteString +sbEncryptTailTag_ key (CbNonce nonce) msg len paddedLen = LB.fromChunks <$> (secretBoxTailTag sbEncryptChunk key nonce =<< pad msg len paddedLen) -- | NaCl @secret_box@ decrypt with a symmetric 256-bit key and 192-bit nonce with appended auth tag (more efficient with large files). -- paddedLen should NOT include the tag length, it should be the same number that is passed to sbEncrypt / sbEncryptTailTag. sbDecryptTailTag :: SbKey -> CbNonce -> Int64 -> LazyByteString -> Either CryptoError (Bool, LazyByteString) -sbDecryptTailTag (SbKey key) (CbNonce nonce) paddedLen packet = +sbDecryptTailTag (SbKey key) = sbDecryptTailTag_ key +{-# INLINE sbDecryptTailTag #-} + +-- | NaCl @crypto_box@ lazy decrypt with a shared hybrid KEM+DH 256-bit secret and 192-bit nonce with appended auth tag (more efficient with large strings/files). +-- paddedLen should NOT include the tag length, it should be the same number that is passed to sbEncrypt / sbEncryptTailTag. +kcbDecryptTailTag :: KEMHybridSecret -> CbNonce -> Int64 -> LazyByteString -> Either CryptoError (Bool, LazyByteString) +kcbDecryptTailTag (KEMHybridSecret key) = sbDecryptTailTag_ key +{-# INLINE kcbDecryptTailTag #-} + +-- paddedLen should NOT include the tag length, it should be the same number that is passed to sbEncrypt / sbEncryptTailTag. +sbDecryptTailTag_ :: ByteArrayAccess key => key -> CbNonce -> Int64 -> LazyByteString -> Either CryptoError (Bool, LazyByteString) +sbDecryptTailTag_ key (CbNonce nonce) paddedLen packet = case secretBox sbDecryptChunk key nonce c of Right (tag :| cs) -> let valid = LB.length tag' == 16 && BA.constEq (LB.toStrict tag') tag @@ -165,6 +189,10 @@ sbInit :: SbKey -> CbNonce -> Either CryptoError SbState sbInit (SbKey secret) (CbNonce nonce) = sbInit_ secret nonce {-# INLINE sbInit #-} +kcbInit :: KEMHybridSecret -> CbNonce -> Either CryptoError SbState +kcbInit (KEMHybridSecret k) (CbNonce nonce) = sbInit_ k nonce +{-# INLINE kcbInit #-} + sbInit_ :: ByteArrayAccess key => key -> ByteString -> Either CryptoError SbState sbInit_ secret nonce = (state2,) <$> cryptoPassed (Poly1305.initialize rs) where diff --git a/src/Simplex/RemoteControl/Client.hs b/src/Simplex/RemoteControl/Client.hs index 2b488de2a..e6ab65516 100644 --- a/src/Simplex/RemoteControl/Client.hs +++ b/src/Simplex/RemoteControl/Client.hs @@ -21,6 +21,9 @@ module Simplex.RemoteControl.Client confirmCtrlSession, cancelCtrlClient, RCStepTMVar, + rcEncryptBody, + rcDecryptBody, + xrcpBlockSize, ) where import Control.Applicative ((<|>)) @@ -46,6 +49,8 @@ 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.Lazy (LazyByteString) +import qualified Simplex.Messaging.Crypto.Lazy as LC import Simplex.Messaging.Crypto.SNTRUP761 import Simplex.Messaging.Crypto.SNTRUP761.Bindings import Simplex.Messaging.Encoding @@ -386,3 +391,20 @@ cancelCtrlClient :: RCCtrlClient -> IO () cancelCtrlClient RCCtrlClient {action, client_ = RCCClient_ {endSession}} = do atomically $ putTMVar endSession () uninterruptibleCancel action + +-- * Session encryption + +rcEncryptBody :: TVar ChaChaDRG -> KEMHybridSecret -> LazyByteString -> ExceptT RCErrorType IO (C.CbNonce, LazyByteString) +rcEncryptBody drg hybridKey s = do + nonce <- atomically $ C.pseudoRandomCbNonce drg + let len = LB.length s + ct <- liftEitherWith (const RCEEncrypt) $ LC.kcbEncryptTailTag hybridKey nonce s len (len + 8) + pure (nonce, ct) + +rcDecryptBody :: KEMHybridSecret -> C.CbNonce -> LazyByteString -> ExceptT RCErrorType IO LazyByteString +rcDecryptBody hybridKey nonce ct = do + let len = LB.length ct - 16 + when (len < 0) $ throwError RCEDecrypt + (ok, s) <- liftEitherWith (const RCEDecrypt) $ LC.kcbDecryptTailTag hybridKey nonce len ct + unless ok $ throwError RCEDecrypt + pure s diff --git a/src/Simplex/RemoteControl/Types.hs b/src/Simplex/RemoteControl/Types.hs index 1c83389f7..78e7d8956 100644 --- a/src/Simplex/RemoteControl/Types.hs +++ b/src/Simplex/RemoteControl/Types.hs @@ -37,6 +37,7 @@ data RCErrorType | RCECtrlNotFound | RCECtrlError {ctrlErr :: String} | RCEVersion + | RCEEncrypt | RCEDecrypt | RCEBlockSize | RCESyntax {syntaxErr :: String} @@ -53,6 +54,7 @@ instance StrEncoding RCErrorType where RCECtrlNotFound -> "CTRL_NOT_FOUND" RCECtrlError err -> "CTRL_ERROR" <> text err RCEVersion -> "VERSION" + RCEEncrypt -> "ENCRYPT" RCEDecrypt -> "DECRYPT" RCEBlockSize -> "BLOCK_SIZE" RCESyntax err -> "SYNTAX" <> text err @@ -69,6 +71,7 @@ instance StrEncoding RCErrorType where "CTRL_NOT_FOUND" -> pure RCECtrlNotFound "CTRL_ERROR" -> RCECtrlError <$> textP "VERSION" -> pure RCEVersion + "ENCRYPT" -> pure RCEEncrypt "DECRYPT" -> pure RCEDecrypt "BLOCK_SIZE" -> pure RCEBlockSize "SYNTAX" -> RCESyntax <$> textP From 4f5d52ada47a15532766b2ff3d3781be629648d8 Mon Sep 17 00:00:00 2001 From: Alexander Bondarenko <486682+dpwiz@users.noreply.github.com> Date: Mon, 13 Nov 2023 19:57:26 +0200 Subject: [PATCH 12/16] Do not allow rejected client certificate (#893) --- src/Simplex/RemoteControl/Client.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Simplex/RemoteControl/Client.hs b/src/Simplex/RemoteControl/Client.hs index e6ab65516..d4ba60e88 100644 --- a/src/Simplex/RemoteControl/Client.hs +++ b/src/Simplex/RemoteControl/Client.hs @@ -138,8 +138,7 @@ connectRCHost drg pairing@RCHostPairing {caKey, caCert, idPrivKey, knownHost} ct 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.onNewHandshake = \_ -> atomically $ isNothing <$> tryReadTMVar r, TLS.onClientCertificate = \(X509.CertificateChain chain) -> case chain of [_leaf, ca] -> do From e0b7942e45e36d92625e07c0c1ce9ca2375a0980 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Mon, 13 Nov 2023 19:25:53 +0000 Subject: [PATCH 13/16] remote: return tls with remote host before host confirmation (#894) --- src/Simplex/RemoteControl/Client.hs | 6 +++--- tests/RemoteControl.hs | 4 ++-- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Simplex/RemoteControl/Client.hs b/src/Simplex/RemoteControl/Client.hs index d4ba60e88..2f9050288 100644 --- a/src/Simplex/RemoteControl/Client.hs +++ b/src/Simplex/RemoteControl/Client.hs @@ -93,7 +93,7 @@ data RCHClient_ = RCHClient_ endSession :: TMVar () } -type RCHostConnection = (RCSignedInvitation, RCHostClient, RCStepTMVar (SessionCode, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing))) +type RCHostConnection = (RCSignedInvitation, RCHostClient, RCStepTMVar (SessionCode, TLS, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing))) connectRCHost :: TVar ChaChaDRG -> RCHostPairing -> J.Value -> ExceptT RCErrorType IO RCHostConnection connectRCHost drg pairing@RCHostPairing {caKey, caCert, idPrivKey, knownHost} ctrlAppInfo = do @@ -114,13 +114,13 @@ connectRCHost drg pairing@RCHostPairing {caKey, caCert, idPrivKey, knownHost} ct endSession <- newEmptyTMVarIO hostCAHash <- newEmptyTMVarIO pure RCHClient_ {startedPort, hostCAHash, endSession} - runClient :: RCHClient_ -> RCStepTMVar (ByteString, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)) -> RCHostKeys -> ExceptT RCErrorType IO (Async ()) + runClient :: RCHClient_ -> RCStepTMVar (SessionCode, TLS, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)) -> RCHostKeys -> ExceptT RCErrorType IO (Async ()) runClient RCHClient_ {startedPort, hostCAHash, endSession} r hostKeys = do tlsCreds <- liftIO $ genTLSCredentials caKey caCert startTLSServer startedPort tlsCreds (tlsHooks r knownHost hostCAHash) $ \tls -> void . runExceptT $ do r' <- newEmptyTMVarIO - whenM (atomically $ tryPutTMVar r $ Right (tlsUniq tls, r')) $ + whenM (atomically $ tryPutTMVar r $ Right (tlsUniq tls, tls, r')) $ runSession tls r' `putRCError` r' where runSession tls r' = do diff --git a/tests/RemoteControl.hs b/tests/RemoteControl.hs index 26b9cdb11..efd7a42b4 100644 --- a/tests/RemoteControl.hs +++ b/tests/RemoteControl.hs @@ -30,7 +30,7 @@ testNewPairing = do logNote "c 2" putMVar invVar (inv, hc) logNote "c 3" - Right (sessId, r') <- atomically $ takeTMVar r + Right (sessId, _tls, r') <- atomically $ takeTMVar r logNote "c 4" Right (_rcHostSession, _rcHelloBody, _hp') <- atomically $ takeTMVar r' logNote "c 5" @@ -98,7 +98,7 @@ testExistingPairing = do runCtrl drg hp invVar = async . runRight $ do (inv, hc, r) <- RC.connectRCHost drg hp (J.String "app") putMVar invVar inv - Right (_sessId, r') <- atomically $ takeTMVar r + Right (_sessId, _tls, r') <- atomically $ takeTMVar r Right (_rcHostSession, _rcHelloBody, hp') <- atomically $ takeTMVar r' threadDelay 250000 liftIO $ RC.cancelHostClient hc From d60911c78096c37c3b2f3c925018863a6cbba3e0 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Tue, 14 Nov 2023 13:51:23 +0000 Subject: [PATCH 14/16] xftp: refactor receiving encrypted file (#896) --- src/Simplex/FileTransfer/Transport.hs | 22 +++++++++++++++++----- 1 file changed, 17 insertions(+), 5 deletions(-) diff --git a/src/Simplex/FileTransfer/Transport.hs b/src/Simplex/FileTransfer/Transport.hs index 1309b9c31..90b1a8a44 100644 --- a/src/Simplex/FileTransfer/Transport.hs +++ b/src/Simplex/FileTransfer/Transport.hs @@ -6,9 +6,11 @@ module Simplex.FileTransfer.Transport ( supportedFileServerVRange, XFTPRcvChunkSpec (..), + ReceiveFileError (..), receiveFile, sendEncFile, receiveEncFile, + receiveSbFile, ) where @@ -16,6 +18,7 @@ import qualified Control.Exception as E import Control.Monad import Control.Monad.Except import Control.Monad.IO.Class +import Data.Bifunctor (first) import qualified Data.ByteArray as BA import Data.ByteString.Builder (Builder, byteString) import Data.ByteString.Char8 (ByteString) @@ -59,25 +62,34 @@ receiveFile getBody = receiveFile_ receive receiveEncFile :: (Int -> IO ByteString) -> LC.SbState -> XFTPRcvChunkSpec -> ExceptT XFTPErrorType IO () receiveEncFile getBody = receiveFile_ . receive where - receive sbState h sz = do + receive sbState h sz = first err <$> receiveSbFile getBody h sbState sz + err RFESize = SIZE + err RFECrypto = CRYPTO + +data ReceiveFileError = RFESize | RFECrypto + +receiveSbFile :: (Int -> IO ByteString) -> Handle -> LC.SbState -> Word32 -> IO (Either ReceiveFileError ()) +receiveSbFile getBody h = receive + where + receive sbState sz = do ch <- getBody fileBlockSize let chSize = fromIntegral $ B.length ch if - | chSize > sz + authSz -> pure $ Left SIZE + | chSize > sz + authSz -> pure $ Left RFESize | chSize > 0 -> do let (ch', rest) = B.splitAt (fromIntegral sz) ch (decCh, sbState') = LC.sbDecryptChunk sbState ch' sz' = sz - fromIntegral (B.length ch') B.hPut h decCh if sz' > 0 - then receive sbState' h sz' + then receive sbState' sz' else do let tag' = B.take C.authTagSize rest tagSz = B.length tag' tag = LC.sbAuth sbState' tag'' <- if tagSz == C.authTagSize then pure tag' else (tag' <>) <$> getBody (C.authTagSize - tagSz) - pure $ if BA.constEq tag'' tag then Right () else Left CRYPTO - | otherwise -> pure $ Left SIZE + pure $ if BA.constEq tag'' tag then Right () else Left RFECrypto + | otherwise -> pure $ Left RFESize authSz = fromIntegral C.authTagSize receiveFile_ :: (Handle -> Word32 -> IO (Either XFTPErrorType ())) -> XFTPRcvChunkSpec -> ExceptT XFTPErrorType IO () From c501f4f9ccdd48807a5153697ea1827129841158 Mon Sep 17 00:00:00 2001 From: Alexander Bondarenko <486682+dpwiz@users.noreply.github.com> Date: Fri, 17 Nov 2023 12:37:32 +0200 Subject: [PATCH 15/16] remote: fix deadlocked client when server rejects its cert (#897) * remote: detect tls errors sooner to prevent deadlocks * remove redundant error checking * cleanup --- src/Simplex/Messaging/Transport/Buffer.hs | 9 +++++++++ src/Simplex/RemoteControl/Client.hs | 18 ++++++++++-------- 2 files changed, 19 insertions(+), 8 deletions(-) diff --git a/src/Simplex/Messaging/Transport/Buffer.hs b/src/Simplex/Messaging/Transport/Buffer.hs index 251471679..6de9326f8 100644 --- a/src/Simplex/Messaging/Transport/Buffer.hs +++ b/src/Simplex/Messaging/Transport/Buffer.hs @@ -6,6 +6,7 @@ module Simplex.Messaging.Transport.Buffer where import Control.Concurrent.STM import qualified Control.Exception as E +import Control.Monad (forM_) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import GHC.IO.Exception (IOErrorType (..), IOException (..), ioException) @@ -28,6 +29,14 @@ withBufferLock TBuffer {getLock} = (atomically $ takeTMVar getLock) (atomically $ putTMVar getLock ()) +-- | Attempt to read some bytes, appending it to the existing buffer +peekBuffered :: TBuffer -> Int -> IO ByteString -> IO (ByteString, Maybe ByteString) +peekBuffered tb@TBuffer {buffer} t getChunk = withBufferLock tb $ do + old <- readTVarIO buffer + next_ <- timeout t getChunk + forM_ next_ $ \next -> atomically $ writeTVar buffer $! old <> next + pure (old, next_) + getBuffered :: TBuffer -> Int -> Maybe Int -> IO ByteString -> IO ByteString getBuffered tb@TBuffer {buffer} n t_ getChunk = withBufferLock tb $ do b <- readChunks True =<< readTVarIO buffer diff --git a/src/Simplex/RemoteControl/Client.hs b/src/Simplex/RemoteControl/Client.hs index 2f9050288..efbda4998 100644 --- a/src/Simplex/RemoteControl/Client.hs +++ b/src/Simplex/RemoteControl/Client.hs @@ -54,7 +54,8 @@ import qualified Simplex.Messaging.Crypto.Lazy as LC import Simplex.Messaging.Crypto.SNTRUP761 import Simplex.Messaging.Crypto.SNTRUP761.Bindings import Simplex.Messaging.Encoding -import Simplex.Messaging.Transport (TLS (tlsUniq), cGet, cPut) +import Simplex.Messaging.Transport (TLS (..), cGet, cPut) +import Simplex.Messaging.Transport.Buffer (peekBuffered) import Simplex.Messaging.Transport.Client (TransportClientConfig (..), TransportHost, defaultTransportClientConfig, runTransportClient) import Simplex.Messaging.Transport.Credentials (genCredentials, tlsCredentials) import Simplex.Messaging.Util @@ -273,13 +274,14 @@ connectRCCtrl_ drg pairing'@RCCtrlPairing {caKey, caCert} inv@RCInvitation {ca, TLS.Credentials (creds : _) -> pure $ Just creds _ -> throwError $ RCEInternal "genTLSCredentials must generate credentials" let clientConfig = defaultTransportClientConfig {clientCredentials} - liftIO . runTransportClient clientConfig Nothing host (show port) (Just ca) $ \tls -> - void . runExceptT $ do - logDebug "Got TLS connection" - r' <- newEmptyTMVarIO - whenM (atomically $ tryPutTMVar r $ Right (tlsUniq tls, tls, r')) $ do - logDebug "Waiting for session confirmation" - whenM (atomically $ readTMVar confirmSession) (runSession tls r') `putRCError` r' + runTransportClient clientConfig Nothing host (show port) (Just ca) $ \tls@TLS {tlsBuffer, tlsContext} -> do + -- pump socket to detect connection problems + liftIO $ peekBuffered tlsBuffer 100000 (TLS.recvData tlsContext) >>= logDebug . tshow -- should normally be ("", Nothing) here + logDebug "Got TLS connection" + r' <- newEmptyTMVarIO + whenM (atomically $ tryPutTMVar r $ Right (tlsUniq tls, tls, r')) $ do + logDebug "Waiting for session confirmation" + whenM (atomically $ readTMVar confirmSession) $ runSession tls r' `putRCError` r' where runSession tls r' = do (sharedKey, kemPrivKey, hostEncHello) <- prepareHostHello drg pairing' inv hostAppInfo From 40ba94ce72fb4273641c56fd4c60cd133a24925a Mon Sep 17 00:00:00 2001 From: Alexander Bondarenko <486682+dpwiz@users.noreply.github.com> Date: Fri, 17 Nov 2023 19:56:14 +0200 Subject: [PATCH 16/16] remote: add multicast discovery w/ encrypted announce (#895) * Implement multicast discovery * replace rcConnectMulticast with explicit discoverRCCtrl * add multicast source/invitation host check * remove JSON encoding for multicast invitations * add specific error for announcing "new" controllers * rename * set size, rename --------- Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> --- rfcs/2023-10-25-remote-control.md | 42 +-------- src/Simplex/Messaging/Agent.hs | 31 +++---- src/Simplex/Messaging/Agent/Env/SQLite.hs | 6 +- src/Simplex/Messaging/Util.hs | 5 +- src/Simplex/RemoteControl/Client.hs | 106 ++++++++++++++-------- src/Simplex/RemoteControl/Invitation.hs | 51 +++++------ src/Simplex/RemoteControl/Types.hs | 9 ++ tests/RemoteControl.hs | 96 ++++++++++++++------ 8 files changed, 195 insertions(+), 151 deletions(-) diff --git a/rfcs/2023-10-25-remote-control.md b/rfcs/2023-10-25-remote-control.md index 097377322..444185307 100644 --- a/rfcs/2023-10-25-remote-control.md +++ b/rfcs/2023-10-25-remote-control.md @@ -86,52 +86,16 @@ base64url = ; RFC4648, section 5 Multicast session announcement is a binary encoded packet with this syntax: ```abnf -sessionAddressPacket = dhPubKey nonce encrypted(unpaddedSize serviceAddress sessSignature idSignature packetPad) -dhPubKey = length x509encoded +sessionAddressPacket = dhPubKey nonce encrypted(unpaddedSize sessionAddress packetPad) +dhPubKey = length x509encoded ; same as announced nonce = length *OCTET -serviceAddress = largeLength serviceAddressJSON -sessSignature = length *OCTET ; signs the preceding announcement packet -idSignature = length *OCTET ; signs the preceding announcement packet including sessSignature +sessionAddress = largeLength sessionAddressUri ; as above length = 1*1 OCTET ; for binary data up to 255 bytes largeLength = 2*2 OCTET ; for binary data up to 65535 bytes packetPad = ; possibly, we may need to move KEM agreement one step later, ; with encapsulation key in HELLO block and KEM ciphertext in reply to HELLO. ``` -addressJSON is a JSON string valid against this JTD (RFC 8927) schema: - -```json -{ - "definitions": { - "versionRange": { - "type": "string", - "metadata": { - "format": "[0-9]+(-[0-9]+)?" - } - }, - "base64url": { - "type": "string", - "metadata": { - "format": "base64url" - } - } - }, - "properties": { - "ca": {"ref": "base64url"}, - "host": {"type": "string"}, - "port": {"type": "uint16"}, - "v": {"ref": "versionRange"}, - "ts": {"type": "uint64"}, - "skey": {"ref": "base64url"}, - "idkey": {"ref": "base64url"} - }, - "optionalProperties": { - "app": {"properties": {}, "additionalProperties": true} - }, - "additionalProperties": true -} -``` - ### Establishing session TLS connection Host connects to controller via TCP session and validates CA credentials during TLS handshake. Controller acts as a TCP server in this connection, to avoid host device listening on a port, which might create an attack vector. During TLS handshake the controller's TCP server MUST present a self-signed two-certificate chain where the fingerprint of the first certificate MUST be the same as in the announcement. diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index e3b1bccf4..6a0701136 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -95,8 +95,8 @@ module Simplex.Messaging.Agent xftpDeleteSndFileRemote, rcNewHostPairing, rcConnectHost, - rcConnectCtrlURI, - rcConnectCtrlMulticast, + rcConnectCtrl, + rcDiscoverCtrl, foregroundAgent, suspendAgent, execAgentStoreSQL, @@ -396,28 +396,27 @@ rcConnectHost :: AgentErrorMonad m => AgentClient -> RCHostPairing -> J.Value -> rcConnectHost c = withAgentEnv c .:. rcConnectHost' rcConnectHost' :: AgentMonad m => RCHostPairing -> J.Value -> Bool -> m RCHostConnection -rcConnectHost' pairing ctrlAppInfo _multicast = do +rcConnectHost' pairing ctrlAppInfo multicast = do drg <- asks random - liftError RCP $ connectRCHost drg pairing ctrlAppInfo + liftError RCP $ connectRCHost drg pairing ctrlAppInfo multicast -- | connect to remote controller via URI -rcConnectCtrlURI :: AgentErrorMonad m => AgentClient -> RCSignedInvitation -> Maybe RCCtrlPairing -> J.Value -> m RCCtrlConnection -rcConnectCtrlURI c = withAgentEnv c .:. rcConnectCtrlURI' +rcConnectCtrl :: AgentErrorMonad m => AgentClient -> RCVerifiedInvitation -> Maybe RCCtrlPairing -> J.Value -> m RCCtrlConnection +rcConnectCtrl c = withAgentEnv c .:. rcConnectCtrl' -rcConnectCtrlURI' :: AgentMonad m => RCSignedInvitation -> Maybe RCCtrlPairing -> J.Value -> m RCCtrlConnection -rcConnectCtrlURI' signedInv pairing_ hostAppInfo = do +rcConnectCtrl' :: AgentMonad m => RCVerifiedInvitation -> Maybe RCCtrlPairing -> J.Value -> m RCCtrlConnection +rcConnectCtrl' verifiedInv pairing_ hostAppInfo = do drg <- asks random - liftError RCP $ connectRCCtrlURI drg signedInv pairing_ hostAppInfo + liftError RCP $ connectRCCtrl drg verifiedInv pairing_ hostAppInfo -- | connect to known remote controller via multicast -rcConnectCtrlMulticast :: AgentErrorMonad m => AgentClient -> NonEmpty RCCtrlPairing -> J.Value -> m RCCtrlConnection -rcConnectCtrlMulticast c = withAgentEnv c .: rcConnectCtrlMulticast' +rcDiscoverCtrl :: AgentErrorMonad m => AgentClient -> NonEmpty RCCtrlPairing -> m (RCCtrlPairing, RCVerifiedInvitation) +rcDiscoverCtrl c = withAgentEnv c . rcDiscoverCtrl' -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 +rcDiscoverCtrl' :: AgentMonad m => NonEmpty RCCtrlPairing -> m (RCCtrlPairing, RCVerifiedInvitation) +rcDiscoverCtrl' pairings = do + subs <- asks multicastSubscribers + liftError RCP $ discoverRCCtrl subs pairings -- | Activate operations foregroundAgent :: MonadUnliftIO m => AgentClient -> m () diff --git a/src/Simplex/Messaging/Agent/Env/SQLite.hs b/src/Simplex/Messaging/Agent/Env/SQLite.hs index cbdae289c..6f2347391 100644 --- a/src/Simplex/Messaging/Agent/Env/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Env/SQLite.hs @@ -182,7 +182,8 @@ data Env = Env clientCounter :: TVar Int, randomServer :: TVar StdGen, ntfSupervisor :: NtfSupervisor, - xftpAgent :: XFTPAgent + xftpAgent :: XFTPAgent, + multicastSubscribers :: TMVar Int } newSMPAgentEnv :: AgentConfig -> SQLiteStore -> IO Env @@ -192,7 +193,8 @@ newSMPAgentEnv config@AgentConfig {initialClientId} store = do randomServer <- newTVarIO =<< liftIO newStdGen ntfSupervisor <- atomically . newNtfSubSupervisor $ tbqSize config xftpAgent <- atomically newXFTPAgent - pure Env {config, store, random, clientCounter, randomServer, ntfSupervisor, xftpAgent} + multicastSubscribers <- newTMVarIO 0 + pure Env {config, store, random, clientCounter, randomServer, ntfSupervisor, xftpAgent, multicastSubscribers} createAgentStore :: FilePath -> String -> MigrationConfirmation -> IO (Either MigrationError SQLiteStore) createAgentStore dbFilePath dbKey = createSQLiteStore dbFilePath dbKey Migrations.app diff --git a/src/Simplex/Messaging/Util.hs b/src/Simplex/Messaging/Util.hs index 2dca0956a..373a19172 100644 --- a/src/Simplex/Messaging/Util.hs +++ b/src/Simplex/Messaging/Util.hs @@ -19,7 +19,7 @@ import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8With) import Data.Time (NominalDiffTime) import GHC.Conc -import UnliftIO.Async +import UnliftIO hiding (handle) import qualified UnliftIO.Exception as UE raceAny_ :: MonadUnliftIO m => [m a] -> m () @@ -136,6 +136,9 @@ safeDecodeUtf8 = decodeUtf8With onError where onError _ _ = Just '?' +timeoutThrow :: (MonadUnliftIO m, MonadError e m) => e -> Int -> m a -> m a +timeoutThrow e ms action = timeout ms action >>= maybe (throwError e) pure + threadDelay' :: Int64 -> IO () threadDelay' time | time <= 0 = pure () diff --git a/src/Simplex/RemoteControl/Client.hs b/src/Simplex/RemoteControl/Client.hs index efbda4998..9f2c75463 100644 --- a/src/Simplex/RemoteControl/Client.hs +++ b/src/Simplex/RemoteControl/Client.hs @@ -16,8 +16,8 @@ module Simplex.RemoteControl.Client cancelHostClient, RCCtrlClient (action), RCCtrlConnection, - connectRCCtrlURI, - connectKnownRCCtrlMulticast, + connectRCCtrl, + discoverRCCtrl, confirmCtrlSession, cancelCtrlClient, RCStepTMVar, @@ -45,8 +45,9 @@ 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 Network.Socket (PortNumber, SockAddr (..), hostAddressToTuple) import qualified Network.TLS as TLS +import qualified Network.UDP as UDP import Simplex.Messaging.Agent.Client () import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.Lazy (LazyByteString) @@ -54,16 +55,18 @@ import qualified Simplex.Messaging.Crypto.Lazy as LC import Simplex.Messaging.Crypto.SNTRUP761 import Simplex.Messaging.Crypto.SNTRUP761.Bindings import Simplex.Messaging.Encoding +import Simplex.Messaging.Encoding.String (StrEncoding (..)) import Simplex.Messaging.Transport (TLS (..), cGet, cPut) import Simplex.Messaging.Transport.Buffer (peekBuffered) -import Simplex.Messaging.Transport.Client (TransportClientConfig (..), TransportHost, defaultTransportClientConfig, runTransportClient) +import Simplex.Messaging.Transport.Client (TransportClientConfig (..), TransportHost (..), defaultTransportClientConfig, runTransportClient) import Simplex.Messaging.Transport.Credentials (genCredentials, tlsCredentials) import Simplex.Messaging.Util import Simplex.Messaging.Version -import Simplex.RemoteControl.Discovery (getLocalAddress, startTLSServer) +import Simplex.RemoteControl.Discovery (getLocalAddress, recvAnnounce, startTLSServer, withListener, withSender) import Simplex.RemoteControl.Invitation import Simplex.RemoteControl.Types import UnliftIO +import UnliftIO.Concurrent currentRCVersion :: Version currentRCVersion = 1 @@ -77,6 +80,9 @@ xrcpBlockSize = 16384 helloBlockSize :: Int helloBlockSize = 12288 +encInvitationSize :: Int +encInvitationSize = 900 + newRCHostPairing :: IO RCHostPairing newRCHostPairing = do ((_, caKey), caCert) <- genCredentials Nothing (-25, 24 * 999999) "ca" @@ -90,33 +96,40 @@ data RCHostClient = RCHostClient data RCHClient_ = RCHClient_ { startedPort :: TMVar (Maybe PortNumber), + announcer :: TMVar (Async (Either RCErrorType ())), hostCAHash :: TMVar C.KeyHash, endSession :: TMVar () } type RCHostConnection = (RCSignedInvitation, RCHostClient, RCStepTMVar (SessionCode, TLS, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing))) -connectRCHost :: TVar ChaChaDRG -> RCHostPairing -> J.Value -> ExceptT RCErrorType IO RCHostConnection -connectRCHost drg pairing@RCHostPairing {caKey, caCert, idPrivKey, knownHost} ctrlAppInfo = do +connectRCHost :: TVar ChaChaDRG -> RCHostPairing -> J.Value -> Bool -> ExceptT RCErrorType IO RCHostConnection +connectRCHost drg pairing@RCHostPairing {caKey, caCert, idPrivKey, knownHost} ctrlAppInfo multicast = do r <- newEmptyTMVarIO host <- getLocalAddress >>= maybe (throwError RCENoLocalAddress) pure - c@RCHClient_ {startedPort} <- liftIO mkClient + c@RCHClient_ {startedPort, announcer} <- liftIO mkClient hostKeys <- liftIO genHostKeys action <- runClient c r hostKeys `putRCError` r -- 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 + signedInv@RCSignedInvitation {invitation} <- maybe (throwError RCETLSStartFailed) (liftIO . mkInvitation hostKeys host) portNum + when multicast $ case knownHost of + Nothing -> throwError RCENewController + Just KnownHostPairing {hostDhPubKey} -> do + ann <- async . liftIO . runExceptT $ announceRC drg 60 idPrivKey hostDhPubKey hostKeys invitation + atomically $ putTMVar announcer ann pure (signedInv, RCHostClient {action, client_ = c}, r) where mkClient :: IO RCHClient_ mkClient = do startedPort <- newEmptyTMVarIO + announcer <- newEmptyTMVarIO endSession <- newEmptyTMVarIO hostCAHash <- newEmptyTMVarIO - pure RCHClient_ {startedPort, hostCAHash, endSession} + pure RCHClient_ {startedPort, announcer, hostCAHash, endSession} runClient :: RCHClient_ -> RCStepTMVar (SessionCode, TLS, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)) -> RCHostKeys -> ExceptT RCErrorType IO (Async ()) - runClient RCHClient_ {startedPort, hostCAHash, endSession} r hostKeys = do + runClient RCHClient_ {startedPort, announcer, hostCAHash, endSession} r hostKeys = do tlsCreds <- liftIO $ genTLSCredentials caKey caCert startTLSServer startedPort tlsCreds (tlsHooks r knownHost hostCAHash) $ \tls -> void . runExceptT $ do @@ -133,6 +146,7 @@ connectRCHost drg pairing@RCHostPairing {caKey, caCert, idPrivKey, knownHost} ct sendRCPacket tls ctrlEncHello logDebug "Sent ctrl HELLO" whenM (atomically $ tryPutTMVar r' $ Right (RCHostSession {tls, sessionKeys}, helloBody, pairing')) $ do + atomically (tryReadTMVar announcer) >>= mapM_ uninterruptibleCancel -- can use `RCHostSession` until `endSession` is signalled logDebug "Holding session" atomically $ takeTMVar endSession @@ -171,8 +185,7 @@ connectRCHost drg pairing@RCHostPairing {caKey, caCert, idPrivKey, knownHost} ct idkey = C.publicKey idPrivKey, dh = fst dhKeys } - signedInv = signInviteURL (snd sessKeys) idPrivKey inv - pure signedInv + pure $ signInvitation (snd sessKeys) idPrivKey inv genTLSCredentials :: C.APrivateSignKey -> C.SignedCertificate -> IO TLS.Credentials genTLSCredentials caKey caCert = do @@ -186,8 +199,9 @@ certFingerprint caCert = C.KeyHash fp Fingerprint fp = getFingerprint caCert X509.HashSHA256 cancelHostClient :: RCHostClient -> IO () -cancelHostClient RCHostClient {action, client_ = RCHClient_ {endSession}} = do +cancelHostClient RCHostClient {action, client_ = RCHClient_ {announcer, endSession}} = do atomically $ putTMVar endSession () + atomically (tryTakeTMVar announcer) >>= mapM_ uninterruptibleCancel uninterruptibleCancel action prepareHostSession :: TVar ChaChaDRG -> C.KeyHash -> RCHostPairing -> RCHostKeys -> RCHostEncHello -> ExceptT RCErrorType IO (RCCtrlEncHello, HostSessKeys, RCHostHello, RCHostPairing) @@ -233,14 +247,9 @@ data RCCClient_ = RCCClient_ type RCCtrlConnection = (RCCtrlClient, RCStepTMVar (SessionCode, TLS, 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 +connectRCCtrl :: TVar ChaChaDRG -> RCVerifiedInvitation -> Maybe RCCtrlPairing -> J.Value -> ExceptT RCErrorType IO RCCtrlConnection +connectRCCtrl drg (RCVerifiedInvitation inv@RCInvitation {ca, idkey}) pairing_ hostAppInfo = do pairing' <- maybe (liftIO newCtrlPairing) updateCtrlPairing pairing_ connectRCCtrl_ drg pairing' inv hostAppInfo where @@ -351,24 +360,47 @@ prepareCtrlSession message <- liftEitherWith (const RCEDecrypt) $ C.cbDecrypt 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 +-- * Multicast discovery -findRCCtrlPairing :: NonEmpty RCCtrlPairing -> RCEncInvitation -> ExceptT RCErrorType IO (RCCtrlPairing, RCInvitation) +announceRC :: TVar ChaChaDRG -> Int -> C.PrivateKeyEd25519 -> C.PublicKeyX25519 -> RCHostKeys -> RCInvitation -> ExceptT RCErrorType IO () +announceRC drg maxCount idPrivKey knownDhPub RCHostKeys {sessKeys, dhKeys} inv = withSender $ \sender -> do + replicateM_ maxCount $ do + logDebug "Announcing..." + nonce <- atomically $ C.pseudoRandomCbNonce drg + encInvitation <- liftEitherWith undefined $ C.cbEncrypt sharedKey nonce sigInvitation encInvitationSize + liftIO . UDP.send sender $ smpEncode RCEncInvitation {dhPubKey, nonce, encInvitation} + threadDelay 1000000 + where + sigInvitation = strEncode $ signInvitation sPrivKey idPrivKey inv + (_sPub, sPrivKey) = sessKeys + sharedKey = C.dh' knownDhPub dhPrivKey + (dhPubKey, dhPrivKey) = dhKeys + +discoverRCCtrl :: TMVar Int -> NonEmpty RCCtrlPairing -> ExceptT RCErrorType IO (RCCtrlPairing, RCVerifiedInvitation) +discoverRCCtrl subscribers pairings = + timeoutThrow RCENotDiscovered 30000000 $ withListener subscribers $ \listener -> + loop $ do + (source, bytes) <- recvAnnounce listener + encInvitation <- liftEitherWith (const RCEInvitation) $ smpDecode bytes + r@(_, RCVerifiedInvitation RCInvitation {host}) <- findRCCtrlPairing pairings encInvitation + case source of + SockAddrInet _ ha | THIPv4 (hostAddressToTuple ha) == host -> pure () + _ -> throwError RCEInvitation + pure r + where + loop :: ExceptT RCErrorType IO a -> ExceptT RCErrorType IO a + loop action = + liftIO (runExceptT action) >>= \case + Left err -> logError (tshow err) >> loop action + Right res -> pure res + +findRCCtrlPairing :: NonEmpty RCCtrlPairing -> RCEncInvitation -> ExceptT RCErrorType IO (RCCtrlPairing, RCVerifiedInvitation) 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) + signedInv <- liftEitherWith RCESyntax $ strDecode signedInvStr + inv@(RCVerifiedInvitation RCInvitation {dh = invDh}) <- maybe (throwError RCEInvitation) pure $ verifySignedInvitation signedInv + unless (invDh == dhPubKey) $ throwError RCEInvitation + pure (pairing, inv) where decrypt :: [RCCtrlPairing] -> Either RCErrorType (RCCtrlPairing, ByteString) decrypt [] = Left RCECtrlNotFound @@ -380,6 +412,8 @@ findRCCtrlPairing pairings RCEncInvitation {dhPubKey, nonce, encInvitation} = do let key = C.dh' dhPubKey dhPrivKey in eitherToMaybe $ C.cbDecrypt key nonce encInvitation +-- * Controller handle operations + -- application should call this function when TMVar resolves confirmCtrlSession :: RCCtrlClient -> Bool -> IO () confirmCtrlSession RCCtrlClient {client_ = RCCClient_ {confirmSession}} res = do diff --git a/src/Simplex/RemoteControl/Invitation.hs b/src/Simplex/RemoteControl/Invitation.hs index 224417ea0..f5deac9a8 100644 --- a/src/Simplex/RemoteControl/Invitation.hs +++ b/src/Simplex/RemoteControl/Invitation.hs @@ -3,13 +3,17 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -module Simplex.RemoteControl.Invitation where +module Simplex.RemoteControl.Invitation + ( RCInvitation (..) + , signInvitation + , RCSignedInvitation (..) + , verifySignedInvitation + , RCVerifiedInvitation (..) + , RCEncInvitation (..) + ) 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 @@ -21,7 +25,7 @@ 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.Parsers (parseAll) import Simplex.Messaging.Transport.Client (TransportHost) import Simplex.Messaging.Version (VersionRange) @@ -119,38 +123,32 @@ instance StrEncoding RCSignedInvitation where 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} +signInvitation :: C.PrivateKey C.Ed25519 -> C.PrivateKey C.Ed25519 -> RCInvitation -> RCSignedInvitation +signInvitation sKey idKey invitation = RCSignedInvitation {invitation, ssig, idsig} where - inviteUrl = strEncode invitation + uri = strEncode invitation ssig = - case C.sign (C.APrivateSignKey C.SEd25519 sKey) inviteUrl of + case C.sign (C.APrivateSignKey C.SEd25519 sKey) uri of C.ASignature C.SEd25519 s -> s _ -> error "signing with ed25519" - inviteUrlSigned = mconcat [inviteUrl, "&ssig=", strEncode ssig] + inviteUrlSigned = mconcat [uri, "&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 +newtype RCVerifiedInvitation = RCVerifiedInvitation RCInvitation + deriving (Show) + +verifySignedInvitation :: RCSignedInvitation -> Maybe RCVerifiedInvitation +verifySignedInvitation RCSignedInvitation {invitation, ssig, idsig} = + if C.verify' skey ssig inviteURL && C.verify' idkey idsig inviteURLS + then Just $ RCVerifiedInvitation invitation + else Nothing 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, @@ -169,8 +167,3 @@ instance Encoding RCEncInvitation where 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) diff --git a/src/Simplex/RemoteControl/Types.hs b/src/Simplex/RemoteControl/Types.hs index 78e7d8956..7f99079b2 100644 --- a/src/Simplex/RemoteControl/Types.hs +++ b/src/Simplex/RemoteControl/Types.hs @@ -31,11 +31,14 @@ data RCErrorType = RCEInternal {internalErr :: String} | RCEIdentity | RCENoLocalAddress + | RCENewController + | RCENotDiscovered | RCETLSStartFailed | RCEException {exception :: String} | RCECtrlAuth | RCECtrlNotFound | RCECtrlError {ctrlErr :: String} + | RCEInvitation | RCEVersion | RCEEncrypt | RCEDecrypt @@ -48,11 +51,14 @@ instance StrEncoding RCErrorType where RCEInternal err -> "INTERNAL" <> text err RCEIdentity -> "IDENTITY" RCENoLocalAddress -> "NO_LOCAL_ADDR" + RCENewController -> "NEW_CONTROLLER" + RCENotDiscovered -> "NOT_DISCOVERED" RCETLSStartFailed -> "CTRL_TLS_START" RCEException err -> "EXCEPTION" <> text err RCECtrlAuth -> "CTRL_AUTH" RCECtrlNotFound -> "CTRL_NOT_FOUND" RCECtrlError err -> "CTRL_ERROR" <> text err + RCEInvitation -> "INVITATION" RCEVersion -> "VERSION" RCEEncrypt -> "ENCRYPT" RCEDecrypt -> "DECRYPT" @@ -65,11 +71,14 @@ instance StrEncoding RCErrorType where "INTERNAL" -> RCEInternal <$> textP "IDENTITY" -> pure RCEIdentity "NO_LOCAL_ADDR" -> pure RCENoLocalAddress + "NEW_CONTROLLER" -> pure RCENewController + "NOT_DISCOVERED" -> pure RCENotDiscovered "CTRL_TLS_START" -> pure RCETLSStartFailed "EXCEPTION" -> RCEException <$> textP "CTRL_AUTH" -> pure RCECtrlAuth "CTRL_NOT_FOUND" -> pure RCECtrlNotFound "CTRL_ERROR" -> RCECtrlError <$> textP + "INVITATION" -> pure RCEInvitation "VERSION" -> pure RCEVersion "ENCRYPT" -> pure RCEEncrypt "DECRYPT" -> pure RCEDecrypt diff --git a/tests/RemoteControl.hs b/tests/RemoteControl.hs index efd7a42b4..d70fbc7e7 100644 --- a/tests/RemoteControl.hs +++ b/tests/RemoteControl.hs @@ -6,9 +6,12 @@ module RemoteControl where import AgentTests.FunctionalAPITests (runRight) import Control.Logger.Simple -import Crypto.Random (drgNew) +import Crypto.Random (ChaChaDRG, drgNew) import qualified Data.Aeson as J +import Data.List.NonEmpty (NonEmpty (..)) import qualified Simplex.RemoteControl.Client as RC +import Simplex.RemoteControl.Invitation (RCSignedInvitation, verifySignedInvitation) +import Simplex.RemoteControl.Types import Test.Hspec import UnliftIO import UnliftIO.Concurrent @@ -18,6 +21,8 @@ remoteControlTests = do describe "New controller/host pairing" $ do it "should connect to new pairing" testNewPairing it "should connect to existing pairing" testExistingPairing + describe "Multicast discovery" $ do + it "should find paired host and connect" testMulticast testNewPairing :: IO () testNewPairing = do @@ -26,7 +31,7 @@ testNewPairing = do invVar <- newEmptyMVar ctrlSessId <- async . runRight $ do logNote "c 1" - (inv, hc, r) <- RC.connectRCHost drg hp (J.String "app") + (inv, hc, r) <- RC.connectRCHost drg hp (J.String "app") False logNote "c 2" putMVar invVar (inv, hc) logNote "c 3" @@ -39,12 +44,13 @@ testNewPairing = do liftIO $ RC.cancelHostClient hc pure sessId - (inv, hc) <- takeMVar invVar + (signedInv, hc) <- takeMVar invVar -- logNote $ decodeUtf8 $ strEncode inv + inv <- maybe (fail "bad invite") pure $ verifySignedInvitation signedInv hostSessId <- async . runRight $ do logNote "h 1" - (rcCtrlClient, r) <- RC.connectRCCtrlURI drg inv Nothing (J.String "app") + (rcCtrlClient, r) <- RC.connectRCCtrl drg inv Nothing (J.String "app") logNote "h 2" Right (sessId', _tls, r') <- atomically $ takeTMVar r logNote "h 3" @@ -69,44 +75,78 @@ testExistingPairing = do drg <- drgNew >>= newTVarIO invVar <- newEmptyMVar hp <- liftIO $ RC.newRCHostPairing - ctrl <- runCtrl drg hp invVar + ctrl <- runCtrl drg False hp invVar inv <- takeMVar invVar let cp_ = Nothing - host <- runHost drg cp_ inv + host <- runHostURI drg cp_ inv timeout 5000000 (waitBoth ctrl host) >>= \case Nothing -> fail "timeout" Just (hp', cp') -> do - ctrl' <- runCtrl drg hp' invVar + ctrl' <- runCtrl drg False hp' invVar inv' <- takeMVar invVar - host' <- runHost drg (Just cp') inv' + host' <- runHostURI drg (Just cp') inv' timeout 5000000 (waitBoth ctrl' host') >>= \case Nothing -> fail "timeout" Just (_hp2, cp2) -> do - ctrl2 <- runCtrl drg hp' invVar -- old host pairing used to test controller not updating state + ctrl2 <- runCtrl drg False hp' invVar -- old host pairing used to test controller not updating state inv2 <- takeMVar invVar - host2 <- runHost drg (Just cp2) inv2 + host2 <- runHostURI drg (Just cp2) inv2 timeout 5000000 (waitBoth ctrl2 host2) >>= \case Nothing -> fail "timeout" Just (hp3, cp3) -> do - ctrl3 <- runCtrl drg hp3 invVar + ctrl3 <- runCtrl drg False hp3 invVar inv3 <- takeMVar invVar - host3 <- runHost drg (Just cp3) inv3 + host3 <- runHostURI drg (Just cp3) inv3 timeout 5000000 (waitBoth ctrl3 host3) >>= \case Nothing -> fail "timeout" Just _ -> pure () - where - runCtrl drg hp invVar = async . runRight $ do - (inv, hc, r) <- RC.connectRCHost drg hp (J.String "app") - putMVar invVar inv - Right (_sessId, _tls, r') <- atomically $ takeTMVar r - Right (_rcHostSession, _rcHelloBody, hp') <- atomically $ takeTMVar r' - threadDelay 250000 - liftIO $ RC.cancelHostClient hc - pure hp' - runHost drg cp_ inv = async . runRight $ do - (rcCtrlClient, r) <- RC.connectRCCtrlURI drg inv cp_ (J.String "app") - Right (_sessId', _tls, r') <- atomically $ takeTMVar r - liftIO $ RC.confirmCtrlSession rcCtrlClient True - Right (_rcCtrlSession, cp') <- atomically $ takeTMVar r' - threadDelay 250000 - pure cp' + +testMulticast :: IO () +testMulticast = do + drg <- drgNew >>= newTVarIO + subscribers <- newTMVarIO 0 + invVar <- newEmptyMVar + hp <- liftIO RC.newRCHostPairing + ctrl <- runCtrl drg False hp invVar + inv <- takeMVar invVar + let cp_ = Nothing + host <- runHostURI drg cp_ inv + timeout 5000000 (waitBoth ctrl host) >>= \case + Nothing -> fail "timeout" + Just (hp', cp') -> do + ctrl' <- runCtrl drg True hp' invVar + _inv <- takeMVar invVar + host' <- runHostMulticast drg subscribers cp' + timeout 5000000 (waitBoth ctrl' host') >>= \case + Nothing -> fail "timeout" + Just _ -> pure () + +runCtrl :: TVar ChaChaDRG -> Bool -> RCHostPairing -> MVar RCSignedInvitation -> IO (Async RCHostPairing) +runCtrl drg multicast hp invVar = async . runRight $ do + (inv, hc, r) <- RC.connectRCHost drg hp (J.String "app") multicast + putMVar invVar inv + Right (_sessId, _tls, r') <- atomically $ takeTMVar r + Right (_rcHostSession, _rcHelloBody, hp') <- atomically $ takeTMVar r' + threadDelay 250000 + liftIO $ RC.cancelHostClient hc + pure hp' + +runHostURI :: TVar ChaChaDRG -> Maybe RCCtrlPairing -> RCSignedInvitation -> IO (Async RCCtrlPairing) +runHostURI drg cp_ signedInv = async . runRight $ do + inv <- maybe (fail "bad invite") pure $ verifySignedInvitation signedInv + (rcCtrlClient, r) <- RC.connectRCCtrl drg inv cp_ (J.String "app") + Right (_sessId', _tls, r') <- atomically $ takeTMVar r + liftIO $ RC.confirmCtrlSession rcCtrlClient True + Right (_rcCtrlSession, cp') <- atomically $ takeTMVar r' + threadDelay 250000 + pure cp' + +runHostMulticast :: TVar ChaChaDRG -> TMVar Int -> RCCtrlPairing -> IO (Async RCCtrlPairing) +runHostMulticast drg subscribers cp = async . runRight $ do + (pairing, inv) <- RC.discoverRCCtrl subscribers (cp :| []) + (rcCtrlClient, r) <- RC.connectRCCtrl drg inv (Just pairing) (J.String "app") + Right (_sessId', _tls, r') <- atomically $ takeTMVar r + liftIO $ RC.confirmCtrlSession rcCtrlClient True + Right (_rcCtrlSession, cp') <- atomically $ takeTMVar r' + threadDelay 250000 + pure cp'