diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs index 9489f52c1..85c1200eb 100644 --- a/src/Simplex/FileTransfer/Client.hs +++ b/src/Simplex/FileTransfer/Client.hs @@ -131,7 +131,7 @@ xftpClientError = \case HCNetworkError -> PCENetworkError HCIOError e -> PCEIOError e -sendXFTPCommand :: forall p. FilePartyI p => XFTPClient -> C.APrivateSignKey -> XFTPFileId -> FileCommand p -> Maybe XFTPChunkSpec -> ExceptT XFTPClientError IO (FileResponse, HTTP2Body) +sendXFTPCommand :: forall p. FilePartyI p => XFTPClient -> C.APrivateAuthKey -> XFTPFileId -> FileCommand p -> Maybe XFTPChunkSpec -> ExceptT XFTPClientError IO (FileResponse, HTTP2Body) sendXFTPCommand c@XFTPClient {http2Client = HTTP2Client {sessionId}} pKey fId cmd chunkSpec_ = do t <- liftEither . first PCETransportError $ @@ -163,9 +163,9 @@ sendXFTPTransmission XFTPClient {config, http2Client = http2@HTTP2Client {sessio createXFTPChunk :: XFTPClient -> - C.APrivateSignKey -> + C.APrivateAuthKey -> FileInfo -> - NonEmpty C.APublicVerifyKey -> + NonEmpty C.APublicAuthKey -> Maybe BasicAuth -> ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId) createXFTPChunk c spKey file rcps auth_ = @@ -173,17 +173,17 @@ createXFTPChunk c spKey file rcps auth_ = (FRSndIds sId rIds, body) -> noFile body (sId, rIds) (r, _) -> throwError . PCEUnexpectedResponse $ bshow r -addXFTPRecipients :: XFTPClient -> C.APrivateSignKey -> XFTPFileId -> NonEmpty C.APublicVerifyKey -> ExceptT XFTPClientError IO (NonEmpty RecipientId) +addXFTPRecipients :: XFTPClient -> C.APrivateAuthKey -> XFTPFileId -> NonEmpty C.APublicAuthKey -> ExceptT XFTPClientError IO (NonEmpty RecipientId) addXFTPRecipients c spKey fId rcps = sendXFTPCommand c spKey fId (FADD rcps) Nothing >>= \case (FRRcvIds rIds, body) -> noFile body rIds (r, _) -> throwError . PCEUnexpectedResponse $ bshow r -uploadXFTPChunk :: XFTPClient -> C.APrivateSignKey -> XFTPFileId -> XFTPChunkSpec -> ExceptT XFTPClientError IO () +uploadXFTPChunk :: XFTPClient -> C.APrivateAuthKey -> XFTPFileId -> XFTPChunkSpec -> ExceptT XFTPClientError IO () uploadXFTPChunk c spKey fId chunkSpec = sendXFTPCommand c spKey fId FPUT (Just chunkSpec) >>= okResponse -downloadXFTPChunk :: TVar ChaChaDRG -> XFTPClient -> C.APrivateSignKey -> XFTPFileId -> XFTPRcvChunkSpec -> ExceptT XFTPClientError IO () +downloadXFTPChunk :: TVar ChaChaDRG -> XFTPClient -> C.APrivateAuthKey -> XFTPFileId -> XFTPRcvChunkSpec -> ExceptT XFTPClientError IO () downloadXFTPChunk g c@XFTPClient {config} rpKey fId chunkSpec@XFTPRcvChunkSpec {filePath, chunkSize} = do (rDhKey, rpDhKey) <- atomically $ C.generateKeyPair g sendXFTPCommand c rpKey fId (FGET rDhKey) Nothing >>= \case @@ -205,10 +205,10 @@ downloadXFTPChunk g c@XFTPClient {config} rpKey fId chunkSpec@XFTPRcvChunkSpec { chunkTimeout :: XFTPClientConfig -> Word32 -> Int chunkTimeout config chunkSize = fromIntegral $ (fromIntegral chunkSize * uploadTimeoutPerMb config) `div` mb 1 -deleteXFTPChunk :: XFTPClient -> C.APrivateSignKey -> SenderId -> ExceptT XFTPClientError IO () +deleteXFTPChunk :: XFTPClient -> C.APrivateAuthKey -> SenderId -> ExceptT XFTPClientError IO () deleteXFTPChunk c spKey sId = sendXFTPCommand c spKey sId FDEL Nothing >>= okResponse -ackXFTPChunk :: XFTPClient -> C.APrivateSignKey -> RecipientId -> ExceptT XFTPClientError IO () +ackXFTPChunk :: XFTPClient -> C.APrivateAuthKey -> RecipientId -> ExceptT XFTPClientError IO () ackXFTPChunk c rpKey rId = sendXFTPCommand c rpKey rId FACK Nothing >>= okResponse pingXFTP :: XFTPClient -> ExceptT XFTPClientError IO () diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs index 7c3521fc2..512f91ad7 100644 --- a/src/Simplex/FileTransfer/Client/Main.hs +++ b/src/Simplex/FileTransfer/Client/Main.hs @@ -62,7 +62,7 @@ import qualified Simplex.Messaging.Crypto.Lazy as LC import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String (StrEncoding (..)) import Simplex.Messaging.Parsers (parseAll) -import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), SenderId, SndPrivateSignKey, XFTPServer, XFTPServerWithAuth) +import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), SenderId, SndPrivateAuthKey, XFTPServer, XFTPServerWithAuth) import Simplex.Messaging.Server.CLI (getCliCommand') import Simplex.Messaging.Util (groupAllOn, ifM, tshow, whenM) import System.Exit (exitFailure) @@ -208,7 +208,7 @@ cliCommandP = data SentFileChunk = SentFileChunk { chunkNo :: Int, sndId :: SenderId, - sndPrivateKey :: SndPrivateSignKey, + sndPrivateKey :: SndPrivateAuthKey, chunkSize :: FileSize Word32, digest :: FileDigest, replicas :: [SentFileChunkReplica] @@ -217,7 +217,7 @@ data SentFileChunk = SentFileChunk data SentFileChunkReplica = SentFileChunkReplica { server :: XFTPServer, - recipients :: [(ChunkReplicaId, C.APrivateSignKey)] + recipients :: [(ChunkReplicaId, C.APrivateAuthKey)] } deriving (Eq, Show) @@ -226,7 +226,7 @@ data SentRecipientReplica = SentRecipientReplica server :: XFTPServer, rcvNo :: Int, replicaId :: ChunkReplicaId, - replicaKey :: C.APrivateSignKey, + replicaKey :: C.APrivateAuthKey, digest :: FileDigest, chunkSize :: FileSize Word32 } @@ -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) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g - rKeys <- atomically $ L.fromList <$> replicateM numRecipients (C.generateSignatureKeyPair C.SEd25519 g) + (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + rKeys <- atomically $ L.fromList <$> replicateM numRecipients (C.generateAuthKeyPair C.SEd25519 g) digest <- liftIO $ getChunkDigest chunkSpec let ch = FileInfo {sndKey, size = fromIntegral chunkSize, digest} c <- withRetry retryCount $ getXFTPServerClient a xftpServer @@ -387,7 +387,7 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re sentChunks -- SentFileChunk having sndId and sndPrivateKey represents the current implementation's limitation -- that sender uploads each chunk only to one server, so we can use the first replica's server for FileChunkReplica - sndReplicas :: [SentFileChunkReplica] -> ChunkReplicaId -> C.APrivateSignKey -> [FileChunkReplica] + sndReplicas :: [SentFileChunkReplica] -> ChunkReplicaId -> C.APrivateAuthKey -> [FileChunkReplica] sndReplicas [] _ _ = [] sndReplicas (SentFileChunkReplica {server} : _) replicaId replicaKey = [FileChunkReplica {server, replicaId, replicaKey}] writeFileDescriptions :: String -> [FileDescription 'FRecipient] -> FileDescription 'FSender -> IO ([FilePath], FilePath) diff --git a/src/Simplex/FileTransfer/Description.hs b/src/Simplex/FileTransfer/Description.hs index cbea3f23b..834970c69 100644 --- a/src/Simplex/FileTransfer/Description.hs +++ b/src/Simplex/FileTransfer/Description.hs @@ -118,7 +118,7 @@ data FileChunk = FileChunk data FileChunkReplica = FileChunkReplica { server :: XFTPServer, replicaId :: ChunkReplicaId, - replicaKey :: C.APrivateSignKey + replicaKey :: C.APrivateAuthKey } deriving (Eq, Show) @@ -161,7 +161,7 @@ data FileServerReplica = FileServerReplica { chunkNo :: Int, server :: XFTPServer, replicaId :: ChunkReplicaId, - replicaKey :: C.APrivateSignKey, + replicaKey :: C.APrivateAuthKey, digest :: Maybe FileDigest, chunkSize :: Maybe (FileSize Word32) } diff --git a/src/Simplex/FileTransfer/Protocol.hs b/src/Simplex/FileTransfer/Protocol.hs index 578aefd15..7e36ab92e 100644 --- a/src/Simplex/FileTransfer/Protocol.hs +++ b/src/Simplex/FileTransfer/Protocol.hs @@ -21,9 +21,9 @@ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Kind (Type) import Data.List.NonEmpty (NonEmpty (..)) -import Data.Maybe (isNothing) import Data.Type.Equality import Data.Word (Word32) +import Simplex.Messaging.Client (authTransmission) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String @@ -38,13 +38,14 @@ import Simplex.Messaging.Protocol ProtocolMsgTag (..), ProtocolType (..), RcvPublicDhKey, - RcvPublicVerifyKey, + RcvPublicAuthKey, RecipientId, SenderId, SentRawTransmission, SignedTransmission, - SndPublicVerifyKey, + SndPublicAuthKey, Transmission, + isAuthNone, encodeTransmission, messageTagP, tDecodeParseValidate, @@ -148,8 +149,8 @@ instance Protocol XFTPErrorType FileResponse where _ -> Nothing data FileCommand (p :: FileParty) where - FNEW :: FileInfo -> NonEmpty RcvPublicVerifyKey -> Maybe BasicAuth -> FileCommand FSender - FADD :: NonEmpty RcvPublicVerifyKey -> FileCommand FSender + FNEW :: FileInfo -> NonEmpty RcvPublicAuthKey -> Maybe BasicAuth -> FileCommand FSender + FADD :: NonEmpty RcvPublicAuthKey -> FileCommand FSender FPUT :: FileCommand FSender FDEL :: FileCommand FSender FGET :: RcvPublicDhKey -> FileCommand FRecipient @@ -163,7 +164,7 @@ data FileCmd = forall p. FilePartyI p => FileCmd (SFileParty p) (FileCommand p) deriving instance Show FileCmd data FileInfo = FileInfo - { sndKey :: SndPublicVerifyKey, + { sndKey :: SndPublicAuthKey, size :: Word32, digest :: ByteString } @@ -190,18 +191,18 @@ instance FilePartyI p => ProtocolEncoding XFTPErrorType (FileCommand p) where fromProtocolError = fromProtocolError @XFTPErrorType @FileResponse {-# INLINE fromProtocolError #-} - checkCredentials (sig, _, fileId, _) cmd = case cmd of + checkCredentials (auth, _, fileId, _) cmd = case cmd of -- FNEW must not have signature and chunk ID FNEW {} - | isNothing sig -> Left $ CMD NO_AUTH + | isAuthNone auth -> Left $ CMD NO_AUTH | not (B.null fileId) -> Left $ CMD HAS_AUTH | otherwise -> Right cmd PING - | isNothing sig && B.null fileId -> Right cmd + | isAuthNone auth && B.null fileId -> Right cmd | otherwise -> Left $ CMD HAS_AUTH -- other client commands must have both signature and queue ID _ - | isNothing sig || B.null fileId -> Left $ CMD NO_AUTH + | isAuthNone auth || B.null fileId -> Left $ CMD NO_AUTH | otherwise -> Right cmd instance ProtocolEncoding XFTPErrorType FileCmd where @@ -393,13 +394,10 @@ checkParty' c = case testEquality (sFileParty @p) (sFileParty @p') of Just Refl -> Just c _ -> Nothing -xftpEncodeTransmission :: ProtocolEncoding e c => SessionId -> Maybe C.APrivateSignKey -> Transmission c -> Either TransportError ByteString +xftpEncodeTransmission :: ProtocolEncoding e c => SessionId -> Maybe C.APrivateAuthKey -> Transmission c -> Either TransportError ByteString xftpEncodeTransmission sessionId pKey (corrId, fId, msg) = do let t = encodeTransmission currentXFTPVersion sessionId (corrId, fId, msg) - xftpEncodeBatch1 $ signTransmission t - where - signTransmission :: ByteString -> SentRawTransmission - signTransmission t = ((`C.sign` t) <$> pKey, t) + xftpEncodeBatch1 =<< authTransmission Nothing pKey corrId t -- this function uses batch syntax but puts only one transmission in the batch xftpEncodeBatch1 :: SentRawTransmission -> Either TransportError ByteString diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs index f4b725462..ddc1044e2 100644 --- a/src/Simplex/FileTransfer/Server.hs +++ b/src/Simplex/FileTransfer/Server.hs @@ -47,7 +47,7 @@ import Simplex.FileTransfer.Transport import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto.Lazy as LC import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Protocol (CorrId, RcvPublicDhKey, RcvPublicVerifyKey, RecipientId) +import Simplex.Messaging.Protocol (CorrId, RcvPublicDhKey, RcvPublicAuthKey, RecipientId, TransmissionAuth) import Simplex.Messaging.Server (dummyVerifyCmd, verifyCmdSignature) import Simplex.Messaging.Server.Expiration import Simplex.Messaging.Server.Stats @@ -250,10 +250,10 @@ processRequest HTTP2Request {sessionId, reqBody = body@HTTP2Body {bodyHead}, sen data VerificationResult = VRVerified XFTPRequest | VRFailed -verifyXFTPTransmission :: Maybe C.ASignature -> ByteString -> XFTPFileId -> FileCmd -> M VerificationResult -verifyXFTPTransmission sig_ signed fId cmd = +verifyXFTPTransmission :: TransmissionAuth -> ByteString -> XFTPFileId -> FileCmd -> M VerificationResult +verifyXFTPTransmission tAuth authorized fId cmd = case cmd of - FileCmd SFSender (FNEW file rcps auth) -> pure $ XFTPReqNew file rcps auth `verifyWith` sndKey file + FileCmd SFSender (FNEW file rcps auth') -> pure $ XFTPReqNew file rcps auth' `verifyWith` sndKey file FileCmd SFRecipient PING -> pure $ VRVerified XFTPReqPing FileCmd party _ -> verifyCmd party where @@ -264,8 +264,8 @@ verifyXFTPTransmission sig_ signed fId cmd = where verify = \case Right (fr, k) -> XFTPReqCmd fId fr cmd `verifyWith` k - _ -> maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed - req `verifyWith` k = if verifyCmdSignature sig_ signed k then VRVerified req else VRFailed + _ -> dummyVerifyCmd authorized tAuth `seq` VRFailed + req `verifyWith` k = if verifyCmdSignature tAuth authorized k then VRVerified req else VRFailed processXFTPRequest :: HTTP2Body -> XFTPRequest -> M (FileResponse, Maybe ServerFile) processXFTPRequest HTTP2Body {bodyPart} = \case @@ -286,7 +286,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case XFTPReqPing -> noFile FRPong where noFile resp = pure (resp, Nothing) - createFile :: FileInfo -> NonEmpty RcvPublicVerifyKey -> M FileResponse + createFile :: FileInfo -> NonEmpty RcvPublicAuthKey -> M FileResponse createFile file rks = do st <- asks store r <- runExceptT $ do @@ -310,7 +310,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case retryAdd n $ \sId -> runExceptT $ do ExceptT $ addFile st sId file ts pure sId - addRecipientRetry :: FileStore -> Int -> XFTPFileId -> RcvPublicVerifyKey -> M (Either XFTPErrorType FileRecipient) + addRecipientRetry :: FileStore -> Int -> XFTPFileId -> RcvPublicAuthKey -> M (Either XFTPErrorType FileRecipient) addRecipientRetry st n sId rpk = retryAdd n $ \rId -> runExceptT $ do let rcp = FileRecipient rId rpk @@ -323,7 +323,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case atomically (add fId) >>= \case Left DUPLICATE_ -> retryAdd (n - 1) add r -> pure r - addRecipients :: XFTPFileId -> NonEmpty RcvPublicVerifyKey -> M FileResponse + addRecipients :: XFTPFileId -> NonEmpty RcvPublicAuthKey -> M FileResponse addRecipients sId rks = do st <- asks store r <- runExceptT $ do diff --git a/src/Simplex/FileTransfer/Server/Env.hs b/src/Simplex/FileTransfer/Server/Env.hs index 89763608a..4d5d67b07 100644 --- a/src/Simplex/FileTransfer/Server/Env.hs +++ b/src/Simplex/FileTransfer/Server/Env.hs @@ -24,7 +24,7 @@ import Simplex.FileTransfer.Server.Stats import Simplex.FileTransfer.Server.Store import Simplex.FileTransfer.Server.StoreLog import qualified Simplex.Messaging.Crypto as C -import Simplex.Messaging.Protocol (BasicAuth, RcvPublicVerifyKey) +import Simplex.Messaging.Protocol (BasicAuth, RcvPublicAuthKey) import Simplex.Messaging.Server.Expiration import Simplex.Messaging.Transport.Server (TransportServerConfig, loadFingerprint, loadTLSServerParams) import Simplex.Messaging.Util (tshow) @@ -103,6 +103,6 @@ newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, caCertifi pure XFTPEnv {config, store, storeLog, random, tlsServerParams, serverIdentity = C.KeyHash fp, serverStats} data XFTPRequest - = XFTPReqNew FileInfo (NonEmpty RcvPublicVerifyKey) (Maybe BasicAuth) + = XFTPReqNew FileInfo (NonEmpty RcvPublicAuthKey) (Maybe BasicAuth) | XFTPReqCmd XFTPFileId FileRec FileCmd | XFTPReqPing diff --git a/src/Simplex/FileTransfer/Server/Store.hs b/src/Simplex/FileTransfer/Server/Store.hs index 337214e62..031c46f5b 100644 --- a/src/Simplex/FileTransfer/Server/Store.hs +++ b/src/Simplex/FileTransfer/Server/Store.hs @@ -31,14 +31,14 @@ import Data.Time.Clock.System (SystemTime (..)) import Simplex.FileTransfer.Protocol (FileInfo (..), SFileParty (..), XFTPErrorType (..), XFTPFileId) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Protocol (RcvPublicVerifyKey, RecipientId, SenderId) +import Simplex.Messaging.Protocol (RcvPublicAuthKey, RecipientId, SenderId) import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Util (ifM, ($>>=)) data FileStore = FileStore { files :: TMap SenderId FileRec, - recipients :: TMap RecipientId (SenderId, RcvPublicVerifyKey), + recipients :: TMap RecipientId (SenderId, RcvPublicAuthKey), usedStorage :: TVar Int64 } @@ -51,7 +51,7 @@ data FileRec = FileRec } deriving (Eq) -data FileRecipient = FileRecipient RecipientId RcvPublicVerifyKey +data FileRecipient = FileRecipient RecipientId RcvPublicAuthKey instance StrEncoding FileRecipient where strEncode (FileRecipient rId rKey) = strEncode rId <> ":" <> strEncode rKey @@ -113,7 +113,7 @@ deleteRecipient FileStore {recipients} rId FileRec {recipientIds} = do TM.delete rId recipients modifyTVar' recipientIds $ S.delete rId -getFile :: FileStore -> SFileParty p -> XFTPFileId -> STM (Either XFTPErrorType (FileRec, C.APublicVerifyKey)) +getFile :: FileStore -> SFileParty p -> XFTPFileId -> STM (Either XFTPErrorType (FileRec, C.APublicAuthKey)) getFile st party fId = case party of SFSender -> withFile st fId $ pure . Right . (\f -> (f, sndKey $ fileInfo f)) SFRecipient -> diff --git a/src/Simplex/FileTransfer/Server/StoreLog.hs b/src/Simplex/FileTransfer/Server/StoreLog.hs index dcfbb757e..f2ee311b7 100644 --- a/src/Simplex/FileTransfer/Server/StoreLog.hs +++ b/src/Simplex/FileTransfer/Server/StoreLog.hs @@ -31,7 +31,7 @@ import Data.Time.Clock.System (SystemTime) import Simplex.FileTransfer.Protocol (FileInfo (..)) import Simplex.FileTransfer.Server.Store import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Protocol (RcvPublicVerifyKey, RecipientId, SenderId) +import Simplex.Messaging.Protocol (RcvPublicAuthKey, RecipientId, SenderId) import Simplex.Messaging.Server.StoreLog import Simplex.Messaging.Util (bshow, whenM) import System.Directory (doesFileExist, renameFile) @@ -109,7 +109,7 @@ writeFileStore s FileStore {files, recipients} = do allRcps <- readTVarIO recipients readTVarIO files >>= mapM_ (logFile allRcps) where - logFile :: Map RecipientId (SenderId, RcvPublicVerifyKey) -> FileRec -> IO () + logFile :: Map RecipientId (SenderId, RcvPublicAuthKey) -> FileRec -> IO () logFile allRcps FileRec {senderId, fileInfo, filePath, recipientIds, createdAt} = do logAddFile s senderId fileInfo createdAt (rcpErrs, rcps) <- M.mapEither getRcp . M.fromSet id <$> readTVarIO recipientIds diff --git a/src/Simplex/FileTransfer/Types.hs b/src/Simplex/FileTransfer/Types.hs index e51cb14e3..a4d05089a 100644 --- a/src/Simplex/FileTransfer/Types.hs +++ b/src/Simplex/FileTransfer/Types.hs @@ -101,7 +101,7 @@ data RcvFileChunkReplica = RcvFileChunkReplica { rcvChunkReplicaId :: Int64, server :: XFTPServer, replicaId :: ChunkReplicaId, - replicaKey :: C.APrivateSignKey, + replicaKey :: C.APrivateAuthKey, received :: Bool, delay :: Maybe Int64, retries :: Int @@ -181,8 +181,8 @@ sndChunkSize SndFileChunk {chunkSpec = XFTPChunkSpec {chunkSize}} = chunkSize data NewSndChunkReplica = NewSndChunkReplica { server :: XFTPServer, replicaId :: ChunkReplicaId, - replicaKey :: C.APrivateSignKey, - rcvIdsKeys :: [(ChunkReplicaId, C.APrivateSignKey)] + replicaKey :: C.APrivateAuthKey, + rcvIdsKeys :: [(ChunkReplicaId, C.APrivateAuthKey)] } deriving (Eq, Show) @@ -190,8 +190,8 @@ data SndFileChunkReplica = SndFileChunkReplica { sndChunkReplicaId :: Int64, server :: XFTPServer, replicaId :: ChunkReplicaId, - replicaKey :: C.APrivateSignKey, - rcvIdsKeys :: [(ChunkReplicaId, C.APrivateSignKey)], + replicaKey :: C.APrivateAuthKey, + rcvIdsKeys :: [(ChunkReplicaId, C.APrivateAuthKey)], replicaStatus :: SndFileReplicaStatus, delay :: Maybe Int64, retries :: Int @@ -221,7 +221,7 @@ data DeletedSndChunkReplica = DeletedSndChunkReplica userId :: Int64, server :: XFTPServer, replicaId :: ChunkReplicaId, - replicaKey :: C.APrivateSignKey, + replicaKey :: C.APrivateAuthKey, chunkDigest :: FileDigest, delay :: Maybe Int64, retries :: Int diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 36dcee49d..b7eac5a97 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -161,7 +161,7 @@ import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfRegCode (NtfReg import Simplex.Messaging.Notifications.Server.Push.APNS (PNMessageData (..)) import Simplex.Messaging.Notifications.Types import Simplex.Messaging.Parsers (parse) -import Simplex.Messaging.Protocol (BrokerMsg, EntityId, ErrorType (AUTH), MsgBody, MsgFlags (..), NtfServer, ProtoServerWithAuth, ProtocolTypeI (..), SMPMsgMeta, SProtocolType (..), SndPublicVerifyKey, SubscriptionMode (..), UserProtocol, XFTPServerWithAuth) +import Simplex.Messaging.Protocol (BrokerMsg, EntityId, ErrorType (AUTH), MsgBody, MsgFlags (..), NtfServer, ProtoServerWithAuth, ProtocolTypeI (..), SMPMsgMeta, SProtocolType (..), SndPublicAuthKey, SubscriptionMode (..), UserProtocol, XFTPServerWithAuth) import qualified Simplex.Messaging.Protocol as SMP import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Util @@ -1031,7 +1031,7 @@ runCommandProcessing c@AgentClient {subQ} server_ Worker {doWork} = do ack srv rId srvMsgId = do rq <- withStore c $ \db -> getRcvQueue db connId srv rId ackQueueMessage c rq srvMsgId - secure :: RcvQueue -> SMP.SndPublicVerifyKey -> m () + secure :: RcvQueue -> SMP.SndPublicAuthKey -> m () secure rq senderKey = do secureQueue c rq senderKey withStore' c $ \db -> setRcvQueueStatus db rq Secured @@ -1635,10 +1635,10 @@ registerNtfToken' c suppliedDeviceToken suppliedNtfMode = createToken = getNtfServer c >>= \case Just ntfServer -> - asks (cmdSignAlg . config) >>= \case - C.SignAlg a -> do + asks (cmdAuthAlg . config) >>= \case + C.AuthAlg a -> do g <- asks random - tknKeys <- atomically $ C.generateSignatureKeyPair a g + tknKeys <- atomically $ C.generateAuthKeyPair a g dhKeys <- atomically $ C.generateKeyPair g let tkn = newNtfToken suppliedDeviceToken ntfServer tknKeys dhKeys suppliedNtfMode withStore' c (`createNtfToken` tkn) @@ -2100,7 +2100,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s parseMessage :: Encoding a => ByteString -> m a parseMessage = liftEither . parse smpP (AGENT A_MESSAGE) - smpConfirmation :: SMP.MsgId -> Connection c -> C.APublicVerifyKey -> C.PublicKeyX25519 -> Maybe (CR.E2ERatchetParams 'C.X448) -> ByteString -> Version -> Version -> m () + smpConfirmation :: SMP.MsgId -> Connection c -> C.APublicAuthKey -> C.PublicKeyX25519 -> Maybe (CR.E2ERatchetParams 'C.X448) -> ByteString -> Version -> Version -> m () smpConfirmation srvMsgId conn' senderKey e2ePubKey e2eEncryption encConnInfo smpClientVersion agentVersion = do logServer "<--" c srv rId $ "MSG :" <> logSecret srvMsgId AgentConfig {smpClientVRange, smpAgentVRange, e2eEncryptVRange} <- asks config @@ -2246,7 +2246,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s _ -> throwError $ AGENT A_VERSION -- processed by queue recipient - qKeyMsg :: SMP.MsgId -> NonEmpty (SMPQueueInfo, SndPublicVerifyKey) -> Connection 'CDuplex -> m () + qKeyMsg :: SMP.MsgId -> NonEmpty (SMPQueueInfo, SndPublicAuthKey) -> Connection 'CDuplex -> m () qKeyMsg srvMsgId ((qInfo, senderKey) :| _) conn'@(DuplexConnection cData' rqs _) = do when (ratchetSyncSendProhibited cData') $ throwError $ AGENT (A_QUEUE "ratchet is not synchronized") clientVRange <- asks $ smpClientVRange . config @@ -2500,9 +2500,9 @@ agentRatchetDecrypt' g db connId rc encAgentMsg = do newSndQueue :: (MonadUnliftIO m, MonadReader Env m) => UserId -> ConnId -> Compatible SMPQueueInfo -> m NewSndQueue newSndQueue userId connId (Compatible (SMPQueueInfo smpClientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey = rcvE2ePubDhKey})) = do - C.SignAlg a <- asks $ cmdSignAlg . config + C.AuthAlg a <- asks $ cmdAuthAlg . config g <- asks random - (sndPublicKey, sndPrivateKey) <- atomically $ C.generateSignatureKeyPair a g + (sndPublicKey, sndPrivateKey) <- atomically $ C.generateAuthKeyPair a g (e2ePubKey, e2ePrivKey) <- atomically $ C.generateKeyPair g pure SndQueue diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 9c6571f14..1dfdd524b 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -200,9 +200,10 @@ import Simplex.Messaging.Protocol QueueIdsKeys (..), RcvMessage (..), RcvNtfPublicDhKey, + NtfPublicAuthKey, SMPMsgMeta (..), SProtocolType (..), - SndPublicVerifyKey, + SndPublicAuthKey, SubscriptionMode (..), UserProtocol, XFTPServer, @@ -507,8 +508,9 @@ getSMPServerClient c@AgentClient {active, smpClients, msgQ} tSess@(userId, srv, connectClient :: SMPClientVar -> m SMPClient connectClient v = do cfg <- getClientConfig c smpCfg + g <- asks random u <- askUnliftIO - liftEitherError (protocolClientError SMP $ B.unpack $ strEncode srv) (getProtocolClient tSess cfg (Just msgQ) $ clientDisconnected u v) + liftEitherError (protocolClientError SMP $ B.unpack $ strEncode srv) (getProtocolClient g tSess cfg (Just msgQ) $ clientDisconnected u v) clientDisconnected :: UnliftIO m -> SMPClientVar -> SMPClient -> IO () clientDisconnected u v client = do @@ -606,7 +608,8 @@ getNtfServerClient c@AgentClient {active, ntfClients} tSess@(userId, srv, _) = d connectClient :: NtfClientVar -> m NtfClient connectClient v = do cfg <- getClientConfig c ntfCfg - liftEitherError (protocolClientError NTF $ B.unpack $ strEncode srv) (getProtocolClient tSess cfg Nothing $ clientDisconnected v) + g <- asks random + liftEitherError (protocolClientError NTF $ B.unpack $ strEncode srv) (getProtocolClient g tSess cfg Nothing $ clientDisconnected v) clientDisconnected :: NtfClientVar -> NtfClient -> IO () clientDisconnected v client = do @@ -860,17 +863,17 @@ data ProtocolTestFailure = ProtocolTestFailure runSMPServerTest :: AgentMonad m => AgentClient -> UserId -> SMPServerWithAuth -> m (Maybe ProtocolTestFailure) runSMPServerTest c userId (ProtoServerWithAuth srv auth) = do cfg <- getClientConfig c smpCfg - C.SignAlg a <- asks $ cmdSignAlg . config + C.AuthAlg a <- asks $ cmdAuthAlg . config g <- asks random liftIO $ do let tSess = (userId, srv, Nothing) - getProtocolClient tSess cfg Nothing (\_ -> pure ()) >>= \case + getProtocolClient g tSess cfg Nothing (\_ -> pure ()) >>= \case Right smp -> do - (rKey, rpKey) <- atomically $ C.generateSignatureKeyPair a g - (sKey, _) <- atomically $ C.generateSignatureKeyPair a g + rKeys@(_, rpKey) <- atomically $ C.generateAuthKeyPair a g + (sKey, _) <- atomically $ C.generateAuthKeyPair a g (dhKey, _) <- atomically $ C.generateKeyPair g r <- runExceptT $ do - SMP.QIK {rcvId} <- liftError (testErr TSCreateQueue) $ createSMPQueue smp rpKey rKey dhKey auth SMSubscribe + SMP.QIK {rcvId} <- liftError (testErr TSCreateQueue) $ createSMPQueue smp rKeys dhKey auth SMSubscribe liftError (testErr TSSecureQueue) $ secureSMPQueue smp rpKey rcvId sKey liftError (testErr TSDeleteQueue) $ deleteSMPQueue smp rpKey rcvId ok <- tcpTimeout (networkConfig cfg) `timeout` closeProtocolClient smp @@ -894,8 +897,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) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g - (rcvKey, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g createTestChunk filePath digest <- liftIO $ C.sha256Hash <$> B.readFile filePath let file = FileInfo {sndKey, size = chSize, digest} @@ -948,15 +951,15 @@ getSessionMode = fmap sessionMode . readTVarIO . useNetworkConfig newRcvQueue :: AgentMonad m => AgentClient -> UserId -> ConnId -> SMPServerWithAuth -> VersionRange -> SubscriptionMode -> m (NewRcvQueue, SMPQueueUri) newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange subMode = do - C.SignAlg a <- asks (cmdSignAlg . config) + C.AuthAlg a <- asks (cmdAuthAlg . config) g <- asks random - (recipientKey, rcvPrivateKey) <- atomically $ C.generateSignatureKeyPair a g + rKeys@(_, rcvPrivateKey) <- atomically $ C.generateAuthKeyPair 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} <- - withClient c tSess "NEW" $ \smp -> createSMPQueue smp rcvPrivateKey recipientKey dhKey auth subMode + withClient c tSess "NEW" $ \smp -> createSMPQueue smp rKeys dhKey auth subMode logServer "<--" c srv "" $ B.unwords ["IDS", logSecret rcvId, logSecret sndId] let rq = RcvQueue @@ -1054,7 +1057,7 @@ sendTSessionBatches statCmd statBatchSize toRQ action c qs = let n = (length qs - 1) `div` statBatchSize + 1 in incClientStatN c userId smp n statCmd "OK" -sendBatch :: (SMPClient -> NonEmpty (SMP.RcvPrivateSignKey, SMP.RecipientId) -> IO (NonEmpty (Either SMPClientError ()))) -> SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses SMPClientError ()) +sendBatch :: (SMPClient -> NonEmpty (SMP.RcvPrivateAuthKey, SMP.RecipientId) -> IO (NonEmpty (Either SMPClientError ()))) -> SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses SMPClientError ()) sendBatch smpCmdFunc smp qs = L.zip qs <$> smpCmdFunc smp (L.map queueCreds qs) where queueCreds RcvQueue {rcvPrivateKey, rcvId} = (rcvPrivateKey, rcvId) @@ -1132,23 +1135,23 @@ decryptSMPMessage v rq SMP.RcvMessage {msgId, msgTs, msgFlags, msgBody = SMP.Enc where decrypt = agentCbDecrypt (rcvDhSecret rq) (C.cbNonce msgId) -secureQueue :: AgentMonad m => AgentClient -> RcvQueue -> SndPublicVerifyKey -> m () +secureQueue :: AgentMonad m => AgentClient -> RcvQueue -> SndPublicAuthKey -> m () secureQueue c rq@RcvQueue {rcvId, rcvPrivateKey} senderKey = withSMPClient c rq "KEY " $ \smp -> secureSMPQueue smp rcvPrivateKey rcvId senderKey -enableQueueNotifications :: AgentMonad m => AgentClient -> RcvQueue -> SMP.NtfPublicVerifyKey -> SMP.RcvNtfPublicDhKey -> m (SMP.NotifierId, SMP.RcvNtfPublicDhKey) +enableQueueNotifications :: AgentMonad m => AgentClient -> RcvQueue -> SMP.NtfPublicAuthKey -> SMP.RcvNtfPublicDhKey -> m (SMP.NotifierId, SMP.RcvNtfPublicDhKey) enableQueueNotifications c rq@RcvQueue {rcvId, rcvPrivateKey} notifierKey rcvNtfPublicDhKey = withSMPClient c rq "NKEY " $ \smp -> enableSMPQueueNotifications smp rcvPrivateKey rcvId notifierKey rcvNtfPublicDhKey -enableQueuesNtfs :: forall m. AgentMonad' m => AgentClient -> [(RcvQueue, SMP.NtfPublicVerifyKey, SMP.RcvNtfPublicDhKey)] -> m [(RcvQueue, Either AgentErrorType (SMP.NotifierId, SMP.RcvNtfPublicDhKey))] +enableQueuesNtfs :: forall m. AgentMonad' m => AgentClient -> [(RcvQueue, SMP.NtfPublicAuthKey, SMP.RcvNtfPublicDhKey)] -> m [(RcvQueue, Either AgentErrorType (SMP.NotifierId, SMP.RcvNtfPublicDhKey))] enableQueuesNtfs = sendTSessionBatches "NKEY" 90 fst3 enableQueues_ where fst3 (x, _, _) = x - enableQueues_ :: SMPClient -> NonEmpty (RcvQueue, SMP.NtfPublicVerifyKey, SMP.RcvNtfPublicDhKey) -> IO (NonEmpty (RcvQueue, Either (ProtocolClientError ErrorType) (SMP.NotifierId, RcvNtfPublicDhKey))) + enableQueues_ :: SMPClient -> NonEmpty (RcvQueue, SMP.NtfPublicAuthKey, SMP.RcvNtfPublicDhKey) -> IO (NonEmpty (RcvQueue, Either (ProtocolClientError ErrorType) (SMP.NotifierId, RcvNtfPublicDhKey))) enableQueues_ smp qs' = L.zipWith ((,) . fst3) qs' <$> enableSMPQueuesNtfs smp (L.map queueCreds qs') - queueCreds :: (RcvQueue, SMP.NtfPublicVerifyKey, SMP.RcvNtfPublicDhKey) -> (SMP.RcvPrivateSignKey, SMP.RecipientId, SMP.NtfPublicVerifyKey, SMP.RcvNtfPublicDhKey) + queueCreds :: (RcvQueue, SMP.NtfPublicAuthKey, SMP.RcvNtfPublicDhKey) -> (SMP.RcvPrivateAuthKey, SMP.RecipientId, SMP.NtfPublicAuthKey, SMP.RcvNtfPublicDhKey) queueCreds (RcvQueue {rcvPrivateKey, rcvId}, notifierKey, rcvNtfPublicDhKey) = (rcvPrivateKey, rcvId, notifierKey, rcvNtfPublicDhKey) disableQueueNotifications :: AgentMonad m => AgentClient -> RcvQueue -> m () @@ -1193,7 +1196,7 @@ sendAgentMessage c sq@SndQueue {sndId, sndPrivateKey} msgFlags agentMsg = msg <- agentCbEncrypt sq Nothing $ smpEncode clientMsg liftClient SMP (clientServer smp) $ sendSMPMessage smp (Just sndPrivateKey) sndId msgFlags msg -agentNtfRegisterToken :: AgentMonad m => AgentClient -> NtfToken -> C.APublicVerifyKey -> C.PublicKeyX25519 -> m (NtfTokenId, C.PublicKeyX25519) +agentNtfRegisterToken :: AgentMonad m => AgentClient -> NtfToken -> NtfPublicAuthKey -> C.PublicKeyX25519 -> m (NtfTokenId, C.PublicKeyX25519) agentNtfRegisterToken c NtfToken {deviceToken, ntfServer, ntfPrivKey} ntfPubKey pubDhKey = withClient c (0, ntfServer, Nothing) "TNEW" $ \ntf -> ntfRegisterToken ntf ntfPrivKey (NewNtfTkn deviceToken ntfPubKey pubDhKey) @@ -1217,7 +1220,7 @@ agentNtfEnableCron :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> W agentNtfEnableCron c tknId NtfToken {ntfServer, ntfPrivKey} interval = withNtfClient c ntfServer tknId "TCRN" $ \ntf -> ntfEnableCron ntf ntfPrivKey tknId interval -agentNtfCreateSubscription :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> SMPQueueNtf -> SMP.NtfPrivateSignKey -> m NtfSubscriptionId +agentNtfCreateSubscription :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> SMPQueueNtf -> SMP.NtfPrivateAuthKey -> m NtfSubscriptionId agentNtfCreateSubscription c tknId NtfToken {ntfServer, ntfPrivKey} smpQueue nKey = withNtfClient c ntfServer tknId "SNEW" $ \ntf -> ntfCreateSubscription ntf ntfPrivKey (NewNtfSub tknId smpQueue nKey) @@ -1237,7 +1240,7 @@ agentXFTPDownloadChunk c userId (FileDigest chunkDigest) RcvFileChunkReplica {se 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) <- atomically . C.generateSignatureKeyPair C.SEd25519 =<< asks random + (sndKey, replicaKey) <- atomically . C.generateAuthKeyPair C.SEd25519 =<< asks random let fileInfo = FileInfo {sndKey, size = fromIntegral chunkSize, digest = chunkDigest} logServer "-->" c srv "" "FNEW" tSess <- mkTransportSession c userId srv chunkDigest @@ -1249,7 +1252,7 @@ agentXFTPUploadChunk :: AgentMonad m => AgentClient -> UserId -> FileDigest -> S agentXFTPUploadChunk c userId (FileDigest chunkDigest) SndFileChunkReplica {server, replicaId = ChunkReplicaId fId, replicaKey} chunkSpec = withXFTPClient c (userId, server, chunkDigest) "FPUT" $ \xftp -> X.uploadXFTPChunk xftp replicaKey fId chunkSpec -agentXFTPAddRecipients :: AgentMonad m => AgentClient -> UserId -> FileDigest -> SndFileChunkReplica -> Int -> m (NonEmpty (ChunkReplicaId, C.APrivateSignKey)) +agentXFTPAddRecipients :: AgentMonad m => AgentClient -> UserId -> FileDigest -> SndFileChunkReplica -> Int -> m (NonEmpty (ChunkReplicaId, C.APrivateAuthKey)) agentXFTPAddRecipients c userId (FileDigest chunkDigest) SndFileChunkReplica {server, replicaId = ChunkReplicaId fId, replicaKey} n = do rKeys <- xftpRcvKeys n rIds <- withXFTPClient c (userId, server, chunkDigest) "FADD" $ \xftp -> X.addXFTPRecipients xftp replicaKey fId (L.map fst rKeys) @@ -1259,14 +1262,14 @@ agentXFTPDeleteChunk :: AgentMonad m => AgentClient -> UserId -> DeletedSndChunk agentXFTPDeleteChunk c userId DeletedSndChunkReplica {server, replicaId = ChunkReplicaId fId, replicaKey, chunkDigest = FileDigest chunkDigest} = withXFTPClient c (userId, server, chunkDigest) "FDEL" $ \xftp -> X.deleteXFTPChunk xftp replicaKey fId -xftpRcvKeys :: AgentMonad m => Int -> m (NonEmpty C.ASignatureKeyPair) +xftpRcvKeys :: AgentMonad m => Int -> m (NonEmpty C.AAuthKeyPair) xftpRcvKeys n = do - rKeys <- atomically . replicateM n . C.generateSignatureKeyPair C.SEd25519 =<< asks random + rKeys <- atomically . replicateM n . C.generateAuthKeyPair C.SEd25519 =<< asks random case L.nonEmpty rKeys of Just rKeys' -> pure rKeys' _ -> throwError $ INTERNAL "non-positive number of recipients" -xftpRcvIdsKeys :: NonEmpty ByteString -> NonEmpty C.ASignatureKeyPair -> NonEmpty (ChunkReplicaId, C.APrivateSignKey) +xftpRcvIdsKeys :: NonEmpty ByteString -> NonEmpty C.AAuthKeyPair -> NonEmpty (ChunkReplicaId, C.APrivateAuthKey) xftpRcvIdsKeys rIds rKeys = L.map ChunkReplicaId rIds `L.zip` L.map snd rKeys agentCbEncrypt :: AgentMonad m => SndQueue -> Maybe C.PublicKeyX25519 -> ByteString -> m ByteString diff --git a/src/Simplex/Messaging/Agent/Env/SQLite.hs b/src/Simplex/Messaging/Agent/Env/SQLite.hs index 02d172d0e..1f62fa35c 100644 --- a/src/Simplex/Messaging/Agent/Env/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Env/SQLite.hs @@ -82,7 +82,7 @@ data InitialAgentServers = InitialAgentServers data AgentConfig = AgentConfig { tcpPort :: ServiceName, - cmdSignAlg :: C.SignAlg, + cmdAuthAlg :: C.AuthAlg, connIdBytes :: Int, tbqSize :: Natural, smpCfg :: ProtocolClientConfig, @@ -147,7 +147,7 @@ defaultAgentConfig :: AgentConfig defaultAgentConfig = AgentConfig { tcpPort = "5224", - cmdSignAlg = C.SignAlg C.SEd448, + cmdAuthAlg = C.AuthAlg C.SEd448, connIdBytes = 12, tbqSize = 64, smpCfg = defaultClientConfig {defaultTransport = (show defaultSMPPort, transport @TLS)}, diff --git a/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs b/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs index 5e51b2217..002a82fcc 100644 --- a/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs +++ b/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs @@ -253,9 +253,9 @@ runNtfSMPWorker c srv Worker {doWork} = do getNtfToken >>= \case Just NtfToken {ntfTknStatus = NTActive, ntfMode = NMInstant} -> do rq <- withStore c (`getPrimaryRcvQueue` connId) - C.SignAlg a <- asks (cmdSignAlg . config) + C.AuthAlg a <- asks (cmdAuthAlg . config) g <- asks random - (ntfPublicKey, ntfPrivateKey) <- atomically $ C.generateSignatureKeyPair a g + (ntfPublicKey, ntfPrivateKey) <- atomically $ C.generateAuthKeyPair a g (rcvNtfPubDhKey, rcvNtfPrivDhKey) <- atomically $ C.generateKeyPair g (notifierId, rcvNtfSrvPubDhKey) <- enableQueueNotifications c rq ntfPublicKey rcvNtfPubDhKey let rcvNtfDhSecret = C.dh' rcvNtfSrvPubDhKey rcvNtfPrivDhKey diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index 54777bb64..008145114 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -196,7 +196,7 @@ import Simplex.Messaging.Protocol SMPMsgMeta, SMPServer, SMPServerWithAuth, - SndPublicVerifyKey, + SndPublicAuthKey, SrvLoc (..), SubscriptionMode, legacyEncodeServer, @@ -776,7 +776,7 @@ instance StrEncoding MsgMeta where data SMPConfirmation = SMPConfirmation { -- | sender's public key to use for authentication of sender's commands at the recepient's server - senderKey :: SndPublicVerifyKey, + senderKey :: SndPublicAuthKey, -- | sender's DH public key for simple per-queue e2e encryption e2ePubKey :: C.PublicKeyX25519, -- | sender's information to be associated with the connection, e.g. sender's profile information @@ -1010,7 +1010,7 @@ data AMessage | -- add queue to connection (sent by recipient), with optional address of the replaced queue QADD (NonEmpty (SMPQueueUri, Maybe SndQAddr)) | -- key to secure the added queues and agree e2e encryption key (sent by sender) - QKEY (NonEmpty (SMPQueueInfo, SndPublicVerifyKey)) + QKEY (NonEmpty (SMPQueueInfo, SndPublicAuthKey)) | -- inform that the queues are ready to use (sent by recipient) QUSE (NonEmpty (SndQAddr, Bool)) | -- sent by the sender to test new queues and to complete switching diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs index 028b7d8ea..db1d37c06 100644 --- a/src/Simplex/Messaging/Agent/Store.hs +++ b/src/Simplex/Messaging/Agent/Store.hs @@ -37,12 +37,13 @@ import Simplex.Messaging.Protocol MsgFlags, MsgId, NotifierId, - NtfPrivateSignKey, - NtfPublicVerifyKey, + NtfPrivateAuthKey, + NtfPublicAuthKey, RcvDhSecret, RcvNtfDhSecret, - RcvPrivateSignKey, - SndPrivateSignKey, + RcvPrivateAuthKey, + SndPrivateAuthKey, + SndPublicAuthKey, ) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Util ((<$?>)) @@ -75,8 +76,8 @@ data StoredRcvQueue (q :: QueueStored) = RcvQueue server :: SMPServer, -- | recipient queue ID rcvId :: SMP.RecipientId, - -- | key used by the recipient to sign transmissions - rcvPrivateKey :: RcvPrivateSignKey, + -- | key used by the recipient to authorize transmissions + rcvPrivateKey :: RcvPrivateAuthKey, -- | shared DH secret used to encrypt/decrypt message bodies from server to recipient rcvDhSecret :: RcvDhSecret, -- | private DH key related to public sent to sender out-of-band (to agree simple per-queue e2e) @@ -119,9 +120,9 @@ canAbortRcvSwitch = maybe False canAbort . rcvSwchStatus RSReceivedMessage -> False data ClientNtfCreds = ClientNtfCreds - { -- | key pair to be used by the notification server to sign transmissions - ntfPublicKey :: NtfPublicVerifyKey, - ntfPrivateKey :: NtfPrivateSignKey, + { -- | key pair to be used by the notification server to authorize transmissions + ntfPublicKey :: NtfPublicAuthKey, + ntfPrivateKey :: NtfPrivateAuthKey, -- | queue ID to be used by the notification server for NSUB command notifierId :: NotifierId, -- | shared DH secret used to encrypt/decrypt notification metadata (NMsgMeta) from server to recipient @@ -140,9 +141,10 @@ data StoredSndQueue (q :: QueueStored) = SndQueue server :: SMPServer, -- | sender queue ID sndId :: SMP.SenderId, - -- | key pair used by the sender to sign transmissions - sndPublicKey :: Maybe C.APublicVerifyKey, - sndPrivateKey :: SndPrivateSignKey, + -- | key pair used by the sender to authorize transmissions + -- TODO combine keys to key pair so that types match + sndPublicKey :: Maybe SndPublicAuthKey, + sndPrivateKey :: SndPrivateAuthKey, -- | DH public key used to negotiate per-queue e2e encryption e2ePubKey :: Maybe C.PublicKeyX25519, -- | shared DH secret agreed for simple per-queue e2e encryption @@ -388,11 +390,11 @@ instance StrEncoding AgentCommandTag where data InternalCommand = ICAck SMP.RecipientId MsgId | ICAckDel SMP.RecipientId MsgId InternalId - | ICAllowSecure SMP.RecipientId SMP.SndPublicVerifyKey - | ICDuplexSecure SMP.RecipientId SMP.SndPublicVerifyKey + | ICAllowSecure SMP.RecipientId SMP.SndPublicAuthKey + | ICDuplexSecure SMP.RecipientId SMP.SndPublicAuthKey | ICDeleteConn | ICDeleteRcvQueue SMP.RecipientId - | ICQSecure SMP.RecipientId SMP.SndPublicVerifyKey + | ICQSecure SMP.RecipientId SMP.SndPublicAuthKey | ICQDelete SMP.RecipientId data InternalCommandTag diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index 06f41be9e..dfe9ad7d8 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -780,7 +780,7 @@ setRcvQueueNtfCreds db connId clientNtfCreds = Just ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret} -> (Just ntfPublicKey, Just ntfPrivateKey, Just notifierId, Just rcvNtfDhSecret) Nothing -> (Nothing, Nothing, Nothing, Nothing) -type SMPConfirmationRow = (SndPublicVerifyKey, C.PublicKeyX25519, ConnInfo, Maybe [SMPQueueInfo], Maybe Version) +type SMPConfirmationRow = (SndPublicAuthKey, C.PublicKeyX25519, ConnInfo, Maybe [SMPQueueInfo], Maybe Version) smpConfirmation :: SMPConfirmationRow -> SMPConfirmation smpConfirmation (senderKey, e2ePubKey, connInfo, smpReplyQueues_, smpClientVersion_) = @@ -1984,9 +1984,9 @@ rcvQueueQuery = |] toRcvQueue :: - (UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SMP.RecipientId, SMP.RcvPrivateSignKey, SMP.RcvDhSecret, C.PrivateKeyX25519, Maybe C.DhSecretX25519, SMP.SenderId, QueueStatus) + (UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SMP.RecipientId, SMP.RcvPrivateAuthKey, SMP.RcvDhSecret, C.PrivateKeyX25519, Maybe C.DhSecretX25519, SMP.SenderId, QueueStatus) :. (DBQueueId 'QSStored, Bool, Maybe Int64, Maybe RcvSwitchStatus, Maybe Version, Int) - :. (Maybe SMP.NtfPublicVerifyKey, Maybe SMP.NtfPrivateSignKey, Maybe SMP.NotifierId, Maybe RcvNtfDhSecret) -> + :. (Maybe SMP.NtfPublicAuthKey, Maybe SMP.NtfPrivateAuthKey, Maybe SMP.NotifierId, Maybe RcvNtfDhSecret) -> RcvQueue toRcvQueue ((userId, keyHash, connId, host, port, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status) :. (dbQueueId, primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion_, deleteErrors) :. (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_)) = let server = SMPServer host port keyHash @@ -2025,7 +2025,7 @@ sndQueueQuery = toSndQueue :: (UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SenderId) - :. (Maybe C.APublicVerifyKey, SndPrivateSignKey, Maybe C.PublicKeyX25519, C.DhSecretX25519, QueueStatus) + :. (Maybe SndPublicAuthKey, SndPrivateAuthKey, Maybe C.PublicKeyX25519, C.DhSecretX25519, QueueStatus) :. (DBQueueId 'QSStored, Bool, Maybe Int64, Maybe SndSwitchStatus, Version) -> SndQueue toSndQueue @@ -2363,7 +2363,7 @@ getRcvFile db rcvFileId = runExceptT $ do |] (Only chunkId) where - toReplica :: (Int64, ChunkReplicaId, C.APrivateSignKey, Bool, Maybe Int64, Int, NonEmpty TransportHost, ServiceName, C.KeyHash) -> RcvFileChunkReplica + toReplica :: (Int64, ChunkReplicaId, C.APrivateAuthKey, Bool, Maybe Int64, Int, NonEmpty TransportHost, ServiceName, C.KeyHash) -> RcvFileChunkReplica toReplica (rcvChunkReplicaId, replicaId, replicaKey, received, delay, retries, host, port, keyHash) = let server = XFTPServer host port keyHash in RcvFileChunkReplica {rcvChunkReplicaId, server, replicaId, replicaKey, received, delay, retries} @@ -2449,7 +2449,7 @@ getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} ttl = d |] (Only rcvFileChunkReplicaId) where - toChunk :: ((DBRcvFileId, RcvFileId, UserId, Int64, Int, FileSize Word32, FileDigest, FilePath, Maybe FilePath) :. (Int64, ChunkReplicaId, C.APrivateSignKey, Bool, Maybe Int64, Int)) -> RcvFileChunk + toChunk :: ((DBRcvFileId, RcvFileId, UserId, Int64, Int, FileSize Word32, FileDigest, FilePath, Maybe FilePath) :. (Int64, ChunkReplicaId, C.APrivateAuthKey, Bool, Maybe Int64, Int)) -> RcvFileChunk toChunk ((rcvFileId, rcvFileEntityId, userId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath, chunkTmpPath) :. (rcvChunkReplicaId, replicaId, replicaKey, received, delay, retries)) = RcvFileChunk { rcvFileId, @@ -2621,12 +2621,12 @@ getSndFile db sndFileId = runExceptT $ do rcvIdsKeys <- getChunkReplicaRecipients_ db sndChunkReplicaId pure (replica :: SndFileChunkReplica) {rcvIdsKeys} where - toReplica :: (Int64, ChunkReplicaId, C.APrivateSignKey, SndFileReplicaStatus, Maybe Int64, Int, NonEmpty TransportHost, ServiceName, C.KeyHash) -> SndFileChunkReplica + toReplica :: (Int64, ChunkReplicaId, C.APrivateAuthKey, SndFileReplicaStatus, Maybe Int64, Int, NonEmpty TransportHost, ServiceName, C.KeyHash) -> SndFileChunkReplica toReplica (sndChunkReplicaId, replicaId, replicaKey, replicaStatus, delay, retries, host, port, keyHash) = let server = XFTPServer host port keyHash in SndFileChunkReplica {sndChunkReplicaId, server, replicaId, replicaKey, replicaStatus, delay, retries, rcvIdsKeys = []} -getChunkReplicaRecipients_ :: DB.Connection -> Int64 -> IO [(ChunkReplicaId, C.APrivateSignKey)] +getChunkReplicaRecipients_ :: DB.Connection -> Int64 -> IO [(ChunkReplicaId, C.APrivateAuthKey)] getChunkReplicaRecipients_ db replicaId = DB.query db @@ -2774,7 +2774,7 @@ getNextSndChunkToUpload db server@ProtocolServer {host, port, keyHash} ttl = do pure (replica :: SndFileChunkReplica) {rcvIdsKeys} pure (chunk {replicas = replicas'} :: SndFileChunk) where - toChunk :: ((DBSndFileId, SndFileId, UserId, Int, FilePath) :. (Int64, Int, Int64, Word32, FileDigest) :. (Int64, ChunkReplicaId, C.APrivateSignKey, SndFileReplicaStatus, Maybe Int64, Int)) -> SndFileChunk + toChunk :: ((DBSndFileId, SndFileId, UserId, Int, FilePath) :. (Int64, Int, Int64, Word32, FileDigest) :. (Int64, ChunkReplicaId, C.APrivateAuthKey, SndFileReplicaStatus, Maybe Int64, Int)) -> SndFileChunk toChunk ((sndFileId, sndFileEntityId, userId, numRecipients, filePrefixPath) :. (sndChunkId, chunkNo, chunkOffset, chunkSize, digest) :. (sndChunkReplicaId, replicaId, replicaKey, replicaStatus, delay, retries)) = let chunkSpec = XFTPChunkSpec {filePath = sndFileEncPath filePrefixPath, chunkOffset, chunkSize} in SndFileChunk @@ -2795,7 +2795,7 @@ updateSndChunkReplicaDelay db replicaId delay = do updatedAt <- getCurrentTime DB.execute db "UPDATE snd_file_chunk_replicas SET delay = ?, retries = retries + 1, updated_at = ? WHERE snd_file_chunk_replica_id = ?" (delay, updatedAt, replicaId) -addSndChunkReplicaRecipients :: DB.Connection -> SndFileChunkReplica -> [(ChunkReplicaId, C.APrivateSignKey)] -> IO SndFileChunkReplica +addSndChunkReplicaRecipients :: DB.Connection -> SndFileChunkReplica -> [(ChunkReplicaId, C.APrivateAuthKey)] -> IO SndFileChunkReplica addSndChunkReplicaRecipients db r@SndFileChunkReplica {sndChunkReplicaId} rcvIdsKeys = do forM_ rcvIdsKeys $ \(rcvId, rcvKey) -> do DB.execute @@ -2888,7 +2888,7 @@ getDeletedSndChunkReplica db deletedSndChunkReplicaId = |] (Only deletedSndChunkReplicaId) where - toReplica :: (UserId, ChunkReplicaId, C.APrivateSignKey, FileDigest, Maybe Int64, Int, NonEmpty TransportHost, ServiceName, C.KeyHash) -> DeletedSndChunkReplica + toReplica :: (UserId, ChunkReplicaId, C.APrivateAuthKey, FileDigest, Maybe Int64, Int, NonEmpty TransportHost, ServiceName, C.KeyHash) -> DeletedSndChunkReplica toReplica (userId, replicaId, replicaKey, chunkDigest, delay, retries, host, port, keyHash) = let server = XFTPServer host port keyHash in DeletedSndChunkReplica {deletedSndChunkReplicaId, userId, server, replicaId, replicaKey, chunkDigest, delay, retries} diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index a3aaaa84d..dde9f1f5d 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -74,6 +74,7 @@ module Simplex.Messaging.Client -- * For testing PCTransmission, mkTransmission, + authTransmission, clientStub, ) where @@ -83,7 +84,9 @@ import Control.Concurrent.STM import Control.Exception import Control.Monad import Control.Monad.IO.Class (liftIO) +import Control.Monad.Except import Control.Monad.Trans.Except +import Crypto.Random (ChaChaDRG) import qualified Data.Aeson.TH as J import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B @@ -118,6 +121,7 @@ data ProtocolClient err msg = ProtocolClient sessionId :: SessionId, sessionTs :: UTCTime, thVersion :: Version, + thAuth :: Maybe THandleAuth, timeoutPerBlock :: Int, blockSize :: Int, batch :: Bool, @@ -150,7 +154,8 @@ clientStub sessionId = do { action = Nothing, sessionId, sessionTs = undefined, - thVersion = 5, + thVersion = currentSMPServerVersion, + thAuth = Nothing, timeoutPerBlock = undefined, blockSize = smpBlockSize, batch = undefined, @@ -173,7 +178,7 @@ clientStub sessionId = do type SMPClient = ProtocolClient ErrorType BrokerMsg -- | Type for client command data -type ClientCommand msg = (Maybe C.APrivateSignKey, EntityId, ProtoCommand msg) +type ClientCommand msg = (Maybe C.APrivateAuthKey, EntityId, ProtoCommand msg) -- | Type synonym for transmission from some SPM server queue. type ServerTransmission msg = (TransportSession msg, Version, SessionId, EntityId, msg) @@ -306,8 +311,8 @@ type TransportSession msg = (UserId, ProtoServer msg, Maybe EntityId) -- -- A single queue can be used for multiple 'SMPClient' instances, -- as 'SMPServerTransmission' includes server information. -getProtocolClient :: forall err msg. Protocol err msg => TransportSession msg -> ProtocolClientConfig -> Maybe (TBQueue (ServerTransmission msg)) -> (ProtocolClient err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient err msg)) -getProtocolClient transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, serverVRange, batchDelay} msgQ disconnected = do +getProtocolClient :: forall err msg. Protocol err msg => TVar ChaChaDRG -> TransportSession msg -> ProtocolClientConfig -> Maybe (TBQueue (ServerTransmission msg)) -> (ProtocolClient err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient err msg)) +getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, serverVRange, batchDelay} msgQ disconnected = do case chooseTransportHost networkConfig (host srv) of Right useHost -> (atomically (mkProtocolClient useHost) >>= runClient useTransport useHost) @@ -360,13 +365,14 @@ getProtocolClient transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, p -> (p, transport @TLS) client :: forall c. Transport c => TProxy c -> PClient err msg -> TMVar (Either (ProtocolClientError err) (ProtocolClient err msg)) -> c -> IO () - client _ c cVar h = - runExceptT (protocolClientHandshake @err @msg h (keyHash srv) serverVRange) >>= \case + client _ c cVar h = do + ks <- atomically $ C.generateKeyPair g + runExceptT (protocolClientHandshake @err @msg h ks (keyHash srv) serverVRange) >>= \case Left e -> atomically . putTMVar cVar . Left $ PCETransportError e - Right th@THandle {sessionId, thVersion, blockSize, batch} -> do + Right th@THandle {sessionId, thVersion, thAuth, blockSize, batch} -> do sessionTs <- getCurrentTime let timeoutPerBlock = (blockSize * tcpTimeoutPerKb) `div` 1024 - c' = ProtocolClient {action = Nothing, client_ = c, sessionId, thVersion, sessionTs, timeoutPerBlock, blockSize, batch} + c' = ProtocolClient {action = Nothing, client_ = c, sessionId, thVersion, thAuth, sessionTs, timeoutPerBlock, blockSize, batch} atomically $ do writeTVar (connected c) True putTMVar cVar $ Right c' @@ -468,13 +474,12 @@ temporaryClientError = \case -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#create-queue-command createSMPQueue :: SMPClient -> - RcvPrivateSignKey -> - RcvPublicVerifyKey -> + C.AAuthKeyPair -> -- SMP v6 - signature key pair, SMP v7 - DH key pair RcvPublicDhKey -> Maybe BasicAuth -> SubscriptionMode -> ExceptT SMPClientError IO QueueIdsKeys -createSMPQueue c rpKey rKey dhKey auth subMode = +createSMPQueue c (rKey, rpKey) dhKey auth subMode = sendSMPCommand c (Just rpKey) "" (NEW rKey dhKey auth subMode) >>= \case IDS qik -> pure qik r -> throwE . PCEUnexpectedResponse $ bshow r @@ -482,7 +487,7 @@ createSMPQueue c rpKey rKey dhKey auth subMode = -- | Subscribe to the SMP queue. -- -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#subscribe-to-queue -subscribeSMPQueue :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT SMPClientError IO () +subscribeSMPQueue :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO () subscribeSMPQueue c rpKey rId = sendSMPCommand c (Just rpKey) rId SUB >>= \case OK -> return () @@ -490,12 +495,12 @@ subscribeSMPQueue c rpKey rId = r -> throwE . PCEUnexpectedResponse $ bshow r -- | Subscribe to multiple SMP queues batching commands if supported. -subscribeSMPQueues :: SMPClient -> NonEmpty (RcvPrivateSignKey, RecipientId) -> IO (NonEmpty (Either SMPClientError ())) +subscribeSMPQueues :: SMPClient -> NonEmpty (RcvPrivateAuthKey, RecipientId) -> IO (NonEmpty (Either SMPClientError ())) subscribeSMPQueues c qs = sendProtocolCommands c cs >>= mapM (processSUBResponse c) where cs = L.map (\(rpKey, rId) -> (Just rpKey, rId, Cmd SRecipient SUB)) qs -streamSubscribeSMPQueues :: SMPClient -> NonEmpty (RcvPrivateSignKey, RecipientId) -> ([(RecipientId, Either SMPClientError ())] -> IO ()) -> IO () +streamSubscribeSMPQueues :: SMPClient -> NonEmpty (RcvPrivateAuthKey, RecipientId) -> ([(RecipientId, Either SMPClientError ())] -> IO ()) -> IO () streamSubscribeSMPQueues c qs cb = streamProtocolCommands c cs $ mapM process >=> cb where cs = L.map (\(rpKey, rId) -> (Just rpKey, rId, Cmd SRecipient SUB)) qs @@ -518,7 +523,7 @@ serverTransmission ProtocolClient {thVersion, sessionId, client_ = PClient {tran -- | Get message from SMP queue. The server returns ERR PROHIBITED if a client uses SUB and GET via the same transport connection for the same queue -- -- https://github.covm/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#receive-a-message-from-the-queue -getSMPMessage :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT SMPClientError IO (Maybe RcvMessage) +getSMPMessage :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO (Maybe RcvMessage) getSMPMessage c rpKey rId = sendSMPCommand c (Just rpKey) rId GET >>= \case OK -> pure Nothing @@ -528,30 +533,30 @@ getSMPMessage c rpKey rId = -- | Subscribe to the SMP queue notifications. -- -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#subscribe-to-queue-notifications -subscribeSMPQueueNotifications :: SMPClient -> NtfPrivateSignKey -> NotifierId -> ExceptT SMPClientError IO () +subscribeSMPQueueNotifications :: SMPClient -> NtfPrivateAuthKey -> NotifierId -> ExceptT SMPClientError IO () subscribeSMPQueueNotifications = okSMPCommand NSUB -- | Subscribe to multiple SMP queues notifications batching commands if supported. -subscribeSMPQueuesNtfs :: SMPClient -> NonEmpty (NtfPrivateSignKey, NotifierId) -> IO (NonEmpty (Either SMPClientError ())) +subscribeSMPQueuesNtfs :: SMPClient -> NonEmpty (NtfPrivateAuthKey, NotifierId) -> IO (NonEmpty (Either SMPClientError ())) subscribeSMPQueuesNtfs = okSMPCommands NSUB -- | Secure the SMP queue by adding a sender public key. -- -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#secure-queue-command -secureSMPQueue :: SMPClient -> RcvPrivateSignKey -> RecipientId -> SndPublicVerifyKey -> ExceptT SMPClientError IO () +secureSMPQueue :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> SndPublicAuthKey -> ExceptT SMPClientError IO () secureSMPQueue c rpKey rId senderKey = okSMPCommand (KEY senderKey) c rpKey rId -- | Enable notifications for the queue for push notifications server. -- -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#enable-notifications-command -enableSMPQueueNotifications :: SMPClient -> RcvPrivateSignKey -> RecipientId -> NtfPublicVerifyKey -> RcvNtfPublicDhKey -> ExceptT SMPClientError IO (NotifierId, RcvNtfPublicDhKey) +enableSMPQueueNotifications :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> NtfPublicAuthKey -> RcvNtfPublicDhKey -> ExceptT SMPClientError IO (NotifierId, RcvNtfPublicDhKey) enableSMPQueueNotifications c rpKey rId notifierKey rcvNtfPublicDhKey = sendSMPCommand c (Just rpKey) rId (NKEY notifierKey rcvNtfPublicDhKey) >>= \case NID nId rcvNtfSrvPublicDhKey -> pure (nId, rcvNtfSrvPublicDhKey) r -> throwE . PCEUnexpectedResponse $ bshow r -- | Enable notifications for the multiple queues for push notifications server. -enableSMPQueuesNtfs :: SMPClient -> NonEmpty (RcvPrivateSignKey, RecipientId, NtfPublicVerifyKey, RcvNtfPublicDhKey) -> IO (NonEmpty (Either SMPClientError (NotifierId, RcvNtfPublicDhKey))) +enableSMPQueuesNtfs :: SMPClient -> NonEmpty (RcvPrivateAuthKey, RecipientId, NtfPublicAuthKey, RcvNtfPublicDhKey) -> IO (NonEmpty (Either SMPClientError (NotifierId, RcvNtfPublicDhKey))) enableSMPQueuesNtfs c qs = L.map process <$> sendProtocolCommands c cs where cs = L.map (\(rpKey, rId, notifierKey, rcvNtfPublicDhKey) -> (Just rpKey, rId, Cmd SRecipient $ NKEY notifierKey rcvNtfPublicDhKey)) qs @@ -563,17 +568,17 @@ enableSMPQueuesNtfs c qs = L.map process <$> sendProtocolCommands c cs -- | Disable notifications for the queue for push notifications server. -- -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#disable-notifications-command -disableSMPQueueNotifications :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT SMPClientError IO () +disableSMPQueueNotifications :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO () disableSMPQueueNotifications = okSMPCommand NDEL -- | Disable notifications for multiple queues for push notifications server. -disableSMPQueuesNtfs :: SMPClient -> NonEmpty (RcvPrivateSignKey, RecipientId) -> IO (NonEmpty (Either SMPClientError ())) +disableSMPQueuesNtfs :: SMPClient -> NonEmpty (RcvPrivateAuthKey, RecipientId) -> IO (NonEmpty (Either SMPClientError ())) disableSMPQueuesNtfs = okSMPCommands NDEL -- | Send SMP message. -- -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#send-message -sendSMPMessage :: SMPClient -> Maybe SndPrivateSignKey -> SenderId -> MsgFlags -> MsgBody -> ExceptT SMPClientError IO () +sendSMPMessage :: SMPClient -> Maybe SndPrivateAuthKey -> SenderId -> MsgFlags -> MsgBody -> ExceptT SMPClientError IO () sendSMPMessage c spKey sId flags msg = sendSMPCommand c spKey sId (SEND flags msg) >>= \case OK -> pure () @@ -582,7 +587,7 @@ sendSMPMessage c spKey sId flags msg = -- | Acknowledge message delivery (server deletes the message). -- -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#acknowledge-message-delivery -ackSMPMessage :: SMPClient -> RcvPrivateSignKey -> QueueId -> MsgId -> ExceptT SMPClientError IO () +ackSMPMessage :: SMPClient -> RcvPrivateAuthKey -> QueueId -> MsgId -> ExceptT SMPClientError IO () ackSMPMessage c rpKey rId msgId = sendSMPCommand c (Just rpKey) rId (ACK msgId) >>= \case OK -> return () @@ -593,26 +598,26 @@ ackSMPMessage c rpKey rId msgId = -- The existing messages from the queue will still be delivered. -- -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#suspend-queue -suspendSMPQueue :: SMPClient -> RcvPrivateSignKey -> QueueId -> ExceptT SMPClientError IO () +suspendSMPQueue :: SMPClient -> RcvPrivateAuthKey -> QueueId -> ExceptT SMPClientError IO () suspendSMPQueue = okSMPCommand OFF -- | Irreversibly delete SMP queue and all messages in it. -- -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#delete-queue -deleteSMPQueue :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT SMPClientError IO () +deleteSMPQueue :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO () deleteSMPQueue = okSMPCommand DEL -- | Delete multiple SMP queues batching commands if supported. -deleteSMPQueues :: SMPClient -> NonEmpty (RcvPrivateSignKey, RecipientId) -> IO (NonEmpty (Either SMPClientError ())) +deleteSMPQueues :: SMPClient -> NonEmpty (RcvPrivateAuthKey, RecipientId) -> IO (NonEmpty (Either SMPClientError ())) deleteSMPQueues = okSMPCommands DEL -okSMPCommand :: PartyI p => Command p -> SMPClient -> C.APrivateSignKey -> QueueId -> ExceptT SMPClientError IO () +okSMPCommand :: PartyI p => Command p -> SMPClient -> C.APrivateAuthKey -> QueueId -> ExceptT SMPClientError IO () okSMPCommand cmd c pKey qId = sendSMPCommand c (Just pKey) qId cmd >>= \case OK -> return () r -> throwE . PCEUnexpectedResponse $ bshow r -okSMPCommands :: PartyI p => Command p -> SMPClient -> NonEmpty (C.APrivateSignKey, QueueId) -> IO (NonEmpty (Either SMPClientError ())) +okSMPCommands :: PartyI p => Command p -> SMPClient -> NonEmpty (C.APrivateAuthKey, QueueId) -> IO (NonEmpty (Either SMPClientError ())) okSMPCommands cmd c qs = L.map process <$> sendProtocolCommands c cs where aCmd = Cmd sParty cmd @@ -623,10 +628,10 @@ okSMPCommands cmd c qs = L.map process <$> sendProtocolCommands c cs Left e -> Left e -- | Send SMP command -sendSMPCommand :: PartyI p => SMPClient -> Maybe C.APrivateSignKey -> QueueId -> Command p -> ExceptT SMPClientError IO BrokerMsg +sendSMPCommand :: PartyI p => SMPClient -> Maybe C.APrivateAuthKey -> QueueId -> Command p -> ExceptT SMPClientError IO BrokerMsg sendSMPCommand c pKey qId cmd = sendProtocolCommand c pKey qId (Cmd sParty cmd) -type PCTransmission err msg = (SentRawTransmission, Request err msg) +type PCTransmission err msg = (Either TransportError SentRawTransmission, Request err msg) -- | Send multiple commands with batching and collect responses sendProtocolCommands :: forall err msg. ProtocolEncoding err (ProtoCommand msg) => ProtocolClient err msg -> NonEmpty (ClientCommand msg) -> IO (NonEmpty (Response err msg)) @@ -654,9 +659,9 @@ streamProtocolCommands c@ProtocolClient {batch, blockSize} cs cb = do sendBatch :: ProtocolClient err msg -> TransportBatch (Request err msg) -> IO [Response err msg] sendBatch c@ProtocolClient {client_ = PClient {sndQ}} b = do case b of - TBLargeTransmission Request {entityId} -> do + TBError e Request {entityId} -> do putStrLn "send error: large message" - pure [Response entityId $ Left $ PCETransportError TELargeMsg] + pure [Response entityId $ Left $ PCETransportError e] TBTransmissions s n rs | n > 0 -> do atomically $ writeTBQueue sndQ s @@ -667,19 +672,21 @@ sendBatch c@ProtocolClient {client_ = PClient {sndQ}} b = do (: []) <$> getResponse c r -- | Send Protocol command -sendProtocolCommand :: forall err msg. ProtocolEncoding err (ProtoCommand msg) => ProtocolClient err msg -> Maybe C.APrivateSignKey -> EntityId -> ProtoCommand msg -> ExceptT (ProtocolClientError err) IO msg +sendProtocolCommand :: forall err msg. ProtocolEncoding err (ProtoCommand msg) => ProtocolClient err msg -> Maybe C.APrivateAuthKey -> EntityId -> ProtoCommand msg -> ExceptT (ProtocolClientError err) IO msg sendProtocolCommand c@ProtocolClient {client_ = PClient {sndQ}, batch, blockSize} pKey entId cmd = ExceptT $ uncurry sendRecv =<< mkTransmission c (pKey, entId, cmd) where -- two separate "atomically" needed to avoid blocking - sendRecv :: SentRawTransmission -> Request err msg -> IO (Either (ProtocolClientError err) msg) - sendRecv t r - | B.length s > blockSize - 2 = pure $ Left $ PCETransportError TELargeMsg - | otherwise = atomically (writeTBQueue sndQ s) >> response <$> getResponse c r - where - s - | batch = tEncodeBatch1 t - | otherwise = tEncode t + sendRecv :: Either TransportError SentRawTransmission -> Request err msg -> IO (Either (ProtocolClientError err) msg) + sendRecv t_ r = case t_ of + Left e -> pure . Left $ PCETransportError e + Right t + | B.length s > blockSize - 2 -> pure . Left $ PCETransportError TELargeMsg + | otherwise -> atomically (writeTBQueue sndQ s) >> response <$> getResponse c r + where + s + | batch = tEncodeBatch1 t + | otherwise = tEncode t -- TODO switch to timeout or TimeManager that supports Int64 getResponse :: ProtocolClient err msg -> Request err msg -> IO (Response err msg) @@ -691,24 +698,37 @@ getResponse ProtocolClient {client_ = PClient {tcpTimeout, pingErrorCount}} Requ pure Response {entityId, response} mkTransmission :: forall err msg. ProtocolEncoding err (ProtoCommand msg) => ProtocolClient err msg -> ClientCommand msg -> IO (PCTransmission err msg) -mkTransmission ProtocolClient {sessionId, thVersion, client_ = PClient {clientCorrId, sentCommands}} (pKey, entId, cmd) = do +mkTransmission ProtocolClient {sessionId, thVersion = v, thAuth, client_ = PClient {clientCorrId, sentCommands}} (pKey_, entId, cmd) = do corrId <- atomically getNextCorrId - let t = signTransmission $ encodeTransmission thVersion sessionId (corrId, entId, cmd) + let t = authTransmission thAuth pKey_ corrId $ encodeTransmission v sessionId (corrId, entId, cmd) r <- atomically $ mkRequest corrId pure (t, r) where getNextCorrId :: STM CorrId getNextCorrId = do - i <- stateTVar clientCorrId $ \i -> (i, i + 1) + i <- stateTVar clientCorrId $ \i -> (i, i + 2) pure . CorrId $ bshow i - signTransmission :: ByteString -> SentRawTransmission - signTransmission t = ((`C.sign` t) <$> pKey, t) mkRequest :: CorrId -> STM (Request err msg) mkRequest corrId = do r <- Request entId <$> newEmptyTMVar TM.insert corrId r sentCommands pure r +authTransmission :: Maybe THandleAuth -> Maybe C.APrivateAuthKey -> CorrId -> ByteString -> Either TransportError SentRawTransmission +authTransmission thAuth pKey_ (CorrId corrId) t = case pKey_ of + Nothing -> Right (TAuthNone, t) + Just pKey -> (,t) <$> authorize pKey + where + authorize :: C.APrivateAuthKey -> Either TransportError TransmissionAuth + authorize (C.APrivateAuthKey a pk) = case a of + C.SX25519 -> case thAuth of + Just THandleAuth {peerPubKey} -> Right $ TAuthEncHash $ C.cbEncryptNoPad (C.dh' peerPubKey pk) (C.cbNonce corrId) (C.sha512Hash t) + Nothing -> Left TENoServerAuth + C.SEd25519 -> sign pk + C.SEd448 -> sign pk + sign :: forall a. (C.AlgorithmI a, C.SignatureAlgorithm a) => C.PrivateKey a -> Either TransportError TransmissionAuth + sign pk = Right $ TAuthSignature $ C.ASignature (C.sAlgorithm @a) (C.sign' pk t) + $(J.deriveJSON (enumJSON $ dropPrefix "HM") ''HostMode) $(J.deriveJSON (enumJSON $ dropPrefix "TSM") ''TransportSessionMode) diff --git a/src/Simplex/Messaging/Client/Agent.hs b/src/Simplex/Messaging/Client/Agent.hs index 4d0d81bbc..993fb60a2 100644 --- a/src/Simplex/Messaging/Client/Agent.hs +++ b/src/Simplex/Messaging/Client/Agent.hs @@ -18,6 +18,7 @@ import Control.Monad import Control.Monad.Except import Control.Monad.IO.Unlift import Control.Monad.Trans.Except +import Crypto.Random (ChaChaDRG) import Data.Bifunctor (bimap, first) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B @@ -36,7 +37,7 @@ import Simplex.Messaging.Agent.RetryInterval import Simplex.Messaging.Client import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Protocol (BrokerMsg, NotifierId, NtfPrivateSignKey, ProtocolServer (..), QueueId, RcvPrivateSignKey, RecipientId, SMPServer) +import Simplex.Messaging.Protocol (BrokerMsg, NotifierId, NtfPrivateAuthKey, ProtocolServer (..), QueueId, RcvPrivateAuthKey, RecipientId, SMPServer) import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Transport @@ -92,9 +93,10 @@ data SMPClientAgent = SMPClientAgent { agentCfg :: SMPClientAgentConfig, msgQ :: TBQueue (ServerTransmission BrokerMsg), agentQ :: TBQueue SMPClientAgentEvent, + randomDrg :: TVar ChaChaDRG, smpClients :: TMap SMPServer SMPClientVar, - srvSubs :: TMap SMPServer (TMap SMPSub C.APrivateSignKey), - pendingSrvSubs :: TMap SMPServer (TMap SMPSub C.APrivateSignKey), + srvSubs :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey), + pendingSrvSubs :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey), reconnections :: TVar [Async ()], asyncClients :: TVar [Async ()] } @@ -111,8 +113,8 @@ instance (MonadUnliftIO m, Exception e) => MonadUnliftIO (ExceptT e m) where withRunInIO $ \run -> exceptToIO $ run . (either (E.throwIO . InternalException) return <=< runExceptT) -newSMPClientAgent :: SMPClientAgentConfig -> STM SMPClientAgent -newSMPClientAgent agentCfg@SMPClientAgentConfig {msgQSize, agentQSize} = do +newSMPClientAgent :: SMPClientAgentConfig -> TVar ChaChaDRG -> STM SMPClientAgent +newSMPClientAgent agentCfg@SMPClientAgentConfig {msgQSize, agentQSize} randomDrg = do msgQ <- newTBQueue msgQSize agentQ <- newTBQueue agentQSize smpClients <- TM.empty @@ -120,10 +122,10 @@ newSMPClientAgent agentCfg@SMPClientAgentConfig {msgQSize, agentQSize} = do pendingSrvSubs <- TM.empty reconnections <- newTVar [] asyncClients <- newTVar [] - pure SMPClientAgent {agentCfg, msgQ, agentQ, smpClients, srvSubs, pendingSrvSubs, reconnections, asyncClients} + pure SMPClientAgent {agentCfg, msgQ, agentQ, randomDrg, smpClients, srvSubs, pendingSrvSubs, reconnections, asyncClients} getSMPServerClient' :: SMPClientAgent -> SMPServer -> ExceptT SMPClientError IO SMPClient -getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv = +getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ, randomDrg} srv = atomically getClientVar >>= either newSMPClient waitForSMPClient where getClientVar :: STM (Either SMPClientVar SMPClientVar) @@ -171,14 +173,14 @@ getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv = void $ tryConnectClient (const reconnectClient) loop connectClient :: ExceptT SMPClientError IO SMPClient - connectClient = ExceptT $ getProtocolClient (1, srv, Nothing) (smpCfg agentCfg) (Just msgQ) clientDisconnected + connectClient = ExceptT $ getProtocolClient randomDrg (1, srv, Nothing) (smpCfg agentCfg) (Just msgQ) clientDisconnected clientDisconnected :: SMPClient -> IO () clientDisconnected _ = do removeClientAndSubs >>= (`forM_` serverDown) logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv - removeClientAndSubs :: IO (Maybe (Map SMPSub C.APrivateSignKey)) + removeClientAndSubs :: IO (Maybe (Map SMPSub C.APrivateAuthKey)) removeClientAndSubs = atomically $ do TM.delete srv smpClients TM.lookupDelete srv (srvSubs ca) >>= mapM updateSubs @@ -194,7 +196,7 @@ getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv = Just v -> TM.union ss v _ -> TM.insert srv sVar ps - serverDown :: Map SMPSub C.APrivateSignKey -> IO () + serverDown :: Map SMPSub C.APrivateAuthKey -> IO () serverDown ss = unless (M.null ss) $ do notify . CADisconnected srv $ M.keysSet ss void $ runExceptT reconnectServer @@ -224,15 +226,15 @@ getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv = SPNotifier -> True SPRecipient -> False - subscribe_ :: SMPClient -> SMPSubParty -> [(SMPSub, C.APrivateSignKey)] -> ExceptT SMPClientError IO () + subscribe_ :: SMPClient -> SMPSubParty -> [(SMPSub, C.APrivateAuthKey)] -> ExceptT SMPClientError IO () subscribe_ smp party = mapM_ subscribeBatch . toChunks (agentSubsBatchSize agentCfg) where subscribeBatch subs' = do - let subs'' :: (NonEmpty (QueueId, C.APrivateSignKey)) = L.map (first snd) subs' + let subs'' :: (NonEmpty (QueueId, C.APrivateAuthKey)) = L.map (first snd) subs' rs <- liftIO $ smpSubscribeQueues party ca smp srv subs'' - let rs' :: (NonEmpty ((SMPSub, C.APrivateSignKey), Either SMPClientError ())) = + let rs' :: (NonEmpty ((SMPSub, C.APrivateAuthKey), Either SMPClientError ())) = L.zipWith (first . const) subs' rs - rs'' :: [Either (SMPSub, SMPClientError) (SMPSub, C.APrivateSignKey)] = + rs'' :: [Either (SMPSub, SMPClientError) (SMPSub, C.APrivateAuthKey)] = map (\(sub, r) -> bimap (fst sub,) (const sub) r) $ L.toList rs' (errs, oks) = partitionEithers rs'' (tempErrs, finalErrs) = partition (temporaryClientError . snd) errs @@ -270,7 +272,7 @@ withSMP ca srv action = (getSMPServerClient' ca srv >>= action) `catchE` logSMPE liftIO $ putStrLn $ "SMP error (" <> show srv <> "): " <> show e throwE e -subscribeQueue :: SMPClientAgent -> SMPServer -> (SMPSub, C.APrivateSignKey) -> ExceptT SMPClientError IO () +subscribeQueue :: SMPClientAgent -> SMPServer -> (SMPSub, C.APrivateAuthKey) -> ExceptT SMPClientError IO () subscribeQueue ca srv sub = do atomically $ addPendingSubscription ca srv sub withSMP ca srv $ \smp -> subscribe_ smp `catchE` handleErr @@ -284,20 +286,20 @@ subscribeQueue ca srv sub = do removePendingSubscription ca srv (fst sub) throwE e -subscribeQueuesSMP :: SMPClientAgent -> SMPServer -> NonEmpty (RecipientId, RcvPrivateSignKey) -> IO (NonEmpty (RecipientId, Either SMPClientError ())) +subscribeQueuesSMP :: SMPClientAgent -> SMPServer -> NonEmpty (RecipientId, RcvPrivateAuthKey) -> IO (NonEmpty (RecipientId, Either SMPClientError ())) subscribeQueuesSMP = subscribeQueues_ SPRecipient -subscribeQueuesNtfs :: SMPClientAgent -> SMPServer -> NonEmpty (NotifierId, NtfPrivateSignKey) -> IO (NonEmpty (NotifierId, Either SMPClientError ())) +subscribeQueuesNtfs :: SMPClientAgent -> SMPServer -> NonEmpty (NotifierId, NtfPrivateAuthKey) -> IO (NonEmpty (NotifierId, Either SMPClientError ())) subscribeQueuesNtfs = subscribeQueues_ SPNotifier -subscribeQueues_ :: SMPSubParty -> SMPClientAgent -> SMPServer -> NonEmpty (QueueId, C.APrivateSignKey) -> IO (NonEmpty (QueueId, Either SMPClientError ())) +subscribeQueues_ :: SMPSubParty -> SMPClientAgent -> SMPServer -> NonEmpty (QueueId, C.APrivateAuthKey) -> IO (NonEmpty (QueueId, Either SMPClientError ())) subscribeQueues_ party ca srv subs = do atomically $ forM_ subs $ addPendingSubscription ca srv . first (party,) runExceptT (getSMPServerClient' ca srv) >>= \case Left e -> pure $ L.map ((,Left e) . fst) subs Right smp -> smpSubscribeQueues party ca smp srv subs -smpSubscribeQueues :: SMPSubParty -> SMPClientAgent -> SMPClient -> SMPServer -> NonEmpty (QueueId, C.APrivateSignKey) -> IO (NonEmpty (QueueId, Either SMPClientError ())) +smpSubscribeQueues :: SMPSubParty -> SMPClientAgent -> SMPClient -> SMPServer -> NonEmpty (QueueId, C.APrivateAuthKey) -> IO (NonEmpty (QueueId, Either SMPClientError ())) smpSubscribeQueues party ca smp srv subs = do rs <- L.zip subs <$> subscribe smp (L.map swap subs) atomically $ forM rs $ \(sub, r) -> @@ -318,22 +320,22 @@ showServer :: SMPServer -> ByteString showServer ProtocolServer {host, port} = strEncode host <> B.pack (if null port then "" else ':' : port) -smpSubscribe :: SMPClient -> (SMPSub, C.APrivateSignKey) -> ExceptT SMPClientError IO () +smpSubscribe :: SMPClient -> (SMPSub, C.APrivateAuthKey) -> ExceptT SMPClientError IO () smpSubscribe smp ((party, queueId), privKey) = subscribe_ smp privKey queueId where subscribe_ = case party of SPRecipient -> subscribeSMPQueue SPNotifier -> subscribeSMPQueueNotifications -addSubscription :: SMPClientAgent -> SMPServer -> (SMPSub, C.APrivateSignKey) -> STM () +addSubscription :: SMPClientAgent -> SMPServer -> (SMPSub, C.APrivateAuthKey) -> STM () addSubscription ca srv sub = do addSub_ (srvSubs ca) srv sub removePendingSubscription ca srv $ fst sub -addPendingSubscription :: SMPClientAgent -> SMPServer -> (SMPSub, C.APrivateSignKey) -> STM () +addPendingSubscription :: SMPClientAgent -> SMPServer -> (SMPSub, C.APrivateAuthKey) -> STM () addPendingSubscription = addSub_ . pendingSrvSubs -addSub_ :: TMap SMPServer (TMap SMPSub C.APrivateSignKey) -> SMPServer -> (SMPSub, C.APrivateSignKey) -> STM () +addSub_ :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey) -> SMPServer -> (SMPSub, C.APrivateAuthKey) -> STM () addSub_ subs srv (s, key) = TM.lookup srv subs >>= \case Just m -> TM.insert s key m @@ -345,11 +347,11 @@ removeSubscription = removeSub_ . srvSubs removePendingSubscription :: SMPClientAgent -> SMPServer -> SMPSub -> STM () removePendingSubscription = removeSub_ . pendingSrvSubs -removeSub_ :: TMap SMPServer (TMap SMPSub C.APrivateSignKey) -> SMPServer -> SMPSub -> STM () +removeSub_ :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey) -> SMPServer -> SMPSub -> STM () removeSub_ subs srv s = TM.lookup srv subs >>= mapM_ (TM.delete s) -getSubKey :: TMap SMPServer (TMap SMPSub C.APrivateSignKey) -> SMPServer -> SMPSub -> STM (Maybe C.APrivateSignKey) +getSubKey :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey) -> SMPServer -> SMPSub -> STM (Maybe C.APrivateAuthKey) getSubKey subs srv s = TM.lookup srv subs $>>= TM.lookup s -hasSub :: TMap SMPServer (TMap SMPSub C.APrivateSignKey) -> SMPServer -> SMPSub -> STM Bool +hasSub :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey) -> SMPServer -> SMPSub -> STM Bool hasSub subs srv s = maybe (pure False) (TM.member s) =<< TM.lookup srv subs diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs index 3564454ff..4fa202542 100644 --- a/src/Simplex/Messaging/Crypto.hs +++ b/src/Simplex/Messaging/Crypto.hs @@ -36,7 +36,7 @@ module Simplex.Messaging.Crypto Algorithm (..), SAlgorithm (..), Alg (..), - SignAlg (..), + AuthAlg (..), DhAlg (..), DhAlgorithm, PrivateKey (..), @@ -53,9 +53,13 @@ module Simplex.Messaging.Crypto APublicVerifyKey (..), APrivateDhKey (..), APublicDhKey (..), + APrivateAuthKey (..), + APublicAuthKey (..), CryptoPublicKey (..), CryptoPrivateKey (..), + AAuthKeyPair, KeyPair, + KeyPairX25519, ASignatureKeyPair, DhSecret (..), DhSecretX25519, @@ -65,6 +69,7 @@ module Simplex.Messaging.Crypto generateAKeyPair, generateKeyPair, generateSignatureKeyPair, + generateAuthKeyPair, generateDhKeyPair, privateToX509, publicKey, @@ -84,6 +89,7 @@ module Simplex.Messaging.Crypto CryptoSignature (..), SignatureSize (..), SignatureAlgorithm, + AuthAlgorithm, AlgorithmI (..), sign, sign', @@ -115,6 +121,7 @@ module Simplex.Messaging.Crypto CbNonce (unCbNonce), pattern CbNonce, cbEncrypt, + cbEncryptNoPad, cbEncryptMaxLenBS, cbDecrypt, sbDecrypt_, @@ -226,10 +233,10 @@ deriving instance Show (SAlgorithm a) data Alg = forall a. AlgorithmI a => Alg (SAlgorithm a) -data SignAlg +data AuthAlg = forall a. - (AlgorithmI a, SignatureAlgorithm a) => - SignAlg (SAlgorithm a) + (AlgorithmI a, AuthAlgorithm a) => + AuthAlg (SAlgorithm a) data DhAlg = forall a. @@ -279,6 +286,12 @@ instance Eq APublicKey where Just Refl -> k == k' Nothing -> False +instance Encoding APublicKey where + smpEncode = smpEncode . encodePubKey + {-# INLINE smpEncode #-} + smpDecode = decodePubKey + {-# INLINE smpDecode #-} + deriving instance Show APublicKey type PublicKeyEd25519 = PublicKey Ed25519 @@ -425,6 +438,57 @@ dhAlgorithm = \case SX448 -> Just Dict _ -> Nothing +data APrivateAuthKey + = forall a. + (AlgorithmI a, AuthAlgorithm a) => + APrivateAuthKey (SAlgorithm a) (PrivateKey a) + +instance Eq APrivateAuthKey where + APrivateAuthKey a k == APrivateAuthKey a' k' = case testEquality a a' of + Just Refl -> k == k' + Nothing -> False + +deriving instance Show APrivateAuthKey + +instance Encoding APrivateAuthKey where + smpEncode = smpEncode . encodePrivKey + {-# INLINE smpEncode #-} + smpDecode = decodePrivKey + {-# INLINE smpDecode #-} + +instance StrEncoding APrivateAuthKey where + strEncode = strEncode . encodePrivKey + {-# INLINE strEncode #-} + strDecode = decodePrivKey + {-# INLINE strDecode #-} + +data APublicAuthKey + = forall a. + (AlgorithmI a, AuthAlgorithm a) => + APublicAuthKey (SAlgorithm a) (PublicKey a) + +instance Eq APublicAuthKey where + APublicAuthKey a k == APublicAuthKey a' k' = case testEquality a a' of + Just Refl -> k == k' + Nothing -> False + +deriving instance Show APublicAuthKey + +-- either X25519 or Ed algorithm that can be used to authorize commands to SMP server +type family AuthAlgorithm (a :: Algorithm) :: Constraint where + AuthAlgorithm Ed25519 = () + AuthAlgorithm Ed448 = () + AuthAlgorithm X25519 = () + AuthAlgorithm a = + (Int ~ Bool, TypeError (Text "Algorithm " :<>: ShowType a :<>: Text " cannot be used for authorization")) + +authAlgorithm :: SAlgorithm a -> Maybe (Dict (AuthAlgorithm a)) +authAlgorithm = \case + SEd25519 -> Just Dict + SEd448 -> Just Dict + SX25519 -> Just Dict + _ -> Nothing + dhBytes' :: DhSecret a -> ByteString dhBytes' = \case DhSecretX25519 s -> BA.convert s @@ -464,6 +528,12 @@ instance CryptoPublicKey APublicVerifyKey where Just Dict -> Right $ APublicVerifyKey a k _ -> Left "key does not support signature algorithms" +instance CryptoPublicKey APublicAuthKey where + toPubKey f (APublicAuthKey _ k) = f k + pubKey (APublicKey a k) = case authAlgorithm a of + Just Dict -> Right $ APublicAuthKey a k + _ -> Left "key does not support auth algorithms" + instance CryptoPublicKey APublicDhKey where toPubKey f (APublicDhKey _ k) = f k pubKey (APublicKey a k) = case dhAlgorithm a of @@ -480,6 +550,12 @@ instance Encoding APublicVerifyKey where smpDecode = decodePubKey {-# INLINE smpDecode #-} +instance Encoding APublicAuthKey where + smpEncode = smpEncode . encodePubKey + {-# INLINE smpEncode #-} + smpDecode = decodePubKey + {-# INLINE smpDecode #-} + instance Encoding APublicDhKey where smpEncode = smpEncode . encodePubKey {-# INLINE smpEncode #-} @@ -498,6 +574,12 @@ instance StrEncoding APublicVerifyKey where strDecode = decodePubKey {-# INLINE strDecode #-} +instance StrEncoding APublicAuthKey where + strEncode = strEncode . encodePubKey + {-# INLINE strEncode #-} + strDecode = decodePubKey + {-# INLINE strDecode #-} + instance StrEncoding APublicDhKey where strEncode = strEncode . encodePubKey {-# INLINE strEncode #-} @@ -545,6 +627,13 @@ instance CryptoPrivateKey APrivateSignKey where Just Dict -> Right $ APrivateSignKey a k _ -> Left "key does not support signature algorithms" +instance CryptoPrivateKey APrivateAuthKey where + type PublicKeyType APrivateAuthKey = APublicAuthKey + toPrivKey f (APrivateAuthKey _ k) = f k + privKey (APrivateKey a k) = case authAlgorithm a of + Just Dict -> Right $ APrivateAuthKey a k + _ -> Left "key does not support auth algorithms" + instance CryptoPrivateKey APrivateDhKey where type PublicKeyType APrivateDhKey = APublicDhKey toPrivKey f (APrivateDhKey _ k) = f k @@ -588,12 +677,17 @@ type KeyPairType pk = (PublicKeyType pk, pk) type KeyPair a = KeyPairType (PrivateKey a) +type KeyPairX25519 = KeyPair X25519 + +-- TODO narrow key pair types to have the same algorithm in both keys type AKeyPair = KeyPairType APrivateKey type ASignatureKeyPair = KeyPairType APrivateSignKey type ADhKeyPair = KeyPairType APrivateDhKey +type AAuthKeyPair = KeyPairType APrivateAuthKey + newRandom :: IO (TVar ChaChaDRG) newRandom = newTVarIO =<< drgNew @@ -603,6 +697,9 @@ generateAKeyPair a g = bimap (APublicKey a) (APrivateKey a) <$> generateKeyPair generateSignatureKeyPair :: (AlgorithmI a, SignatureAlgorithm a) => SAlgorithm a -> TVar ChaChaDRG -> STM ASignatureKeyPair generateSignatureKeyPair a g = bimap (APublicVerifyKey a) (APrivateSignKey a) <$> generateKeyPair g +generateAuthKeyPair :: (AlgorithmI a, AuthAlgorithm a) => SAlgorithm a -> TVar ChaChaDRG -> STM AAuthKeyPair +generateAuthKeyPair a g = bimap (APublicAuthKey a) (APrivateAuthKey a) <$> generateKeyPair g + generateDhKeyPair :: (AlgorithmI a, DhAlgorithm a) => SAlgorithm a -> TVar ChaChaDRG -> STM ADhKeyPair generateDhKeyPair a g = bimap (APublicDhKey a) (APrivateDhKey a) <$> generateKeyPair g @@ -632,6 +729,10 @@ instance ToField APrivateSignKey where toField = toField . encodePrivKey instance ToField APublicVerifyKey where toField = toField . encodePubKey +instance ToField APrivateAuthKey where toField = toField . encodePrivKey + +instance ToField APublicAuthKey where toField = toField . encodePubKey + instance ToField APrivateDhKey where toField = toField . encodePrivKey instance ToField APublicDhKey where toField = toField . encodePubKey @@ -646,6 +747,10 @@ instance FromField APrivateSignKey where fromField = blobFieldDecoder decodePriv instance FromField APublicVerifyKey where fromField = blobFieldDecoder decodePubKey +instance FromField APrivateAuthKey where fromField = blobFieldDecoder decodePrivKey + +instance FromField APublicAuthKey where fromField = blobFieldDecoder decodePubKey + instance FromField APrivateDhKey where fromField = blobFieldDecoder decodePrivKey instance FromField APublicDhKey where fromField = blobFieldDecoder decodePubKey @@ -656,7 +761,7 @@ instance (Typeable a, AlgorithmI a) => FromField (PublicKey a) where fromField = instance (Typeable a, AlgorithmI a) => FromField (DhSecret a) where fromField = blobFieldDecoder strDecode -instance IsString (Maybe ASignature) where +instance IsString ASignature where fromString = parseString $ decode >=> decodeSignature data Signature (a :: Algorithm) where @@ -1073,10 +1178,14 @@ dh' :: DhAlgorithm a => PublicKey a -> PrivateKey a -> DhSecret a dh' (PublicKeyX25519 k) (PrivateKeyX25519 pk _) = DhSecretX25519 $ X25519.dh k pk dh' (PublicKeyX448 k) (PrivateKeyX448 pk _) = DhSecretX448 $ X448.dh k pk --- | NaCl @crypto_box@ encrypt with a shared DH secret and 192-bit nonce. +-- | NaCl @crypto_box@ encrypt with padding with a shared DH secret and 192-bit nonce. cbEncrypt :: DhSecret X25519 -> CbNonce -> ByteString -> Int -> Either CryptoError ByteString cbEncrypt (DhSecretX25519 secret) = sbEncrypt_ secret +-- | NaCl @crypto_box@ encrypt with a shared DH secret and 192-bit nonce. +cbEncryptNoPad :: DhSecret X25519 -> CbNonce -> ByteString -> ByteString +cbEncryptNoPad (DhSecretX25519 secret) (CbNonce nonce) = cryptoBox secret nonce + -- | NaCl @secret_box@ encrypt with a symmetric 256-bit key and 192-bit nonce. sbEncrypt :: SbKey -> CbNonce -> ByteString -> Int -> Either CryptoError ByteString sbEncrypt (SbKey key) = sbEncrypt_ key diff --git a/src/Simplex/Messaging/Encoding.hs b/src/Simplex/Messaging/Encoding.hs index 6fa2c72c9..9f4c47583 100644 --- a/src/Simplex/Messaging/Encoding.hs +++ b/src/Simplex/Messaging/Encoding.hs @@ -110,7 +110,7 @@ lenP = fromIntegral . c2w <$> A.anyChar {-# INLINE lenP #-} instance Encoding a => Encoding (Maybe a) where - smpEncode = maybe "0" (("1" <>) . smpEncode) + smpEncode = maybe "0" (('1' `B.cons`) . smpEncode) {-# INLINE smpEncode #-} smpP = smpP >>= \case diff --git a/src/Simplex/Messaging/Notifications/Client.hs b/src/Simplex/Messaging/Notifications/Client.hs index dfd84c909..983349537 100644 --- a/src/Simplex/Messaging/Notifications/Client.hs +++ b/src/Simplex/Messaging/Notifications/Client.hs @@ -17,50 +17,50 @@ type NtfClient = ProtocolClient ErrorType NtfResponse type NtfClientError = ProtocolClientError ErrorType -ntfRegisterToken :: NtfClient -> C.APrivateSignKey -> NewNtfEntity 'Token -> ExceptT NtfClientError IO (NtfTokenId, C.PublicKeyX25519) +ntfRegisterToken :: NtfClient -> C.APrivateAuthKey -> NewNtfEntity 'Token -> ExceptT NtfClientError IO (NtfTokenId, C.PublicKeyX25519) ntfRegisterToken c pKey newTkn = sendNtfCommand c (Just pKey) "" (TNEW newTkn) >>= \case NRTknId tknId dhKey -> pure (tknId, dhKey) r -> throwE . PCEUnexpectedResponse $ bshow r -ntfVerifyToken :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> NtfRegCode -> ExceptT NtfClientError IO () +ntfVerifyToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> NtfRegCode -> ExceptT NtfClientError IO () ntfVerifyToken c pKey tknId code = okNtfCommand (TVFY code) c pKey tknId -ntfCheckToken :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> ExceptT NtfClientError IO NtfTknStatus +ntfCheckToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> ExceptT NtfClientError IO NtfTknStatus ntfCheckToken c pKey tknId = sendNtfCommand c (Just pKey) tknId TCHK >>= \case NRTkn stat -> pure stat r -> throwE . PCEUnexpectedResponse $ bshow r -ntfReplaceToken :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> DeviceToken -> ExceptT NtfClientError IO () +ntfReplaceToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> DeviceToken -> ExceptT NtfClientError IO () ntfReplaceToken c pKey tknId token = okNtfCommand (TRPL token) c pKey tknId -ntfDeleteToken :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> ExceptT NtfClientError IO () +ntfDeleteToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> ExceptT NtfClientError IO () ntfDeleteToken = okNtfCommand TDEL -ntfEnableCron :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> Word16 -> ExceptT NtfClientError IO () +ntfEnableCron :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> Word16 -> ExceptT NtfClientError IO () ntfEnableCron c pKey tknId int = okNtfCommand (TCRN int) c pKey tknId -ntfCreateSubscription :: NtfClient -> C.APrivateSignKey -> NewNtfEntity 'Subscription -> ExceptT NtfClientError IO NtfSubscriptionId +ntfCreateSubscription :: NtfClient -> C.APrivateAuthKey -> NewNtfEntity 'Subscription -> ExceptT NtfClientError IO NtfSubscriptionId ntfCreateSubscription c pKey newSub = sendNtfCommand c (Just pKey) "" (SNEW newSub) >>= \case NRSubId subId -> pure subId r -> throwE . PCEUnexpectedResponse $ bshow r -ntfCheckSubscription :: NtfClient -> C.APrivateSignKey -> NtfSubscriptionId -> ExceptT NtfClientError IO NtfSubStatus +ntfCheckSubscription :: NtfClient -> C.APrivateAuthKey -> NtfSubscriptionId -> ExceptT NtfClientError IO NtfSubStatus ntfCheckSubscription c pKey subId = sendNtfCommand c (Just pKey) subId SCHK >>= \case NRSub stat -> pure stat r -> throwE . PCEUnexpectedResponse $ bshow r -ntfDeleteSubscription :: NtfClient -> C.APrivateSignKey -> NtfSubscriptionId -> ExceptT NtfClientError IO () +ntfDeleteSubscription :: NtfClient -> C.APrivateAuthKey -> NtfSubscriptionId -> ExceptT NtfClientError IO () ntfDeleteSubscription = okNtfCommand SDEL -- | Send notification server command -sendNtfCommand :: NtfEntityI e => NtfClient -> Maybe C.APrivateSignKey -> NtfEntityId -> NtfCommand e -> ExceptT NtfClientError IO NtfResponse +sendNtfCommand :: NtfEntityI e => NtfClient -> Maybe C.APrivateAuthKey -> NtfEntityId -> NtfCommand e -> ExceptT NtfClientError IO NtfResponse sendNtfCommand c pKey entId cmd = sendProtocolCommand c pKey entId (NtfCmd sNtfEntity cmd) -okNtfCommand :: NtfEntityI e => NtfCommand e -> NtfClient -> C.APrivateSignKey -> NtfEntityId -> ExceptT NtfClientError IO () +okNtfCommand :: NtfEntityI e => NtfCommand e -> NtfClient -> C.APrivateAuthKey -> NtfEntityId -> ExceptT NtfClientError IO () okNtfCommand cmd c pKey entId = sendNtfCommand c (Just pKey) entId cmd >>= \case NROk -> return () diff --git a/src/Simplex/Messaging/Notifications/Protocol.hs b/src/Simplex/Messaging/Notifications/Protocol.hs index 77b9c10bf..f54997007 100644 --- a/src/Simplex/Messaging/Notifications/Protocol.hs +++ b/src/Simplex/Messaging/Notifications/Protocol.hs @@ -18,7 +18,6 @@ import qualified Data.Attoparsec.ByteString.Char8 as A import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Kind -import Data.Maybe (isNothing) import Data.Text.Encoding (decodeLatin1, encodeUtf8) import Data.Type.Equality import Data.Word (Word16) @@ -124,8 +123,8 @@ instance ToJSON NtfRegCode where toEncoding = strToJEncoding data NewNtfEntity (e :: NtfEntity) where - NewNtfTkn :: DeviceToken -> C.APublicVerifyKey -> C.PublicKeyX25519 -> NewNtfEntity 'Token - NewNtfSub :: NtfTokenId -> SMPQueueNtf -> NtfPrivateSignKey -> NewNtfEntity 'Subscription + NewNtfTkn :: DeviceToken -> NtfPublicAuthKey -> C.PublicKeyX25519 -> NewNtfEntity 'Token + NewNtfSub :: NtfTokenId -> SMPQueueNtf -> NtfPrivateAuthKey -> NewNtfEntity 'Subscription deriving instance Show (NewNtfEntity e) @@ -206,20 +205,20 @@ instance NtfEntityI e => ProtocolEncoding ErrorType (NtfCommand e) where fromProtocolError = fromProtocolError @ErrorType @NtfResponse {-# INLINE fromProtocolError #-} - checkCredentials (sig, _, entityId, _) cmd = case cmd of + checkCredentials (auth, _, entityId, _) cmd = case cmd of -- TNEW and SNEW must have signature but NOT token/subscription IDs TNEW {} -> sigNoEntity SNEW {} -> sigNoEntity PING - | isNothing sig && B.null entityId -> Right cmd + | isAuthNone auth && B.null entityId -> Right cmd | otherwise -> Left $ CMD HAS_AUTH -- other client commands must have both signature and entity ID _ - | isNothing sig || B.null entityId -> Left $ CMD NO_AUTH + | isAuthNone auth || B.null entityId -> Left $ CMD NO_AUTH | otherwise -> Right cmd where sigNoEntity - | isNothing sig = Left $ CMD NO_AUTH + | isAuthNone auth = Left $ CMD NO_AUTH | not (B.null entityId) = Left $ CMD HAS_AUTH | otherwise = Right cmd diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs index 1de707e58..d7f9406df 100644 --- a/src/Simplex/Messaging/Notifications/Server.hs +++ b/src/Simplex/Messaging/Notifications/Server.hs @@ -43,7 +43,7 @@ import Simplex.Messaging.Notifications.Server.Stats import Simplex.Messaging.Notifications.Server.Store import Simplex.Messaging.Notifications.Server.StoreLog import Simplex.Messaging.Notifications.Transport -import Simplex.Messaging.Protocol (ErrorType (..), ProtocolServer (host), SMPServer, SignedTransmission, Transmission, encodeTransmission, tGet, tPut) +import Simplex.Messaging.Protocol (ErrorType (..), ProtocolServer (host), SMPServer, SignedTransmission, Transmission, TransmissionAuth (..), encodeTransmission, tGet, tPut) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Server import Simplex.Messaging.Server.Stats @@ -369,7 +369,7 @@ receive th NtfServerClient {rcvQ, sndQ, rcvActiveAt} = forever $ do send :: Transport c => THandle c -> NtfServerClient -> IO () send h@THandle {thVersion = v} NtfServerClient {sndQ, sessionId, sndActiveAt} = forever $ do t <- atomically $ readTBQueue sndQ - void . liftIO $ tPut h [(Nothing, encodeTransmission v sessionId t)] + void . liftIO $ tPut h [Right (TAuthNone, encodeTransmission v sessionId t)] atomically . writeTVar sndActiveAt =<< liftIO getSystemTime -- instance Show a => Show (TVar a) where @@ -378,13 +378,13 @@ send h@THandle {thVersion = v} NtfServerClient {sndQ, sessionId, sndActiveAt} = data VerificationResult = VRVerified NtfRequest | VRFailed verifyNtfTransmission :: SignedTransmission ErrorType NtfCmd -> NtfCmd -> M VerificationResult -verifyNtfTransmission (sig_, signed, (corrId, entId, _)) cmd = do +verifyNtfTransmission (tAuth, authorized, (corrId, entId, _)) cmd = do st <- asks store case cmd of NtfCmd SToken c@(TNEW tkn@(NewNtfTkn _ k _)) -> do r_ <- atomically $ getNtfTokenRegistration st tkn pure $ - if verifyCmdSignature sig_ signed k + if verifyCmdSignature tAuth authorized k then case r_ of Just t@NtfTknData {tknVerifyKey} | k == tknVerifyKey -> verifiedTknCmd t c @@ -405,7 +405,7 @@ verifyNtfTransmission (sig_, signed, (corrId, entId, _)) cmd = do then do t_ <- atomically $ getActiveNtfToken st subTknId verifyToken' t_ $ verifiedSubCmd s c - else pure $ maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed + else pure $ dummyVerifyCmd authorized tAuth `seq` VRFailed NtfCmd SSubscription PING -> pure $ VRVerified $ NtfReqPing corrId entId NtfCmd SSubscription c -> do s_ <- atomically $ getNtfSubscription st entId @@ -413,7 +413,7 @@ verifyNtfTransmission (sig_, signed, (corrId, entId, _)) cmd = do Just s@NtfSubData {tokenId = subTknId} -> do t_ <- atomically $ getActiveNtfToken st subTknId verifyToken' t_ $ verifiedSubCmd s c - _ -> pure $ maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed + _ -> pure $ dummyVerifyCmd authorized tAuth `seq` VRFailed where verifiedTknCmd t c = VRVerified (NtfReqCmd SToken (NtfTkn t) (corrId, entId, c)) verifiedSubCmd s c = VRVerified (NtfReqCmd SSubscription (NtfSub s) (corrId, entId, c)) @@ -421,10 +421,10 @@ verifyNtfTransmission (sig_, signed, (corrId, entId, _)) cmd = do verifyToken t_ positiveVerificationResult = pure $ case t_ of Just t@NtfTknData {tknVerifyKey} -> - if verifyCmdSignature sig_ signed tknVerifyKey + if verifyCmdSignature tAuth authorized tknVerifyKey then positiveVerificationResult t else VRFailed - _ -> maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed + _ -> dummyVerifyCmd authorized tAuth `seq` VRFailed verifyToken' :: Maybe NtfTknData -> VerificationResult -> M VerificationResult verifyToken' t_ = verifyToken t_ . const diff --git a/src/Simplex/Messaging/Notifications/Server/Env.hs b/src/Simplex/Messaging/Notifications/Server/Env.hs index e1b4f51c5..02529f13c 100644 --- a/src/Simplex/Messaging/Notifications/Server/Env.hs +++ b/src/Simplex/Messaging/Notifications/Server/Env.hs @@ -89,7 +89,7 @@ newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsCo logInfo "restoring subscriptions..." storeLog <- liftIO $ mapM (`readWriteNtfStore` store) storeLogFile logInfo "restored subscriptions" - subscriber <- atomically $ newNtfSubscriber subQSize smpAgentCfg + subscriber <- atomically $ newNtfSubscriber subQSize smpAgentCfg random pushServer <- atomically $ newNtfPushServer pushQSize apnsConfig tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile Fingerprint fp <- liftIO $ loadFingerprint caCertificateFile @@ -102,11 +102,11 @@ data NtfSubscriber = NtfSubscriber smpAgent :: SMPClientAgent } -newNtfSubscriber :: Natural -> SMPClientAgentConfig -> STM NtfSubscriber -newNtfSubscriber qSize smpAgentCfg = do +newNtfSubscriber :: Natural -> SMPClientAgentConfig -> TVar ChaChaDRG -> STM NtfSubscriber +newNtfSubscriber qSize smpAgentCfg random = do smpSubscribers <- TM.empty newSubQ <- newTBQueue qSize - smpAgent <- newSMPClientAgent smpAgentCfg + smpAgent <- newSMPClientAgent smpAgentCfg random pure NtfSubscriber {smpSubscribers, newSubQ, smpAgent} data SMPSubscriber = SMPSubscriber diff --git a/src/Simplex/Messaging/Notifications/Server/Store.hs b/src/Simplex/Messaging/Notifications/Server/Store.hs index b7750ae2c..83dc1a4c2 100644 --- a/src/Simplex/Messaging/Notifications/Server/Store.hs +++ b/src/Simplex/Messaging/Notifications/Server/Store.hs @@ -19,7 +19,7 @@ import qualified Data.Set as S import Data.Word (Word16) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Notifications.Protocol -import Simplex.Messaging.Protocol (NtfPrivateSignKey, SMPServer) +import Simplex.Messaging.Protocol (NtfPrivateAuthKey, NtfPublicAuthKey, SMPServer) import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Util (whenM, ($>>=)) @@ -46,7 +46,7 @@ data NtfTknData = NtfTknData { ntfTknId :: NtfTokenId, token :: DeviceToken, tknStatus :: TVar NtfTknStatus, - tknVerifyKey :: C.APublicVerifyKey, + tknVerifyKey :: NtfPublicAuthKey, tknDhKeys :: C.KeyPair 'C.X25519, tknDhSecret :: C.DhSecretX25519, tknRegCode :: NtfRegCode, @@ -62,7 +62,7 @@ mkNtfTknData ntfTknId (NewNtfTkn token tknVerifyKey _) tknDhKeys tknDhSecret tkn data NtfSubData = NtfSubData { ntfSubId :: NtfSubscriptionId, smpQueue :: SMPQueueNtf, - notifierKey :: NtfPrivateSignKey, + notifierKey :: NtfPrivateAuthKey, tokenId :: NtfTokenId, subStatus :: TVar NtfSubStatus } diff --git a/src/Simplex/Messaging/Notifications/Server/StoreLog.hs b/src/Simplex/Messaging/Notifications/Server/StoreLog.hs index 3ed28eb52..cc2a1802e 100644 --- a/src/Simplex/Messaging/Notifications/Server/StoreLog.hs +++ b/src/Simplex/Messaging/Notifications/Server/StoreLog.hs @@ -32,7 +32,7 @@ import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String import Simplex.Messaging.Notifications.Protocol import Simplex.Messaging.Notifications.Server.Store -import Simplex.Messaging.Protocol (NtfPrivateSignKey) +import Simplex.Messaging.Protocol (NtfPrivateAuthKey) import Simplex.Messaging.Server.StoreLog import Simplex.Messaging.Util (whenM) import System.Directory (doesFileExist, renameFile) @@ -52,7 +52,7 @@ data NtfTknRec = NtfTknRec { ntfTknId :: NtfTokenId, token :: DeviceToken, tknStatus :: NtfTknStatus, - tknVerifyKey :: C.APublicVerifyKey, + tknVerifyKey :: C.APublicAuthKey, tknDhKeys :: C.KeyPair 'C.X25519, tknDhSecret :: C.DhSecretX25519, tknRegCode :: NtfRegCode, @@ -74,7 +74,7 @@ mkTknRec NtfTknData {ntfTknId, token, tknStatus = status, tknVerifyKey, tknDhKey data NtfSubRec = NtfSubRec { ntfSubId :: NtfSubscriptionId, smpQueue :: SMPQueueNtf, - notifierKey :: NtfPrivateSignKey, + notifierKey :: NtfPrivateAuthKey, tokenId :: NtfTokenId, subStatus :: NtfSubStatus } diff --git a/src/Simplex/Messaging/Notifications/Transport.hs b/src/Simplex/Messaging/Notifications/Transport.hs index 54bd354bb..6818565d4 100644 --- a/src/Simplex/Messaging/Notifications/Transport.hs +++ b/src/Simplex/Messaging/Notifications/Transport.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} @@ -56,8 +57,8 @@ ntfServerHandshake c kh ntfVRange = do | otherwise -> throwError $ TEHandshake VERSION -- | Notifcations server client transport handshake. -ntfClientHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c) -ntfClientHandshake c keyHash ntfVRange = do +ntfClientHandshake :: forall c. Transport c => c -> C.KeyPairX25519 -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c) +ntfClientHandshake c _ keyHash ntfVRange = do let th@THandle {sessionId} = ntfTHandle c NtfServerHandshake {sessionId = sessId, ntfVersionRange} <- getHandshake th if sessionId /= sessId @@ -69,4 +70,4 @@ ntfClientHandshake c keyHash ntfVRange = do Nothing -> throwError $ TEHandshake VERSION ntfTHandle :: Transport c => c -> THandle c -ntfTHandle c = THandle {connection = c, sessionId = tlsUnique c, blockSize = ntfBlockSize, thVersion = 0, batch = False} +ntfTHandle c = THandle {connection = c, sessionId = tlsUnique c, blockSize = ntfBlockSize, thVersion = 0, thAuth = Nothing, batch = False} diff --git a/src/Simplex/Messaging/Notifications/Types.hs b/src/Simplex/Messaging/Notifications/Types.hs index 34a0079bb..4465f8767 100644 --- a/src/Simplex/Messaging/Notifications/Types.hs +++ b/src/Simplex/Messaging/Notifications/Types.hs @@ -47,10 +47,11 @@ data NtfToken = NtfToken { deviceToken :: DeviceToken, ntfServer :: NtfServer, ntfTokenId :: Maybe NtfTokenId, + -- TODO combine keys to key pair as the types should match -- | key used by the ntf server to verify transmissions - ntfPubKey :: C.APublicVerifyKey, + ntfPubKey :: C.APublicAuthKey, -- | key used by the ntf client to sign transmissions - ntfPrivKey :: C.APrivateSignKey, + ntfPrivKey :: C.APrivateAuthKey, -- | client's DH keys (to repeat registration if necessary) ntfDhKeys :: C.KeyPair 'C.X25519, -- | shared DH secret used to encrypt/decrypt notifications e2e @@ -63,7 +64,7 @@ data NtfToken = NtfToken } deriving (Show) -newNtfToken :: DeviceToken -> NtfServer -> C.ASignatureKeyPair -> C.KeyPair 'C.X25519 -> NotificationsMode -> NtfToken +newNtfToken :: DeviceToken -> NtfServer -> C.AAuthKeyPair -> C.KeyPair 'C.X25519 -> NotificationsMode -> NtfToken newNtfToken deviceToken ntfServer (ntfPubKey, ntfPrivKey) ntfDhKeys ntfMode = NtfToken { deviceToken, diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index f2571a9d4..52716c6a3 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -59,6 +59,7 @@ module Simplex.Messaging.Protocol ErrorType (..), CommandError (..), Transmission, + TransmissionAuth (..), SignedTransmission, SentRawTransmission, SignedRawTransmission, @@ -92,14 +93,14 @@ module Simplex.Messaging.Protocol RecipientId, SenderId, NotifierId, - RcvPrivateSignKey, - RcvPublicVerifyKey, + RcvPrivateAuthKey, + RcvPublicAuthKey, RcvPublicDhKey, RcvDhSecret, - SndPrivateSignKey, - SndPublicVerifyKey, - NtfPrivateSignKey, - NtfPublicVerifyKey, + SndPrivateAuthKey, + SndPublicAuthKey, + NtfPrivateAuthKey, + NtfPublicAuthKey, RcvNtfPublicDhKey, RcvNtfDhSecret, Message (..), @@ -120,6 +121,7 @@ module Simplex.Messaging.Protocol noMsgFlags, messageId, messageTs, + isAuthNone, -- * Parse and serialize ProtocolMsgTag (..), @@ -155,11 +157,13 @@ module Simplex.Messaging.Protocol where import Control.Applicative (optional, (<|>)) +import Control.Monad import Control.Monad.Except import Data.Aeson (FromJSON (..), ToJSON (..)) import qualified Data.Aeson.TH as J import Data.Attoparsec.ByteString.Char8 (Parser, ()) import qualified Data.Attoparsec.ByteString.Char8 as A +import qualified Data.ByteString.Base64 as B64 import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Char (isPrint, isSpace) @@ -168,7 +172,7 @@ import Data.Functor (($>)) import Data.Kind import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as L -import Data.Maybe (isJust, isNothing) +import Data.Maybe (isJust) import Data.String import Data.Time.Clock.System (SystemTime (..)) import Data.Type.Equality @@ -239,14 +243,14 @@ deriving instance Show Cmd type Transmission c = (CorrId, EntityId, c) -- | signed parsed transmission, with original raw bytes and parsing error. -type SignedTransmission e c = (Maybe C.ASignature, Signed, Transmission (Either e c)) +type SignedTransmission e c = (TransmissionAuth, Signed, Transmission (Either e c)) type Signed = ByteString -- | unparsed SMP transmission with signature. data RawTransmission = RawTransmission - { signature :: ByteString, - signed :: ByteString, + { authorization :: ByteString, -- signature or encrypted transmission hash + authorized :: ByteString, -- authorized transmission sessId :: SessionId, corrId :: ByteString, entityId :: ByteString, @@ -254,11 +258,38 @@ data RawTransmission = RawTransmission } deriving (Show) +data TransmissionAuth + = TAuthNone + | TAuthSignature C.ASignature + | TAuthEncHash ByteString + deriving (Eq, Show) + +isAuthNone :: TransmissionAuth -> Bool +isAuthNone = \case + TAuthNone -> True + _ -> False + +-- this encoding is backwards compatible with v6 that used Maybe C.ASignature instead of TAuthorization +instance Encoding TransmissionAuth where + smpEncode = \case + TAuthNone -> "0" -- same as Nothing + TAuthSignature s -> smpEncode ('1', C.signatureBytes s) -- same as Just + TAuthEncHash s -> smpEncode ('2', s) + smpP = + A.anyChar >>= \case + '0' -> pure TAuthNone + '1' -> fmap TAuthSignature . C.decodeSignature <$?> smpP + '2' -> TAuthEncHash <$> smpP + _ -> fail "bad TransmissionAuth tag" + +instance IsString TransmissionAuth where + fromString = parseString $ B64.decode >=> C.decodeSignature >=> pure . maybe TAuthNone TAuthSignature + -- | unparsed sent SMP transmission with signature, without session ID. -type SignedRawTransmission = (Maybe C.ASignature, SessionId, ByteString, ByteString) +type SignedRawTransmission = (TransmissionAuth, SessionId, ByteString, ByteString) -- | unparsed sent SMP transmission with signature. -type SentRawTransmission = (Maybe C.ASignature, ByteString) +type SentRawTransmission = (TransmissionAuth, ByteString) -- | SMP queue ID for the recipient. type RecipientId = QueueId @@ -277,10 +308,14 @@ type EntityId = ByteString -- | Parameterized type for SMP protocol commands from all clients. data Command (p :: Party) where -- SMP recipient commands - NEW :: RcvPublicVerifyKey -> RcvPublicDhKey -> Maybe BasicAuth -> SubscriptionMode -> Command Recipient + -- RcvPublicAuthKey is the key used for command authorization: + -- v6 of SMP servers only support signature algorithm for command authorization. + -- v7 of SMP servers additionally support additional layer of authenticated encryption. + -- RcvPublicAuthKey is defined as C.APublicKey - it can be either signature or DH public keys. + NEW :: RcvPublicAuthKey -> RcvPublicDhKey -> Maybe BasicAuth -> SubscriptionMode -> Command Recipient SUB :: Command Recipient - KEY :: SndPublicVerifyKey -> Command Recipient - NKEY :: NtfPublicVerifyKey -> RcvNtfPublicDhKey -> Command Recipient + KEY :: SndPublicAuthKey -> Command Recipient + NKEY :: NtfPublicAuthKey -> RcvNtfPublicDhKey -> Command Recipient NDEL :: Command Recipient GET :: Command Recipient -- ACK v1 has to be supported for encoding/decoding @@ -640,7 +675,7 @@ instance Encoding ClientMsgEnvelope where data ClientMessage = ClientMessage PrivHeader ByteString data PrivHeader - = PHConfirmation C.APublicVerifyKey + = PHConfirmation C.APublicAuthKey | PHEmpty deriving (Show) @@ -951,13 +986,13 @@ data QueueIdsKeys = QIK } deriving (Eq, Show) --- | Recipient's private key used by the recipient to authorize (sign) SMP commands. +-- | Recipient's private key used by the recipient to authorize (v6: sign, v7: encrypt hash) SMP commands. -- -- Only used by SMP agent, kept here so its definition is close to respective public key. -type RcvPrivateSignKey = C.APrivateSignKey +type RcvPrivateAuthKey = C.APrivateAuthKey -- | Recipient's public key used by SMP server to verify authorization of SMP commands. -type RcvPublicVerifyKey = C.APublicVerifyKey +type RcvPublicAuthKey = C.APublicAuthKey -- | Public key used for DH exchange to encrypt message bodies from server to recipient type RcvPublicDhKey = C.PublicKeyX25519 @@ -965,19 +1000,19 @@ type RcvPublicDhKey = C.PublicKeyX25519 -- | DH Secret used to encrypt message bodies from server to recipient type RcvDhSecret = C.DhSecretX25519 --- | Sender's private key used by the recipient to authorize (sign) SMP commands. +-- | Sender's private key used by the recipient to authorize (v6: sign, v7: encrypt hash) SMP commands. -- -- Only used by SMP agent, kept here so its definition is close to respective public key. -type SndPrivateSignKey = C.APrivateSignKey +type SndPrivateAuthKey = C.APrivateAuthKey -- | Sender's public key used by SMP server to verify authorization of SMP commands. -type SndPublicVerifyKey = C.APublicVerifyKey +type SndPublicAuthKey = C.APublicAuthKey --- | Private key used by push notifications server to authorize (sign) NSUB command. -type NtfPrivateSignKey = C.APrivateSignKey +-- | Private key used by push notifications server to authorize (sign or encrypt hash) NSUB command. +type NtfPrivateAuthKey = C.APrivateAuthKey -- | Public key used by SMP server to verify authorization of NSUB command sent by push notifications server. -type NtfPublicVerifyKey = C.APublicVerifyKey +type NtfPublicAuthKey = C.APublicAuthKey -- | Public key used for DH exchange to encrypt notification metadata from server to recipient type RcvNtfPublicDhKey = C.PublicKeyX25519 @@ -1040,21 +1075,21 @@ data CommandError -- | SMP transmission parser. transmissionP :: Parser RawTransmission transmissionP = do - signature <- smpP - signed <- A.takeByteString - either fail pure $ parseAll (trn signature signed) signed + authorization <- smpP + authorized <- A.takeByteString + either fail pure $ parseAll (trn authorization authorized) authorized where - trn signature signed = do + trn authorization authorized = do sessId <- smpP corrId <- smpP entityId <- smpP command <- A.takeByteString - pure RawTransmission {signature, signed, sessId, corrId, entityId, command} + pure RawTransmission {authorization, authorized, sessId, corrId, entityId, command} class (ProtocolEncoding err msg, ProtocolEncoding err (ProtoCommand msg), Show err, Show msg) => Protocol err msg | msg -> err where type ProtoCommand msg = cmd | cmd -> msg type ProtoType msg = (sch :: ProtocolType) | sch -> msg - protocolClientHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c) + protocolClientHandshake :: forall c. Transport c => c -> C.KeyPairX25519 -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c) protocolPing :: ProtoCommand msg protocolError :: msg -> Maybe err @@ -1080,8 +1115,8 @@ instance PartyI p => ProtocolEncoding ErrorType (Command p) where type Tag (Command p) = CommandTag p encodeProtocol v = \case NEW rKey dhKey auth_ subMode - | v >= 6 -> new <> auth <> e subMode - | v == 5 -> new <> auth + | v >= subModeSMPVersion -> new <> auth <> e subMode + | v == basicAuthSMPVersion -> new <> auth | otherwise -> new where new = e (NEW_, ' ', rKey, dhKey) @@ -1110,10 +1145,10 @@ instance PartyI p => ProtocolEncoding ErrorType (Command p) where fromProtocolError = fromProtocolError @ErrorType @BrokerMsg {-# INLINE fromProtocolError #-} - checkCredentials (sig, _, queueId, _) cmd = case cmd of + checkCredentials (auth, _, queueId, _) cmd = case cmd of -- NEW must have signature but NOT queue ID NEW {} - | isNothing sig -> Left $ CMD NO_AUTH + | isAuthNone auth -> Left $ CMD NO_AUTH | not (B.null queueId) -> Left $ CMD HAS_AUTH | otherwise -> Right cmd -- SEND must have queue ID, signature is not always required @@ -1122,11 +1157,11 @@ instance PartyI p => ProtocolEncoding ErrorType (Command p) where | otherwise -> Right cmd -- PING must not have queue ID or signature PING - | isNothing sig && B.null queueId -> Right cmd + | isAuthNone auth && B.null queueId -> Right cmd | otherwise -> Left $ CMD HAS_AUTH -- other client commands must have both signature and queue ID _ - | isNothing sig || B.null queueId -> Left $ CMD NO_AUTH + | isAuthNone auth || B.null queueId -> Left $ CMD NO_AUTH | otherwise -> Right cmd instance ProtocolEncoding ErrorType Cmd where @@ -1137,8 +1172,8 @@ instance ProtocolEncoding ErrorType Cmd where CT SRecipient tag -> Cmd SRecipient <$> case tag of NEW_ - | v >= 6 -> new <*> auth <*> smpP - | v == 5 -> new <*> auth <*> pure SMSubscribe + | v >= subModeSMPVersion -> new <*> auth <*> smpP + | v == basicAuthSMPVersion -> new <*> auth <*> pure SMSubscribe | otherwise -> new <*> pure Nothing <*> pure SMSubscribe where new = NEW <$> _smpP <*> smpP @@ -1283,13 +1318,13 @@ instance Encoding CommandError where _ -> fail "bad command error type" -- | Send signed SMP transmission to TCP transport. -tPut :: Transport c => THandle c -> NonEmpty SentRawTransmission -> IO [Either TransportError ()] +tPut :: Transport c => THandle c -> NonEmpty (Either TransportError SentRawTransmission) -> IO [Either TransportError ()] tPut th = fmap concat . mapM tPutBatch . batchTransmissions (batch th) (blockSize th) where tPutBatch :: TransportBatch () -> IO [Either TransportError ()] tPutBatch = \case - TBLargeTransmission _ -> [Left TELargeMsg] <$ putStrLn "tPut error: large message" - TBTransmissions s n _ -> replicate n <$> (tPutLog th s) + TBError e _ -> [Left e] <$ putStrLn "tPut error: large message" + TBTransmissions s n _ -> replicate n <$> tPutLog th s TBTransmission s _ -> (: []) <$> tPutLog th s tPutLog :: Transport c => THandle c -> ByteString -> IO (Either TransportError ()) @@ -1301,42 +1336,46 @@ tPutLog th s = do pure r -- ByteString in TBTransmissions includes byte with transmissions count -data TransportBatch r = TBTransmissions ByteString Int [r] | TBTransmission ByteString r | TBLargeTransmission r +data TransportBatch r = TBTransmissions ByteString Int [r] | TBTransmission ByteString r | TBError TransportError r -batchTransmissions :: Bool -> Int -> NonEmpty SentRawTransmission -> [TransportBatch ()] +batchTransmissions :: Bool -> Int -> NonEmpty (Either TransportError SentRawTransmission) -> [TransportBatch ()] batchTransmissions batch bSize = batchTransmissions' batch bSize . L.map (,()) -- | encodes and batches transmissions into blocks, -batchTransmissions' :: forall r. Bool -> Int -> NonEmpty (SentRawTransmission, r) -> [TransportBatch r] +batchTransmissions' :: forall r. Bool -> Int -> NonEmpty (Either TransportError SentRawTransmission, r) -> [TransportBatch r] batchTransmissions' batch bSize | batch = addBatch . foldr addTransmission ([], 0, 0, [], []) | otherwise = map mkBatch1 . L.toList where - mkBatch1 :: (SentRawTransmission, r) -> TransportBatch r - mkBatch1 (t, r) - -- 2 bytes are reserved for pad size - | B.length s <= bSize - 2 = TBTransmission s r - | otherwise = TBLargeTransmission r - where - s = tEncode t + mkBatch1 :: (Either TransportError SentRawTransmission, r) -> TransportBatch r + mkBatch1 (t_, r) = case t_ of + Left e -> TBError e r + Right t + -- 2 bytes are reserved for pad size + | B.length s <= bSize - 2 -> TBTransmission s r + | otherwise -> TBError TELargeMsg r + where + s = tEncode t -- 3 = 2 bytes reserved for pad size + 1 for transmission count bSize' = bSize - 3 - addTransmission :: (SentRawTransmission, r) -> ([TransportBatch r], Int, Int, [ByteString], [r]) -> ([TransportBatch r], Int, Int, [ByteString], [r]) - addTransmission (t, r) acc@(bs, len, n, ss, rs) - | len' <= bSize' && n < 255 = (bs, len', 1 + n, s : ss, r : rs) - | sLen <= bSize' = (addBatch acc, sLen, 1, [s], [r]) - | otherwise = (TBLargeTransmission r : addBatch acc, 0, 0, [], []) - where - s = tEncodeForBatch t - sLen = B.length s - len' = len + sLen + addTransmission :: (Either TransportError SentRawTransmission, r) -> ([TransportBatch r], Int, Int, [ByteString], [r]) -> ([TransportBatch r], Int, Int, [ByteString], [r]) + addTransmission (t_, r) acc@(bs, len, n, ss, rs) = case t_ of + Left e -> (TBError e r : addBatch acc, 0, 0, [], []) + Right t + | len' <= bSize' && n < 255 -> (bs, len', 1 + n, s : ss, r : rs) + | sLen <= bSize' -> (addBatch acc, sLen, 1, [s], [r]) + | otherwise -> (TBError TELargeMsg r : addBatch acc, 0, 0, [], []) + where + s = tEncodeForBatch t + sLen = B.length s + len' = len + sLen addBatch :: ([TransportBatch r], Int, Int, [ByteString], [r]) -> [TransportBatch r] addBatch (bs, _len, n, ss, rs) = if n == 0 then bs else TBTransmissions b n rs : bs where b = B.concat $ B.singleton (lenEncode n) : ss tEncode :: SentRawTransmission -> ByteString -tEncode (sig, t) = smpEncode (C.signatureBytes sig) <> t +tEncode (auth, t) = smpEncode auth <> t {-# INLINE tEncode #-} tEncodeForBatch :: SentRawTransmission -> ByteString @@ -1374,15 +1413,15 @@ tGet th@THandle {sessionId, thVersion = v} = L.map (tDecodeParseValidate session tDecodeParseValidate :: forall err cmd. ProtocolEncoding err cmd => SessionId -> Version -> Either TransportError RawTransmission -> SignedTransmission err cmd tDecodeParseValidate sessionId v = \case - Right RawTransmission {signature, signed, sessId, corrId, entityId, command} + Right RawTransmission {authorization, authorized, sessId, corrId, entityId, command} | sessId == sessionId -> - let decodedTransmission = (,corrId,entityId,command) <$> C.decodeSignature signature - in either (const $ tError corrId) (tParseValidate signed) decodedTransmission - | otherwise -> (Nothing, "", (CorrId corrId, "", Left $ fromProtocolError @err @cmd PESession)) + let decodedTransmission = (,corrId,entityId,command) <$> smpDecode authorization + in either (const $ tError corrId) (tParseValidate authorized) decodedTransmission + | otherwise -> (TAuthNone, "", (CorrId corrId, "", Left $ fromProtocolError @err @cmd PESession)) Left _ -> tError "" where tError :: ByteString -> SignedTransmission err cmd - tError corrId = (Nothing, "", (CorrId corrId, "", Left $ fromProtocolError @err @cmd PEBlock)) + tError corrId = (TAuthNone, "", (CorrId corrId, "", Left $ fromProtocolError @err @cmd PEBlock)) tParseValidate :: ByteString -> SignedRawTransmission -> SignedTransmission err cmd tParseValidate signed t@(sig, corrId, entityId, command) = diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 1bf7de2eb..7b766cf5d 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -13,6 +13,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} -- | -- Module : Simplex.Messaging.Server @@ -247,8 +248,10 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do runClient tp h = do kh <- asks serverIdentity ServerConfig {smpServerVRange, smpHandshakeTimeout} <- asks config + g <- asks random + ks <- atomically $ C.generateKeyPair g labelMyThread $ "smp handshake for " <> transportName tp - liftIO (timeout smpHandshakeTimeout . runExceptT $ smpServerHandshake h kh smpServerVRange) >>= \case + liftIO (timeout smpHandshakeTimeout . runExceptT $ smpServerHandshake h ks kh smpServerVRange) >>= \case Just (Right th) -> runClientTransport th _ -> pure () @@ -424,10 +427,10 @@ receive th Client {rcvQ, sndQ, rcvActiveAt, sessionId} = do write rcvQ $ snd as where cmdAction :: SignedTransmission ErrorType Cmd -> M (Either (Transmission BrokerMsg) (Maybe QueueRec, Transmission Cmd)) - cmdAction (sig, signed, (corrId, queueId, cmdOrError)) = + cmdAction (auth, authorized, (corrId, queueId, cmdOrError)) = case cmdOrError of Left e -> pure $ Left (corrId, queueId, ERR e) - Right cmd -> verified <$> verifyTransmission sig signed queueId cmd + Right cmd -> verified <$> verifyTransmission auth authorized queueId cmd where verified = \case VRVerified qr -> Right (qr, (corrId, queueId, cmd)) @@ -439,7 +442,8 @@ send h@THandle {thVersion = v} Client {sndQ, sessionId, sndActiveAt} = do labelMyThread . B.unpack $ "client $" <> encode sessionId <> " send" forever $ do ts <- atomically $ L.sortWith tOrder <$> readTBQueue sndQ - void . liftIO . tPut h $ L.map ((Nothing,) . encodeTransmission v sessionId) ts + -- TODO we can authorize responses as well + void . liftIO . tPut h $ L.map (\t -> Right (TAuthNone, encodeTransmission v sessionId t)) ts atomically . writeTVar sndActiveAt =<< liftIO getSystemTime where tOrder :: Transmission BrokerMsg -> Int @@ -463,11 +467,11 @@ disconnectTransport THandle {connection, sessionId} rcvActiveAt sndActiveAt expC data VerificationResult = VRVerified (Maybe QueueRec) | VRFailed -verifyTransmission :: Maybe C.ASignature -> ByteString -> QueueId -> Cmd -> M VerificationResult -verifyTransmission sig_ signed queueId cmd = +verifyTransmission :: TransmissionAuth -> ByteString -> QueueId -> Cmd -> M VerificationResult +verifyTransmission auth authorized queueId cmd = case cmd of - Cmd SRecipient (NEW k _ _ _) -> pure $ Nothing `verified` verifyCmdSignature sig_ signed k - Cmd SRecipient _ -> verifyCmd SRecipient $ verifyCmdSignature sig_ signed . recipientKey + Cmd SRecipient (NEW k _ _ _) -> pure $ Nothing `verified` verifyCmdSignature auth authorized k + Cmd SRecipient _ -> verifyCmd SRecipient $ verifyCmdSignature auth authorized . recipientKey Cmd SSender SEND {} -> verifyCmd SSender $ verifyMaybe . senderKey Cmd SSender PING -> pure $ VRVerified Nothing Cmd SNotifier NSUB -> verifyCmd SNotifier $ verifyMaybe . fmap notifierKey . notifier @@ -478,29 +482,37 @@ verifyTransmission sig_ signed queueId cmd = q_ <- atomically $ getQueue st party queueId pure $ case q_ of Right q -> Just q `verified` f q - _ -> maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed - verifyMaybe :: Maybe C.APublicVerifyKey -> Bool - verifyMaybe = maybe (isNothing sig_) $ verifyCmdSignature sig_ signed + _ -> dummyVerifyCmd authorized auth `seq` VRFailed + verifyMaybe :: Maybe C.APublicAuthKey -> Bool + verifyMaybe = maybe (isAuthNone auth) $ verifyCmdSignature auth authorized verified q cond = if cond then VRVerified q else VRFailed -verifyCmdSignature :: Maybe C.ASignature -> ByteString -> C.APublicVerifyKey -> Bool -verifyCmdSignature sig_ signed key = maybe False (verify key) sig_ +verifyCmdSignature :: TransmissionAuth -> ByteString -> C.APublicAuthKey -> Bool +verifyCmdSignature auth authorized key = case auth of + TAuthNone -> False + TAuthSignature sig -> verify key sig + TAuthEncHash _ -> False where - verify :: C.APublicVerifyKey -> C.ASignature -> Bool - verify (C.APublicVerifyKey a k) sig@(C.ASignature a' s) = - case (testEquality a a', C.signatureSize k == C.signatureSize s) of - (Just Refl, True) -> C.verify' k s signed - _ -> dummyVerifyCmd signed sig `seq` False + verify :: C.APublicAuthKey -> C.ASignature -> Bool + verify (C.APublicAuthKey a k) sig@(C.ASignature a' s) = + case testEquality a a' of + Just Refl | C.signatureSize k == C.signatureSize s -> C.verify' k s authorized + _ -> dummyVerifyCmd authorized (TAuthSignature sig) `seq` False -dummyVerifyCmd :: ByteString -> C.ASignature -> Bool -dummyVerifyCmd signed (C.ASignature _ s) = C.verify' (dummyPublicKey s) s signed +dummyVerifyCmd :: ByteString -> TransmissionAuth -> Bool +dummyVerifyCmd authorized = \case + TAuthNone -> False + TAuthSignature (C.ASignature a s) -> C.verify' (dummyPublicKey a) s authorized + TAuthEncHash _ -> False -- These dummy keys are used with `dummyVerify` function to mitigate timing attacks -- by having the same time of the response whether a queue exists or nor, for all valid key/signature sizes -dummyPublicKey :: C.Signature a -> C.PublicKey a +dummyPublicKey :: C.SAlgorithm a -> C.PublicKey a dummyPublicKey = \case - C.SignatureEd25519 _ -> dummyKeyEd25519 - C.SignatureEd448 _ -> dummyKeyEd448 + C.SEd25519 -> dummyKeyEd25519 + C.SEd448 -> dummyKeyEd448 + C.SX25519 -> dummyKeyX25519 + C.SX448 -> dummyKeyX448 dummyKeyEd25519 :: C.PublicKey 'C.Ed25519 dummyKeyEd25519 = "MCowBQYDK2VwAyEA139Oqs4QgpqbAmB0o7rZf6T19ryl7E65k4AYe0kE3Qs=" @@ -508,6 +520,12 @@ dummyKeyEd25519 = "MCowBQYDK2VwAyEA139Oqs4QgpqbAmB0o7rZf6T19ryl7E65k4AYe0kE3Qs=" dummyKeyEd448 :: C.PublicKey 'C.Ed448 dummyKeyEd448 = "MEMwBQYDK2VxAzoA6ibQc9XpkSLtwrf7PLvp81qW/etiumckVFImCMRdftcG/XopbOSaq9qyLhrgJWKOLyNrQPNVvpMA" +dummyKeyX25519 :: C.PublicKey 'C.X25519 +dummyKeyX25519 = "" + +dummyKeyX448 :: C.PublicKey 'C.X448 +dummyKeyX448 = "" + client :: forall m. (MonadUnliftIO m, MonadReader Env m) => Client -> Server -> m () client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ, sessionId} Server {subscribedQ, ntfSubscribedQ, notifiers} = do labelMyThread . B.unpack $ "client $" <> encode sessionId <> " commands" @@ -545,7 +563,7 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ, sess OFF -> suspendQueue_ st DEL -> delQueueAndMsgs st where - createQueue :: QueueStore -> RcvPublicVerifyKey -> RcvPublicDhKey -> SubscriptionMode -> m (Transmission BrokerMsg) + createQueue :: QueueStore -> RcvPublicAuthKey -> RcvPublicDhKey -> SubscriptionMode -> m (Transmission BrokerMsg) createQueue st recipientKey dhKey subMode = time "NEW" $ do (rcvPublicDhKey, privDhKey) <- atomically . C.generateKeyPair =<< asks random let rcvDhSecret = C.dh' dhKey privDhKey @@ -593,14 +611,14 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ, sess n <- asks $ queueIdBytes . config liftM2 (,) (randomId n) (randomId n) - secureQueue_ :: QueueStore -> SndPublicVerifyKey -> m (Transmission BrokerMsg) + secureQueue_ :: QueueStore -> SndPublicAuthKey -> m (Transmission BrokerMsg) secureQueue_ st sKey = time "KEY" $ do withLog $ \s -> logSecureQueue s queueId sKey stats <- asks serverStats atomically $ modifyTVar' (qSecured stats) (+ 1) atomically $ (corrId,queueId,) . either ERR (const OK) <$> secureQueue st queueId sKey - addQueueNotifier_ :: QueueStore -> NtfPublicVerifyKey -> RcvNtfPublicDhKey -> m (Transmission BrokerMsg) + addQueueNotifier_ :: QueueStore -> NtfPublicAuthKey -> RcvNtfPublicDhKey -> m (Transmission BrokerMsg) addQueueNotifier_ st notifierKey dhKey = time "NKEY" $ do (rcvPublicDhKey, privDhKey) <- atomically . C.generateKeyPair =<< asks random let rcvNtfDhSecret = C.dh' dhKey privDhKey diff --git a/src/Simplex/Messaging/Server/QueueStore.hs b/src/Simplex/Messaging/Server/QueueStore.hs index 8a7856eb6..56ce9b679 100644 --- a/src/Simplex/Messaging/Server/QueueStore.hs +++ b/src/Simplex/Messaging/Server/QueueStore.hs @@ -10,10 +10,10 @@ import Simplex.Messaging.Protocol data QueueRec = QueueRec { recipientId :: !RecipientId, - recipientKey :: !RcvPublicVerifyKey, + recipientKey :: !RcvPublicAuthKey, rcvDhSecret :: !RcvDhSecret, senderId :: !SenderId, - senderKey :: !(Maybe SndPublicVerifyKey), + senderKey :: !(Maybe SndPublicAuthKey), notifier :: !(Maybe NtfCreds), status :: !ServerQueueStatus } @@ -21,7 +21,7 @@ data QueueRec = QueueRec data NtfCreds = NtfCreds { notifierId :: !NotifierId, - notifierKey :: !NtfPublicVerifyKey, + notifierKey :: !NtfPublicAuthKey, rcvNtfDhSecret :: !RcvNtfDhSecret } deriving (Eq, Show) diff --git a/src/Simplex/Messaging/Server/QueueStore/STM.hs b/src/Simplex/Messaging/Server/QueueStore/STM.hs index b4c41c0de..195955513 100644 --- a/src/Simplex/Messaging/Server/QueueStore/STM.hs +++ b/src/Simplex/Messaging/Server/QueueStore/STM.hs @@ -63,7 +63,7 @@ getQueue QueueStore {queues, senders, notifiers} party qId = SSender -> TM.lookup qId senders $>>= (`TM.lookup` queues) SNotifier -> TM.lookup qId notifiers $>>= (`TM.lookup` queues) -secureQueue :: QueueStore -> RecipientId -> SndPublicVerifyKey -> STM (Either ErrorType QueueRec) +secureQueue :: QueueStore -> RecipientId -> SndPublicAuthKey -> STM (Either ErrorType QueueRec) secureQueue QueueStore {queues} rId sKey = withQueue rId queues $ \qVar -> readTVar qVar >>= \q -> case senderKey q of diff --git a/src/Simplex/Messaging/Server/StoreLog.hs b/src/Simplex/Messaging/Server/StoreLog.hs index b88338ab8..b3f5486b8 100644 --- a/src/Simplex/Messaging/Server/StoreLog.hs +++ b/src/Simplex/Messaging/Server/StoreLog.hs @@ -46,7 +46,7 @@ data StoreLog (a :: IOMode) where data StoreLogRecord = CreateQueue QueueRec - | SecureQueue QueueId SndPublicVerifyKey + | SecureQueue QueueId SndPublicAuthKey | AddNotifier QueueId NtfCreds | SuspendQueue QueueId | DeleteQueue QueueId @@ -120,7 +120,7 @@ writeStoreLogRecord (WriteStoreLog _ h) r = do logCreateQueue :: StoreLog 'WriteMode -> QueueRec -> IO () logCreateQueue s = writeStoreLogRecord s . CreateQueue -logSecureQueue :: StoreLog 'WriteMode -> QueueId -> SndPublicVerifyKey -> IO () +logSecureQueue :: StoreLog 'WriteMode -> QueueId -> SndPublicAuthKey -> IO () logSecureQueue s qId sKey = writeStoreLogRecord s $ SecureQueue qId sKey logAddNotifier :: StoreLog 'WriteMode -> QueueId -> NtfCreds -> IO () diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs index c67c812af..90c0de75d 100644 --- a/src/Simplex/Messaging/Transport.hs +++ b/src/Simplex/Messaging/Transport.hs @@ -5,6 +5,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -27,6 +28,10 @@ module Simplex.Messaging.Transport ( -- * SMP transport parameters supportedSMPServerVRange, + currentSMPServerVersion, + basicAuthSMPVersion, + subModeSMPVersion, + authEncryptCmdsSMPVersion, simplexMQVersion, smpBlockSize, TransportConfig (..), @@ -47,6 +52,7 @@ module Simplex.Messaging.Transport -- * SMP transport THandle (..), + THandleAuth (..), TransportError (..), HandshakeError (..), smpServerHandshake, @@ -72,6 +78,7 @@ import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB import Data.Default (def) import Data.Functor (($>)) +import Data.Maybe (fromMaybe) import Data.Version (showVersion) import GHC.IO.Handle.Internals (ioe_EOF) import Network.Socket @@ -93,8 +100,34 @@ import UnliftIO.STM smpBlockSize :: Int smpBlockSize = 16384 +-- SMP protocol version history: +-- 1 - binary protocol encoding (1/1/2022) +-- 2 - message flags (used to control notifications, 6/6/2022) +-- 3 - encrypt message timestamp and flags together with the body when delivered to the recipient (7/5/2022) +-- 4 - support command batching (7/17/2022) +-- 5 - basic auth for SMP servers (11/12/2022) +-- 6 - allow creating queues without subscribing (9/10/2023) +-- 7 - use authenticated encryption instead of signature to verify commands (2/3/2024) + +batchCmdsSMPVersion :: Version +batchCmdsSMPVersion = 4 + +basicAuthSMPVersion :: Version +basicAuthSMPVersion = 5 + +subModeSMPVersion :: Version +subModeSMPVersion = 6 + +authEncryptCmdsSMPVersion :: Version +authEncryptCmdsSMPVersion = 7 + +currentSMPServerVersion :: Version +currentSMPServerVersion = 7 + +-- minimal supported protocol version is 4 +-- TODO remove code that supports sending commands without batching supportedSMPServerVRange :: VersionRange -supportedSMPServerVRange = mkVersionRange 1 6 +supportedSMPServerVRange = mkVersionRange batchCmdsSMPVersion (currentSMPServerVersion - 1) simplexMQVersion :: String simplexMQVersion = showVersion SMQ.version @@ -230,45 +263,64 @@ instance Transport TLS where -- * SMP transport --- | The handle for SMP encrypted transport connection over Transport . +-- | The handle for SMP encrypted transport connection over Transport. data THandle c = THandle { connection :: c, sessionId :: SessionId, blockSize :: Int, -- | agreed server protocol version thVersion :: Version, + -- | peer public key for command authorization and shared secrets for entity ID encryption + thAuth :: Maybe THandleAuth, -- | send multiple transmissions in a single block -- based on protocol and protocol version batch :: Bool } +data THandleAuth = THandleAuth + { peerPubKey :: C.PublicKeyX25519, -- used only in the client to combine with per-queue key + dhSecret :: C.DhSecretX25519 -- used by both parties to encrypt entity IDs in for version >= 7 + } + -- | TLS-unique channel binding type SessionId = ByteString data ServerHandshake = ServerHandshake { smpVersionRange :: VersionRange, - sessionId :: SessionId + sessionId :: SessionId, + -- pub key to agree shared secrets for command authorization and entity ID encryption. + authPubKey :: Maybe C.PublicKeyX25519 } data ClientHandshake = ClientHandshake { -- | agreed SMP server protocol version smpVersion :: Version, -- | server identity - CA certificate fingerprint - keyHash :: C.KeyHash + keyHash :: C.KeyHash, + -- pub key to agree shared secret for entity ID encryption, shared secret for command authorization is agreed using per-queue keys. + authPubKey :: Maybe C.PublicKeyX25519 } instance Encoding ClientHandshake where - smpEncode ClientHandshake {smpVersion, keyHash} = smpEncode (smpVersion, keyHash) + smpEncode ClientHandshake {smpVersion, keyHash, authPubKey} = + smpEncode (smpVersion, keyHash, fromMaybe "" authPubKey) smpP = do (smpVersion, keyHash) <- smpP - pure ClientHandshake {smpVersion, keyHash} + -- TODO drop SMP v6: remove special parser and make key non-optional + authPubKey <- authPubKeyP smpVersion + pure ClientHandshake {smpVersion, keyHash, authPubKey} instance Encoding ServerHandshake where - smpEncode ServerHandshake {smpVersionRange, sessionId} = - smpEncode (smpVersionRange, sessionId) + smpEncode ServerHandshake {smpVersionRange, sessionId, authPubKey} = + smpEncode (smpVersionRange, sessionId, fromMaybe "" authPubKey) smpP = do (smpVersionRange, sessionId) <- smpP - pure ServerHandshake {smpVersionRange, sessionId} + -- TODO drop SMP v6: remove special parser and make key non-optional + authPubKey <- authPubKeyP $ maxVersion smpVersionRange + pure ServerHandshake {smpVersionRange, sessionId, authPubKey} + +authPubKeyP :: Version -> Parser (Maybe C.PublicKeyX25519) +authPubKeyP v = if v >= authEncryptCmdsSMPVersion then Just <$> smpP else pure Nothing -- | Error of SMP encrypted transport over TCP. data TransportError @@ -278,6 +330,9 @@ data TransportError TELargeMsg | -- | incorrect session ID TEBadSession + | -- | absent server key for v7 entity + -- This error happens when the server did not provide a DH key to authorize commands for the queue that should be authorized with a DH key. + TENoServerAuth | -- | transport handshake error TEHandshake {handshakeErr :: HandshakeError} deriving (Eq, Read, Show, Exception) @@ -298,6 +353,7 @@ transportErrorP = "BLOCK" $> TEBadBlock <|> "LARGE_MSG" $> TELargeMsg <|> "SESSION" $> TEBadSession + <|> "NO_AUTH" $> TENoServerAuth <|> "HANDSHAKE " *> (TEHandshake <$> parseRead1) -- | Serialize SMP encrypted transport error. @@ -306,6 +362,7 @@ serializeTransportError = \case TEBadBlock -> "BLOCK" TELargeMsg -> "LARGE_MSG" TEBadSession -> "SESSION" + TENoServerAuth -> "NO_AUTH" TEHandshake e -> "HANDSHAKE " <> bshow e -- | Pad and send block to SMP transport. @@ -325,44 +382,49 @@ tGetBlock THandle {connection = c, blockSize} = do -- | Server SMP transport handshake. -- -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a -smpServerHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c) -smpServerHandshake c kh smpVRange = do +smpServerHandshake :: forall c. Transport c => c -> C.KeyPairX25519 -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c) +smpServerHandshake c (k, pk) kh smpVRange = do let th@THandle {sessionId} = smpTHandle c - sendHandshake th $ ServerHandshake {sessionId, smpVersionRange = smpVRange} + sendHandshake th $ ServerHandshake {sessionId, smpVersionRange = smpVRange, authPubKey = Just k} getHandshake th >>= \case - ClientHandshake {smpVersion, keyHash} + ClientHandshake {smpVersion = v, keyHash, authPubKey = k'} | keyHash /= kh -> throwE $ TEHandshake IDENTITY - | smpVersion `isCompatible` smpVRange -> do - pure $ smpThHandle th smpVersion + | v `isCompatible` smpVRange -> + pure $ smpThHandle th v pk k' | otherwise -> throwE $ TEHandshake VERSION -- | Client SMP transport handshake. -- -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a -smpClientHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c) -smpClientHandshake c keyHash smpVRange = do +smpClientHandshake :: forall c. Transport c => c -> C.KeyPairX25519 -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c) +smpClientHandshake c (k, pk) keyHash smpVRange = do let th@THandle {sessionId} = smpTHandle c - ServerHandshake {sessionId = sessId, smpVersionRange} <- getHandshake th + ServerHandshake {sessionId = sessId, smpVersionRange, authPubKey = k'} <- getHandshake th if sessionId /= sessId then throwE TEBadSession else case smpVersionRange `compatibleVersion` smpVRange of - Just (Compatible smpVersion) -> do - sendHandshake th $ ClientHandshake {smpVersion, keyHash} - pure $ smpThHandle th smpVersion + Just (Compatible v) -> do + sendHandshake th $ ClientHandshake {smpVersion = v, keyHash, authPubKey = Just k} + pure $ smpThHandle th v pk k' Nothing -> throwE $ TEHandshake VERSION -smpThHandle :: forall c. THandle c -> Version -> THandle c -smpThHandle th v = (th :: THandle c) {thVersion = v, batch = v >= 4} +smpThHandle :: forall c. THandle c -> Version -> C.PrivateKeyX25519 -> Maybe C.PublicKeyX25519 -> THandle c +smpThHandle th v pk k_ = + -- TODO drop SMP v6: make thAuth non-optional + let thAuth = (\k -> THandleAuth {peerPubKey = k, dhSecret = C.dh' k pk}) <$> k_ + in (th :: THandle c) {thVersion = v, thAuth, batch = v >= batchCmdsSMPVersion} sendHandshake :: (Transport c, Encoding smp) => THandle c -> smp -> ExceptT TransportError IO () sendHandshake th = ExceptT . tPutBlock th . smpEncode +-- The parser in getHandshake ignores all bytes that follow the handshake, allowing to extend it. +-- This version extends server handshake with the SMP relay DH public key for command authorization. getHandshake :: (Transport c, Encoding smp) => THandle c -> ExceptT TransportError IO smp getHandshake th = ExceptT $ (parse smpP (TEHandshake PARSE) =<<) <$> tGetBlock th smpTHandle :: Transport c => c -> THandle c -smpTHandle c = THandle {connection = c, sessionId = tlsUnique c, blockSize = smpBlockSize, thVersion = 0, batch = False} +smpTHandle c = THandle {connection = c, sessionId = tlsUnique c, blockSize = smpBlockSize, thVersion = 0, thAuth = Nothing, batch = False} $(J.deriveJSON (sumTypeJSON id) ''HandshakeError) diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index 98fb47b80..ad268862b 100644 --- a/tests/AgentTests/SQLiteTests.hs +++ b/tests/AgentTests/SQLiteTests.hs @@ -174,8 +174,8 @@ testForeignKeysEnabled = cData1 :: ConnData cData1 = ConnData {userId = 1, connId = "conn1", connAgentVersion = 1, enableNtfs = True, duplexHandshake = Nothing, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk} -testPrivateSignKey :: C.APrivateSignKey -testPrivateSignKey = C.APrivateSignKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe" +testPrivateAuthKey :: C.APrivateAuthKey +testPrivateAuthKey = C.APrivateAuthKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe" testPrivDhKey :: C.PrivateKeyX25519 testPrivDhKey = "MC4CAQAwBQYDK2VuBCIEINCzbVFaCiYHoYncxNY8tSIfn0pXcIAhLBfFc0m+gOpk" @@ -193,7 +193,7 @@ rcvQueue1 = connId = "conn1", server = smpServer1, rcvId = "1234", - rcvPrivateKey = testPrivateSignKey, + rcvPrivateKey = testPrivateAuthKey, rcvDhSecret = testDhSecret, e2ePrivKey = testPrivDhKey, e2eDhSecret = Nothing, @@ -216,7 +216,7 @@ sndQueue1 = server = smpServer1, sndId = "3456", sndPublicKey = Nothing, - sndPrivateKey = testPrivateSignKey, + sndPrivateKey = testPrivateAuthKey, e2ePubKey = Nothing, e2eDhSecret = testDhSecret, status = New, @@ -354,7 +354,7 @@ testUpgradeRcvConnToDuplex = server = SMPServer "smp.simplex.im" "5223" testKeyHash, sndId = "2345", sndPublicKey = Nothing, - sndPrivateKey = testPrivateSignKey, + sndPrivateKey = testPrivateAuthKey, e2ePubKey = Nothing, e2eDhSecret = testDhSecret, status = New, @@ -381,7 +381,7 @@ testUpgradeSndConnToDuplex = connId = "conn1", server = SMPServer "smp.simplex.im" "5223" testKeyHash, rcvId = "3456", - rcvPrivateKey = testPrivateSignKey, + rcvPrivateKey = testPrivateAuthKey, rcvDhSecret = testDhSecret, e2ePrivKey = testPrivDhKey, e2eDhSecret = Nothing, @@ -671,8 +671,8 @@ testFileSbKey = either error id $ strDecode "00n8p1tJq5E-SGnHcYTOrS4A9I07gTA_WFD testFileCbNonce :: C.CbNonce testFileCbNonce = either error id $ strDecode "dPSF-wrQpDiK_K6sYv0BDBZ9S4dg-jmu" -testFileReplicaKey :: C.APrivateSignKey -testFileReplicaKey = C.APrivateSignKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe" +testFileReplicaKey :: C.APrivateAuthKey +testFileReplicaKey = C.APrivateAuthKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe" testGetNextRcvChunkToDownload :: SQLiteStore -> Expectation testGetNextRcvChunkToDownload st = do diff --git a/tests/CoreTests/BatchingTests.hs b/tests/CoreTests/BatchingTests.hs index bf31f0811..4160d7f39 100644 --- a/tests/CoreTests/BatchingTests.hs +++ b/tests/CoreTests/BatchingTests.hs @@ -69,7 +69,7 @@ testBatchWithLargeMessage = do length batches1' `shouldBe` 160 let batches = batchTransmissions True smpBlockSize $ L.fromList cmds length batches `shouldBe` 4 - [TBTransmissions s1 n1 _, TBLargeTransmission _, TBTransmissions s2 n2 _, TBTransmissions s3 n3 _] <- pure batches + [TBTransmissions s1 n1 _, TBError TELargeMsg _, TBTransmissions s2 n2 _, TBTransmissions s3 n3 _] <- pure batches (n1, n2, n3) `shouldBe` (60, 10, 90) all lenOk [s1, s2, s3] `shouldBe` True @@ -122,7 +122,7 @@ testClientBatchWithLargeMessage = do -- let batches = batchTransmissions' True smpBlockSize $ L.fromList cmds length batches `shouldBe` 4 - [TBTransmissions s1 n1 rs1, TBLargeTransmission _, TBTransmissions s2 n2 rs2, TBTransmissions s3 n3 rs3] <- pure batches + [TBTransmissions s1 n1 rs1, TBError TELargeMsg _, TBTransmissions s2 n2 rs2, TBTransmissions s3 n3 rs3] <- pure batches (n1, n2, n3) `shouldBe` (60, 10, 90) (length rs1, length rs2, length rs3) `shouldBe` (60, 10, 90) all lenOk [s1, s2, s3] `shouldBe` True @@ -130,28 +130,28 @@ testClientBatchWithLargeMessage = do let cmds' = [send] <> subs1 <> subs2 let batches' = batchTransmissions' True smpBlockSize $ L.fromList cmds' length batches' `shouldBe` 3 - [TBLargeTransmission _, TBTransmissions s1' n1' rs1', TBTransmissions s2' n2' rs2'] <- pure batches' + [TBError TELargeMsg _, TBTransmissions s1' n1' rs1', TBTransmissions s2' n2' rs2'] <- pure batches' (n1', n2') `shouldBe` (70, 90) (length rs1', length rs2') `shouldBe` (70, 90) all lenOk [s1', s2'] `shouldBe` True -randomSUB :: ByteString -> IO (Maybe C.ASignature, ByteString) +randomSUB :: ByteString -> IO (Either TransportError (TransmissionAuth, ByteString)) randomSUB sessId = do 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) + pure $ Right (TAuthSignature $ C.sign rpKey s, s) randomSUBCmd :: ProtocolClient ErrorType BrokerMsg -> IO (PCTransmission ErrorType BrokerMsg) randomSUBCmd c = do g <- C.newRandom rId <- atomically $ C.randomBytes 24 g - (_, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g + (_, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g mkTransmission c (Just rpKey, rId, Cmd SRecipient SUB) -randomSEND :: ByteString -> Int -> IO (Maybe C.ASignature, ByteString) +randomSEND :: ByteString -> Int -> IO (Either TransportError (TransmissionAuth, ByteString)) randomSEND sessId len = do g <- C.newRandom sId <- atomically $ C.randomBytes 24 g @@ -159,13 +159,13 @@ randomSEND sessId len = do (_, 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) + pure $ Right (TAuthSignature $ C.sign rpKey s, s) randomSENDCmd :: ProtocolClient ErrorType BrokerMsg -> Int -> IO (PCTransmission ErrorType BrokerMsg) randomSENDCmd c len = do g <- C.newRandom sId <- atomically $ C.randomBytes 24 g - (_, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g + (_, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g msg <- atomically $ C.randomBytes len g mkTransmission c (Just rpKey, sId, Cmd SSender $ SEND noMsgFlags msg) diff --git a/tests/FileDescriptionTests.hs b/tests/FileDescriptionTests.hs index 676882bcd..879ded459 100644 --- a/tests/FileDescriptionTests.hs +++ b/tests/FileDescriptionTests.hs @@ -87,7 +87,7 @@ fileDesc = where defaultChunkSize = FileSize $ mb 8 replicaId = ChunkReplicaId "abc" - replicaKey = C.APrivateSignKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe" + replicaKey = C.APrivateAuthKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe" chunkDigest = FileDigest "ghi" yamlFileDesc :: YAMLFileDescription diff --git a/tests/NtfClient.hs b/tests/NtfClient.hs index 02ce7b997..b4f6eb506 100644 --- a/tests/NtfClient.hs +++ b/tests/NtfClient.hs @@ -72,8 +72,10 @@ ntfTestStoreLogFile = "tests/tmp/ntf-server-store.log" testNtfClient :: (Transport c, MonadUnliftIO m, MonadFail m) => (THandle c -> m a) -> m a testNtfClient client = do Right host <- pure $ chooseTransportHost defaultNetworkConfig testHost - runTransportClient defaultTransportClientConfig Nothing host ntfTestPort (Just testKeyHash) $ \h -> - liftIO (runExceptT $ ntfClientHandshake h testKeyHash supportedNTFServerVRange) >>= \case + runTransportClient defaultTransportClientConfig Nothing host ntfTestPort (Just testKeyHash) $ \h -> do + g <- liftIO C.newRandom + ks <- atomically $ C.generateKeyPair g + liftIO (runExceptT $ ntfClientHandshake h ks testKeyHash supportedNTFServerVRange) >>= \case Right th -> client th Left e -> error $ show e @@ -135,18 +137,18 @@ ntfServerTest :: forall c smp. (Transport c, Encoding smp) => TProxy c -> - (Maybe C.ASignature, ByteString, ByteString, smp) -> - IO (Maybe C.ASignature, ByteString, ByteString, BrokerMsg) + (TransmissionAuth, ByteString, ByteString, smp) -> + IO (TransmissionAuth, ByteString, ByteString, BrokerMsg) ntfServerTest _ t = runNtfTest $ \h -> tPut' h t >> tGet' h where - tPut' :: THandle c -> (Maybe C.ASignature, ByteString, ByteString, smp) -> IO () + tPut' :: THandle c -> (TransmissionAuth, ByteString, ByteString, smp) -> IO () tPut' h@THandle {sessionId} (sig, corrId, queueId, smp) = do let t' = smpEncode (sessionId, corrId, queueId, smp) - [Right ()] <- tPut h [(sig, t')] + [Right ()] <- tPut h [Right (sig, t')] pure () tGet' h = do - [(Nothing, _, (CorrId corrId, qId, Right cmd))] <- tGet h - pure (Nothing, corrId, qId, cmd) + [(TAuthNone, _, (CorrId corrId, qId, Right cmd))] <- tGet h + pure (TAuthNone, corrId, qId, cmd) ntfTest :: Transport c => TProxy c -> (THandle c -> IO ()) -> Expectation ntfTest _ test' = runNtfTest test' `shouldReturn` () diff --git a/tests/NtfServerTests.hs b/tests/NtfServerTests.hs index b46ea311d..d03e5eed0 100644 --- a/tests/NtfServerTests.hs +++ b/tests/NtfServerTests.hs @@ -59,25 +59,30 @@ ntfSyntaxTests (ATransport t) = do where (>#>) :: Encoding smp => - (Maybe C.ASignature, ByteString, ByteString, smp) -> - (Maybe C.ASignature, ByteString, ByteString, BrokerMsg) -> + (TransmissionAuth, ByteString, ByteString, smp) -> + (TransmissionAuth, ByteString, ByteString, BrokerMsg) -> Expectation command >#> response = withAPNSMockServer $ \_ -> ntfServerTest t command `shouldReturn` response pattern RespNtf :: CorrId -> QueueId -> NtfResponse -> SignedTransmission ErrorType NtfResponse pattern RespNtf corrId queueId command <- (_, _, (corrId, queueId, Right command)) -sendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandle c -> (Maybe C.ASignature, ByteString, ByteString, NtfCommand e) -> IO (SignedTransmission ErrorType NtfResponse) +sendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandle c -> (TransmissionAuth, ByteString, ByteString, NtfCommand e) -> IO (SignedTransmission ErrorType NtfResponse) sendRecvNtf h@THandle {thVersion, sessionId} (sgn, corrId, qId, cmd) = do let t = encodeTransmission thVersion sessionId (CorrId corrId, qId, cmd) Right () <- tPut1 h (sgn, t) tGet1 h -signSendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandle c -> C.APrivateSignKey -> (ByteString, ByteString, NtfCommand e) -> IO (SignedTransmission ErrorType NtfResponse) -signSendRecvNtf h@THandle {thVersion, sessionId} pk (corrId, qId, cmd) = do +signSendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandle c -> C.APrivateAuthKey -> (ByteString, ByteString, NtfCommand e) -> IO (SignedTransmission ErrorType NtfResponse) +signSendRecvNtf h@THandle {thVersion, sessionId} (C.APrivateAuthKey a pk) (corrId, qId, cmd) = do let t = encodeTransmission thVersion sessionId (CorrId corrId, qId, cmd) - Right () <- tPut1 h (Just $ C.sign pk t, t) + Right () <- tPut1 h (authorize t, t) tGet1 h + where + authorize t = case a of + C.SEd25519 -> TAuthSignature . C.ASignature C.SEd25519 $ C.sign' pk t + C.SEd448 -> TAuthSignature . C.ASignature C.SEd448 $ C.sign' pk t + _ -> TAuthNone (.->) :: J.Value -> J.Key -> Either String ByteString v .-> key = @@ -89,9 +94,9 @@ testNotificationSubscription (ATransport t) = -- hangs on Ubuntu 20/22 xit' "should create notification subscription and notify when message is received" $ do g <- C.newRandom - (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g - (nPub, nKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g - (tknPub, tknKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (nPub, nKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (tknPub, tknKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g let tkn = DeviceToken PPApnsTest "abcd" withAPNSMockServer $ \APNSMockServer {apnsQ} -> diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index 5bff0405c..6836ef985 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -70,8 +70,10 @@ xit'' d t = do testSMPClient :: (Transport c, MonadUnliftIO m, MonadFail m) => (THandle c -> m a) -> m a testSMPClient client = do Right useHost <- pure $ chooseTransportHost defaultNetworkConfig testHost - runTransportClient defaultTransportClientConfig Nothing useHost testPort (Just testKeyHash) $ \h -> - liftIO (runExceptT $ smpClientHandshake h testKeyHash supportedSMPServerVRange) >>= \case + runTransportClient defaultTransportClientConfig Nothing useHost testPort (Just testKeyHash) $ \h -> do + g <- liftIO C.newRandom + ks <- atomically $ C.generateKeyPair g + liftIO (runExceptT $ smpClientHandshake h ks testKeyHash supportedSMPServerVRange) >>= \case Right th -> client th Left e -> error $ show e @@ -157,18 +159,18 @@ smpServerTest :: forall c smp. (Transport c, Encoding smp) => TProxy c -> - (Maybe C.ASignature, ByteString, ByteString, smp) -> - IO (Maybe C.ASignature, ByteString, ByteString, BrokerMsg) + (TransmissionAuth, ByteString, ByteString, smp) -> + IO (TransmissionAuth, ByteString, ByteString, BrokerMsg) smpServerTest _ t = runSmpTest $ \h -> tPut' h t >> tGet' h where - tPut' :: THandle c -> (Maybe C.ASignature, ByteString, ByteString, smp) -> IO () + tPut' :: THandle c -> (TransmissionAuth, ByteString, ByteString, smp) -> IO () tPut' h@THandle {sessionId} (sig, corrId, queueId, smp) = do let t' = smpEncode (sessionId, corrId, queueId, smp) - [Right ()] <- tPut h [(sig, t')] + [Right ()] <- tPut h [Right (sig, t')] pure () tGet' h = do - [(Nothing, _, (CorrId corrId, qId, Right cmd))] <- tGet h - pure (Nothing, corrId, qId, cmd) + [(TAuthNone, _, (CorrId corrId, qId, Right cmd))] <- tGet h + pure (TAuthNone, corrId, qId, cmd) smpTest :: (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandle c -> IO ()) -> Expectation smpTest _ test' = runSmpTest test' `shouldReturn` () diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index 4bd468f16..585252afc 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -75,21 +75,26 @@ pattern Ids rId sId srvDh <- IDS (QIK rId sId srvDh) pattern Msg :: MsgId -> MsgBody -> BrokerMsg pattern Msg msgId body <- MSG RcvMessage {msgId, msgBody = EncRcvMsgBody body} -sendRecv :: forall c p. (Transport c, PartyI p) => THandle c -> (Maybe C.ASignature, ByteString, ByteString, Command p) -> IO (SignedTransmission ErrorType BrokerMsg) +sendRecv :: forall c p. (Transport c, PartyI p) => THandle c -> (TransmissionAuth, ByteString, ByteString, Command p) -> IO (SignedTransmission ErrorType BrokerMsg) sendRecv h@THandle {thVersion, sessionId} (sgn, corrId, qId, cmd) = do let t = encodeTransmission thVersion sessionId (CorrId corrId, qId, cmd) Right () <- tPut1 h (sgn, t) tGet1 h -signSendRecv :: forall c p. (Transport c, PartyI p) => THandle c -> C.APrivateSignKey -> (ByteString, ByteString, Command p) -> IO (SignedTransmission ErrorType BrokerMsg) -signSendRecv h@THandle {thVersion, sessionId} pk (corrId, qId, cmd) = do +signSendRecv :: forall c p. (Transport c, PartyI p) => THandle c -> C.APrivateAuthKey -> (ByteString, ByteString, Command p) -> IO (SignedTransmission ErrorType BrokerMsg) +signSendRecv h@THandle {thVersion, sessionId} (C.APrivateAuthKey a pk) (corrId, qId, cmd) = do let t = encodeTransmission thVersion sessionId (CorrId corrId, qId, cmd) - Right () <- tPut1 h (Just $ C.sign pk t, t) + Right () <- tPut1 h (authorize t, t) tGet1 h + where + authorize t = case a of + C.SEd25519 -> TAuthSignature . C.ASignature C.SEd25519 $ C.sign' pk t + C.SEd448 -> TAuthSignature . C.ASignature C.SEd448 $ C.sign' pk t + _ -> TAuthNone tPut1 :: Transport c => THandle c -> SentRawTransmission -> IO (Either TransportError ()) tPut1 h t = do - [r] <- tPut h [t] + [r] <- tPut h [Right t] pure r tGet1 :: (ProtocolEncoding err cmd, Transport c, MonadIO m, MonadFail m) => THandle c -> m (SignedTransmission err cmd) @@ -121,7 +126,7 @@ testCreateSecureV2 _ = it "should create (NEW) and secure (KEY) queue" $ withSmpServerConfigOn (transport @c) cfgV2 testPort $ \_ -> testSMPClient @c $ \h -> do g <- C.newRandom - (rPub, rKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g + (rPub, rKey) <- atomically $ C.generateAuthKeyPair 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 @@ -140,7 +145,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) <- atomically $ C.generateSignatureKeyPair C.SEd448 g + (sPub, sKey) <- atomically $ C.generateAuthKeyPair 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" @@ -156,7 +161,7 @@ testCreateSecureV2 _ = (rId2, rId) #== "same queue ID in response 3" Resp "abcd" _ OK <- signSendRecv h rKey ("abcd", rId, KEY sPub) - (sPub', _) <- atomically $ C.generateSignatureKeyPair C.SEd448 g + (sPub', _) <- atomically $ C.generateAuthKeyPair C.SEd448 g Resp "abcd" _ err4 <- signSendRecv h rKey ("abcd", rId, KEY sPub') (err4, ERR AUTH) #== "rejects if secured with different key" @@ -186,7 +191,7 @@ testCreateSecure (ATransport t) = it "should create (NEW) and secure (KEY) queue" $ smpTest2 t $ \r s -> do g <- C.newRandom - (rPub, rKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g + (rPub, rKey) <- atomically $ C.generateAuthKeyPair 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 @@ -205,7 +210,7 @@ testCreateSecure (ATransport t) = Resp "dabc" _ err6 <- signSendRecv r rKey ("dabc", rId, ACK mId1) (err6, ERR NO_MSG) #== "replies ERR when message acknowledged without messages" - (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g + (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g Resp "abcd" sId2 err1 <- signSendRecv s sKey ("abcd", sId, _SEND "hello") (err1, ERR AUTH) #== "rejects signed SEND" (sId2, sId) #== "same queue ID in response 2" @@ -221,7 +226,7 @@ testCreateSecure (ATransport t) = (rId2, rId) #== "same queue ID in response 3" Resp "abcd" _ OK <- signSendRecv r rKey ("abcd", rId, KEY sPub) - (sPub', _) <- atomically $ C.generateSignatureKeyPair C.SEd448 g + (sPub', _) <- atomically $ C.generateAuthKeyPair C.SEd448 g Resp "abcd" _ err4 <- signSendRecv r rKey ("abcd", rId, KEY sPub') (err4, ERR AUTH) #== "rejects if secured with different key" @@ -251,13 +256,13 @@ testCreateDelete (ATransport t) = it "should create (NEW), suspend (OFF) and delete (DEL) queue" $ smpTest2 t $ \rh sh -> do g <- C.newRandom - (rPub, rKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (rPub, rKey) <- atomically $ C.generateAuthKeyPair 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) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g Resp "bcda" _ ok1 <- signSendRecv rh rKey ("bcda", rId, KEY sPub) (ok1, OK) #== "secures queue" @@ -322,7 +327,7 @@ stressTest (ATransport t) = it "should create many queues, disconnect and re-connect" $ smpTest3 t $ \h1 h2 h3 -> do g <- C.newRandom - (rPub, rKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (rPub, rKey) <- atomically $ C.generateAuthKeyPair 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) @@ -341,7 +346,7 @@ testAllowNewQueues t = withSmpServerConfigOn (ATransport t) cfg {allowNewQueues = False} testPort $ \_ -> testSMPClient @c $ \h -> do g <- C.newRandom - (rPub, rKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g + (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g (dhPub, _ :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g Resp "abcd" "" (ERR AUTH) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe) pure () @@ -351,13 +356,13 @@ testDuplex (ATransport t) = it "should create 2 simplex connections and exchange messages" $ smpTest2 t $ \alice bob -> do g <- C.newRandom - (arPub, arKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g + (arPub, arKey) <- atomically $ C.generateAuthKeyPair 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) <- atomically $ C.generateSignatureKeyPair C.SEd448 g + (bsPub, bsKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g Resp "bcda" _ OK <- sendRecv bob ("", "bcda", aSnd, _SEND $ "key " <> strEncode bsPub) -- "key ..." is ad-hoc, not a part of SMP protocol @@ -367,7 +372,7 @@ testDuplex (ATransport t) = (bobKey, strEncode bsPub) #== "key received from Bob" Resp "dabc" _ OK <- signSendRecv alice arKey ("dabc", aRcv, KEY bsPub) - (brPub, brKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g + (brPub, brKey) <- atomically $ C.generateAuthKeyPair 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 @@ -379,7 +384,7 @@ testDuplex (ATransport t) = Right ["reply_id", bId] <- pure $ B.words <$> aDec mId2 msg2 (bId, encode bSnd) #== "reply queue ID received from Bob" - (asPub, asKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g + (asPub, asKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g Resp "dabc" _ OK <- sendRecv alice ("", "dabc", bSnd, _SEND $ "key " <> strEncode asPub) -- "key ..." is ad-hoc, not a part of SMP protocol @@ -406,7 +411,7 @@ testSwitchSub (ATransport t) = it "should create simplex connections and switch subscription to another TCP connection" $ smpTest3 t $ \rh1 rh2 sh -> do g <- C.newRandom - (rPub, rKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g + (rPub, rKey) <- atomically $ C.generateAuthKeyPair 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 @@ -446,7 +451,7 @@ testGetCommand :: forall c. Transport c => TProxy c -> Spec testGetCommand t = it "should retrieve messages from the queue using GET command" $ do g <- C.newRandom - (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g smpTest t $ \sh -> do queue <- newEmptyTMVarIO testSMPClient @c $ \rh -> @@ -465,7 +470,7 @@ testGetSubCommands :: forall c. Transport c => TProxy c -> Spec testGetSubCommands t = it "should retrieve messages with GET and receive with SUB, only one ACK would work" $ do g <- C.newRandom - (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g smpTest3 t $ \rh1 rh2 sh -> do (sId, rId, rKey, dhShared) <- createAndSecureQueue rh1 sPub let dec = decryptMsgV3 dhShared @@ -517,7 +522,7 @@ testExceedQueueQuota t = withSmpServerConfigOn (ATransport t) cfg {msgQueueQuota = 2} testPort $ \_ -> testSMPClient @c $ \sh -> testSMPClient @c $ \rh -> do g <- C.newRandom - (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (sId, rId, rKey, dhShared) <- createAndSecureQueue rh sPub let dec = decryptMsgV3 dhShared Resp "1" _ OK <- signSendRecv sh sKey ("1", sId, _SEND "hello 1") @@ -542,9 +547,9 @@ testWithStoreLog :: ATransport -> Spec testWithStoreLog at@(ATransport t) = it "should store simplex queues to log and restore them after server restart" $ do g <- C.newRandom - (sPub1, sKey1) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g - (sPub2, sKey2) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g - (nPub, nKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (sPub1, sKey1) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (sPub2, sKey2) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (nPub, nKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g recipientId1 <- newTVarIO "" recipientKey1 <- newTVarIO Nothing dhShared1 <- newTVarIO Nothing @@ -631,7 +636,7 @@ testRestoreMessages at@(ATransport t) = removeFileIfExists testServerStatsBackupFile g <- C.newRandom - (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g recipientId <- newTVarIO "" recipientKey <- newTVarIO Nothing dhShared <- newTVarIO Nothing @@ -733,7 +738,7 @@ testRestoreMessagesV2 :: ATransport -> Spec testRestoreMessagesV2 at@(ATransport t) = it "should store messages on exit and restore on start" $ do g <- C.newRandom - (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g recipientId <- newTVarIO "" recipientKey <- newTVarIO Nothing dhShared <- newTVarIO Nothing @@ -803,7 +808,7 @@ testRestoreExpireMessages :: ATransport -> Spec testRestoreExpireMessages at@(ATransport t) = it "should store messages on exit and restore on start" $ do g <- C.newRandom - (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g recipientId <- newTVarIO "" recipientKey <- newTVarIO Nothing dhShared <- newTVarIO Nothing @@ -857,10 +862,10 @@ testRestoreExpireMessages at@(ATransport t) = runClient :: Transport c => TProxy c -> (THandle c -> IO ()) -> Expectation runClient _ test' = testSMPClient test' `shouldReturn` () -createAndSecureQueue :: Transport c => THandle c -> SndPublicVerifyKey -> IO (SenderId, RecipientId, RcvPrivateSignKey, RcvDhSecret) +createAndSecureQueue :: Transport c => THandle c -> SndPublicAuthKey -> IO (SenderId, RecipientId, RcvPrivateAuthKey, RcvDhSecret) createAndSecureQueue h sPub = do g <- C.newRandom - (rPub, rKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g + (rPub, rKey) <- atomically $ C.generateAuthKeyPair 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 @@ -905,8 +910,8 @@ testTiming (ATransport t) = runTimingTest sh badKey sId $ _SEND "hello" where generateKeys g = \case - 32 -> atomically $ C.generateSignatureKeyPair C.SEd25519 g - 57 -> atomically $ C.generateSignatureKeyPair C.SEd448 g + 32 -> atomically $ C.generateAuthKeyPair C.SEd25519 g + 57 -> atomically $ C.generateAuthKeyPair C.SEd448 g _ -> error "unsupported key size" runTimingTest h badKey qId cmd = do threadDelay 100000 @@ -932,8 +937,8 @@ testMessageNotifications :: ATransport -> Spec testMessageNotifications (ATransport t) = it "should create simplex connection, subscribe notifier and deliver notifications" $ do g <- C.newRandom - (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g - (nPub, nKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (nPub, nKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g smpTest4 t $ \rh sh nh1 nh2 -> do (sId, rId, rKey, dhShared) <- createAndSecureQueue rh sPub let dec = decryptMsgV3 dhShared @@ -969,7 +974,7 @@ testMsgExpireOnSend :: forall c. Transport c => TProxy c -> Spec testMsgExpireOnSend t = it "should expire messages that are not received before messageTTL on SEND" $ do g <- C.newRandom - (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g let cfg' = cfg {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 10000}} withSmpServerConfigOn (ATransport t) cfg' testPort $ \_ -> testSMPClient @c $ \sh -> do @@ -990,7 +995,7 @@ testMsgExpireOnInterval t = -- fails on ubuntu xit' "should expire messages that are not received before messageTTL after expiry interval" $ do g <- C.newRandom - (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g let cfg' = cfg {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}} withSmpServerConfigOn (ATransport t) cfg' testPort $ \_ -> testSMPClient @c $ \sh -> do @@ -1009,7 +1014,7 @@ testMsgNOTExpireOnInterval :: forall c. Transport c => TProxy c -> Spec testMsgNOTExpireOnInterval t = it "should NOT expire messages that are not received before messageTTL if expiry interval is large" $ do g <- C.newRandom - (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g let cfg' = cfg {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 10000}} withSmpServerConfigOn (ATransport t) cfg' testPort $ \_ -> testSMPClient @c $ \sh -> do @@ -1030,8 +1035,8 @@ samplePubKey = C.APublicVerifyKey C.SEd25519 "MCowBQYDK2VwAyEAfAOflyvbJv1fszgzkQ sampleDhPubKey :: C.PublicKey 'C.X25519 sampleDhPubKey = "MCowBQYDK2VuAyEAriy+HcARIhqsgSjVnjKqoft+y6pxrxdY68zn4+LjYhQ=" -sampleSig :: Maybe C.ASignature -sampleSig = "e8JK+8V3fq6kOLqco/SaKlpNaQ7i1gfOrXoqekEl42u4mF8Bgu14T5j0189CGcUhJHw2RwCMvON+qbvQ9ecJAA==" +sampleSig :: TransmissionAuth +sampleSig = TAuthSignature "e8JK+8V3fq6kOLqco/SaKlpNaQ7i1gfOrXoqekEl42u4mF8Bgu14T5j0189CGcUhJHw2RwCMvON+qbvQ9ecJAA==" noAuth :: (Char, Maybe BasicAuth) noAuth = ('A', Nothing) @@ -1075,7 +1080,7 @@ syntaxTests (ATransport t) = do it "no queue ID" $ (sampleSig, "dabc", "", cmd) >#> ("", "dabc", "", ERR $ CMD NO_AUTH) (>#>) :: Encoding smp => - (Maybe C.ASignature, ByteString, ByteString, smp) -> - (Maybe C.ASignature, ByteString, ByteString, BrokerMsg) -> + (TransmissionAuth, ByteString, ByteString, smp) -> + (TransmissionAuth, ByteString, ByteString, BrokerMsg) -> Expectation command >#> response = withFrozenCallStack $ smpServerTest t command `shouldReturn` response diff --git a/tests/XFTPServerTests.hs b/tests/XFTPServerTests.hs index ead057122..a11ba515a 100644 --- a/tests/XFTPServerTests.hs +++ b/tests/XFTPServerTests.hs @@ -86,8 +86,8 @@ testFileChunkDelivery2 = xftpTest2 $ \s r -> runRight_ $ runTestFileChunkDeliver runTestFileChunkDelivery :: XFTPClient -> XFTPClient -> ExceptT XFTPClientError IO () runTestFileChunkDelivery s r = do g <- liftIO C.newRandom - (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g - (rcvKey, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g bytes <- liftIO $ createTestChunk testChunkPath digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath let file = FileInfo {sndKey, size = chSize, digest} @@ -106,10 +106,10 @@ runTestFileChunkDelivery s r = do testFileChunkDeliveryAddRecipients :: Expectation testFileChunkDeliveryAddRecipients = xftpTest4 $ \s r1 r2 r3 -> runRight_ $ do 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 + (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (rcvKey1, rpKey1) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (rcvKey2, rpKey2) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (rcvKey3, rpKey3) <- atomically $ C.generateAuthKeyPair C.SEd25519 g bytes <- liftIO $ createTestChunk testChunkPath digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath let file = FileInfo {sndKey, size = chSize, digest} @@ -133,8 +133,8 @@ testFileChunkDelete2 = xftpTest2 $ \s r -> runRight_ $ runTestFileChunkDelete s runTestFileChunkDelete :: XFTPClient -> XFTPClient -> ExceptT XFTPClientError IO () runTestFileChunkDelete s r = do g <- liftIO C.newRandom - (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g - (rcvKey, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g bytes <- liftIO $ createTestChunk testChunkPath digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath let file = FileInfo {sndKey, size = chSize, digest} @@ -162,8 +162,8 @@ testFileChunkAck2 = xftpTest2 $ \s r -> runRight_ $ runTestFileChunkAck s r runTestFileChunkAck :: XFTPClient -> XFTPClient -> ExceptT XFTPClientError IO () runTestFileChunkAck s r = do g <- liftIO C.newRandom - (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g - (rcvKey, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g bytes <- liftIO $ createTestChunk testChunkPath digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath let file = FileInfo {sndKey, size = chSize, digest} @@ -183,8 +183,8 @@ runTestFileChunkAck s r = do testWrongChunkSize :: Expectation testWrongChunkSize = xftpTest $ \c -> do g <- C.newRandom - (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g - (rcvKey, _rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (rcvKey, _rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g B.writeFile testChunkPath =<< atomically (C.randomBytes (kb 96) g) digest <- LC.sha256Hash <$> LB.readFile testChunkPath let file = FileInfo {sndKey, size = kb 96, digest} @@ -196,8 +196,8 @@ testFileChunkExpiration :: Expectation testFileChunkExpiration = withXFTPServerCfg testXFTPServerConfig {fileExpiration} $ \_ -> testXFTPClient $ \c -> runRight_ $ do g <- liftIO C.newRandom - (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g - (rcvKey, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g bytes <- liftIO $ createTestChunk testChunkPath digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath let file = FileInfo {sndKey, size = chSize, digest} @@ -235,8 +235,8 @@ testFileStorageQuota :: Expectation testFileStorageQuota = withXFTPServerCfg testXFTPServerConfig {fileSizeQuota = Just $ chSize * 2} $ \_ -> testXFTPClient $ \c -> runRight_ $ do g <- liftIO C.newRandom - (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g - (rcvKey, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g bytes <- liftIO $ createTestChunk testChunkPath digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath let file = FileInfo {sndKey, size = chSize, digest} @@ -263,9 +263,9 @@ testFileLog :: Expectation testFileLog = do g <- C.newRandom bytes <- liftIO $ createTestChunk testChunkPath - (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g - (rcvKey1, rpKey1) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g - (rcvKey2, rpKey2) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (rcvKey1, rpKey1) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (rcvKey2, rpKey2) <- atomically $ C.generateAuthKeyPair C.SEd25519 g digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath sIdVar <- newTVarIO "" rIdVar1 <- newTVarIO "" @@ -356,8 +356,8 @@ testFileBasicAuth allowNewFiles newFileBasicAuth clntAuth success = withXFTPServerCfg testXFTPServerConfig {allowNewFiles, newFileBasicAuth} $ \_ -> testXFTPClient $ \c -> do g <- C.newRandom - (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g - (rcvKey, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g bytes <- createTestChunk testChunkPath digest <- LC.sha256Hash <$> LB.readFile testChunkPath let file = FileInfo {sndKey, size = chSize, digest}