diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 391f49405..98eb84da1 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -1227,7 +1227,7 @@ registerNtfToken' c suppliedDeviceToken suppliedNtfMode = (Nothing, Just NTARegister) -> do when (savedDeviceToken /= suppliedDeviceToken) $ withStore' c $ \db -> updateDeviceToken db tkn suppliedDeviceToken registerToken tkn $> NTRegistered - -- TODO minimal time before repeat registration + -- possible improvement: add minimal time before repeat registration (Just tknId, Nothing) | savedDeviceToken == suppliedDeviceToken -> when (ntfTknStatus == NTRegistered) (registerToken tkn) $> NTRegistered @@ -1245,8 +1245,8 @@ registerNtfToken' c suppliedDeviceToken suppliedNtfMode = agentNtfEnableCron c tknId tkn cron when (suppliedNtfMode == NMInstant) $ initializeNtfSubs c when (suppliedNtfMode == NMPeriodic && savedNtfMode == NMInstant) $ deleteNtfSubs c NSCDelete - pure ntfTknStatus -- TODO - -- agentNtfCheckToken c tknId tkn >>= \case + -- possible improvement: get updated token status from the server, or maybe TCRON could return the current status + pure ntfTknStatus | otherwise -> replaceToken tknId (Just tknId, Just NTADelete) -> do agentNtfDeleteToken c tknId tkn @@ -1413,11 +1413,6 @@ sendNtfConnCommands c cmd = do _ -> atomically $ writeTBQueue (subQ c) ("", connId, ERR $ INTERNAL "no connection data") --- TODO --- There should probably be another function to cancel all subscriptions that would flush the queue first, --- so that supervisor stops processing pending commands? --- It is an optimization, but I am thinking how it would behave if a user were to flip on/off quickly several times. - setNtfServers' :: AgentMonad m => AgentClient -> [NtfServer] -> m () setNtfServers' c = atomically . writeTVar (ntfServers c) diff --git a/src/Simplex/Messaging/Agent/Env/SQLite.hs b/src/Simplex/Messaging/Agent/Env/SQLite.hs index 920a9b4dd..60afe9bcf 100644 --- a/src/Simplex/Messaging/Agent/Env/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Env/SQLite.hs @@ -118,7 +118,7 @@ defaultMessageRetryInterval = maxInterval = 60_000000 }, riSlow = - -- TODO: these timeouts can be increased once most clients are updates + -- TODO: these timeouts can be increased in v4.6 once most clients are updated -- to resume sending on QCONT messages. -- After that local message expiration period should be also increased. RetryInterval diff --git a/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs b/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs index a76787db2..5d6af212b 100644 --- a/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs +++ b/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs @@ -191,7 +191,7 @@ runNtfWorker c srv doWork = do case clientNtfCreds of Just ClientNtfCreds {ntfPrivateKey, notifierId} -> do nSubId <- agentNtfCreateSubscription c tknId tkn (SMPQueueNtf smpServer notifierId) ntfPrivateKey - -- TODO smaller retry until Active, less frequently (daily?) once Active + -- possible improvement: smaller retry until Active, less frequently (daily?) once Active let actionTs' = addUTCTime 30 ts withStore' c $ \db -> updateNtfSubscription db sub {ntfSubId = Just nSubId, ntfSubStatus = NASCreated NSNew} (NtfSubNTFAction NSACheck) actionTs' diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index 783cde141..8f9c833d1 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -1130,7 +1130,6 @@ instance ToJSON BrokerErrorType where toEncoding = J.genericToEncoding $ sumTypeJSON id -- | Errors of another SMP agent. --- TODO encode/decode without A prefix data SMPAgentError = -- | client or agent message that failed to parse A_MESSAGE diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index 370965c7f..611702b69 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} @@ -94,7 +93,7 @@ import Simplex.Messaging.Transport import Simplex.Messaging.Transport.Client (SocksProxy, TransportClientConfig (..), TransportHost (..), runTransportClient) import Simplex.Messaging.Transport.KeepAlive import Simplex.Messaging.Transport.WebSockets (WS) -import Simplex.Messaging.Util (bshow, liftError, raceAny_) +import Simplex.Messaging.Util (bshow, raceAny_) import Simplex.Messaging.Version import System.Timeout (timeout) @@ -541,7 +540,7 @@ sendProtocolCommand c@ProtocolClient {client_ = PClient {sndQ, tcpTimeout}} pKey mkTransmission :: forall msg. ProtocolEncoding (ProtoCommand msg) => ProtocolClient msg -> ClientCommand msg -> ExceptT ProtocolClientError IO (SentRawTransmission, TMVar (Response msg)) mkTransmission ProtocolClient {sessionId, thVersion, client_ = PClient {clientCorrId, sentCommands}} (pKey, qId, cmd) = do corrId <- liftIO $ atomically getNextCorrId - t <- signTransmission $ encodeTransmission thVersion sessionId (corrId, qId, cmd) + let t = signTransmission $ encodeTransmission thVersion sessionId (corrId, qId, cmd) r <- liftIO . atomically $ mkRequest corrId pure (t, r) where @@ -549,12 +548,8 @@ mkTransmission ProtocolClient {sessionId, thVersion, client_ = PClient {clientCo getNextCorrId = do i <- stateTVar clientCorrId $ \i -> (i, i + 1) pure . CorrId $ bshow i - signTransmission :: ByteString -> ExceptT ProtocolClientError IO SentRawTransmission - signTransmission t = case pKey of - Nothing -> pure (Nothing, t) - Just pk -> do - sig <- liftError PCESignatureError $ C.sign pk t - return (Just sig, t) + signTransmission :: ByteString -> SentRawTransmission + signTransmission t = ((`C.sign` t) <$> pKey, t) mkRequest :: CorrId -> STM (TMVar (Response msg)) mkRequest corrId = do r <- newEmptyTMVar diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs index c5d727aad..bfbd6b584 100644 --- a/src/Simplex/Messaging/Crypto.hs +++ b/src/Simplex/Messaging/Crypto.hs @@ -67,7 +67,9 @@ module Simplex.Messaging.Crypto -- * key encoding/decoding encodePubKey, + decodePubKey, encodePrivKey, + decodePrivKey, pubKeyBytes, -- * sign/verify @@ -888,12 +890,12 @@ cryptoFailable = liftEither . first AESCipherError . CE.eitherCryptoError -- | Message signing. -- -- Used by SMP clients to sign SMP commands and by SMP agents to sign messages. -sign' :: SignatureAlgorithm a => PrivateKey a -> ByteString -> ExceptT CryptoError IO (Signature a) -sign' (PrivateKeyEd25519 pk k) msg = pure . SignatureEd25519 $ Ed25519.sign pk k msg -sign' (PrivateKeyEd448 pk k) msg = pure . SignatureEd448 $ Ed448.sign pk k msg +sign' :: SignatureAlgorithm a => PrivateKey a -> ByteString -> Signature a +sign' (PrivateKeyEd25519 pk k) msg = SignatureEd25519 $ Ed25519.sign pk k msg +sign' (PrivateKeyEd448 pk k) msg = SignatureEd448 $ Ed448.sign pk k msg -sign :: APrivateSignKey -> ByteString -> ExceptT CryptoError IO ASignature -sign (APrivateSignKey a k) = fmap (ASignature a) . sign' k +sign :: APrivateSignKey -> ByteString -> ASignature +sign (APrivateSignKey a k) = ASignature a . sign' k -- | Signature verification. -- diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs index 7afb3c407..43b0d33de 100644 --- a/src/Simplex/Messaging/Notifications/Server.hs +++ b/src/Simplex/Messaging/Notifications/Server.hs @@ -512,7 +512,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu (corrId,subId,) <$> case cmd of SNEW (NewNtfSub _ _ notifierKey) -> do logDebug "SNEW - existing subscription" - -- TODO retry if subscription failed, if pending or AUTH do nothing + -- possible improvement: retry if subscription failed, if pending or AUTH do nothing pure $ if notifierKey == registeredNKey then NRSubId subId diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index e28ac1b6c..645a26e3a 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -888,7 +888,7 @@ data ErrorType | -- | internal server error INTERNAL | -- | used internally, never returned by the server (to be removed) - DUPLICATE_ -- TODO remove, not part of SMP protocol + DUPLICATE_ -- not part of SMP protocol, used internally deriving (Eq, Generic, Read, Show) instance ToJSON ErrorType where diff --git a/src/Simplex/Messaging/Server/MsgStore.hs b/src/Simplex/Messaging/Server/MsgStore.hs index 565c89e1e..37f5822d3 100644 --- a/src/Simplex/Messaging/Server/MsgStore.hs +++ b/src/Simplex/Messaging/Server/MsgStore.hs @@ -6,7 +6,6 @@ module Simplex.Messaging.Server.MsgStore where import Control.Applicative ((<|>)) import Data.Int (Int64) -import Numeric.Natural import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol (Message (..), MsgId, RcvMessage (..), RecipientId) diff --git a/tests/CoreTests/CryptoTests.hs b/tests/CoreTests/CryptoTests.hs index 25975dc6f..e35b109ff 100644 --- a/tests/CoreTests/CryptoTests.hs +++ b/tests/CoreTests/CryptoTests.hs @@ -1,18 +1,20 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module CoreTests.CryptoTests (cryptoTests) where +import qualified Data.ByteString.Char8 as B +import Data.Either (isRight) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) import qualified Simplex.Messaging.Crypto as C import Test.Hspec import Test.Hspec.QuickCheck (modifyMaxSuccess) import Test.QuickCheck -import qualified Data.Text as T -import qualified Data.ByteString.Char8 as B -import Data.Text.Encoding (encodeUtf8) cryptoTests :: Spec -cryptoTests = modifyMaxSuccess (const 10000) $ do - describe "padding / unpadding" $ do +cryptoTests = do + modifyMaxSuccess (const 10000) . describe "padding / unpadding" $ do it "should pad / unpad string" . property $ \(s, paddedLen) -> let b = encodeUtf8 $ T.pack s len = B.length b @@ -34,3 +36,37 @@ cryptoTests = modifyMaxSuccess (const 10000) $ do it "unpad should fail on shorter string" $ do C.unPad "\000\003abc" `shouldBe` Right "abc" C.unPad "\000\003ab" `shouldBe` Left C.CryptoInvalidMsgError + describe "Ed signatures" $ do + describe "Ed25519" $ testSignature C.SEd25519 + describe "Ed448" $ testSignature C.SEd448 + describe "DH X25519 + cryptobox" $ + testDHCryptoBox + describe "X509 key encoding" $ do + describe "Ed25519" $ testEncoding C.SEd25519 + describe "Ed448" $ testEncoding C.SEd448 + describe "X25519" $ testEncoding C.SX25519 + describe "X448" $ testEncoding C.SX448 + +testSignature :: (C.AlgorithmI a, C.SignatureAlgorithm a) => C.SAlgorithm a -> Spec +testSignature alg = it "should sign / verify string" . ioProperty $ do + (k, pk) <- C.generateSignatureKeyPair alg + pure $ \s -> let b = encodeUtf8 $ T.pack s in C.verify k (C.sign pk b) b + +testDHCryptoBox :: Spec +testDHCryptoBox = it "should encrypt / decrypt string" . ioProperty $ do + (sk, spk) <- C.generateKeyPair' + (rk, rpk) <- C.generateKeyPair' + nonce <- C.randomCbNonce + pure $ \(s, pad) -> + let b = encodeUtf8 $ T.pack s + paddedLen = B.length b + abs pad + 2 + cipher = C.cbEncrypt (C.dh' rk spk) nonce b paddedLen + plain = C.cbDecrypt (C.dh' sk rpk) nonce =<< cipher + in isRight cipher && cipher /= plain && Right b == plain + +testEncoding :: (C.AlgorithmI a) => C.SAlgorithm a -> Spec +testEncoding alg = it "should encode / decode key" . ioProperty $ do + (k, pk) <- C.generateKeyPair alg + pure $ \(_ :: Int) -> + C.decodePubKey (C.encodePubKey k) == Right k + && C.decodePrivKey (C.encodePrivKey pk) == Right pk diff --git a/tests/NtfServerTests.hs b/tests/NtfServerTests.hs index 42c439987..7601652d1 100644 --- a/tests/NtfServerTests.hs +++ b/tests/NtfServerTests.hs @@ -10,7 +10,6 @@ module NtfServerTests where import Control.Concurrent (threadDelay) -import Control.Monad.Except (runExceptT) import qualified Data.Aeson as J import qualified Data.Aeson.Types as JT import Data.Bifunctor (first) @@ -77,8 +76,7 @@ sendRecvNtf h@THandle {thVersion, sessionId} (sgn, corrId, qId, cmd) = do signSendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandle c -> C.APrivateSignKey -> (ByteString, ByteString, NtfCommand e) -> IO (SignedTransmission NtfResponse) signSendRecvNtf h@THandle {thVersion, sessionId} pk (corrId, qId, cmd) = do let t = encodeTransmission thVersion sessionId (CorrId corrId, qId, cmd) - Right sig <- runExceptT $ C.sign pk t - Right () <- tPut1 h (Just sig, t) + Right () <- tPut1 h (Just $ C.sign pk t, t) tGet1 h (.->) :: J.Value -> J.Key -> Either String ByteString diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index 561da754e..cf3208775 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -14,7 +14,7 @@ module ServerTests where import Control.Concurrent (ThreadId, killThread, threadDelay) import Control.Concurrent.STM import Control.Exception (SomeException, try) -import Control.Monad.Except (forM, forM_, runExceptT) +import Control.Monad.Except (forM, forM_) import Control.Monad.IO.Class import Data.Bifunctor (first) import Data.ByteString.Base64 @@ -78,8 +78,7 @@ sendRecv h@THandle {thVersion, sessionId} (sgn, corrId, qId, cmd) = do signSendRecv :: forall c p. (Transport c, PartyI p) => THandle c -> C.APrivateSignKey -> (ByteString, ByteString, Command p) -> IO (SignedTransmission BrokerMsg) signSendRecv h@THandle {thVersion, sessionId} pk (corrId, qId, cmd) = do let t = encodeTransmission thVersion sessionId (CorrId corrId, qId, cmd) - Right sig <- runExceptT $ C.sign pk t - Right () <- tPut1 h (Just sig, t) + Right () <- tPut1 h (Just $ C.sign pk t, t) tGet1 h tPut1 :: Transport c => THandle c -> SentRawTransmission -> IO (Either TransportError ())