diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs index ddc1044e2..845f0b599 100644 --- a/src/Simplex/FileTransfer/Server.hs +++ b/src/Simplex/FileTransfer/Server.hs @@ -264,8 +264,9 @@ verifyXFTPTransmission tAuth authorized fId cmd = where verify = \case Right (fr, k) -> XFTPReqCmd fId fr cmd `verifyWith` k - _ -> dummyVerifyCmd authorized tAuth `seq` VRFailed - req `verifyWith` k = if verifyCmdSignature tAuth authorized k then VRVerified req else VRFailed + _ -> dummyVerifyCmd Nothing authorized tAuth `seq` VRFailed + -- TODO verify with DH authorization + req `verifyWith` k = if verifyCmdSignature Nothing tAuth authorized k then VRVerified req else VRFailed processXFTPRequest :: HTTP2Body -> XFTPRequest -> M (FileResponse, Maybe ServerFile) processXFTPRequest HTTP2Body {bodyPart} = \case diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs index 4fa202542..48be2726e 100644 --- a/src/Simplex/Messaging/Crypto.hs +++ b/src/Simplex/Messaging/Crypto.hs @@ -124,6 +124,7 @@ module Simplex.Messaging.Crypto cbEncryptNoPad, cbEncryptMaxLenBS, cbDecrypt, + cbDecryptNoPad, sbDecrypt_, sbEncrypt_, cbNonce, @@ -1182,7 +1183,7 @@ dh' (PublicKeyX448 k) (PrivateKeyX448 pk _) = DhSecretX448 $ X448.dh k pk cbEncrypt :: DhSecret X25519 -> CbNonce -> ByteString -> Int -> Either CryptoError ByteString cbEncrypt (DhSecretX25519 secret) = sbEncrypt_ secret --- | NaCl @crypto_box@ encrypt with a shared DH secret and 192-bit nonce. +-- | NaCl @crypto_box@ encrypt with a shared DH secret and 192-bit nonce (without padding). cbEncryptNoPad :: DhSecret X25519 -> CbNonce -> ByteString -> ByteString cbEncryptNoPad (DhSecretX25519 secret) (CbNonce nonce) = cryptoBox secret nonce @@ -1207,15 +1208,23 @@ cryptoBox secret nonce s = BA.convert tag <> c cbDecrypt :: DhSecret X25519 -> CbNonce -> ByteString -> Either CryptoError ByteString cbDecrypt (DhSecretX25519 secret) = sbDecrypt_ secret +-- | NaCl @crypto_box@ decrypt with a shared DH secret and 192-bit nonce (without unpadding). +cbDecryptNoPad :: DhSecret X25519 -> CbNonce -> ByteString -> Either CryptoError ByteString +cbDecryptNoPad (DhSecretX25519 secret) = sbDecryptNoPad_ secret + -- | NaCl @secret_box@ decrypt with a symmetric 256-bit key and 192-bit nonce. sbDecrypt :: SbKey -> CbNonce -> ByteString -> Either CryptoError ByteString sbDecrypt (SbKey key) = sbDecrypt_ key -- | NaCl @crypto_box@ decrypt with a shared DH secret and 192-bit nonce. sbDecrypt_ :: ByteArrayAccess key => key -> CbNonce -> ByteString -> Either CryptoError ByteString -sbDecrypt_ secret (CbNonce nonce) packet +sbDecrypt_ secret nonce = unPad <=< sbDecryptNoPad_ secret nonce + +-- | NaCl @crypto_box@ decrypt with a shared DH secret and 192-bit nonce (without unpadding). +sbDecryptNoPad_ :: ByteArrayAccess key => key -> CbNonce -> ByteString -> Either CryptoError ByteString +sbDecryptNoPad_ secret (CbNonce nonce) packet | B.length packet < 16 = Left CBDecryptError - | BA.constEq tag' tag = unPad msg + | BA.constEq tag' tag = Right msg | otherwise = Left CBDecryptError where (tag', c) = B.splitAt 16 packet diff --git a/src/Simplex/Messaging/Crypto/SNTRUP761.hs b/src/Simplex/Messaging/Crypto/SNTRUP761.hs index 99b2771f6..07377e91b 100644 --- a/src/Simplex/Messaging/Crypto/SNTRUP761.hs +++ b/src/Simplex/Messaging/Crypto/SNTRUP761.hs @@ -19,7 +19,7 @@ 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 k) = sbDecrypt_ k +kcbDecrypt (KEMHybridSecret k) nonce = sbDecrypt_ k nonce -- | NaCl @crypto_box@ encrypt with a shared hybrid DH + KEM secret and 192-bit nonce. kcbEncrypt :: KEMHybridSecret -> CbNonce -> ByteString -> Int -> Either CryptoError ByteString diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs index d7f9406df..d0f9b08cd 100644 --- a/src/Simplex/Messaging/Notifications/Server.hs +++ b/src/Simplex/Messaging/Notifications/Server.hs @@ -48,7 +48,7 @@ import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Server import Simplex.Messaging.Server.Stats import qualified Simplex.Messaging.TMap as TM -import Simplex.Messaging.Transport (ATransport (..), THandle (..), TProxy, Transport (..)) +import Simplex.Messaging.Transport (ATransport (..), THandle (..), THandleAuth (..), TProxy, Transport (..)) import Simplex.Messaging.Transport.Server (runTransportServer) import Simplex.Messaging.Util import System.Exit (exitFailure) @@ -352,7 +352,7 @@ clientDisconnected :: NtfServerClient -> IO () clientDisconnected NtfServerClient {connected} = atomically $ writeTVar connected False receive :: Transport c => THandle c -> NtfServerClient -> M () -receive th NtfServerClient {rcvQ, sndQ, rcvActiveAt} = forever $ do +receive th@THandle {thAuth} NtfServerClient {rcvQ, sndQ, rcvActiveAt} = forever $ do ts <- liftIO $ tGet th forM_ ts $ \t@(_, _, (corrId, entId, cmdOrError)) -> do atomically . writeTVar rcvActiveAt =<< liftIO getSystemTime @@ -360,7 +360,7 @@ receive th NtfServerClient {rcvQ, sndQ, rcvActiveAt} = forever $ do case cmdOrError of Left e -> write sndQ (corrId, entId, NRErr e) Right cmd -> - verifyNtfTransmission t cmd >>= \case + verifyNtfTransmission ((,C.cbNonce (SMP.bs corrId)) <$> thAuth) t cmd >>= \case VRVerified req -> write rcvQ req VRFailed -> write sndQ (corrId, entId, NRErr AUTH) where @@ -377,14 +377,14 @@ send h@THandle {thVersion = v} NtfServerClient {sndQ, sessionId, sndActiveAt} = data VerificationResult = VRVerified NtfRequest | VRFailed -verifyNtfTransmission :: SignedTransmission ErrorType NtfCmd -> NtfCmd -> M VerificationResult -verifyNtfTransmission (tAuth, authorized, (corrId, entId, _)) cmd = do +verifyNtfTransmission :: Maybe (THandleAuth, C.CbNonce) -> SignedTransmission ErrorType NtfCmd -> NtfCmd -> M VerificationResult +verifyNtfTransmission auth_ (tAuth, authorized, (corrId, entId, _)) cmd = do st <- asks store case cmd of NtfCmd SToken c@(TNEW tkn@(NewNtfTkn _ k _)) -> do r_ <- atomically $ getNtfTokenRegistration st tkn pure $ - if verifyCmdSignature tAuth authorized k + if verifyCmdSignature auth_ tAuth authorized k then case r_ of Just t@NtfTknData {tknVerifyKey} | k == tknVerifyKey -> verifiedTknCmd t c @@ -405,7 +405,7 @@ verifyNtfTransmission (tAuth, authorized, (corrId, entId, _)) cmd = do then do t_ <- atomically $ getActiveNtfToken st subTknId verifyToken' t_ $ verifiedSubCmd s c - else pure $ dummyVerifyCmd authorized tAuth `seq` VRFailed + else pure $ dummyVerifyCmd auth_ authorized tAuth `seq` VRFailed NtfCmd SSubscription PING -> pure $ VRVerified $ NtfReqPing corrId entId NtfCmd SSubscription c -> do s_ <- atomically $ getNtfSubscription st entId @@ -413,7 +413,7 @@ verifyNtfTransmission (tAuth, authorized, (corrId, entId, _)) cmd = do Just s@NtfSubData {tokenId = subTknId} -> do t_ <- atomically $ getActiveNtfToken st subTknId verifyToken' t_ $ verifiedSubCmd s c - _ -> pure $ dummyVerifyCmd authorized tAuth `seq` VRFailed + _ -> pure $ dummyVerifyCmd auth_ authorized tAuth `seq` VRFailed where verifiedTknCmd t c = VRVerified (NtfReqCmd SToken (NtfTkn t) (corrId, entId, c)) verifiedSubCmd s c = VRVerified (NtfReqCmd SSubscription (NtfSub s) (corrId, entId, c)) @@ -421,10 +421,10 @@ verifyNtfTransmission (tAuth, authorized, (corrId, entId, _)) cmd = do verifyToken t_ positiveVerificationResult = pure $ case t_ of Just t@NtfTknData {tknVerifyKey} -> - if verifyCmdSignature tAuth authorized tknVerifyKey + if verifyCmdSignature auth_ tAuth authorized tknVerifyKey then positiveVerificationResult t else VRFailed - _ -> dummyVerifyCmd authorized tAuth `seq` VRFailed + _ -> dummyVerifyCmd auth_ authorized tAuth `seq` VRFailed verifyToken' :: Maybe NtfTknData -> VerificationResult -> M VerificationResult verifyToken' t_ = verifyToken t_ . const diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 7b766cf5d..7470d6fe2 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -417,7 +417,7 @@ cancelSub sub = _ -> return () receive :: Transport c => THandle c -> Client -> M () -receive th Client {rcvQ, sndQ, rcvActiveAt, sessionId} = do +receive th@THandle {thAuth} Client {rcvQ, sndQ, rcvActiveAt, sessionId} = do labelMyThread . B.unpack $ "client $" <> encode sessionId <> " receive" forever $ do ts <- L.toList <$> liftIO (tGet th) @@ -427,10 +427,10 @@ receive th Client {rcvQ, sndQ, rcvActiveAt, sessionId} = do write rcvQ $ snd as where cmdAction :: SignedTransmission ErrorType Cmd -> M (Either (Transmission BrokerMsg) (Maybe QueueRec, Transmission Cmd)) - cmdAction (auth, authorized, (corrId, queueId, cmdOrError)) = + cmdAction (tAuth, authorized, (corrId, queueId, cmdOrError)) = case cmdOrError of Left e -> pure $ Left (corrId, queueId, ERR e) - Right cmd -> verified <$> verifyTransmission auth authorized queueId cmd + Right cmd -> verified <$> verifyTransmission ((,C.cbNonce (bs corrId)) <$> thAuth) tAuth authorized queueId cmd where verified = \case VRVerified qr -> Right (qr, (corrId, queueId, cmd)) @@ -467,11 +467,11 @@ disconnectTransport THandle {connection, sessionId} rcvActiveAt sndActiveAt expC data VerificationResult = VRVerified (Maybe QueueRec) | VRFailed -verifyTransmission :: TransmissionAuth -> ByteString -> QueueId -> Cmd -> M VerificationResult -verifyTransmission auth authorized queueId cmd = +verifyTransmission :: Maybe (THandleAuth, C.CbNonce) -> TransmissionAuth -> ByteString -> QueueId -> Cmd -> M VerificationResult +verifyTransmission auth_ tAuth authorized queueId cmd = case cmd of - Cmd SRecipient (NEW k _ _ _) -> pure $ Nothing `verified` verifyCmdSignature auth authorized k - Cmd SRecipient _ -> verifyCmd SRecipient $ verifyCmdSignature auth authorized . recipientKey + Cmd SRecipient (NEW k _ _ _) -> pure $ Nothing `verified` verifyCmdSignature auth_ tAuth authorized k + Cmd SRecipient _ -> verifyCmd SRecipient $ verifyCmdSignature auth_ tAuth authorized . recipientKey Cmd SSender SEND {} -> verifyCmd SSender $ verifyMaybe . senderKey Cmd SSender PING -> pure $ VRVerified Nothing Cmd SNotifier NSUB -> verifyCmd SNotifier $ verifyMaybe . fmap notifierKey . notifier @@ -482,28 +482,41 @@ verifyTransmission auth authorized queueId cmd = q_ <- atomically $ getQueue st party queueId pure $ case q_ of Right q -> Just q `verified` f q - _ -> dummyVerifyCmd authorized auth `seq` VRFailed + _ -> dummyVerifyCmd auth_ authorized tAuth `seq` VRFailed verifyMaybe :: Maybe C.APublicAuthKey -> Bool - verifyMaybe = maybe (isAuthNone auth) $ verifyCmdSignature auth authorized + verifyMaybe = maybe (isAuthNone tAuth) $ verifyCmdSignature auth_ tAuth authorized verified q cond = if cond then VRVerified q else VRFailed -verifyCmdSignature :: TransmissionAuth -> ByteString -> C.APublicAuthKey -> Bool -verifyCmdSignature auth authorized key = case auth of +verifyCmdSignature :: Maybe (THandleAuth, C.CbNonce) -> TransmissionAuth -> ByteString -> C.APublicAuthKey -> Bool +verifyCmdSignature auth_ tAuth authorized key = case tAuth of TAuthNone -> False TAuthSignature sig -> verify key sig - TAuthEncHash _ -> False + TAuthEncHash s -> authorize key s where verify :: C.APublicAuthKey -> C.ASignature -> Bool verify (C.APublicAuthKey a k) sig@(C.ASignature a' s) = case testEquality a a' of Just Refl | C.signatureSize k == C.signatureSize s -> C.verify' k s authorized - _ -> dummyVerifyCmd authorized (TAuthSignature sig) `seq` False + _ -> dummyVerifyCmd auth_ authorized (TAuthSignature sig) `seq` False + authorize :: C.APublicAuthKey -> ByteString -> Bool + authorize (C.APublicAuthKey a k) s = + case a of + C.SX25519 -> authorizeCmd auth_ k s authorized + _ -> dummyVerifyCmd auth_ authorized (TAuthEncHash s) `seq` False -dummyVerifyCmd :: ByteString -> TransmissionAuth -> Bool -dummyVerifyCmd authorized = \case +authorizeCmd :: Maybe (THandleAuth, C.CbNonce) -> C.PublicKeyX25519 -> ByteString -> ByteString -> Bool +authorizeCmd auth_ k s authorized = case auth_ of + Just (THandleAuth {privKey}, nonce) -> cbAuthorize k privKey nonce s authorized + Nothing -> False + +cbAuthorize :: C.PublicKeyX25519 -> C.PrivateKeyX25519 -> C.CbNonce -> ByteString -> ByteString -> Bool +cbAuthorize k pk nonce s authorized = C.cbDecryptNoPad (C.dh' k pk) nonce s == Right (C.sha512Hash authorized) + +dummyVerifyCmd :: Maybe (THandleAuth, C.CbNonce) -> ByteString -> TransmissionAuth -> Bool +dummyVerifyCmd auth_ authorized = \case TAuthNone -> False TAuthSignature (C.ASignature a s) -> C.verify' (dummyPublicKey a) s authorized - TAuthEncHash _ -> False + TAuthEncHash s -> authorizeCmd auth_ dummyKeyX25519 s authorized -- These dummy keys are used with `dummyVerify` function to mitigate timing attacks -- by having the same time of the response whether a queue exists or nor, for all valid key/signature sizes @@ -521,10 +534,10 @@ dummyKeyEd448 :: C.PublicKey 'C.Ed448 dummyKeyEd448 = "MEMwBQYDK2VxAzoA6ibQc9XpkSLtwrf7PLvp81qW/etiumckVFImCMRdftcG/XopbOSaq9qyLhrgJWKOLyNrQPNVvpMA" dummyKeyX25519 :: C.PublicKey 'C.X25519 -dummyKeyX25519 = "" +dummyKeyX25519 = "MCowBQYDK2VuAyEA4JGSMYht18H4mas_jHeBwfcM7jLwNYJNOAhi2_g4RXg=" dummyKeyX448 :: C.PublicKey 'C.X448 -dummyKeyX448 = "" +dummyKeyX448 = "MEIwBQYDK2VvAzkAs6Z2fErHib1C2QfKcrDeNlfi8Xtb1UTWF-slWubEmfbk0M0N-qh9A2JBNZebrVUMW4--skAjJ3I=" client :: forall m. (MonadUnliftIO m, MonadReader Env m) => Client -> Server -> m () client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ, sessionId} Server {subscribedQ, ntfSubscribedQ, notifiers} = do diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs index 243fba7f1..99b5e4eed 100644 --- a/src/Simplex/Messaging/Transport.hs +++ b/src/Simplex/Messaging/Transport.hs @@ -279,6 +279,7 @@ data THandle c = THandle data THandleAuth = THandleAuth { peerPubKey :: C.PublicKeyX25519, -- used only in the client to combine with per-queue key + privKey :: C.PrivateKeyX25519, -- used to combine with peer's per-queue key (currently only in the server) dhSecret :: C.DhSecretX25519 -- used by both parties to encrypt entity IDs in for version >= 7 } @@ -415,9 +416,9 @@ smpClientHandshake c (k, pk) keyHash smpVRange = do Nothing -> throwE $ TEHandshake VERSION smpThHandle :: forall c. THandle c -> Version -> C.PrivateKeyX25519 -> Maybe C.PublicKeyX25519 -> THandle c -smpThHandle th v pk k_ = +smpThHandle th v pk k_ = -- TODO drop SMP v6: make thAuth non-optional - let thAuth = (\k -> THandleAuth {peerPubKey = k, dhSecret = C.dh' k pk}) <$> k_ + let thAuth = (\k -> THandleAuth {peerPubKey = k, privKey = pk, dhSecret = C.dh' k pk}) <$> k_ in (th :: THandle c) {thVersion = v, thAuth, batch = v >= batchCmdsSMPVersion} sendHandshake :: (Transport c, Encoding smp) => THandle c -> smp -> ExceptT TransportError IO () diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index adc41b881..2112f9e59 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -49,7 +49,7 @@ import Data.Time.Clock.System (SystemTime (..), getSystemTime) import Data.Type.Equality import qualified Database.SQLite.Simple as SQL import SMPAgentClient -import SMPClient (cfg, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn) +import SMPClient (cfg, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerV7, withSmpServerConfigOn, withSmpServerOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn) import Simplex.Messaging.Agent import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..)) import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers (..), createAgentStore) @@ -63,7 +63,7 @@ import Simplex.Messaging.Protocol (BasicAuth, ErrorType (..), MsgBody, ProtocolS import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Server.Env.STM (ServerConfig (..)) import Simplex.Messaging.Server.Expiration -import Simplex.Messaging.Transport (ATransport (..)) +import Simplex.Messaging.Transport (ATransport (..), authEncryptCmdsSMPVersion) import Simplex.Messaging.Version import System.Directory (copyFile, renameFile) import Test.Hspec @@ -129,6 +129,9 @@ smpCfgVPrev = (smpCfg agentCfg) {serverVRange = prevRange $ serverVRange $ smpCf smpCfgV4 :: ProtocolClientConfig smpCfgV4 = (smpCfg agentCfg) {serverVRange = mkVersionRange 4 4} +smpCfgV7 :: ProtocolClientConfig +smpCfgV7 = (smpCfg agentCfg) {serverVRange = mkVersionRange 4 authEncryptCmdsSMPVersion} + agentCfgVPrev :: AgentConfig agentCfgVPrev = agentCfg @@ -138,6 +141,13 @@ agentCfgVPrev = smpCfg = smpCfgVPrev } +agentCfgV7 :: AgentConfig +agentCfgV7 = + agentCfg + { cmdAuthAlg = C.AuthAlg C.SX25519, + smpCfg = smpCfgV7 + } + agentCfgV1 :: AgentConfig agentCfgV1 = agentCfg @@ -363,6 +373,9 @@ canCreateQueue allowNew (srvAuth, srvVersion) (clntAuth, clntVersion) = testMatrix2 :: ATransport -> (AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec testMatrix2 t runTest = do + it "v7" $ withSmpServerV7 t $ runTestCfg2 agentCfgV7 agentCfgV7 3 runTest + it "v7 to current" $ withSmpServerV7 t $ runTestCfg2 agentCfgV7 agentCfg 3 runTest + it "current to v7" $ withSmpServerV7 t $ runTestCfg2 agentCfg agentCfgV7 3 runTest it "current" $ withSmpServer t $ runTestCfg2 agentCfg agentCfg 3 runTest it "prev" $ withSmpServer t $ runTestCfg2 agentCfgVPrev agentCfgVPrev 3 runTest it "prev to current" $ withSmpServer t $ runTestCfg2 agentCfgVPrev agentCfg 3 runTest diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index 2d0dc9260..0ccf8d543 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -26,6 +26,7 @@ import Simplex.Messaging.Server.Env.STM import Simplex.Messaging.Transport import Simplex.Messaging.Transport.Client import Simplex.Messaging.Transport.Server +import Simplex.Messaging.Version (mkVersionRange) import System.Environment (lookupEnv) import System.Info (os) import Test.Hspec @@ -104,6 +105,9 @@ cfg = controlPort = Nothing } +cfgV7 :: ServerConfig +cfgV7 = cfg {smpServerVRange = mkVersionRange 4 authEncryptCmdsSMPVersion} + withSmpServerStoreMsgLogOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a withSmpServerStoreMsgLogOn t = withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile, serverStatsBackupFile = Just testServerStatsBackupFile} @@ -138,6 +142,9 @@ withSmpServerOn t port' = withSmpServerThreadOn t port' . const withSmpServer :: HasCallStack => ATransport -> IO a -> IO a withSmpServer t = withSmpServerOn t testPort +withSmpServerV7 :: HasCallStack => ATransport -> IO a -> IO a +withSmpServerV7 t = withSmpServerConfigOn t cfgV7 testPort . const + runSmpTest :: forall c a. (HasCallStack, Transport c) => (HasCallStack => THandle c -> IO a) -> IO a runSmpTest test = withSmpServer (transport @c) $ testSMPClient test