From 517933d1894c3ce3fbefb60572558a970f09afb6 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Thu, 29 Aug 2024 14:37:45 +0100 Subject: [PATCH] put DRG state to IORef, split STM transaction of sending notification (#1288) * put DRG state to IORef, split STM transaction of sending notification * remove comment * remove comment * add comment * revert version --- src/Simplex/FileTransfer/Agent.hs | 12 +- src/Simplex/FileTransfer/Client.hs | 4 +- src/Simplex/FileTransfer/Client/Main.hs | 16 +- src/Simplex/FileTransfer/Server.hs | 12 +- src/Simplex/FileTransfer/Server/Env.hs | 3 +- src/Simplex/Messaging/Agent.hs | 19 +- src/Simplex/Messaging/Agent/Client.hs | 35 +-- src/Simplex/Messaging/Agent/Env/SQLite.hs | 3 +- .../Messaging/Agent/NtfSubSupervisor.hs | 4 +- src/Simplex/Messaging/Agent/Store/SQLite.hs | 26 +- src/Simplex/Messaging/Client.hs | 21 +- src/Simplex/Messaging/Client/Agent.hs | 5 +- src/Simplex/Messaging/Crypto.hs | 36 +-- src/Simplex/Messaging/Crypto/File.hs | 3 +- src/Simplex/Messaging/Crypto/Ratchet.hs | 16 +- .../Messaging/Crypto/SNTRUP761/Bindings.hs | 6 +- .../Crypto/SNTRUP761/Bindings/RNG.hs | 7 +- src/Simplex/Messaging/Notifications/Server.hs | 6 +- .../Messaging/Notifications/Server/Env.hs | 5 +- .../Notifications/Server/Push/APNS.hs | 5 +- src/Simplex/Messaging/Server.hs | 61 ++--- src/Simplex/Messaging/Server/Env/STM.hs | 4 +- src/Simplex/Messaging/Server/Main.hs | 3 +- .../Messaging/Transport/Credentials.hs | 6 +- src/Simplex/Messaging/Util.hs | 6 + src/Simplex/RemoteControl/Client.hs | 36 +-- tests/AgentTests/DoubleRatchetTests.hs | 35 +-- tests/AgentTests/FunctionalAPITests.hs | 2 +- tests/AgentTests/SQLiteTests.hs | 4 +- tests/CoreTests/BatchingTests.hs | 50 ++-- tests/CoreTests/CryptoFileTests.hs | 26 +- tests/CoreTests/CryptoTests.hs | 37 ++- tests/NtfServerTests.hs | 10 +- tests/RemoteControl.hs | 6 +- tests/SMPProxyTests.hs | 8 +- tests/ServerTests.hs | 80 +++--- tests/XFTPAgent.hs | 4 +- tests/XFTPServerTests.hs | 240 +++++++++--------- 38 files changed, 443 insertions(+), 419 deletions(-) diff --git a/src/Simplex/FileTransfer/Agent.hs b/src/Simplex/FileTransfer/Agent.hs index d6ee75ae9..5292f13b4 100644 --- a/src/Simplex/FileTransfer/Agent.hs +++ b/src/Simplex/FileTransfer/Agent.hs @@ -145,7 +145,7 @@ xftpReceiveFile' c userId (ValidFileDescription fd@FileDescription {chunks, redi relSavePathRedirect = relPrefixPath "xftp.redirect-decrypted" lift $ createDirectory =<< toFSFilePath relTmpPathRedirect lift $ createEmptyFile =<< toFSFilePath relSavePathRedirect - cfArgsRedirect <- atomically $ CF.randomArgs g + cfArgsRedirect <- liftIO $ CF.randomArgs g let saveFileRedirect = CryptoFile relSavePathRedirect $ Just cfArgsRedirect -- create download tasks withStore c $ \db -> createRcvFileRedirect db g userId fd relPrefixPath relTmpPathRedirect saveFileRedirect relTmpPath saveFile approvedRelays @@ -355,8 +355,8 @@ xftpSendFile' c userId file numRecipients = do prefixPath <- lift $ getPrefixPath "snd.xftp" createDirectory prefixPath let relPrefixPath = takeFileName prefixPath - key <- atomically $ C.randomSbKey g - nonce <- atomically $ C.randomCbNonce g + key <- liftIO $ C.randomSbKey g + nonce <- liftIO $ C.randomCbNonce g -- saving absolute filePath will not allow to restore file encryption after app update, but it's a short window fId <- withStore c $ \db -> createSndFile db g userId file numRecipients relPrefixPath key nonce Nothing lift . void $ getXFTPSndWorker True c Nothing @@ -369,11 +369,11 @@ xftpSendDescription' c userId (ValidFileDescription fdDirect@FileDescription {si createDirectory prefixPath let relPrefixPath = takeFileName prefixPath let directYaml = prefixPath "direct.yaml" - cfArgs <- atomically $ CF.randomArgs g + cfArgs <- liftIO $ CF.randomArgs g let file = CryptoFile directYaml (Just cfArgs) liftError (FILE . FILE_IO . show) $ CF.writeFile file (LB.fromStrict $ strEncode fdDirect) - key <- atomically $ C.randomSbKey g - nonce <- atomically $ C.randomCbNonce g + key <- liftIO $ C.randomSbKey g + nonce <- liftIO $ C.randomCbNonce g fId <- withStore c $ \db -> createSndFile db g userId file numRecipients relPrefixPath key nonce $ Just RedirectFileInfo {size, digest} lift . void $ getXFTPSndWorker True c Nothing pure fId diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs index 1404fd434..0df53918b 100644 --- a/src/Simplex/FileTransfer/Client.hs +++ b/src/Simplex/FileTransfer/Client.hs @@ -236,9 +236,9 @@ uploadXFTPChunk :: XFTPClient -> C.APrivateAuthKey -> XFTPFileId -> XFTPChunkSpe uploadXFTPChunk c spKey fId chunkSpec = sendXFTPCommand c spKey fId FPUT (Just chunkSpec) >>= okResponse -downloadXFTPChunk :: TVar ChaChaDRG -> XFTPClient -> C.APrivateAuthKey -> XFTPFileId -> XFTPRcvChunkSpec -> ExceptT XFTPClientError IO () +downloadXFTPChunk :: IORef ChaChaDRG -> XFTPClient -> C.APrivateAuthKey -> XFTPFileId -> XFTPRcvChunkSpec -> ExceptT XFTPClientError IO () downloadXFTPChunk g c@XFTPClient {config} rpKey fId chunkSpec@XFTPRcvChunkSpec {filePath, chunkSize} = do - (rDhKey, rpDhKey) <- atomically $ C.generateKeyPair g + (rDhKey, rpDhKey) <- liftIO $ C.generateKeyPair g sendXFTPCommand c rpKey fId (FGET rDhKey) Nothing >>= \case (FRFile sDhKey cbNonce, HTTP2Body {bodyHead = _bg, bodySize = _bs, bodyPart}) -> case bodyPart of -- TODO atm bodySize is set to 0, so chunkSize will be incorrect - validate once set diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs index 079392a1b..df59654f0 100644 --- a/src/Simplex/FileTransfer/Client/Main.hs +++ b/src/Simplex/FileTransfer/Client/Main.hs @@ -290,13 +290,13 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re putStrLn "Pass file descriptions to the recipient(s):" forM_ fdRcvPaths putStrLn where - encryptFileForUpload :: TVar ChaChaDRG -> String -> ExceptT CLIError IO (FilePath, FileDescription 'FRecipient, FileDescription 'FSender, [XFTPChunkSpec], Int64) + encryptFileForUpload :: IORef ChaChaDRG -> String -> ExceptT CLIError IO (FilePath, FileDescription 'FRecipient, FileDescription 'FSender, [XFTPChunkSpec], Int64) encryptFileForUpload g fileName = do fileSize <- fromInteger <$> getFileSize filePath when (fileSize > maxFileSize) $ throwE $ CLIError $ "Files bigger than " <> maxFileSizeStr <> " are not supported" encPath <- getEncPath tempPath "xftp" - key <- atomically $ C.randomSbKey g - nonce <- atomically $ C.randomCbNonce g + key <- liftIO $ C.randomSbKey g + nonce <- liftIO $ C.randomCbNonce g let fileHdr = smpEncode FileHeader {fileName, fileExtra = Nothing} fileSize' = fromIntegral (B.length fileHdr) + fileSize chunkSizes = prepareChunkSizes $ fileSize' + fileSizeLen + authTagSize @@ -311,7 +311,7 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re fdSnd = FileDescription {party = SFSender, size = FileSize encSize, digest = FileDigest digest, key, nonce, chunkSize = FileSize defChunkSize, chunks = [], redirect = Nothing} logInfo $ "encrypted file to " <> tshow encPath pure (encPath, fdRcv, fdSnd, chunkSpecs, encSize) - uploadFile :: TVar ChaChaDRG -> [XFTPChunkSpec] -> TVar [Int64] -> Int64 -> ExceptT CLIError IO [SentFileChunk] + uploadFile :: IORef ChaChaDRG -> [XFTPChunkSpec] -> TVar [Int64] -> Int64 -> ExceptT CLIError IO [SentFileChunk] uploadFile g chunks uploadedChunks encSize = do a <- liftIO $ newXFTPAgent defaultXFTPClientAgentConfig gen <- newTVarIO =<< liftIO newStdGen @@ -330,8 +330,8 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re uploadFileChunk :: XFTPClientAgent -> (Int, XFTPChunkSpec, XFTPServerWithAuth) -> ExceptT CLIError IO (Int, SentFileChunk) uploadFileChunk a (chunkNo, chunkSpec@XFTPChunkSpec {chunkSize}, ProtoServerWithAuth xftpServer auth) = do logInfo $ "uploading chunk " <> tshow chunkNo <> " to " <> showServer xftpServer <> "..." - (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g - rKeys <- atomically $ L.fromList <$> replicateM numRecipients (C.generateAuthKeyPair C.SEd25519 g) + (sndKey, spKey) <- liftIO $ C.generateAuthKeyPair C.SEd25519 g + rKeys <- liftIO $ L.fromList <$> replicateM numRecipients (C.generateAuthKeyPair C.SEd25519 g) digest <- liftIO $ getChunkDigest chunkSpec let ch = FileInfo {sndKey, size = chunkSize, digest} c <- withRetry retryCount $ getXFTPServerClient a xftpServer @@ -451,7 +451,7 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath, liftIO $ do printNoNewLine $ "File downloaded: " <> path removeFD yes fileDescription - downloadFileChunk :: TVar ChaChaDRG -> XFTPClientAgent -> FilePath -> FileSize Int64 -> TVar [Int64] -> FileChunk -> ExceptT CLIError IO (Int, FilePath) + downloadFileChunk :: IORef ChaChaDRG -> XFTPClientAgent -> FilePath -> FileSize Int64 -> TVar [Int64] -> FileChunk -> ExceptT CLIError IO (Int, FilePath) downloadFileChunk g a encPath (FileSize encSize) downloadedChunks FileChunk {chunkNo, chunkSize, digest, replicas = replica : _} = do let FileChunkReplica {server, replicaId, replicaKey} = replica logInfo $ "downloading chunk " <> tshow chunkNo <> " from " <> showServer server <> "..." @@ -615,7 +615,7 @@ cliRandomFile RandomFileOptions {filePath, fileSize = FileSize size} = do where saveRandomFile h sz = do g <- C.newRandom - bytes <- atomically $ C.randomBytes (fromIntegral $ min mb' sz) g + bytes <- C.randomBytes (fromIntegral $ min mb' sz) g B.hPut h bytes when (sz > mb') $ saveRandomFile h (sz - mb') mb' = mb 1 diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs index 00b320f68..1048bd611 100644 --- a/src/Simplex/FileTransfer/Server.hs +++ b/src/Simplex/FileTransfer/Server.hs @@ -130,7 +130,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira _ -> liftIO . sendResponse $ H.responseNoBody N.ok200 [] -- shouldn't happen: means server picked handshake protocol it doesn't know about xftpServerHandshakeV1 :: X.CertificateChain -> C.APrivateSignKey -> TMap SessionId Handshake -> XFTPTransportRequest -> M (Maybe (THandleParams XFTPVersion 'TServer)) xftpServerHandshakeV1 chain serverSignKey sessions XFTPTransportRequest {thParams = thParams0@THandleParams {sessionId}, reqBody = HTTP2Body {bodyHead}, sendResponse} = do - s <- atomically $ TM.lookup sessionId sessions + s <- liftIO $ TM.lookupIO sessionId sessions r <- runExceptT $ case s of Nothing -> processHello Just (HandshakeSent pk) -> processClientHandshake pk @@ -139,7 +139,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira where processHello = do unless (B.null bodyHead) $ throwE HANDSHAKE - (k, pk) <- atomically . C.generateKeyPair =<< asks random + (k, pk) <- liftIO . C.generateKeyPair =<< asks random atomically $ TM.insert sessionId (HandshakeSent pk) sessions let authPubKey = (chain, C.signX509 serverSignKey $ C.publicToX509 k) let hs = XFTPServerHandshake {xftpVersionRange = xftpServerVRange, sessionId, authPubKey} @@ -489,9 +489,9 @@ processXFTPRequest HTTP2Body {bodyPart} = \case where sendFile = do g <- asks random - (sDhKey, spDhKey) <- atomically $ C.generateKeyPair g + (sDhKey, spDhKey) <- liftIO $ C.generateKeyPair g let dhSecret = C.dh' rDhKey spDhKey - cbNonce <- atomically $ C.randomCbNonce g + cbNonce <- liftIO $ C.randomCbNonce g case LC.cbInit dhSecret cbNonce of Right sbState -> do stats <- asks serverStats @@ -557,12 +557,12 @@ expireServerFiles itemDelay expCfg = do incFileStat filesExpired randomId :: Int -> M ByteString -randomId n = atomically . C.randomBytes n =<< asks random +randomId n = liftIO . C.randomBytes n =<< asks random getFileId :: M XFTPFileId getFileId = do size <- asks (fileIdSize . config) - atomically . C.randomBytes size =<< asks random + liftIO . C.randomBytes size =<< asks random withFileLog :: (StoreLog 'WriteMode -> IO a) -> M () withFileLog action = liftIO . mapM_ action =<< asks storeLog diff --git a/src/Simplex/FileTransfer/Server/Env.hs b/src/Simplex/FileTransfer/Server/Env.hs index 1fa399a2a..442febaae 100644 --- a/src/Simplex/FileTransfer/Server/Env.hs +++ b/src/Simplex/FileTransfer/Server/Env.hs @@ -12,6 +12,7 @@ module Simplex.FileTransfer.Server.Env where import Control.Logger.Simple import Control.Monad import Crypto.Random +import Data.IORef (IORef) import Data.Int (Int64) import Data.List.NonEmpty (NonEmpty) import qualified Data.Map.Strict as M @@ -83,7 +84,7 @@ data XFTPEnv = XFTPEnv { config :: XFTPServerConfig, store :: FileStore, storeLog :: Maybe (StoreLog 'WriteMode), - random :: TVar ChaChaDRG, + random :: IORef ChaChaDRG, serverIdentity :: C.KeyHash, tlsServerParams :: T.ServerParams, serverStats :: FileServerStats diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 755734fde..c7e5d69cc 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -136,6 +136,7 @@ import Data.Either (isRight, rights) import Data.Foldable (foldl', toList) import Data.Functor (($>)) import Data.Functor.Identity +import Data.IORef (IORef) import Data.List (find) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as L @@ -821,7 +822,7 @@ startJoinInvitation userId connId sq_ enableNtfs cReqUri pqSup = g <- asks random let pqSupport = pqSup `CR.pqSupportAnd` versionPQSupport_ connAgentVersion (Just v) (pk1, pk2, pKem, e2eSndParams) <- liftIO $ CR.generateSndE2EParams g v (CR.replyKEM_ v kem_ pqSupport) - (_, rcDHRs) <- atomically $ C.generateKeyPair g + (_, rcDHRs) <- liftIO $ C.generateKeyPair g rcParams <- liftEitherWith cryptoError $ CR.pqX3dhSnd pk1 pk2 pKem e2eRcvParams maxSupported <- asks $ maxVersion . e2eEncryptVRange . config let rcVs = CR.RatchetVersions {current = v, maxSupported} @@ -1941,8 +1942,8 @@ registerNtfToken' c suppliedDeviceToken suppliedNtfMode = asks (rcvAuthAlg . config) >>= \case C.AuthAlg a -> do g <- asks random - tknKeys <- atomically $ C.generateAuthKeyPair a g - dhKeys <- atomically $ C.generateKeyPair g + tknKeys <- liftIO $ C.generateAuthKeyPair a g + dhKeys <- liftIO $ C.generateKeyPair g let tkn = newNtfToken suppliedDeviceToken ntfServer tknKeys dhKeys suppliedNtfMode withStore' c (`createNtfToken` tkn) registerToken tkn @@ -2405,7 +2406,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId checkDuplicateHash e encryptedMsgHash = unlessM (withStore' c $ \db -> checkRcvMsgHashExists db connId encryptedMsgHash) $ throwE e - agentClientMsg :: TVar ChaChaDRG -> ByteString -> AM (Maybe (InternalId, MsgMeta, AMessage, CR.RatchetX448)) + agentClientMsg :: IORef ChaChaDRG -> ByteString -> AM (Maybe (InternalId, MsgMeta, AMessage, CR.RatchetX448)) agentClientMsg g encryptedMsgHash = withStore c $ \db -> runExceptT $ do rc <- ExceptT $ getRatchet db connId -- ratchet state pre-decryption - required for processing EREADY (agentMsgBody, pqEncryption) <- agentRatchetDecrypt' g db connId rc encAgentMessage @@ -2787,7 +2788,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId rcParams <- liftError cryptoError $ CR.pqX3dhRcv pk1 pk2 pKem e2eOtherPartyParams recreateRatchet $ CR.initRcvRatchet rcVs pk2 rcParams pqSupport | otherwise = do - (_, rcDHRs) <- atomically . C.generateKeyPair =<< asks random + (_, rcDHRs) <- liftIO . C.generateKeyPair =<< asks random rcParams <- liftEitherWith cryptoError $ CR.pqX3dhSnd pk1 pk2 (CR.APRKP CR.SRKSProposed <$> pKem) e2eOtherPartyParams recreateRatchet $ CR.initSndRatchet rcVs k2Rcv rcDHRs rcParams void . enqueueMessages' c cData' sqs SMP.MsgFlags {notification = True} $ EREADY lastExternalSndId @@ -2934,12 +2935,12 @@ agentRatchetEncrypt db ConnData {connId, connAgentVersion = v, pqSupport} msg ge pure (encMsg, CR.rcSndKEM rc') -- encoded EncAgentMessage -> encoded AgentMessage -agentRatchetDecrypt :: TVar ChaChaDRG -> DB.Connection -> ConnId -> ByteString -> ExceptT StoreError IO (ByteString, PQEncryption) +agentRatchetDecrypt :: IORef ChaChaDRG -> DB.Connection -> ConnId -> ByteString -> ExceptT StoreError IO (ByteString, PQEncryption) agentRatchetDecrypt g db connId encAgentMsg = do rc <- ExceptT $ getRatchet db connId agentRatchetDecrypt' g db connId rc encAgentMsg -agentRatchetDecrypt' :: TVar ChaChaDRG -> DB.Connection -> ConnId -> CR.RatchetX448 -> ByteString -> ExceptT StoreError IO (ByteString, PQEncryption) +agentRatchetDecrypt' :: IORef ChaChaDRG -> DB.Connection -> ConnId -> CR.RatchetX448 -> ByteString -> ExceptT StoreError IO (ByteString, PQEncryption) agentRatchetDecrypt' g db connId rc encAgentMsg = do skipped <- liftIO $ getSkippedMsgKeys db connId (agentMsgBody_, rc', skippedDiff) <- withExceptT (SEAgentError . cryptoError) $ CR.rcDecrypt g rc skipped encAgentMsg @@ -2950,8 +2951,8 @@ newSndQueue :: UserId -> ConnId -> Compatible SMPQueueInfo -> AM' (NewSndQueue, newSndQueue userId connId (Compatible (SMPQueueInfo smpClientVersion SMPQueueAddress {smpServer, senderId, sndSecure, dhPublicKey = rcvE2ePubDhKey})) = do C.AuthAlg a <- asks $ sndAuthAlg . config g <- asks random - (sndPublicKey, sndPrivateKey) <- atomically $ C.generateAuthKeyPair a g - (e2ePubKey, e2ePrivKey) <- atomically $ C.generateKeyPair g + (sndPublicKey, sndPrivateKey) <- liftIO $ C.generateAuthKeyPair a g + (e2ePubKey, e2ePrivKey) <- liftIO $ C.generateKeyPair g let sq = SndQueue { userId, diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 8f339cab7..540289b2b 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -182,6 +182,7 @@ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Either (isRight, partitionEithers) import Data.Functor (($>)) +import Data.IORef (IORef) import Data.Int (Int64) import Data.List (deleteFirstsBy, foldl', partition, (\\)) import Data.List.NonEmpty (NonEmpty (..), (<|)) @@ -548,7 +549,7 @@ agentClientStore :: AgentClient -> SQLiteStore agentClientStore AgentClient {agentEnv = Env {store}} = store {-# INLINE agentClientStore #-} -agentDRG :: AgentClient -> TVar ChaChaDRG +agentDRG :: AgentClient -> IORef ChaChaDRG agentDRG AgentClient {agentEnv = Env {random}} = random {-# INLINE agentDRG #-} @@ -1198,9 +1199,9 @@ runSMPServerTest c userId (ProtoServerWithAuth srv auth) = do let tSess = (userId, srv, Nothing) getProtocolClient g tSess cfg Nothing (\_ -> pure ()) >>= \case Right smp -> do - rKeys@(_, rpKey) <- atomically $ C.generateAuthKeyPair ra g - (sKey, spKey) <- atomically $ C.generateAuthKeyPair sa g - (dhKey, _) <- atomically $ C.generateKeyPair g + rKeys@(_, rpKey) <- liftIO $ C.generateAuthKeyPair ra g + (sKey, spKey) <- liftIO $ C.generateAuthKeyPair sa g + (dhKey, _) <- liftIO $ C.generateKeyPair g r <- runExceptT $ do SMP.QIK {rcvId, sndId, sndSecure} <- liftError (testErr TSCreateQueue) $ createSMPQueue smp rKeys dhKey auth SMSubscribe True liftError (testErr TSSecureQueue) $ @@ -1228,8 +1229,8 @@ runXFTPServerTest c userId (ProtoServerWithAuth srv auth) = do let tSess = (userId, srv, Nothing) X.getXFTPClient tSess cfg {xftpNetworkConfig} (\_ -> pure ()) >>= \case Right xftp -> withTestChunk filePath $ do - (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g - (rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (sndKey, spKey) <- liftIO $ C.generateAuthKeyPair C.SEd25519 g + (rcvKey, rpKey) <- liftIO $ C.generateAuthKeyPair C.SEd25519 g digest <- liftIO $ C.sha256Hash <$> B.readFile filePath let file = FileInfo {sndKey, size = chSize, digest} chunkSpec = X.XFTPChunkSpec {filePath, chunkOffset = 0, chunkSize = chSize} @@ -1261,7 +1262,7 @@ runXFTPServerTest c userId (ProtoServerWithAuth srv auth) = do (whenM (doesFileExist fp) $ removeFile fp `catchAll_` pure ()) -- this creates a new DRG on purpose to avoid blocking the one used in the agent createTestChunk :: FilePath -> IO () - createTestChunk fp = B.writeFile fp =<< atomically . C.randomBytes chSize =<< C.newRandom + createTestChunk fp = B.writeFile fp =<< liftIO . C.randomBytes chSize =<< C.newRandom runNTFServerTest :: AgentClient -> UserId -> NtfServerWithAuth -> AM' (Maybe ProtocolTestFailure) runNTFServerTest c userId (ProtoServerWithAuth srv _) = do @@ -1272,8 +1273,8 @@ runNTFServerTest c userId (ProtoServerWithAuth srv _) = do let tSess = (userId, srv, Nothing) getProtocolClient g tSess cfg Nothing (\_ -> pure ()) >>= \case Right ntf -> do - (nKey, npKey) <- atomically $ C.generateAuthKeyPair a g - (dhKey, _) <- atomically $ C.generateKeyPair g + (nKey, npKey) <- liftIO $ C.generateAuthKeyPair a g + (dhKey, _) <- liftIO $ C.generateKeyPair g r <- runExceptT $ do let deviceToken = DeviceToken PPApnsNull "test_ntf_token" (tknId, _) <- liftError (testErr TSCreateNtfToken) $ ntfRegisterToken ntf npKey (NewNtfTkn deviceToken nKey dhKey) @@ -1315,9 +1316,9 @@ newRcvQueue :: AgentClient -> UserId -> ConnId -> SMPServerWithAuth -> VersionRa newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange subMode senderCanSecure = do C.AuthAlg a <- asks (rcvAuthAlg . config) g <- asks random - rKeys@(_, rcvPrivateKey) <- atomically $ C.generateAuthKeyPair a g - (dhKey, privDhKey) <- atomically $ C.generateKeyPair g - (e2eDhKey, e2ePrivKey) <- atomically $ C.generateKeyPair g + rKeys@(_, rcvPrivateKey) <- liftIO $ C.generateAuthKeyPair a g + (dhKey, privDhKey) <- liftIO $ C.generateKeyPair g + (e2eDhKey, e2ePrivKey) <- liftIO $ C.generateKeyPair g logServer "-->" c srv "" "NEW" tSess <- mkTransportSession c userId srv connId (sessId, QIK {rcvId, sndId, rcvPublicDhKey, sndSecure}) <- @@ -1705,7 +1706,7 @@ agentXFTPDownloadChunk c userId (FileDigest chunkDigest) RcvFileChunkReplica {se agentXFTPNewChunk :: AgentClient -> SndFileChunk -> Int -> XFTPServerWithAuth -> AM NewSndChunkReplica agentXFTPNewChunk c SndFileChunk {userId, chunkSpec = XFTPChunkSpec {chunkSize}, digest = FileDigest chunkDigest} n (ProtoServerWithAuth srv auth) = do rKeys <- xftpRcvKeys n - (sndKey, replicaKey) <- atomically . C.generateAuthKeyPair C.SEd25519 =<< asks random + (sndKey, replicaKey) <- liftIO . C.generateAuthKeyPair C.SEd25519 =<< asks random let fileInfo = FileInfo {sndKey, size = chunkSize, digest = chunkDigest} logServer "-->" c srv "" "FNEW" tSess <- mkTransportSession c userId srv chunkDigest @@ -1729,7 +1730,7 @@ agentXFTPDeleteChunk c userId DeletedSndChunkReplica {server, replicaId = ChunkR xftpRcvKeys :: Int -> AM (NonEmpty C.AAuthKeyPair) xftpRcvKeys n = do - rKeys <- atomically . replicateM n . C.generateAuthKeyPair C.SEd25519 =<< asks random + rKeys <- liftIO . replicateM n . C.generateAuthKeyPair C.SEd25519 =<< asks random case L.nonEmpty rKeys of Just rKeys' -> pure rKeys' _ -> throwE $ INTERNAL "non-positive number of recipients" @@ -1739,7 +1740,7 @@ xftpRcvIdsKeys rIds rKeys = L.map ChunkReplicaId rIds `L.zip` L.map snd rKeys agentCbEncrypt :: SndQueue -> Maybe C.PublicKeyX25519 -> ByteString -> AM ByteString agentCbEncrypt SndQueue {e2eDhSecret, smpClientVersion} e2ePubKey msg = do - cmNonce <- atomically . C.randomCbNonce =<< asks random + cmNonce <- liftIO . C.randomCbNonce =<< asks random let paddedLen = maybe SMP.e2eEncMessageLength (const SMP.e2eEncConfirmationLength) e2ePubKey cmEncBody <- liftEither . first cryptoError $ @@ -1751,9 +1752,9 @@ agentCbEncrypt SndQueue {e2eDhSecret, smpClientVersion} e2ePubKey msg = do agentCbEncryptOnce :: VersionSMPC -> C.PublicKeyX25519 -> ByteString -> AM ByteString agentCbEncryptOnce clientVersion dhRcvPubKey msg = do g <- asks random - (dhSndPubKey, dhSndPrivKey) <- atomically $ C.generateKeyPair g + (dhSndPubKey, dhSndPrivKey) <- liftIO $ C.generateKeyPair g let e2eDhSecret = C.dh' dhRcvPubKey dhSndPrivKey - cmNonce <- atomically $ C.randomCbNonce g + cmNonce <- liftIO $ C.randomCbNonce g cmEncBody <- liftEither . first cryptoError $ C.cbEncrypt e2eDhSecret cmNonce msg SMP.e2eEncConfirmationLength diff --git a/src/Simplex/Messaging/Agent/Env/SQLite.hs b/src/Simplex/Messaging/Agent/Env/SQLite.hs index bc5e800c5..68e827295 100644 --- a/src/Simplex/Messaging/Agent/Env/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Env/SQLite.hs @@ -49,6 +49,7 @@ import Crypto.Random import Data.Aeson (FromJSON (..), ToJSON (..)) import qualified Data.Aeson.TH as JQ import Data.ByteArray (ScrubbedBytes) +import Data.IORef (IORef) import Data.Int (Int64) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as L @@ -233,7 +234,7 @@ defaultAgentConfig = data Env = Env { config :: AgentConfig, store :: SQLiteStore, - random :: TVar ChaChaDRG, + random :: IORef ChaChaDRG, randomServer :: TVar StdGen, ntfSupervisor :: NtfSupervisor, xftpAgent :: XFTPAgent, diff --git a/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs b/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs index 23a88ea70..579ac7c2c 100644 --- a/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs +++ b/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs @@ -259,8 +259,8 @@ runNtfSMPWorker c srv Worker {doWork} = do rq <- withStore c (`getPrimaryRcvQueue` connId) C.AuthAlg a <- asks (rcvAuthAlg . config) g <- asks random - (ntfPublicKey, ntfPrivateKey) <- atomically $ C.generateAuthKeyPair a g - (rcvNtfPubDhKey, rcvNtfPrivDhKey) <- atomically $ C.generateKeyPair g + (ntfPublicKey, ntfPrivateKey) <- liftIO $ C.generateAuthKeyPair a g + (rcvNtfPubDhKey, rcvNtfPrivDhKey) <- liftIO $ C.generateKeyPair g (notifierId, rcvNtfSrvPubDhKey) <- enableQueueNotifications c rq ntfPublicKey rcvNtfPubDhKey let rcvNtfDhSecret = C.dh' rcvNtfSrvPubDhKey rcvNtfPrivDhKey withStore' c $ \db -> do diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index 97b32eca8..859da15cc 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -547,7 +547,7 @@ deleteUsersWithoutConns db = do pure userIds createConn_ :: - TVar ChaChaDRG -> + IORef ChaChaDRG -> ConnData -> (ConnId -> IO a) -> IO (Either StoreError (ConnId, a)) @@ -555,7 +555,7 @@ createConn_ gVar cData create = checkConstraint SEConnDuplicate $ case cData of ConnData {connId = ""} -> createWithRandomId' gVar create ConnData {connId} -> Right . (connId,) <$> create connId -createNewConn :: DB.Connection -> TVar ChaChaDRG -> ConnData -> SConnectionMode c -> IO (Either StoreError ConnId) +createNewConn :: DB.Connection -> IORef ChaChaDRG -> ConnData -> SConnectionMode c -> IO (Either StoreError ConnId) createNewConn db gVar cData cMode = do fst <$$> createConn_ gVar cData (\connId -> createConnRecord db connId cData cMode) @@ -579,7 +579,7 @@ updateNewConnSnd db connId sq = updateConn :: IO (Either StoreError SndQueue) updateConn = Right <$> addConnSndQueue_ db connId sq -createSndConn :: DB.Connection -> TVar ChaChaDRG -> ConnData -> NewSndQueue -> IO (Either StoreError (ConnId, SndQueue)) +createSndConn :: DB.Connection -> IORef ChaChaDRG -> ConnData -> NewSndQueue -> IO (Either StoreError (ConnId, SndQueue)) createSndConn db gVar cData q@SndQueue {server} = -- check confirmed snd queue doesn't already exist, to prevent it being deleted by REPLACE in insertSndQueue_ ifM (liftIO $ checkConfirmedSndQueueExists_ db q) (pure $ Left SESndQueueExists) $ @@ -828,7 +828,7 @@ smpConfirmation (senderKey, e2ePubKey, connInfo, smpReplyQueues_, smpClientVersi smpClientVersion = fromMaybe initialSMPClientVersion smpClientVersion_ } -createConfirmation :: DB.Connection -> TVar ChaChaDRG -> NewConfirmation -> IO (Either StoreError ConfirmationId) +createConfirmation :: DB.Connection -> IORef ChaChaDRG -> NewConfirmation -> IO (Either StoreError ConfirmationId) createConfirmation db gVar NewConfirmation {connId, senderConf = SMPConfirmation {senderKey, e2ePubKey, connInfo, smpReplyQueues, smpClientVersion}, ratchetState} = createWithRandomId gVar $ \confirmationId -> DB.execute @@ -902,7 +902,7 @@ removeConfirmations db connId = |] [":conn_id" := connId] -createInvitation :: DB.Connection -> TVar ChaChaDRG -> NewInvitation -> IO (Either StoreError InvitationId) +createInvitation :: DB.Connection -> IORef ChaChaDRG -> NewInvitation -> IO (Either StoreError InvitationId) createInvitation db gVar NewInvitation {contactConnId, connReq, recipientConnInfo} = createWithRandomId gVar $ \invitationId -> DB.execute @@ -2284,10 +2284,10 @@ updateSndMsgHash db connId internalSndId internalHash = ] -- create record with a random ID -createWithRandomId :: TVar ChaChaDRG -> (ByteString -> IO ()) -> IO (Either StoreError ByteString) +createWithRandomId :: IORef ChaChaDRG -> (ByteString -> IO ()) -> IO (Either StoreError ByteString) createWithRandomId gVar create = fst <$$> createWithRandomId' gVar create -createWithRandomId' :: forall a. TVar ChaChaDRG -> (ByteString -> IO a) -> IO (Either StoreError (ByteString, a)) +createWithRandomId' :: forall a. IORef ChaChaDRG -> (ByteString -> IO a) -> IO (Either StoreError (ByteString, a)) createWithRandomId' gVar create = tryCreate 3 where tryCreate :: Int -> IO (Either StoreError (ByteString, a)) @@ -2300,8 +2300,8 @@ createWithRandomId' gVar create = tryCreate 3 | SQL.sqlError e == SQL.ErrorConstraint -> tryCreate (n - 1) | otherwise -> pure . Left . SEInternal $ bshow e -randomId :: TVar ChaChaDRG -> Int -> IO ByteString -randomId gVar n = atomically $ U.encode <$> C.randomBytes n gVar +randomId :: IORef ChaChaDRG -> Int -> IO ByteString +randomId gVar n = U.encode <$> C.randomBytes n gVar ntfSubAndSMPAction :: NtfSubAction -> (Maybe NtfSubNTFAction, Maybe NtfSubSMPAction) ntfSubAndSMPAction (NSANtf action) = (Just action, Nothing) @@ -2322,7 +2322,7 @@ getXFTPServerId_ db ProtocolServer {host, port, keyHash} = do firstRow fromOnly SEXFTPServerNotFound $ DB.query db "SELECT xftp_server_id FROM xftp_servers WHERE xftp_host = ? AND xftp_port = ? AND xftp_key_hash = ?" (host, port, keyHash) -createRcvFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> FileDescription 'FRecipient -> FilePath -> FilePath -> CryptoFile -> Bool -> IO (Either StoreError RcvFileId) +createRcvFile :: DB.Connection -> IORef ChaChaDRG -> UserId -> FileDescription 'FRecipient -> FilePath -> FilePath -> CryptoFile -> Bool -> IO (Either StoreError RcvFileId) createRcvFile db gVar userId fd@FileDescription {chunks} prefixPath tmpPath file approvedRelays = runExceptT $ do (rcvFileEntityId, rcvFileId) <- ExceptT $ insertRcvFile db gVar userId fd prefixPath tmpPath file Nothing Nothing approvedRelays liftIO $ @@ -2331,7 +2331,7 @@ createRcvFile db gVar userId fd@FileDescription {chunks} prefixPath tmpPath file forM_ (zip [1 ..] replicas) $ \(rno, replica) -> insertRcvFileChunkReplica db rno replica chunkId pure rcvFileEntityId -createRcvFileRedirect :: DB.Connection -> TVar ChaChaDRG -> UserId -> FileDescription 'FRecipient -> FilePath -> FilePath -> CryptoFile -> FilePath -> CryptoFile -> Bool -> IO (Either StoreError RcvFileId) +createRcvFileRedirect :: DB.Connection -> IORef ChaChaDRG -> UserId -> FileDescription 'FRecipient -> FilePath -> FilePath -> CryptoFile -> FilePath -> CryptoFile -> Bool -> IO (Either StoreError RcvFileId) createRcvFileRedirect _ _ _ FileDescription {redirect = Nothing} _ _ _ _ _ _ = pure $ Left $ SEInternal "createRcvFileRedirect called without redirect" createRcvFileRedirect db gVar userId redirectFd@FileDescription {chunks = redirectChunks, redirect = Just RedirectFileInfo {size, digest}} prefixPath redirectPath redirectFile dstPath dstFile approvedRelays = runExceptT $ do (dstEntityId, dstId) <- ExceptT $ insertRcvFile db gVar userId dummyDst prefixPath dstPath dstFile Nothing Nothing approvedRelays @@ -2355,7 +2355,7 @@ createRcvFileRedirect db gVar userId redirectFd@FileDescription {chunks = redire chunks = [] } -insertRcvFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> FileDescription 'FRecipient -> FilePath -> FilePath -> CryptoFile -> Maybe DBRcvFileId -> Maybe RcvFileId -> Bool -> IO (Either StoreError (RcvFileId, DBRcvFileId)) +insertRcvFile :: DB.Connection -> IORef ChaChaDRG -> UserId -> FileDescription 'FRecipient -> FilePath -> FilePath -> CryptoFile -> Maybe DBRcvFileId -> Maybe RcvFileId -> Bool -> IO (Either StoreError (RcvFileId, DBRcvFileId)) insertRcvFile db gVar userId FileDescription {size, digest, key, nonce, chunkSize, redirect} prefixPath tmpPath (CryptoFile savePath cfArgs) redirectId_ redirectEntityId_ approvedRelays = runExceptT $ do let (redirectDigest_, redirectSize_) = case redirect of Just RedirectFileInfo {digest = d, size = s} -> (Just d, Just s) @@ -2651,7 +2651,7 @@ getRcvFilesExpired db ttl = do |] (Only cutoffTs) -createSndFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> CryptoFile -> Int -> FilePath -> C.SbKey -> C.CbNonce -> Maybe RedirectFileInfo -> IO (Either StoreError SndFileId) +createSndFile :: DB.Connection -> IORef ChaChaDRG -> UserId -> CryptoFile -> Int -> FilePath -> C.SbKey -> C.CbNonce -> Maybe RedirectFileInfo -> IO (Either StoreError SndFileId) createSndFile db gVar userId (CryptoFile path cfArgs) numRecipients prefixPath key nonce redirect_ = createWithRandomId gVar $ \sndFileEntityId -> DB.execute diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index b4567c62e..52dbde113 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -118,6 +118,7 @@ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Functor (($>)) import Data.Int (Int64) +import Data.IORef import Data.List (find) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as L @@ -163,18 +164,18 @@ data PClient v err msg = PClient sendPings :: TVar Bool, lastReceived :: TVar UTCTime, timeoutErrorCount :: TVar Int, - clientCorrId :: TVar ChaChaDRG, + clientCorrId :: IORef ChaChaDRG, sentCommands :: TMap CorrId (Request err msg), sndQ :: TBQueue (Maybe (TVar Bool), ByteString), rcvQ :: TBQueue (NonEmpty (SignedTransmission err msg)), msgQ :: Maybe (TBQueue (ServerTransmissionBatch v err msg)) } -smpClientStub :: TVar ChaChaDRG -> ByteString -> VersionSMP -> Maybe (THandleAuth 'TClient) -> IO SMPClient +smpClientStub :: IORef ChaChaDRG -> ByteString -> VersionSMP -> Maybe (THandleAuth 'TClient) -> IO SMPClient smpClientStub g sessionId thVersion thAuth = do let ts = UTCTime (read "2024-03-31") 0 connected <- newTVarIO False - clientCorrId <- atomically $ C.newRandomDRG g + clientCorrId <- C.newRandomDRG g sentCommands <- TM.emptyIO sendPings <- newTVarIO False lastReceived <- newTVarIO ts @@ -448,7 +449,7 @@ type TransportSession msg = (UserId, ProtoServer msg, Maybe EntityId) -- -- A single queue can be used for multiple 'SMPClient' instances, -- as 'SMPServerTransmission' includes server information. -getProtocolClient :: forall v err msg. Protocol v err msg => TVar ChaChaDRG -> TransportSession msg -> ProtocolClientConfig v -> Maybe (TBQueue (ServerTransmissionBatch v err msg)) -> (ProtocolClient v err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg)) +getProtocolClient :: forall v err msg. Protocol v err msg => IORef ChaChaDRG -> TransportSession msg -> ProtocolClientConfig v -> Maybe (TBQueue (ServerTransmissionBatch v err msg)) -> (ProtocolClient v err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg)) getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, clientALPN, serverVRange, agreeSecret} msgQ disconnected = do case chooseTransportHost networkConfig (host srv) of Right useHost -> @@ -463,7 +464,7 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize sendPings <- newTVarIO False lastReceived <- newTVarIO ts timeoutErrorCount <- newTVarIO 0 - clientCorrId <- atomically $ C.newRandomDRG g + clientCorrId <- C.newRandomDRG g sentCommands <- TM.emptyIO sndQ <- newTBQueueIO qSize rcvQ <- newTBQueueIO qSize @@ -506,7 +507,7 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize client :: forall c. Transport c => TProxy c -> PClient v err msg -> TMVar (Either (ProtocolClientError err) (ProtocolClient v err msg)) -> c -> IO () client _ c cVar h = do - ks <- if agreeSecret then Just <$> atomically (C.generateKeyPair g) else pure Nothing + ks <- if agreeSecret then Just <$> C.generateKeyPair g else pure Nothing runExceptT (protocolClientHandshake @v @err @msg h ks (keyHash srv) serverVRange) >>= \case Left e -> atomically . putTMVar cVar . Left $ PCETransportError e Right th@THandle {params} -> do @@ -917,9 +918,9 @@ proxySMPCommand c@ProtocolClient {thParams = proxyThParams, client_ = PClient {c -- prepare params let serverThAuth = (\ta -> ta {serverPeerPubKey = serverKey}) <$> thAuth proxyThParams serverThParams = smpTHParamsSetVersion v proxyThParams {sessionId, thAuth = serverThAuth} - (cmdPubKey, cmdPrivKey) <- liftIO . atomically $ C.generateKeyPair @'C.X25519 g + (cmdPubKey, cmdPrivKey) <- liftIO $ C.generateKeyPair @'C.X25519 g let cmdSecret = C.dh' serverKey cmdPrivKey - nonce@(C.CbNonce corrId) <- liftIO . atomically $ C.randomCbNonce g + nonce@(C.CbNonce corrId) <- liftIO $ C.randomCbNonce g -- encode let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth serverThParams (CorrId corrId, sId, Cmd SSender command) auth <- liftEitherWith PCETransportError $ authTransmission serverThAuth spKey nonce tForAuth @@ -962,7 +963,7 @@ forwardSMPTransmission c@ProtocolClient {thParams, client_ = PClient {clientCorr sessSecret <- case thAuth thParams of Nothing -> throwE $ PCETransportError TENoServerAuth Just THAuthClient {sessSecret} -> maybe (throwE $ PCETransportError TENoServerAuth) pure sessSecret - nonce <- liftIO . atomically $ C.randomCbNonce g + nonce <- liftIO $ C.randomCbNonce g -- wrap let fwdT = FwdTransmission {fwdCorrId, fwdVersion, fwdKey, fwdTransmission} eft = EncFwdTransmission $ C.cbEncryptNoPad sessSecret nonce (smpEncode fwdT) @@ -1086,7 +1087,7 @@ mkTransmission c = mkTransmission_ c Nothing mkTransmission_ :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> Maybe C.CbNonce -> ClientCommand msg -> IO (PCTransmission err msg) mkTransmission_ ProtocolClient {thParams, client_ = PClient {clientCorrId, sentCommands}} nonce_ (pKey_, entityId, command) = do - nonce@(C.CbNonce corrId) <- maybe (atomically $ C.randomCbNonce clientCorrId) pure nonce_ + nonce@(C.CbNonce corrId) <- maybe (C.randomCbNonce clientCorrId) pure nonce_ let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (CorrId corrId, entityId, command) auth = authTransmission (thAuth thParams) pKey_ nonce tForAuth r <- mkRequest (CorrId corrId) diff --git a/src/Simplex/Messaging/Client/Agent.hs b/src/Simplex/Messaging/Client/Agent.hs index 29c485ebd..ada51bd04 100644 --- a/src/Simplex/Messaging/Client/Agent.hs +++ b/src/Simplex/Messaging/Client/Agent.hs @@ -23,6 +23,7 @@ import Crypto.Random (ChaChaDRG) import Data.Bifunctor (first) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B +import Data.IORef import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) @@ -97,7 +98,7 @@ data SMPClientAgent = SMPClientAgent active :: TVar Bool, msgQ :: TBQueue (ServerTransmissionBatch SMPVersion ErrorType BrokerMsg), agentQ :: TBQueue SMPClientAgentEvent, - randomDrg :: TVar ChaChaDRG, + randomDrg :: IORef ChaChaDRG, smpClients :: TMap SMPServer SMPClientVar, smpSessions :: TMap SessionId (OwnServer, SMPClient), srvSubs :: TMap SMPServer (TMap SMPSub (SessionId, C.APrivateAuthKey)), @@ -108,7 +109,7 @@ data SMPClientAgent = SMPClientAgent type OwnServer = Bool -newSMPClientAgent :: SMPClientAgentConfig -> TVar ChaChaDRG -> IO SMPClientAgent +newSMPClientAgent :: SMPClientAgentConfig -> IORef ChaChaDRG -> IO SMPClientAgent newSMPClientAgent agentCfg@SMPClientAgentConfig {msgQSize, agentQSize} randomDrg = do active <- newTVarIO True msgQ <- newTBQueueIO msgQSize diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs index 7aefbd709..a234145c3 100644 --- a/src/Simplex/Messaging/Crypto.hs +++ b/src/Simplex/Messaging/Crypto.hs @@ -188,7 +188,6 @@ module Simplex.Messaging.Crypto ) where -import Control.Concurrent.STM import Control.Exception (Exception) import Control.Monad import Control.Monad.Except @@ -218,6 +217,7 @@ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.ByteString.Lazy (fromStrict, toStrict) import Data.Constraint (Dict (..)) +import Data.IORef import Data.Kind (Constraint, Type) import qualified Data.List.NonEmpty as L import Data.String @@ -233,7 +233,7 @@ import Network.Transport.Internal (decodeWord16, encodeWord16) import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (blobFieldDecoder, parseAll, parseString) -import Simplex.Messaging.Util ((<$?>)) +import Simplex.Messaging.Util (atomicStateIORef, (<$?>)) -- | Cryptographic algorithms. data Algorithm = Ed25519 | Ed448 | X25519 | X448 @@ -674,26 +674,26 @@ type ADhKeyPair = KeyPairType APrivateDhKey type AAuthKeyPair = KeyPairType APrivateAuthKey -newRandom :: IO (TVar ChaChaDRG) -newRandom = newTVarIO =<< drgNew +newRandom :: IO (IORef ChaChaDRG) +newRandom = newIORef =<< drgNew -newRandomDRG :: TVar ChaChaDRG -> STM (TVar ChaChaDRG) -newRandomDRG g = newTVar =<< stateTVar g (`withDRG` drgNew) +newRandomDRG :: IORef ChaChaDRG -> IO (IORef ChaChaDRG) +newRandomDRG g = newIORef =<< atomicStateIORef g (`withDRG` drgNew) -generateAKeyPair :: AlgorithmI a => SAlgorithm a -> TVar ChaChaDRG -> STM AKeyPair +generateAKeyPair :: AlgorithmI a => SAlgorithm a -> IORef ChaChaDRG -> IO AKeyPair generateAKeyPair a g = bimap (APublicKey a) (APrivateKey a) <$> generateKeyPair g -generateSignatureKeyPair :: (AlgorithmI a, SignatureAlgorithm a) => SAlgorithm a -> TVar ChaChaDRG -> STM ASignatureKeyPair +generateSignatureKeyPair :: (AlgorithmI a, SignatureAlgorithm a) => SAlgorithm a -> IORef ChaChaDRG -> IO ASignatureKeyPair generateSignatureKeyPair a g = bimap (APublicVerifyKey a) (APrivateSignKey a) <$> generateKeyPair g -generateAuthKeyPair :: (AlgorithmI a, AuthAlgorithm a) => SAlgorithm a -> TVar ChaChaDRG -> STM AAuthKeyPair +generateAuthKeyPair :: (AlgorithmI a, AuthAlgorithm a) => SAlgorithm a -> IORef ChaChaDRG -> IO AAuthKeyPair generateAuthKeyPair a g = bimap (APublicAuthKey a) (APrivateAuthKey a) <$> generateKeyPair g -generateDhKeyPair :: (AlgorithmI a, DhAlgorithm a) => SAlgorithm a -> TVar ChaChaDRG -> STM ADhKeyPair +generateDhKeyPair :: (AlgorithmI a, DhAlgorithm a) => SAlgorithm a -> IORef ChaChaDRG -> IO ADhKeyPair generateDhKeyPair a g = bimap (APublicDhKey a) (APrivateDhKey a) <$> generateKeyPair g -generateKeyPair :: forall a. AlgorithmI a => TVar ChaChaDRG -> STM (KeyPair a) -generateKeyPair g = stateTVar g (`withDRG` generateKeyPair_) +generateKeyPair :: forall a. AlgorithmI a => IORef ChaChaDRG -> IO (KeyPair a) +generateKeyPair g = atomicStateIORef g (`withDRG` generateKeyPair_) generateKeyPair_ :: forall a. AlgorithmI a => MonadPseudoRandom ChaChaDRG (KeyPair a) generateKeyPair_ = case sAlgorithm @a of @@ -1070,10 +1070,10 @@ initAEADGCM (Key aesKey) (GCMIV ivBytes) = cryptoFailable $ do AES.aeadInit AES.AEAD_GCM cipher ivBytes -- | Random AES256 key. -randomAesKey :: TVar ChaChaDRG -> STM Key +randomAesKey :: IORef ChaChaDRG -> IO Key randomAesKey = fmap Key . randomBytes aesKeySize -randomGCMIV :: TVar ChaChaDRG -> STM GCMIV +randomGCMIV :: IORef ChaChaDRG -> IO GCMIV randomGCMIV = fmap GCMIV . randomBytes gcmIVSize ivSize :: forall c. AES.BlockCipher c => Int @@ -1287,11 +1287,11 @@ cbNonce s where len = B.length s -randomCbNonce :: TVar ChaChaDRG -> STM CbNonce +randomCbNonce :: IORef ChaChaDRG -> IO CbNonce randomCbNonce = fmap CryptoBoxNonce . randomBytes 24 -randomBytes :: Int -> TVar ChaChaDRG -> STM ByteString -randomBytes n gVar = stateTVar gVar $ randomBytesGenerate n +randomBytes :: Int -> IORef ChaChaDRG -> IO ByteString +randomBytes n gRef = atomicStateIORef gRef $ randomBytesGenerate n reverseNonce :: CbNonce -> CbNonce reverseNonce (CryptoBoxNonce s) = CryptoBoxNonce (B.reverse s) @@ -1331,7 +1331,7 @@ sbKey s unsafeSbKey :: ByteString -> SbKey unsafeSbKey s = either error id $ sbKey s -randomSbKey :: TVar ChaChaDRG -> STM SbKey +randomSbKey :: IORef ChaChaDRG -> IO SbKey randomSbKey gVar = SecretBoxKey <$> randomBytes 32 gVar xSalsa20 :: ByteArrayAccess key => key -> ByteString -> ByteString -> (ByteString, ByteString) diff --git a/src/Simplex/Messaging/Crypto/File.hs b/src/Simplex/Messaging/Crypto/File.hs index 3ab491946..f3519440f 100644 --- a/src/Simplex/Messaging/Crypto/File.hs +++ b/src/Simplex/Messaging/Crypto/File.hs @@ -30,6 +30,7 @@ import qualified Data.ByteArray as BA import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as LB +import Data.IORef (IORef) import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (isJust) import qualified Simplex.Messaging.Crypto as C @@ -110,7 +111,7 @@ data FTCryptoError plain :: FilePath -> CryptoFile plain = (`CryptoFile` Nothing) -randomArgs :: TVar ChaChaDRG -> STM CryptoFileArgs +randomArgs :: IORef ChaChaDRG -> IO CryptoFileArgs randomArgs g = CFArgs <$> C.randomSbKey g <*> C.randomCbNonce g getFileContentsSize :: CryptoFile -> IO Integer diff --git a/src/Simplex/Messaging/Crypto/Ratchet.hs b/src/Simplex/Messaging/Crypto/Ratchet.hs index 148d931a9..eb1bc5ff6 100644 --- a/src/Simplex/Messaging/Crypto/Ratchet.hs +++ b/src/Simplex/Messaging/Crypto/Ratchet.hs @@ -102,6 +102,7 @@ import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as LB import Data.Composition ((.:), (.:.)) import Data.Functor (($>)) +import Data.IORef (IORef) import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) import qualified Data.Map.Strict as M @@ -120,7 +121,6 @@ import Simplex.Messaging.Parsers (blobFieldDecoder, defaultJSON, parseE, parseE' import Simplex.Messaging.Util (($>>=), (<$?>)) import Simplex.Messaging.Version import Simplex.Messaging.Version.Internal -import UnliftIO.STM -- e2e encryption headers version history: -- 1 - binary protocol encoding (1/1/2022) @@ -369,10 +369,10 @@ data UseKEM (s :: RatchetKEMState) where data AUseKEM = forall s. RatchetKEMStateI s => AUseKEM (SRatchetKEMState s) (UseKEM s) -generateE2EParams :: forall s a. (AlgorithmI a, DhAlgorithm a) => TVar ChaChaDRG -> VersionE2E -> Maybe (UseKEM s) -> IO (PrivateKey a, PrivateKey a, Maybe (PrivRKEMParams s), E2ERatchetParams s a) +generateE2EParams :: forall s a. (AlgorithmI a, DhAlgorithm a) => IORef ChaChaDRG -> VersionE2E -> Maybe (UseKEM s) -> IO (PrivateKey a, PrivateKey a, Maybe (PrivRKEMParams s), E2ERatchetParams s a) generateE2EParams g v useKEM_ = do - (k1, pk1) <- atomically $ generateKeyPair g - (k2, pk2) <- atomically $ generateKeyPair g + (k1, pk1) <- generateKeyPair g + (k2, pk2) <- generateKeyPair g kems <- kemParams pure (pk1, pk2, snd <$> kems, E2ERatchetParams v k1 k2 (fst <$> kems)) where @@ -390,7 +390,7 @@ generateE2EParams g v useKEM_ = do _ -> pure Nothing -- used by party initiating connection, Bob in double-ratchet spec -generateRcvE2EParams :: (AlgorithmI a, DhAlgorithm a) => TVar ChaChaDRG -> VersionE2E -> PQSupport -> IO (PrivateKey a, PrivateKey a, Maybe (PrivRKEMParams 'RKSProposed), E2ERatchetParams 'RKSProposed a) +generateRcvE2EParams :: (AlgorithmI a, DhAlgorithm a) => IORef ChaChaDRG -> VersionE2E -> PQSupport -> IO (PrivateKey a, PrivateKey a, Maybe (PrivRKEMParams 'RKSProposed), E2ERatchetParams 'RKSProposed a) generateRcvE2EParams g v = generateE2EParams g v . proposeKEM_ where proposeKEM_ :: PQSupport -> Maybe (UseKEM 'RKSProposed) @@ -399,7 +399,7 @@ generateRcvE2EParams g v = generateE2EParams g v . proposeKEM_ PQSupportOff -> Nothing -- used by party accepting connection, Alice in double-ratchet spec -generateSndE2EParams :: forall a. (AlgorithmI a, DhAlgorithm a) => TVar ChaChaDRG -> VersionE2E -> Maybe AUseKEM -> IO (PrivateKey a, PrivateKey a, Maybe APrivRKEMParams, AE2ERatchetParams a) +generateSndE2EParams :: forall a. (AlgorithmI a, DhAlgorithm a) => IORef ChaChaDRG -> VersionE2E -> Maybe AUseKEM -> IO (PrivateKey a, PrivateKey a, Maybe APrivRKEMParams, AE2ERatchetParams a) generateSndE2EParams g v = \case Nothing -> do (pk1, pk2, _, e2eParams) <- generateE2EParams g v Nothing @@ -911,7 +911,7 @@ maxSkip = 512 rcDecrypt :: forall a. (AlgorithmI a, DhAlgorithm a) => - TVar ChaChaDRG -> + IORef ChaChaDRG -> Ratchet a -> SkippedMsgKeys -> ByteString -> @@ -965,7 +965,7 @@ rcDecrypt g rc@Ratchet {rcRcv, rcAD = Str rcAD, rcVersion} rcMKSkipped msg' = do ratchetStep rc'@Ratchet {rcDHRs, rcRK, rcNHKs, rcNHKr, rcSupportKEM, rcVersion = rv} MsgHeader {msgDHRs, msgKEM} = do (kemSS, kemSS', rcKEM') <- pqRatchetStep rc' msgKEM -- state.DHRs = GENERATE_DH() - (_, rcDHRs') <- atomically $ generateKeyPair @a g + (_, rcDHRs') <- liftIO $ generateKeyPair @a g -- state.RK, state.CKr, state.NHKr = KDF_RK_HE(state.RK, DH(state.DHRs, state.DHRr) || ss) let (rcRK', rcCKr', rcNHKr') = rootKdf rcRK msgDHRs rcDHRs kemSS -- state.RK, state.CKs, state.NHKs = KDF_RK_HE(state.RK, DH(state.DHRs, state.DHRr) || state.PQRss) diff --git a/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings.hs b/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings.hs index 3b2238086..74d3a03e1 100644 --- a/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings.hs +++ b/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings.hs @@ -2,13 +2,13 @@ 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 import Data.ByteString (ByteString) +import Data.IORef import Database.SQLite.Simple.FromField import Database.SQLite.Simple.ToField import Foreign (nullPtr) @@ -36,7 +36,7 @@ unsafeRevealKEMSharedKey (KEMSharedKey scrubbed) = show (BA.convert scrubbed :: type KEMKeyPair = (KEMPublicKey, KEMSecretKey) -sntrup761Keypair :: TVar ChaChaDRG -> IO KEMKeyPair +sntrup761Keypair :: IORef ChaChaDRG -> IO KEMKeyPair sntrup761Keypair drg = bimap KEMPublicKey KEMSecretKey <$> BA.allocRet @@ -46,7 +46,7 @@ sntrup761Keypair drg = withDRG drg $ c_sntrup761_keypair pkPtr skPtr nullPtr ) -sntrup761Enc :: TVar ChaChaDRG -> KEMPublicKey -> IO (KEMCiphertext, KEMSharedKey) +sntrup761Enc :: IORef ChaChaDRG -> KEMPublicKey -> IO (KEMCiphertext, KEMSharedKey) sntrup761Enc drg (KEMPublicKey pk) = BA.withByteArray pk $ \pkPtr -> bimap KEMCiphertext KEMSharedKey diff --git a/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/RNG.hs b/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/RNG.hs index 322d583c9..1b0527423 100644 --- a/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/RNG.hs +++ b/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/RNG.hs @@ -8,17 +8,18 @@ import Control.Concurrent.STM import Control.Exception (bracket) import Crypto.Random (ChaChaDRG) import Data.ByteArray (ByteArrayAccess (copyByteArrayToPtr)) +import Data.IORef import Foreign import Foreign.C import qualified Simplex.Messaging.Crypto as C -withDRG :: TVar ChaChaDRG -> (FunPtr RNGFunc -> IO a) -> IO a +withDRG :: IORef ChaChaDRG -> (FunPtr RNGFunc -> IO a) -> IO a withDRG drg = bracket (createRNGFunc drg) freeHaskellFunPtr -createRNGFunc :: TVar ChaChaDRG -> IO (FunPtr RNGFunc) +createRNGFunc :: IORef ChaChaDRG -> IO (FunPtr RNGFunc) createRNGFunc drg = mkRNGFunc $ \_ctx sz buf -> do - bs <- atomically $ C.randomBytes (fromIntegral sz) drg + bs <- C.randomBytes (fromIntegral sz) drg copyByteArrayToPtr bs buf type RNGContext = () diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs index 21f551199..d4cda7a86 100644 --- a/src/Simplex/Messaging/Notifications/Server.hs +++ b/src/Simplex/Messaging/Notifications/Server.hs @@ -90,7 +90,7 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do runClient :: Transport c => C.APrivateSignKey -> TProxy c -> c -> M () runClient signKey _ h = do kh <- asks serverIdentity - ks <- atomically . C.generateKeyPair =<< asks random + ks <- liftIO . C.generateKeyPair =<< asks random NtfServerConfig {ntfServerVRange} <- asks config liftIO (runExceptT $ ntfServerHandshake signKey h ks kh ntfServerVRange) >>= \case Right th -> runNtfClientTransport th @@ -439,7 +439,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu NtfReqNew corrId (ANE SToken newTkn@(NewNtfTkn token _ dhPubKey)) -> do logDebug "TNEW - new token" st <- asks store - ks@(srvDhPubKey, srvDhPrivKey) <- atomically . C.generateKeyPair =<< asks random + ks@(srvDhPubKey, srvDhPrivKey) <- liftIO . C.generateKeyPair =<< asks random let dhSecret = C.dh' dhPubKey srvDhPrivKey tknId <- getId regCode <- getRegCode @@ -568,7 +568,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu getRegCode :: M NtfRegCode getRegCode = NtfRegCode <$> (randomBytes =<< asks (regCodeBytes . config)) randomBytes :: Int -> M ByteString - randomBytes n = atomically . C.randomBytes n =<< asks random + randomBytes n = liftIO . C.randomBytes n =<< asks random cancelInvervalNotifications :: NtfTokenId -> M () cancelInvervalNotifications tknId = atomically (TM.lookupDelete tknId intervalNotifiers) diff --git a/src/Simplex/Messaging/Notifications/Server/Env.hs b/src/Simplex/Messaging/Notifications/Server/Env.hs index dc0cb0a73..0c140e3d1 100644 --- a/src/Simplex/Messaging/Notifications/Server/Env.hs +++ b/src/Simplex/Messaging/Notifications/Server/Env.hs @@ -11,6 +11,7 @@ import Control.Concurrent (ThreadId) import Control.Concurrent.Async (Async) import Control.Logger.Simple import Crypto.Random +import Data.IORef (IORef) import Data.Int (Int64) import Data.List.NonEmpty (NonEmpty) import Data.Time.Clock (getCurrentTime) @@ -76,7 +77,7 @@ data NtfEnv = NtfEnv pushServer :: NtfPushServer, store :: NtfStore, storeLog :: Maybe (StoreLog 'WriteMode), - random :: TVar ChaChaDRG, + random :: IORef ChaChaDRG, tlsServerParams :: T.ServerParams, serverIdentity :: C.KeyHash, serverStats :: NtfServerStats @@ -102,7 +103,7 @@ data NtfSubscriber = NtfSubscriber smpAgent :: SMPClientAgent } -newNtfSubscriber :: Natural -> SMPClientAgentConfig -> TVar ChaChaDRG -> IO NtfSubscriber +newNtfSubscriber :: Natural -> SMPClientAgentConfig -> IORef ChaChaDRG -> IO NtfSubscriber newNtfSubscriber qSize smpAgentCfg random = do smpSubscribers <- TM.emptyIO newSubQ <- newTBQueueIO qSize diff --git a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs index 2632ff4b4..874833f78 100644 --- a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs +++ b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs @@ -33,6 +33,7 @@ import qualified Data.ByteString.Base64.URL as U import Data.ByteString.Builder (lazyByteString) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Lazy.Char8 as LB +import Data.IORef (IORef) import Data.Int (Int64) import Data.Map.Strict (Map) import Data.Maybe (isNothing) @@ -221,7 +222,7 @@ data APNSPushClient = APNSPushClient privateKey :: EC.PrivateKey, jwtHeader :: JWTHeader, jwtToken :: TVar (JWTToken, SignedJWTToken), - nonceDrg :: TVar ChaChaDRG, + nonceDrg :: IORef ChaChaDRG, apnsHost :: HostName, apnsCfg :: APNSPushClientConfig } @@ -339,7 +340,7 @@ $(JQ.deriveFromJSON defaultJSON ''APNSErrorResponse) apnsPushProviderClient :: APNSPushClient -> PushProviderClient apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknData {token = DeviceToken _ tknStr} pn = do http2 <- liftHTTPS2 $ getApnsHTTP2Client c - nonce <- atomically $ C.randomCbNonce nonceDrg + nonce <- liftIO $ C.randomCbNonce nonceDrg apnsNtf <- liftEither $ first PPCryptoError $ apnsNotification tkn nonce (paddedNtfLength apnsCfg) pn req <- liftIO $ apnsRequest c tknStr apnsNtf -- TODO when HTTP2 client is thread-safe, we can use sendRequestDirect diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index fb840fbb1..3b4718f86 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -44,7 +44,6 @@ import Control.Monad.Except import Control.Monad.IO.Unlift import Control.Monad.Reader import Control.Monad.Trans.Except -import Crypto.Random import Control.Monad.STM (retry) import Data.Bifunctor (first) import Data.ByteString.Base64 (encode) @@ -392,7 +391,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do runClient :: Transport c => C.APrivateSignKey -> TProxy c -> c -> M () runClient signKey tp h = do kh <- asks serverIdentity - ks <- atomically . C.generateKeyPair =<< asks random + ks <- liftIO . C.generateKeyPair =<< asks random ServerConfig {smpServerVRange, smpHandshakeTimeout} <- asks config labelMyThread $ "smp handshake for " <> transportName tp liftIO (timeout smpHandshakeTimeout . runExceptT $ smpServerHandshake signKey h ks kh smpServerVRange) >>= \case @@ -1017,7 +1016,7 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi where createQueue :: QueueStore -> RcvPublicAuthKey -> RcvPublicDhKey -> SubscriptionMode -> SenderCanSecure -> M (Transmission BrokerMsg) createQueue st recipientKey dhKey subMode sndSecure = time "NEW" $ do - (rcvPublicDhKey, privDhKey) <- atomically . C.generateKeyPair =<< asks random + (rcvPublicDhKey, privDhKey) <- liftIO . C.generateKeyPair =<< asks random let rcvDhSecret = C.dh' dhKey privDhKey qik (rcvId, sndId) = QIK {rcvId, sndId, rcvPublicDhKey, sndSecure} qRec (recipientId, senderId) = @@ -1074,7 +1073,7 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi addQueueNotifier_ :: QueueStore -> NtfPublicAuthKey -> RcvNtfPublicDhKey -> M (Transmission BrokerMsg) addQueueNotifier_ st notifierKey dhKey = time "NKEY" $ do - (rcvPublicDhKey, privDhKey) <- atomically . C.generateKeyPair =<< asks random + (rcvPublicDhKey, privDhKey) <- liftIO . C.generateKeyPair =<< asks random let rcvNtfDhSecret = C.dh' dhKey privDhKey (corrId,entId,) <$> addNotifierRetry 3 rcvPublicDhKey rcvNtfDhSecret where @@ -1255,15 +1254,7 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi Just (msg, wasEmpty) -> time "SEND ok" $ do when wasEmpty $ tryDeliverMessage msg when (notification msgFlags) $ do - forM_ (notifier qr) $ \ntf -> do - asks random >>= atomically . trySendNotification ntf msg >>= \case - Nothing -> do - incStat $ msgNtfNoSub stats - logWarn "No notification subscription" - Just False -> do - incStat $ msgNtfLost stats - logWarn "Dropped message notification" - Just True -> incStat $ msgNtfs stats + mapM_ (`trySendNotification` msg) (notifier qr) incStat $ msgSentNtf stats liftIO $ updatePeriodStats (activeQueuesNtf stats) (recipientId qr) incStat $ msgSent stats @@ -1335,23 +1326,35 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi deliver q s writeTVar st NoSub - trySendNotification :: NtfCreds -> Message -> TVar ChaChaDRG -> STM (Maybe Bool) - trySendNotification NtfCreds {notifierId, rcvNtfDhSecret} msg ntfNonceDrg = - mapM (writeNtf notifierId msg rcvNtfDhSecret ntfNonceDrg) =<< TM.lookup notifierId notifiers + trySendNotification :: NtfCreds -> Message -> M () + trySendNotification NtfCreds {notifierId, rcvNtfDhSecret} msg = do + stats <- asks serverStats + liftIO (TM.lookupIO notifierId notifiers) >>= \case + Nothing -> do + incStat $ msgNtfNoSub stats + logWarn "No notification subscription" + Just ntfClnt -> do + let updateStats True = incStat $ msgNtfs stats + updateStats _ = do + incStat $ msgNtfLost stats + logWarn "Dropped message notification" + writeNtf notifierId msg rcvNtfDhSecret ntfClnt >>= mapM_ updateStats - writeNtf :: NotifierId -> Message -> RcvNtfDhSecret -> TVar ChaChaDRG -> Client -> STM Bool - writeNtf nId msg rcvNtfDhSecret ntfNonceDrg Client {sndQ = q} = - ifM (isFullTBQueue q) (pure False) (sendNtf $> True) - where - sendNtf = case msg of - Message {msgId, msgTs} -> do - (nmsgNonce, encNMsgMeta) <- mkMessageNotification msgId msgTs rcvNtfDhSecret ntfNonceDrg - writeTBQueue q [(CorrId "", nId, NMSG nmsgNonce encNMsgMeta)] - _ -> pure () + writeNtf :: NotifierId -> Message -> RcvNtfDhSecret -> Client -> M (Maybe Bool) + writeNtf nId msg rcvNtfDhSecret Client {sndQ = q} = case msg of + Message {msgId, msgTs} -> Just <$> do + (nmsgNonce, encNMsgMeta) <- mkMessageNotification msgId msgTs rcvNtfDhSecret + -- must be in one STM transaction to avoid the queue becoming full between the check and writing + atomically $ + ifM + (isFullTBQueue q) + (pure $ False) + (True <$ writeTBQueue q [(CorrId "", nId, NMSG nmsgNonce encNMsgMeta)]) + _ -> pure Nothing - mkMessageNotification :: ByteString -> SystemTime -> RcvNtfDhSecret -> TVar ChaChaDRG -> STM (C.CbNonce, EncNMsgMeta) - mkMessageNotification msgId msgTs rcvNtfDhSecret ntfNonceDrg = do - cbNonce <- C.randomCbNonce ntfNonceDrg + mkMessageNotification :: ByteString -> SystemTime -> RcvNtfDhSecret -> M (C.CbNonce, EncNMsgMeta) + mkMessageNotification msgId msgTs rcvNtfDhSecret = do + cbNonce <- liftIO . C.randomCbNonce =<< asks random let msgMeta = NMsgMeta {msgId, msgTs} encNMsgMeta = C.cbEncrypt rcvNtfDhSecret cbNonce (smpEncode msgMeta) 128 pure . (cbNonce,) $ fromRight "" encNMsgMeta @@ -1518,7 +1521,7 @@ timed name qId a = do sec = 1000_000000 randomId :: Int -> M ByteString -randomId n = atomically . C.randomBytes n =<< asks random +randomId n = liftIO . C.randomBytes n =<< asks random saveServerMessages :: Bool -> M () saveServerMessages keepMsgs = asks (storeMsgsFile . config) >>= mapM_ saveMessages diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs index 49b6f61ed..6f0e287c6 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -124,7 +124,7 @@ data Env = Env serverIdentity :: KeyHash, queueStore :: QueueStore, msgStore :: STMMsgStore, - random :: TVar ChaChaDRG, + random :: IORef ChaChaDRG, storeLog :: Maybe (StoreLog 'WriteMode), tlsServerParams :: T.ServerParams, serverStats :: ServerStats, @@ -267,7 +267,7 @@ newEnv config@ServerConfig {caCertificateFile, certificateFile, privateKeyFile, | isJust (storeMsgsFile config) = SPMMessages | otherwise = SPMQueues -newSMPProxyAgent :: SMPClientAgentConfig -> TVar ChaChaDRG -> IO ProxyAgent +newSMPProxyAgent :: SMPClientAgentConfig -> IORef ChaChaDRG -> IO ProxyAgent newSMPProxyAgent smpAgentCfg random = do smpAgent <- newSMPClientAgent smpAgentCfg random pure ProxyAgent {smpAgent} diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index e06bdd3ee..a4da43683 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -11,7 +11,6 @@ module Simplex.Messaging.Server.Main where -import Control.Concurrent.STM import Control.Logger.Simple import Control.Monad (void, when, (<$!>)) import Data.ByteString.Char8 (ByteString) @@ -135,7 +134,7 @@ smpServerCLI_ generateSite serveStaticFiles cfgPath logPath = where createServerPassword = \case ServerPassword s -> pure s - SPRandom -> BasicAuth . strEncode <$> (atomically . C.randomBytes 32 =<< C.newRandom) + SPRandom -> BasicAuth . strEncode <$> (C.randomBytes 32 =<< C.newRandom) iniFileContent host basicAuth sourceCode' = informationIniContent sourceCode' <> "[STORE_LOG]\n\ diff --git a/src/Simplex/Messaging/Transport/Credentials.hs b/src/Simplex/Messaging/Transport/Credentials.hs index 90089f9ef..03deb6275 100644 --- a/src/Simplex/Messaging/Transport/Credentials.hs +++ b/src/Simplex/Messaging/Transport/Credentials.hs @@ -9,11 +9,11 @@ module Simplex.Messaging.Transport.Credentials ) where -import Control.Concurrent.STM import Crypto.Random (ChaChaDRG) import Data.ASN1.Types (getObjectID) import Data.ASN1.Types.String (ASN1StringEncoding (UTF8)) import Data.Hourglass (Hours (..), timeAdd) +import Data.IORef import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as L import Data.Text (Text) @@ -47,9 +47,9 @@ privateToTls (C.APrivateSignKey _ k) = case k of type Credentials = (C.ASignatureKeyPair, X509.SignedCertificate) -genCredentials :: TVar ChaChaDRG -> Maybe Credentials -> (Hours, Hours) -> Text -> IO Credentials +genCredentials :: IORef ChaChaDRG -> Maybe Credentials -> (Hours, Hours) -> Text -> IO Credentials genCredentials g parent (before, after) subjectName = do - subjectKeys <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + subjectKeys <- C.generateSignatureKeyPair C.SEd25519 g let (issuerKeys, issuer) = case parent of Nothing -> (subjectKeys, subject) -- self-signed Just (keys, cert) -> (keys, X509.certSubjectDN . X509.signedObject $ X509.getSigned cert) diff --git a/src/Simplex/Messaging/Util.hs b/src/Simplex/Messaging/Util.hs index 9ab881e83..dffc18c9a 100644 --- a/src/Simplex/Messaging/Util.hs +++ b/src/Simplex/Messaging/Util.hs @@ -23,6 +23,7 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8With, encodeUtf8) import Data.Time (NominalDiffTime) +import Data.Tuple (swap) import GHC.Conc (labelThread, myThreadId, threadDelay) import UnliftIO hiding (atomicModifyIORef') import qualified UnliftIO.Exception as UE @@ -177,6 +178,11 @@ labelMyThread label = liftIO $ myThreadId >>= (`labelThread` label) atomicModifyIORef'_ :: IORef a -> (a -> a) -> IO () atomicModifyIORef'_ r f = atomicModifyIORef' r $ \v -> (f v, ()) +{-# INLINE atomicModifyIORef'_ #-} + +atomicStateIORef :: IORef s -> (s -> (a, s)) -> IO a +atomicStateIORef r f = atomicModifyIORef' r $ swap . f +{-# INLINE atomicStateIORef #-} encodeJSON :: ToJSON a => a -> Text encodeJSON = safeDecodeUtf8 . LB.toStrict . J.encode diff --git a/src/Simplex/RemoteControl/Client.hs b/src/Simplex/RemoteControl/Client.hs index 381397c6e..55d85f0a5 100644 --- a/src/Simplex/RemoteControl/Client.hs +++ b/src/Simplex/RemoteControl/Client.hs @@ -78,10 +78,10 @@ helloBlockSize = 12288 encInvitationSize :: Int encInvitationSize = 900 -newRCHostPairing :: TVar ChaChaDRG -> IO RCHostPairing +newRCHostPairing :: IORef ChaChaDRG -> IO RCHostPairing newRCHostPairing drg = do ((_, caKey), caCert) <- genCredentials drg Nothing (-25, 24 * 999999) "ca" - (_, idPrivKey) <- atomically $ C.generateKeyPair drg + (_, idPrivKey) <- C.generateKeyPair drg pure RCHostPairing {caKey, caCert, idPrivKey, knownHost = Nothing} data RCHostClient = RCHostClient @@ -98,12 +98,12 @@ data RCHClient_ = RCHClient_ type RCHostConnection = (NonEmpty RCCtrlAddress, RCSignedInvitation, RCHostClient, RCStepTMVar (SessionCode, TLS, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing))) -connectRCHost :: TVar ChaChaDRG -> RCHostPairing -> J.Value -> Bool -> Maybe RCCtrlAddress -> Maybe Word16 -> ExceptT RCErrorType IO RCHostConnection +connectRCHost :: IORef ChaChaDRG -> RCHostPairing -> J.Value -> Bool -> Maybe RCCtrlAddress -> Maybe Word16 -> ExceptT RCErrorType IO RCHostConnection connectRCHost drg pairing@RCHostPairing {caKey, caCert, idPrivKey, knownHost} ctrlAppInfo multicast rcAddrPrefs_ port_ = do r <- newEmptyTMVarIO found@(RCCtrlAddress {address} :| _) <- findCtrlAddress c@RCHClient_ {startedPort, announcer} <- liftIO mkClient - hostKeys <- atomically genHostKeys + hostKeys <- liftIO genHostKeys action <- liftIO $ runClient c r hostKeys -- wait for the port to make invitation portNum <- atomically $ readTMVar startedPort @@ -163,7 +163,7 @@ connectRCHost drg pairing@RCHostPairing {caKey, caCert, idPrivKey, knownHost} ct _ -> pure $ TLS.CertificateUsageReject TLS.CertificateRejectUnknownCA } - genHostKeys :: STM RCHostKeys + genHostKeys :: IO RCHostKeys genHostKeys = do sessKeys <- C.generateKeyPair drg dhKeys <- C.generateKeyPair drg @@ -185,7 +185,7 @@ connectRCHost drg pairing@RCHostPairing {caKey, caCert, idPrivKey, knownHost} ct } pure $ signInvitation (snd sessKeys) idPrivKey inv -genTLSCredentials :: TVar ChaChaDRG -> C.APrivateSignKey -> C.SignedCertificate -> IO TLS.Credentials +genTLSCredentials :: IORef ChaChaDRG -> C.APrivateSignKey -> C.SignedCertificate -> IO TLS.Credentials genTLSCredentials drg caKey caCert = do let caCreds = (C.signatureKeyPair caKey, caCert) leaf <- genCredentials drg (Just caCreds) (0, 24 * 999999) "localhost" -- session-signing cert @@ -202,7 +202,7 @@ cancelHostClient RCHostClient {action, client_ = RCHClient_ {announcer, endSessi atomically (tryTakeTMVar announcer) >>= mapM_ uninterruptibleCancel uninterruptibleCancel action -prepareHostSession :: TVar ChaChaDRG -> C.KeyHash -> RCHostPairing -> RCHostKeys -> RCHostEncHello -> ExceptT RCErrorType IO (RCCtrlEncHello, HostSessKeys, RCHostHello, RCHostPairing) +prepareHostSession :: IORef ChaChaDRG -> C.KeyHash -> RCHostPairing -> RCHostKeys -> RCHostEncHello -> ExceptT RCErrorType IO (RCCtrlEncHello, HostSessKeys, RCHostHello, RCHostPairing) prepareHostSession drg tlsHostFingerprint @@ -220,7 +220,7 @@ prepareHostSession knownHost' <- updateKnownHost ca dhPubKey let ctrlHello = RCCtrlHello {} -- TODO send error response if something fails - nonce' <- liftIO . atomically $ C.randomCbNonce drg + nonce' <- liftIO $ C.randomCbNonce 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'}) @@ -246,7 +246,7 @@ data RCCClient_ = RCCClient_ type RCCtrlConnection = (RCCtrlClient, RCStepTMVar (SessionCode, TLS, RCStepTMVar (RCCtrlSession, RCCtrlPairing))) -- app should determine whether it is a new or known pairing based on CA fingerprint in the invitation -connectRCCtrl :: TVar ChaChaDRG -> RCVerifiedInvitation -> Maybe RCCtrlPairing -> J.Value -> ExceptT RCErrorType IO RCCtrlConnection +connectRCCtrl :: IORef 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 @@ -254,15 +254,15 @@ connectRCCtrl drg (RCVerifiedInvitation inv@RCInvitation {ca, idkey}) pairing_ h newCtrlPairing :: IO RCCtrlPairing newCtrlPairing = do ((_, caKey), caCert) <- genCredentials drg Nothing (0, 24 * 999999) "ca" - (_, dhPrivKey) <- atomically $ C.generateKeyPair drg + (_, dhPrivKey) <- liftIO $ C.generateKeyPair drg pure RCCtrlPairing {caKey, caCert, ctrlFingerprint = ca, idPubKey = idkey, dhPrivKey, prevDhPrivKey = Nothing} updateCtrlPairing :: RCCtrlPairing -> ExceptT RCErrorType IO RCCtrlPairing updateCtrlPairing pairing@RCCtrlPairing {ctrlFingerprint, idPubKey, dhPrivKey = currDhPrivKey} = do unless (ca == ctrlFingerprint && idPubKey == idkey) $ throwE RCEIdentity - (_, dhPrivKey) <- atomically $ C.generateKeyPair drg + (_, dhPrivKey) <- liftIO $ C.generateKeyPair drg pure pairing {dhPrivKey, prevDhPrivKey = Just currDhPrivKey} -connectRCCtrl_ :: TVar ChaChaDRG -> RCCtrlPairing -> RCInvitation -> J.Value -> ExceptT RCErrorType IO RCCtrlConnection +connectRCCtrl_ :: IORef 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 @@ -324,7 +324,7 @@ receiveRCPacket tls = do b' <- liftEitherWith (const RCEBlockSize) $ C.unPad b liftEitherWith RCESyntax $ smpDecode b' -prepareHostHello :: TVar ChaChaDRG -> RCCtrlPairing -> RCInvitation -> J.Value -> ExceptT RCErrorType IO (C.DhSecretX25519, KEMSecretKey, RCHostEncHello) +prepareHostHello :: IORef ChaChaDRG -> RCCtrlPairing -> RCInvitation -> J.Value -> ExceptT RCErrorType IO (C.DhSecretX25519, KEMSecretKey, RCHostEncHello) prepareHostHello drg RCCtrlPairing {caCert, dhPrivKey} @@ -334,7 +334,7 @@ prepareHostHello case compatibleVersion v supportedRCPVRange of Nothing -> throwE RCEVersion Just (Compatible v') -> do - nonce <- liftIO . atomically $ C.randomCbNonce drg + nonce <- liftIO . liftIO $ C.randomCbNonce drg (kemPubKey, kemPrivKey) <- liftIO $ sntrup761Keypair drg let helloBody = RCHostHello {v = v', ca = certFingerprint caCert, app = hostAppInfo, kem = kemPubKey} sharedKey = C.dh' dhPubKey dhPrivKey @@ -362,11 +362,11 @@ prepareCtrlSession -- * Multicast discovery -announceRC :: TVar ChaChaDRG -> Int -> C.PrivateKeyEd25519 -> C.PublicKeyX25519 -> RCHostKeys -> RCInvitation -> ExceptT RCErrorType IO () +announceRC :: IORef ChaChaDRG -> Int -> C.PrivateKeyEd25519 -> C.PublicKeyX25519 -> RCHostKeys -> RCInvitation -> ExceptT RCErrorType IO () announceRC drg maxCount idPrivKey knownDhPub RCHostKeys {sessKeys, dhKeys} inv = ExceptT $ withSender $ \sender -> runExceptT $ do replicateM_ maxCount $ do logDebug "Announcing..." - nonce <- atomically $ C.randomCbNonce drg + nonce <- liftIO $ C.randomCbNonce drg encInvitation <- liftEitherWith (const RCEEncrypt) $ C.cbEncrypt sharedKey nonce sigInvitation encInvitationSize liftIO . UDP.send sender $ smpEncode RCEncInvitation {dhPubKey, nonce, encInvitation} threadDelay 1000000 @@ -426,9 +426,9 @@ cancelCtrlClient RCCtrlClient {action, client_ = RCCClient_ {endSession}} = do -- * Session encryption -rcEncryptBody :: TVar ChaChaDRG -> KEMHybridSecret -> LazyByteString -> ExceptT RCErrorType IO (C.CbNonce, LazyByteString) +rcEncryptBody :: IORef ChaChaDRG -> KEMHybridSecret -> LazyByteString -> ExceptT RCErrorType IO (C.CbNonce, LazyByteString) rcEncryptBody drg hybridKey s = do - nonce <- atomically $ C.randomCbNonce drg + nonce <- liftIO $ C.randomCbNonce drg let len = LB.length s ct <- liftEitherWith (const RCEEncrypt) $ LC.kcbEncryptTailTag hybridKey nonce s len (len + 8) pure (nonce, ct) diff --git a/tests/AgentTests/DoubleRatchetTests.hs b/tests/AgentTests/DoubleRatchetTests.hs index c3fbf01e8..78056d84c 100644 --- a/tests/AgentTests/DoubleRatchetTests.hs +++ b/tests/AgentTests/DoubleRatchetTests.hs @@ -22,6 +22,7 @@ import Data.Aeson (FromJSON, ToJSON, (.=)) import qualified Data.Aeson as J import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B +import Data.IORef (IORef) import qualified Data.Map.Strict as M import Data.Type.Equality import Simplex.Messaging.Crypto (Algorithm (..), AlgorithmI, CryptoError, DhAlgorithm) @@ -99,7 +100,7 @@ fullMsgLen Ratchet {rcSupportKEM, rcVersion} = headerLenLength + fullHeaderLen v testMessageHeader :: forall a. AlgorithmI a => VersionE2E -> C.SAlgorithm a -> Expectation testMessageHeader v _ = do - (k, _) <- atomically . C.generateKeyPair @a =<< C.newRandom + (k, _) <- C.generateKeyPair @a =<< C.newRandom let hdr = MsgHeader {msgMaxVersion = v, msgDHRs = k, msgKEM = Nothing, msgPN = 0, msgNs = 0} parseAll (msgHeaderP v) (encodeMsgHeader v hdr) `shouldBe` Right hdr @@ -117,7 +118,7 @@ testKEMParams = do testMessageHeaderKEM :: forall a. AlgorithmI a => C.SAlgorithm a -> Expectation testMessageHeaderKEM _ = do g <- C.newRandom - (k, _) <- atomically $ C.generateKeyPair @a g + (k, _) <- C.generateKeyPair @a g (kem, _) <- sntrup761Keypair g let msgMaxVersion = max pqRatchetE2EEncryptVersion currentE2EEncryptVersion msgKEM = Just . ARKP SRKSProposed $ RKParamsProposed kem @@ -132,15 +133,15 @@ testMessageHeaderKEM _ = do pattern Decrypted :: ByteString -> Either CryptoError (Either CryptoError ByteString) pattern Decrypted msg <- Right (Right msg) -type Encrypt a = TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either CryptoError ByteString) +type Encrypt a = TVar (IORef ChaChaDRG, Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either CryptoError ByteString) -type Decrypt a = TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either CryptoError (Either CryptoError ByteString)) +type Decrypt a = TVar (IORef ChaChaDRG, Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either CryptoError (Either CryptoError ByteString)) -type EncryptDecryptSpec a = (TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys), ByteString) -> TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> Expectation +type EncryptDecryptSpec a = (TVar (IORef ChaChaDRG, Ratchet a, SkippedMsgKeys), ByteString) -> TVar (IORef ChaChaDRG, Ratchet a, SkippedMsgKeys) -> Expectation type TestRatchets a = - TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> - TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> + TVar (IORef ChaChaDRG, Ratchet a, SkippedMsgKeys) -> + TVar (IORef ChaChaDRG, Ratchet a, SkippedMsgKeys) -> Encrypt a -> Decrypt a -> EncryptDecryptSpec a -> @@ -167,7 +168,7 @@ instance Eq ARKEMParams where deriving instance Eq (MsgHeader a) -initRatchetKEM :: (AlgorithmI a, DhAlgorithm a) => TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> IO () +initRatchetKEM :: (AlgorithmI a, DhAlgorithm a) => TVar (IORef ChaChaDRG, Ratchet a, SkippedMsgKeys) -> TVar (IORef ChaChaDRG, Ratchet a, SkippedMsgKeys) -> IO () initRatchetKEM s r = encryptDecrypt (Just $ PQEncOn) (const ()) (const ()) (s, "initialising ratchet") r testEncryptDecrypt :: (AlgorithmI a, DhAlgorithm a) => Bool -> TestRatchets a @@ -338,7 +339,7 @@ testEnableKEMStrict alice bob _ _ _ = do testKeyJSON :: forall a. AlgorithmI a => C.SAlgorithm a -> IO () testKeyJSON _ = do - (k, pk) <- atomically . C.generateKeyPair @a =<< C.newRandom + (k, pk) <- C.generateKeyPair @a =<< C.newRandom testEncodeDecode k testEncodeDecode pk @@ -519,7 +520,7 @@ initRatchets = do (pkAlice1, pkAlice2, _pKem@Nothing, e2eAlice) <- liftIO $ generateRcvE2EParams g v PQSupportOff Right paramsBob <- pure $ pqX3dhSnd pkBob1 pkBob2 Nothing e2eAlice Right paramsAlice <- runExceptT $ pqX3dhRcv pkAlice1 pkAlice2 Nothing e2eBob - (_, pkBob3) <- atomically $ C.generateKeyPair g + (_, pkBob3) <- C.generateKeyPair g let vs = testRatchetVersions bob = initSndRatchet vs (C.publicKey pkAlice2) pkBob3 paramsBob alice = initRcvRatchet vs pkAlice2 paramsAlice PQSupportOff @@ -536,7 +537,7 @@ initRatchetsKEMProposed = do (pkBob1, pkBob2, pKemParams_@(Just _), AE2ERatchetParams _ e2eBob) <- liftIO $ generateSndE2EParams g v (Just useKem) Right paramsBob <- pure $ pqX3dhSnd pkBob1 pkBob2 pKemParams_ e2eAlice Right paramsAlice <- runExceptT $ pqX3dhRcv pkAlice1 pkAlice2 Nothing e2eBob - (_, pkBob3) <- atomically $ C.generateKeyPair g + (_, pkBob3) <- C.generateKeyPair g let vs = testRatchetVersions bob = initSndRatchet vs (C.publicKey pkAlice2) pkBob3 paramsBob alice = initRcvRatchet vs pkAlice2 paramsAlice PQSupportOn @@ -554,7 +555,7 @@ initRatchetsKEMAccepted = do (pkBob1, pkBob2, pKemParams_@(Just _), AE2ERatchetParams _ e2eBob) <- liftIO $ generateSndE2EParams g v (Just useKem) Right paramsBob <- pure $ pqX3dhSnd pkBob1 pkBob2 pKemParams_ e2eAlice Right paramsAlice <- runExceptT $ pqX3dhRcv pkAlice1 pkAlice2 pKem_ e2eBob - (_, pkBob3) <- atomically $ C.generateKeyPair g + (_, pkBob3) <- C.generateKeyPair g let vs = testRatchetVersions bob = initSndRatchet vs (C.publicKey pkAlice2) pkBob3 paramsBob alice = initRcvRatchet vs pkAlice2 paramsAlice PQSupportOn @@ -571,7 +572,7 @@ initRatchetsKEMProposedAgain = do (pkBob1, pkBob2, pKemParams_@(Just _), AE2ERatchetParams _ e2eBob) <- liftIO $ generateSndE2EParams g v (Just useKem) Right paramsBob <- pure $ pqX3dhSnd pkBob1 pkBob2 pKemParams_ e2eAlice Right paramsAlice <- runExceptT $ pqX3dhRcv pkAlice1 pkAlice2 pKem_ e2eBob - (_, pkBob3) <- atomically $ C.generateKeyPair g + (_, pkBob3) <- C.generateKeyPair g let vs = testRatchetVersions bob = initSndRatchet vs (C.publicKey pkAlice2) pkBob3 paramsBob alice = initRcvRatchet vs pkAlice2 paramsAlice PQSupportOn @@ -582,7 +583,7 @@ testRatchetVersions = let v = maxVersion supportedE2EEncryptVRange in RatchetVersions v v -encrypt_ :: AlgorithmI a => Maybe PQEncryption -> (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either CryptoError (ByteString, Ratchet a, SkippedMsgDiff)) +encrypt_ :: AlgorithmI a => Maybe PQEncryption -> (IORef ChaChaDRG, Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either CryptoError (ByteString, Ratchet a, SkippedMsgDiff)) encrypt_ pqEnc_ (_, rc, _) msg = -- print msg >> runExceptT (rcEncrypt rc paddedMsgLen msg pqEnc_ currentE2EEncryptVersion) @@ -592,7 +593,7 @@ encrypt_ pqEnc_ (_, rc, _) msg = B.length msg' `shouldBe` fullMsgLen rc' pure $ Right (msg', rc', SMDNoChange) -decrypt_ :: (AlgorithmI a, DhAlgorithm a) => (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either CryptoError (Either CryptoError ByteString, Ratchet a, SkippedMsgDiff)) +decrypt_ :: (AlgorithmI a, DhAlgorithm a) => (IORef ChaChaDRG, Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either CryptoError (Either CryptoError ByteString, Ratchet a, SkippedMsgDiff)) decrypt_ (g, rc, smks) msg = runExceptT $ rcDecrypt g rc smks msg encrypt' :: AlgorithmI a => (Ratchet a -> ()) -> Encrypt a @@ -619,9 +620,9 @@ hasRcvKEM _ = error "rcv ratchet has no KEM" withTVar :: AlgorithmI a => - ((TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either e (r, Ratchet a, SkippedMsgDiff))) -> + ((IORef ChaChaDRG, Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either e (r, Ratchet a, SkippedMsgDiff))) -> (Ratchet a -> ()) -> - TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> + TVar (IORef ChaChaDRG, Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either e r) withTVar op valid rcVar msg = do diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 29725f96a..0b4ecc86a 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -718,7 +718,7 @@ testEnablePQEncryption = (a, 2, "msg 1") \#>\ b (b, 3, "msg 2") \#>\ a -- 45 bytes is used by agent message envelope inside double ratchet message envelope - let largeMsg g' pqEnc = atomically $ C.randomBytes (e2eEncAgentMsgLength pqdrSMPAgentVersion pqEnc - 45) g' + let largeMsg g' pqEnc = liftIO $ C.randomBytes (e2eEncAgentMsgLength pqdrSMPAgentVersion pqEnc - 45) g' lrg <- largeMsg g PQSupportOff (a, 4, lrg) \#>\ b (b, 5, lrg) \#>\ a diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index f876603f5..c6bad23e5 100644 --- a/tests/AgentTests/SQLiteTests.hs +++ b/tests/AgentTests/SQLiteTests.hs @@ -18,13 +18,13 @@ module AgentTests.SQLiteTests (storeTests) where import AgentTests.EqInstances () import Control.Concurrent.Async (concurrently_) import Control.Concurrent.MVar -import Control.Concurrent.STM import Control.Exception (SomeException) import Control.Monad (replicateM_) import Control.Monad.Trans.Except import Crypto.Random (ChaChaDRG) import Data.ByteArray (ScrubbedBytes) import Data.ByteString.Char8 (ByteString) +import Data.IORef (IORef) import Data.List (isInfixOf) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) @@ -254,7 +254,7 @@ sndQueue1 = smpClientVersion = VersionSMPC 1 } -createRcvConn :: DB.Connection -> TVar ChaChaDRG -> ConnData -> NewRcvQueue -> SConnectionMode c -> IO (Either StoreError (ConnId, RcvQueue)) +createRcvConn :: DB.Connection -> IORef ChaChaDRG -> ConnData -> NewRcvQueue -> SConnectionMode c -> IO (Either StoreError (ConnId, RcvQueue)) createRcvConn db g cData rq cMode = runExceptT $ do connId <- ExceptT $ createNewConn db g cData cMode rq' <- ExceptT $ updateNewConnRcv db connId rq diff --git a/tests/CoreTests/BatchingTests.hs b/tests/CoreTests/BatchingTests.hs index 023f6de04..e39f8ea6c 100644 --- a/tests/CoreTests/BatchingTests.hs +++ b/tests/CoreTests/BatchingTests.hs @@ -8,11 +8,11 @@ module CoreTests.BatchingTests (batchingTests) where -import Control.Concurrent.STM import Control.Monad import Crypto.Random (ChaChaDRG) import qualified Data.ByteString as B import Data.ByteString.Char8 (ByteString) +import Data.IORef (IORef) import qualified Data.List.NonEmpty as L import qualified Data.X509 as X import qualified Data.X509.CertificateStore as XS @@ -47,7 +47,7 @@ batchingTests = do testBatchSubscriptions :: IO () testBatchSubscriptions = do - sessId <- atomically . C.randomBytes 32 =<< C.newRandom + sessId <- C.randomBytes 32 =<< C.newRandom subs <- replicateM 250 $ randomSUB sessId let batches1 = batchTransmissions False smpBlockSize $ L.fromList subs all lenOk1 batches1 `shouldBe` True @@ -60,7 +60,7 @@ testBatchSubscriptions = do testBatchSubscriptionsV7 :: IO () testBatchSubscriptionsV7 = do - sessId <- atomically . C.randomBytes 32 =<< C.newRandom + sessId <- C.randomBytes 32 =<< C.newRandom subs <- replicateM 300 $ randomSUBv7 sessId let batches1 = batchTransmissions False smpBlockSize $ L.fromList subs all lenOk1 batches1 `shouldBe` True @@ -73,7 +73,7 @@ testBatchSubscriptionsV7 = do testBatchWithMessage :: IO () testBatchWithMessage = do - sessId <- atomically . C.randomBytes 32 =<< C.newRandom + sessId <- C.randomBytes 32 =<< C.newRandom subs1 <- replicateM 60 $ randomSUB sessId send <- randomSEND sessId 8000 subs2 <- replicateM 40 $ randomSUB sessId @@ -89,7 +89,7 @@ testBatchWithMessage = do testBatchWithMessageV7 :: IO () testBatchWithMessageV7 = do - sessId <- atomically . C.randomBytes 32 =<< C.newRandom + sessId <- C.randomBytes 32 =<< C.newRandom subs1 <- replicateM 60 $ randomSUBv7 sessId send <- randomSENDv7 sessId 8000 subs2 <- replicateM 40 $ randomSUBv7 sessId @@ -105,7 +105,7 @@ testBatchWithMessageV7 = do testBatchWithLargeMessage :: IO () testBatchWithLargeMessage = do - sessId <- atomically . C.randomBytes 32 =<< C.newRandom + sessId <- C.randomBytes 32 =<< C.newRandom subs1 <- replicateM 50 $ randomSUB sessId send <- randomSEND sessId 17000 subs2 <- replicateM 150 $ randomSUB sessId @@ -124,7 +124,7 @@ testBatchWithLargeMessage = do testBatchWithLargeMessageV7 :: IO () testBatchWithLargeMessageV7 = do - sessId <- atomically . C.randomBytes 32 =<< C.newRandom + sessId <- C.randomBytes 32 =<< C.newRandom subs1 <- replicateM 60 $ randomSUBv7 sessId send <- randomSENDv7 sessId 17000 subs2 <- replicateM 150 $ randomSUBv7 sessId @@ -276,14 +276,14 @@ testClientBatchWithLargeMessageV7 = do testClientStub :: IO (ProtocolClient SMPVersion ErrorType BrokerMsg) testClientStub = do g <- C.newRandom - sessId <- atomically $ C.randomBytes 32 g + sessId <- C.randomBytes 32 g smpClientStub g sessId subModeSMPVersion Nothing clientStubV7 :: IO (ProtocolClient SMPVersion ErrorType BrokerMsg) clientStubV7 = do g <- C.newRandom - sessId <- atomically $ C.randomBytes 32 g - (rKey, _) <- atomically $ C.generateAuthKeyPair C.SX25519 g + sessId <- C.randomBytes 32 g + (rKey, _) <- C.generateAuthKeyPair C.SX25519 g thAuth_ <- testTHandleAuth authCmdsSMPVersion g rKey smpClientStub g sessId authCmdsSMPVersion thAuth_ @@ -296,9 +296,9 @@ randomSUBv7 = randomSUB_ C.SEd25519 authCmdsSMPVersion randomSUB_ :: (C.AlgorithmI a, C.AuthAlgorithm a) => C.SAlgorithm a -> VersionSMP -> ByteString -> IO (Either TransportError (Maybe TransmissionAuth, ByteString)) randomSUB_ a v sessId = do g <- C.newRandom - rId <- atomically $ C.randomBytes 24 g - nonce@(C.CbNonce corrId) <- atomically $ C.randomCbNonce g - (rKey, rpKey) <- atomically $ C.generateAuthKeyPair a g + rId <- C.randomBytes 24 g + nonce@(C.CbNonce corrId) <- C.randomCbNonce g + (rKey, rpKey) <- C.generateAuthKeyPair a g thAuth_ <- testTHandleAuth v g rKey let thParams = testTHandleParams v sessId TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (CorrId corrId, rId, Cmd SRecipient SUB) @@ -313,14 +313,14 @@ randomSUBCmdV7 = randomSUBCmd_ C.SEd25519 -- same as v6 randomSUBCmd_ :: (C.AlgorithmI a, C.AuthAlgorithm a) => C.SAlgorithm a -> ProtocolClient SMPVersion ErrorType BrokerMsg -> IO (PCTransmission ErrorType BrokerMsg) randomSUBCmd_ a c = do g <- C.newRandom - rId <- atomically $ C.randomBytes 24 g - (_, rpKey) <- atomically $ C.generateAuthKeyPair a g + rId <- C.randomBytes 24 g + (_, rpKey) <- C.generateAuthKeyPair a g mkTransmission c (Just rpKey, rId, Cmd SRecipient SUB) randomENDCmd :: IO (Transmission BrokerMsg) randomENDCmd = do g <- C.newRandom - rId <- atomically $ C.randomBytes 24 g + rId <- C.randomBytes 24 g pure (CorrId "", rId, END) randomSEND :: ByteString -> Int -> IO (Either TransportError (Maybe TransmissionAuth, ByteString)) @@ -332,11 +332,11 @@ randomSENDv7 = randomSEND_ C.SX25519 authCmdsSMPVersion randomSEND_ :: (C.AlgorithmI a, C.AuthAlgorithm a) => C.SAlgorithm a -> VersionSMP -> ByteString -> Int -> IO (Either TransportError (Maybe TransmissionAuth, ByteString)) randomSEND_ a v sessId len = do g <- C.newRandom - sId <- atomically $ C.randomBytes 24 g - nonce@(C.CbNonce corrId) <- atomically $ C.randomCbNonce g - (sKey, spKey) <- atomically $ C.generateAuthKeyPair a g + sId <- C.randomBytes 24 g + nonce@(C.CbNonce corrId) <- C.randomCbNonce g + (sKey, spKey) <- C.generateAuthKeyPair a g thAuth_ <- testTHandleAuth v g sKey - msg <- atomically $ C.randomBytes len g + msg <- C.randomBytes len g let thParams = testTHandleParams v sessId TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (CorrId corrId, sId, Cmd SSender $ SEND noMsgFlags msg) pure $ (,tToSend) <$> authTransmission thAuth_ (Just spKey) nonce tForAuth @@ -353,14 +353,14 @@ testTHandleParams v sessionId = batch = True } -testTHandleAuth :: VersionSMP -> TVar ChaChaDRG -> C.APublicAuthKey -> IO (Maybe (THandleAuth 'TClient)) +testTHandleAuth :: VersionSMP -> IORef ChaChaDRG -> C.APublicAuthKey -> IO (Maybe (THandleAuth 'TClient)) testTHandleAuth v g (C.APublicAuthKey a serverPeerPubKey) = case a of C.SX25519 | v >= authCmdsSMPVersion -> do ca <- head <$> XS.readCertificates "tests/fixtures/ca.crt" serverCert <- head <$> XS.readCertificates "tests/fixtures/server.crt" serverKey <- head <$> XF.readKeyFile "tests/fixtures/server.key" signKey <- either error pure $ C.x509ToPrivate (serverKey, []) >>= C.privKey @C.APrivateSignKey - (serverAuthPub, _) <- atomically $ C.generateKeyPair @'C.X25519 g + (serverAuthPub, _) <- C.generateKeyPair @'C.X25519 g let serverCertKey = (X.CertificateChain [serverCert, ca], C.signX509 signKey $ C.toPubKey C.publicToX509 serverAuthPub) pure $ Just THAuthClient {serverPeerPubKey, serverCertKey, sessSecret = Nothing} _ -> pure Nothing @@ -374,9 +374,9 @@ randomSENDCmdV7 = randomSENDCmd_ C.SX25519 randomSENDCmd_ :: (C.AlgorithmI a, C.AuthAlgorithm a) => C.SAlgorithm a -> ProtocolClient SMPVersion ErrorType BrokerMsg -> Int -> IO (PCTransmission ErrorType BrokerMsg) randomSENDCmd_ a c len = do g <- C.newRandom - sId <- atomically $ C.randomBytes 24 g - (_, rpKey) <- atomically $ C.generateAuthKeyPair a g - msg <- atomically $ C.randomBytes len g + sId <- C.randomBytes 24 g + (_, rpKey) <- C.generateAuthKeyPair a g + msg <- C.randomBytes len g mkTransmission c (Just rpKey, sId, Cmd SSender $ SEND noMsgFlags msg) lenOk :: ByteString -> Bool diff --git a/tests/CoreTests/CryptoFileTests.hs b/tests/CoreTests/CryptoFileTests.hs index a1af00c08..65d904dff 100644 --- a/tests/CoreTests/CryptoFileTests.hs +++ b/tests/CoreTests/CryptoFileTests.hs @@ -3,11 +3,11 @@ module CoreTests.CryptoFileTests (cryptoFileTests) where import AgentTests.FunctionalAPITests (runRight_) -import Control.Concurrent.STM import Control.Monad.Except import Control.Monad.IO.Class import Crypto.Random (ChaChaDRG) import qualified Data.ByteString.Lazy as LB +import Data.IORef (IORef) import GHC.IO.IOMode (IOMode (..)) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.File (CryptoFile (..), FTCryptoError (..)) @@ -29,8 +29,8 @@ testFilePath = "tests/tmp/testcryptofile" testWriteReadFile :: IO () testWriteReadFile = do g <- C.newRandom - s <- atomically $ LB.fromStrict <$> C.randomBytes 100000 g - file <- atomically $ mkCryptoFile g + s <- LB.fromStrict <$> C.randomBytes 100000 g + file <- mkCryptoFile g runRight_ $ do CF.writeFile file s liftIO $ CF.getFileContentsSize file `shouldReturn` 100000 @@ -41,9 +41,9 @@ testWriteReadFile = do testPutGetFile :: IO () testPutGetFile = do g <- C.newRandom - s <- atomically $ LB.fromStrict <$> C.randomBytes 50000 g - s' <- atomically $ LB.fromStrict <$> C.randomBytes 50000 g - file <- atomically $ mkCryptoFile g + s <- LB.fromStrict <$> C.randomBytes 50000 g + s' <- LB.fromStrict <$> C.randomBytes 50000 g + file <- mkCryptoFile g runRight_ $ do CF.withFile file WriteMode $ \h -> liftIO $ do CF.hPut h s @@ -61,8 +61,8 @@ testPutGetFile = do testWriteGetFile :: IO () testWriteGetFile = do g <- C.newRandom - s <- atomically $ LB.fromStrict <$> C.randomBytes 100000 g - file <- atomically $ mkCryptoFile g + s <- LB.fromStrict <$> C.randomBytes 100000 g + file <- mkCryptoFile g runRight_ $ do CF.writeFile file s CF.withFile file ReadMode $ \h -> do @@ -75,9 +75,9 @@ testWriteGetFile = do testPutReadFile :: IO () testPutReadFile = do g <- C.newRandom - s <- atomically $ LB.fromStrict <$> C.randomBytes 50000 g - s' <- atomically $ LB.fromStrict <$> C.randomBytes 50000 g - file <- atomically $ mkCryptoFile g + s <- LB.fromStrict <$> C.randomBytes 50000 g + s' <- LB.fromStrict <$> C.randomBytes 50000 g + file <- mkCryptoFile g runRight_ $ do CF.withFile file WriteMode $ \h -> liftIO $ do CF.hPut h s @@ -94,11 +94,11 @@ testPutReadFile = do testSmallFile :: IO () testSmallFile = do g <- C.newRandom - file <- atomically $ mkCryptoFile g + file <- mkCryptoFile g LB.writeFile testFilePath "" runExceptT (CF.readFile file) `shouldReturn` Left FTCEInvalidFileSize LB.writeFile testFilePath "123" runExceptT (CF.readFile file) `shouldReturn` Left FTCEInvalidFileSize -mkCryptoFile :: TVar ChaChaDRG -> STM CryptoFile +mkCryptoFile :: IORef ChaChaDRG -> IO CryptoFile mkCryptoFile g = CryptoFile testFilePath . Just <$> CF.randomArgs g diff --git a/tests/CoreTests/CryptoTests.hs b/tests/CoreTests/CryptoTests.hs index 0a6ca90db..a2e181cad 100644 --- a/tests/CoreTests/CryptoTests.hs +++ b/tests/CoreTests/CryptoTests.hs @@ -5,7 +5,6 @@ module CoreTests.CryptoTests (cryptoTests) where -import Control.Concurrent.STM import Control.Monad.Except import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB @@ -125,15 +124,15 @@ testPadUnpadFile = do testSignature :: (C.AlgorithmI a, C.SignatureAlgorithm a) => C.SAlgorithm a -> Spec testSignature alg = it "should sign / verify string" . ioProperty $ do g <- C.newRandom - (k, pk) <- atomically $ C.generateSignatureKeyPair alg g + (k, pk) <- C.generateSignatureKeyPair alg g 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 with asymmetric DH keys" . ioProperty $ do g <- C.newRandom - (sk, spk) <- atomically $ C.generateKeyPair g - (rk, rpk) <- atomically $ C.generateKeyPair g - nonce <- atomically $ C.randomCbNonce g + (sk, spk) <- C.generateKeyPair g + (rk, rpk) <- C.generateKeyPair g + nonce <- C.randomCbNonce g pure $ \(s, pad) -> let b = encodeUtf8 $ T.pack s paddedLen = B.length b + abs pad + 2 @@ -144,8 +143,8 @@ testDHCryptoBox = it "should encrypt / decrypt string with asymmetric DH keys" . testSecretBox :: Spec testSecretBox = it "should encrypt / decrypt string with a random symmetric key" . ioProperty $ do g <- C.newRandom - k <- atomically $ C.randomSbKey g - nonce <- atomically $ C.randomCbNonce g + k <- C.randomSbKey g + nonce <- C.randomCbNonce g pure $ \(s, pad) -> let b = encodeUtf8 $ T.pack s pad' = min (abs pad) 100000 @@ -157,8 +156,8 @@ testSecretBox = it "should encrypt / decrypt string with a random symmetric key" testLazySecretBox :: Spec testLazySecretBox = it "should lazily encrypt / decrypt string with a random symmetric key" . ioProperty $ do g <- C.newRandom - k <- atomically $ C.randomSbKey g - nonce <- atomically $ C.randomCbNonce g + k <- C.randomSbKey g + nonce <- C.randomCbNonce g pure $ \(s, pad) -> let b = LE.encodeUtf8 $ LT.pack s len = LB.length b @@ -171,8 +170,8 @@ testLazySecretBox = it "should lazily encrypt / decrypt string with a random sym testLazySecretBoxFile :: Spec testLazySecretBoxFile = it "should lazily encrypt / decrypt file with a random symmetric key" $ do g <- C.newRandom - k <- atomically $ C.randomSbKey g - nonce <- atomically $ C.randomCbNonce g + k <- C.randomSbKey g + nonce <- C.randomCbNonce g let f = "tests/tmp/testsecretbox" paddedLen = 4 * 1024 * 1024 len = 4 * 1000 * 1000 :: Int64 @@ -185,8 +184,8 @@ testLazySecretBoxFile = it "should lazily encrypt / decrypt file with a random s testLazySecretBoxTailTag :: Spec testLazySecretBoxTailTag = it "should lazily encrypt / decrypt string with a random symmetric key (tail tag)" . ioProperty $ do g <- C.newRandom - k <- atomically $ C.randomSbKey g - nonce <- atomically $ C.randomCbNonce g + k <- C.randomSbKey g + nonce <- C.randomCbNonce g pure $ \(s, pad) -> let b = LE.encodeUtf8 $ LT.pack s len = LB.length b @@ -199,8 +198,8 @@ testLazySecretBoxTailTag = it "should lazily encrypt / decrypt string with a ran testLazySecretBoxFileTailTag :: Spec testLazySecretBoxFileTailTag = it "should lazily encrypt / decrypt file with a random symmetric key (tail tag)" $ do g <- C.newRandom - k <- atomically $ C.randomSbKey g - nonce <- atomically $ C.randomCbNonce g + k <- C.randomSbKey g + nonce <- C.randomCbNonce g let f = "tests/tmp/testsecretbox" paddedLen = 4 * 1024 * 1024 len = 4 * 1000 * 1000 :: Int64 @@ -214,9 +213,9 @@ testLazySecretBoxFileTailTag = it "should lazily encrypt / decrypt file with a r testAESGCM :: Spec testAESGCM = it "should encrypt / decrypt string with a random symmetric key" $ do g <- C.newRandom - k <- atomically $ C.randomAesKey g - iv <- atomically $ C.randomGCMIV g - s <- atomically $ C.randomBytes 100 g + k <- C.randomAesKey g + iv <- C.randomGCMIV g + s <- C.randomBytes 100 g Right (tag, cipher) <- runExceptT $ C.encryptAESNoPad k iv s Right plain <- runExceptT $ C.decryptAESNoPad k iv cipher tag cipher `shouldNotBe` plain @@ -225,7 +224,7 @@ testAESGCM = it "should encrypt / decrypt string with a random symmetric key" $ testEncoding :: C.AlgorithmI a => C.SAlgorithm a -> Spec testEncoding alg = it "should encode / decode key" . ioProperty $ do g <- C.newRandom - (k, pk) <- atomically $ C.generateAKeyPair alg g + (k, pk) <- C.generateAKeyPair alg g 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 e5f096eef..336807cd9 100644 --- a/tests/NtfServerTests.hs +++ b/tests/NtfServerTests.hs @@ -99,10 +99,10 @@ testNotificationSubscription (ATransport t) = -- hangs on Ubuntu 20/22 xit' "should create notification subscription and notify when message is received" $ do g <- C.newRandom - (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g - (nPub, nKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g - (tknPub, tknKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g - (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g + (sPub, sKey) <- C.generateAuthKeyPair C.SEd25519 g + (nPub, nKey) <- C.generateAuthKeyPair C.SEd25519 g + (tknPub, tknKey) <- C.generateAuthKeyPair C.SEd25519 g + (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair g let tkn = DeviceToken PPApnsTest "abcd" withAPNSMockServer $ \APNSMockServer {apnsQ} -> smpTest2 t $ \rh sh -> @@ -121,7 +121,7 @@ testNotificationSubscription (ATransport t) = RespNtf "2" _ NROk <- signSendRecvNtf nh tknKey ("2", tId, TVFY code) RespNtf "2a" _ (NRTkn NTActive) <- signSendRecvNtf nh tknKey ("2a", tId, TCHK) -- enable queue notifications - (rcvNtfPubDhKey, rcvNtfPrivDhKey) <- atomically $ C.generateKeyPair g + (rcvNtfPubDhKey, rcvNtfPrivDhKey) <- C.generateKeyPair g Resp "3" _ (NID nId rcvNtfSrvPubDhKey) <- signSendRecv rh rKey ("3", rId, NKEY nPub rcvNtfPubDhKey) let srv = SMPServer SMP.testHost SMP.testPort SMP.testKeyHash q = SMPQueueNtf srv nId diff --git a/tests/RemoteControl.hs b/tests/RemoteControl.hs index c0a32cd4c..01105409c 100644 --- a/tests/RemoteControl.hs +++ b/tests/RemoteControl.hs @@ -158,7 +158,7 @@ testMulticast = do Nothing -> fail "timeout" Just _ -> pure () -runCtrl :: TVar ChaChaDRG -> Bool -> RCHostPairing -> MVar RCSignedInvitation -> IO (Async RCHostPairing) +runCtrl :: IORef ChaChaDRG -> Bool -> RCHostPairing -> MVar RCSignedInvitation -> IO (Async RCHostPairing) runCtrl drg multicast hp invVar = async . runRight $ do (_found, inv, hc, r) <- RC.connectRCHost drg hp (J.String "app") multicast Nothing Nothing putMVar invVar inv @@ -168,7 +168,7 @@ runCtrl drg multicast hp invVar = async . runRight $ do liftIO $ RC.cancelHostClient hc pure hp' -runHostURI :: TVar ChaChaDRG -> Maybe RCCtrlPairing -> RCSignedInvitation -> IO (Async RCCtrlPairing) +runHostURI :: IORef 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") @@ -178,7 +178,7 @@ runHostURI drg cp_ signedInv = async . runRight $ do threadDelay 250000 pure cp' -runHostMulticast :: TVar ChaChaDRG -> TMVar Int -> RCCtrlPairing -> IO (Async RCCtrlPairing) +runHostMulticast :: IORef 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") diff --git a/tests/SMPProxyTests.hs b/tests/SMPProxyTests.hs index 8044d23f7..b3d5673e8 100644 --- a/tests/SMPProxyTests.hs +++ b/tests/SMPProxyTests.hs @@ -71,7 +71,7 @@ smpProxyTests = do relayServ = srv2 (msg1, msg2) <- runIO $ do g <- C.newRandom - atomically $ (,) <$> C.randomBytes maxLen g <*> C.randomBytes maxLen g + (,) <$> C.randomBytes maxLen g <*> C.randomBytes maxLen g it "deliver via proxy" . twoServersFirstProxy $ deliverMessageViaProxy proxyServ relayServ C.SEd448 "hello 1" "hello 2" it "max message size, Ed448 keys" . twoServersFirstProxy $ @@ -158,8 +158,8 @@ deliverMessagesViaProxy proxyServ relayServ alg unsecuredMsgs securedMsgs = do rc' <- getProtocolClient g (2, relayServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange batchCmdsSMPVersion authCmdsSMPVersion} (Just msgQ) (\_ -> pure ()) rc <- either (fail . show) pure rc' -- prepare receiving queue - (rPub, rPriv) <- atomically $ C.generateAuthKeyPair alg g - (rdhPub, rdhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g + (rPub, rPriv) <- C.generateAuthKeyPair alg g + (rdhPub, rdhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair g SMP.QIK {rcvId, sndId, rcvPublicDhKey = srvDh} <- runExceptT' $ createSMPQueue rc (rPub, rPriv) rdhPub (Just "correct") SMSubscribe False let dec = decryptMsgV3 $ C.dh' srvDh rdhPriv -- get proxy session @@ -175,7 +175,7 @@ deliverMessagesViaProxy proxyServ relayServ alg unsecuredMsgs securedMsgs = do dec msgId encBody `shouldBe` Right msg runExceptT' $ ackSMPMessage rc rPriv rcvId msgId -- secure queue - (sPub, sPriv) <- atomically $ C.generateAuthKeyPair alg g + (sPub, sPriv) <- C.generateAuthKeyPair alg g runExceptT' $ secureSMPQueue rc rPriv rcvId sPub -- send via proxy to secured queue waitSendRecv diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index 30521c8a8..73c187d5c 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -132,8 +132,8 @@ testCreateSecure (ATransport t) = it "should create (NEW) and secure (KEY) queue" $ smpTest2 t $ \r s -> do g <- C.newRandom - (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g - (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g + (rPub, rKey) <- C.generateAuthKeyPair C.SEd448 g + (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair g Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv r rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe False) let dec = decryptMsgV3 $ C.dh' srvDh dhPriv (rId1, "") #== "creates queue" @@ -151,7 +151,7 @@ testCreateSecure (ATransport t) = Resp "dabc" _ err6 <- signSendRecv r rKey ("dabc", rId, ACK mId1) (err6, ERR NO_MSG) #== "replies ERR when message acknowledged without messages" - (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g + (sPub, sKey) <- C.generateAuthKeyPair C.SEd448 g Resp "abcd" sId2 err1 <- signSendRecv s sKey ("abcd", sId, _SEND "hello") (err1, ERR AUTH) #== "rejects signed SEND" (sId2, sId) #== "same queue ID in response 2" @@ -167,7 +167,7 @@ testCreateSecure (ATransport t) = (rId2, rId) #== "same queue ID in response 3" Resp "abcd" _ OK <- signSendRecv r rKey ("abcd", rId, KEY sPub) - (sPub', _) <- atomically $ C.generateAuthKeyPair C.SEd448 g + (sPub', _) <- C.generateAuthKeyPair C.SEd448 g Resp "abcd" _ err4 <- signSendRecv r rKey ("abcd", rId, KEY sPub') (err4, ERR AUTH) #== "rejects if secured with different key" @@ -197,13 +197,13 @@ testCreateDelete (ATransport t) = it "should create (NEW), suspend (OFF) and delete (DEL) queue" $ smpTest2 t $ \rh sh -> do g <- C.newRandom - (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g - (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g + (rPub, rKey) <- C.generateAuthKeyPair C.SEd25519 g + (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair g Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe False) let dec = decryptMsgV3 $ C.dh' srvDh dhPriv (rId1, "") #== "creates queue" - (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (sPub, sKey) <- C.generateAuthKeyPair C.SEd25519 g Resp "bcda" _ ok1 <- signSendRecv rh rKey ("bcda", rId, KEY sPub) (ok1, OK) #== "secures queue" @@ -268,8 +268,8 @@ stressTest (ATransport t) = it "should create many queues, disconnect and re-connect" $ smpTest3 t $ \h1 h2 h3 -> do g <- C.newRandom - (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g - (dhPub, _ :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g + (rPub, rKey) <- C.generateAuthKeyPair C.SEd25519 g + (dhPub, _ :: C.PrivateKeyX25519) <- C.generateKeyPair g rIds <- forM ([1 .. 50] :: [Int]) . const $ do Resp "" "" (Ids rId _ _) <- signSendRecv h1 rKey ("", "", NEW rPub dhPub Nothing SMSubscribe False) pure rId @@ -287,8 +287,8 @@ testAllowNewQueues t = withSmpServerConfigOn (ATransport t) cfg {allowNewQueues = False} testPort $ \_ -> testSMPClient @c $ \h -> do g <- C.newRandom - (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g - (dhPub, _ :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g + (rPub, rKey) <- C.generateAuthKeyPair C.SEd448 g + (dhPub, _ :: C.PrivateKeyX25519) <- C.generateKeyPair g Resp "abcd" "" (ERR AUTH) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe False) pure () @@ -297,13 +297,13 @@ testDuplex (ATransport t) = it "should create 2 simplex connections and exchange messages" $ smpTest2 t $ \alice bob -> do g <- C.newRandom - (arPub, arKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g - (aDhPub, aDhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g + (arPub, arKey) <- C.generateAuthKeyPair C.SEd448 g + (aDhPub, aDhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair g Resp "abcd" _ (Ids aRcv aSnd aSrvDh) <- signSendRecv alice arKey ("abcd", "", NEW arPub aDhPub Nothing SMSubscribe False) let aDec = decryptMsgV3 $ C.dh' aSrvDh aDhPriv -- aSnd ID is passed to Bob out-of-band - (bsPub, bsKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g + (bsPub, bsKey) <- C.generateAuthKeyPair C.SEd448 g Resp "bcda" _ OK <- sendRecv bob ("", "bcda", aSnd, _SEND $ "key " <> strEncode bsPub) -- "key ..." is ad-hoc, not a part of SMP protocol @@ -313,8 +313,8 @@ testDuplex (ATransport t) = (bobKey, strEncode bsPub) #== "key received from Bob" Resp "dabc" _ OK <- signSendRecv alice arKey ("dabc", aRcv, KEY bsPub) - (brPub, brKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g - (bDhPub, bDhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g + (brPub, brKey) <- C.generateAuthKeyPair C.SEd448 g + (bDhPub, bDhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair g Resp "abcd" _ (Ids bRcv bSnd bSrvDh) <- signSendRecv bob brKey ("abcd", "", NEW brPub bDhPub Nothing SMSubscribe False) let bDec = decryptMsgV3 $ C.dh' bSrvDh bDhPriv Resp "bcda" _ OK <- signSendRecv bob bsKey ("bcda", aSnd, _SEND $ "reply_id " <> encode bSnd) @@ -325,7 +325,7 @@ testDuplex (ATransport t) = Right ["reply_id", bId] <- pure $ B.words <$> aDec mId2 msg2 (bId, encode bSnd) #== "reply queue ID received from Bob" - (asPub, asKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g + (asPub, asKey) <- C.generateAuthKeyPair C.SEd448 g Resp "dabc" _ OK <- sendRecv alice ("", "dabc", bSnd, _SEND $ "key " <> strEncode asPub) -- "key ..." is ad-hoc, not a part of SMP protocol @@ -352,8 +352,8 @@ testSwitchSub (ATransport t) = it "should create simplex connections and switch subscription to another TCP connection" $ smpTest3 t $ \rh1 rh2 sh -> do g <- C.newRandom - (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g - (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g + (rPub, rKey) <- C.generateAuthKeyPair C.SEd448 g + (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair g Resp "abcd" _ (Ids rId sId srvDh) <- signSendRecv rh1 rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe False) let dec = decryptMsgV3 $ C.dh' srvDh dhPriv Resp "bcda" _ ok1 <- sendRecv sh ("", "bcda", sId, _SEND "test1") @@ -392,7 +392,7 @@ testGetCommand :: forall c. Transport c => TProxy c -> Spec testGetCommand t = it "should retrieve messages from the queue using GET command" $ do g <- C.newRandom - (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (sPub, sKey) <- C.generateAuthKeyPair C.SEd25519 g smpTest t $ \sh -> do queue <- newEmptyTMVarIO testSMPClient @c $ \rh -> @@ -411,7 +411,7 @@ testGetSubCommands :: forall c. Transport c => TProxy c -> Spec testGetSubCommands t = it "should retrieve messages with GET and receive with SUB, only one ACK would work" $ do g <- C.newRandom - (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (sPub, sKey) <- C.generateAuthKeyPair C.SEd25519 g smpTest3 t $ \rh1 rh2 sh -> do (sId, rId, rKey, dhShared) <- createAndSecureQueue rh1 sPub let dec = decryptMsgV3 dhShared @@ -463,7 +463,7 @@ testExceedQueueQuota t = withSmpServerConfigOn (ATransport t) cfg {msgQueueQuota = 2} testPort $ \_ -> testSMPClient @c $ \sh -> testSMPClient @c $ \rh -> do g <- C.newRandom - (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (sPub, sKey) <- C.generateAuthKeyPair C.SEd25519 g (sId, rId, rKey, dhShared) <- createAndSecureQueue rh sPub let dec = decryptMsgV3 dhShared Resp "1" _ OK <- signSendRecv sh sKey ("1", sId, _SEND "hello 1") @@ -488,9 +488,9 @@ testWithStoreLog :: ATransport -> Spec testWithStoreLog at@(ATransport t) = it "should store simplex queues to log and restore them after server restart" $ do g <- C.newRandom - (sPub1, sKey1) <- atomically $ C.generateAuthKeyPair C.SEd25519 g - (sPub2, sKey2) <- atomically $ C.generateAuthKeyPair C.SEd25519 g - (nPub, nKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (sPub1, sKey1) <- C.generateAuthKeyPair C.SEd25519 g + (sPub2, sKey2) <- C.generateAuthKeyPair C.SEd25519 g + (nPub, nKey) <- C.generateAuthKeyPair C.SEd25519 g recipientId1 <- newTVarIO "" recipientKey1 <- newTVarIO Nothing dhShared1 <- newTVarIO Nothing @@ -500,7 +500,7 @@ testWithStoreLog at@(ATransport t) = withSmpServerStoreLogOn at testPort . runTest t $ \h -> runClient t $ \h1 -> do (sId1, rId1, rKey1, dhShared) <- createAndSecureQueue h sPub1 - (rcvNtfPubDhKey, _) <- atomically $ C.generateKeyPair g + (rcvNtfPubDhKey, _) <- C.generateKeyPair g Resp "abcd" _ (NID nId _) <- signSendRecv h rKey1 ("abcd", rId1, NKEY nPub rcvNtfPubDhKey) atomically $ do writeTVar recipientId1 rId1 @@ -579,7 +579,7 @@ testRestoreMessages at@(ATransport t) = removeFileIfExists testServerStatsBackupFile g <- C.newRandom - (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (sPub, sKey) <- C.generateAuthKeyPair C.SEd25519 g recipientId <- newTVarIO "" recipientKey <- newTVarIO Nothing dhShared <- newTVarIO Nothing @@ -683,7 +683,7 @@ testRestoreExpireMessages :: ATransport -> Spec testRestoreExpireMessages at@(ATransport t) = it "should store messages on exit and restore on start" $ do g <- C.newRandom - (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (sPub, sKey) <- C.generateAuthKeyPair C.SEd25519 g recipientId <- newTVarIO "" recipientKey <- newTVarIO Nothing dhShared <- newTVarIO Nothing @@ -740,8 +740,8 @@ testRestoreExpireMessages at@(ATransport t) = createAndSecureQueue :: Transport c => THandleSMP c 'TClient -> SndPublicAuthKey -> IO (SenderId, RecipientId, RcvPrivateAuthKey, RcvDhSecret) createAndSecureQueue h sPub = do g <- C.newRandom - (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g - (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g + (rPub, rKey) <- C.generateAuthKeyPair C.SEd448 g + (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair g Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe False) let dhShared = C.dh' srvDh dhPriv Resp "dabc" rId' OK <- signSendRecv h rKey ("dabc", rId, KEY sPub) @@ -775,16 +775,16 @@ testTiming (ATransport t) = testSameTiming :: forall c. Transport c => THandleSMP c 'TClient -> THandleSMP c 'TClient -> (C.AuthAlg, C.AuthAlg, Int) -> Expectation testSameTiming rh sh (C.AuthAlg goodKeyAlg, C.AuthAlg badKeyAlg, n) = do g <- C.newRandom - (rPub, rKey) <- atomically $ C.generateAuthKeyPair goodKeyAlg g - (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g + (rPub, rKey) <- C.generateAuthKeyPair goodKeyAlg g + (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair g Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe False) let dec = decryptMsgV3 $ C.dh' srvDh dhPriv Resp "cdab" _ OK <- signSendRecv rh rKey ("cdab", rId, SUB) - (_, badKey) <- atomically $ C.generateAuthKeyPair badKeyAlg g + (_, badKey) <- C.generateAuthKeyPair badKeyAlg g runTimingTest rh badKey rId SUB - (sPub, sKey) <- atomically $ C.generateAuthKeyPair goodKeyAlg g + (sPub, sKey) <- C.generateAuthKeyPair goodKeyAlg g Resp "dabc" _ OK <- signSendRecv rh rKey ("dabc", rId, KEY sPub) Resp "bcda" _ OK <- signSendRecv sh sKey ("bcda", sId, _SEND "hello") @@ -822,12 +822,12 @@ testMessageNotifications :: ATransport -> Spec testMessageNotifications (ATransport t) = it "should create simplex connection, subscribe notifier and deliver notifications" $ do g <- C.newRandom - (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g - (nPub, nKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (sPub, sKey) <- C.generateAuthKeyPair C.SEd25519 g + (nPub, nKey) <- C.generateAuthKeyPair C.SEd25519 g smpTest4 t $ \rh sh nh1 nh2 -> do (sId, rId, rKey, dhShared) <- createAndSecureQueue rh sPub let dec = decryptMsgV3 dhShared - (rcvNtfPubDhKey, _) <- atomically $ C.generateKeyPair g + (rcvNtfPubDhKey, _) <- C.generateKeyPair g Resp "1" _ (NID nId' _) <- signSendRecv rh rKey ("1", rId, NKEY nPub rcvNtfPubDhKey) Resp "1a" _ (NID nId _) <- signSendRecv rh rKey ("1a", rId, NKEY nPub rcvNtfPubDhKey) nId' `shouldNotBe` nId @@ -859,7 +859,7 @@ testMsgExpireOnSend :: forall c. Transport c => TProxy c -> Spec testMsgExpireOnSend t = it "should expire messages that are not received before messageTTL on SEND" $ do g <- C.newRandom - (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (sPub, sKey) <- C.generateAuthKeyPair C.SEd25519 g let cfg' = cfg {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 10000}} withSmpServerConfigOn (ATransport t) cfg' testPort $ \_ -> testSMPClient @c $ \sh -> do @@ -880,7 +880,7 @@ testMsgExpireOnInterval t = -- fails on ubuntu xit' "should expire messages that are not received before messageTTL after expiry interval" $ do g <- C.newRandom - (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (sPub, sKey) <- C.generateAuthKeyPair C.SEd25519 g let cfg' = cfg {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}} withSmpServerConfigOn (ATransport t) cfg' testPort $ \_ -> testSMPClient @c $ \sh -> do @@ -899,7 +899,7 @@ testMsgNOTExpireOnInterval :: forall c. Transport c => TProxy c -> Spec testMsgNOTExpireOnInterval t = it "should NOT expire messages that are not received before messageTTL if expiry interval is large" $ do g <- C.newRandom - (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (sPub, sKey) <- C.generateAuthKeyPair C.SEd25519 g let cfg' = cfg {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 10000}} withSmpServerConfigOn (ATransport t) cfg' testPort $ \_ -> testSMPClient @c $ \sh -> do diff --git a/tests/XFTPAgent.hs b/tests/XFTPAgent.hs index 8de86eff1..8be3fe4ea 100644 --- a/tests/XFTPAgent.hs +++ b/tests/XFTPAgent.hs @@ -127,7 +127,7 @@ testXFTPAgentSendReceiveEncrypted = withXFTPServer $ do g <- C.newRandom filePath <- createRandomFile s <- LB.readFile filePath - file <- atomically $ CryptoFile (senderFiles "encrypted_testfile") . Just <$> CF.randomArgs g + file <- CryptoFile (senderFiles "encrypted_testfile") . Just <$> CF.randomArgs g runRight_ $ CF.writeFile file s (rfd1, rfd2) <- withAgent 1 agentCfg initAgentServers testDB $ \sndr -> runRight $ do (sfId, _, rfd1, rfd2) <- testSendCF sndr file @@ -139,7 +139,7 @@ testXFTPAgentSendReceiveEncrypted = withXFTPServer $ do where testReceiveDelete clientId rfd originalFilePath g = withAgent clientId agentCfg initAgentServers testDB2 $ \rcp -> do - cfArgs <- atomically $ Just <$> CF.randomArgs g + cfArgs <- Just <$> CF.randomArgs g rfId <- runRight $ testReceiveCF rcp rfd cfArgs originalFilePath xftpDeleteRcvFile rcp rfId diff --git a/tests/XFTPServerTests.hs b/tests/XFTPServerTests.hs index 19713d8b1..c36213bae 100644 --- a/tests/XFTPServerTests.hs +++ b/tests/XFTPServerTests.hs @@ -70,7 +70,7 @@ testChunkPath = "tests/tmp/chunk1" createTestChunk :: FilePath -> IO ByteString createTestChunk fp = do g <- C.newRandom - bytes <- atomically $ C.randomBytes chSize g + bytes <- C.randomBytes chSize g B.writeFile fp bytes pure bytes @@ -78,114 +78,118 @@ readChunk :: SenderId -> IO ByteString readChunk sId = B.readFile (xftpServerFiles B.unpack (B64.encode sId)) testFileChunkDelivery :: Expectation -testFileChunkDelivery = xftpTest $ \c -> runRight_ $ runTestFileChunkDelivery c c +testFileChunkDelivery = xftpTest $ \c -> runTestFileChunkDelivery c c testFileChunkDelivery2 :: Expectation -testFileChunkDelivery2 = xftpTest2 $ \s r -> runRight_ $ runTestFileChunkDelivery s r +testFileChunkDelivery2 = xftpTest2 $ \s r -> runTestFileChunkDelivery s r -runTestFileChunkDelivery :: XFTPClient -> XFTPClient -> ExceptT XFTPClientError IO () +runTestFileChunkDelivery :: XFTPClient -> XFTPClient -> IO () runTestFileChunkDelivery s r = do - g <- liftIO C.newRandom - (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g - (rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g - bytes <- liftIO $ createTestChunk testChunkPath - digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath + g <- C.newRandom + (sndKey, spKey) <- C.generateAuthKeyPair C.SEd25519 g + (rcvKey, rpKey) <- C.generateAuthKeyPair C.SEd25519 g + bytes <- createTestChunk testChunkPath + digest <- LC.sha256Hash <$> LB.readFile testChunkPath let file = FileInfo {sndKey, size = chSize, digest} chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize} - (sId, [rId]) <- createXFTPChunk s spKey file [rcvKey] Nothing - uploadXFTPChunk s spKey sId chunkSpec - (sId', _) <- createXFTPChunk s spKey file {digest = digest <> "_wrong"} [rcvKey] Nothing - uploadXFTPChunk s spKey sId' chunkSpec - `catchError` (liftIO . (`shouldBe` PCEProtocolError DIGEST)) - liftIO $ readChunk sId `shouldReturn` bytes - downloadXFTPChunk g r rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize (digest <> "_wrong")) - `catchError` (liftIO . (`shouldBe` PCEResponseError DIGEST)) - downloadXFTPChunk g r rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest - liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes + runRight_ $ do + (sId, [rId]) <- createXFTPChunk s spKey file [rcvKey] Nothing + uploadXFTPChunk s spKey sId chunkSpec + (sId', _) <- createXFTPChunk s spKey file {digest = digest <> "_wrong"} [rcvKey] Nothing + uploadXFTPChunk s spKey sId' chunkSpec + `catchError` (liftIO . (`shouldBe` PCEProtocolError DIGEST)) + liftIO $ readChunk sId `shouldReturn` bytes + downloadXFTPChunk g r rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize (digest <> "_wrong")) + `catchError` (liftIO . (`shouldBe` PCEResponseError DIGEST)) + downloadXFTPChunk g r rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest + liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes testFileChunkDeliveryAddRecipients :: Expectation -testFileChunkDeliveryAddRecipients = xftpTest4 $ \s r1 r2 r3 -> runRight_ $ do - g <- liftIO C.newRandom - (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g - (rcvKey1, rpKey1) <- atomically $ C.generateAuthKeyPair C.SEd25519 g - (rcvKey2, rpKey2) <- atomically $ C.generateAuthKeyPair C.SEd25519 g - (rcvKey3, rpKey3) <- atomically $ C.generateAuthKeyPair C.SEd25519 g - bytes <- liftIO $ createTestChunk testChunkPath - digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath +testFileChunkDeliveryAddRecipients = xftpTest4 $ \s r1 r2 r3 -> do + g <- C.newRandom + (sndKey, spKey) <- C.generateAuthKeyPair C.SEd25519 g + (rcvKey1, rpKey1) <- C.generateAuthKeyPair C.SEd25519 g + (rcvKey2, rpKey2) <- C.generateAuthKeyPair C.SEd25519 g + (rcvKey3, rpKey3) <- C.generateAuthKeyPair C.SEd25519 g + bytes <- createTestChunk testChunkPath + digest <- LC.sha256Hash <$> LB.readFile testChunkPath let file = FileInfo {sndKey, size = chSize, digest} chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize} - (sId, [rId1]) <- createXFTPChunk s spKey file [rcvKey1] Nothing - [rId2, rId3] <- addXFTPRecipients s spKey sId [rcvKey2, rcvKey3] - uploadXFTPChunk s spKey sId chunkSpec - let testReceiveChunk r rpKey rId fPath = do - downloadXFTPChunk g r rpKey rId $ XFTPRcvChunkSpec fPath chSize digest - liftIO $ B.readFile fPath `shouldReturn` bytes - testReceiveChunk r1 rpKey1 rId1 "tests/tmp/received_chunk1" - testReceiveChunk r2 rpKey2 rId2 "tests/tmp/received_chunk2" - testReceiveChunk r3 rpKey3 rId3 "tests/tmp/received_chunk3" + runRight_ $ do + (sId, [rId1]) <- createXFTPChunk s spKey file [rcvKey1] Nothing + [rId2, rId3] <- addXFTPRecipients s spKey sId [rcvKey2, rcvKey3] + uploadXFTPChunk s spKey sId chunkSpec + let testReceiveChunk r rpKey rId fPath = do + downloadXFTPChunk g r rpKey rId $ XFTPRcvChunkSpec fPath chSize digest + liftIO $ B.readFile fPath `shouldReturn` bytes + testReceiveChunk r1 rpKey1 rId1 "tests/tmp/received_chunk1" + testReceiveChunk r2 rpKey2 rId2 "tests/tmp/received_chunk2" + testReceiveChunk r3 rpKey3 rId3 "tests/tmp/received_chunk3" testFileChunkDelete :: Expectation -testFileChunkDelete = xftpTest $ \c -> runRight_ $ runTestFileChunkDelete c c +testFileChunkDelete = xftpTest $ \c -> runTestFileChunkDelete c c testFileChunkDelete2 :: Expectation -testFileChunkDelete2 = xftpTest2 $ \s r -> runRight_ $ runTestFileChunkDelete s r +testFileChunkDelete2 = xftpTest2 $ \s r -> runTestFileChunkDelete s r -runTestFileChunkDelete :: XFTPClient -> XFTPClient -> ExceptT XFTPClientError IO () +runTestFileChunkDelete :: XFTPClient -> XFTPClient -> IO () runTestFileChunkDelete s r = do - g <- liftIO C.newRandom - (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g - (rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g - bytes <- liftIO $ createTestChunk testChunkPath - digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath + g <- C.newRandom + (sndKey, spKey) <- C.generateAuthKeyPair C.SEd25519 g + (rcvKey, rpKey) <- C.generateAuthKeyPair C.SEd25519 g + bytes <- createTestChunk testChunkPath + digest <- LC.sha256Hash <$> LB.readFile testChunkPath let file = FileInfo {sndKey, size = chSize, digest} chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize} - (sId, [rId]) <- createXFTPChunk s spKey file [rcvKey] Nothing - uploadXFTPChunk s spKey sId chunkSpec + runRight_ $ do + (sId, [rId]) <- createXFTPChunk s spKey file [rcvKey] Nothing + uploadXFTPChunk s spKey sId chunkSpec - downloadXFTPChunk g r rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest - liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes - deleteXFTPChunk s spKey sId - liftIO $ - readChunk sId - `shouldThrow` \(e :: SomeException) -> "does not exist" `isInfixOf` show e - downloadXFTPChunk g r rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk2" chSize digest) - `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH)) - deleteXFTPChunk s spKey sId - `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH)) + downloadXFTPChunk g r rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest + liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes + deleteXFTPChunk s spKey sId + liftIO $ + readChunk sId + `shouldThrow` \(e :: SomeException) -> "does not exist" `isInfixOf` show e + downloadXFTPChunk g r rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk2" chSize digest) + `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH)) + deleteXFTPChunk s spKey sId + `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH)) testFileChunkAck :: Expectation -testFileChunkAck = xftpTest $ \c -> runRight_ $ runTestFileChunkAck c c +testFileChunkAck = xftpTest $ \c -> runTestFileChunkAck c c testFileChunkAck2 :: Expectation -testFileChunkAck2 = xftpTest2 $ \s r -> runRight_ $ runTestFileChunkAck s r +testFileChunkAck2 = xftpTest2 $ \s r -> runTestFileChunkAck s r -runTestFileChunkAck :: XFTPClient -> XFTPClient -> ExceptT XFTPClientError IO () +runTestFileChunkAck :: XFTPClient -> XFTPClient -> IO () runTestFileChunkAck s r = do - g <- liftIO C.newRandom - (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g - (rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g - bytes <- liftIO $ createTestChunk testChunkPath - digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath + g <- C.newRandom + (sndKey, spKey) <- C.generateAuthKeyPair C.SEd25519 g + (rcvKey, rpKey) <- C.generateAuthKeyPair C.SEd25519 g + bytes <- createTestChunk testChunkPath + digest <- LC.sha256Hash <$> LB.readFile testChunkPath let file = FileInfo {sndKey, size = chSize, digest} chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize} - (sId, [rId]) <- createXFTPChunk s spKey file [rcvKey] Nothing - uploadXFTPChunk s spKey sId chunkSpec + runRight_ $ do + (sId, [rId]) <- createXFTPChunk s spKey file [rcvKey] Nothing + uploadXFTPChunk s spKey sId chunkSpec - downloadXFTPChunk g r rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest - liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes - ackXFTPChunk r rpKey rId - liftIO $ readChunk sId `shouldReturn` bytes - downloadXFTPChunk g r rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk2" chSize digest) - `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH)) - ackXFTPChunk r rpKey rId - `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH)) + downloadXFTPChunk g r rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest + liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes + ackXFTPChunk r rpKey rId + liftIO $ readChunk sId `shouldReturn` bytes + downloadXFTPChunk g r rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk2" chSize digest) + `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH)) + ackXFTPChunk r rpKey rId + `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH)) testWrongChunkSize :: Expectation testWrongChunkSize = xftpTest $ \c -> do g <- C.newRandom - (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g - (rcvKey, _rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g - B.writeFile testChunkPath =<< atomically (C.randomBytes (kb 96) g) + (sndKey, spKey) <- C.generateAuthKeyPair C.SEd25519 g + (rcvKey, _rpKey) <- C.generateAuthKeyPair C.SEd25519 g + B.writeFile testChunkPath =<< C.randomBytes (kb 96) g digest <- LC.sha256Hash <$> LB.readFile testChunkPath let file = FileInfo {sndKey, size = kb 96, digest} runRight_ $ @@ -194,25 +198,26 @@ testWrongChunkSize = xftpTest $ \c -> do testFileChunkExpiration :: Expectation testFileChunkExpiration = withXFTPServerCfg testXFTPServerConfig {fileExpiration} $ - \_ -> testXFTPClient $ \c -> runRight_ $ do - g <- liftIO C.newRandom - (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g - (rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g - bytes <- liftIO $ createTestChunk testChunkPath - digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath + \_ -> testXFTPClient $ \c -> do + g <- C.newRandom + (sndKey, spKey) <- C.generateAuthKeyPair C.SEd25519 g + (rcvKey, rpKey) <- C.generateAuthKeyPair C.SEd25519 g + bytes <- createTestChunk testChunkPath + digest <- LC.sha256Hash <$> LB.readFile testChunkPath let file = FileInfo {sndKey, size = chSize, digest} chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize} - (sId, [rId]) <- createXFTPChunk c spKey file [rcvKey] Nothing - uploadXFTPChunk c spKey sId chunkSpec + runRight_ $ do + (sId, [rId]) <- createXFTPChunk c spKey file [rcvKey] Nothing + uploadXFTPChunk c spKey sId chunkSpec - downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest - liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes + downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest + liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes - liftIO $ threadDelay 1000000 - downloadXFTPChunk g c rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk2" chSize digest) - `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH)) - deleteXFTPChunk c spKey sId - `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH)) + liftIO $ threadDelay 1000000 + downloadXFTPChunk g c rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk2" chSize digest) + `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH)) + deleteXFTPChunk c spKey sId + `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH)) where fileExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1} @@ -233,39 +238,40 @@ testInactiveClientExpiration = withXFTPServerCfg testXFTPServerConfig {inactiveC testFileStorageQuota :: Expectation testFileStorageQuota = withXFTPServerCfg testXFTPServerConfig {fileSizeQuota = Just $ chSize * 2} $ - \_ -> testXFTPClient $ \c -> runRight_ $ do - g <- liftIO C.newRandom - (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g - (rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g - bytes <- liftIO $ createTestChunk testChunkPath - digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath + \_ -> testXFTPClient $ \c -> do + g <- C.newRandom + (sndKey, spKey) <- C.generateAuthKeyPair C.SEd25519 g + (rcvKey, rpKey) <- C.generateAuthKeyPair C.SEd25519 g + bytes <- createTestChunk testChunkPath + digest <- LC.sha256Hash <$> LB.readFile testChunkPath let file = FileInfo {sndKey, size = chSize, digest} chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize} download rId = do downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes - (sId1, [rId1]) <- createXFTPChunk c spKey file [rcvKey] Nothing - uploadXFTPChunk c spKey sId1 chunkSpec - download rId1 - (sId2, [rId2]) <- createXFTPChunk c spKey file [rcvKey] Nothing - uploadXFTPChunk c spKey sId2 chunkSpec - download rId2 + runRight_ $ do + (sId1, [rId1]) <- createXFTPChunk c spKey file [rcvKey] Nothing + uploadXFTPChunk c spKey sId1 chunkSpec + download rId1 + (sId2, [rId2]) <- createXFTPChunk c spKey file [rcvKey] Nothing + uploadXFTPChunk c spKey sId2 chunkSpec + download rId2 - (sId3, [rId3]) <- createXFTPChunk c spKey file [rcvKey] Nothing - uploadXFTPChunk c spKey sId3 chunkSpec - `catchError` (liftIO . (`shouldBe` PCEProtocolError QUOTA)) + (sId3, [rId3]) <- createXFTPChunk c spKey file [rcvKey] Nothing + uploadXFTPChunk c spKey sId3 chunkSpec + `catchError` (liftIO . (`shouldBe` PCEProtocolError QUOTA)) - deleteXFTPChunk c spKey sId1 - uploadXFTPChunk c spKey sId3 chunkSpec - download rId3 + deleteXFTPChunk c spKey sId1 + uploadXFTPChunk c spKey sId3 chunkSpec + download rId3 testFileLog :: Expectation testFileLog = do g <- C.newRandom bytes <- liftIO $ createTestChunk testChunkPath - (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g - (rcvKey1, rpKey1) <- atomically $ C.generateAuthKeyPair C.SEd25519 g - (rcvKey2, rpKey2) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (sndKey, spKey) <- C.generateAuthKeyPair C.SEd25519 g + (rcvKey1, rpKey1) <- C.generateAuthKeyPair C.SEd25519 g + (rcvKey2, rpKey2) <- C.generateAuthKeyPair C.SEd25519 g digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath sIdVar <- newTVarIO "" rIdVar1 <- newTVarIO "" @@ -356,8 +362,8 @@ testFileBasicAuth allowNewFiles newFileBasicAuth clntAuth success = withXFTPServerCfg testXFTPServerConfig {allowNewFiles, newFileBasicAuth} $ \_ -> testXFTPClient $ \c -> do g <- C.newRandom - (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g - (rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (sndKey, spKey) <- C.generateAuthKeyPair C.SEd25519 g + (rcvKey, rpKey) <- C.generateAuthKeyPair C.SEd25519 g bytes <- createTestChunk testChunkPath digest <- LC.sha256Hash <$> LB.readFile testChunkPath let file = FileInfo {sndKey, size = chSize, digest} @@ -378,8 +384,8 @@ testFileSkipCommitted = withXFTPServerCfg testXFTPServerConfig $ \_ -> testXFTPClient $ \c -> do g <- C.newRandom - (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g - (rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (sndKey, spKey) <- C.generateAuthKeyPair C.SEd25519 g + (rcvKey, rpKey) <- C.generateAuthKeyPair C.SEd25519 g bytes <- createTestChunk testChunkPath digest <- LC.sha256Hash <$> LB.readFile testChunkPath let file = FileInfo {sndKey, size = chSize, digest}