diff --git a/src/Simplex/FileTransfer/Agent.hs b/src/Simplex/FileTransfer/Agent.hs index f558b652f..2bc02374b 100644 --- a/src/Simplex/FileTransfer/Agent.hs +++ b/src/Simplex/FileTransfer/Agent.hs @@ -286,8 +286,8 @@ xftpSendFile' c userId file numRecipients = do prefixPath <- getPrefixPath "snd.xftp" createDirectory prefixPath let relPrefixPath = takeFileName prefixPath - key <- liftIO C.randomSbKey - nonce <- liftIO C.randomCbNonce + key <- atomically $ C.randomSbKey g + nonce <- atomically $ 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 addXFTPSndWorker c Nothing diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs index 240eb57af..1b3727d22 100644 --- a/src/Simplex/FileTransfer/Client.hs +++ b/src/Simplex/FileTransfer/Client.hs @@ -11,6 +11,7 @@ module Simplex.FileTransfer.Client where import Control.Monad import Control.Monad.Except +import Crypto.Random (ChaChaDRG) import Data.Bifunctor (first) import Data.ByteString.Builder (Builder, byteString) import Data.ByteString.Char8 (ByteString) @@ -178,9 +179,9 @@ uploadXFTPChunk :: XFTPClient -> C.APrivateSignKey -> XFTPFileId -> XFTPChunkSpe uploadXFTPChunk c spKey fId chunkSpec = sendXFTPCommand c spKey fId FPUT (Just chunkSpec) >>= okResponse -downloadXFTPChunk :: XFTPClient -> C.APrivateSignKey -> XFTPFileId -> XFTPRcvChunkSpec -> ExceptT XFTPClientError IO () -downloadXFTPChunk c@XFTPClient {config} rpKey fId chunkSpec@XFTPRcvChunkSpec {filePath, chunkSize} = do - (rDhKey, rpDhKey) <- liftIO C.generateKeyPair' +downloadXFTPChunk :: TVar ChaChaDRG -> XFTPClient -> C.APrivateSignKey -> XFTPFileId -> XFTPRcvChunkSpec -> ExceptT XFTPClientError IO () +downloadXFTPChunk g c@XFTPClient {config} rpKey fId chunkSpec@XFTPRcvChunkSpec {filePath, chunkSize} = do + (rDhKey, rpDhKey) <- atomically $ 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 0ed2a54f9..7c3521fc2 100644 --- a/src/Simplex/FileTransfer/Client/Main.hs +++ b/src/Simplex/FileTransfer/Client/Main.hs @@ -15,7 +15,6 @@ module Simplex.FileTransfer.Client.Main CLIError (..), xftpClientCLI, cliSendFile, - cliSendFileOpts, prepareChunkSizes, prepareChunkSpecs, maxFileSize, @@ -28,7 +27,7 @@ where import Control.Logger.Simple import Control.Monad import Control.Monad.Except -import Crypto.Random (getRandomBytes) +import Crypto.Random (ChaChaDRG) import qualified Data.Attoparsec.ByteString.Char8 as A import Data.Bifunctor (first) import Data.ByteString.Char8 (ByteString) @@ -264,10 +263,11 @@ cliSendFileOpts :: SendOptions -> Bool -> (Int64 -> Int64 -> IO ()) -> ExceptT C cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, retryCount, tempPath, verbose} printInfo notifyProgress = do let (_, fileName) = splitFileName filePath liftIO $ when printInfo $ printNoNewLine "Encrypting file..." - (encPath, fdRcv, fdSnd, chunkSpecs, encSize) <- encryptFileForUpload fileName + g <- liftIO C.newRandom + (encPath, fdRcv, fdSnd, chunkSpecs, encSize) <- encryptFileForUpload g fileName liftIO $ when printInfo $ printNoNewLine "Uploading file..." uploadedChunks <- newTVarIO [] - sentChunks <- uploadFile chunkSpecs uploadedChunks encSize + sentChunks <- uploadFile g chunkSpecs uploadedChunks encSize whenM (doesFileExist encPath) $ removeFile encPath -- TODO if only small chunks, use different default size liftIO $ do @@ -280,13 +280,13 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re putStrLn "Pass file descriptions to the recipient(s):" forM_ fdRcvPaths putStrLn where - encryptFileForUpload :: String -> ExceptT CLIError IO (FilePath, FileDescription 'FRecipient, FileDescription 'FSender, [XFTPChunkSpec], Int64) - encryptFileForUpload fileName = do + encryptFileForUpload :: TVar ChaChaDRG -> String -> ExceptT CLIError IO (FilePath, FileDescription 'FRecipient, FileDescription 'FSender, [XFTPChunkSpec], Int64) + encryptFileForUpload g fileName = do fileSize <- fromInteger <$> getFileSize filePath when (fileSize > maxFileSize) $ throwError $ CLIError $ "Files bigger than " <> maxFileSizeStr <> " are not supported" encPath <- getEncPath tempPath "xftp" - key <- liftIO C.randomSbKey - nonce <- liftIO C.randomCbNonce + key <- atomically $ C.randomSbKey g + nonce <- atomically $ C.randomCbNonce g let fileHdr = smpEncode FileHeader {fileName, fileExtra = Nothing} fileSize' = fromIntegral (B.length fileHdr) + fileSize chunkSizes = prepareChunkSizes $ fileSize' + fileSizeLen + authTagSize @@ -301,8 +301,8 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re fdSnd = FileDescription {party = SFSender, size = FileSize encSize, digest = FileDigest digest, key, nonce, chunkSize = FileSize defChunkSize, chunks = []} logInfo $ "encrypted file to " <> tshow encPath pure (encPath, fdRcv, fdSnd, chunkSpecs, encSize) - uploadFile :: [XFTPChunkSpec] -> TVar [Int64] -> Int64 -> ExceptT CLIError IO [SentFileChunk] - uploadFile chunks uploadedChunks encSize = do + uploadFile :: TVar ChaChaDRG -> [XFTPChunkSpec] -> TVar [Int64] -> Int64 -> ExceptT CLIError IO [SentFileChunk] + uploadFile g chunks uploadedChunks encSize = do a <- atomically $ newXFTPAgent defaultXFTPClientAgentConfig gen <- newTVarIO =<< liftIO newStdGen let xftpSrvs = fromMaybe defaultXFTPServers (nonEmpty xftpServers) @@ -318,8 +318,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) <- liftIO $ C.generateSignatureKeyPair C.SEd25519 - rKeys <- liftIO $ L.fromList <$> replicateM numRecipients (C.generateSignatureKeyPair C.SEd25519) + (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + rKeys <- atomically $ L.fromList <$> replicateM numRecipients (C.generateSignatureKeyPair C.SEd25519 g) digest <- liftIO $ getChunkDigest chunkSpec let ch = FileInfo {sndKey, size = fromIntegral chunkSize, digest} c <- withRetry retryCount $ getXFTPServerClient a xftpServer @@ -423,7 +423,8 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath, [] -> error "empty FileChunk.replicas" FileChunkReplica {server} : _ -> server srvChunks = groupAllOn srv chunks - chunkPaths <- map snd . sortOn fst . concat <$> pooledForConcurrentlyN 16 srvChunks (mapM $ downloadFileChunk a encPath size downloadedChunks) + g <- liftIO C.newRandom + chunkPaths <- map snd . sortOn fst . concat <$> pooledForConcurrentlyN 16 srvChunks (mapM $ downloadFileChunk g a encPath size downloadedChunks) encDigest <- liftIO $ LC.sha512Hash <$> readChunks chunkPaths when (encDigest /= unFileDigest digest) $ throwError $ CLIError "File digest mismatch" encSize <- liftIO $ foldM (\s path -> (s +) . fromIntegral <$> getFileSize path) 0 chunkPaths @@ -435,13 +436,13 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath, liftIO $ do printNoNewLine $ "File downloaded: " <> path removeFD yes fileDescription - downloadFileChunk :: XFTPClientAgent -> FilePath -> FileSize Int64 -> TVar [Int64] -> FileChunk -> ExceptT CLIError IO (Int, FilePath) - downloadFileChunk a encPath (FileSize encSize) downloadedChunks FileChunk {chunkNo, chunkSize, digest, replicas = replica : _} = do + downloadFileChunk :: TVar 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 <> "..." chunkPath <- uniqueCombine encPath $ show chunkNo let chunkSpec = XFTPRcvChunkSpec chunkPath (unFileSize chunkSize) (unFileDigest digest) - withReconnect a server retryCount $ \c -> downloadXFTPChunk c replicaKey (unChunkReplicaId replicaId) chunkSpec + withReconnect a server retryCount $ \c -> downloadXFTPChunk g c replicaKey (unChunkReplicaId replicaId) chunkSpec logInfo $ "downloaded chunk " <> tshow chunkNo <> " to " <> T.pack chunkPath downloaded <- atomically . stateTVar downloadedChunks $ \cs -> let cs' = fromIntegral (unFileSize chunkSize) : cs in (sum cs', cs') @@ -449,7 +450,7 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath, printProgress "Downloaded" downloaded encSize when verbose $ putStrLn "" pure (chunkNo, chunkPath) - downloadFileChunk _ _ _ _ _ = throwError $ CLIError "chunk has no replicas" + downloadFileChunk _ _ _ _ _ _ = throwError $ CLIError "chunk has no replicas" getFilePath :: String -> ExceptT String IO FilePath getFilePath name = case filePath of @@ -593,7 +594,8 @@ cliRandomFile RandomFileOptions {filePath, fileSize = FileSize size} = do putStrLn $ "File created: " <> filePath where saveRandomFile h sz = do - bytes <- getRandomBytes $ fromIntegral $ min mb' sz + g <- C.newRandom + bytes <- atomically $ 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 4113b316c..87c06226b 100644 --- a/src/Simplex/FileTransfer/Server.hs +++ b/src/Simplex/FileTransfer/Server.hs @@ -16,7 +16,6 @@ import Control.Monad import Control.Monad.Except import Control.Monad.IO.Unlift (MonadUnliftIO) import Control.Monad.Reader -import Crypto.Random (getRandomBytes) import Data.Bifunctor (first) import qualified Data.ByteString.Base64.URL as B64 import Data.ByteString.Builder (byteString) @@ -318,9 +317,10 @@ processXFTPRequest HTTP2Body {bodyPart} = \case sendServerFile FileRec {senderId, filePath, fileInfo = FileInfo {size}} rDhKey = do readTVarIO filePath >>= \case Just path -> do - (sDhKey, spDhKey) <- liftIO C.generateKeyPair' + g <- asks random + (sDhKey, spDhKey) <- atomically $ C.generateKeyPair g let dhSecret = C.dh' rDhKey spDhKey - cbNonce <- liftIO C.randomCbNonce + cbNonce <- atomically $ C.randomCbNonce g case LC.cbInit dhSecret cbNonce of Right sbState -> do stats <- asks serverStats @@ -360,12 +360,12 @@ processXFTPRequest HTTP2Body {bodyPart} = \case pure FROk randomId :: (MonadUnliftIO m, MonadReader XFTPEnv m) => Int -> m ByteString -randomId n = do - gVar <- asks idsDrg - atomically (C.pseudoRandomBytes n gVar) +randomId n = atomically . C.randomBytes n =<< asks random getFileId :: M XFTPFileId -getFileId = liftIO . getRandomBytes =<< asks (fileIdSize . config) +getFileId = do + size <- asks (fileIdSize . config) + atomically . C.randomBytes size =<< asks random withFileLog :: (MonadIO m, MonadReader XFTPEnv m) => (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 8c82b4a84..d9b20be19 100644 --- a/src/Simplex/FileTransfer/Server/Env.hs +++ b/src/Simplex/FileTransfer/Server/Env.hs @@ -62,7 +62,7 @@ data XFTPEnv = XFTPEnv { config :: XFTPServerConfig, store :: FileStore, storeLog :: Maybe (StoreLog 'WriteMode), - idsDrg :: TVar ChaChaDRG, + random :: TVar ChaChaDRG, serverIdentity :: C.KeyHash, tlsServerParams :: T.ServerParams, serverStats :: FileServerStats @@ -80,7 +80,7 @@ defaultFileExpiration = newXFTPServerEnv :: (MonadUnliftIO m, MonadRandom m) => XFTPServerConfig -> m XFTPEnv newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, caCertificateFile, certificateFile, privateKeyFile} = do - idsDrg <- drgNew >>= newTVarIO + random <- liftIO C.newRandom store <- atomically newFileStore storeLog <- liftIO $ mapM (`readWriteFileStore` store) storeLogFile used <- readTVarIO (usedStorage store) @@ -90,7 +90,7 @@ newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, caCertifi tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile Fingerprint fp <- liftIO $ loadFingerprint caCertificateFile serverStats <- atomically . newFileServerStats =<< liftIO getCurrentTime - pure XFTPEnv {config, store, storeLog, idsDrg, tlsServerParams, serverIdentity = C.KeyHash fp, serverStats} + pure XFTPEnv {config, store, storeLog, random, tlsServerParams, serverIdentity = C.KeyHash fp, serverStats} data XFTPRequest = XFTPReqNew FileInfo (NonEmpty RcvPublicVerifyKey) (Maybe BasicAuth) diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 675509fb4..f1a56d110 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -114,7 +114,7 @@ import Control.Monad import Control.Monad.Except import Control.Monad.IO.Unlift (MonadUnliftIO) import Control.Monad.Reader -import Crypto.Random (MonadRandom) +import Crypto.Random (ChaChaDRG, MonadRandom) import qualified Data.Aeson as J import Data.Bifunctor (bimap, first, second) import Data.ByteString.Char8 (ByteString) @@ -397,8 +397,8 @@ xftpDeleteSndFileRemote :: AgentErrorMonad m => AgentClient -> UserId -> SndFile xftpDeleteSndFileRemote c = withAgentEnv c .:. deleteSndFileRemote c -- | Create new remote host pairing -rcNewHostPairing :: MonadIO m => m RCHostPairing -rcNewHostPairing = liftIO newRCHostPairing +rcNewHostPairing :: AgentErrorMonad m => AgentClient -> m RCHostPairing +rcNewHostPairing c = withAgentEnv c $ liftIO . newRCHostPairing =<< asks random -- | start TLS server for remote host with optional multicast rcConnectHost :: AgentErrorMonad m => AgentClient -> RCHostPairing -> J.Value -> Bool -> Maybe RCCtrlAddress -> Maybe Word16 -> m RCHostConnection @@ -634,7 +634,8 @@ newRcvConnSrv c userId connId enableNtfs cMode clientData subMode srv = do case cMode of SCMContact -> pure (connId, CRContactUri crData) SCMInvitation -> do - (pk1, pk2, e2eRcvParams) <- liftIO . CR.generateE2EParams $ maxVersion e2eEncryptVRange + g <- asks random + (pk1, pk2, e2eRcvParams) <- atomically . CR.generateE2EParams g $ maxVersion e2eEncryptVRange withStore' c $ \db -> createRatchetX3dhKeys db connId pk1 pk2 pure (connId, CRInvitationUri crData $ toVersionRangeT e2eRcvParams e2eEncryptVRange) @@ -654,8 +655,9 @@ startJoinInvitation userId connId enableNtfs (CRInvitationUri ConnReqUriData {cr crAgentVRange `compatibleVersion` smpAgentVRange ) of (Just qInfo, Just (Compatible e2eRcvParams@(CR.E2ERatchetParams _ _ rcDHRr)), Just aVersion@(Compatible connAgentVersion)) -> do - (pk1, pk2, e2eSndParams) <- liftIO . CR.generateE2EParams $ version e2eRcvParams - (_, rcDHRs) <- liftIO C.generateKeyPair' + g <- asks random + (pk1, pk2, e2eSndParams) <- atomically . CR.generateE2EParams g $ version e2eRcvParams + (_, rcDHRs) <- atomically $ C.generateKeyPair g let rc = CR.initSndRatchet e2eEncryptVRange rcDHRr rcDHRs $ CR.x3dhSnd pk1 pk2 e2eRcvParams q <- newSndQueue userId "" qInfo let duplexHS = connAgentVersion /= 1 @@ -1427,7 +1429,8 @@ synchronizeRatchet' c connId force = withConnLock c connId "synchronizeRatchet" | ratchetSyncAllowed cData || force -> do -- check queues are not switching? AgentConfig {e2eEncryptVRange} <- asks config - (pk1, pk2, e2eParams@(CR.E2ERatchetParams _ k1 k2)) <- liftIO . CR.generateE2EParams $ maxVersion e2eEncryptVRange + g <- asks random + (pk1, pk2, e2eParams@(CR.E2ERatchetParams _ k1 k2)) <- atomically . CR.generateE2EParams g $ maxVersion e2eEncryptVRange void $ enqueueRatchetKeyMsgs c cData sqs e2eParams withStore' c $ \db -> do setConnRatchetSync db connId RSStarted @@ -1663,8 +1666,9 @@ registerNtfToken' c suppliedDeviceToken suppliedNtfMode = Just ntfServer -> asks (cmdSignAlg . config) >>= \case C.SignAlg a -> do - tknKeys <- liftIO $ C.generateSignatureKeyPair a - dhKeys <- liftIO C.generateKeyPair' + g <- asks random + tknKeys <- atomically $ C.generateSignatureKeyPair a g + dhKeys <- atomically $ C.generateKeyPair g let tkn = newNtfToken suppliedDeviceToken ntfServer tknKeys dhKeys suppliedNtfMode withStore' c (`createNtfToken` tkn) registerToken tkn @@ -1980,7 +1984,8 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s _ -> notify . ERR . AGENT $ A_QUEUE "replaced RcvQueue not found in connection" _ -> pure () let encryptedMsgHash = C.sha256Hash encAgentMessage - tryError (agentClientMsg encryptedMsgHash) >>= \case + g <- asks random + tryError (agentClientMsg g encryptedMsgHash) >>= \case Right (Just (msgId, msgMeta, aMessage, rcPrev)) -> do conn'' <- resetRatchetSync case aMessage of @@ -2042,10 +2047,10 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s checkDuplicateHash e encryptedMsgHash = unlessM (withStore' c $ \db -> checkRcvMsgHashExists db connId encryptedMsgHash) $ throwError e - agentClientMsg :: ByteString -> m (Maybe (InternalId, MsgMeta, AMessage, CR.RatchetX448)) - agentClientMsg encryptedMsgHash = withStore c $ \db -> runExceptT $ do + agentClientMsg :: TVar ChaChaDRG -> ByteString -> m (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 <- agentRatchetDecrypt' db connId rc encAgentMessage + agentMsgBody <- agentRatchetDecrypt' g db connId rc encAgentMessage liftEither (parse smpP (SEAgentError $ AGENT A_MESSAGE) agentMsgBody) >>= \case agentMsg@(AgentMessage APrivHeader {sndMsgId, prevMsgHash} aMessage) -> do let msgType = agentMessageType agentMsg @@ -2139,7 +2144,8 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s unless (e2eVersion `isCompatible` e2eEncryptVRange) (throwError $ AGENT A_VERSION) (pk1, rcDHRs) <- withStore c (`getRatchetX3dhKeys` connId) let rc = CR.initRcvRatchet e2eEncryptVRange rcDHRs $ CR.x3dhRcv pk1 rcDHRs e2eSndParams - (agentMsgBody_, rc', skipped) <- liftError cryptoError $ CR.rcDecrypt rc M.empty encConnInfo + g <- asks random + (agentMsgBody_, rc', skipped) <- liftError cryptoError $ CR.rcDecrypt g rc M.empty encConnInfo case (agentMsgBody_, skipped) of (Right agentMsgBody, CR.SMDNoChange) -> parseMessage agentMsgBody >>= \case @@ -2151,7 +2157,6 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s where processConf connInfo senderConf duplexHS = do let newConfirmation = NewConfirmation {connId, senderConf, ratchetState = rc'} - g <- asks random confId <- withStore c $ \db -> do setHandshakeVersion db connId agentVersion duplexHS createConfirmation db g newConfirmation @@ -2160,7 +2165,8 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s _ -> prohibited -- party accepting connection (DuplexConnection _ (RcvQueue {smpClientVersion = v'} :| _) _, Nothing) -> do - withStore c (\db -> runExceptT $ agentRatchetDecrypt db connId encConnInfo) >>= parseMessage >>= \case + g <- asks random + withStore c (\db -> runExceptT $ agentRatchetDecrypt g db connId encConnInfo) >>= parseMessage >>= \case AgentConnInfo connInfo -> do notify $ INFO connInfo let dhSecret = C.dh' e2ePubKey e2ePrivKey @@ -2247,7 +2253,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s case (findQ (qAddress sqInfo) sqs, findQ addr sqs) of (Just _, _) -> qError "QADD: queue address is already used in connection" (_, Just sq@SndQueue {dbQueueId}) -> do - let (delSqs, keepSqs) = L.partition ((Just dbQueueId == ) . dbReplaceQId) sqs + let (delSqs, keepSqs) = L.partition ((Just dbQueueId ==) . dbReplaceQId) sqs case L.nonEmpty keepSqs of Just sqs' -> do -- move inside case? @@ -2371,7 +2377,8 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s throwError $ AGENT (A_CRYPTO RATCHET_SYNC) where sendReplyKey = do - (pk1, pk2, e2eParams@(CR.E2ERatchetParams _ k1 k2)) <- liftIO . CR.generateE2EParams $ version e2eOtherPartyParams + g <- asks random + (pk1, pk2, e2eParams@(CR.E2ERatchetParams _ k1 k2)) <- atomically . CR.generateE2EParams g $ version e2eOtherPartyParams void $ enqueueRatchetKeyMsgs c cData' sqs e2eParams pure (pk1, pk2, k1, k2) notifyRatchetSyncError = do @@ -2395,7 +2402,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s | rkHash k1 k2 <= rkHashRcv = do recreateRatchet $ CR.initRcvRatchet e2eEncryptVRange pk2 $ CR.x3dhRcv pk1 pk2 e2eOtherPartyParams | otherwise = do - (_, rcDHRs) <- liftIO C.generateKeyPair' + (_, rcDHRs) <- atomically . C.generateKeyPair =<< asks random recreateRatchet $ CR.initSndRatchet e2eEncryptVRange k2Rcv rcDHRs $ CR.x3dhSnd pk1 pk2 e2eOtherPartyParams void . enqueueMessages' c cData' sqs SMP.MsgFlags {notification = True} $ EREADY lastExternalSndId @@ -2515,23 +2522,24 @@ agentRatchetEncrypt db connId msg paddedLen = do pure encMsg -- encoded EncAgentMessage -> encoded AgentMessage -agentRatchetDecrypt :: DB.Connection -> ConnId -> ByteString -> ExceptT StoreError IO ByteString -agentRatchetDecrypt db connId encAgentMsg = do +agentRatchetDecrypt :: TVar ChaChaDRG -> DB.Connection -> ConnId -> ByteString -> ExceptT StoreError IO ByteString +agentRatchetDecrypt g db connId encAgentMsg = do rc <- ExceptT $ getRatchet db connId - agentRatchetDecrypt' db connId rc encAgentMsg + agentRatchetDecrypt' g db connId rc encAgentMsg -agentRatchetDecrypt' :: DB.Connection -> ConnId -> CR.RatchetX448 -> ByteString -> ExceptT StoreError IO ByteString -agentRatchetDecrypt' db connId rc encAgentMsg = do +agentRatchetDecrypt' :: TVar ChaChaDRG -> DB.Connection -> ConnId -> CR.RatchetX448 -> ByteString -> ExceptT StoreError IO ByteString +agentRatchetDecrypt' g db connId rc encAgentMsg = do skipped <- liftIO $ getSkippedMsgKeys db connId - (agentMsgBody_, rc', skippedDiff) <- liftE (SEAgentError . cryptoError) $ CR.rcDecrypt rc skipped encAgentMsg + (agentMsgBody_, rc', skippedDiff) <- liftE (SEAgentError . cryptoError) $ CR.rcDecrypt g rc skipped encAgentMsg liftIO $ updateRatchet db connId rc' skippedDiff liftEither $ first (SEAgentError . cryptoError) agentMsgBody_ newSndQueue :: (MonadUnliftIO m, MonadReader Env m) => UserId -> ConnId -> Compatible SMPQueueInfo -> m SndQueue newSndQueue userId connId (Compatible (SMPQueueInfo smpClientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey = rcvE2ePubDhKey})) = do C.SignAlg a <- asks $ cmdSignAlg . config - (sndPublicKey, sndPrivateKey) <- liftIO $ C.generateSignatureKeyPair a - (e2ePubKey, e2ePrivKey) <- liftIO C.generateKeyPair' + g <- asks random + (sndPublicKey, sndPrivateKey) <- atomically $ C.generateSignatureKeyPair a g + (e2ePubKey, e2ePrivKey) <- atomically $ C.generateKeyPair g pure SndQueue { userId, diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 0ac65d466..d5cf2db17 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -121,7 +121,7 @@ import Control.Monad import Control.Monad.Except import Control.Monad.IO.Unlift import Control.Monad.Reader -import Crypto.Random (ChaChaDRG, getRandomBytes) +import Crypto.Random (ChaChaDRG) import qualified Data.Aeson.TH as J import Data.Bifunctor (bimap, first, second) import Data.ByteString.Base64 @@ -762,13 +762,14 @@ runSMPServerTest :: AgentMonad m => AgentClient -> UserId -> SMPServerWithAuth - runSMPServerTest c userId (ProtoServerWithAuth srv auth) = do cfg <- getClientConfig c smpCfg C.SignAlg a <- asks $ cmdSignAlg . config + g <- asks random liftIO $ do let tSess = (userId, srv, Nothing) getProtocolClient tSess cfg Nothing (\_ -> pure ()) >>= \case Right smp -> do - (rKey, rpKey) <- C.generateSignatureKeyPair a - (sKey, _) <- C.generateSignatureKeyPair a - (dhKey, _) <- C.generateKeyPair' + (rKey, rpKey) <- atomically $ C.generateSignatureKeyPair a g + (sKey, _) <- atomically $ C.generateSignatureKeyPair a g + (dhKey, _) <- atomically $ C.generateKeyPair g r <- runExceptT $ do SMP.QIK {rcvId} <- liftError (testErr TSCreateQueue) $ createSMPQueue smp rpKey rKey dhKey auth SMSubscribe liftError (testErr TSSecureQueue) $ secureSMPQueue smp rpKey rcvId sKey @@ -785,6 +786,7 @@ runSMPServerTest c userId (ProtoServerWithAuth srv auth) = do runXFTPServerTest :: forall m. AgentMonad m => AgentClient -> UserId -> XFTPServerWithAuth -> m (Maybe ProtocolTestFailure) runXFTPServerTest c userId (ProtoServerWithAuth srv auth) = do cfg <- asks $ xftpCfg . config + g <- asks random xftpNetworkConfig <- readTVarIO $ useNetworkConfig c workDir <- getXFTPWorkPath filePath <- getTempFilePath workDir @@ -793,8 +795,8 @@ runXFTPServerTest c userId (ProtoServerWithAuth srv auth) = do let tSess = (userId, srv, Nothing) X.getXFTPClient tSess cfg {xftpNetworkConfig} (\_ -> pure ()) >>= \case Right xftp -> do - (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519 - (rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519 + (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (rcvKey, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g createTestChunk filePath digest <- liftIO $ C.sha256Hash <$> B.readFile filePath let file = FileInfo {sndKey, size = chSize, digest} @@ -802,7 +804,7 @@ runXFTPServerTest c userId (ProtoServerWithAuth srv auth) = do r <- runExceptT $ do (sId, [rId]) <- liftError (testErr TSCreateFile) $ X.createXFTPChunk xftp spKey file [rcvKey] auth liftError (testErr TSUploadFile) $ X.uploadXFTPChunk xftp spKey sId chunkSpec - liftError (testErr TSDownloadFile) $ X.downloadXFTPChunk xftp rpKey rId $ XFTPRcvChunkSpec rcvPath chSize digest + liftError (testErr TSDownloadFile) $ X.downloadXFTPChunk g xftp rpKey rId $ XFTPRcvChunkSpec rcvPath chSize digest rcvDigest <- liftIO $ C.sha256Hash <$> B.readFile rcvPath unless (digest == rcvDigest) $ throwError $ ProtocolTestFailure TSCompareFile $ XFTP DIGEST liftError (testErr TSDeleteFile) $ X.deleteXFTPChunk xftp spKey sId @@ -821,8 +823,9 @@ runXFTPServerTest c userId (ProtoServerWithAuth srv auth) = do ts <- liftIO getCurrentTime let isoTime = formatTime defaultTimeLocale "%Y-%m-%dT%H%M%S.%6q" ts uniqueCombine workPath isoTime + -- this creates a new DRG on purpose to avoid blocking the one used in the agent createTestChunk :: FilePath -> IO () - createTestChunk fp = B.writeFile fp =<< getRandomBytes chSize + createTestChunk fp = B.writeFile fp =<< atomically . C.randomBytes chSize =<< C.newRandom getXFTPWorkPath :: AgentMonad m => m FilePath getXFTPWorkPath = do @@ -847,9 +850,10 @@ getSessionMode = fmap sessionMode . readTVarIO . useNetworkConfig newRcvQueue :: AgentMonad m => AgentClient -> UserId -> ConnId -> SMPServerWithAuth -> VersionRange -> SubscriptionMode -> m (RcvQueue, SMPQueueUri) newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange subMode = do C.SignAlg a <- asks (cmdSignAlg . config) - (recipientKey, rcvPrivateKey) <- liftIO $ C.generateSignatureKeyPair a - (dhKey, privDhKey) <- liftIO C.generateKeyPair' - (e2eDhKey, e2ePrivKey) <- liftIO C.generateKeyPair' + g <- asks random + (recipientKey, rcvPrivateKey) <- atomically $ C.generateSignatureKeyPair a g + (dhKey, privDhKey) <- atomically $ C.generateKeyPair g + (e2eDhKey, e2ePrivKey) <- atomically $ C.generateKeyPair g logServer "-->" c srv "" "NEW" tSess <- mkTransportSession c userId srv connId QIK {rcvId, sndId, rcvPublicDhKey} <- @@ -1127,13 +1131,14 @@ agentNtfDeleteSubscription c subId NtfToken {ntfServer, ntfPrivKey} = withNtfClient c ntfServer subId "SDEL" $ \ntf -> ntfDeleteSubscription ntf ntfPrivKey subId agentXFTPDownloadChunk :: AgentMonad m => AgentClient -> UserId -> FileDigest -> RcvFileChunkReplica -> XFTPRcvChunkSpec -> m () -agentXFTPDownloadChunk c userId (FileDigest chunkDigest) RcvFileChunkReplica {server, replicaId = ChunkReplicaId fId, replicaKey} chunkSpec = - withXFTPClient c (userId, server, chunkDigest) "FGET" $ \xftp -> X.downloadXFTPChunk xftp replicaKey fId chunkSpec +agentXFTPDownloadChunk c userId (FileDigest chunkDigest) RcvFileChunkReplica {server, replicaId = ChunkReplicaId fId, replicaKey} chunkSpec = do + g <- asks random + withXFTPClient c (userId, server, chunkDigest) "FGET" $ \xftp -> X.downloadXFTPChunk g xftp replicaKey fId chunkSpec agentXFTPNewChunk :: AgentMonad m => AgentClient -> SndFileChunk -> Int -> XFTPServerWithAuth -> m NewSndChunkReplica agentXFTPNewChunk c SndFileChunk {userId, chunkSpec = XFTPChunkSpec {chunkSize}, digest = FileDigest chunkDigest} n (ProtoServerWithAuth srv auth) = do rKeys <- xftpRcvKeys n - (sndKey, replicaKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519 + (sndKey, replicaKey) <- atomically . C.generateSignatureKeyPair C.SEd25519 =<< asks random let fileInfo = FileInfo {sndKey, size = fromIntegral chunkSize, digest = chunkDigest} logServer "-->" c srv "" "FNEW" tSess <- mkTransportSession c userId srv chunkDigest @@ -1157,7 +1162,7 @@ agentXFTPDeleteChunk c userId DeletedSndChunkReplica {server, replicaId = ChunkR xftpRcvKeys :: AgentMonad m => Int -> m (NonEmpty C.ASignatureKeyPair) xftpRcvKeys n = do - rKeys <- liftIO $ replicateM n $ C.generateSignatureKeyPair C.SEd25519 + rKeys <- atomically . replicateM n . C.generateSignatureKeyPair C.SEd25519 =<< asks random case L.nonEmpty rKeys of Just rKeys' -> pure rKeys' _ -> throwError $ INTERNAL "non-positive number of recipients" @@ -1167,7 +1172,7 @@ xftpRcvIdsKeys rIds rKeys = L.map ChunkReplicaId rIds `L.zip` L.map snd rKeys agentCbEncrypt :: AgentMonad m => SndQueue -> Maybe C.PublicKeyX25519 -> ByteString -> m ByteString agentCbEncrypt SndQueue {e2eDhSecret, smpClientVersion} e2ePubKey msg = do - cmNonce <- liftIO C.randomCbNonce + cmNonce <- atomically . C.randomCbNonce =<< asks random let paddedLen = maybe SMP.e2eEncMessageLength (const SMP.e2eEncConfirmationLength) e2ePubKey cmEncBody <- liftEither . first cryptoError $ @@ -1178,9 +1183,10 @@ agentCbEncrypt SndQueue {e2eDhSecret, smpClientVersion} e2ePubKey msg = do -- add encoding as AgentInvitation'? agentCbEncryptOnce :: AgentMonad m => Version -> C.PublicKeyX25519 -> ByteString -> m ByteString agentCbEncryptOnce clientVersion dhRcvPubKey msg = do - (dhSndPubKey, dhSndPrivKey) <- liftIO C.generateKeyPair' + g <- asks random + (dhSndPubKey, dhSndPrivKey) <- atomically $ C.generateKeyPair g let e2eDhSecret = C.dh' dhRcvPubKey dhSndPrivKey - cmNonce <- liftIO C.randomCbNonce + cmNonce <- atomically $ 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 e47de1c46..da96c0c45 100644 --- a/src/Simplex/Messaging/Agent/Env/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Env/SQLite.hs @@ -189,7 +189,7 @@ data Env = Env newSMPAgentEnv :: AgentConfig -> SQLiteStore -> IO Env newSMPAgentEnv config@AgentConfig {initialClientId} store = do - random <- newTVarIO =<< drgNew + random <- C.newRandom clientCounter <- newTVarIO initialClientId randomServer <- newTVarIO =<< liftIO newStdGen ntfSupervisor <- atomically . newNtfSubSupervisor $ tbqSize config diff --git a/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs b/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs index 8434ddbdf..cc7c1b7e4 100644 --- a/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs +++ b/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs @@ -269,8 +269,9 @@ runNtfSMPWorker c srv doWork = do Just NtfToken {ntfTknStatus = NTActive, ntfMode = NMInstant} -> do rq <- withStore c (`getPrimaryRcvQueue` connId) C.SignAlg a <- asks (cmdSignAlg . config) - (ntfPublicKey, ntfPrivateKey) <- liftIO $ C.generateSignatureKeyPair a - (rcvNtfPubDhKey, rcvNtfPrivDhKey) <- liftIO C.generateKeyPair' + g <- asks random + (ntfPublicKey, ntfPrivateKey) <- atomically $ C.generateSignatureKeyPair a g + (rcvNtfPubDhKey, rcvNtfPrivDhKey) <- atomically $ 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 f1388489f..c4043d0ec 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -2106,7 +2106,7 @@ createWithRandomId gVar create = tryCreate 3 | otherwise -> pure . Left . SEInternal $ bshow e randomId :: TVar ChaChaDRG -> Int -> IO ByteString -randomId gVar n = atomically $ U.encode <$> C.pseudoRandomBytes n gVar +randomId gVar n = atomically $ U.encode <$> C.randomBytes n gVar ntfSubAndSMPAction :: NtfSubAction -> (Maybe NtfSubNTFAction, Maybe NtfSubSMPAction) ntfSubAndSMPAction (NtfSubNTFAction action) = (Just action, Nothing) diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs index 65c58919c..3564454ff 100644 --- a/src/Simplex/Messaging/Crypto.hs +++ b/src/Simplex/Messaging/Crypto.hs @@ -61,8 +61,9 @@ module Simplex.Messaging.Crypto DhSecretX25519, ADhSecret (..), KeyHash (..), + newRandom, + generateAKeyPair, generateKeyPair, - generateKeyPair', generateSignatureKeyPair, generateDhKeyPair, privateToX509, @@ -105,7 +106,6 @@ module Simplex.Messaging.Crypto decryptAESNoPad, authTagSize, randomAesKey, - randomIV, randomGCMIV, ivSize, gcmIVSize, @@ -121,7 +121,6 @@ module Simplex.Messaging.Crypto sbEncrypt_, cbNonce, randomCbNonce, - pseudoRandomCbNonce, -- * NaCl crypto_secretbox SbKey (unSbKey), @@ -133,7 +132,7 @@ module Simplex.Messaging.Crypto randomSbKey, -- * pseudo-random bytes - pseudoRandomBytes, + randomBytes, -- * digests sha256Hash, @@ -180,7 +179,7 @@ import qualified Crypto.PubKey.Curve25519 as X25519 import qualified Crypto.PubKey.Curve448 as X448 import qualified Crypto.PubKey.Ed25519 as Ed25519 import qualified Crypto.PubKey.Ed448 as Ed448 -import Crypto.Random (ChaChaDRG, getRandomBytes, randomBytesGenerate) +import Crypto.Random (ChaChaDRG, MonadPseudoRandom, drgNew, randomBytesGenerate, withDRG) import Data.ASN1.BinaryEncoding import Data.ASN1.Encoding import Data.ASN1.Types @@ -595,17 +594,23 @@ type ASignatureKeyPair = KeyPairType APrivateSignKey type ADhKeyPair = KeyPairType APrivateDhKey -generateKeyPair :: AlgorithmI a => SAlgorithm a -> IO AKeyPair -generateKeyPair a = bimap (APublicKey a) (APrivateKey a) <$> generateKeyPair' +newRandom :: IO (TVar ChaChaDRG) +newRandom = newTVarIO =<< drgNew -generateSignatureKeyPair :: (AlgorithmI a, SignatureAlgorithm a) => SAlgorithm a -> IO ASignatureKeyPair -generateSignatureKeyPair a = bimap (APublicVerifyKey a) (APrivateSignKey a) <$> generateKeyPair' +generateAKeyPair :: AlgorithmI a => SAlgorithm a -> TVar ChaChaDRG -> STM AKeyPair +generateAKeyPair a g = bimap (APublicKey a) (APrivateKey a) <$> generateKeyPair g -generateDhKeyPair :: (AlgorithmI a, DhAlgorithm a) => SAlgorithm a -> IO ADhKeyPair -generateDhKeyPair a = bimap (APublicDhKey a) (APrivateDhKey a) <$> generateKeyPair' +generateSignatureKeyPair :: (AlgorithmI a, SignatureAlgorithm a) => SAlgorithm a -> TVar ChaChaDRG -> STM ASignatureKeyPair +generateSignatureKeyPair a g = bimap (APublicVerifyKey a) (APrivateSignKey a) <$> generateKeyPair g -generateKeyPair' :: forall a. AlgorithmI a => IO (KeyPair a) -generateKeyPair' = case sAlgorithm @a of +generateDhKeyPair :: (AlgorithmI a, DhAlgorithm a) => SAlgorithm a -> TVar ChaChaDRG -> STM 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 => MonadPseudoRandom ChaChaDRG (KeyPair a) +generateKeyPair_ = case sAlgorithm @a of SEd25519 -> Ed25519.generateSecretKey >>= \pk -> let k = Ed25519.toPublic pk @@ -974,15 +979,11 @@ initAEADGCM (Key aesKey) (GCMIV ivBytes) = cryptoFailable $ do AES.aeadInit AES.AEAD_GCM cipher ivBytes -- | Random AES256 key. -randomAesKey :: IO Key -randomAesKey = Key <$> getRandomBytes aesKeySize +randomAesKey :: TVar ChaChaDRG -> STM Key +randomAesKey = fmap Key . randomBytes aesKeySize --- | Random IV bytes for AES256 encryption. -randomIV :: IO IV -randomIV = IV <$> getRandomBytes (ivSize @AES256) - -randomGCMIV :: IO GCMIV -randomGCMIV = GCMIV <$> getRandomBytes gcmIVSize +randomGCMIV :: TVar ChaChaDRG -> STM GCMIV +randomGCMIV = fmap GCMIV . randomBytes gcmIVSize ivSize :: forall c. AES.BlockCipher c => Int ivSize = AES.blockSize (undefined :: c) @@ -1143,14 +1144,11 @@ cbNonce s where len = B.length s -randomCbNonce :: IO CbNonce -randomCbNonce = CryptoBoxNonce <$> getRandomBytes 24 +randomCbNonce :: TVar ChaChaDRG -> STM CbNonce +randomCbNonce = fmap CryptoBoxNonce . randomBytes 24 -pseudoRandomCbNonce :: TVar ChaChaDRG -> STM CbNonce -pseudoRandomCbNonce gVar = CryptoBoxNonce <$> pseudoRandomBytes 24 gVar - -pseudoRandomBytes :: Int -> TVar ChaChaDRG -> STM ByteString -pseudoRandomBytes n gVar = stateTVar gVar $ randomBytesGenerate n +randomBytes :: Int -> TVar ChaChaDRG -> STM ByteString +randomBytes n gVar = stateTVar gVar $ randomBytesGenerate n instance Encoding CbNonce where smpEncode = unCbNonce @@ -1187,8 +1185,8 @@ sbKey s unsafeSbKey :: ByteString -> SbKey unsafeSbKey s = either error id $ sbKey s -randomSbKey :: IO SbKey -randomSbKey = SecretBoxKey <$> getRandomBytes 32 +randomSbKey :: TVar ChaChaDRG -> STM SbKey +randomSbKey gVar = SecretBoxKey <$> randomBytes 32 gVar xSalsa20 :: ByteArrayAccess key => key -> ByteString -> ByteString -> (ByteString, ByteString) xSalsa20 secret nonce msg = (rs, msg') diff --git a/src/Simplex/Messaging/Crypto/File.hs b/src/Simplex/Messaging/Crypto/File.hs index 9afc5d583..84a1d18e9 100644 --- a/src/Simplex/Messaging/Crypto/File.hs +++ b/src/Simplex/Messaging/Crypto/File.hs @@ -23,6 +23,7 @@ where import Control.Exception import Control.Monad import Control.Monad.Except +import Crypto.Random (ChaChaDRG) import qualified Data.Aeson.TH as J import qualified Data.ByteArray as BA import Data.ByteString.Char8 (ByteString) @@ -109,8 +110,8 @@ data FTCryptoError plain :: FilePath -> CryptoFile plain = (`CryptoFile` Nothing) -randomArgs :: IO CryptoFileArgs -randomArgs = CFArgs <$> C.randomSbKey <*> C.randomCbNonce +randomArgs :: TVar ChaChaDRG -> STM CryptoFileArgs +randomArgs g = CFArgs <$> C.randomSbKey g <*> C.randomCbNonce g getFileContentsSize :: CryptoFile -> IO Integer getFileContentsSize (CryptoFile path cfArgs) = do diff --git a/src/Simplex/Messaging/Crypto/Ratchet.hs b/src/Simplex/Messaging/Crypto/Ratchet.hs index b84975a3d..4b74bfe7b 100644 --- a/src/Simplex/Messaging/Crypto/Ratchet.hs +++ b/src/Simplex/Messaging/Crypto/Ratchet.hs @@ -15,11 +15,11 @@ module Simplex.Messaging.Crypto.Ratchet where import Control.Monad.Except -import Control.Monad.IO.Class import Control.Monad.Trans.Except import Crypto.Cipher.AES (AES256) import Crypto.Hash (SHA512) import qualified Crypto.KDF.HKDF as H +import Crypto.Random (ChaChaDRG) import Data.Aeson (FromJSON (..), ToJSON (..)) import qualified Data.Aeson as J import qualified Data.Aeson.TH as JQ @@ -40,6 +40,7 @@ import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (blobFieldDecoder, defaultJSON, parseE, parseE') import Simplex.Messaging.Version +import UnliftIO.STM currentE2EEncryptVersion :: Version currentE2EEncryptVersion = 2 @@ -81,10 +82,10 @@ instance AlgorithmI a => StrEncoding (E2ERatchetParamsUri a) where [key1, key2] -> pure $ E2ERatchetParamsUri vs key1 key2 _ -> fail "bad e2e params" -generateE2EParams :: (AlgorithmI a, DhAlgorithm a) => Version -> IO (PrivateKey a, PrivateKey a, E2ERatchetParams a) -generateE2EParams v = do - (k1, pk1) <- generateKeyPair' - (k2, pk2) <- generateKeyPair' +generateE2EParams :: (AlgorithmI a, DhAlgorithm a) => TVar ChaChaDRG -> Version -> STM (PrivateKey a, PrivateKey a, E2ERatchetParams a) +generateE2EParams g v = do + (k1, pk1) <- generateKeyPair g + (k2, pk2) <- generateKeyPair g pure (pk1, pk2, E2ERatchetParams v k1 k2) data RatchetInitParams = RatchetInitParams @@ -345,11 +346,12 @@ maxSkip = 512 rcDecrypt :: forall a. (AlgorithmI a, DhAlgorithm a) => + TVar ChaChaDRG -> Ratchet a -> SkippedMsgKeys -> ByteString -> ExceptT CryptoError IO (DecryptResult a) -rcDecrypt rc@Ratchet {rcRcv, rcAD = Str rcAD} rcMKSkipped msg' = do +rcDecrypt g rc@Ratchet {rcRcv, rcAD = Str rcAD} rcMKSkipped msg' = do encMsg@EncRatchetMessage {emHeader} <- parseE CryptoHeaderError smpP msg' encHdr <- parseE CryptoHeaderError smpP emHeader -- plaintext = TrySkippedMessageKeysHE(state, enc_header, cipher-text, AD) @@ -389,7 +391,7 @@ rcDecrypt rc@Ratchet {rcRcv, rcAD = Str rcAD} rcMKSkipped msg' = do Left e -> throwE e Right (rc'@Ratchet {rcDHRs, rcRK, rcNHKs, rcNHKr}, hmks) -> do -- DHRatchetHE(state, header) - (_, rcDHRs') <- liftIO $ generateKeyPair' @a + (_, rcDHRs') <- atomically $ generateKeyPair @a g -- state.RK, state.CKr, state.NHKr = KDF_RK_HE(state.RK, DH(state.DHRs, state.DHRr)) let (rcRK', rcCKr', rcNHKr') = rootKdf rcRK msgDHRs rcDHRs -- state.RK, state.CKs, state.NHKs = KDF_RK_HE(state.RK, DH(state.DHRs, state.DHRr)) diff --git a/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/RNG.hs b/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/RNG.hs index e776f610d..322d583c9 100644 --- a/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/RNG.hs +++ b/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/RNG.hs @@ -18,7 +18,7 @@ withDRG drg = bracket (createRNGFunc drg) freeHaskellFunPtr createRNGFunc :: TVar ChaChaDRG -> IO (FunPtr RNGFunc) createRNGFunc drg = mkRNGFunc $ \_ctx sz buf -> do - bs <- atomically $ C.pseudoRandomBytes (fromIntegral sz) drg + bs <- atomically $ 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 5d79a0753..302754bce 100644 --- a/src/Simplex/Messaging/Notifications/Server.hs +++ b/src/Simplex/Messaging/Notifications/Server.hs @@ -440,7 +440,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu NtfReqNew corrId (ANE SToken newTkn@(NewNtfTkn _ _ dhPubKey)) -> do logDebug "TNEW - new token" st <- asks store - ks@(srvDhPubKey, srvDhPrivKey) <- liftIO C.generateKeyPair' + ks@(srvDhPubKey, srvDhPrivKey) <- atomically . C.generateKeyPair =<< asks random let dhSecret = C.dh' dhPubKey srvDhPrivKey tknId <- getId regCode <- getRegCode @@ -565,13 +565,11 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu PING -> pure NRPong NtfReqPing corrId entId -> pure (corrId, entId, NRPong) getId :: M NtfEntityId - getId = getRandomBytes =<< asks (subIdBytes . config) + getId = randomBytes =<< asks (subIdBytes . config) getRegCode :: M NtfRegCode - getRegCode = NtfRegCode <$> (getRandomBytes =<< asks (regCodeBytes . config)) - getRandomBytes :: Int -> M ByteString - getRandomBytes n = do - gVar <- asks idsDrg - atomically (C.pseudoRandomBytes n gVar) + getRegCode = NtfRegCode <$> (randomBytes =<< asks (regCodeBytes . config)) + randomBytes :: Int -> M ByteString + randomBytes n = atomically . 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 8e73e450b..e1b4f51c5 100644 --- a/src/Simplex/Messaging/Notifications/Server/Env.hs +++ b/src/Simplex/Messaging/Notifications/Server/Env.hs @@ -76,7 +76,7 @@ data NtfEnv = NtfEnv pushServer :: NtfPushServer, store :: NtfStore, storeLog :: Maybe (StoreLog 'WriteMode), - idsDrg :: TVar ChaChaDRG, + random :: TVar ChaChaDRG, tlsServerParams :: T.ServerParams, serverIdentity :: C.KeyHash, serverStats :: NtfServerStats @@ -84,7 +84,7 @@ data NtfEnv = NtfEnv newNtfServerEnv :: (MonadUnliftIO m, MonadRandom m) => NtfServerConfig -> m NtfEnv newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsConfig, storeLogFile, caCertificateFile, certificateFile, privateKeyFile} = do - idsDrg <- newTVarIO =<< drgNew + random <- liftIO C.newRandom store <- atomically newNtfStore logInfo "restoring subscriptions..." storeLog <- liftIO $ mapM (`readWriteNtfStore` store) storeLogFile @@ -94,7 +94,7 @@ newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsCo tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile Fingerprint fp <- liftIO $ loadFingerprint caCertificateFile serverStats <- atomically . newNtfServerStats =<< liftIO getCurrentTime - pure NtfEnv {config, subscriber, pushServer, store, storeLog, idsDrg, tlsServerParams, serverIdentity = C.KeyHash fp, serverStats} + pure NtfEnv {config, subscriber, pushServer, store, storeLog, random, tlsServerParams, serverIdentity = C.KeyHash fp, serverStats} data NtfSubscriber = NtfSubscriber { smpSubscribers :: TMap SMPServer SMPSubscriber, diff --git a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs index fd07e0a02..5d8e298ea 100644 --- a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs +++ b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs @@ -18,7 +18,7 @@ import Control.Monad.IO.Class import Crypto.Hash.Algorithms (SHA256 (..)) import qualified Crypto.PubKey.ECC.ECDSA as EC import qualified Crypto.PubKey.ECC.Types as ECT -import Crypto.Random (ChaChaDRG, drgNew) +import Crypto.Random (ChaChaDRG) import qualified Crypto.Store.PKCS8 as PK import Data.ASN1.BinaryEncoding (DER (..)) import Data.ASN1.Encoding @@ -232,7 +232,7 @@ createAPNSPushClient apnsHost apnsCfg@APNSPushClientConfig {authKeyFileEnv, auth authKeyId <- T.pack <$> getEnv authKeyIdEnv let jwtHeader = JWTHeader {alg = authKeyAlg, kid = authKeyId} jwtToken <- newTVarIO =<< mkApnsJWTToken appTeamId jwtHeader privateKey - nonceDrg <- drgNew >>= newTVarIO + nonceDrg <- C.newRandom pure APNSPushClient {https2Client, privateKey, jwtHeader, jwtToken, nonceDrg, apnsHost, apnsCfg} getApnsJWTToken :: APNSPushClient -> IO SignedJWTToken @@ -337,7 +337,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.pseudoRandomCbNonce nonceDrg + nonce <- atomically $ 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 14fea9486..7417c948d 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -525,7 +525,7 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ, sess where createQueue :: QueueStore -> RcvPublicVerifyKey -> RcvPublicDhKey -> SubscriptionMode -> m (Transmission BrokerMsg) createQueue st recipientKey dhKey subMode = time "NEW" $ do - (rcvPublicDhKey, privDhKey) <- liftIO C.generateKeyPair' + (rcvPublicDhKey, privDhKey) <- atomically . C.generateKeyPair =<< asks random let rcvDhSecret = C.dh' dhKey privDhKey qik (rcvId, sndId) = QIK {rcvId, sndId, rcvPublicDhKey} qRec (recipientId, senderId) = @@ -580,7 +580,7 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ, sess addQueueNotifier_ :: QueueStore -> NtfPublicVerifyKey -> RcvNtfPublicDhKey -> m (Transmission BrokerMsg) addQueueNotifier_ st notifierKey dhKey = time "NKEY" $ do - (rcvPublicDhKey, privDhKey) <- liftIO C.generateKeyPair' + (rcvPublicDhKey, privDhKey) <- atomically . C.generateKeyPair =<< asks random let rcvNtfDhSecret = C.dh' dhKey privDhKey (corrId,queueId,) <$> addNotifierRetry 3 rcvPublicDhKey rcvNtfDhSecret where @@ -726,7 +726,7 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ, sess Just msg -> time "SEND ok" $ do stats <- asks serverStats when (notification msgFlags) $ do - atomically . trySendNotification msg =<< asks idsDrg + atomically . trySendNotification msg =<< asks random atomically $ modifyTVar' (msgSentNtf stats) (+ 1) atomically $ updatePeriodStats (activeQueuesNtf stats) (recipientId qr) atomically $ modifyTVar' (msgSent stats) (+ 1) @@ -761,7 +761,7 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ, sess mkMessageNotification :: ByteString -> SystemTime -> RcvNtfDhSecret -> TVar ChaChaDRG -> STM (C.CbNonce, EncNMsgMeta) mkMessageNotification msgId msgTs rcvNtfDhSecret ntfNonceDrg = do - cbNonce <- C.pseudoRandomCbNonce ntfNonceDrg + cbNonce <- C.randomCbNonce ntfNonceDrg let msgMeta = NMsgMeta {msgId, msgTs} encNMsgMeta = C.cbEncrypt rcvNtfDhSecret cbNonce (smpEncode msgMeta) 128 pure . (cbNonce,) $ fromRight "" encNMsgMeta @@ -861,9 +861,7 @@ timed name qId a = do sec = 1000_000000 randomId :: (MonadUnliftIO m, MonadReader Env m) => Int -> m ByteString -randomId n = do - gVar <- asks idsDrg - atomically (C.pseudoRandomBytes n gVar) +randomId n = atomically . C.randomBytes n =<< asks random saveServerMessages :: (MonadUnliftIO m, MonadReader Env m) => 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 64b6bdbb0..ab88331f6 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -21,6 +21,7 @@ import qualified Network.TLS as T import Numeric.Natural import Simplex.Messaging.Agent.Lock import Simplex.Messaging.Crypto (KeyHash (..)) +import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Protocol import Simplex.Messaging.Server.Expiration import Simplex.Messaging.Server.MsgStore.STM @@ -100,7 +101,7 @@ data Env = Env serverIdentity :: KeyHash, queueStore :: QueueStore, msgStore :: STMMsgStore, - idsDrg :: TVar ChaChaDRG, + random :: TVar ChaChaDRG, storeLog :: Maybe (StoreLog 'WriteMode), tlsServerParams :: T.ServerParams, serverStats :: ServerStats, @@ -169,7 +170,7 @@ newEnv config@ServerConfig {caCertificateFile, certificateFile, privateKeyFile, server <- atomically newServer queueStore <- atomically newQueueStore msgStore <- atomically newMsgStore - idsDrg <- drgNew >>= newTVarIO + random <- liftIO C.newRandom storeLog <- restoreQueues queueStore `mapM` storeLogFile tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile Fingerprint fp <- liftIO $ loadFingerprint caCertificateFile @@ -178,7 +179,7 @@ newEnv config@ServerConfig {caCertificateFile, certificateFile, privateKeyFile, sockets <- atomically newSocketState clientSeq <- newTVarIO 0 clients <- atomically TM.empty - return Env {config, server, serverIdentity, queueStore, msgStore, idsDrg, storeLog, tlsServerParams, serverStats, sockets, clientSeq, clients} + return Env {config, server, serverIdentity, queueStore, msgStore, random, storeLog, tlsServerParams, serverStats, sockets, clientSeq, clients} where restoreQueues :: QueueStore -> FilePath -> m (StoreLog 'WriteMode) restoreQueues QueueStore {queues, senders, notifiers} f = do diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index 92886e713..e02256aab 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -8,8 +8,8 @@ module Simplex.Messaging.Server.Main where +import Control.Concurrent.STM import Control.Monad (void) -import Crypto.Random (getRandomBytes) import qualified Data.ByteString.Char8 as B import Data.Functor (($>)) import Data.Ini (lookupValue, readIniFile) @@ -95,7 +95,7 @@ smpServerCLI cfgPath logPath = where createServerPassword = \case ServerPassword s -> pure s - SPRandom -> BasicAuth . strEncode <$> (getRandomBytes 32 :: IO B.ByteString) + SPRandom -> BasicAuth . strEncode <$> (atomically . C.randomBytes 32 =<< C.newRandom) iniFileContent host basicAuth = "[STORE_LOG]\n\ \# The server uses STM memory for persistence,\n\ diff --git a/src/Simplex/Messaging/Transport/Credentials.hs b/src/Simplex/Messaging/Transport/Credentials.hs index e935ba2ad..90089f9ef 100644 --- a/src/Simplex/Messaging/Transport/Credentials.hs +++ b/src/Simplex/Messaging/Transport/Credentials.hs @@ -9,6 +9,8 @@ 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) @@ -45,9 +47,9 @@ privateToTls (C.APrivateSignKey _ k) = case k of type Credentials = (C.ASignatureKeyPair, X509.SignedCertificate) -genCredentials :: Maybe Credentials -> (Hours, Hours) -> Text -> IO Credentials -genCredentials parent (before, after) subjectName = do - subjectKeys <- C.generateSignatureKeyPair C.SEd25519 +genCredentials :: TVar ChaChaDRG -> Maybe Credentials -> (Hours, Hours) -> Text -> IO Credentials +genCredentials g parent (before, after) subjectName = do + subjectKeys <- atomically $ 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/RemoteControl/Client.hs b/src/Simplex/RemoteControl/Client.hs index fb78033e6..c73679439 100644 --- a/src/Simplex/RemoteControl/Client.hs +++ b/src/Simplex/RemoteControl/Client.hs @@ -83,10 +83,10 @@ helloBlockSize = 12288 encInvitationSize :: Int encInvitationSize = 900 -newRCHostPairing :: IO RCHostPairing -newRCHostPairing = do - ((_, caKey), caCert) <- genCredentials Nothing (-25, 24 * 999999) "ca" - (_, idPrivKey) <- C.generateKeyPair' +newRCHostPairing :: TVar ChaChaDRG -> IO RCHostPairing +newRCHostPairing drg = do + ((_, caKey), caCert) <- genCredentials drg Nothing (-25, 24 * 999999) "ca" + (_, idPrivKey) <- atomically $ C.generateKeyPair drg pure RCHostPairing {caKey, caCert, idPrivKey, knownHost = Nothing} data RCHostClient = RCHostClient @@ -108,7 +108,7 @@ connectRCHost drg pairing@RCHostPairing {caKey, caCert, idPrivKey, knownHost} ct r <- newEmptyTMVarIO found@(RCCtrlAddress {address} :| _) <- findCtrlAddress c@RCHClient_ {startedPort, announcer} <- liftIO mkClient - hostKeys <- liftIO genHostKeys + hostKeys <- atomically genHostKeys action <- runClient c r hostKeys `putRCError` r -- wait for the port to make invitation portNum <- atomically $ readTMVar startedPort @@ -133,7 +133,7 @@ connectRCHost drg pairing@RCHostPairing {caKey, caCert, idPrivKey, knownHost} ct pure RCHClient_ {startedPort, announcer, hostCAHash, endSession} runClient :: RCHClient_ -> RCStepTMVar (SessionCode, TLS, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)) -> RCHostKeys -> ExceptT RCErrorType IO (Async ()) runClient RCHClient_ {startedPort, announcer, hostCAHash, endSession} r hostKeys = do - tlsCreds <- liftIO $ genTLSCredentials caKey caCert + tlsCreds <- liftIO $ genTLSCredentials drg caKey caCert startTLSServer port_ startedPort tlsCreds (tlsHooks r knownHost hostCAHash) $ \tls -> void . runExceptT $ do r' <- newEmptyTMVarIO @@ -168,10 +168,10 @@ connectRCHost drg pairing@RCHostPairing {caKey, caCert, idPrivKey, knownHost} ct _ -> pure $ TLS.CertificateUsageReject TLS.CertificateRejectUnknownCA } - genHostKeys :: IO RCHostKeys + genHostKeys :: STM RCHostKeys genHostKeys = do - sessKeys <- C.generateKeyPair' - dhKeys <- C.generateKeyPair' + sessKeys <- C.generateKeyPair drg + dhKeys <- C.generateKeyPair drg pure RCHostKeys {sessKeys, dhKeys} mkInvitation :: RCHostKeys -> TransportHost -> PortNumber -> IO RCSignedInvitation mkInvitation RCHostKeys {sessKeys, dhKeys} host portNum = do @@ -190,10 +190,10 @@ connectRCHost drg pairing@RCHostPairing {caKey, caCert, idPrivKey, knownHost} ct } pure $ signInvitation (snd sessKeys) idPrivKey inv -genTLSCredentials :: C.APrivateSignKey -> C.SignedCertificate -> IO TLS.Credentials -genTLSCredentials caKey caCert = do +genTLSCredentials :: TVar ChaChaDRG -> C.APrivateSignKey -> C.SignedCertificate -> IO TLS.Credentials +genTLSCredentials drg caKey caCert = do let caCreds = (C.signatureKeyPair caKey, caCert) - leaf <- genCredentials (Just caCreds) (0, 24 * 999999) "localhost" -- session-signing cert + leaf <- genCredentials drg (Just caCreds) (0, 24 * 999999) "localhost" -- session-signing cert pure . snd $ tlsCredentials (leaf :| [caCreds]) certFingerprint :: X509.SignedCertificate -> C.KeyHash @@ -225,7 +225,7 @@ prepareHostSession knownHost' <- updateKnownHost ca dhPubKey let ctrlHello = RCCtrlHello {} -- TODO send error response if something fails - nonce' <- liftIO . atomically $ C.pseudoRandomCbNonce drg + nonce' <- liftIO . atomically $ 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'}) @@ -258,13 +258,13 @@ connectRCCtrl drg (RCVerifiedInvitation inv@RCInvitation {ca, idkey}) pairing_ h where newCtrlPairing :: IO RCCtrlPairing newCtrlPairing = do - ((_, caKey), caCert) <- genCredentials Nothing (0, 24 * 999999) "ca" - (_, dhPrivKey) <- C.generateKeyPair' + ((_, caKey), caCert) <- genCredentials drg Nothing (0, 24 * 999999) "ca" + (_, dhPrivKey) <- atomically $ 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) $ throwError RCEIdentity - (_, dhPrivKey) <- liftIO C.generateKeyPair' + (_, dhPrivKey) <- atomically $ C.generateKeyPair drg pure pairing {dhPrivKey, prevDhPrivKey = Just currDhPrivKey} connectRCCtrl_ :: TVar ChaChaDRG -> RCCtrlPairing -> RCInvitation -> J.Value -> ExceptT RCErrorType IO RCCtrlConnection @@ -282,7 +282,7 @@ connectRCCtrl_ drg pairing'@RCCtrlPairing {caKey, caCert} inv@RCInvitation {ca, runClient :: RCCClient_ -> RCStepTMVar (SessionCode, TLS, RCStepTMVar (RCCtrlSession, RCCtrlPairing)) -> ExceptT RCErrorType IO () runClient RCCClient_ {confirmSession, endSession} r = do clientCredentials <- - liftIO (genTLSCredentials caKey caCert) >>= \case + liftIO (genTLSCredentials drg caKey caCert) >>= \case TLS.Credentials (creds : _) -> pure $ Just creds _ -> throwError $ RCEInternal "genTLSCredentials must generate credentials" let clientConfig = defaultTransportClientConfig {clientCredentials} @@ -337,7 +337,7 @@ prepareHostHello case compatibleVersion v supportedRCVRange of Nothing -> throwError RCEVersion Just (Compatible v') -> do - nonce <- liftIO . atomically $ C.pseudoRandomCbNonce drg + nonce <- liftIO . atomically $ 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 @@ -369,7 +369,7 @@ announceRC :: TVar ChaChaDRG -> Int -> C.PrivateKeyEd25519 -> C.PublicKeyX25519 announceRC drg maxCount idPrivKey knownDhPub RCHostKeys {sessKeys, dhKeys} inv = withSender $ \sender -> do replicateM_ maxCount $ do logDebug "Announcing..." - nonce <- atomically $ C.pseudoRandomCbNonce drg + nonce <- atomically $ C.randomCbNonce drg encInvitation <- liftEitherWith undefined $ C.cbEncrypt sharedKey nonce sigInvitation encInvitationSize liftIO . UDP.send sender $ smpEncode RCEncInvitation {dhPubKey, nonce, encInvitation} threadDelay 1000000 @@ -434,7 +434,7 @@ cancelCtrlClient RCCtrlClient {action, client_ = RCCClient_ {endSession}} = do rcEncryptBody :: TVar ChaChaDRG -> KEMHybridSecret -> LazyByteString -> ExceptT RCErrorType IO (C.CbNonce, LazyByteString) rcEncryptBody drg hybridKey s = do - nonce <- atomically $ C.pseudoRandomCbNonce drg + nonce <- atomically $ 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 a343c0b7c..95e23b333 100644 --- a/tests/AgentTests/DoubleRatchetTests.hs +++ b/tests/AgentTests/DoubleRatchetTests.hs @@ -11,6 +11,7 @@ module AgentTests.DoubleRatchetTests where import Control.Concurrent.STM import Control.Monad.Except +import Crypto.Random (ChaChaDRG) import Data.Aeson (FromJSON, ToJSON) import qualified Data.Aeson as J import Data.ByteString.Char8 (ByteString) @@ -58,14 +59,14 @@ fullMsgLen = 1 + fullHeaderLen + C.authTagSize + paddedMsgLen testMessageHeader :: Expectation testMessageHeader = do - (k, _) <- C.generateKeyPair' @X25519 + (k, _) <- atomically . C.generateKeyPair @X25519 =<< C.newRandom let hdr = MsgHeader {msgMaxVersion = currentE2EEncryptVersion, msgDHRs = k, msgPN = 0, msgNs = 0} parseAll (smpP @(MsgHeader 'X25519)) (smpEncode hdr) `shouldBe` Right hdr pattern Decrypted :: ByteString -> Either CryptoError (Either CryptoError ByteString) pattern Decrypted msg <- Right (Right msg) -type TestRatchets a = (AlgorithmI a, DhAlgorithm a) => TVar (Ratchet a, SkippedMsgKeys) -> TVar (Ratchet a, SkippedMsgKeys) -> IO () +type TestRatchets a = (AlgorithmI a, DhAlgorithm a) => TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> IO () testEncryptDecrypt :: TestRatchets a testEncryptDecrypt alice bob = do @@ -153,7 +154,7 @@ testSkippedAfterRatchetAdvance alice bob = do testKeyJSON :: forall a. AlgorithmI a => C.SAlgorithm a -> IO () testKeyJSON _ = do - (k, pk) <- C.generateKeyPair' @a + (k, pk) <- atomically . C.generateKeyPair @a =<< C.newRandom testEncodeDecode k testEncodeDecode pk @@ -171,46 +172,51 @@ testEncodeDecode x = do testX3dh :: forall a. (AlgorithmI a, DhAlgorithm a) => C.SAlgorithm a -> IO () testX3dh _ = do - (pkBob1, pkBob2, e2eBob) <- generateE2EParams @a currentE2EEncryptVersion - (pkAlice1, pkAlice2, e2eAlice) <- generateE2EParams @a currentE2EEncryptVersion + g <- C.newRandom + (pkBob1, pkBob2, e2eBob) <- atomically $ generateE2EParams @a g currentE2EEncryptVersion + (pkAlice1, pkAlice2, e2eAlice) <- atomically $ generateE2EParams @a g currentE2EEncryptVersion let paramsBob = x3dhSnd pkBob1 pkBob2 e2eAlice paramsAlice = x3dhRcv pkAlice1 pkAlice2 e2eBob paramsAlice `shouldBe` paramsBob testX3dhV1 :: forall a. (AlgorithmI a, DhAlgorithm a) => C.SAlgorithm a -> IO () testX3dhV1 _ = do - (pkBob1, pkBob2, e2eBob) <- generateE2EParams @a 1 - (pkAlice1, pkAlice2, e2eAlice) <- generateE2EParams @a 1 + g <- C.newRandom + (pkBob1, pkBob2, e2eBob) <- atomically $ generateE2EParams @a g 1 + (pkAlice1, pkAlice2, e2eAlice) <- atomically $ generateE2EParams @a g 1 let paramsBob = x3dhSnd pkBob1 pkBob2 e2eAlice paramsAlice = x3dhRcv pkAlice1 pkAlice2 e2eBob paramsAlice `shouldBe` paramsBob -(#>) :: (AlgorithmI a, DhAlgorithm a) => (TVar (Ratchet a, SkippedMsgKeys), ByteString) -> TVar (Ratchet a, SkippedMsgKeys) -> Expectation +(#>) :: (AlgorithmI a, DhAlgorithm a) => (TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys), ByteString) -> TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> Expectation (alice, msg) #> bob = do Right msg' <- encrypt alice msg Decrypted msg'' <- decrypt bob msg' msg'' `shouldBe` msg -withRatchets :: forall a. (AlgorithmI a, DhAlgorithm a) => (TVar (Ratchet a, SkippedMsgKeys) -> TVar (Ratchet a, SkippedMsgKeys) -> IO ()) -> Expectation +withRatchets :: forall a. (AlgorithmI a, DhAlgorithm a) => (TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> IO ()) -> Expectation withRatchets test = do + ga <- C.newRandom + gb <- C.newRandom (a, b) <- initRatchets @a - alice <- newTVarIO (a, M.empty) - bob <- newTVarIO (b, M.empty) + alice <- newTVarIO (ga, a, M.empty) + bob <- newTVarIO (gb, b, M.empty) test alice bob `shouldReturn` () initRatchets :: (AlgorithmI a, DhAlgorithm a) => IO (Ratchet a, Ratchet a) initRatchets = do - (pkBob1, pkBob2, e2eBob) <- generateE2EParams currentE2EEncryptVersion - (pkAlice1, pkAlice2, e2eAlice) <- generateE2EParams currentE2EEncryptVersion + g <- C.newRandom + (pkBob1, pkBob2, e2eBob) <- atomically $ generateE2EParams g currentE2EEncryptVersion + (pkAlice1, pkAlice2, e2eAlice) <- atomically $ generateE2EParams g currentE2EEncryptVersion let paramsBob = x3dhSnd pkBob1 pkBob2 e2eAlice paramsAlice = x3dhRcv pkAlice1 pkAlice2 e2eBob - (_, pkBob3) <- C.generateKeyPair' + (_, pkBob3) <- atomically $ C.generateKeyPair g let bob = initSndRatchet supportedE2EEncryptVRange (C.publicKey pkAlice2) pkBob3 paramsBob alice = initRcvRatchet supportedE2EEncryptVRange pkAlice2 paramsAlice pure (alice, bob) -encrypt_ :: AlgorithmI a => (Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either CryptoError (ByteString, Ratchet a, SkippedMsgDiff)) -encrypt_ (rc, _) msg = +encrypt_ :: AlgorithmI a => (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either CryptoError (ByteString, Ratchet a, SkippedMsgDiff)) +encrypt_ (_, rc, _) msg = runExceptT (rcEncrypt rc paddedMsgLen msg) >>= either (pure . Left) checkLength where @@ -218,26 +224,26 @@ encrypt_ (rc, _) msg = B.length msg' `shouldBe` fullMsgLen pure $ Right (msg', rc', SMDNoChange) -decrypt_ :: (AlgorithmI a, DhAlgorithm a) => (Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either CryptoError (Either CryptoError ByteString, Ratchet a, SkippedMsgDiff)) -decrypt_ (rc, smks) msg = runExceptT $ rcDecrypt rc smks msg +decrypt_ :: (AlgorithmI a, DhAlgorithm a) => (TVar 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 => TVar (Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either CryptoError ByteString) +encrypt :: AlgorithmI a => TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either CryptoError ByteString) encrypt = withTVar encrypt_ -decrypt :: (AlgorithmI a, DhAlgorithm a) => TVar (Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either CryptoError (Either CryptoError ByteString)) +decrypt :: (AlgorithmI a, DhAlgorithm a) => TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either CryptoError (Either CryptoError ByteString)) decrypt = withTVar decrypt_ withTVar :: AlgorithmI a => - ((Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either e (r, Ratchet a, SkippedMsgDiff))) -> - TVar (Ratchet a, SkippedMsgKeys) -> + ((TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either e (r, Ratchet a, SkippedMsgDiff))) -> + TVar (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either e r) -withTVar op rcVar msg = - readTVarIO rcVar - >>= (\(rc, smks) -> applyDiff smks <$$> (testEncodeDecode rc >> op (rc, smks) msg)) +withTVar op rcVar msg = do + (g, rc, smks) <- readTVarIO rcVar + applyDiff smks <$$> (testEncodeDecode rc >> op (g, rc, smks) msg) >>= \case - Right (res, rc', smks') -> atomically (writeTVar rcVar (rc', smks')) >> pure (Right res) + Right (res, rc', smks') -> atomically (writeTVar rcVar (g, rc', smks')) >> pure (Right res) Left e -> pure $ Left e where applyDiff smks (res, rc', smDiff) = (res, rc', applySMDiff smks smDiff) diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index 9c2aa2fdf..80e9770ad 100644 --- a/tests/AgentTests/SQLiteTests.hs +++ b/tests/AgentTests/SQLiteTests.hs @@ -15,7 +15,6 @@ import Control.Concurrent.Async (concurrently_) import Control.Concurrent.STM import Control.Exception (SomeException) import Control.Monad (replicateM_) -import Crypto.Random (drgNew) import Data.ByteArray (ScrubbedBytes) import Data.ByteString.Char8 (ByteString) import Data.List (isInfixOf) @@ -118,7 +117,7 @@ storeTests = do testConcurrentWrites :: SpecWith (SQLiteStore, SQLiteStore) testConcurrentWrites = it "should complete multiple concurrent write transactions w/t sqlite busy errors" $ \(s1, s2) -> do - g <- newTVarIO =<< drgNew + g <- C.newRandom _ <- withTransaction s1 $ \db -> createRcvConn db g cData1 rcvQueue1 SCMInvitation let ConnData {connId} = cData1 @@ -208,7 +207,7 @@ sndQueue1 = testCreateRcvConn :: SpecWith SQLiteStore testCreateRcvConn = it "should create RcvConnection and add SndQueue" . withStoreTransaction $ \db -> do - g <- newTVarIO =<< drgNew + g <- C.newRandom createRcvConn db g cData1 rcvQueue1 SCMInvitation `shouldReturn` Right "conn1" getConn db "conn1" @@ -221,7 +220,7 @@ testCreateRcvConn = testCreateRcvConnRandomId :: SpecWith SQLiteStore testCreateRcvConnRandomId = it "should create RcvConnection and add SndQueue with random ID" . withStoreTransaction $ \db -> do - g <- newTVarIO =<< drgNew + g <- C.newRandom Right connId <- createRcvConn db g cData1 {connId = ""} rcvQueue1 SCMInvitation let rq' = (rcvQueue1 :: RcvQueue) {connId} sq' = (sndQueue1 :: SndQueue) {connId} @@ -235,7 +234,7 @@ testCreateRcvConnRandomId = testCreateRcvConnDuplicate :: SpecWith SQLiteStore testCreateRcvConnDuplicate = it "should throw error on attempt to create duplicate RcvConnection" . withStoreTransaction $ \db -> do - g <- newTVarIO =<< drgNew + g <- C.newRandom _ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation createRcvConn db g cData1 rcvQueue1 SCMInvitation `shouldReturn` Left SEConnDuplicate @@ -243,7 +242,7 @@ testCreateRcvConnDuplicate = testCreateSndConn :: SpecWith SQLiteStore testCreateSndConn = it "should create SndConnection and add RcvQueue" . withStoreTransaction $ \db -> do - g <- newTVarIO =<< drgNew + g <- C.newRandom createSndConn db g cData1 sndQueue1 `shouldReturn` Right "conn1" getConn db "conn1" @@ -256,7 +255,7 @@ testCreateSndConn = testCreateSndConnRandomID :: SpecWith SQLiteStore testCreateSndConnRandomID = it "should create SndConnection and add RcvQueue with random ID" . withStoreTransaction $ \db -> do - g <- newTVarIO =<< drgNew + g <- C.newRandom Right connId <- createSndConn db g cData1 {connId = ""} sndQueue1 let rq' = (rcvQueue1 :: RcvQueue) {connId} sq' = (sndQueue1 :: SndQueue) {connId} @@ -270,7 +269,7 @@ testCreateSndConnRandomID = testCreateSndConnDuplicate :: SpecWith SQLiteStore testCreateSndConnDuplicate = it "should throw error on attempt to create duplicate SndConnection" . withStoreTransaction $ \db -> do - g <- newTVarIO =<< drgNew + g <- C.newRandom _ <- createSndConn db g cData1 sndQueue1 createSndConn db g cData1 sndQueue1 `shouldReturn` Left SEConnDuplicate @@ -280,7 +279,7 @@ testGetRcvConn = it "should get connection using rcv queue id and server" . withStoreTransaction $ \db -> do let smpServer = SMPServer "smp.simplex.im" "5223" testKeyHash let recipientId = "1234" - g <- newTVarIO =<< drgNew + g <- C.newRandom _ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation getRcvConn db smpServer recipientId `shouldReturn` Right (rcvQueue1, SomeConn SCRcv (RcvConnection cData1 rcvQueue1)) @@ -288,7 +287,7 @@ testGetRcvConn = testDeleteRcvConn :: SpecWith SQLiteStore testDeleteRcvConn = it "should create RcvConnection and delete it" . withStoreTransaction $ \db -> do - g <- newTVarIO =<< drgNew + g <- C.newRandom _ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation getConn db "conn1" `shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 rcvQueue1)) @@ -300,7 +299,7 @@ testDeleteRcvConn = testDeleteSndConn :: SpecWith SQLiteStore testDeleteSndConn = it "should create SndConnection and delete it" . withStoreTransaction $ \db -> do - g <- newTVarIO =<< drgNew + g <- C.newRandom _ <- createSndConn db g cData1 sndQueue1 getConn db "conn1" `shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 sndQueue1)) @@ -312,7 +311,7 @@ testDeleteSndConn = testDeleteDuplexConn :: SpecWith SQLiteStore testDeleteDuplexConn = it "should create DuplexConnection and delete it" . withStoreTransaction $ \db -> do - g <- newTVarIO =<< drgNew + g <- C.newRandom _ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation _ <- upgradeRcvConnToDuplex db "conn1" sndQueue1 getConn db "conn1" @@ -325,7 +324,7 @@ testDeleteDuplexConn = testUpgradeRcvConnToDuplex :: SpecWith SQLiteStore testUpgradeRcvConnToDuplex = it "should throw error on attempt to add SndQueue to SndConnection or DuplexConnection" . withStoreTransaction $ \db -> do - g <- newTVarIO =<< drgNew + g <- C.newRandom _ <- createSndConn db g cData1 sndQueue1 let anotherSndQueue = SndQueue @@ -353,7 +352,7 @@ testUpgradeRcvConnToDuplex = testUpgradeSndConnToDuplex :: SpecWith SQLiteStore testUpgradeSndConnToDuplex = it "should throw error on attempt to add RcvQueue to RcvConnection or DuplexConnection" . withStoreTransaction $ \db -> do - g <- newTVarIO =<< drgNew + g <- C.newRandom _ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation let anotherRcvQueue = RcvQueue @@ -384,7 +383,7 @@ testUpgradeSndConnToDuplex = testSetRcvQueueStatus :: SpecWith SQLiteStore testSetRcvQueueStatus = it "should update status of RcvQueue" . withStoreTransaction $ \db -> do - g <- newTVarIO =<< drgNew + g <- C.newRandom _ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation getConn db "conn1" `shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 rcvQueue1)) @@ -396,7 +395,7 @@ testSetRcvQueueStatus = testSetSndQueueStatus :: SpecWith SQLiteStore testSetSndQueueStatus = it "should update status of SndQueue" . withStoreTransaction $ \db -> do - g <- newTVarIO =<< drgNew + g <- C.newRandom _ <- createSndConn db g cData1 sndQueue1 getConn db "conn1" `shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 sndQueue1)) @@ -408,7 +407,7 @@ testSetSndQueueStatus = testSetQueueStatusDuplex :: SpecWith SQLiteStore testSetQueueStatusDuplex = it "should update statuses of RcvQueue and SndQueue in DuplexConnection" . withStoreTransaction $ \db -> do - g <- newTVarIO =<< drgNew + g <- C.newRandom _ <- createRcvConn db g cData1 rcvQueue1 SCMInvitation _ <- upgradeRcvConnToDuplex db "conn1" sndQueue1 getConn db "conn1" @@ -460,7 +459,7 @@ testCreateRcvMsg_ db expectedPrevSndId expectedPrevHash connId rq rcvMsgData@Rcv testCreateRcvMsg :: SpecWith SQLiteStore testCreateRcvMsg = it "should reserve internal ids and create a RcvMsg" $ \st -> do - g <- newTVarIO =<< drgNew + g <- C.newRandom let ConnData {connId} = cData1 _ <- withTransaction st $ \db -> do createRcvConn db g cData1 rcvQueue1 SCMInvitation @@ -491,7 +490,7 @@ testCreateSndMsg_ db expectedPrevHash connId sndMsgData@SndMsgData {..} = do testCreateSndMsg :: SpecWith SQLiteStore testCreateSndMsg = it "should create a SndMsg and return InternalId and PrevSndMsgHash" $ \st -> do - g <- newTVarIO =<< drgNew + g <- C.newRandom let ConnData {connId} = cData1 _ <- withTransaction st $ \db -> do createSndConn db g cData1 sndQueue1 @@ -504,7 +503,7 @@ testCreateRcvAndSndMsgs = it "should create multiple RcvMsg and SndMsg, correctly ordering internal Ids and returning previous state" $ \st -> do let ConnData {connId} = cData1 _ <- withTransaction st $ \db -> do - g <- newTVarIO =<< drgNew + g <- C.newRandom createRcvConn db g cData1 rcvQueue1 SCMInvitation withTransaction st $ \db -> do _ <- upgradeRcvConnToDuplex db "conn1" sndQueue1 diff --git a/tests/CoreTests/BatchingTests.hs b/tests/CoreTests/BatchingTests.hs index 260411e6e..fea45d4d5 100644 --- a/tests/CoreTests/BatchingTests.hs +++ b/tests/CoreTests/BatchingTests.hs @@ -4,7 +4,6 @@ module CoreTests.BatchingTests (batchingTests) where import Control.Concurrent.STM import Control.Monad -import Crypto.Random (MonadRandom (..)) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import qualified Data.List.NonEmpty as L @@ -28,7 +27,7 @@ batchingTests = do testBatchSubscriptions :: IO () testBatchSubscriptions = do - sessId <- getRandomBytes 32 + sessId <- atomically . C.randomBytes 32 =<< C.newRandom subs <- replicateM 200 $ randomSUB sessId let batches1 = batchTransmissions False smpBlockSize $ L.fromList subs all lenOk1 batches1 `shouldBe` True @@ -41,7 +40,7 @@ testBatchSubscriptions = do testBatchWithMessage :: IO () testBatchWithMessage = do - sessId <- getRandomBytes 32 + sessId <- atomically . C.randomBytes 32 =<< C.newRandom subs1 <- replicateM 60 $ randomSUB sessId send <- randomSEND sessId 8000 subs2 <- replicateM 40 $ randomSUB sessId @@ -57,7 +56,7 @@ testBatchWithMessage = do testBatchWithLargeMessage :: IO () testBatchWithLargeMessage = do - sessId <- getRandomBytes 32 + sessId <- atomically . C.randomBytes 32 =<< C.newRandom subs1 <- replicateM 60 $ randomSUB sessId send <- randomSEND sessId 17000 subs2 <- replicateM 100 $ randomSUB sessId @@ -76,7 +75,7 @@ testBatchWithLargeMessage = do testClientBatchSubscriptions :: IO () testClientBatchSubscriptions = do - sessId <- getRandomBytes 32 + sessId <- atomically . C.randomBytes 32 =<< C.newRandom client <- atomically $ clientStub sessId subs <- replicateM 200 $ randomSUBCmd client let batches1 = batchClientTransmissions False smpBlockSize $ L.fromList subs @@ -90,7 +89,7 @@ testClientBatchSubscriptions = do testClientBatchWithMessage :: IO () testClientBatchWithMessage = do - sessId <- getRandomBytes 32 + sessId <- atomically . C.randomBytes 32 =<< C.newRandom client <- atomically $ clientStub sessId subs1 <- replicateM 60 $ randomSUBCmd client send <- randomSENDCmd client 8000 @@ -108,7 +107,7 @@ testClientBatchWithMessage = do testClientBatchWithLargeMessage :: IO () testClientBatchWithLargeMessage = do - sessId <- getRandomBytes 32 + sessId <- atomically . C.randomBytes 32 =<< C.newRandom client <- atomically $ clientStub sessId subs1 <- replicateM 60 $ randomSUBCmd client send <- randomSENDCmd client 17000 @@ -138,32 +137,36 @@ testClientBatchWithLargeMessage = do randomSUB :: ByteString -> IO (Maybe C.ASignature, ByteString) randomSUB sessId = do - rId <- getRandomBytes 24 - corrId <- CorrId <$> getRandomBytes 3 - (_, rpKey) <- C.generateSignatureKeyPair C.SEd448 + g <- C.newRandom + rId <- atomically $ C.randomBytes 24 g + corrId <- atomically $ CorrId <$> C.randomBytes 3 g + (_, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g let s = encodeTransmission (maxVersion supportedSMPServerVRange) sessId (corrId, rId, Cmd SRecipient SUB) pure (Just $ C.sign rpKey s, s) randomSUBCmd :: ProtocolClient ErrorType BrokerMsg -> IO (PCTransmission ErrorType BrokerMsg) randomSUBCmd c = do - rId <- getRandomBytes 24 - (_, rpKey) <- C.generateSignatureKeyPair C.SEd448 + g <- C.newRandom + rId <- atomically $ C.randomBytes 24 g + (_, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g mkTransmission c (Just rpKey, rId, Cmd SRecipient SUB) randomSEND :: ByteString -> Int -> IO (Maybe C.ASignature, ByteString) randomSEND sessId len = do - sId <- getRandomBytes 24 - corrId <- CorrId <$> getRandomBytes 3 - (_, rpKey) <- C.generateSignatureKeyPair C.SEd448 - msg <- getRandomBytes len + g <- C.newRandom + sId <- atomically $ C.randomBytes 24 g + corrId <- atomically $ CorrId <$> C.randomBytes 3 g + (_, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g + msg <- atomically $ C.randomBytes len g let s = encodeTransmission (maxVersion supportedSMPServerVRange) sessId (corrId, sId, Cmd SSender $ SEND noMsgFlags msg) pure (Just $ C.sign rpKey s, s) randomSENDCmd :: ProtocolClient ErrorType BrokerMsg -> Int -> IO (PCTransmission ErrorType BrokerMsg) randomSENDCmd c len = do - sId <- getRandomBytes 24 - (_, rpKey) <- C.generateSignatureKeyPair C.SEd448 - msg <- getRandomBytes len + g <- C.newRandom + sId <- atomically $ C.randomBytes 24 g + (_, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g + msg <- atomically $ 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 b15405d02..a1af00c08 100644 --- a/tests/CoreTests/CryptoFileTests.hs +++ b/tests/CoreTests/CryptoFileTests.hs @@ -3,12 +3,13 @@ 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 (getRandomBytes) +import Crypto.Random (ChaChaDRG) import qualified Data.ByteString.Lazy as LB import GHC.IO.IOMode (IOMode (..)) -import qualified Simplex.FileTransfer.Types as C +import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.File (CryptoFile (..), FTCryptoError (..)) import qualified Simplex.Messaging.Crypto.File as CF import System.Directory (getFileSize) @@ -27,8 +28,9 @@ testFilePath = "tests/tmp/testcryptofile" testWriteReadFile :: IO () testWriteReadFile = do - s <- LB.fromStrict <$> getRandomBytes 100000 - file <- mkCryptoFile + g <- C.newRandom + s <- atomically $ LB.fromStrict <$> C.randomBytes 100000 g + file <- atomically $ mkCryptoFile g runRight_ $ do CF.writeFile file s liftIO $ CF.getFileContentsSize file `shouldReturn` 100000 @@ -38,9 +40,10 @@ testWriteReadFile = do testPutGetFile :: IO () testPutGetFile = do - s <- LB.fromStrict <$> getRandomBytes 50000 - s' <- LB.fromStrict <$> getRandomBytes 50000 - file <- mkCryptoFile + g <- C.newRandom + s <- atomically $ LB.fromStrict <$> C.randomBytes 50000 g + s' <- atomically $ LB.fromStrict <$> C.randomBytes 50000 g + file <- atomically $ mkCryptoFile g runRight_ $ do CF.withFile file WriteMode $ \h -> liftIO $ do CF.hPut h s @@ -57,8 +60,9 @@ testPutGetFile = do testWriteGetFile :: IO () testWriteGetFile = do - s <- LB.fromStrict <$> getRandomBytes 100000 - file <- mkCryptoFile + g <- C.newRandom + s <- atomically $ LB.fromStrict <$> C.randomBytes 100000 g + file <- atomically $ mkCryptoFile g runRight_ $ do CF.writeFile file s CF.withFile file ReadMode $ \h -> do @@ -70,9 +74,10 @@ testWriteGetFile = do testPutReadFile :: IO () testPutReadFile = do - s <- LB.fromStrict <$> getRandomBytes 50000 - s' <- LB.fromStrict <$> getRandomBytes 50000 - file <- mkCryptoFile + g <- C.newRandom + s <- atomically $ LB.fromStrict <$> C.randomBytes 50000 g + s' <- atomically $ LB.fromStrict <$> C.randomBytes 50000 g + file <- atomically $ mkCryptoFile g runRight_ $ do CF.withFile file WriteMode $ \h -> liftIO $ do CF.hPut h s @@ -88,11 +93,12 @@ testPutReadFile = do testSmallFile :: IO () testSmallFile = do - file <- mkCryptoFile + g <- C.newRandom + file <- atomically $ mkCryptoFile g LB.writeFile testFilePath "" runExceptT (CF.readFile file) `shouldReturn` Left FTCEInvalidFileSize LB.writeFile testFilePath "123" runExceptT (CF.readFile file) `shouldReturn` Left FTCEInvalidFileSize -mkCryptoFile :: IO CryptoFile -mkCryptoFile = CryptoFile testFilePath . Just <$> CF.randomArgs +mkCryptoFile :: TVar ChaChaDRG -> STM CryptoFile +mkCryptoFile g = CryptoFile testFilePath . Just <$> CF.randomArgs g diff --git a/tests/CoreTests/CryptoTests.hs b/tests/CoreTests/CryptoTests.hs index fb902a41e..39bc17c4b 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 Crypto.Random (drgNew, getRandomBytes) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB import Data.Either (isRight) @@ -105,14 +104,16 @@ testPadUnpadFile = do testSignature :: (C.AlgorithmI a, C.SignatureAlgorithm a) => C.SAlgorithm a -> Spec testSignature alg = it "should sign / verify string" . ioProperty $ do - (k, pk) <- C.generateSignatureKeyPair alg + g <- C.newRandom + (k, pk) <- atomically $ 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 - (sk, spk) <- C.generateKeyPair' - (rk, rpk) <- C.generateKeyPair' - nonce <- C.randomCbNonce + g <- C.newRandom + (sk, spk) <- atomically $ C.generateKeyPair g + (rk, rpk) <- atomically $ C.generateKeyPair g + nonce <- atomically $ C.randomCbNonce g pure $ \(s, pad) -> let b = encodeUtf8 $ T.pack s paddedLen = B.length b + abs pad + 2 @@ -122,8 +123,9 @@ 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 - k <- C.randomSbKey - nonce <- C.randomCbNonce + g <- C.newRandom + k <- atomically $ C.randomSbKey g + nonce <- atomically $ C.randomCbNonce g pure $ \(s, pad) -> let b = encodeUtf8 $ T.pack s pad' = min (abs pad) 100000 @@ -134,8 +136,9 @@ 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 - k <- C.randomSbKey - nonce <- C.randomCbNonce + g <- C.newRandom + k <- atomically $ C.randomSbKey g + nonce <- atomically $ C.randomCbNonce g pure $ \(s, pad) -> let b = LE.encodeUtf8 $ LT.pack s len = LB.length b @@ -147,8 +150,9 @@ 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 - k <- C.randomSbKey - nonce <- C.randomCbNonce + g <- C.newRandom + k <- atomically $ C.randomSbKey g + nonce <- atomically $ C.randomCbNonce g let f = "tests/tmp/testsecretbox" paddedLen = 4 * 1024 * 1024 len = 4 * 1000 * 1000 :: Int64 @@ -160,8 +164,9 @@ 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 - k <- C.randomSbKey - nonce <- C.randomCbNonce + g <- C.newRandom + k <- atomically $ C.randomSbKey g + nonce <- atomically $ C.randomCbNonce g pure $ \(s, pad) -> let b = LE.encodeUtf8 $ LT.pack s len = LB.length b @@ -173,8 +178,9 @@ 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 - k <- C.randomSbKey - nonce <- C.randomCbNonce + g <- C.newRandom + k <- atomically $ C.randomSbKey g + nonce <- atomically $ C.randomCbNonce g let f = "tests/tmp/testsecretbox" paddedLen = 4 * 1024 * 1024 len = 4 * 1000 * 1000 :: Int64 @@ -187,9 +193,10 @@ testLazySecretBoxFileTailTag = it "should lazily encrypt / decrypt file with a r testAESGCM :: Spec testAESGCM = it "should encrypt / decrypt string with a random symmetric key" $ do - k <- C.randomAesKey - iv <- C.randomGCMIV - s <- getRandomBytes 100 + g <- C.newRandom + k <- atomically $ C.randomAesKey g + iv <- atomically $ C.randomGCMIV g + s <- atomically $ 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 @@ -197,14 +204,15 @@ 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 - (k, pk) <- C.generateKeyPair alg + g <- C.newRandom + (k, pk) <- atomically $ C.generateAKeyPair alg g pure $ \(_ :: Int) -> C.decodePubKey (C.encodePubKey k) == Right k && C.decodePrivKey (C.encodePrivKey pk) == Right pk testSNTRUP761 :: IO () testSNTRUP761 = do - drg <- newTVarIO =<< drgNew + drg <- C.newRandom (pk, sk) <- sntrup761Keypair drg (c, KEMSharedKey k) <- sntrup761Enc drg pk KEMSharedKey k' <- sntrup761Dec c sk diff --git a/tests/NtfServerTests.hs b/tests/NtfServerTests.hs index 77a4b1945..b46ea311d 100644 --- a/tests/NtfServerTests.hs +++ b/tests/NtfServerTests.hs @@ -88,10 +88,11 @@ testNotificationSubscription :: ATransport -> Spec testNotificationSubscription (ATransport t) = -- hangs on Ubuntu 20/22 xit' "should create notification subscription and notify when message is received" $ do - (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519 - (nPub, nKey) <- C.generateSignatureKeyPair C.SEd25519 - (tknPub, tknKey) <- C.generateSignatureKeyPair C.SEd25519 - (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair' + g <- C.newRandom + (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (nPub, nKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (tknPub, tknKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g let tkn = DeviceToken PPApnsTest "abcd" withAPNSMockServer $ \APNSMockServer {apnsQ} -> smpTest2 t $ \rh sh -> @@ -110,7 +111,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) <- C.generateKeyPair' + (rcvNtfPubDhKey, rcvNtfPrivDhKey) <- atomically $ 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 d4079fe9f..c0a32cd4c 100644 --- a/tests/RemoteControl.hs +++ b/tests/RemoteControl.hs @@ -6,9 +6,10 @@ module RemoteControl where import AgentTests.FunctionalAPITests (runRight) import Control.Logger.Simple -import Crypto.Random (ChaChaDRG, drgNew) +import Crypto.Random (ChaChaDRG) import qualified Data.Aeson as J import Data.List.NonEmpty (NonEmpty (..)) +import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String (StrEncoding (..)) import qualified Simplex.RemoteControl.Client as HC (RCHostClient (action)) import qualified Simplex.RemoteControl.Client as RC @@ -62,8 +63,8 @@ testPreferAddress = do testNewPairing :: IO () testNewPairing = do - drg <- drgNew >>= newTVarIO - hp <- RC.newRCHostPairing + drg <- C.newRandom + hp <- RC.newRCHostPairing drg invVar <- newEmptyMVar ctrlSessId <- async . runRight $ do logNote "c 1" @@ -108,9 +109,9 @@ testNewPairing = do testExistingPairing :: IO () testExistingPairing = do - drg <- drgNew >>= newTVarIO + drg <- C.newRandom invVar <- newEmptyMVar - hp <- liftIO $ RC.newRCHostPairing + hp <- RC.newRCHostPairing drg ctrl <- runCtrl drg False hp invVar inv <- takeMVar invVar let cp_ = Nothing @@ -139,10 +140,10 @@ testExistingPairing = do testMulticast :: IO () testMulticast = do - drg <- drgNew >>= newTVarIO + drg <- C.newRandom subscribers <- newTMVarIO 0 invVar <- newEmptyMVar - hp <- liftIO RC.newRCHostPairing + hp <- RC.newRCHostPairing drg ctrl <- runCtrl drg False hp invVar inv <- takeMVar invVar let cp_ = Nothing diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index cc20d3958..cd9ef27a7 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -120,8 +120,9 @@ testCreateSecureV2 :: forall c. Transport c => TProxy c -> Spec testCreateSecureV2 _ = it "should create (NEW) and secure (KEY) queue" $ withSmpServerConfigOn (transport @c) cfgV2 testPort $ \_ -> testSMPClient @c $ \h -> do - (rPub, rKey) <- C.generateSignatureKeyPair C.SEd448 - (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair' + g <- C.newRandom + (rPub, rKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g + (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe) let dec = decryptMsgV2 $ C.dh' srvDh dhPriv (rId1, "") #== "creates queue" @@ -139,7 +140,7 @@ testCreateSecureV2 _ = Resp "dabc" _ err6 <- signSendRecv h rKey ("dabc", rId, ACK mId1) (err6, ERR NO_MSG) #== "replies ERR when message acknowledged without messages" - (sPub, sKey) <- C.generateSignatureKeyPair C.SEd448 + (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g Resp "abcd" sId2 err1 <- signSendRecv h sKey ("abcd", sId, _SEND "hello") (err1, ERR AUTH) #== "rejects signed SEND" (sId2, sId) #== "same queue ID in response 2" @@ -155,7 +156,7 @@ testCreateSecureV2 _ = (rId2, rId) #== "same queue ID in response 3" Resp "abcd" _ OK <- signSendRecv h rKey ("abcd", rId, KEY sPub) - (sPub', _) <- C.generateSignatureKeyPair C.SEd448 + (sPub', _) <- atomically $ C.generateSignatureKeyPair C.SEd448 g Resp "abcd" _ err4 <- signSendRecv h rKey ("abcd", rId, KEY sPub') (err4, ERR AUTH) #== "rejects if secured with different key" @@ -184,8 +185,9 @@ testCreateSecure :: ATransport -> Spec testCreateSecure (ATransport t) = it "should create (NEW) and secure (KEY) queue" $ smpTest2 t $ \r s -> do - (rPub, rKey) <- C.generateSignatureKeyPair C.SEd448 - (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair' + g <- C.newRandom + (rPub, rKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g + (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv r rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe) let dec = decryptMsgV3 $ C.dh' srvDh dhPriv (rId1, "") #== "creates queue" @@ -203,7 +205,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) <- C.generateSignatureKeyPair C.SEd448 + (sPub, sKey) <- atomically $ C.generateSignatureKeyPair 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" @@ -219,7 +221,7 @@ testCreateSecure (ATransport t) = (rId2, rId) #== "same queue ID in response 3" Resp "abcd" _ OK <- signSendRecv r rKey ("abcd", rId, KEY sPub) - (sPub', _) <- C.generateSignatureKeyPair C.SEd448 + (sPub', _) <- atomically $ C.generateSignatureKeyPair C.SEd448 g Resp "abcd" _ err4 <- signSendRecv r rKey ("abcd", rId, KEY sPub') (err4, ERR AUTH) #== "rejects if secured with different key" @@ -248,13 +250,14 @@ testCreateDelete :: ATransport -> Spec testCreateDelete (ATransport t) = it "should create (NEW), suspend (OFF) and delete (DEL) queue" $ smpTest2 t $ \rh sh -> do - (rPub, rKey) <- C.generateSignatureKeyPair C.SEd25519 - (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair' + g <- C.newRandom + (rPub, rKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe) let dec = decryptMsgV3 $ C.dh' srvDh dhPriv (rId1, "") #== "creates queue" - (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519 + (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g Resp "bcda" _ ok1 <- signSendRecv rh rKey ("bcda", rId, KEY sPub) (ok1, OK) #== "secures queue" @@ -318,8 +321,9 @@ stressTest :: ATransport -> Spec stressTest (ATransport t) = it "should create many queues, disconnect and re-connect" $ smpTest3 t $ \h1 h2 h3 -> do - (rPub, rKey) <- C.generateSignatureKeyPair C.SEd25519 - (dhPub, _ :: C.PrivateKeyX25519) <- C.generateKeyPair' + g <- C.newRandom + (rPub, rKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (dhPub, _ :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g rIds <- forM ([1 .. 50] :: [Int]) . const $ do Resp "" "" (Ids rId _ _) <- signSendRecv h1 rKey ("", "", NEW rPub dhPub Nothing SMSubscribe) pure rId @@ -336,8 +340,9 @@ testAllowNewQueues t = it "should prohibit creating new queues with allowNewQueues = False" $ do withSmpServerConfigOn (ATransport t) cfg {allowNewQueues = False} testPort $ \_ -> testSMPClient @c $ \h -> do - (rPub, rKey) <- C.generateSignatureKeyPair C.SEd448 - (dhPub, _ :: C.PrivateKeyX25519) <- C.generateKeyPair' + g <- C.newRandom + (rPub, rKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g + (dhPub, _ :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g Resp "abcd" "" (ERR AUTH) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe) pure () @@ -345,13 +350,14 @@ testDuplex :: ATransport -> Spec testDuplex (ATransport t) = it "should create 2 simplex connections and exchange messages" $ smpTest2 t $ \alice bob -> do - (arPub, arKey) <- C.generateSignatureKeyPair C.SEd448 - (aDhPub, aDhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair' + g <- C.newRandom + (arPub, arKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g + (aDhPub, aDhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g Resp "abcd" _ (Ids aRcv aSnd aSrvDh) <- signSendRecv alice arKey ("abcd", "", NEW arPub aDhPub Nothing SMSubscribe) let aDec = decryptMsgV3 $ C.dh' aSrvDh aDhPriv -- aSnd ID is passed to Bob out-of-band - (bsPub, bsKey) <- C.generateSignatureKeyPair C.SEd448 + (bsPub, bsKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g Resp "bcda" _ OK <- sendRecv bob ("", "bcda", aSnd, _SEND $ "key " <> strEncode bsPub) -- "key ..." is ad-hoc, not a part of SMP protocol @@ -361,8 +367,8 @@ testDuplex (ATransport t) = (bobKey, strEncode bsPub) #== "key received from Bob" Resp "dabc" _ OK <- signSendRecv alice arKey ("dabc", aRcv, KEY bsPub) - (brPub, brKey) <- C.generateSignatureKeyPair C.SEd448 - (bDhPub, bDhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair' + (brPub, brKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g + (bDhPub, bDhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g Resp "abcd" _ (Ids bRcv bSnd bSrvDh) <- signSendRecv bob brKey ("abcd", "", NEW brPub bDhPub Nothing SMSubscribe) let bDec = decryptMsgV3 $ C.dh' bSrvDh bDhPriv Resp "bcda" _ OK <- signSendRecv bob bsKey ("bcda", aSnd, _SEND $ "reply_id " <> encode bSnd) @@ -373,7 +379,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) <- C.generateSignatureKeyPair C.SEd448 + (asPub, asKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g Resp "dabc" _ OK <- sendRecv alice ("", "dabc", bSnd, _SEND $ "key " <> strEncode asPub) -- "key ..." is ad-hoc, not a part of SMP protocol @@ -399,8 +405,9 @@ testSwitchSub :: ATransport -> Spec testSwitchSub (ATransport t) = it "should create simplex connections and switch subscription to another TCP connection" $ smpTest3 t $ \rh1 rh2 sh -> do - (rPub, rKey) <- C.generateSignatureKeyPair C.SEd448 - (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair' + g <- C.newRandom + (rPub, rKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g + (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g Resp "abcd" _ (Ids rId sId srvDh) <- signSendRecv rh1 rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe) let dec = decryptMsgV3 $ C.dh' srvDh dhPriv Resp "bcda" _ ok1 <- sendRecv sh ("", "bcda", sId, _SEND "test1") @@ -438,7 +445,8 @@ testSwitchSub (ATransport t) = testGetCommand :: forall c. Transport c => TProxy c -> Spec testGetCommand t = it "should retrieve messages from the queue using GET command" $ do - (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519 + g <- C.newRandom + (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g smpTest t $ \sh -> do queue <- newEmptyTMVarIO testSMPClient @c $ \rh -> @@ -456,7 +464,8 @@ testGetCommand t = 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 - (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519 + g <- C.newRandom + (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g smpTest3 t $ \rh1 rh2 sh -> do (sId, rId, rKey, dhShared) <- createAndSecureQueue rh1 sPub let dec = decryptMsgV3 dhShared @@ -507,7 +516,8 @@ testExceedQueueQuota t = it "should reply with ERR QUOTA to sender and send QUOTA message to the recipient" $ do withSmpServerConfigOn (ATransport t) cfg {msgQueueQuota = 2} testPort $ \_ -> testSMPClient @c $ \sh -> testSMPClient @c $ \rh -> do - (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519 + g <- C.newRandom + (sPub, sKey) <- atomically $ C.generateSignatureKeyPair 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") @@ -531,9 +541,10 @@ testExceedQueueQuota t = testWithStoreLog :: ATransport -> Spec testWithStoreLog at@(ATransport t) = it "should store simplex queues to log and restore them after server restart" $ do - (sPub1, sKey1) <- C.generateSignatureKeyPair C.SEd25519 - (sPub2, sKey2) <- C.generateSignatureKeyPair C.SEd25519 - (nPub, nKey) <- C.generateSignatureKeyPair C.SEd25519 + g <- C.newRandom + (sPub1, sKey1) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (sPub2, sKey2) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (nPub, nKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g recipientId1 <- newTVarIO "" recipientKey1 <- newTVarIO Nothing dhShared1 <- newTVarIO Nothing @@ -543,7 +554,7 @@ testWithStoreLog at@(ATransport t) = withSmpServerStoreLogOn at testPort . runTest t $ \h -> runClient t $ \h1 -> do (sId1, rId1, rKey1, dhShared) <- createAndSecureQueue h sPub1 - (rcvNtfPubDhKey, _) <- C.generateKeyPair' + (rcvNtfPubDhKey, _) <- atomically $ C.generateKeyPair g Resp "abcd" _ (NID nId _) <- signSendRecv h rKey1 ("abcd", rId1, NKEY nPub rcvNtfPubDhKey) atomically $ do writeTVar recipientId1 rId1 @@ -619,7 +630,8 @@ testRestoreMessages at@(ATransport t) = removeFileIfExists testStoreMsgsFile removeFileIfExists testServerStatsBackupFile - (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519 + g <- C.newRandom + (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g recipientId <- newTVarIO "" recipientKey <- newTVarIO Nothing dhShared <- newTVarIO Nothing @@ -720,7 +732,8 @@ checkStats s qs sent received = do testRestoreMessagesV2 :: ATransport -> Spec testRestoreMessagesV2 at@(ATransport t) = it "should store messages on exit and restore on start" $ do - (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519 + g <- C.newRandom + (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g recipientId <- newTVarIO "" recipientKey <- newTVarIO Nothing dhShared <- newTVarIO Nothing @@ -789,7 +802,8 @@ testRestoreMessagesV2 at@(ATransport t) = testRestoreExpireMessages :: ATransport -> Spec testRestoreExpireMessages at@(ATransport t) = it "should store messages on exit and restore on start" $ do - (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519 + g <- C.newRandom + (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g recipientId <- newTVarIO "" recipientKey <- newTVarIO Nothing dhShared <- newTVarIO Nothing @@ -843,8 +857,9 @@ testRestoreExpireMessages at@(ATransport t) = createAndSecureQueue :: Transport c => THandle c -> SndPublicVerifyKey -> IO (SenderId, RecipientId, RcvPrivateSignKey, RcvDhSecret) createAndSecureQueue h sPub = do - (rPub, rKey) <- C.generateSignatureKeyPair C.SEd448 - (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair' + g <- C.newRandom + (rPub, rKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g + (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe) let dhShared = C.dh' srvDh dhPriv Resp "dabc" rId' OK <- signSendRecv h rKey ("dabc", rId, KEY sPub) @@ -868,16 +883,17 @@ testTiming (ATransport t) = similarTime t1 t2 = abs (t2 / t1 - 1) < 0.25 `shouldBe` True testSameTiming :: Transport c => THandle c -> THandle c -> (Int, Int, Int) -> Expectation testSameTiming rh sh (goodKeySize, badKeySize, n) = do - (rPub, rKey) <- generateKeys goodKeySize - (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair' + g <- C.newRandom + (rPub, rKey) <- generateKeys g goodKeySize + (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe) let dec = decryptMsgV3 $ C.dh' srvDh dhPriv Resp "cdab" _ OK <- signSendRecv rh rKey ("cdab", rId, SUB) - (_, badKey) <- generateKeys badKeySize + (_, badKey) <- generateKeys g badKeySize -- runTimingTest rh badKey rId "SUB" - (sPub, sKey) <- generateKeys goodKeySize + (sPub, sKey) <- generateKeys g goodKeySize Resp "dabc" _ OK <- signSendRecv rh rKey ("dabc", rId, KEY sPub) Resp "bcda" _ OK <- signSendRecv sh sKey ("bcda", sId, _SEND "hello") @@ -886,9 +902,9 @@ testTiming (ATransport t) = runTimingTest sh badKey sId $ _SEND "hello" where - generateKeys = \case - 32 -> C.generateSignatureKeyPair C.SEd25519 - 57 -> C.generateSignatureKeyPair C.SEd448 + generateKeys g = \case + 32 -> atomically $ C.generateSignatureKeyPair C.SEd25519 g + 57 -> atomically $ C.generateSignatureKeyPair C.SEd448 g _ -> error "unsupported key size" runTimingTest h badKey qId cmd = do timeWrongKey <- timeRepeat n $ do @@ -909,12 +925,13 @@ testTiming (ATransport t) = testMessageNotifications :: ATransport -> Spec testMessageNotifications (ATransport t) = it "should create simplex connection, subscribe notifier and deliver notifications" $ do - (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519 - (nPub, nKey) <- C.generateSignatureKeyPair C.SEd25519 + g <- C.newRandom + (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (nPub, nKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g smpTest4 t $ \rh sh nh1 nh2 -> do (sId, rId, rKey, dhShared) <- createAndSecureQueue rh sPub let dec = decryptMsgV3 dhShared - (rcvNtfPubDhKey, _) <- C.generateKeyPair' + (rcvNtfPubDhKey, _) <- atomically $ 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 @@ -945,7 +962,8 @@ testMessageNotifications (ATransport t) = testMsgExpireOnSend :: forall c. Transport c => TProxy c -> Spec testMsgExpireOnSend t = it "should expire messages that are not received before messageTTL on SEND" $ do - (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519 + g <- C.newRandom + (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g let cfg' = cfg {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 10000}} withSmpServerConfigOn (ATransport t) cfg' testPort $ \_ -> testSMPClient @c $ \sh -> do @@ -965,7 +983,8 @@ testMsgExpireOnInterval :: forall c. Transport c => TProxy c -> Spec testMsgExpireOnInterval t = -- fails on ubuntu xit' "should expire messages that are not received before messageTTL after expiry interval" $ do - (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519 + g <- C.newRandom + (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g let cfg' = cfg {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}} withSmpServerConfigOn (ATransport t) cfg' testPort $ \_ -> testSMPClient @c $ \sh -> do @@ -983,7 +1002,8 @@ testMsgExpireOnInterval t = 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 - (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519 + g <- C.newRandom + (sPub, sKey) <- atomically $ C.generateSignatureKeyPair 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 465c9c2b6..f6061c2d7 100644 --- a/tests/XFTPAgent.hs +++ b/tests/XFTPAgent.hs @@ -8,6 +8,7 @@ module XFTPAgent where import AgentTests.FunctionalAPITests (get, getSMPAgentClient', rfGet, runRight, runRight_, sfGet) import Control.Concurrent (threadDelay) +import Control.Concurrent.STM import Control.Logger.Simple import Control.Monad import Control.Monad.Except @@ -24,6 +25,7 @@ import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..)) import Simplex.Messaging.Agent (AgentClient, disconnectAgentClient, testProtocolServer, xftpDeleteRcvFile, xftpDeleteSndFileInternal, xftpDeleteSndFileRemote, xftpReceiveFile, xftpSendFile, xftpStartWorkers) import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..)) import Simplex.Messaging.Agent.Protocol (ACommand (..), AgentErrorType (..), BrokerErrorType (..), RcvFileId, SndFileId, noAuthSrv) +import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs) import qualified Simplex.Messaging.Crypto.File as CF import Simplex.Messaging.Encoding.String (StrEncoding (..)) @@ -107,9 +109,10 @@ testXFTPAgentSendReceive = withXFTPServer $ do testXFTPAgentSendReceiveEncrypted :: HasCallStack => IO () testXFTPAgentSendReceiveEncrypted = withXFTPServer $ do + g <- C.newRandom filePath <- createRandomFile s <- LB.readFile filePath - file <- CryptoFile (senderFiles "encrypted_testfile") . Just <$> CF.randomArgs + file <- atomically $ CryptoFile (senderFiles "encrypted_testfile") . Just <$> CF.randomArgs g runRight_ $ CF.writeFile file s sndr <- getSMPAgentClient' agentCfg initAgentServers testDB (rfd1, rfd2) <- runRight $ do @@ -117,12 +120,12 @@ testXFTPAgentSendReceiveEncrypted = withXFTPServer $ do xftpDeleteSndFileInternal sndr sfId pure (rfd1, rfd2) -- receive file, delete rcv file - testReceiveDelete rfd1 filePath - testReceiveDelete rfd2 filePath + testReceiveDelete rfd1 filePath g + testReceiveDelete rfd2 filePath g where - testReceiveDelete rfd originalFilePath = do + testReceiveDelete rfd originalFilePath g = do rcp <- getSMPAgentClient' agentCfg initAgentServers testDB2 - cfArgs <- Just <$> CF.randomArgs + cfArgs <- atomically $ Just <$> CF.randomArgs g runRight_ $ do rfId <- testReceiveCF rcp rfd cfArgs originalFilePath xftpDeleteRcvFile rcp rfId diff --git a/tests/XFTPServerTests.hs b/tests/XFTPServerTests.hs index 3a6645cdd..cb939e07e 100644 --- a/tests/XFTPServerTests.hs +++ b/tests/XFTPServerTests.hs @@ -8,12 +8,10 @@ module XFTPServerTests where import AgentTests.FunctionalAPITests (runRight_) import Control.Concurrent (threadDelay) -import Control.Concurrent.STM import Control.Exception (SomeException) import Control.Monad import Control.Monad.Except import Control.Monad.IO.Unlift -import Crypto.Random (getRandomBytes) import qualified Data.ByteString.Base64.URL as B64 import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B @@ -33,6 +31,7 @@ import Simplex.Messaging.Server.Expiration (ExpirationConfig (..)) import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive, removeFile) import System.FilePath (()) import Test.Hspec +import UnliftIO.STM import XFTPClient xftpServerTests :: Spec @@ -68,7 +67,8 @@ testChunkPath = "tests/tmp/chunk1" createTestChunk :: FilePath -> IO ByteString createTestChunk fp = do - bytes <- getRandomBytes chSize + g <- C.newRandom + bytes <- atomically $ C.randomBytes chSize g B.writeFile fp bytes pure bytes @@ -83,8 +83,9 @@ testFileChunkDelivery2 = xftpTest2 $ \s r -> runRight_ $ runTestFileChunkDeliver runTestFileChunkDelivery :: XFTPClient -> XFTPClient -> ExceptT XFTPClientError IO () runTestFileChunkDelivery s r = do - (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519 - (rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519 + g <- liftIO C.newRandom + (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (rcvKey, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g bytes <- liftIO $ createTestChunk testChunkPath digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath let file = FileInfo {sndKey, size = chSize, digest} @@ -95,17 +96,18 @@ runTestFileChunkDelivery s r = do uploadXFTPChunk s spKey sId' chunkSpec `catchError` (liftIO . (`shouldBe` PCEProtocolError DIGEST)) liftIO $ readChunk sId `shouldReturn` bytes - downloadXFTPChunk r rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize (digest <> "_wrong")) + downloadXFTPChunk g r rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize (digest <> "_wrong")) `catchError` (liftIO . (`shouldBe` PCEResponseError DIGEST)) - downloadXFTPChunk r rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize 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 - (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519 - (rcvKey1, rpKey1) <- liftIO $ C.generateSignatureKeyPair C.SEd25519 - (rcvKey2, rpKey2) <- liftIO $ C.generateSignatureKeyPair C.SEd25519 - (rcvKey3, rpKey3) <- liftIO $ C.generateSignatureKeyPair C.SEd25519 + g <- liftIO C.newRandom + (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (rcvKey1, rpKey1) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (rcvKey2, rpKey2) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (rcvKey3, rpKey3) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g bytes <- liftIO $ createTestChunk testChunkPath digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath let file = FileInfo {sndKey, size = chSize, digest} @@ -114,7 +116,7 @@ testFileChunkDeliveryAddRecipients = xftpTest4 $ \s r1 r2 r3 -> runRight_ $ do [rId2, rId3] <- addXFTPRecipients s spKey sId [rcvKey2, rcvKey3] uploadXFTPChunk s spKey sId chunkSpec let testReceiveChunk r rpKey rId fPath = do - downloadXFTPChunk r rpKey rId $ XFTPRcvChunkSpec fPath chSize digest + 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" @@ -128,8 +130,9 @@ testFileChunkDelete2 = xftpTest2 $ \s r -> runRight_ $ runTestFileChunkDelete s runTestFileChunkDelete :: XFTPClient -> XFTPClient -> ExceptT XFTPClientError IO () runTestFileChunkDelete s r = do - (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519 - (rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519 + g <- liftIO C.newRandom + (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (rcvKey, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g bytes <- liftIO $ createTestChunk testChunkPath digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath let file = FileInfo {sndKey, size = chSize, digest} @@ -137,13 +140,13 @@ runTestFileChunkDelete s r = do (sId, [rId]) <- createXFTPChunk s spKey file [rcvKey] Nothing uploadXFTPChunk s spKey sId chunkSpec - downloadXFTPChunk r rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest + 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 r rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk2" chSize digest) + 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)) @@ -156,8 +159,9 @@ testFileChunkAck2 = xftpTest2 $ \s r -> runRight_ $ runTestFileChunkAck s r runTestFileChunkAck :: XFTPClient -> XFTPClient -> ExceptT XFTPClientError IO () runTestFileChunkAck s r = do - (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519 - (rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519 + g <- liftIO C.newRandom + (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (rcvKey, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g bytes <- liftIO $ createTestChunk testChunkPath digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath let file = FileInfo {sndKey, size = chSize, digest} @@ -165,30 +169,33 @@ runTestFileChunkAck s r = do (sId, [rId]) <- createXFTPChunk s spKey file [rcvKey] Nothing uploadXFTPChunk s spKey sId chunkSpec - downloadXFTPChunk r rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest + 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 r rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk2" chSize digest) + 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 -> runRight_ $ do - (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519 - (rcvKey, _rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519 - liftIO $ B.writeFile testChunkPath =<< getRandomBytes (kb 96) - digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath +testWrongChunkSize = xftpTest $ \c -> do + g <- C.newRandom + (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (rcvKey, _rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + B.writeFile testChunkPath =<< atomically (C.randomBytes (kb 96) g) + digest <- LC.sha256Hash <$> LB.readFile testChunkPath let file = FileInfo {sndKey, size = kb 96, digest} - void (createXFTPChunk c spKey file [rcvKey] Nothing) - `catchError` (liftIO . (`shouldBe` PCEProtocolError SIZE)) + runRight_ $ + void (createXFTPChunk c spKey file [rcvKey] Nothing) + `catchError` (liftIO . (`shouldBe` PCEProtocolError SIZE)) testFileChunkExpiration :: Expectation testFileChunkExpiration = withXFTPServerCfg testXFTPServerConfig {fileExpiration} $ \_ -> testXFTPClient $ \c -> runRight_ $ do - (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519 - (rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519 + g <- liftIO C.newRandom + (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (rcvKey, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g bytes <- liftIO $ createTestChunk testChunkPath digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath let file = FileInfo {sndKey, size = chSize, digest} @@ -196,11 +203,11 @@ testFileChunkExpiration = withXFTPServerCfg testXFTPServerConfig {fileExpiration (sId, [rId]) <- createXFTPChunk c spKey file [rcvKey] Nothing uploadXFTPChunk c spKey sId chunkSpec - downloadXFTPChunk c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest + 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 c rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk2" chSize digest) + 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)) @@ -210,14 +217,15 @@ testFileChunkExpiration = withXFTPServerCfg testXFTPServerConfig {fileExpiration testFileStorageQuota :: Expectation testFileStorageQuota = withXFTPServerCfg testXFTPServerConfig {fileSizeQuota = Just $ chSize * 2} $ \_ -> testXFTPClient $ \c -> runRight_ $ do - (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519 - (rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519 + g <- liftIO C.newRandom + (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (rcvKey, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g bytes <- liftIO $ createTestChunk testChunkPath digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath let file = FileInfo {sndKey, size = chSize, digest} chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize} download rId = do - downloadXFTPChunk c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest + 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 @@ -236,10 +244,11 @@ testFileStorageQuota = withXFTPServerCfg testXFTPServerConfig {fileSizeQuota = J testFileLog :: Expectation testFileLog = do + g <- C.newRandom bytes <- liftIO $ createTestChunk testChunkPath - (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519 - (rcvKey1, rpKey1) <- liftIO $ C.generateSignatureKeyPair C.SEd25519 - (rcvKey2, rpKey2) <- liftIO $ C.generateSignatureKeyPair C.SEd25519 + (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (rcvKey1, rpKey1) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (rcvKey2, rpKey2) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath sIdVar <- newTVarIO "" rIdVar1 <- newTVarIO "" @@ -257,8 +266,8 @@ testFileLog = do writeTVar rIdVar1 rId1 writeTVar rIdVar2 rId2 uploadXFTPChunk c spKey sId chunkSpec - download c rpKey1 rId1 digest bytes - download c rpKey2 rId2 digest bytes + download g c rpKey1 rId1 digest bytes + download g c rpKey2 rId2 digest bytes logSize testXFTPLogFile `shouldReturn` 3 logSize testXFTPStatsBackupFile `shouldReturn` 11 @@ -269,9 +278,9 @@ testFileLog = do rId1 <- liftIO $ readTVarIO rIdVar1 rId2 <- liftIO $ readTVarIO rIdVar2 -- recipients and sender get AUTH error because server restarted without log - downloadXFTPChunk c rpKey1 rId1 (XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest) + downloadXFTPChunk g c rpKey1 rId1 (XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest) `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH)) - downloadXFTPChunk c rpKey2 rId2 (XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest) + downloadXFTPChunk g c rpKey2 rId2 (XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest) `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH)) deleteXFTPChunk c spKey sId `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH)) @@ -282,10 +291,10 @@ testFileLog = do rId1 <- liftIO $ readTVarIO rIdVar1 rId2 <- liftIO $ readTVarIO rIdVar2 -- recipient 1 can download, acknowledges - +1 to log - download c rpKey1 rId1 digest bytes + download g c rpKey1 rId1 digest bytes ackXFTPChunk c rpKey1 rId1 -- recipient 2 can download - download c rpKey2 rId2 digest bytes + download g c rpKey2 rId2 digest bytes logSize testXFTPLogFile `shouldReturn` 4 logSize testXFTPStatsBackupFile `shouldReturn` 11 @@ -301,10 +310,10 @@ testFileLog = do rId1 <- liftIO $ readTVarIO rIdVar1 rId2 <- liftIO $ readTVarIO rIdVar2 -- recipient 1 can't download due to previous acknowledgement - download c rpKey1 rId1 digest bytes + download g c rpKey1 rId1 digest bytes `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH)) -- recipient 2 can download - download c rpKey2 rId2 digest bytes + download g c rpKey2 rId2 digest bytes -- sender can delete - +1 to log deleteXFTPChunk c spKey sId logSize testXFTPLogFile `shouldReturn` 4 @@ -321,26 +330,28 @@ testFileLog = do removeFile testXFTPLogFile removeFile testXFTPStatsBackupFile where - download c rpKey rId digest bytes = do - downloadXFTPChunk c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest + download g c rpKey rId digest bytes = do + downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes testFileBasicAuth :: Bool -> Maybe BasicAuth -> Maybe BasicAuth -> Bool -> IO () testFileBasicAuth allowNewFiles newFileBasicAuth clntAuth success = withXFTPServerCfg testXFTPServerConfig {allowNewFiles, newFileBasicAuth} $ - \_ -> testXFTPClient $ \c -> runRight_ $ do - (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519 - (rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519 - bytes <- liftIO $ createTestChunk testChunkPath - digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath + \_ -> testXFTPClient $ \c -> do + g <- C.newRandom + (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (rcvKey, rpKey) <- atomically $ C.generateSignatureKeyPair 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} - if success - then do - (sId, [rId]) <- createXFTPChunk c spKey file [rcvKey] clntAuth - uploadXFTPChunk c spKey sId chunkSpec - downloadXFTPChunk c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk" chSize digest - liftIO $ B.readFile "tests/tmp/received_chunk" `shouldReturn` bytes - else do - void (createXFTPChunk c spKey file [rcvKey] clntAuth) - `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH)) + runRight_ $ + if success + then do + (sId, [rId]) <- createXFTPChunk c spKey file [rcvKey] clntAuth + uploadXFTPChunk c spKey sId chunkSpec + downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk" chSize digest + liftIO $ B.readFile "tests/tmp/received_chunk" `shouldReturn` bytes + else do + void (createXFTPChunk c spKey file [rcvKey] clntAuth) + `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))