dandri/simplexmq
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplexmq.git synced 2026-08-29 03:28:42 +00:00
Code Issues Packages Projects Releases Wiki Activity

smp: command authorization (#982)

Browse Source 
* smp: command authorization

* fix encoding, most tests

* remove old tests

* authorize via crypto_box

* extract authenticator to Crypto module

* make TransmissionAuth Maybe

* rfc

* support authenticators in NTF protocol, test matrix (no backwards compatibility yet from new clients to old servers)

* fix/add tests, add version config to "small" agent

* separate client and server versions for SMP protocol

* test batching SMP v7

* do not send session ID in each transmission

* refactor auth verification in the server, split tests

* server "warm up" fixes timing test

* uncomment SUB timing test

* comments, disable two timing tests

* rename version

* increase auth timing test failure threshold

* use different algorithms to authorize snd/rcv commands, use random correlation ID

* transport: fetch and store server certificate (#985)

* THandleParams (WIP, does not compile)

* transport: fetch and store server certificate

* smp: add getOnlinePubKey example to smpClientHandshake

* add server certs and sign authPub

* cleanup

* update

* style

* load server certs from test fixtures

* sign ntf authPubKey

* fix onServerCertificate

* increase delay before sending messages

* require certificate with key in SMP server handshake

---------

Co-authored-by: Evgeny Poberezkin <evgeny@poberezkin.com>

* remove dhSecret from THandle

* remove v8, merge all changes to one version

* parameterize THandle

* rfc: transmission ecnryption

* Revert "parameterize THandle"

This reverts commit 75adfc94fb.

* use batch syntax for ntf server commands

* separate encodeTransmission when there is no key

* typo

Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>

* rename

* diff

---------

Co-authored-by: Alexander Bondarenko <486682+dpwiz@users.noreply.github.com>
Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
This commit is contained in:
Evgeny Poberezkin
2024-02-16 11:45:54 +00:00
committed by GitHub
co-authored by spaced4ndy Alexander Bondarenko
parent 9254d8dac5
commit 416f1b1721
52 changed files with 1686 additions and 946 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Simplex/FileTransfer/Client.hs
+20 -17
View File
@@ -45,7 +45,7 @@ import Simplex.Messaging.Protocol
RecipientId,
SenderId,
)
import Simplex.Messaging.Transport (supportedParameters)
import Simplex.Messaging.Transport (THandleParams (..), supportedParameters)
import Simplex.Messaging.Transport.Client (TransportClientConfig, TransportHost)
import Simplex.Messaging.Transport.HTTP2
import Simplex.Messaging.Transport.HTTP2.Client
@@ -57,6 +57,7 @@ import UnliftIO.Directory
data XFTPClient = XFTPClient
{ http2Client :: HTTP2Client,
transportSession :: TransportSession FileResponse,
thParams :: THandleParams,
config :: XFTPClientConfig
}
@@ -98,7 +99,9 @@ getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {xftpNetworkC
let usePort = if null port then "443" else port
clientDisconnected = readTVarIO clientVar >>= mapM_ disconnected
http2Client <- liftEitherError xftpClientError $ getVerifiedHTTP2Client (Just username) useHost usePort (Just keyHash) Nothing http2Config clientDisconnected
let c = XFTPClient {http2Client, transportSession, config}
let HTTP2Client {sessionId} = http2Client
thParams = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = currentXFTPVersion, thAuth = Nothing, implySessId = False, batch = True}
c = XFTPClient {http2Client, thParams, transportSession, config}
atomically $ writeTVar clientVar $ Just c
pure c
@@ -131,21 +134,21 @@ 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 c@XFTPClient {http2Client = HTTP2Client {sessionId}} pKey fId cmd chunkSpec_ = do
sendXFTPCommand :: forall p. FilePartyI p => XFTPClient -> C.APrivateAuthKey -> XFTPFileId -> FileCommand p -> Maybe XFTPChunkSpec -> ExceptT XFTPClientError IO (FileResponse, HTTP2Body)
sendXFTPCommand c@XFTPClient {thParams} pKey fId cmd chunkSpec_ = do
t <-
liftEither . first PCETransportError $
xftpEncodeTransmission sessionId (Just pKey) ("", fId, FileCmd (sFileParty @p) cmd)
xftpEncodeAuthTransmission thParams pKey ("", fId, FileCmd (sFileParty @p) cmd)
sendXFTPTransmission c t chunkSpec_
sendXFTPTransmission :: XFTPClient -> ByteString -> Maybe XFTPChunkSpec -> ExceptT XFTPClientError IO (FileResponse, HTTP2Body)
sendXFTPTransmission XFTPClient {config, http2Client = http2@HTTP2Client {sessionId}} t chunkSpec_ = do
sendXFTPTransmission XFTPClient {config, thParams, http2Client} t chunkSpec_ = do
let req = H.requestStreaming N.methodPost "/" [] streamBody
reqTimeout = (\XFTPChunkSpec {chunkSize} -> chunkTimeout config chunkSize) <$> chunkSpec_
HTTP2Response {respBody = body@HTTP2Body {bodyHead}} <- liftEitherError xftpClientError $ sendRequest http2 req reqTimeout
HTTP2Response {respBody = body@HTTP2Body {bodyHead}} <- liftEitherError xftpClientError $ sendRequest http2Client req reqTimeout
when (B.length bodyHead /= xftpBlockSize) $ throwError $ PCEResponseError BLOCK
-- TODO validate that the file ID is the same as in the request?
(_, _, (_, _fId, respOrErr)) <- liftEither . first PCEResponseError $ xftpDecodeTransmission sessionId bodyHead
(_, _, (_, _fId, respOrErr)) <- liftEither . first PCEResponseError $ xftpDecodeTransmission thParams bodyHead
case respOrErr of
Right r -> case protocolError r of
Just e -> throwError $ PCEProtocolError e
@@ -163,9 +166,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 +176,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,17 +208,17 @@ 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 ()
pingXFTP c@XFTPClient {http2Client = HTTP2Client {sessionId}} = do
pingXFTP c@XFTPClient {thParams} = do
t <-
liftEither . first PCETransportError $
xftpEncodeTransmission sessionId Nothing ("", "", FileCmd SFRecipient PING)
xftpEncodeTransmission thParams ("", "", FileCmd SFRecipient PING)
(r, _) <- sendXFTPTransmission c t Nothing
case r of
FRPong -> pure ()
src/Simplex/FileTransfer/Client/Main.hs
+7 -7
View File
@@ -63,7 +63,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)
@@ -209,7 +209,7 @@ cliCommandP =
data SentFileChunk = SentFileChunk
{ chunkNo :: Int,
sndId :: SenderId,
sndPrivateKey :: SndPrivateSignKey,
sndPrivateKey :: SndPrivateAuthKey,
chunkSize :: FileSize Word32,
digest :: FileDigest,
replicas :: [SentFileChunkReplica]
@@ -218,7 +218,7 @@ data SentFileChunk = SentFileChunk
data SentFileChunkReplica = SentFileChunkReplica
{ server :: XFTPServer,
recipients :: [(ChunkReplicaId, C.APrivateSignKey)]
recipients :: [(ChunkReplicaId, C.APrivateAuthKey)]
}
deriving (Eq, Show)
@@ -227,7 +227,7 @@ data SentRecipientReplica = SentRecipientReplica
server :: XFTPServer,
rcvNo :: Int,
replicaId :: ChunkReplicaId,
replicaKey :: C.APrivateSignKey,
replicaKey :: C.APrivateAuthKey,
digest :: FileDigest,
chunkSize :: FileSize Word32
}
@@ -319,8 +319,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
@@ -388,7 +388,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)
src/Simplex/FileTransfer/Description.hs
+2 -2
View File
@@ -135,7 +135,7 @@ data FileChunk = FileChunk
data FileChunkReplica = FileChunkReplica
{ server :: XFTPServer,
replicaId :: ChunkReplicaId,
replicaKey :: C.APrivateSignKey
replicaKey :: C.APrivateAuthKey
}
deriving (Eq, Show)
@@ -179,7 +179,7 @@ data FileServerReplica = FileServerReplica
{ chunkNo :: Int,
server :: XFTPServer,
replicaId :: ChunkReplicaId,
replicaKey :: C.APrivateSignKey,
replicaKey :: C.APrivateAuthKey,
digest :: Maybe FileDigest,
chunkSize :: Maybe (FileSize Word32)
}
src/Simplex/FileTransfer/Protocol.hs
+27 -21
View File
@@ -7,6 +7,7 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
@@ -24,6 +25,7 @@ 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,20 +40,22 @@ import Simplex.Messaging.Protocol
ProtocolMsgTag (..),
ProtocolType (..),
RcvPublicDhKey,
RcvPublicVerifyKey,
RcvPublicAuthKey,
RecipientId,
SenderId,
SentRawTransmission,
SignedTransmission,
SndPublicVerifyKey,
SndPublicAuthKey,
Transmission,
TransmissionForAuth (..),
encodeTransmissionForAuth,
encodeTransmission,
messageTagP,
tDecodeParseValidate,
tEncodeBatch1,
tParse,
)
import Simplex.Messaging.Transport (SessionId, TransportError (..))
import Simplex.Messaging.Transport (THandleParams (..), TransportError (..))
import Simplex.Messaging.Util (bshow, (<$?>))
import Simplex.Messaging.Version
@@ -148,8 +152,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 +167,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 +194,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
| isNothing auth -> Left $ CMD NO_AUTH
| not (B.null fileId) -> Left $ CMD HAS_AUTH
| otherwise -> Right cmd
PING
| isNothing sig && B.null fileId -> Right cmd
| isNothing 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
| isNothing auth || B.null fileId -> Left $ CMD NO_AUTH
| otherwise -> Right cmd
instance ProtocolEncoding XFTPErrorType FileCmd where
@@ -401,23 +405,25 @@ 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 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)
xftpEncodeAuthTransmission :: ProtocolEncoding e c => THandleParams -> C.APrivateAuthKey -> Transmission c -> Either TransportError ByteString
xftpEncodeAuthTransmission thParams pKey (corrId, fId, msg) = do
let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (corrId, fId, msg)
xftpEncodeBatch1 . (,tToSend) =<< authTransmission Nothing (Just pKey) corrId tForAuth
xftpEncodeTransmission :: ProtocolEncoding e c => THandleParams -> Transmission c -> Either TransportError ByteString
xftpEncodeTransmission thParams (corrId, fId, msg) = do
let t = encodeTransmission thParams (corrId, fId, msg)
xftpEncodeBatch1 (Nothing, t)
-- this function uses batch syntax but puts only one transmission in the batch
xftpEncodeBatch1 :: SentRawTransmission -> Either TransportError ByteString
xftpEncodeBatch1 t = first (const TELargeMsg) $ C.pad (tEncodeBatch1 t) xftpBlockSize
xftpDecodeTransmission :: ProtocolEncoding e c => SessionId -> ByteString -> Either XFTPErrorType (SignedTransmission e c)
xftpDecodeTransmission sessionId t = do
xftpDecodeTransmission :: ProtocolEncoding e c => THandleParams -> ByteString -> Either XFTPErrorType (SignedTransmission e c)
xftpDecodeTransmission thParams t = do
t' <- first (const BLOCK) $ C.unPad t
case tParse True t' of
t'' :| [] -> Right $ tDecodeParseValidate sessionId currentXFTPVersion t''
case tParse thParams t' of
t'' :| [] -> Right $ tDecodeParseValidate thParams t''
_ -> Left BLOCK
$(J.deriveJSON (enumJSON $ dropPrefix "F") ''FileParty)
src/Simplex/FileTransfer/Server.hs
+26 -15
View File
@@ -47,10 +47,11 @@ 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.Server (dummyVerifyCmd, verifyCmdSignature)
import Simplex.Messaging.Protocol (CorrId, RcvPublicDhKey, RcvPublicAuthKey, RecipientId, TransmissionAuth)
import Simplex.Messaging.Server (dummyVerifyCmd, verifyCmdAuthorization)
import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.Server.Stats
import Simplex.Messaging.Transport (THandleParams (..))
import Simplex.Messaging.Transport.Buffer (trimCR)
import Simplex.Messaging.Transport.HTTP2
import Simplex.Messaging.Transport.HTTP2.Server
@@ -66,6 +67,14 @@ import qualified UnliftIO.Exception as E
type M a = ReaderT XFTPEnv IO a
data XFTPTransportRequest =
XFTPTransportRequest
{ thParams :: THandleParams,
reqBody :: HTTP2Body,
request :: H.Request,
sendResponse :: H.Response -> IO ()
}
runXFTPServer :: XFTPServerConfig -> IO ()
runXFTPServer cfg = do
started <- newEmptyTMVarIO
@@ -86,7 +95,8 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
liftIO $
runHTTP2Server started xftpPort defaultHTTP2BufferSize serverParams transportConfig inactiveClientExpiration $ \sessionId r sendResponse -> do
reqBody <- getHTTP2Body r xftpBlockSize
processRequest HTTP2Request {sessionId, request = r, reqBody, sendResponse} `runReaderT` env
let thParams = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = currentXFTPVersion, thAuth = Nothing, implySessId = False, batch = True}
processRequest XFTPTransportRequest {thParams, request = r, reqBody, sendResponse} `runReaderT` env
stopServer :: M ()
stopServer = do
@@ -215,11 +225,11 @@ data ServerFile = ServerFile
sbState :: LC.SbState
}
processRequest :: HTTP2Request -> M ()
processRequest HTTP2Request {sessionId, reqBody = body@HTTP2Body {bodyHead}, sendResponse}
processRequest :: XFTPTransportRequest -> M ()
processRequest XFTPTransportRequest {thParams, reqBody = body@HTTP2Body {bodyHead}, sendResponse}
| B.length bodyHead /= xftpBlockSize = sendXFTPResponse ("", "", FRErr BLOCK) Nothing
| otherwise = do
case xftpDecodeTransmission sessionId bodyHead of
case xftpDecodeTransmission thParams bodyHead of
Right (sig_, signed, (corrId, fId, cmdOrErr)) -> do
case cmdOrErr of
Right cmd -> do
@@ -233,7 +243,7 @@ processRequest HTTP2Request {sessionId, reqBody = body@HTTP2Body {bodyHead}, sen
where
sendXFTPResponse :: (CorrId, XFTPFileId, FileResponse) -> Maybe ServerFile -> M ()
sendXFTPResponse (corrId, fId, resp) serverFile_ = do
let t_ = xftpEncodeTransmission sessionId Nothing (corrId, fId, resp)
let t_ = xftpEncodeTransmission thParams (corrId, fId, resp)
liftIO $ sendResponse $ H.responseStreaming N.ok200 [] $ streamBody t_
where
streamBody t_ send done = do
@@ -250,10 +260,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 :: Maybe 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 +274,9 @@ 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
_ -> maybe False (dummyVerifyCmd Nothing authorized) tAuth `seq` VRFailed
-- TODO verify with DH authorization
req `verifyWith` k = if verifyCmdAuthorization Nothing tAuth authorized k then VRVerified req else VRFailed
processXFTPRequest :: HTTP2Body -> XFTPRequest -> M (FileResponse, Maybe ServerFile)
processXFTPRequest HTTP2Body {bodyPart} = \case
@@ -286,7 +297,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 +321,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 +334,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
src/Simplex/FileTransfer/Server/Env.hs
+2 -2
View File
@@ -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
src/Simplex/FileTransfer/Server/Store.hs
+4 -4
View File
@@ -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 ->
src/Simplex/FileTransfer/Server/StoreLog.hs
+2 -2
View File
@@ -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
src/Simplex/FileTransfer/Types.hs
+6 -6
View File
@@ -102,7 +102,7 @@ data RcvFileChunkReplica = RcvFileChunkReplica
{ rcvChunkReplicaId :: Int64,
server :: XFTPServer,
replicaId :: ChunkReplicaId,
replicaKey :: C.APrivateSignKey,
replicaKey :: C.APrivateAuthKey,
received :: Bool,
delay :: Maybe Int64,
retries :: Int
@@ -190,8 +190,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)
@@ -199,8 +199,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
@@ -230,7 +230,7 @@ data DeletedSndChunkReplica = DeletedSndChunkReplica
userId :: Int64,
server :: XFTPServer,
replicaId :: ChunkReplicaId,
replicaKey :: C.APrivateSignKey,
replicaKey :: C.APrivateAuthKey,
chunkDigest :: FileDigest,
delay :: Maybe Int64,
retries :: Int
src/Simplex/Messaging/Agent.hs
+11 -10
View File
@@ -162,9 +162,10 @@ 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 Simplex.Messaging.ServiceScheme (ServiceScheme (..))
import Simplex.Messaging.Transport (THandleParams (sessionId))
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Util
import Simplex.Messaging.Version
@@ -1037,7 +1038,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
@@ -1641,10 +1642,10 @@ registerNtfToken' c suppliedDeviceToken suppliedNtfMode =
createToken =
getNtfServer c >>= \case
Just ntfServer ->
asks (cmdSignAlg . config) >>= \case
C.SignAlg a -> do
asks (rcvAuthAlg . 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)
@@ -2067,7 +2068,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
where
processEND = \case
Just (Right clnt)
| sessId == sessionId clnt -> do
| sessId == sessionId (thParams clnt) -> do
removeSubscription c connId
notify' END
pure "END"
@@ -2106,7 +2107,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 <CONF>:" <> logSecret srvMsgId
AgentConfig {smpClientVRange, smpAgentVRange, e2eEncryptVRange} <- asks config
@@ -2252,7 +2253,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
@@ -2506,9 +2507,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 $ sndAuthAlg . 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
src/Simplex/Messaging/Agent/Client.hs
+32 -27
View File
@@ -200,9 +200,10 @@ import Simplex.Messaging.Protocol
QueueIdsKeys (..),
RcvMessage (..),
RcvNtfPublicDhKey,
NtfPublicAuthKey,
SMPMsgMeta (..),
SProtocolType (..),
SndPublicVerifyKey,
SndPublicAuthKey,
SubscriptionMode (..),
UserProtocol,
XFTPServer,
@@ -212,6 +213,7 @@ import Simplex.Messaging.Protocol
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport (THandleParams (..))
import Simplex.Messaging.Transport.Client (TransportHost)
import Simplex.Messaging.Util
import Simplex.Messaging.Version
@@ -507,8 +509,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 +609,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 +864,18 @@ 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 ra <- asks $ rcvAuthAlg . config
C.AuthAlg sa <- asks $ sndAuthAlg . 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 ra g
(sKey, _) <- atomically $ C.generateAuthKeyPair sa 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 +899,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 +953,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 (rcvAuthAlg . 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 +1059,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)
@@ -1114,7 +1119,7 @@ getQueueMessage :: AgentMonad m => AgentClient -> RcvQueue -> m (Maybe SMPMsgMet
getQueueMessage c rq@RcvQueue {server, rcvId, rcvPrivateKey} = do
atomically createTakeGetLock
(v, msg_) <- withSMPClient c rq "GET" $ \smp ->
(thVersion smp,) <$> getSMPMessage smp rcvPrivateKey rcvId
(thVersion $ thParams smp,) <$> getSMPMessage smp rcvPrivateKey rcvId
mapM (decryptMeta v) msg_
where
decryptMeta v msg@SMP.RcvMessage {msgId} = SMP.rcvMessageMeta msgId <$> decryptSMPMessage v rq msg
@@ -1132,23 +1137,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 <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 <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 +1198,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 +1222,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 +1242,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 +1254,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 +1264,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
src/Simplex/Messaging/Agent/Env/SQLite.hs
+9 -4
View File
@@ -57,6 +57,7 @@ import Simplex.Messaging.Client
import Simplex.Messaging.Client.Agent ()
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.Ratchet (supportedE2EEncryptVRange)
import Simplex.Messaging.Notifications.Client (defaultNTFClientConfig)
import Simplex.Messaging.Notifications.Types
import Simplex.Messaging.Protocol (NtfServer, XFTPServer, XFTPServerWithAuth, supportedSMPClientVRange)
import Simplex.Messaging.TMap (TMap)
@@ -82,7 +83,8 @@ data InitialAgentServers = InitialAgentServers
data AgentConfig = AgentConfig
{ tcpPort :: ServiceName,
cmdSignAlg :: C.SignAlg,
rcvAuthAlg :: C.AuthAlg,
sndAuthAlg :: C.AuthAlg,
connIdBytes :: Int,
tbqSize :: Natural,
smpCfg :: ProtocolClientConfig,
@@ -147,11 +149,14 @@ defaultAgentConfig :: AgentConfig
defaultAgentConfig =
AgentConfig
{ tcpPort = "5224",
cmdSignAlg = C.SignAlg C.SEd448,
-- while the current client version supports X25519, it can only be enabled once support for SMP v6 is dropped,
-- and all servers are required to support v7 to be compatible.
rcvAuthAlg = C.AuthAlg C.SEd25519, -- this will stay as Ed25519
sndAuthAlg = C.AuthAlg C.SEd25519, -- TODO replace with X25519 when switching to v7
connIdBytes = 12,
tbqSize = 64,
smpCfg = defaultClientConfig {defaultTransport = (show defaultSMPPort, transport @TLS)},
ntfCfg = defaultClientConfig {defaultTransport = ("443", transport @TLS)},
smpCfg = defaultSMPClientConfig {defaultTransport = (show defaultSMPPort, transport @TLS)},
ntfCfg = defaultNTFClientConfig {defaultTransport = ("443", transport @TLS)},
xftpCfg = defaultXFTPClientConfig,
reconnectInterval = defaultReconnectInterval,
messageRetryInterval = defaultMessageRetryInterval,
src/Simplex/Messaging/Agent/NtfSubSupervisor.hs
+2 -2
View File
@@ -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 (rcvAuthAlg . 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
src/Simplex/Messaging/Agent/Protocol.hs
+3 -3
View File
@@ -196,7 +196,7 @@ import Simplex.Messaging.Protocol
SMPMsgMeta,
SMPServer,
SMPServerWithAuth,
SndPublicVerifyKey,
SndPublicAuthKey,
SubscriptionMode,
legacyEncodeServer,
legacyServerP,
@@ -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
src/Simplex/Messaging/Agent/Store.hs
+17 -15
View File
@@ -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
src/Simplex/Messaging/Agent/Store/SQLite.hs
+11 -11
View File
@@ -783,7 +783,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_) =
@@ -1987,9 +1987,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
@@ -2028,7 +2028,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
@@ -2398,7 +2398,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}
@@ -2492,7 +2492,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,
@@ -2670,12 +2670,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
@@ -2823,7 +2823,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
@@ -2844,7 +2844,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
@@ -2937,7 +2937,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}
src/Simplex/Messaging/Client.hs
+92 -71
View File
@@ -28,7 +28,7 @@
module Simplex.Messaging.Client
( -- * Connect (disconnect) client to (from) SMP server
TransportSession,
ProtocolClient (thVersion, sessionId, sessionTs),
ProtocolClient (thParams, sessionTs),
SMPClient,
getProtocolClient,
closeProtocolClient,
@@ -63,6 +63,7 @@ module Simplex.Messaging.Client
NetworkConfig (..),
TransportSessionMode (..),
defaultClientConfig,
defaultSMPClientConfig,
defaultNetworkConfig,
transportClientConfig,
chooseTransportHost,
@@ -74,6 +75,7 @@ module Simplex.Messaging.Client
-- * For testing
PCTransmission,
mkTransmission,
authTransmission,
clientStub,
)
where
@@ -83,7 +85,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
@@ -115,12 +119,9 @@ import System.Timeout (timeout)
-- Use 'getSMPClient' to connect to an SMP server and create a client handle.
data ProtocolClient err msg = ProtocolClient
{ action :: Maybe (Async ()),
sessionId :: SessionId,
thParams :: THandleParams,
sessionTs :: UTCTime,
thVersion :: Version,
timeoutPerBlock :: Int,
blockSize :: Int,
batch :: Bool,
client_ :: PClient err msg
}
@@ -131,29 +132,34 @@ data PClient err msg = PClient
tcpTimeout :: Int,
batchDelay :: Maybe Int,
pingErrorCount :: TVar Int,
clientCorrId :: TVar Natural,
clientCorrId :: TVar ChaChaDRG,
sentCommands :: TMap CorrId (Request err msg),
sndQ :: TBQueue ByteString,
rcvQ :: TBQueue (NonEmpty (SignedTransmission err msg)),
msgQ :: Maybe (TBQueue (ServerTransmission msg))
}
clientStub :: ByteString -> STM (ProtocolClient err msg)
clientStub sessionId = do
clientStub :: TVar ChaChaDRG -> ByteString -> Version -> Maybe THandleAuth -> STM (ProtocolClient err msg)
clientStub g sessionId thVersion thAuth = do
connected <- newTVar False
clientCorrId <- newTVar 0
clientCorrId <- C.newRandomDRG g
sentCommands <- TM.empty
sndQ <- newTBQueue 100
rcvQ <- newTBQueue 100
return
ProtocolClient
{ action = Nothing,
sessionId,
thParams =
THandleParams
{ sessionId,
thVersion,
thAuth,
blockSize = smpBlockSize,
implySessId = thVersion >= authCmdsSMPVersion,
batch = True
},
sessionTs = undefined,
thVersion = 5,
timeoutPerBlock = undefined,
blockSize = smpBlockSize,
batch = undefined,
client_ =
PClient
{ connected,
@@ -173,7 +179,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)
@@ -251,16 +257,19 @@ data ProtocolClientConfig = ProtocolClientConfig
}
-- | Default protocol client configuration.
defaultClientConfig :: ProtocolClientConfig
defaultClientConfig =
defaultClientConfig :: VersionRange -> ProtocolClientConfig
defaultClientConfig serverVRange =
ProtocolClientConfig
{ qSize = 64,
defaultTransport = ("443", transport @TLS),
networkConfig = defaultNetworkConfig,
serverVRange = supportedSMPServerVRange,
serverVRange,
batchDelay = Nothing
}
defaultSMPClientConfig :: ProtocolClientConfig
defaultSMPClientConfig = defaultClientConfig supportedClientSMPRelayVRange
data Request err msg = Request
{ entityId :: EntityId,
responseVar :: TMVar (Either (ProtocolClientError err) msg)
@@ -306,8 +315,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)
@@ -319,7 +328,7 @@ getProtocolClient transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize,
mkProtocolClient transportHost = do
connected <- newTVar False
pingErrorCount <- newTVar 0
clientCorrId <- newTVar 0
clientCorrId <- C.newRandomDRG g
sentCommands <- TM.empty
sndQ <- newTBQueue qSize
rcvQ <- newTBQueue qSize
@@ -360,13 +369,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 {params} -> do
sessionTs <- getCurrentTime
let timeoutPerBlock = (blockSize * tcpTimeoutPerKb) `div` 1024
c' = ProtocolClient {action = Nothing, client_ = c, sessionId, thVersion, sessionTs, timeoutPerBlock, blockSize, batch}
let timeoutPerBlock = (blockSize params * tcpTimeoutPerKb) `div` 1024
c' = ProtocolClient {action = Nothing, client_ = c, thParams = params, sessionTs, timeoutPerBlock}
atomically $ do
writeTVar (connected c) True
putTMVar cVar $ Right c'
@@ -468,13 +478,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 +491,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 +499,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
@@ -512,13 +521,13 @@ writeSMPMessage :: SMPClient -> RecipientId -> BrokerMsg -> IO ()
writeSMPMessage c rId msg = atomically $ mapM_ (`writeTBQueue` serverTransmission c rId msg) (msgQ $ client_ c)
serverTransmission :: ProtocolClient err msg -> RecipientId -> msg -> ServerTransmission msg
serverTransmission ProtocolClient {thVersion, sessionId, client_ = PClient {transportSession}} entityId message =
serverTransmission ProtocolClient {thParams = THandleParams {thVersion, sessionId}, client_ = PClient {transportSession}} entityId message =
(transportSession, thVersion, sessionId, entityId, message)
-- | 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 +537,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 +572,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 +591,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 +602,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,14 +632,14 @@ 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))
sendProtocolCommands c@ProtocolClient {batch, blockSize} cs = do
sendProtocolCommands c@ProtocolClient {thParams = THandleParams {batch, blockSize}} cs = do
bs <- batchTransmissions' batch blockSize <$> mapM (mkTransmission c) cs
validate . concat =<< mapM (sendBatch c) bs
where
@@ -647,16 +656,16 @@ sendProtocolCommands c@ProtocolClient {batch, blockSize} cs = do
diff = L.length cs - length rs
streamProtocolCommands :: forall err msg. ProtocolEncoding err (ProtoCommand msg) => ProtocolClient err msg -> NonEmpty (ClientCommand msg) -> ([Response err msg] -> IO ()) -> IO ()
streamProtocolCommands c@ProtocolClient {batch, blockSize} cs cb = do
streamProtocolCommands c@ProtocolClient {thParams = THandleParams {batch, blockSize}} cs cb = do
bs <- batchTransmissions' batch blockSize <$> mapM (mkTransmission c) cs
mapM_ (cb <=< sendBatch c) bs
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 +676,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 c@ProtocolClient {client_ = PClient {sndQ}, batch, blockSize} pKey entId cmd =
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}, thParams = THandleParams {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 +702,34 @@ 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 {thParams, client_ = PClient {clientCorrId, sentCommands}} (pKey_, entId, cmd) = do
corrId <- atomically getNextCorrId
let t = signTransmission $ encodeTransmission thVersion sessionId (corrId, entId, cmd)
let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (corrId, entId, cmd)
auth = authTransmission (thAuth thParams) pKey_ corrId tForAuth
r <- atomically $ mkRequest corrId
pure (t, r)
pure ((,tToSend) <$> auth, r)
where
getNextCorrId :: STM CorrId
getNextCorrId = do
i <- stateTVar clientCorrId $ \i -> (i, i + 1)
pure . CorrId $ bshow i
signTransmission :: ByteString -> SentRawTransmission
signTransmission t = ((`C.sign` t) <$> pKey, t)
getNextCorrId = CorrId <$> C.randomBytes 24 clientCorrId -- also used as nonce
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 (Maybe TransmissionAuth)
authTransmission thAuth pKey_ (CorrId corrId) t = traverse authenticate pKey_
where
authenticate :: C.APrivateAuthKey -> Either TransportError TransmissionAuth
authenticate (C.APrivateAuthKey a pk) = case a of
C.SX25519 -> case thAuth of
Just THandleAuth {peerPubKey} -> Right $ TAAuthenticator $ C.cbAuthenticate peerPubKey pk (C.cbNonce corrId) 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 $ TASignature $ C.ASignature (C.sAlgorithm @a) (C.sign' pk t)
$(J.deriveJSON (enumJSON $ dropPrefix "HM") ''HostMode)
$(J.deriveJSON (enumJSON $ dropPrefix "TSM") ''TransportSessionMode)
src/Simplex/Messaging/Client/Agent.hs
+29 -27
View File
@@ -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
@@ -74,7 +75,7 @@ data SMPClientAgentConfig = SMPClientAgentConfig
defaultSMPClientAgentConfig :: SMPClientAgentConfig
defaultSMPClientAgentConfig =
SMPClientAgentConfig
{ smpCfg = defaultClientConfig {defaultTransport = ("5223", transport @TLS)},
{ smpCfg = defaultSMPClientConfig {defaultTransport = ("5223", transport @TLS)},
reconnectInterval =
RetryInterval
{ initialInterval = second,
@@ -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
src/Simplex/Messaging/Crypto.hs
+186 -10
View File
@@ -8,6 +8,7 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
@@ -36,7 +37,7 @@ module Simplex.Messaging.Crypto
Algorithm (..),
SAlgorithm (..),
Alg (..),
SignAlg (..),
AuthAlg (..),
DhAlg (..),
DhAlgorithm,
PrivateKey (..),
@@ -53,23 +54,32 @@ module Simplex.Messaging.Crypto
APublicVerifyKey (..),
APrivateDhKey (..),
APublicDhKey (..),
APrivateAuthKey (..),
APublicAuthKey (..),
CryptoPublicKey (..),
CryptoPrivateKey (..),
AAuthKeyPair,
KeyPair,
KeyPairX25519,
ASignatureKeyPair,
DhSecret (..),
DhSecretX25519,
ADhSecret (..),
KeyHash (..),
newRandom,
newRandomDRG,
generateAKeyPair,
generateKeyPair,
generateSignatureKeyPair,
generateAuthKeyPair,
generateDhKeyPair,
privateToX509,
x509ToPublic,
x509ToPrivate,
publicKey,
signatureKeyPair,
publicToX509,
encodeASNObj,
-- * key encoding/decoding
encodePubKey,
@@ -84,6 +94,7 @@ module Simplex.Messaging.Crypto
CryptoSignature (..),
SignatureSize (..),
SignatureAlgorithm,
AuthAlgorithm,
AlgorithmI (..),
sign,
sign',
@@ -91,6 +102,12 @@ module Simplex.Messaging.Crypto
verify',
validSignatureSize,
-- * crypto_box authenticator, as discussed in https://groups.google.com/g/sci.crypt/c/73yb5a9pz2Y/m/LNgRO7IYXOwJ
CbAuthenticator (..),
cbAuthenticatorSize,
cbAuthenticate,
cbVerify,
-- * DH derivation
dh',
dhBytes',
@@ -115,8 +132,10 @@ module Simplex.Messaging.Crypto
CbNonce (unCbNonce),
pattern CbNonce,
cbEncrypt,
cbEncryptNoPad,
cbEncryptMaxLenBS,
cbDecrypt,
cbDecryptNoPad,
sbDecrypt_,
sbEncrypt_,
cbNonce,
@@ -147,10 +166,13 @@ module Simplex.Messaging.Crypto
Certificate,
signCertificate,
signX509,
verifyX509,
certificateFingerprint,
signedFingerprint,
SignatureAlgorithmX509 (..),
SignedObject (..),
encodeCertChain,
certChainP,
-- * Cryptography error type
CryptoError (..),
@@ -173,7 +195,7 @@ import Crypto.Cipher.AES (AES256)
import qualified Crypto.Cipher.Types as AES
import qualified Crypto.Cipher.XSalsa as XSalsa
import qualified Crypto.Error as CE
import Crypto.Hash (Digest, SHA256 (..), SHA512, hash)
import Crypto.Hash (Digest, SHA256 (..), SHA512 (..), hash, hashDigestSize)
import qualified Crypto.MAC.Poly1305 as Poly1305
import qualified Crypto.PubKey.Curve25519 as X25519
import qualified Crypto.PubKey.Curve448 as X448
@@ -195,6 +217,7 @@ import qualified Data.ByteString.Char8 as B
import Data.ByteString.Lazy (fromStrict, toStrict)
import Data.Constraint (Dict (..))
import Data.Kind (Constraint, Type)
import qualified Data.List.NonEmpty as L
import Data.String
import Data.Type.Equality
import Data.Typeable (Proxy (Proxy), Typeable)
@@ -226,10 +249,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 +302,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 +454,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 +544,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 +566,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 +590,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 +643,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,21 +693,32 @@ 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
newRandomDRG :: TVar ChaChaDRG -> STM (TVar ChaChaDRG)
newRandomDRG g = newTVar =<< stateTVar g (`withDRG` drgNew)
generateAKeyPair :: AlgorithmI a => SAlgorithm a -> TVar ChaChaDRG -> STM AKeyPair
generateAKeyPair a g = bimap (APublicKey a) (APrivateKey a) <$> generateKeyPair g
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 +748,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 +766,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 +780,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
@@ -1021,6 +1145,18 @@ signX509 key = fst . objectToSignedExact f
signatureAlgorithmX509 key,
()
)
{-# INLINE signX509 #-}
verifyX509 :: (ASN1Object o, Eq o, Show o) => APublicVerifyKey -> SignedExact o -> Either String o
verifyX509 key exact = do
signature <- case signedAlg of
SignatureALG_IntrinsicHash PubKeyALG_Ed25519 -> ASignature SEd25519 <$> decodeSignature signedSignature
SignatureALG_IntrinsicHash PubKeyALG_Ed448 -> ASignature SEd448 <$> decodeSignature signedSignature
_ -> Left "unknown x509 signature algorithm"
if verify key signature $ getSignedData exact then Right signedObject else Left "bad signature"
where
Signed {signedObject, signedAlg, signedSignature} = getSigned exact
{-# INLINE verifyX509 #-}
certificateFingerprint :: SignedCertificate -> KeyHash
certificateFingerprint = signedFingerprint
@@ -1049,7 +1185,7 @@ instance SignatureAlgorithmX509 pk => SignatureAlgorithmX509 (a, pk) where
signatureAlgorithmX509 = signatureAlgorithmX509 . snd
-- | A wrapper to marshall signed ASN1 objects, like certificates.
newtype SignedObject a = SignedObject (SignedExact a)
newtype SignedObject a = SignedObject {getSignedExact :: SignedExact a}
instance (Typeable a, Eq a, Show a, ASN1Object a) => FromField (SignedObject a) where
fromField = fmap SignedObject . blobFieldDecoder decodeSignedObject
@@ -1057,6 +1193,20 @@ instance (Typeable a, Eq a, Show a, ASN1Object a) => FromField (SignedObject a)
instance (Eq a, Show a, ASN1Object a) => ToField (SignedObject a) where
toField (SignedObject s) = toField $ encodeSignedObject s
instance (Eq a, Show a, ASN1Object a) => Encoding (SignedObject a) where
smpEncode (SignedObject exact) = smpEncode . Large $ encodeSignedObject exact
smpP = fmap SignedObject . decodeSignedObject . unLarge <$?> smpP
encodeCertChain :: CertificateChain -> L.NonEmpty Large
encodeCertChain cc = L.fromList $ map Large blobs
where
CertificateChainRaw blobs = encodeCertificateChain cc
certChainP :: A.Parser CertificateChain
certChainP = do
rawChain <- CertificateChainRaw . map unLarge . L.toList <$> smpP
either (fail . show) pure $ decodeCertificateChain rawChain
-- | Signature verification.
--
-- Used by SMP servers to authorize SMP commands and by SMP agents to verify messages.
@@ -1073,10 +1223,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 (without padding).
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
@@ -1098,21 +1252,43 @@ cryptoBox secret nonce s = BA.convert tag <> c
cbDecrypt :: DhSecret X25519 -> CbNonce -> ByteString -> Either CryptoError ByteString
cbDecrypt (DhSecretX25519 secret) = sbDecrypt_ secret
-- | NaCl @crypto_box@ decrypt with a shared DH secret and 192-bit nonce (without unpadding).
cbDecryptNoPad :: DhSecret X25519 -> CbNonce -> ByteString -> Either CryptoError ByteString
cbDecryptNoPad (DhSecretX25519 secret) = sbDecryptNoPad_ secret
-- | NaCl @secret_box@ decrypt with a symmetric 256-bit key and 192-bit nonce.
sbDecrypt :: SbKey -> CbNonce -> ByteString -> Either CryptoError ByteString
sbDecrypt (SbKey key) = sbDecrypt_ key
-- | NaCl @crypto_box@ decrypt with a shared DH secret and 192-bit nonce.
sbDecrypt_ :: ByteArrayAccess key => key -> CbNonce -> ByteString -> Either CryptoError ByteString
sbDecrypt_ secret (CbNonce nonce) packet
sbDecrypt_ secret nonce = unPad <=< sbDecryptNoPad_ secret nonce
-- | NaCl @crypto_box@ decrypt with a shared DH secret and 192-bit nonce (without unpadding).
sbDecryptNoPad_ :: ByteArrayAccess key => key -> CbNonce -> ByteString -> Either CryptoError ByteString
sbDecryptNoPad_ secret (CbNonce nonce) packet
| B.length packet < 16 = Left CBDecryptError
| BA.constEq tag' tag = unPad msg
| BA.constEq tag' tag = Right msg
| otherwise = Left CBDecryptError
where
(tag', c) = B.splitAt 16 packet
(rs, msg) = xSalsa20 secret nonce c
tag = Poly1305.auth rs c
-- type for authentication scheme using NaCl @crypto_box@ over the sha512 digest of the message.
newtype CbAuthenticator = CbAuthenticator ByteString deriving (Eq, Show)
cbAuthenticatorSize :: Int
cbAuthenticatorSize = hashDigestSize SHA512 + authTagSize -- 64 + 16 = 80 bytes
-- create crypto_box authenticator for a message.
cbAuthenticate :: PublicKeyX25519 -> PrivateKeyX25519 -> CbNonce -> ByteString -> CbAuthenticator
cbAuthenticate k pk nonce msg = CbAuthenticator $ cbEncryptNoPad (dh' k pk) nonce (sha512Hash msg)
-- verify crypto_box authenticator for a message.
cbVerify :: PublicKeyX25519 -> PrivateKeyX25519 -> CbNonce -> CbAuthenticator -> ByteString -> Bool
cbVerify k pk nonce (CbAuthenticator s) authorized = cbDecryptNoPad (dh' k pk) nonce s == Right (sha512Hash authorized)
newtype CbNonce = CryptoBoxNonce {unCbNonce :: ByteString}
deriving (Eq, Show)
src/Simplex/Messaging/Encoding.hs
+1 -1
View File
@@ -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
src/Simplex/Messaging/Notifications/Client.hs
+15 -11
View File
@@ -10,6 +10,7 @@ import Data.Word (Word16)
import Simplex.Messaging.Client
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Notifications.Protocol
import Simplex.Messaging.Notifications.Transport (supportedClientNTFVRange)
import Simplex.Messaging.Protocol (ErrorType)
import Simplex.Messaging.Util (bshow)
@@ -17,50 +18,53 @@ type NtfClient = ProtocolClient ErrorType NtfResponse
type NtfClientError = ProtocolClientError ErrorType
ntfRegisterToken :: NtfClient -> C.APrivateSignKey -> NewNtfEntity 'Token -> ExceptT NtfClientError IO (NtfTokenId, C.PublicKeyX25519)
defaultNTFClientConfig :: ProtocolClientConfig
defaultNTFClientConfig = defaultClientConfig supportedClientNTFVRange
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 ()
src/Simplex/Messaging/Notifications/Protocol.hs
+6 -6
View File
@@ -124,8 +124,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 +206,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
| isNothing 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
| isNothing auth || B.null entityId -> Left $ CMD NO_AUTH
| otherwise -> Right cmd
where
sigNoEntity
| isNothing sig = Left $ CMD NO_AUTH
| isNothing auth = Left $ CMD NO_AUTH
| not (B.null entityId) = Left $ CMD HAS_AUTH
| otherwise = Right cmd
src/Simplex/Messaging/Notifications/Server.hs
+23 -19
View File
@@ -48,8 +48,8 @@ import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Server
import Simplex.Messaging.Server.Stats
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport (ATransport (..), THandle (..), TProxy, Transport (..))
import Simplex.Messaging.Transport.Server (runTransportServer)
import Simplex.Messaging.Transport (ATransport (..), THandle (..), THandleAuth (..), THandleParams (..), TProxy, Transport (..))
import Simplex.Messaging.Transport.Server (runTransportServer, tlsServerCredentials)
import Simplex.Messaging.Util
import System.Exit (exitFailure)
import System.IO (BufferMode (..), hPutStrLn, hSetBuffering)
@@ -82,12 +82,16 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do
runServer :: (ServiceName, ATransport) -> M ()
runServer (tcpPort, ATransport t) = do
serverParams <- asks tlsServerParams
runTransportServer started tcpPort serverParams tCfg (runClient t)
serverSignKey <- either fail pure . fromTLSCredentials $ tlsServerCredentials serverParams
runTransportServer started tcpPort serverParams tCfg (runClient serverSignKey t)
fromTLSCredentials (_, pk) = C.x509ToPrivate (pk, []) >>= C.privKey
runClient :: Transport c => TProxy c -> c -> M ()
runClient _ h = do
runClient :: Transport c => C.APrivateSignKey -> TProxy c -> c -> M ()
runClient signKey _ h = do
kh <- asks serverIdentity
liftIO (runExceptT $ ntfServerHandshake h kh supportedNTFServerVRange) >>= \case
ks <- atomically . C.generateKeyPair =<< asks random
NtfServerConfig {ntfServerVRange} <- asks config
liftIO (runExceptT $ ntfServerHandshake signKey h ks kh ntfServerVRange) >>= \case
Right th -> runNtfClientTransport th
Left _ -> pure ()
@@ -335,10 +339,10 @@ updateTknStatus NtfTknData {ntfTknId, tknStatus} status = do
when (old /= status) $ withNtfLog $ \sl -> logTokenStatus sl ntfTknId status
runNtfClientTransport :: Transport c => THandle c -> M ()
runNtfClientTransport th@THandle {sessionId} = do
runNtfClientTransport th@THandle {params} = do
qSize <- asks $ clientQSize . config
ts <- liftIO getSystemTime
c <- atomically $ newNtfServerClient qSize sessionId ts
c <- atomically $ newNtfServerClient qSize params ts
s <- asks subscriber
ps <- asks pushServer
expCfg <- asks $ inactiveClientExpiration . config
@@ -352,7 +356,7 @@ clientDisconnected :: NtfServerClient -> IO ()
clientDisconnected NtfServerClient {connected} = atomically $ writeTVar connected False
receive :: Transport c => THandle c -> NtfServerClient -> M ()
receive th NtfServerClient {rcvQ, sndQ, rcvActiveAt} = forever $ do
receive th@THandle {params = THandleParams {thAuth}} NtfServerClient {rcvQ, sndQ, rcvActiveAt} = forever $ do
ts <- liftIO $ tGet th
forM_ ts $ \t@(_, _, (corrId, entId, cmdOrError)) -> do
atomically . writeTVar rcvActiveAt =<< liftIO getSystemTime
@@ -360,16 +364,16 @@ receive th NtfServerClient {rcvQ, sndQ, rcvActiveAt} = forever $ do
case cmdOrError of
Left e -> write sndQ (corrId, entId, NRErr e)
Right cmd ->
verifyNtfTransmission t cmd >>= \case
verifyNtfTransmission ((,C.cbNonce (SMP.bs corrId)) <$> thAuth) t cmd >>= \case
VRVerified req -> write rcvQ req
VRFailed -> write sndQ (corrId, entId, NRErr AUTH)
where
write q t = atomically $ writeTBQueue q t
send :: Transport c => THandle c -> NtfServerClient -> IO ()
send h@THandle {thVersion = v} NtfServerClient {sndQ, sessionId, sndActiveAt} = forever $ do
send h@THandle {params} NtfServerClient {sndQ, sndActiveAt} = forever $ do
t <- atomically $ readTBQueue sndQ
void . liftIO $ tPut h [(Nothing, encodeTransmission v sessionId t)]
void . liftIO $ tPut h [Right (Nothing, encodeTransmission params t)]
atomically . writeTVar sndActiveAt =<< liftIO getSystemTime
-- instance Show a => Show (TVar a) where
@@ -377,14 +381,14 @@ 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 :: Maybe (THandleAuth, C.CbNonce) -> SignedTransmission ErrorType NtfCmd -> NtfCmd -> M VerificationResult
verifyNtfTransmission auth_ (tAuth, authorized, (corrId, entId, _)) cmd = do
st <- asks store
case cmd of
NtfCmd SToken c@(TNEW tkn@(NewNtfTkn _ k _)) -> do
r_ <- atomically $ getNtfTokenRegistration st tkn
pure $
if verifyCmdSignature sig_ signed k
if verifyCmdAuthorization auth_ tAuth authorized k
then case r_ of
Just t@NtfTknData {tknVerifyKey}
| k == tknVerifyKey -> verifiedTknCmd t c
@@ -405,7 +409,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 $ maybe False (dummyVerifyCmd auth_ authorized) tAuth `seq` VRFailed
NtfCmd SSubscription PING -> pure $ VRVerified $ NtfReqPing corrId entId
NtfCmd SSubscription c -> do
s_ <- atomically $ getNtfSubscription st entId
@@ -413,7 +417,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 $ maybe False (dummyVerifyCmd auth_ authorized) tAuth `seq` VRFailed
where
verifiedTknCmd t c = VRVerified (NtfReqCmd SToken (NtfTkn t) (corrId, entId, c))
verifiedSubCmd s c = VRVerified (NtfReqCmd SSubscription (NtfSub s) (corrId, entId, c))
@@ -421,10 +425,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 verifyCmdAuthorization auth_ tAuth authorized tknVerifyKey
then positiveVerificationResult t
else VRFailed
_ -> maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed
_ -> maybe False (dummyVerifyCmd auth_ authorized) tAuth `seq` VRFailed
verifyToken' :: Maybe NtfTknData -> VerificationResult -> M VerificationResult
verifyToken' t_ = verifyToken t_ . const
src/Simplex/Messaging/Notifications/Server/Env.hs
+11 -10
View File
@@ -12,7 +12,6 @@ import Control.Concurrent.Async (Async)
import Control.Logger.Simple
import Control.Monad.IO.Unlift
import Crypto.Random
import Data.ByteString.Char8 (ByteString)
import Data.Int (Int64)
import Data.List.NonEmpty (NonEmpty)
import Data.Time.Clock (getCurrentTime)
@@ -33,8 +32,9 @@ import Simplex.Messaging.Protocol (CorrId, SMPServer, Transmission)
import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport (ATransport)
import Simplex.Messaging.Transport (ATransport, THandleParams)
import Simplex.Messaging.Transport.Server (TransportServerConfig, loadFingerprint, loadTLSServerParams)
import Simplex.Messaging.Version (VersionRange)
import System.IO (IOMode (..))
import System.Mem.Weak (Weak)
import UnliftIO.STM
@@ -60,6 +60,7 @@ data NtfServerConfig = NtfServerConfig
logStatsStartTime :: Int64,
serverStatsLogFile :: FilePath,
serverStatsBackupFile :: Maybe FilePath,
ntfServerVRange :: VersionRange,
transportConfig :: TransportServerConfig
}
@@ -89,7 +90,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 +103,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
@@ -158,17 +159,17 @@ data NtfRequest
data NtfServerClient = NtfServerClient
{ rcvQ :: TBQueue NtfRequest,
sndQ :: TBQueue (Transmission NtfResponse),
sessionId :: ByteString,
ntfThParams :: THandleParams,
connected :: TVar Bool,
rcvActiveAt :: TVar SystemTime,
sndActiveAt :: TVar SystemTime
}
newNtfServerClient :: Natural -> ByteString -> SystemTime -> STM NtfServerClient
newNtfServerClient qSize sessionId ts = do
newNtfServerClient :: Natural -> THandleParams -> SystemTime -> STM NtfServerClient
newNtfServerClient qSize ntfThParams ts = do
rcvQ <- newTBQueue qSize
sndQ <- newTBQueue qSize
connected <- newTVar True
rcvActiveAt <- newTVar ts
sndActiveAt <- newTVar ts
return NtfServerClient {rcvQ, sndQ, sessionId, connected, rcvActiveAt, sndActiveAt}
return NtfServerClient {rcvQ, sndQ, ntfThParams, connected, rcvActiveAt, sndActiveAt}
src/Simplex/Messaging/Notifications/Server/Main.hs
+2
View File
@@ -19,6 +19,7 @@ import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Notifications.Server (runNtfServer)
import Simplex.Messaging.Notifications.Server.Env (NtfServerConfig (..), defaultInactiveClientExpiration)
import Simplex.Messaging.Notifications.Server.Push.APNS (defaultAPNSPushClientConfig)
import Simplex.Messaging.Notifications.Transport (supportedServerNTFVRange)
import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern NtfServer)
import Simplex.Messaging.Server.CLI
import Simplex.Messaging.Server.Expiration
@@ -139,6 +140,7 @@ ntfServerCLI cfgPath logPath =
logStatsStartTime = 0, -- seconds from 00:00 UTC
serverStatsLogFile = combine logPath "ntf-server-stats.daily.log",
serverStatsBackupFile = logStats $> combine logPath "ntf-server-stats.log",
ntfServerVRange = supportedServerNTFVRange,
transportConfig =
defaultTransportServerConfig
{ logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini
src/Simplex/Messaging/Notifications/Server/Store.hs
+3 -3
View File
@@ -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
}
src/Simplex/Messaging/Notifications/Server/StoreLog.hs
+3 -3
View File
@@ -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
}
src/Simplex/Messaging/Notifications/Transport.hs
+88 -24
View File
@@ -1,72 +1,136 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Simplex.Messaging.Notifications.Transport where
import Control.Monad (forM)
import Control.Monad.Except
import Data.Attoparsec.ByteString.Char8 (Parser)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import qualified Data.X509 as X
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding
import Simplex.Messaging.Transport
import Simplex.Messaging.Version
import Simplex.Messaging.Util (liftEitherWith)
ntfBlockSize :: Int
ntfBlockSize = 512
supportedNTFServerVRange :: VersionRange
supportedNTFServerVRange = mkVersionRange 1 1
authBatchCmdsNTFVersion :: Version
authBatchCmdsNTFVersion = 2
currentClientNTFVersion :: Version
currentClientNTFVersion = 1
currentServerNTFVersion :: Version
currentServerNTFVersion = 1
supportedClientNTFVRange :: VersionRange
supportedClientNTFVRange = mkVersionRange 1 currentClientNTFVersion
supportedServerNTFVRange :: VersionRange
supportedServerNTFVRange = mkVersionRange 1 currentServerNTFVersion
data NtfServerHandshake = NtfServerHandshake
{ ntfVersionRange :: VersionRange,
sessionId :: SessionId
sessionId :: SessionId,
-- pub key to agree shared secrets for command authorization and entity ID encryption.
authPubKey :: Maybe (X.SignedExact X.PubKey)
}
data NtfClientHandshake = NtfClientHandshake
{ -- | agreed SMP notifications server protocol version
ntfVersion :: 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 NtfServerHandshake where
smpEncode NtfServerHandshake {ntfVersionRange, sessionId} =
smpEncode (ntfVersionRange, sessionId)
smpEncode NtfServerHandshake {ntfVersionRange, sessionId, authPubKey} =
B.concat
[ smpEncode (ntfVersionRange, sessionId),
encodeAuthEncryptCmds (maxVersion ntfVersionRange) $ C.SignedObject <$> authPubKey
]
smpP = do
(ntfVersionRange, sessionId) <- smpP
pure NtfServerHandshake {ntfVersionRange, sessionId}
-- TODO drop SMP v6: remove special parser and make key non-optional
authPubKey <- authEncryptCmdsP (maxVersion ntfVersionRange) $ C.getSignedExact <$> smpP
pure NtfServerHandshake {ntfVersionRange, sessionId, authPubKey}
encodeAuthEncryptCmds :: Encoding a => Version -> Maybe a -> ByteString
encodeAuthEncryptCmds v k
| v >= authBatchCmdsNTFVersion = maybe "" smpEncode k
| otherwise = ""
authEncryptCmdsP :: Version -> Parser a -> Parser (Maybe a)
authEncryptCmdsP v p = if v >= authBatchCmdsNTFVersion then Just <$> p else pure Nothing
instance Encoding NtfClientHandshake where
smpEncode NtfClientHandshake {ntfVersion, keyHash} = smpEncode (ntfVersion, keyHash)
smpEncode NtfClientHandshake {ntfVersion, keyHash, authPubKey} =
smpEncode (ntfVersion, keyHash) <> encodeNtfAuthPubKey ntfVersion authPubKey
smpP = do
(ntfVersion, keyHash) <- smpP
pure NtfClientHandshake {ntfVersion, keyHash}
-- TODO drop SMP v6: remove special parser and make key non-optional
authPubKey <- ntfAuthPubKeyP ntfVersion
pure NtfClientHandshake {ntfVersion, keyHash, authPubKey}
ntfAuthPubKeyP :: Version -> Parser (Maybe C.PublicKeyX25519)
ntfAuthPubKeyP v = if v >= authBatchCmdsNTFVersion then Just <$> smpP else pure Nothing
encodeNtfAuthPubKey :: Version -> Maybe C.PublicKeyX25519 -> ByteString
encodeNtfAuthPubKey v k
| v >= authBatchCmdsNTFVersion = maybe "" smpEncode k
| otherwise = ""
-- | Notifcations server transport handshake.
ntfServerHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c)
ntfServerHandshake c kh ntfVRange = do
let th@THandle {sessionId} = ntfTHandle c
sendHandshake th $ NtfServerHandshake {sessionId, ntfVersionRange = ntfVRange}
ntfServerHandshake :: forall c. Transport c => C.APrivateSignKey -> c -> C.KeyPairX25519 -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c)
ntfServerHandshake serverSignKey c (k, pk) kh ntfVRange = do
let th@THandle {params = THandleParams {sessionId}} = ntfTHandle c
let sk = C.signX509 serverSignKey $ C.publicToX509 k
sendHandshake th $ NtfServerHandshake {sessionId, ntfVersionRange = ntfVRange, authPubKey = Just sk}
getHandshake th >>= \case
NtfClientHandshake {ntfVersion, keyHash}
NtfClientHandshake {ntfVersion = v, keyHash, authPubKey = k'}
| keyHash /= kh ->
throwError $ TEHandshake IDENTITY
| ntfVersion `isCompatible` ntfVRange ->
pure (th :: THandle c) {thVersion = ntfVersion}
| v `isCompatible` ntfVRange ->
pure $ ntfThHandle th v pk k'
| 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
let th@THandle {sessionId} = ntfTHandle c
NtfServerHandshake {sessionId = sessId, ntfVersionRange} <- getHandshake th
ntfClientHandshake :: forall c. Transport c => c -> C.KeyPairX25519 -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c)
ntfClientHandshake c (k, pk) keyHash ntfVRange = do
let th@THandle {params = THandleParams {sessionId}} = ntfTHandle c
NtfServerHandshake {sessionId = sessId, ntfVersionRange, authPubKey = sk'} <- getHandshake th
if sessionId /= sessId
then throwError TEBadSession
else case ntfVersionRange `compatibleVersion` ntfVRange of
Just (Compatible ntfVersion) -> do
sendHandshake th $ NtfClientHandshake {ntfVersion, keyHash}
pure (th :: THandle c) {thVersion = ntfVersion}
Just (Compatible v) -> do
sk_ <- forM sk' $ \exact -> liftEitherWith (const $ TEHandshake BAD_AUTH) $ do
serverKey <- getServerVerifyKey c
pubKey <- C.verifyX509 serverKey exact
C.x509ToPublic (pubKey, []) >>= C.pubKey
sendHandshake th $ NtfClientHandshake {ntfVersion = v, keyHash, authPubKey = Just k}
pure $ ntfThHandle th v pk sk_
Nothing -> throwError $ TEHandshake VERSION
ntfThHandle :: forall c. THandle c -> Version -> C.PrivateKeyX25519 -> Maybe C.PublicKeyX25519 -> THandle c
ntfThHandle th@THandle {params} v privKey k_ =
-- TODO drop SMP v6: make thAuth non-optional
let thAuth = (\k -> THandleAuth {peerPubKey = k, privKey}) <$> k_
v3 = v >= authBatchCmdsNTFVersion
params' = params {thVersion = v, thAuth, implySessId = v3, batch = v3}
in (th :: THandle c) {params = params'}
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, params}
where
params = THandleParams {sessionId = tlsUnique c, blockSize = ntfBlockSize, thVersion = 0, thAuth = Nothing, implySessId = False, batch = False}
src/Simplex/Messaging/Notifications/Types.hs
+4 -3
View File
@@ -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,
src/Simplex/Messaging/Protocol.hs
+132 -79
View File
@@ -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 (..),
@@ -124,6 +125,8 @@ module Simplex.Messaging.Protocol
-- * Parse and serialize
ProtocolMsgTag (..),
messageTagP,
TransmissionForAuth (..),
encodeTransmissionForAuth,
encodeTransmission,
transmissionP,
_smpP,
@@ -155,11 +158,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)
@@ -240,14 +245,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 = (Maybe TransmissionAuth, Signed, Transmission (Either e c))
type Signed = ByteString
-- | unparsed SMP transmission with signature.
data RawTransmission = RawTransmission
{ signature :: ByteString,
signed :: ByteString,
{ authenticator :: ByteString, -- signature or encrypted transmission hash
authorized :: ByteString, -- authorized transmission
sessId :: SessionId,
corrId :: ByteString,
entityId :: ByteString,
@@ -255,11 +260,32 @@ data RawTransmission = RawTransmission
}
deriving (Show)
data TransmissionAuth
= TASignature C.ASignature
| TAAuthenticator C.CbAuthenticator
deriving (Eq, Show)
-- this encoding is backwards compatible with v6 that used Maybe C.ASignature instead of TAuthorization
tAuthBytes :: Maybe TransmissionAuth -> ByteString
tAuthBytes = \case
Nothing -> ""
Just (TASignature s) -> C.signatureBytes s
Just (TAAuthenticator (C.CbAuthenticator s)) -> s
decodeTAuthBytes :: ByteString -> Either String (Maybe TransmissionAuth)
decodeTAuthBytes s
| B.null s = Right Nothing
| B.length s == C.cbAuthenticatorSize = Right . Just . TAAuthenticator $ C.CbAuthenticator s
| otherwise = Just . TASignature <$> C.decodeSignature s
instance IsString (Maybe TransmissionAuth) where
fromString = parseString $ B64.decode >=> C.decodeSignature >=> pure . fmap TASignature
-- | unparsed sent SMP transmission with signature, without session ID.
type SignedRawTransmission = (Maybe C.ASignature, SessionId, ByteString, ByteString)
type SignedRawTransmission = (Maybe TransmissionAuth, SessionId, ByteString, ByteString)
-- | unparsed sent SMP transmission with signature.
type SentRawTransmission = (Maybe C.ASignature, ByteString)
type SentRawTransmission = (Maybe TransmissionAuth, ByteString)
-- | SMP queue ID for the recipient.
type RecipientId = QueueId
@@ -278,10 +304,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
@@ -641,7 +671,7 @@ instance Encoding ClientMsgEnvelope where
data ClientMessage = ClientMessage PrivHeader ByteString
data PrivHeader
= PHConfirmation C.APublicVerifyKey
= PHConfirmation C.APublicAuthKey
| PHEmpty
deriving (Show)
@@ -942,13 +972,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
@@ -956,19 +986,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
@@ -1029,23 +1059,24 @@ data CommandError
deriving (Eq, Read, Show)
-- | SMP transmission parser.
transmissionP :: Parser RawTransmission
transmissionP = do
signature <- smpP
signed <- A.takeByteString
either fail pure $ parseAll (trn signature signed) signed
transmissionP :: THandleParams -> Parser RawTransmission
transmissionP THandleParams {sessionId, implySessId} = do
authenticator <- smpP
authorized <- A.takeByteString
either fail pure $ parseAll (trn authenticator authorized) authorized
where
trn signature signed = do
sessId <- smpP
trn authenticator authorized = do
sessId <- if implySessId then pure "" else smpP
let authorized' = if implySessId then smpEncode sessionId <> authorized else authorized
corrId <- smpP
entityId <- smpP
command <- A.takeByteString
pure RawTransmission {signature, signed, sessId, corrId, entityId, command}
pure RawTransmission {authenticator, authorized = 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
@@ -1071,8 +1102,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)
@@ -1101,10 +1132,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
| isNothing 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
@@ -1113,11 +1144,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
| isNothing 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
| isNothing auth || B.null queueId -> Left $ CMD NO_AUTH
| otherwise -> Right cmd
instance ProtocolEncoding ErrorType Cmd where
@@ -1128,8 +1159,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
@@ -1274,13 +1305,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 th = fmap concat . mapM tPutBatch . batchTransmissions (batch th) (blockSize th)
tPut :: Transport c => THandle c -> NonEmpty (Either TransportError SentRawTransmission) -> IO [Either TransportError ()]
tPut th@THandle {params} = fmap concat . mapM tPutBatch . batchTransmissions (batch params) (blockSize params)
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 ())
@@ -1292,42 +1323,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 (tAuthBytes auth) <> t
{-# INLINE tEncode #-}
tEncodeForBatch :: SentRawTransmission -> ByteString
@@ -1338,22 +1373,40 @@ tEncodeBatch1 :: SentRawTransmission -> ByteString
tEncodeBatch1 t = lenEncode 1 `B.cons` tEncodeForBatch t
{-# INLINE tEncodeBatch1 #-}
encodeTransmission :: ProtocolEncoding e c => Version -> ByteString -> Transmission c -> ByteString
encodeTransmission v sessionId (CorrId corrId, queueId, command) =
smpEncode (sessionId, corrId, queueId) <> encodeProtocol v command
-- tForAuth is lazy to avoid computing it when there is no key to sign
data TransmissionForAuth = TransmissionForAuth {tForAuth :: ~ByteString, tToSend :: ByteString}
encodeTransmissionForAuth :: ProtocolEncoding e c => THandleParams -> Transmission c -> TransmissionForAuth
encodeTransmissionForAuth THandleParams {thVersion = v, sessionId, implySessId} t =
TransmissionForAuth {tForAuth, tToSend = if implySessId then t' else tForAuth}
where
tForAuth = smpEncode sessionId <> t'
t' = encodeTransmission_ v t
{-# INLINE encodeTransmissionForAuth #-}
encodeTransmission :: ProtocolEncoding e c => THandleParams -> Transmission c -> ByteString
encodeTransmission THandleParams {thVersion = v, sessionId, implySessId} t =
if implySessId then t' else smpEncode sessionId <> t'
where
t' = encodeTransmission_ v t
{-# INLINE encodeTransmission #-}
encodeTransmission_ :: ProtocolEncoding e c => Version -> Transmission c -> ByteString
encodeTransmission_ v (CorrId corrId, queueId, command) =
smpEncode (corrId, queueId) <> encodeProtocol v command
{-# INLINE encodeTransmission_ #-}
-- | Receive and parse transmission from the TCP transport (ignoring any trailing padding).
tGetParse :: Transport c => THandle c -> IO (NonEmpty (Either TransportError RawTransmission))
tGetParse th = eitherList (tParse $ batch th) <$> tGetBlock th
tGetParse th@THandle {params} = eitherList (tParse params) <$> tGetBlock th
{-# INLINE tGetParse #-}
tParse :: Bool -> ByteString -> NonEmpty (Either TransportError RawTransmission)
tParse batch s
tParse :: THandleParams -> ByteString -> NonEmpty (Either TransportError RawTransmission)
tParse thParams@THandleParams {batch} s
| batch = eitherList (L.map (\(Large t) -> tParse1 t)) ts
| otherwise = [tParse1 s]
where
tParse1 = parse transmissionP TEBadBlock
tParse1 = parse (transmissionP thParams) TEBadBlock
ts = parse smpP TEBadBlock s
eitherList :: (a -> NonEmpty (Either e b)) -> Either e a -> NonEmpty (Either e b)
@@ -1361,14 +1414,14 @@ eitherList = either (\e -> [Left e])
-- | Receive client and server transmissions (determined by `cmd` type).
tGet :: forall err cmd c. (ProtocolEncoding err cmd, Transport c) => THandle c -> IO (NonEmpty (SignedTransmission err cmd))
tGet th@THandle {sessionId, thVersion = v} = L.map (tDecodeParseValidate sessionId v) <$> tGetParse th
tGet th@THandle {params} = L.map (tDecodeParseValidate params) <$> tGetParse th
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}
| sessId == sessionId ->
let decodedTransmission = (,corrId,entityId,command) <$> C.decodeSignature signature
in either (const $ tError corrId) (tParseValidate signed) decodedTransmission
tDecodeParseValidate :: forall err cmd. ProtocolEncoding err cmd => THandleParams -> Either TransportError RawTransmission -> SignedTransmission err cmd
tDecodeParseValidate THandleParams {sessionId, thVersion = v, implySessId} = \case
Right RawTransmission {authenticator, authorized, sessId, corrId, entityId, command}
| implySessId || sessId == sessionId ->
let decodedTransmission = (,corrId,entityId,command) <$> decodeTAuthBytes authenticator
in either (const $ tError corrId) (tParseValidate authorized) decodedTransmission
| otherwise -> (Nothing, "", (CorrId corrId, "", Left $ fromProtocolError @err @cmd PESession))
Left _ -> tError ""
where
src/Simplex/Messaging/Server.hs
+76 -43
View File
@@ -13,6 +13,7 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
-- |
-- Module : Simplex.Messaging.Server
@@ -31,7 +32,7 @@ module Simplex.Messaging.Server
( runSMPServer,
runSMPServerBlocking,
disconnectTransport,
verifyCmdSignature,
verifyCmdAuthorization,
dummyVerifyCmd,
randomId,
)
@@ -132,7 +133,9 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
runServer (tcpPort, ATransport t) = do
serverParams <- asks tlsServerParams
ss <- asks sockets
runTransportServerState ss started tcpPort serverParams tCfg (runClient t)
serverSignKey <- either fail pure . fromTLSCredentials $ tlsServerCredentials serverParams
runTransportServerState ss started tcpPort serverParams tCfg (runClient serverSignKey t)
fromTLSCredentials (_, pk) = C.x509ToPrivate (pk, []) >>= C.privKey
saveServer :: Bool -> M ()
saveServer keepMsgs = withLog closeStoreLog >> saveServerMessages keepMsgs >> saveServerStats
@@ -243,12 +246,13 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
]
liftIO $ threadDelay' interval
runClient :: Transport c => TProxy c -> c -> M ()
runClient tp h = do
runClient :: Transport c => C.APrivateSignKey -> TProxy c -> c -> M ()
runClient signKey tp h = do
kh <- asks serverIdentity
ks <- atomically . C.generateKeyPair =<< asks random
ServerConfig {smpServerVRange, smpHandshakeTimeout} <- asks config
labelMyThread $ "smp handshake for " <> transportName tp
liftIO (timeout smpHandshakeTimeout . runExceptT $ smpServerHandshake h kh smpServerVRange) >>= \case
liftIO (timeout smpHandshakeTimeout . runExceptT $ smpServerHandshake signKey h ks kh smpServerVRange) >>= \case
Just (Right th) -> runClientTransport th
_ -> pure ()
@@ -369,7 +373,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
CPSkip -> pure ()
runClientTransport :: Transport c => THandle c -> M ()
runClientTransport th@THandle {thVersion, sessionId} = do
runClientTransport th@THandle {params = THandleParams {thVersion, sessionId}} = do
q <- asks $ tbqSize . config
ts <- liftIO getSystemTime
active <- asks clients
@@ -414,7 +418,7 @@ cancelSub sub =
_ -> return ()
receive :: Transport c => THandle c -> Client -> M ()
receive th Client {rcvQ, sndQ, rcvActiveAt, sessionId} = do
receive th@THandle {params = THandleParams {thAuth}} Client {rcvQ, sndQ, rcvActiveAt, sessionId} = do
labelMyThread . B.unpack $ "client $" <> encode sessionId <> " receive"
forever $ do
ts <- L.toList <$> liftIO (tGet th)
@@ -424,10 +428,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 (tAuth, 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 ((,C.cbNonce (bs corrId)) <$> thAuth) tAuth authorized queueId cmd
where
verified = \case
VRVerified qr -> Right (qr, (corrId, queueId, cmd))
@@ -435,11 +439,12 @@ receive th Client {rcvQ, sndQ, rcvActiveAt, sessionId} = do
write q = mapM_ (atomically . writeTBQueue q) . L.nonEmpty
send :: Transport c => THandle c -> Client -> IO ()
send h@THandle {thVersion = v} Client {sndQ, sessionId, sndActiveAt} = do
send h@THandle {params} 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 (Nothing, encodeTransmission params t)) ts
atomically . writeTVar sndActiveAt =<< liftIO getSystemTime
where
tOrder :: Transmission BrokerMsg -> Int
@@ -449,7 +454,7 @@ send h@THandle {thVersion = v} Client {sndQ, sessionId, sndActiveAt} = do
_ -> 1
disconnectTransport :: Transport c => THandle c -> TVar SystemTime -> TVar SystemTime -> ExpirationConfig -> IO Bool -> IO ()
disconnectTransport THandle {connection, sessionId} rcvActiveAt sndActiveAt expCfg noSubscriptions = do
disconnectTransport THandle {connection, params = THandleParams {sessionId}} rcvActiveAt sndActiveAt expCfg noSubscriptions = do
labelMyThread . B.unpack $ "client $" <> encode sessionId <> " disconnectTransport"
loop
where
@@ -463,44 +468,69 @@ 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 =
-- This function verifies queue command authorization, with the objective to have constant time between the three AUTH error scenarios:
-- - the queue and party key exist, and the provided authorization has type matching queue key, but it is made with the different key.
-- - the queue and party key exist, but the provided authorization has incorrect type.
-- - the queue or party key do not exist.
-- In all cases, the time of the verification should depend only on the provided authorization type,
-- a dummy key is used to run verification in the last two cases, and failure is returned irrespective of the result.
verifyTransmission :: Maybe (THandleAuth, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> QueueId -> Cmd -> M VerificationResult
verifyTransmission auth_ tAuth 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 SSender SEND {} -> verifyCmd SSender $ verifyMaybe . senderKey
Cmd SRecipient (NEW k _ _ _) -> pure $ Nothing `verifiedWith` k
Cmd SRecipient _ -> verifyQueue (\q -> Just q `verifiedWith` recipientKey q) <$> get SRecipient
-- SEND will be accepted without authorization before the queue is secured with KEY command
Cmd SSender SEND {} -> verifyQueue (\q -> Just q `verified` maybe (isNothing tAuth) verify (senderKey q)) <$> get SSender
Cmd SSender PING -> pure $ VRVerified Nothing
Cmd SNotifier NSUB -> verifyCmd SNotifier $ verifyMaybe . fmap notifierKey . notifier
-- NSUB will not be accepted without authorization
Cmd SNotifier NSUB -> verifyQueue (\q -> maybe dummyVerify (Just q `verifiedWith`) (notifierKey <$> notifier q)) <$> get SNotifier
where
verifyCmd :: SParty p -> (QueueRec -> Bool) -> M VerificationResult
verifyCmd party f = do
st <- asks queueStore
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
verify = verifyCmdAuthorization auth_ tAuth authorized
dummyVerify = verify (dummyAuthKey tAuth) `seq` VRFailed
verifyQueue :: (QueueRec -> VerificationResult) -> Either ErrorType QueueRec -> VerificationResult
verifyQueue = either (\_ -> dummyVerify)
verified q cond = if cond then VRVerified q else VRFailed
verifiedWith q k = q `verified` verify k
get :: SParty p -> M (Either ErrorType QueueRec)
get party = do
st <- asks queueStore
atomically $ getQueue st party queueId
verifyCmdSignature :: Maybe C.ASignature -> ByteString -> C.APublicVerifyKey -> Bool
verifyCmdSignature sig_ signed key = maybe False (verify key) sig_
verifyCmdAuthorization :: Maybe (THandleAuth, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> C.APublicAuthKey -> Bool
verifyCmdAuthorization auth_ tAuth authorized key = maybe False (verify key) tAuth
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 -> TransmissionAuth -> Bool
verify (C.APublicAuthKey a k) = \case
TASignature (C.ASignature a' s) -> case testEquality a a' of
Just Refl -> C.verify' k s authorized
_ -> C.verify' (dummySignKey a') s authorized `seq` False
TAAuthenticator s -> case a of
C.SX25519 -> verifyCmdAuth auth_ k s authorized
_ -> verifyCmdAuth auth_ dummyKeyX25519 s authorized `seq` False
dummyVerifyCmd :: ByteString -> C.ASignature -> Bool
dummyVerifyCmd signed (C.ASignature _ s) = C.verify' (dummyPublicKey s) s signed
verifyCmdAuth :: Maybe (THandleAuth, C.CbNonce) -> C.PublicKeyX25519 -> C.CbAuthenticator -> ByteString -> Bool
verifyCmdAuth auth_ k authenticator authorized = case auth_ of
Just (THandleAuth {privKey}, nonce) -> C.cbVerify k privKey nonce authenticator authorized
Nothing -> False
dummyVerifyCmd :: Maybe (THandleAuth, C.CbNonce) -> ByteString -> TransmissionAuth -> Bool
dummyVerifyCmd auth_ authorized = \case
TASignature (C.ASignature a s) -> C.verify' (dummySignKey a) s authorized
TAAuthenticator s -> verifyCmdAuth auth_ dummyKeyX25519 s authorized
-- These dummy keys are used with `dummyVerify` function to mitigate timing attacks
-- by having the same time of the response whether a queue exists or nor, for all valid key/signature sizes
dummyPublicKey :: C.Signature a -> C.PublicKey a
dummyPublicKey = \case
C.SignatureEd25519 _ -> dummyKeyEd25519
C.SignatureEd448 _ -> dummyKeyEd448
dummySignKey :: C.SignatureAlgorithm a => C.SAlgorithm a -> C.PublicKey a
dummySignKey = \case
C.SEd25519 -> dummyKeyEd25519
C.SEd448 -> dummyKeyEd448
dummyAuthKey :: Maybe TransmissionAuth -> C.APublicAuthKey
dummyAuthKey = \case
Just (TASignature (C.ASignature a _)) -> case a of
C.SEd25519 -> C.APublicAuthKey C.SEd25519 dummyKeyEd25519
C.SEd448 -> C.APublicAuthKey C.SEd448 dummyKeyEd448
_ -> C.APublicAuthKey C.SX25519 dummyKeyX25519
dummyKeyEd25519 :: C.PublicKey 'C.Ed25519
dummyKeyEd25519 = "MCowBQYDK2VwAyEA139Oqs4QgpqbAmB0o7rZf6T19ryl7E65k4AYe0kE3Qs="
@@ -508,6 +538,9 @@ dummyKeyEd25519 = "MCowBQYDK2VwAyEA139Oqs4QgpqbAmB0o7rZf6T19ryl7E65k4AYe0kE3Qs="
dummyKeyEd448 :: C.PublicKey 'C.Ed448
dummyKeyEd448 = "MEMwBQYDK2VxAzoA6ibQc9XpkSLtwrf7PLvp81qW/etiumckVFImCMRdftcG/XopbOSaq9qyLhrgJWKOLyNrQPNVvpMA"
dummyKeyX25519 :: C.PublicKey 'C.X25519
dummyKeyX25519 = "MCowBQYDK2VuAyEA4JGSMYht18H4mas/jHeBwfcM7jLwNYJNOAhi2/g4RXg="
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 +578,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 +626,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
src/Simplex/Messaging/Server/Main.hs
+2 -2
View File
@@ -25,7 +25,7 @@ import Simplex.Messaging.Server (runSMPServer)
import Simplex.Messaging.Server.CLI
import Simplex.Messaging.Server.Env.STM (ServerConfig (..), defMsgExpirationDays, defaultInactiveClientExpiration, defaultMessageExpiration)
import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.Transport (simplexMQVersion, supportedSMPServerVRange)
import Simplex.Messaging.Transport (simplexMQVersion, supportedServerSMPRelayVRange)
import Simplex.Messaging.Transport.Client (TransportHost (..))
import Simplex.Messaging.Transport.Server (TransportServerConfig (..), defaultTransportServerConfig)
import Simplex.Messaging.Util (safeDecodeUtf8)
@@ -204,7 +204,7 @@ smpServerCLI cfgPath logPath =
logStatsStartTime = 0, -- seconds from 00:00 UTC
serverStatsLogFile = combine logPath "smp-server-stats.daily.log",
serverStatsBackupFile = logStats $> combine logPath "smp-server-stats.log",
smpServerVRange = supportedSMPServerVRange,
smpServerVRange = supportedServerSMPRelayVRange,
transportConfig =
defaultTransportServerConfig
{ logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini
src/Simplex/Messaging/Server/QueueStore.hs
+3 -3
View File
@@ -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)
src/Simplex/Messaging/Server/QueueStore/STM.hs
+1 -1
View File
@@ -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
src/Simplex/Messaging/Server/StoreLog.hs
+2 -2
View File
@@ -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 ()
src/Simplex/Messaging/Transport.hs
+157 -39
View File
@@ -5,6 +5,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
@@ -26,7 +27,13 @@
-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a
module Simplex.Messaging.Transport
( -- * SMP transport parameters
supportedSMPServerVRange,
supportedClientSMPRelayVRange,
supportedServerSMPRelayVRange,
currentClientSMPRelayVersion,
currentServerSMPRelayVersion,
basicAuthSMPVersion,
subModeSMPVersion,
authCmdsSMPVersion,
simplexMQVersion,
smpBlockSize,
TransportConfig (..),
@@ -36,6 +43,7 @@ module Simplex.Messaging.Transport
TProxy (..),
ATransport (..),
TransportPeer (..),
getServerVerifyKey,
-- * TLS Transport
TLS (..),
@@ -47,6 +55,8 @@ module Simplex.Messaging.Transport
-- * SMP transport
THandle (..),
THandleParams (..),
THandleAuth (..),
TransportError (..),
HandshakeError (..),
smpServerHandshake,
@@ -61,12 +71,13 @@ module Simplex.Messaging.Transport
where
import Control.Applicative ((<|>))
import Control.Monad (forM)
import Control.Monad.Except
import Control.Monad.Trans.Except (throwE)
import qualified Data.Aeson.TH as J
import Data.Attoparsec.ByteString.Char8 (Parser)
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.Bifunctor (first)
import Data.Bifunctor (bimap, first)
import Data.Bitraversable (bimapM)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
@@ -74,6 +85,8 @@ import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Default (def)
import Data.Functor (($>))
import Data.Version (showVersion)
import qualified Data.X509 as X
import qualified Data.X509.Validation as XV
import GHC.IO.Handle.Internals (ioe_EOF)
import Network.Socket
import qualified Network.TLS as T
@@ -83,7 +96,7 @@ import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding
import Simplex.Messaging.Parsers (dropPrefix, parseRead1, sumTypeJSON)
import Simplex.Messaging.Transport.Buffer
import Simplex.Messaging.Util (bshow, catchAll, catchAll_)
import Simplex.Messaging.Util (bshow, catchAll, catchAll_, liftEitherWith)
import Simplex.Messaging.Version
import UnliftIO.Exception (Exception)
import qualified UnliftIO.Exception as E
@@ -94,8 +107,40 @@ import UnliftIO.STM
smpBlockSize :: Int
smpBlockSize = 16384
supportedSMPServerVRange :: VersionRange
supportedSMPServerVRange = mkVersionRange 1 6
-- 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 - support authenticated encryption to verify senders' commands, imply but do NOT send session ID in signed part (2/3/2024)
batchCmdsSMPVersion :: Version
batchCmdsSMPVersion = 4
basicAuthSMPVersion :: Version
basicAuthSMPVersion = 5
subModeSMPVersion :: Version
subModeSMPVersion = 6
authCmdsSMPVersion :: Version
authCmdsSMPVersion = 7
currentClientSMPRelayVersion :: Version
currentClientSMPRelayVersion = 6
currentServerSMPRelayVersion :: Version
currentServerSMPRelayVersion = 6
-- minimal supported protocol version is 4
-- TODO remove code that supports sending commands without batching
supportedClientSMPRelayVRange :: VersionRange
supportedClientSMPRelayVRange = mkVersionRange batchCmdsSMPVersion currentClientSMPRelayVersion
supportedServerSMPRelayVRange :: VersionRange
supportedServerSMPRelayVRange = mkVersionRange batchCmdsSMPVersion currentServerSMPRelayVersion
simplexMQVersion :: String
simplexMQVersion = showVersion SMQ.version
@@ -118,10 +163,12 @@ class Transport c where
transportConfig :: c -> TransportConfig
-- | Upgrade server TLS context to connection (used in the server)
getServerConnection :: TransportConfig -> T.Context -> IO c
getServerConnection :: TransportConfig -> X.CertificateChain -> T.Context -> IO c
-- | Upgrade client TLS context to connection (used in the client)
getClientConnection :: TransportConfig -> T.Context -> IO c
getClientConnection :: TransportConfig -> X.CertificateChain -> T.Context -> IO c
getServerCerts :: c -> X.CertificateChain
-- | tls-unique channel binding per RFC5929
tlsUnique :: c -> SessionId
@@ -149,6 +196,12 @@ data TProxy c = TProxy
data ATransport = forall c. Transport c => ATransport (TProxy c)
getServerVerifyKey :: Transport c => c -> Either String C.APublicVerifyKey
getServerVerifyKey c =
case getServerCerts c of
X.CertificateChain (server : _ca) -> C.x509ToPublic (X.certPubKey . X.signedObject $ X.getSigned server, []) >>= C.pubKey
_ -> Left "no certificate chain"
-- * TLS Transport
data TLS = TLS
@@ -156,6 +209,7 @@ data TLS = TLS
tlsPeer :: TransportPeer,
tlsUniq :: ByteString,
tlsBuffer :: TBuffer,
tlsServerCerts :: X.CertificateChain,
tlsTransportConfig :: TransportConfig
}
@@ -168,12 +222,12 @@ connectTLS host_ TransportConfig {logTLSErrors} params sock =
logThrow e = putStrLn ("TLS error" <> host <> ": " <> show e) >> E.throwIO e
host = maybe "" (\h -> " (" <> h <> ")") host_
getTLS :: TransportPeer -> TransportConfig -> T.Context -> IO TLS
getTLS tlsPeer cfg cxt = withTlsUnique tlsPeer cxt newTLS
getTLS :: TransportPeer -> TransportConfig -> X.CertificateChain -> T.Context -> IO TLS
getTLS tlsPeer cfg tlsServerCerts cxt = withTlsUnique tlsPeer cxt newTLS
where
newTLS tlsUniq = do
tlsBuffer <- atomically newTBuffer
pure TLS {tlsContext = cxt, tlsTransportConfig = cfg, tlsPeer, tlsUniq, tlsBuffer}
pure TLS {tlsContext = cxt, tlsTransportConfig = cfg, tlsServerCerts, tlsPeer, tlsUniq, tlsBuffer}
withTlsUnique :: TransportPeer -> T.Context -> (ByteString -> IO c) -> IO c
withTlsUnique peer cxt f =
@@ -208,6 +262,7 @@ instance Transport TLS where
transportConfig = tlsTransportConfig
getServerConnection = getTLS TServer
getClientConnection = getTLS TClient
getServerCerts = tlsServerCerts
tlsUnique = tlsUniq
closeConnection tls = closeTLS $ tlsContext tls
@@ -231,45 +286,85 @@ 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,
params :: THandleParams
}
data THandleParams = THandleParams
{ 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,
-- | do NOT send session ID in transmission, but include it into signed message
-- based on protocol version
implySessId :: Bool,
-- | send multiple transmissions in a single block
-- based on protocol and protocol version
-- based on protocol version
batch :: Bool
}
data THandleAuth = THandleAuth
{ peerPubKey :: C.PublicKeyX25519, -- used only in the client to combine with per-queue key
privKey :: C.PrivateKeyX25519 -- used to combine with peer's per-queue key (currently only in the server)
}
-- | 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 (X.CertificateChain, X.SignedExact X.PubKey)
}
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) <> encodeAuthEncryptCmds smpVersion authPubKey
smpP = do
(smpVersion, keyHash) <- smpP
pure ClientHandshake {smpVersion, keyHash}
-- TODO drop SMP v6: remove special parser and make key non-optional
authPubKey <- authEncryptCmdsP smpVersion smpP
pure ClientHandshake {smpVersion, keyHash, authPubKey}
instance Encoding ServerHandshake where
smpEncode ServerHandshake {smpVersionRange, sessionId} =
smpEncode (smpVersionRange, sessionId)
smpEncode ServerHandshake {smpVersionRange, sessionId, authPubKey} =
smpEncode (smpVersionRange, sessionId) <> auth
where
auth =
encodeAuthEncryptCmds (maxVersion smpVersionRange) $
bimap C.encodeCertChain C.SignedObject <$> authPubKey
smpP = do
(smpVersionRange, sessionId) <- smpP
pure ServerHandshake {smpVersionRange, sessionId}
-- TODO drop SMP v6: remove special parser and make key non-optional
authPubKey <- authEncryptCmdsP (maxVersion smpVersionRange) authP
pure ServerHandshake {smpVersionRange, sessionId, authPubKey}
where
authP = do
cert <- C.certChainP
C.SignedObject key <- smpP
pure (cert, key)
encodeAuthEncryptCmds :: Encoding a => Version -> Maybe a -> ByteString
encodeAuthEncryptCmds v k
| v >= authCmdsSMPVersion = maybe "" smpEncode k
| otherwise = ""
authEncryptCmdsP :: Version -> Parser a -> Parser (Maybe a)
authEncryptCmdsP v p = if v >= authCmdsSMPVersion then Just <$> p else pure Nothing
-- | Error of SMP encrypted transport over TCP.
data TransportError
@@ -279,6 +374,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)
@@ -291,6 +389,8 @@ data HandshakeError
VERSION
| -- | incorrect server identity
IDENTITY
| -- | v7 authentication failed
BAD_AUTH
deriving (Eq, Read, Show, Exception)
-- | SMP encrypted transport error parser.
@@ -299,6 +399,7 @@ transportErrorP =
"BLOCK" $> TEBadBlock
<|> "LARGE_MSG" $> TELargeMsg
<|> "SESSION" $> TEBadSession
<|> "NO_AUTH" $> TENoServerAuth
<|> "HANDSHAKE " *> (TEHandshake <$> parseRead1)
-- | Serialize SMP encrypted transport error.
@@ -307,17 +408,18 @@ serializeTransportError = \case
TEBadBlock -> "BLOCK"
TELargeMsg -> "LARGE_MSG"
TEBadSession -> "SESSION"
TENoServerAuth -> "NO_AUTH"
TEHandshake e -> "HANDSHAKE " <> bshow e
-- | Pad and send block to SMP transport.
tPutBlock :: Transport c => THandle c -> ByteString -> IO (Either TransportError ())
tPutBlock THandle {connection = c, blockSize} block =
tPutBlock THandle {connection = c, params = THandleParams {blockSize}} block =
bimapM (const $ pure TELargeMsg) (cPut c) $
C.pad block blockSize
-- | Receive block from SMP transport.
tGetBlock :: Transport c => THandle c -> IO (Either TransportError ByteString)
tGetBlock THandle {connection = c, blockSize} = do
tGetBlock THandle {connection = c, params = THandleParams {blockSize}} = do
msg <- cGet c blockSize
if B.length msg == blockSize
then pure . first (const TELargeMsg) $ C.unPad msg
@@ -326,35 +428,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
let th@THandle {sessionId} = smpTHandle c
sendHandshake th $ ServerHandshake {sessionId, smpVersionRange = smpVRange}
smpServerHandshake :: forall c. Transport c => C.APrivateSignKey -> c -> C.KeyPairX25519 -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c)
smpServerHandshake serverSignKey c (k, pk) kh smpVRange = do
let th@THandle {params = THandleParams {sessionId}} = smpTHandle c
sk = C.signX509 serverSignKey $ C.publicToX509 k
certChain = getServerCerts c
sendHandshake th $ ServerHandshake {sessionId, smpVersionRange = smpVRange, authPubKey = Just (certChain, sk)}
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
let th@THandle {sessionId} = smpTHandle c
ServerHandshake {sessionId = sessId, smpVersionRange} <- getHandshake th
smpClientHandshake :: forall c. Transport c => c -> C.KeyPairX25519 -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c)
smpClientHandshake c (k, pk) keyHash@(C.KeyHash kh) smpVRange = do
let th@THandle {params = THandleParams {sessionId}} = smpTHandle c
ServerHandshake {sessionId = sessId, smpVersionRange, authPubKey} <- 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
sk_ <- forM authPubKey $ \(X.CertificateChain cert, exact) ->
liftEitherWith (const $ TEHandshake BAD_AUTH) $ do
case cert of
[_leaf, ca] | XV.Fingerprint kh == XV.getFingerprint ca X.HashSHA256 -> pure ()
_ -> throwError "bad certificate"
serverKey <- getServerVerifyKey c
pubKey <- C.verifyX509 serverKey exact
C.x509ToPublic (pubKey, []) >>= C.pubKey
sendHandshake th $ ClientHandshake {smpVersion = v, keyHash, authPubKey = Just k}
pure $ smpThHandle th v pk sk_
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@THandle {params} v privKey k_ =
-- TODO drop SMP v6: make thAuth non-optional
let thAuth = (\k -> THandleAuth {peerPubKey = k, privKey}) <$> k_
params' = params {thVersion = v, thAuth, implySessId = v >= authCmdsSMPVersion}
in (th :: THandle c) {params = params'}
sendHandshake :: (Transport c, Encoding smp) => THandle c -> smp -> ExceptT TransportError IO ()
sendHandshake th = ExceptT . tPutBlock th . smpEncode
@@ -364,7 +480,9 @@ getHandshake :: (Transport c, Encoding smp) => THandle c -> ExceptT TransportErr
getHandshake th = ExceptT $ (first (\_ -> TEHandshake PARSE) . A.parseOnly smpP =<<) <$> 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, params}
where
params = THandleParams {sessionId = tlsUnique c, blockSize = smpBlockSize, thVersion = 0, thAuth = Nothing, implySessId = False, batch = True}
$(J.deriveJSON (sumTypeJSON id) ''HandshakeError)
src/Simplex/Messaging/Transport/Client.hs
+19 -5
View File
@@ -22,6 +22,7 @@ where
import Control.Applicative (optional)
import Control.Logger.Simple (logError)
import Control.Monad (when)
import Control.Monad.IO.Unlift
import Data.Aeson (FromJSON (..), ToJSON (..))
import qualified Data.Attoparsec.ByteString.Char8 as A
@@ -54,6 +55,7 @@ import System.IO.Error
import Text.Read (readMaybe)
import UnliftIO.Exception (IOException)
import qualified UnliftIO.Exception as E
import UnliftIO.STM
data TransportHost
= THIPv4 (Word8, Word8, Word8, Word8)
@@ -129,8 +131,9 @@ runTransportClient = runTLSTransportClient supportedParameters Nothing
runTLSTransportClient :: (Transport c, MonadUnliftIO m) => T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> Maybe ByteString -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c -> m a) -> m a
runTLSTransportClient tlsParams caStore_ cfg@TransportClientConfig {socksProxy, tcpKeepAlive, clientCredentials} proxyUsername host port keyHash client = do
serverCert <- newEmptyTMVarIO
let hostName = B.unpack $ strEncode host
clientParams = mkTLSClientParams tlsParams caStore_ hostName port keyHash clientCredentials
clientParams = mkTLSClientParams tlsParams caStore_ hostName port keyHash clientCredentials serverCert
connectTCP = case socksProxy of
Just proxy -> connectSocksClient proxy proxyUsername $ hostAddr host
_ -> connectTCPClient hostName
@@ -138,7 +141,13 @@ runTLSTransportClient tlsParams caStore_ cfg@TransportClientConfig {socksProxy,
sock <- connectTCP port
mapM_ (setSocketKeepAlive sock) tcpKeepAlive `catchAll` \e -> logError ("Error setting TCP keep-alive" <> tshow e)
let tCfg = clientTransportConfig cfg
connectTLS (Just hostName) tCfg clientParams sock >>= getClientConnection tCfg
connectTLS (Just hostName) tCfg clientParams sock >>= \tls -> do
chain <- atomically (tryTakeTMVar serverCert) >>= \case
Nothing -> do
logError "onServerCertificate didn't fire or failed to get cert chain"
closeTLS tls >> error "onServerCertificate failed"
Just c -> pure c
getClientConnection tCfg chain tls
client c `E.finally` liftIO (closeConnection c)
where
hostAddr = \case
@@ -207,19 +216,24 @@ instance ToJSON SocksProxy where
instance FromJSON SocksProxy where
parseJSON = strParseJSON "SocksProxy"
mkTLSClientParams :: T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe C.KeyHash -> Maybe (X.CertificateChain, T.PrivKey) -> T.ClientParams
mkTLSClientParams supported caStore_ host port cafp_ clientCreds_ =
mkTLSClientParams :: T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe C.KeyHash -> Maybe (X.CertificateChain, T.PrivKey) -> TMVar X.CertificateChain -> T.ClientParams
mkTLSClientParams supported caStore_ host port cafp_ clientCreds_ serverCerts =
(T.defaultParamsClient host p)
{ T.clientShared = def {T.sharedCAStore = fromMaybe (T.sharedCAStore def) caStore_},
T.clientHooks =
def
{ T.onServerCertificate = maybe def (\cafp _ _ _ -> validateCertificateChain cafp host p) cafp_,
{ T.onServerCertificate = onServerCert,
T.onCertificateRequest = maybe def (const . pure . Just) clientCreds_
},
T.clientSupported = supported
}
where
p = B.pack port
onServerCert _ _ _ c = do
errs <- maybe def (\ca -> validateCertificateChain ca host p c) cafp_
when (null errs) $
atomically (putTMVar serverCerts c)
pure errs
validateCertificateChain :: C.KeyHash -> HostName -> ByteString -> X.CertificateChain -> IO [XV.FailedReason]
validateCertificateChain _ _ _ (X.CertificateChain []) = pure [XV.EmptyChain]
src/Simplex/Messaging/Transport/Server.hs
+9 -3
View File
@@ -19,6 +19,7 @@ module Simplex.Messaging.Transport.Server
loadTLSServerParams,
loadFingerprint,
smpServerHandshake,
tlsServerCredentials
)
where
@@ -78,13 +79,13 @@ runTransportServerState :: forall c m. (Transport c, MonadUnliftIO m) => SocketS
runTransportServerState ss started port = runTransportServerSocketState ss started (startTCPServer started port) (transportName (TProxy :: TProxy c))
-- | Run a transport server with provided connection setup and handler.
runTransportServerSocket :: (MonadUnliftIO m, T.TLSParams p, Transport a) => TMVar Bool -> IO Socket -> String -> p -> TransportServerConfig -> (a -> m ()) -> m ()
runTransportServerSocket :: (MonadUnliftIO m, Transport a) => TMVar Bool -> IO Socket -> String -> T.ServerParams -> TransportServerConfig -> (a -> m ()) -> m ()
runTransportServerSocket started getSocket threadLabel serverParams cfg server = do
ss <- atomically newSocketState
runTransportServerSocketState ss started getSocket threadLabel serverParams cfg server
-- | Run a transport server with provided connection setup and handler.
runTransportServerSocketState :: (MonadUnliftIO m, T.TLSParams p, Transport a) => SocketState -> TMVar Bool -> IO Socket -> String -> p -> TransportServerConfig -> (a -> m ()) -> m ()
runTransportServerSocketState :: (MonadUnliftIO m, Transport a) => SocketState -> TMVar Bool -> IO Socket -> String -> T.ServerParams -> TransportServerConfig -> (a -> m ()) -> m ()
runTransportServerSocketState ss started getSocket threadLabel serverParams cfg server = do
u <- askUnliftIO
labelMyThread $ "transport server for " <> threadLabel
@@ -95,7 +96,12 @@ runTransportServerSocketState ss started getSocket threadLabel serverParams cfg
setup conn = timeout (tlsSetupTimeout cfg) $ do
labelMyThread $ threadLabel <> "/setup"
tls <- connectTLS Nothing tCfg serverParams conn
getServerConnection tCfg tls
getServerConnection tCfg (fst $ tlsServerCredentials serverParams) tls
tlsServerCredentials :: T.ServerParams -> (X.CertificateChain, X.PrivKey)
tlsServerCredentials serverParams = case T.sharedCredentials $ T.serverShared serverParams of
T.Credentials [creds] -> creds
_ -> error "server has more than one key"
-- | Run TCP server without TLS
runTCPServer :: TMVar Bool -> ServiceName -> (Socket -> IO ()) -> IO ()
src/Simplex/Messaging/Transport/WebSockets.hs
+11 -6
View File
@@ -8,6 +8,7 @@ import qualified Control.Exception as E
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as LB
import qualified Data.X509 as X
import qualified Network.TLS as T
import Network.WebSockets
import Network.WebSockets.Stream (Stream)
@@ -29,7 +30,8 @@ data WS = WS
tlsUniq :: ByteString,
wsStream :: Stream,
wsConnection :: Connection,
wsTransportConfig :: TransportConfig
wsTransportConfig :: TransportConfig,
wsServerCerts :: X.CertificateChain
}
websocketsOpts :: ConnectionOptions
@@ -50,12 +52,15 @@ instance Transport WS where
transportConfig :: WS -> TransportConfig
transportConfig = wsTransportConfig
getServerConnection :: TransportConfig -> T.Context -> IO WS
getServerConnection :: TransportConfig -> X.CertificateChain -> T.Context -> IO WS
getServerConnection = getWS TServer
getClientConnection :: TransportConfig -> T.Context -> IO WS
getClientConnection :: TransportConfig -> X.CertificateChain -> T.Context -> IO WS
getClientConnection = getWS TClient
getServerCerts :: WS -> X.CertificateChain
getServerCerts = wsServerCerts
tlsUnique :: WS -> ByteString
tlsUnique = tlsUniq
@@ -79,13 +84,13 @@ instance Transport WS where
then E.throwIO TEBadBlock
else pure $ B.init s
getWS :: TransportPeer -> TransportConfig -> T.Context -> IO WS
getWS wsPeer cfg cxt = withTlsUnique wsPeer cxt connectWS
getWS :: TransportPeer -> TransportConfig -> X.CertificateChain -> T.Context -> IO WS
getWS wsPeer cfg wsServerCerts cxt = withTlsUnique wsPeer cxt connectWS
where
connectWS tlsUniq = do
s <- makeTLSContextStream cxt
wsConnection <- connectPeer wsPeer s
pure $ WS {wsPeer, tlsUniq, wsStream = s, wsConnection, wsTransportConfig = cfg}
pure $ WS {wsPeer, tlsUniq, wsStream = s, wsConnection, wsTransportConfig = cfg, wsServerCerts}
connectPeer :: TransportPeer -> Stream -> IO Connection
connectPeer TServer = acceptClientRequest
connectPeer TClient = sendClientRequest