sid
/
simplexmq
Archived
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

SMP connection handshake v2 (#390) 

* SMP connection handshake v2

* hadshake v2 [mostly] works

* all tests pass, some race conditions remain

* fix build

* fix race conditions, send CON after all HELLOs in duplexHandshake mode

* add comments

* comment

* add comments
This commit is contained in:
Evgeny Poberezkin 2022-06-09 13:47:07 +01:00 committed by GitHub
parent 4220c3bdaf
commit c1348aa54f
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
29 changed files with 660 additions and 331 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
apps/smp-server/Main.hs
View File

@ -12,7 +12,7 @@ import Simplex.Messaging.Server (runSMPServer)
import Simplex.Messaging.Server.CLI (ServerCLIConfig (..), protocolServerCLI, readStrictIni)
import Simplex.Messaging.Server.Env.STM (ServerConfig (..), defaultInactiveClientExpiration, defaultMessageExpiration)
import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.Transport (simplexMQVersion)
import Simplex.Messaging.Transport (simplexMQVersion, supportedSMPServerVRange)
import System.FilePath (combine)
cfgPath :: FilePath
@ -92,6 +92,7 @@ smpServerCLIConfig =
}
else Nothing,
logStatsInterval = Just 86400, -- seconds
logStatsStartTime = 0 -- seconds from 00:00 UTC
logStatsStartTime = 0, -- seconds from 00:00 UTC
smpServerVRange = supportedSMPServerVRange
}
}

71
protocol/diagrams/duplex-messaging/duplex-creating-v2.mmd Normal file
View File

@ -0,0 +1,71 @@
sequenceDiagram
participant A as Alice
participant AA as Alice's<br>agent
participant AS as Alice's<br>server
participant BS as Bob's<br>server
participant BA as Bob's<br>agent
participant B as Bob
note over AA, BA: status (receive/send): NONE/NONE
note over A, AA: 1. request connection<br>from agent
A ->> AA: NEW: create<br>duplex connection
note over AA, AS: 2. create Alice's SMP queue
AA ->> AS: NEW: create SMP queue
AS ->> AA: IDS: SMP queue IDs
note over AA: status: NEW/NONE
AA ->> A: INV: invitation<br>to connect
note over A, B: 3. out-of-band invitation
A ->> B: OOB: invitation to connect
note over BA, B: 4. accept connection
B ->> BA: JOIN:<br>via invitation info
note over BA: status: NONE/NEW
note over BA, BS: 5. create Bob's SMP queue
BA ->> BS: NEW: create SMP queue
BS ->> BA: IDS: SMP queue IDs
note over BA: status: NEW/NEW
note over BA, AA: 6. establish Alice's SMP queue
BA ->> AS: SEND: Bob's info and sender server key (SMP confirmation with reply queues)
note over BA: status: NEW/CONFIRMED
AS ->> AA: MSG: Bob's info and<br>sender server key
note over AA: status: CONFIRMED/NONE
AA ->> AS: ACK: confirm message
AA ->> A: CONF: connection request ID<br>and Bob's info
A ->> AA: LET: accept connection request,<br>send Alice's info
AA ->> AS: KEY: secure queue
note over AA: status: SECURED/NONE
AA ->> BS: SEND: Alice's info and sender's server key (SMP confirmation without reply queues)
note over AA: status: SECURED/CONFIRMED
BS ->> BA: MSG: Alice's info and<br>sender's server key
note over BA: status: CONFIRMED/CONFIRMED
BA ->> B: INFO: Alice's info
BA ->> BS: ACK: confirm message
BA ->> BS: KEY: secure queue
note over BA: status: SECURED/CONFIRMED
BA ->> AS: SEND: HELLO: only needs to be sent once in v2
note over BA: status: SECURED/ACTIVE
note over BA, B: 7a. notify Bob<br>about connection success
BA ->> B: CON: connected
AS ->> AA: MSG: HELLO: Alice's agent<br>knows Bob can send
note over AA: status: SECURED/ACTIVE
AA ->> AS: ACK: confirm message
note over A, AA: 7a. notify Alice<br>about connection success
AA ->> A: CON: connected
AA ->> BS: SEND: HELLO: only needs to be sent once in v2
note over AA: status: ACTIVE/ACTIVE
BS ->> BA: MSG: HELLO: Bob's agent<br>knows Alice can send
note over BA: status: ACTIVE/ACTIVE
BA ->> BS: ACK: confirm message

4
protocol/diagrams/duplex-messaging/duplex-creating.mmd
View File

@ -33,8 +33,8 @@ sequenceDiagram
AS ->> AA: MSG: Bob's info and<br>sender server key
note over AA: status: CONFIRMED/NONE
AA ->> AS: ACK: confirm message
AA ->> A: REQ: connection request ID<br>and Bob's info
A ->> AA: ACPT: accept connection request,<br>send Alice's info
AA ->> A: CONF: connection request ID<br>and Bob's info
A ->> AA: LET: accept connection request,<br>send Alice's info
AA ->> AS: KEY: secure queue
note over AA: status: SECURED/NONE

2
simplexmq.cabal
View File

@ -48,7 +48,7 @@ library
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220301_snd_queue_keys
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220322_notifications
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220404_ntf_subscriptions_draft
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220605_msg_flags
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220608_v2
Simplex.Messaging.Client
Simplex.Messaging.Client.Agent
Simplex.Messaging.Crypto

376
src/Simplex/Messaging/Agent.hs
View File

@ -84,7 +84,7 @@ import Simplex.Messaging.Agent.Env.SQLite
import Simplex.Messaging.Agent.Protocol
import Simplex.Messaging.Agent.RetryInterval
import Simplex.Messaging.Agent.Store
import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore)
import Simplex.Messaging.Agent.Store.SQLite (AgentStoreMonad, SQLiteStore)
import Simplex.Messaging.Client (ProtocolClient (..), ServerTransmission)
import qualified Simplex.Messaging.Crypto as C
import qualified Simplex.Messaging.Crypto.Ratchet as CR
@ -214,10 +214,7 @@ client c@AgentClient {rcvQ, subQ} = forever $ do
Left e -> (corrId, connId, ERR e)
Right (connId', resp) -> (corrId, connId', resp)
withStore ::
AgentMonad m =>
(forall m'. (MonadUnliftIO m', MonadError StoreError m') => SQLiteStore -> m' a) ->
m a
withStore :: AgentMonad m => (forall m'. AgentStoreMonad m' => SQLiteStore -> m' a) -> m a
withStore action = do
st <- asks store
runExceptT (action st `E.catch` handleInternal) >>= \case
@ -235,6 +232,10 @@ withStore action = do
SEBadConnType CRcv -> CONN SIMPLEX
SEBadConnType CSnd -> CONN SIMPLEX
SEInvitationNotFound -> CMD PROHIBITED
-- this error is never reported as store error,
-- it is used to wrap agent operations when "transaction-like" store access is needed
-- NOTE: network IO should NOT be used inside AgentStoreMonad
SEAgentError e -> e
e -> INTERNAL $ show e
-- | execute any SMP agent command
@ -256,10 +257,12 @@ newConn c connId cMode = do
srv <- getSMPServer c
(rq, qUri) <- newRcvQueue c srv
g <- asks idsDrg
let cData = ConnData {connId}
agentVersion <- asks $ smpAgentVersion . config
let cData = ConnData {connId, connAgentVersion = agentVersion, duplexHandshake = Nothing} -- connection mode is determined by the accepting agent
connId' <- withStore $ \st -> createRcvConn st g cData rq cMode
addSubscription c rq connId'
let crData = ConnReqUriData simplexChat smpAgentVRange [qUri]
aVRange <- asks $ smpAgentVRange . config
let crData = ConnReqUriData simplexChat aVRange [qUri]
case cMode of
SCMContact -> pure (connId', CRContactUri crData)
SCMInvitation -> do
@ -268,35 +271,39 @@ newConn c connId cMode = do
pure (connId', CRInvitationUri crData $ toVersionRangeT e2eRcvParams CR.e2eEncryptVRange)
joinConn :: AgentMonad m => AgentClient -> ConnId -> ConnectionRequestUri c -> ConnInfo -> m ConnId
joinConn c connId (CRInvitationUri (ConnReqUriData _ agentVRange (qUri :| _)) e2eRcvParamsUri) cInfo =
joinConn c connId (CRInvitationUri (ConnReqUriData _ agentVRange (qUri :| _)) e2eRcvParamsUri) cInfo = do
aVRange <- asks $ smpAgentVRange . config
case ( qUri `compatibleVersion` SMP.smpClientVRange,
e2eRcvParamsUri `compatibleVersion` CR.e2eEncryptVRange,
agentVRange `compatibleVersion` smpAgentVRange
agentVRange `compatibleVersion` aVRange
) of
(Just qInfo, Just (Compatible e2eRcvParams@(CR.E2ERatchetParams _ _ rcDHRr)), Just _) -> do
(Just qInfo, Just (Compatible e2eRcvParams@(CR.E2ERatchetParams _ _ rcDHRr)), Just aVersion@(Compatible connAgentVersion)) -> do
-- TODO in agent v2 - use found compatible version rather than current
(pk1, pk2, e2eSndParams) <- liftIO . CR.generateE2EParams $ version e2eRcvParams
(_, rcDHRs) <- liftIO C.generateKeyPair'
let rc = CR.initSndRatchet rcDHRr rcDHRs $ CR.x3dhSnd pk1 pk2 e2eRcvParams
sq <- newSndQueue qInfo
g <- asks idsDrg
let cData = ConnData {connId}
let duplexHS = connAgentVersion /= 1
cData = ConnData {connId, connAgentVersion, duplexHandshake = Just duplexHS}
connId' <- withStore $ \st -> do
connId' <- createSndConn st g cData sq
createRatchet st connId' rc
pure connId'
tryError (confirmQueue c connId' sq cInfo $ Just e2eSndParams) >>= \case
let cData' = (cData :: ConnData) {connId = connId'}
tryError (confirmQueue aVersion c connId' sq cInfo $ Just e2eSndParams) >>= \case
Right _ -> do
void $ enqueueMessage c connId' sq SMP.noMsgFlags HELLO
unless duplexHS . void $ enqueueMessage c cData' sq SMP.noMsgFlags HELLO
pure connId'
Left e -> do
-- TODO recovery for failure on network timeout, see rfcs/2022-04-20-smp-conf-timeout-recovery.md
withStore (`deleteConn` connId')
throwError e
_ -> throwError $ AGENT A_VERSION
joinConn c connId (CRContactUri (ConnReqUriData _ agentVRange (qUri :| _))) cInfo =
joinConn c connId (CRContactUri (ConnReqUriData _ agentVRange (qUri :| _))) cInfo = do
aVRange <- asks $ smpAgentVRange . config
case ( qUri `compatibleVersion` SMP.smpClientVRange,
agentVRange `compatibleVersion` smpAgentVRange
agentVRange `compatibleVersion` aVRange
) of
(Just qInfo, Just _) -> do
-- TODO in agent v2 - use found compatible version rather than current
@ -305,24 +312,25 @@ joinConn c connId (CRContactUri (ConnReqUriData _ agentVRange (qUri :| _))) cInf
pure connId'
_ -> throwError $ AGENT A_VERSION
createReplyQueue :: AgentMonad m => AgentClient -> ConnId -> SndQueue -> m ()
createReplyQueue c connId sq = do
createReplyQueue :: AgentMonad m => AgentClient -> ConnId -> m SMPQueueInfo
createReplyQueue c connId = do
srv <- getSMPServer c
(rq, qUri) <- newRcvQueue c srv
-- TODO reply queue version should be the same as send queue, ignoring it in v1
let qInfo = toVersionT qUri SMP.smpClientVersion
addSubscription c rq connId
withStore $ \st -> upgradeSndConnToDuplex st connId rq
void . enqueueMessage c connId sq SMP.noMsgFlags $ REPLY [qInfo]
pure qInfo
-- | Approve confirmation (LET command) in Reader monad
allowConnection' :: AgentMonad m => AgentClient -> ConnId -> ConfirmationId -> ConnInfo -> m ()
allowConnection' c connId confId ownConnInfo = do
withStore (`getConn` connId) >>= \case
SomeConn _ (RcvConnection _ rq) -> do
SomeConn _ (RcvConnection cData rq) -> do
AcceptedConfirmation {senderConf, ratchetState} <- withStore $ \st -> acceptConfirmation st confId ownConnInfo
withStore $ \st -> createRatchet st connId ratchetState
processConfirmation c rq senderConf
mapM_ (connectReplyQueues c cData ownConnInfo) (L.nonEmpty $ smpReplyQueues senderConf)
_ -> throwError $ CMD PROHIBITED
-- | Accept contact (ACPT command) in Reader monad
@ -351,11 +359,11 @@ processConfirmation c rq@RcvQueue {e2ePrivKey} SMPConfirmation {senderKey, e2ePu
subscribeConnection' :: forall m. AgentMonad m => AgentClient -> ConnId -> m ()
subscribeConnection' c connId =
withStore (`getConn` connId) >>= \case
SomeConn _ (DuplexConnection _ rq sq) -> do
resumeMsgDelivery c connId sq
SomeConn _ (DuplexConnection cData rq sq) -> do
resumeMsgDelivery c cData sq
subscribeQueue c rq connId
SomeConn _ (SndConnection _ sq) -> do
resumeMsgDelivery c connId sq
SomeConn _ (SndConnection cData sq) -> do
resumeMsgDelivery c cData sq
case status (sq :: SndQueue) of
Confirmed -> pure ()
Active -> throwError $ CONN SIMPLEX
@ -373,40 +381,40 @@ resubscribeConnection' c connId =
sendMessage' :: forall m. AgentMonad m => AgentClient -> ConnId -> MsgFlags -> MsgBody -> m AgentMsgId
sendMessage' c connId msgFlags msg =
withStore (`getConn` connId) >>= \case
SomeConn _ (DuplexConnection _ _ sq) -> enqueueMsg sq
SomeConn _ (SndConnection _ sq) -> enqueueMsg sq
SomeConn _ (DuplexConnection cData _ sq) -> enqueueMsg cData sq
SomeConn _ (SndConnection cData sq) -> enqueueMsg cData sq
_ -> throwError $ CONN SIMPLEX
where
enqueueMsg :: SndQueue -> m AgentMsgId
enqueueMsg sq = enqueueMessage c connId sq msgFlags $ A_MSG msg
enqueueMsg :: ConnData -> SndQueue -> m AgentMsgId
enqueueMsg cData sq = enqueueMessage c cData sq msgFlags $ A_MSG msg
enqueueMessage :: forall m. AgentMonad m => AgentClient -> ConnId -> SndQueue -> MsgFlags -> AMessage -> m AgentMsgId
enqueueMessage c connId sq msgFlags aMessage = do
resumeMsgDelivery c connId sq
enqueueMessage :: forall m. AgentMonad m => AgentClient -> ConnData -> SndQueue -> MsgFlags -> AMessage -> m AgentMsgId
enqueueMessage c cData@ConnData {connId, connAgentVersion} sq msgFlags aMessage = do
resumeMsgDelivery c cData sq
msgId <- storeSentMsg
queuePendingMsgs c connId sq [msgId]
pure $ unId msgId
where
storeSentMsg :: m InternalId
storeSentMsg = do
storeSentMsg = withStore $ \st -> do
internalTs <- liftIO getCurrentTime
(internalId, internalSndId, prevMsgHash) <- withStore (`updateSndIds` connId)
(internalId, internalSndId, prevMsgHash) <- updateSndIds st connId
let privHeader = APrivHeader (unSndId internalSndId) prevMsgHash
agentMsg = AgentMessage privHeader aMessage
agentMsgStr = smpEncode agentMsg
internalHash = C.sha256Hash agentMsgStr
encAgentMessage <- agentRatchetEncrypt connId agentMsgStr e2eEncUserMsgLength
let msgBody = smpEncode $ AgentMsgEnvelope {agentVersion = smpAgentVersion, encAgentMessage}
encAgentMessage <- agentRatchetEncrypt st connId agentMsgStr e2eEncUserMsgLength
let msgBody = smpEncode $ AgentMsgEnvelope {agentVersion = connAgentVersion, encAgentMessage}
msgType = agentMessageType agentMsg
msgData = SndMsgData {internalId, internalSndId, internalTs, msgType, msgFlags, msgBody, internalHash, prevMsgHash}
withStore $ \st -> createSndMsg st connId msgData
createSndMsg st connId msgData
pure internalId
resumeMsgDelivery :: forall m. AgentMonad m => AgentClient -> ConnId -> SndQueue -> m ()
resumeMsgDelivery c connId sq@SndQueue {server, sndId} = do
resumeMsgDelivery :: forall m. AgentMonad m => AgentClient -> ConnData -> SndQueue -> m ()
resumeMsgDelivery c cData@ConnData {connId} sq@SndQueue {server, sndId} = do
let qKey = (connId, server, sndId)
unlessM (queueDelivering qKey) $
async (runSmpQueueMsgDelivery c connId sq)
async (runSmpQueueMsgDelivery c cData sq)
>>= \a -> atomically (TM.insert qKey a $ smpQueueMsgDeliveries c)
unlessM connQueued $
withStore (`getPendingMsgs` connId)
@ -430,8 +438,8 @@ getPendingMsgQ c connId SndQueue {server, sndId} = do
TM.insert qKey mq $ smpQueueMsgQueues c
pure mq
runSmpQueueMsgDelivery :: forall m. AgentMonad m => AgentClient -> ConnId -> SndQueue -> m ()
runSmpQueueMsgDelivery c@AgentClient {subQ} connId sq = do
runSmpQueueMsgDelivery :: forall m. AgentMonad m => AgentClient -> ConnData -> SndQueue -> m ()
runSmpQueueMsgDelivery c@AgentClient {subQ} cData@ConnData {connId, duplexHandshake} sq = do
mq <- atomically $ getPendingMsgQ c connId sq
ri <- asks $ reconnectInterval . config
forever $ do
@ -451,19 +459,27 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} connId sq = do
case e of
SMP SMP.QUOTA -> case msgType of
AM_CONN_INFO -> connError msgId NOT_AVAILABLE
AM_CONN_INFO_REPLY -> connError msgId NOT_AVAILABLE
_ -> loop
SMP SMP.AUTH -> case msgType of
AM_CONN_INFO -> connError msgId NOT_AVAILABLE
AM_HELLO_ -> do
helloTimeout <- asks $ helloTimeout . config
currentTime <- liftIO getCurrentTime
if diffUTCTime currentTime internalTs > helloTimeout
then case rq_ of
AM_CONN_INFO_REPLY -> connError msgId NOT_AVAILABLE
AM_HELLO_
-- in duplexHandshake mode (v2) HELLO is only sent once, without retrying,
-- because the queue must be secured by the time the confirmation or the first HELLO is received
| duplexHandshake == Just True -> connErr
| otherwise -> do
helloTimeout <- asks $ helloTimeout . config
currentTime <- liftIO getCurrentTime
if diffUTCTime currentTime internalTs > helloTimeout
then connErr
else loop
where
connErr = case rq_ of
-- party initiating connection
Just _ -> connError msgId NOT_AVAILABLE
-- party joining connection
_ -> connError msgId NOT_ACCEPTED
else loop
AM_REPLY_ -> notifyDel msgId $ ERR e
AM_A_MSG_ -> notifyDel msgId $ MERR mId e
SMP (SMP.CMD _) -> notifyDel msgId err
@ -476,16 +492,28 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} connId sq = do
withStore $ \st -> setSndQueueStatus st sq Confirmed
when (isJust rq_) $ withStore (`removeConfirmations` connId)
-- TODO possibly notification flag should be ON for one of the parties, to result in contact connected notification
void $ enqueueMessage c connId sq SMP.noMsgFlags HELLO
unless (duplexHandshake == Just True) . void $ enqueueMessage c cData sq SMP.noMsgFlags HELLO
AM_HELLO_ -> do
withStore $ \st -> setSndQueueStatus st sq Active
case rq_ of
-- party initiating connection
Just rq -> do
subscribeQueue c rq connId
notify CON
-- party joining connection
_ -> createReplyQueue c connId sq
-- party initiating connection (in v1)
Just RcvQueue {status} ->
-- TODO it is unclear why subscribeQueue was needed here,
-- message delivery can only be enabled for queues that were created in the current session or subscribed
-- subscribeQueue c rq connId
--
-- If initiating party were to send CON to the user without waiting for reply HELLO (to reduce handshake time),
-- it would lead to the non-deterministic internal ID of the first sent message, at to some other race conditions,
-- because it can be sent before HELLO is received
-- With `status == Aclive` condition, CON is sent here only by the accepting party, that previously received HELLO
when (status == Active) $ notify CON
-- Party joining connection sends REPLY after HELLO in v1,
-- it is an error to send REPLY in duplexHandshake mode (v2),
-- and this branch should never be reached as receive is created before the confirmation,
-- so the condition is not necessary here, strictly speaking.
_ -> unless (duplexHandshake == Just True) $ do
qInfo <- createReplyQueue c connId
void . enqueueMessage c cData sq SMP.noMsgFlags $ REPLY [qInfo]
AM_A_MSG_ -> notify $ SENT mId
_ -> pure ()
delMsg msgId
@ -509,7 +537,9 @@ ackMessage' c connId msgId = do
ack rq = do
let mId = InternalId msgId
srvMsgId <- withStore $ \st -> checkRcvMsg st connId mId
sendAck c rq srvMsgId
sendAck c rq srvMsgId `catchError` \case
SMP SMP.NO_MSG -> pure ()
e -> throwError e
withStore $ \st -> deleteMsg st connId mId
-- | Suspend SMP agent connection (OFF command) in Reader monad
@ -672,13 +702,13 @@ subscriber c@AgentClient {msgQ} = forever $ do
processSMPTransmission :: forall m. AgentMonad m => AgentClient -> ServerTransmission BrokerMsg -> m ()
processSMPTransmission c@AgentClient {smpClients, subQ} (srv, sessId, rId, cmd) = do
withStore (\st -> getRcvConn st srv rId) >>= \case
SomeConn SCDuplex (DuplexConnection cData rq _) -> processSMP SCDuplex cData rq
SomeConn SCRcv (RcvConnection cData rq) -> processSMP SCRcv cData rq
SomeConn SCContact (ContactConnection cData rq) -> processSMP SCContact cData rq
SomeConn _ conn@(DuplexConnection cData rq _) -> processSMP conn cData rq
SomeConn _ conn@(RcvConnection cData rq) -> processSMP conn cData rq
SomeConn _ conn@(ContactConnection cData rq) -> processSMP conn cData rq
_ -> atomically $ writeTBQueue subQ ("", "", ERR $ CONN NOT_FOUND)
where
processSMP :: SConnType c -> ConnData -> RcvQueue -> m ()
processSMP cType ConnData {connId} rq@RcvQueue {rcvDhSecret, e2ePrivKey, e2eDhSecret, status} =
processSMP :: Connection c -> ConnData -> RcvQueue -> m ()
processSMP conn cData@ConnData {connId, duplexHandshake} rq@RcvQueue {rcvDhSecret, e2ePrivKey, e2eDhSecret, status} =
case cmd of
SMP.MSG srvMsgId srvTs msgFlags msgBody' -> handleNotifyAck $ do
-- TODO deduplicate with previously received
@ -690,32 +720,54 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (srv, sessId, rId, cmd)
(Nothing, Just e2ePubKey) -> do
let e2eDh = C.dh' e2ePubKey e2ePrivKey
decryptClientMessage e2eDh clientMsg >>= \case
(SMP.PHConfirmation senderKey, AgentConfirmation {e2eEncryption, encConnInfo}) ->
smpConfirmation senderKey e2ePubKey e2eEncryption encConnInfo >> ack
(SMP.PHConfirmation senderKey, AgentConfirmation {e2eEncryption, encConnInfo, agentVersion}) ->
smpConfirmation senderKey e2ePubKey e2eEncryption encConnInfo agentVersion >> ack
(SMP.PHEmpty, AgentInvitation {connReq, connInfo}) ->
smpInvitation connReq connInfo >> ack
_ -> prohibited >> ack
(Just e2eDh, Nothing) -> do
decryptClientMessage e2eDh clientMsg >>= \case
(SMP.PHEmpty, AgentMsgEnvelope _ encAgentMsg) -> do
agentMsgBody <- agentRatchetDecrypt connId encAgentMsg
parseMessage agentMsgBody >>= \case
agentMsg@(AgentMessage APrivHeader {sndMsgId, prevMsgHash} aMessage) -> do
let msgType = agentMessageType agentMsg
(msgId, msgMeta) <- agentClientMsg prevMsgHash sndMsgId (srvMsgId, systemToUTCTime srvTs) msgFlags agentMsgBody msgType
case aMessage of
HELLO -> helloMsg >> ack >> withStore (\st -> deleteMsg st connId msgId)
REPLY cReq -> replyMsg cReq >> ack >> withStore (\st -> deleteMsg st connId msgId)
-- note that there is no ACK sent here, it is sent with agent's user ACK command
A_MSG body -> notify $ MSG msgMeta msgFlags body
(SMP.PHEmpty, AgentMsgEnvelope _ encAgentMsg) ->
agentClientMsg >>= \case
Just (msgId, msgMeta, aMessage) -> case aMessage of
HELLO -> helloMsg >> ack >> withStore (\st -> deleteMsg st connId msgId)
REPLY cReq -> replyMsg cReq >> ack >> withStore (\st -> deleteMsg st connId msgId)
-- note that there is no ACK sent for A_MSG, it is sent with agent's user ACK command
A_MSG body -> do
logServer "<--" c srv rId "MSG <MSG>"
notify $ MSG msgMeta msgFlags body
_ -> prohibited >> ack
where
agentClientMsg :: m (Maybe (InternalId, MsgMeta, AMessage))
agentClientMsg = withStore $ \st -> do
agentMsgBody <- agentRatchetDecrypt st connId encAgentMsg
liftEither (parse smpP (SEAgentError $ AGENT A_MESSAGE) agentMsgBody) >>= \case
agentMsg@(AgentMessage APrivHeader {sndMsgId, prevMsgHash} aMessage) -> do
let msgType = agentMessageType agentMsg
internalHash = C.sha256Hash agentMsgBody
internalTs <- liftIO getCurrentTime
(internalId, internalRcvId, prevExtSndId, prevRcvMsgHash) <- updateRcvIds st connId
let integrity = checkMsgIntegrity prevExtSndId sndMsgId prevRcvMsgHash prevMsgHash
recipient = (unId internalId, internalTs)
broker = (srvMsgId, systemToUTCTime srvTs)
msgMeta = MsgMeta {integrity, recipient, broker, sndMsgId}
rcvMsg = RcvMsgData {msgMeta, msgType, msgFlags, msgBody, internalRcvId, internalHash, externalPrevSndHash = prevMsgHash}
createRcvMsg st connId rcvMsg
pure $ Just (internalId, msgMeta, aMessage)
_ -> pure Nothing
_ -> prohibited >> ack
_ -> prohibited >> ack
where
ack :: m ()
ack = sendAck c rq srvMsgId
ack =
sendAck c rq srvMsgId `catchError` \case
SMP SMP.NO_MSG -> pure ()
e -> throwError e
handleNotifyAck :: m () -> m ()
handleNotifyAck m = m `catchError` \e -> notify (ERR e) >> ack
handleNotifyAck m =
m `catchError` \case
AGENT A_DUPLICATE -> ack
e -> notify (ERR e) >> ack
SMP.END ->
atomically (TM.lookup srv smpClients $>>= tryReadTMVar >>= processEND)
>>= logServer "<--" c srv rId
@ -744,38 +796,53 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (srv, sessId, rId, cmd)
clientMsg <- agentCbDecrypt e2eDh cmNonce cmEncBody
SMP.ClientMessage privHeader clientBody <- parseMessage clientMsg
agentEnvelope <- parseMessage clientBody
if agentVersion agentEnvelope `isCompatible` smpAgentVRange
then pure (privHeader, agentEnvelope)
else throwError $ AGENT A_VERSION
-- Version check is removed here, because when connecting via v1 contact address the agent still sends v2 message,
-- to allow duplexHandshake mode, in case the receiving agent was updated to v2 after the address was created.
-- aVRange <- asks $ smpAgentVRange . config
-- if agentVersion agentEnvelope `isCompatible` aVRange
-- then pure (privHeader, agentEnvelope)
-- else throwError $ AGENT A_VERSION
pure (privHeader, agentEnvelope)
parseMessage :: Encoding a => ByteString -> m a
parseMessage = liftEither . parse smpP (AGENT A_MESSAGE)
smpConfirmation :: C.APublicVerifyKey -> C.PublicKeyX25519 -> Maybe (CR.E2ERatchetParams 'C.X448) -> ByteString -> m ()
smpConfirmation senderKey e2ePubKey e2eEncryption encConnInfo = do
smpConfirmation :: C.APublicVerifyKey -> C.PublicKeyX25519 -> Maybe (CR.E2ERatchetParams 'C.X448) -> ByteString -> Version -> m ()
smpConfirmation senderKey e2ePubKey e2eEncryption encConnInfo agentVersion = do
logServer "<--" c srv rId "MSG <CONF>"
aVRange <- asks $ smpAgentVRange . config
unless (agentVersion `isCompatible` aVRange) . throwError $ AGENT A_VERSION
case status of
New -> case (cType, e2eEncryption) of
(SCRcv, Just e2eSndParams) -> do
New -> case (conn, e2eEncryption) of
-- party initiating connection
(RcvConnection {}, Just e2eSndParams) -> do
(pk1, rcDHRs) <- withStore $ \st -> getRatchetX3dhKeys st connId
let rc = CR.initRcvRatchet rcDHRs $ CR.x3dhRcv pk1 rcDHRs e2eSndParams
(agentMsgBody_, rc', skipped) <- liftError cryptoError $ CR.rcDecrypt rc M.empty encConnInfo
case (agentMsgBody_, skipped) of
(Right agentMsgBody, CR.SMDNoChange) ->
parseMessage agentMsgBody >>= \case
AgentConnInfo connInfo -> do
g <- asks idsDrg
let senderConf = SMPConfirmation {senderKey, e2ePubKey, connInfo}
newConfirmation = NewConfirmation {connId, senderConf, ratchetState = rc'}
confId <- withStore $ \st -> createConfirmation st g newConfirmation
notify $ CONF confId connInfo
AgentConnInfo connInfo ->
processConf connInfo SMPConfirmation {senderKey, e2ePubKey, connInfo, smpReplyQueues = []} False
AgentConnInfoReply smpQueues connInfo -> do
processConf connInfo SMPConfirmation {senderKey, e2ePubKey, connInfo, smpReplyQueues = L.toList smpQueues} True
_ -> prohibited
where
processConf connInfo senderConf duplexHS = do
let newConfirmation = NewConfirmation {connId, senderConf, ratchetState = rc'}
g <- asks idsDrg
confId <- withStore $ \st -> do
setHandshakeVersion st connId agentVersion duplexHS
createConfirmation st g newConfirmation
notify $ CONF confId connInfo
_ -> prohibited
(SCDuplex, Nothing) -> do
agentRatchetDecrypt connId encConnInfo >>= parseMessage >>= \case
-- party accepting connection
(DuplexConnection _ _ sq, Nothing) -> do
withStore (\st -> agentRatchetDecrypt st connId encConnInfo) >>= parseMessage >>= \case
AgentConnInfo connInfo -> do
notify $ INFO connInfo
processConfirmation c rq $ SMPConfirmation {senderKey, e2ePubKey, connInfo}
processConfirmation c rq $ SMPConfirmation {senderKey, e2ePubKey, connInfo, smpReplyQueues = []}
when (duplexHandshake == Just True) $ enqueueDuplexHello sq
_ -> prohibited
_ -> prohibited
_ -> prohibited
@ -787,42 +854,36 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (srv, sessId, rId, cmd)
Active -> prohibited
_ -> do
withStore $ \st -> setRcvQueueStatus st rq Active
case cType of
SCDuplex -> notifyConnected c connId
case conn of
DuplexConnection _ _ sq@SndQueue {status = sndStatus}
-- `sndStatus == Active` when HELLO was previously sent, and this is the reply HELLO
-- this branch is executed by the accepting party in duplexHandshake mode (v2)
-- and by the initiating party in v1
-- Also see comment where HELLO is sent.
| sndStatus == Active -> atomically $ writeTBQueue subQ ("", connId, CON)
| duplexHandshake == Just True -> enqueueDuplexHello sq
| otherwise -> pure ()
_ -> pure ()
replyMsg :: L.NonEmpty SMPQueueInfo -> m ()
replyMsg (qInfo :| _) = do
logServer "<--" c srv rId "MSG <REPLY>"
case cType of
SCRcv -> do
AcceptedConfirmation {ownConnInfo} <- withStore (`getAcceptedConfirmation` connId)
case qInfo `proveCompatible` SMP.smpClientVRange of
Nothing -> notify . ERR $ AGENT A_VERSION
Just qInfo' -> do
sq <- newSndQueue qInfo'
withStore $ \st -> upgradeRcvConnToDuplex st connId sq
enqueueConfirmation c connId sq ownConnInfo Nothing
_ -> prohibited
enqueueDuplexHello :: SndQueue -> m ()
enqueueDuplexHello sq = void $ enqueueMessage c cData sq SMP.MsgFlags {notification = True} HELLO
agentClientMsg :: PrevRcvMsgHash -> ExternalSndId -> (BrokerId, BrokerTs) -> MsgFlags -> MsgBody -> AgentMessageType -> m (InternalId, MsgMeta)
agentClientMsg externalPrevSndHash sndMsgId broker msgFlags msgBody msgType = do
logServer "<--" c srv rId "MSG <MSG>"
let internalHash = C.sha256Hash msgBody
internalTs <- liftIO getCurrentTime
(internalId, internalRcvId, prevExtSndId, prevRcvMsgHash) <- withStore (`updateRcvIds` connId)
let integrity = checkMsgIntegrity prevExtSndId sndMsgId prevRcvMsgHash externalPrevSndHash
recipient = (unId internalId, internalTs)
msgMeta = MsgMeta {integrity, recipient, broker, sndMsgId}
rcvMsg = RcvMsgData {msgMeta, msgType, msgFlags, msgBody, internalRcvId, internalHash, externalPrevSndHash}
withStore $ \st -> createRcvMsg st connId rcvMsg
pure (internalId, msgMeta)
replyMsg :: L.NonEmpty SMPQueueInfo -> m ()
replyMsg smpQueues = do
logServer "<--" c srv rId "MSG <REPLY>"
case duplexHandshake of
Just True -> prohibited
_ -> case conn of
RcvConnection {} -> do
AcceptedConfirmation {ownConnInfo} <- withStore (`getAcceptedConfirmation` connId)
connectReplyQueues c cData ownConnInfo smpQueues `catchError` (notify . ERR)
_ -> prohibited
smpInvitation :: ConnectionRequestUri 'CMInvitation -> ConnInfo -> m ()
smpInvitation connReq cInfo = do
logServer "<--" c srv rId "MSG <KEY>"
case cType of
SCContact -> do
case conn of
ContactConnection {} -> do
g <- asks idsDrg
let newInv = NewInvitation {contactConnId = connId, connReq, recipientConnInfo = cInfo}
invId <- withStore $ \st -> createInvitation st g newInv
@ -838,57 +899,70 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (srv, sessId, rId, cmd)
| internalPrevMsgHash /= receivedPrevMsgHash = MsgError MsgBadHash
| otherwise = MsgError MsgDuplicate -- this case is not possible
confirmQueue :: forall m. AgentMonad m => AgentClient -> ConnId -> SndQueue -> ConnInfo -> Maybe (CR.E2ERatchetParams 'C.X448) -> m ()
confirmQueue c connId sq connInfo e2eEncryption = do
_ <- withStore (`updateSndIds` connId)
msg <- mkConfirmation
connectReplyQueues :: AgentMonad m => AgentClient -> ConnData -> ConnInfo -> L.NonEmpty SMPQueueInfo -> m ()
connectReplyQueues c cData@ConnData {connId} ownConnInfo (qInfo :| _) = do
-- TODO make this proof on receiving confirmation too
case qInfo `proveCompatible` SMP.smpClientVRange of
Nothing -> throwError $ AGENT A_VERSION
Just qInfo' -> do
sq <- newSndQueue qInfo'
withStore $ \st -> upgradeRcvConnToDuplex st connId sq
enqueueConfirmation c cData sq ownConnInfo Nothing
confirmQueue :: forall m. AgentMonad m => Compatible Version -> AgentClient -> ConnId -> SndQueue -> ConnInfo -> Maybe (CR.E2ERatchetParams 'C.X448) -> m ()
confirmQueue (Compatible agentVersion) c connId sq connInfo e2eEncryption = do
aMessage <- mkAgentMessage agentVersion
msg <- mkConfirmation aMessage
sendConfirmation c sq msg
withStore $ \st -> setSndQueueStatus st sq Confirmed
where
mkConfirmation :: m MsgBody
mkConfirmation = do
encConnInfo <- agentRatchetEncrypt connId (smpEncode $ AgentConnInfo connInfo) e2eEncConnInfoLength
pure . smpEncode $ AgentConfirmation {agentVersion = smpAgentVersion, e2eEncryption, encConnInfo}
mkConfirmation :: AgentMessage -> m MsgBody
mkConfirmation aMessage = withStore $ \st -> do
void $ updateSndIds st connId
encConnInfo <- agentRatchetEncrypt st connId (smpEncode aMessage) e2eEncConnInfoLength
pure . smpEncode $ AgentConfirmation {agentVersion, e2eEncryption, encConnInfo}
mkAgentMessage :: Version -> m AgentMessage
mkAgentMessage 1 = pure $ AgentConnInfo connInfo
mkAgentMessage _ = do
qInfo <- createReplyQueue c connId
pure $ AgentConnInfoReply (qInfo :| []) connInfo
enqueueConfirmation :: forall m. AgentMonad m => AgentClient -> ConnId -> SndQueue -> ConnInfo -> Maybe (CR.E2ERatchetParams 'C.X448) -> m ()
enqueueConfirmation c connId sq connInfo e2eEncryption = do
resumeMsgDelivery c connId sq
enqueueConfirmation :: forall m. AgentMonad m => AgentClient -> ConnData -> SndQueue -> ConnInfo -> Maybe (CR.E2ERatchetParams 'C.X448) -> m ()
enqueueConfirmation c cData@ConnData {connId, connAgentVersion} sq connInfo e2eEncryption = do
resumeMsgDelivery c cData sq
msgId <- storeConfirmation
queuePendingMsgs c connId sq [msgId]
where
storeConfirmation :: m InternalId
storeConfirmation = do
storeConfirmation = withStore $ \st -> do
internalTs <- liftIO getCurrentTime
(internalId, internalSndId, prevMsgHash) <- withStore (`updateSndIds` connId)
(internalId, internalSndId, prevMsgHash) <- updateSndIds st connId
let agentMsg = AgentConnInfo connInfo
agentMsgStr = smpEncode agentMsg
internalHash = C.sha256Hash agentMsgStr
encConnInfo <- agentRatchetEncrypt connId agentMsgStr e2eEncConnInfoLength
let msgBody = smpEncode $ AgentConfirmation {agentVersion = smpAgentVersion, e2eEncryption, encConnInfo}
encConnInfo <- agentRatchetEncrypt st connId agentMsgStr e2eEncConnInfoLength
let msgBody = smpEncode $ AgentConfirmation {agentVersion = connAgentVersion, e2eEncryption, encConnInfo}
msgType = agentMessageType agentMsg
msgData = SndMsgData {internalId, internalSndId, internalTs, msgType, msgBody, msgFlags = SMP.noMsgFlags, internalHash, prevMsgHash}
withStore $ \st -> createSndMsg st connId msgData
msgData = SndMsgData {internalId, internalSndId, internalTs, msgType, msgBody, msgFlags = SMP.MsgFlags {notification = True}, internalHash, prevMsgHash}
createSndMsg st connId msgData
pure internalId
-- encoded AgentMessage -> encoded EncAgentMessage
agentRatchetEncrypt :: AgentMonad m => ConnId -> ByteString -> Int -> m ByteString
agentRatchetEncrypt connId msg paddedLen = do
rc <- withStore $ \st -> getRatchet st connId
(encMsg, rc') <- liftError cryptoError $ CR.rcEncrypt rc paddedLen msg
withStore $ \st -> updateRatchet st connId rc' CR.SMDNoChange
agentRatchetEncrypt :: AgentStoreMonad m => SQLiteStore -> ConnId -> ByteString -> Int -> m ByteString
agentRatchetEncrypt st connId msg paddedLen = do
rc <- getRatchet st connId
(encMsg, rc') <- liftError (SEAgentError . cryptoError) $ CR.rcEncrypt rc paddedLen msg
updateRatchet st connId rc' CR.SMDNoChange
pure encMsg
-- encoded EncAgentMessage -> encoded AgentMessage
agentRatchetDecrypt :: AgentMonad m => ConnId -> ByteString -> m ByteString
agentRatchetDecrypt connId encAgentMsg = do
(rc, skipped) <- withStore $ \st ->
(,) <$> getRatchet st connId <*> getSkippedMsgKeys st connId
(agentMsgBody_, rc', skippedDiff) <- liftError cryptoError $ CR.rcDecrypt rc skipped encAgentMsg
withStore $ \st -> updateRatchet st connId rc' skippedDiff
liftEither $ first cryptoError agentMsgBody_
notifyConnected :: AgentMonad m => AgentClient -> ConnId -> m ()
notifyConnected c connId = atomically $ writeTBQueue (subQ c) ("", connId, CON)
agentRatchetDecrypt :: AgentStoreMonad m => SQLiteStore -> ConnId -> ByteString -> m ByteString
agentRatchetDecrypt st connId encAgentMsg = do
rc <- getRatchet st connId
skipped <- getSkippedMsgKeys st connId
(agentMsgBody_, rc', skippedDiff) <- liftError (SEAgentError . cryptoError) $ CR.rcDecrypt rc skipped encAgentMsg
updateRatchet st connId rc' skippedDiff
liftEither $ first (SEAgentError . cryptoError) agentMsgBody_
newSndQueue :: (MonadUnliftIO m, MonadReader Env m) => Compatible SMPQueueInfo -> m SndQueue
newSndQueue qInfo =

14
src/Simplex/Messaging/Agent/Client.hs
View File

@ -142,15 +142,15 @@ type AgentMonad m = (MonadUnliftIO m, MonadReader Env m, MonadError AgentErrorTy
class ProtocolServerClient msg where
getProtocolServerClient :: AgentMonad m => AgentClient -> ProtocolServer -> m (ProtocolClient msg)
protocolError :: ErrorType -> AgentErrorType
clientProtocolError :: ErrorType -> AgentErrorType
instance ProtocolServerClient BrokerMsg where
getProtocolServerClient = getSMPServerClient
protocolError = SMP
clientProtocolError = SMP
instance ProtocolServerClient NtfResponse where
getProtocolServerClient = getNtfServerClient
protocolError = NTF
clientProtocolError = NTF
getSMPServerClient :: forall m. AgentMonad m => AgentClient -> SMPServer -> m SMPClient
getSMPServerClient c@AgentClient {active, smpClients, msgQ} srv = do
@ -357,10 +357,10 @@ withLogClient_ c srv qId cmdStr action = do
return res
withClient :: forall m msg a. (AgentMonad m, ProtocolServerClient msg) => AgentClient -> ProtocolServer -> (ProtocolClient msg -> ExceptT ProtocolClientError IO a) -> m a
withClient c srv action = withClient_ c srv $ liftClient (protocolError @msg) . action
withClient c srv action = withClient_ c srv $ liftClient (clientProtocolError @msg) . action
withLogClient :: forall m msg a. (AgentMonad m, ProtocolServerClient msg) => AgentClient -> ProtocolServer -> QueueId -> ByteString -> (ProtocolClient msg -> ExceptT ProtocolClientError IO a) -> m a
withLogClient c srv qId cmdStr action = withLogClient_ c srv qId cmdStr $ liftClient (protocolError @msg) . action
withLogClient c srv qId cmdStr action = withLogClient_ c srv qId cmdStr $ liftClient (clientProtocolError @msg) . action
liftClient :: AgentMonad m => (ErrorType -> AgentErrorType) -> ExceptT ProtocolClientError IO a -> m a
liftClient = liftError . protocolClientError
@ -477,7 +477,8 @@ sendInvitation c (Compatible SMPQueueInfo {smpServer, senderId, dhPublicKey}) co
mkInvitation :: m ByteString
-- this is only encrypted with per-queue E2E, not with double ratchet
mkInvitation = do
let agentEnvelope = AgentInvitation {agentVersion = smpAgentVersion, connReq, connInfo}
agentVersion <- asks $ smpAgentVersion . config
let agentEnvelope = AgentInvitation {agentVersion, connReq, connInfo}
agentCbEncryptOnce dhPublicKey . smpEncode $
SMP.ClientMessage SMP.PHEmpty $ smpEncode agentEnvelope
@ -565,4 +566,5 @@ cryptoError = \case
C.CryptoHeaderError _ -> AGENT A_ENCRYPTION
C.AESDecryptError -> AGENT A_ENCRYPTION
C.CBDecryptError -> AGENT A_ENCRYPTION
-- C.CERatchetDuplicateMessage -> AGENT A_DUPLICATE
e -> INTERNAL $ show e

13
src/Simplex/Messaging/Agent/Env/SQLite.hs
View File

@ -21,7 +21,7 @@ import Data.List.NonEmpty (NonEmpty)
import Data.Time.Clock (NominalDiffTime, nominalDay)
import Network.Socket
import Numeric.Natural
import Simplex.Messaging.Agent.Protocol (SMPServer)
import Simplex.Messaging.Agent.Protocol (SMPServer, currentSMPAgentVersion, supportedSMPAgentVRange)
import Simplex.Messaging.Agent.RetryInterval
import Simplex.Messaging.Agent.Store.SQLite
import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
@ -29,6 +29,7 @@ import Simplex.Messaging.Client
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Notifications.Client (NtfServer)
import Simplex.Messaging.Transport (TLS, Transport (..))
import Simplex.Messaging.Version
import System.Random (StdGen, newStdGen)
import UnliftIO.STM
@ -52,7 +53,9 @@ data AgentConfig = AgentConfig
resubscriptionConcurrency :: Int,
caCertificateFile :: FilePath,
privateKeyFile :: FilePath,
certificateFile :: FilePath
certificateFile :: FilePath,
smpAgentVersion :: Version,
smpAgentVRange :: VersionRange
}
defaultReconnectInterval :: RetryInterval
@ -73,7 +76,7 @@ defaultAgentConfig =
connIdBytes = 12,
tbqSize = 64,
dbFile = "smp-agent.db",
dbPoolSize = 4,
dbPoolSize = 1,
yesToMigrations = False,
smpCfg = defaultClientConfig {defaultTransport = ("5223", transport @TLS)},
ntfCfg = defaultClientConfig {defaultTransport = ("443", transport @TLS)},
@ -84,7 +87,9 @@ defaultAgentConfig =
-- ! we do not generate these
caCertificateFile = "/etc/opt/simplex-agent/ca.crt",
privateKeyFile = "/etc/opt/simplex-agent/agent.key",
certificateFile = "/etc/opt/simplex-agent/agent.crt"
certificateFile = "/etc/opt/simplex-agent/agent.crt",
smpAgentVersion = currentSMPAgentVersion,
smpAgentVRange = supportedSMPAgentVRange
}
data Env = Env

37
src/Simplex/Messaging/Agent/Protocol.hs
View File

@ -32,8 +32,8 @@
-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md
module Simplex.Messaging.Agent.Protocol
( -- * Protocol parameters
smpAgentVersion,
smpAgentVRange,
currentSMPAgentVersion,
supportedSMPAgentVRange,
e2eEncConnInfoLength,
e2eEncUserMsgLength,
@ -147,11 +147,11 @@ import Test.QuickCheck (Arbitrary (..))
import Text.Read
import UnliftIO.Exception (Exception)
smpAgentVersion :: Version
smpAgentVersion = 1
currentSMPAgentVersion :: Version
currentSMPAgentVersion = 2
smpAgentVRange :: VersionRange
smpAgentVRange = mkVersionRange 1 smpAgentVersion
supportedSMPAgentVRange :: VersionRange
supportedSMPAgentVRange = mkVersionRange 1 currentSMPAgentVersion
-- it is shorter to allow all handshake headers,
-- including E2E (double-ratchet) parameters and
@ -288,7 +288,9 @@ data SMPConfirmation = SMPConfirmation
-- | 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
connInfo :: ConnInfo
connInfo :: ConnInfo,
-- | optional reply queues included in confirmation (added in agent protocol v2)
smpReplyQueues :: [SMPQueueInfo]
}
deriving (Show)
@ -334,31 +336,40 @@ instance Encoding AgentMsgEnvelope where
-- SMP agent message formats (after double ratchet decryption,
-- or in case of AgentInvitation - in plain text body)
data AgentMessage = AgentConnInfo ConnInfo | AgentMessage APrivHeader AMessage
data AgentMessage
= AgentConnInfo ConnInfo
| -- AgentConnInfoReply is only used in duplexHandshake mode (v2), allowing to include reply queue(s) in the initial confirmation.
-- It makes REPLY message unnecessary.
AgentConnInfoReply (L.NonEmpty SMPQueueInfo) ConnInfo
| AgentMessage APrivHeader AMessage
deriving (Show)
instance Encoding AgentMessage where
smpEncode = \case
AgentConnInfo cInfo -> smpEncode ('I', Tail cInfo)
AgentConnInfoReply smpQueues cInfo -> smpEncode ('D', smpQueues, Tail cInfo) -- 'D' stands for "duplex"
AgentMessage hdr aMsg -> smpEncode ('M', hdr, aMsg)
smpP =
smpP >>= \case
'I' -> AgentConnInfo . unTail <$> smpP
'D' -> AgentConnInfoReply <$> smpP <*> (unTail <$> smpP)
'M' -> AgentMessage <$> smpP <*> smpP
_ -> fail "bad AgentMessage"
data AgentMessageType = AM_CONN_INFO | AM_HELLO_ | AM_REPLY_ | AM_A_MSG_
data AgentMessageType = AM_CONN_INFO | AM_CONN_INFO_REPLY | AM_HELLO_ | AM_REPLY_ | AM_A_MSG_
deriving (Eq, Show)
instance Encoding AgentMessageType where
smpEncode = \case
AM_CONN_INFO -> "C"
AM_CONN_INFO_REPLY -> "D"
AM_HELLO_ -> "H"
AM_REPLY_ -> "R"
AM_A_MSG_ -> "M"
smpP =
A.anyChar >>= \case
'C' -> pure AM_CONN_INFO
'D' -> pure AM_CONN_INFO_REPLY
'H' -> pure AM_HELLO_
'R' -> pure AM_REPLY_
'M' -> pure AM_A_MSG_
@ -367,8 +378,14 @@ instance Encoding AgentMessageType where
agentMessageType :: AgentMessage -> AgentMessageType
agentMessageType = \case
AgentConnInfo _ -> AM_CONN_INFO
AgentConnInfoReply {} -> AM_CONN_INFO_REPLY
AgentMessage _ aMsg -> case aMsg of
-- HELLO is used both in v1 and in v2, but differently.
-- - in v1 (and, possibly, in v2 for simplex connections) can be sent multiple times,
-- until the queue is secured - the OK response from the server instead of initial AUTH errors confirms it.
-- - in v2 duplexHandshake it is sent only once, when it is known that the queue was secured.
HELLO -> AM_HELLO_
-- REPLY is only used in v1
REPLY _ -> AM_REPLY_
A_MSG _ -> AM_A_MSG_
@ -766,6 +783,8 @@ data SMPAgentError
A_VERSION
| -- | cannot decrypt message
A_ENCRYPTION
| -- | duplicate message - this error is detected by ratchet decryption - this message will be ignored and not shown
A_DUPLICATE
deriving (Eq, Generic, Read, Show, Exception)
instance ToJSON SMPAgentError where

10
src/Simplex/Messaging/Agent/Store.hs
View File

@ -31,6 +31,7 @@ import Simplex.Messaging.Protocol
SndPrivateSignKey,
)
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Version
-- * Store management
@ -53,6 +54,7 @@ class Monad m => MonadAgentStore s m where
acceptConfirmation :: s -> ConfirmationId -> ConnInfo -> m AcceptedConfirmation
getAcceptedConfirmation :: s -> ConnId -> m AcceptedConfirmation
removeConfirmations :: s -> ConnId -> m ()
setHandshakeVersion :: s -> ConnId -> Version -> Bool -> m ()
-- Invitations - sent via Contact connections
createInvitation :: s -> TVar ChaChaDRG -> NewInvitation -> m InvitationId
@ -184,7 +186,11 @@ instance Eq SomeConn where
deriving instance Show SomeConn
newtype ConnData = ConnData {connId :: ConnId}
data ConnData = ConnData
{ connId :: ConnId,
connAgentVersion :: Version,
duplexHandshake :: Maybe Bool -- added in agent protocol v2
}
deriving (Eq, Show)
-- * Confirmation types
@ -327,4 +333,6 @@ data StoreError
SEX3dhKeysNotFound
| -- | Used in `getMsg` that is not implemented/used. TODO remove.
SENotImplemented
| -- | Used to wrap agent errors inside store operations to avoid race conditions
SEAgentError AgentErrorType
deriving (Eq, Show, Exception)

46
src/Simplex/Messaging/Agent/Store/SQLite.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
@ -19,6 +20,7 @@
module Simplex.Messaging.Agent.Store.SQLite
( SQLiteStore (..),
AgentStoreMonad,
createSQLiteStore,
connectSQLiteStore,
withConnection,
@ -40,7 +42,7 @@ import Data.Char (toLower)
import Data.Functor (($>))
import Data.List (find, foldl', partition)
import qualified Data.Map.Strict as M
import Data.Maybe (listToMaybe)
import Data.Maybe (fromMaybe, listToMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
@ -64,6 +66,7 @@ import Simplex.Messaging.Parsers (blobFieldParser, fromTextField_)
import Simplex.Messaging.Protocol (MsgBody, MsgFlags, ProtocolServer (..))
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Util (bshow, eitherToMaybe, liftIOEither)
import Simplex.Messaging.Version
import System.Directory (copyFile, createDirectoryIfMissing, doesFileExist)
import System.Exit (exitFailure)
import System.FilePath (takeDirectory)
@ -187,19 +190,21 @@ createConn_ st gVar cData create =
ConnData {connId = ""} -> createWithRandomId gVar $ create db
ConnData {connId} -> create db connId $> Right connId
type AgentStoreMonad m = (MonadUnliftIO m, MonadError StoreError m, MonadAgentStore SQLiteStore m)
instance (MonadUnliftIO m, MonadError StoreError m) => MonadAgentStore SQLiteStore m where
createRcvConn :: SQLiteStore -> TVar ChaChaDRG -> ConnData -> RcvQueue -> SConnectionMode c -> m ConnId
createRcvConn st gVar cData q@RcvQueue {server} cMode =
createConn_ st gVar cData $ \db connId -> do
upsertServer_ db server
DB.execute db "INSERT INTO connections (conn_id, conn_mode) VALUES (?, ?)" (connId, cMode)
DB.execute db "INSERT INTO connections (conn_id, conn_mode, smp_agent_version, duplex_handshake) VALUES (?, ?, ?, ?)" (connId, cMode, connAgentVersion cData, duplexHandshake cData)
insertRcvQueue_ db connId q
createSndConn :: SQLiteStore -> TVar ChaChaDRG -> ConnData -> SndQueue -> m ConnId
createSndConn st gVar cData q@SndQueue {server} =
createConn_ st gVar cData $ \db connId -> do
upsertServer_ db server
DB.execute db "INSERT INTO connections (conn_id, conn_mode) VALUES (?, ?)" (connId, SCMInvitation)
DB.execute db "INSERT INTO connections (conn_id, conn_mode, smp_agent_version, duplex_handshake) VALUES (?, ?, ?, ?)" (connId, SCMInvitation, connAgentVersion cData, duplexHandshake cData)
insertSndQueue_ db connId q
getConn :: SQLiteStore -> ConnId -> m SomeConn
@ -297,16 +302,16 @@ instance (MonadUnliftIO m, MonadError StoreError m) => MonadAgentStore SQLiteSto
[":status" := status, ":host" := host, ":port" := port, ":snd_id" := sndId]
createConfirmation :: SQLiteStore -> TVar ChaChaDRG -> NewConfirmation -> m ConfirmationId
createConfirmation st gVar NewConfirmation {connId, senderConf = SMPConfirmation {senderKey, e2ePubKey, connInfo}, ratchetState} =
createConfirmation st gVar NewConfirmation {connId, senderConf = SMPConfirmation {senderKey, e2ePubKey, connInfo, smpReplyQueues}, ratchetState} =
liftIOEither . withTransaction st $ \db ->
createWithRandomId gVar $ \confirmationId ->
DB.execute
db
[sql|
INSERT INTO conn_confirmations
(confirmation_id, conn_id, sender_key, e2e_snd_pub_key, ratchet_state, sender_conn_info, accepted) VALUES (?, ?, ?, ?, ?, ?, 0);
(confirmation_id, conn_id, sender_key, e2e_snd_pub_key, ratchet_state, sender_conn_info, smp_reply_queues, accepted) VALUES (?, ?, ?, ?, ?, ?, ?, 0);
|]
(confirmationId, connId, senderKey, e2ePubKey, ratchetState, connInfo)
(confirmationId, connId, senderKey, e2ePubKey, ratchetState, connInfo, smpReplyQueues)
acceptConfirmation :: SQLiteStore -> ConfirmationId -> ConnInfo -> m AcceptedConfirmation
acceptConfirmation st confirmationId ownConnInfo =
@ -326,17 +331,17 @@ instance (MonadUnliftIO m, MonadError StoreError m) => MonadAgentStore SQLiteSto
DB.query
db
[sql|
SELECT conn_id, sender_key, e2e_snd_pub_key, ratchet_state, sender_conn_info
SELECT conn_id, sender_key, e2e_snd_pub_key, ratchet_state, sender_conn_info, smp_reply_queues
FROM conn_confirmations
WHERE confirmation_id = ?;
|]
(Only confirmationId)
where
confirmation (connId, senderKey, e2ePubKey, ratchetState, connInfo) =
confirmation (connId, senderKey, e2ePubKey, ratchetState, connInfo, smpReplyQueues_) =
AcceptedConfirmation
{ confirmationId,
connId,
senderConf = SMPConfirmation {senderKey, e2ePubKey, connInfo},
senderConf = SMPConfirmation {senderKey, e2ePubKey, connInfo, smpReplyQueues = fromMaybe [] smpReplyQueues_},
ratchetState,
ownConnInfo
}
@ -348,17 +353,17 @@ instance (MonadUnliftIO m, MonadError StoreError m) => MonadAgentStore SQLiteSto
DB.query
db
[sql|
SELECT confirmation_id, sender_key, e2e_snd_pub_key, ratchet_state, sender_conn_info, own_conn_info
SELECT confirmation_id, sender_key, e2e_snd_pub_key, ratchet_state, sender_conn_info, smp_reply_queues, own_conn_info
FROM conn_confirmations
WHERE conn_id = ? AND accepted = 1;
|]
(Only connId)
where
confirmation (confirmationId, senderKey, e2ePubKey, ratchetState, connInfo, ownConnInfo) =
confirmation (confirmationId, senderKey, e2ePubKey, ratchetState, connInfo, smpReplyQueues_, ownConnInfo) =
AcceptedConfirmation
{ confirmationId,
connId,
senderConf = SMPConfirmation {senderKey, e2ePubKey, connInfo},
senderConf = SMPConfirmation {senderKey, e2ePubKey, connInfo, smpReplyQueues = fromMaybe [] smpReplyQueues_},
ratchetState,
ownConnInfo
}
@ -374,6 +379,11 @@ instance (MonadUnliftIO m, MonadError StoreError m) => MonadAgentStore SQLiteSto
|]
[":conn_id" := connId]
setHandshakeVersion :: SQLiteStore -> ConnId -> Version -> Bool -> m ()
setHandshakeVersion st connId aVersion duplexHS =
liftIO . withTransaction st $ \db ->
DB.execute db "UPDATE connections SET smp_agent_version = ?, duplex_handshake = ? WHERE conn_id = ?" (aVersion, duplexHS, connId)
createInvitation :: SQLiteStore -> TVar ChaChaDRG -> NewInvitation -> m InvitationId
createInvitation st gVar NewInvitation {contactConnId, connReq, recipientConnInfo} =
liftIOEither . withTransaction st $ \db ->
@ -685,6 +695,10 @@ instance ToField MsgFlags where toField = toField . decodeLatin1 . smpEncode
instance FromField MsgFlags where fromField = fromTextField_ $ eitherToMaybe . smpDecode . encodeUtf8
instance ToField [SMPQueueInfo] where toField = toField . smpEncodeList
instance FromField [SMPQueueInfo] where fromField = blobFieldParser smpListP
listToEither :: e -> [a] -> Either e a
listToEither _ (x : _) = Right x
listToEither e _ = Left e
@ -692,6 +706,10 @@ listToEither e _ = Left e
firstRow :: (a -> b) -> e -> IO [a] -> IO (Either e b)
firstRow f e a = second f . listToEither e <$> a
-- TODO move from simplex-chat
-- firstRow' :: (a -> Either e b) -> e -> IO [a] -> IO (Either e b)
-- firstRow' f e a = (f <=< listToEither e) <$> a
{- ORMOLU_DISABLE -}
-- SQLite.Simple only has these up to 10 fields, which is insufficient for some of our queries
instance (FromField a, FromField b, FromField c, FromField d, FromField e,
@ -791,9 +809,9 @@ getConn_ dbConn connId =
getConnData_ :: DB.Connection -> ConnId -> IO (Maybe (ConnData, ConnectionMode))
getConnData_ dbConn connId' =
connData
<$> DB.query dbConn "SELECT conn_id, conn_mode FROM connections WHERE conn_id = ?;" (Only connId')
<$> DB.query dbConn "SELECT conn_id, conn_mode, smp_agent_version, duplex_handshake FROM connections WHERE conn_id = ?;" (Only connId')
where
connData [(connId, cMode)] = Just (ConnData {connId}, cMode)
connData [(connId, cMode, connAgentVersion, duplexHandshake)] = Just (ConnData {connId, connAgentVersion, duplexHandshake}, cMode)
connData _ = Nothing
getRcvQueueByConnId_ :: DB.Connection -> ConnId -> IO (Maybe RcvQueue)

4
src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs
View File

@ -27,7 +27,7 @@ import qualified Database.SQLite3 as SQLite3
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220101_initial
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220301_snd_queue_keys
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220322_notifications
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220605_msg_flags
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220608_v2
data Migration = Migration {name :: String, up :: Text}
deriving (Show)
@ -37,7 +37,7 @@ schemaMigrations =
[ ("20220101_initial", m20220101_initial),
("20220301_snd_queue_keys", m20220301_snd_queue_keys),
("20220322_notifications", m20220322_notifications),
("20220605_msg_flags", m20220605_msg_flags)
("20220607_v2", m20220608_v2)
]
-- | The list of migrations in ascending order by date

12
src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20220605_msg_flags.hs
View File

@ -1,12 +0,0 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220605_msg_flags where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20220605_msg_flags :: Query
m20220605_msg_flags =
[sql|
ALTER TABLE messages ADD COLUMN msg_flags TEXT NULL;
|]

16
src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20220608_v2.hs Normal file
View File

@ -0,0 +1,16 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220608_v2 where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20220608_v2 :: Query
m20220608_v2 =
[sql|
ALTER TABLE messages ADD COLUMN msg_flags TEXT NULL;
ALTER TABLE conn_confirmations ADD COLUMN smp_reply_queues BLOB NULL;
ALTER TABLE connections ADD COLUMN duplex_handshake INTEGER NULL DEFAULT 0;
|]

4
src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql
View File

@ -19,6 +19,8 @@ CREATE TABLE connections(
last_rcv_msg_hash BLOB NOT NULL DEFAULT x'',
last_snd_msg_hash BLOB NOT NULL DEFAULT x'',
smp_agent_version INTEGER NOT NULL DEFAULT 1
,
duplex_handshake INTEGER NULL DEFAULT 0
) WITHOUT ROWID;
CREATE TABLE rcv_queues(
host TEXT NOT NULL,
@ -105,6 +107,8 @@ CREATE TABLE conn_confirmations(
accepted INTEGER NOT NULL,
own_conn_info BLOB,
created_at TEXT NOT NULL DEFAULT(datetime('now'))
,
smp_reply_queues BLOB NULL
) WITHOUT ROWID;
CREATE TABLE conn_invitations(
invitation_id BLOB NOT NULL PRIMARY KEY,

11
src/Simplex/Messaging/Client.hs
View File

@ -106,7 +106,9 @@ data ProtocolClientConfig = ProtocolClientConfig
-- | TCP keep-alive options, Nothing to skip enabling keep-alive
tcpKeepAlive :: Maybe KeepAliveOpts,
-- | period for SMP ping commands (microseconds)
smpPing :: Int
smpPing :: Int,
-- | SMP client-server protocol version range
smpServerVRange :: VersionRange
}
-- | Default protocol client configuration.
@ -117,7 +119,8 @@ defaultClientConfig =
defaultTransport = ("443", transport @TLS),
tcpTimeout = 5_000_000,
tcpKeepAlive = Just defaultKeepAliveOpts,
smpPing = 600_000_000 -- 10min
smpPing = 600_000_000, -- 10min
smpServerVRange = supportedSMPServerVRange
}
data Request msg = Request
@ -133,7 +136,7 @@ type Response msg = Either ProtocolClientError msg
-- A single queue can be used for multiple 'SMPClient' instances,
-- as 'SMPServerTransmission' includes server information.
getProtocolClient :: forall msg. Protocol msg => ProtocolServer -> ProtocolClientConfig -> Maybe (TBQueue (ServerTransmission msg)) -> IO () -> IO (Either ProtocolClientError (ProtocolClient msg))
getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, tcpTimeout, tcpKeepAlive, smpPing} msgQ disconnected =
getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, tcpTimeout, tcpKeepAlive, smpPing, smpServerVRange} msgQ disconnected =
(atomically mkProtocolClient >>= runClient useTransport)
`catch` \(e :: IOException) -> pure . Left $ PCEIOError e
where
@ -180,7 +183,7 @@ getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, tcpTimeout, tc
client :: forall c. Transport c => TProxy c -> ProtocolClient msg -> TMVar (Either ProtocolClientError (THandle c)) -> c -> IO ()
client _ c thVar h =
runExceptT (protocolClientHandshake @msg h $ keyHash protocolServer) >>= \case
runExceptT (protocolClientHandshake @msg h (keyHash protocolServer) smpServerVRange) >>= \case
Left e -> atomically . putTMVar thVar . Left $ PCETransportError e
Right th@THandle {sessionId, thVersion} -> do
atomically $ do

4
src/Simplex/Messaging/Crypto.hs
View File

@ -678,7 +678,9 @@ data CryptoError
CERatchetHeader
| -- | too many skipped messages
CERatchetTooManySkipped
| -- | duplicate message number (or, possibly, skipped message that failed to decrypt?)
| -- | earlier message number (or, possibly, skipped message that failed to decrypt?)
CERatchetEarlierMessage
| -- | duplicate message number
CERatchetDuplicateMessage
deriving (Eq, Show, Exception)

3
src/Simplex/Messaging/Crypto/Ratchet.hs
View File

@ -416,7 +416,8 @@ rcDecrypt rc@Ratchet {rcRcv, rcAD = Str rcAD} rcMKSkipped msg' = do
skipMessageKeys :: Word32 -> Ratchet a -> Either CryptoError (Ratchet a, SkippedMsgKeys)
skipMessageKeys _ r@Ratchet {rcRcv = Nothing} = Right (r, M.empty)
skipMessageKeys untilN r@Ratchet {rcRcv = Just rr@RcvRatchet {rcCKr, rcHKr}, rcNr}
| rcNr > untilN = Left CERatchetDuplicateMessage
| rcNr > untilN + 1 = Left CERatchetEarlierMessage
| rcNr == untilN + 1 = Left CERatchetDuplicateMessage
| rcNr + maxSkip < untilN = Left CERatchetTooManySkipped
| rcNr == untilN = Right (r, M.empty)
| otherwise =

2
src/Simplex/Messaging/Notifications/Server.hs
View File

@ -61,7 +61,7 @@ ntfServer NtfServerConfig {transports} started = do
runClient :: Transport c => TProxy c -> c -> m ()
runClient _ h = do
kh <- asks serverIdentity
liftIO (runExceptT $ ntfServerHandshake h kh) >>= \case
liftIO (runExceptT $ ntfServerHandshake h kh supportedNTFServerVRange) >>= \case
Right th -> runNtfClientTransport th
Left _ -> pure ()

12
src/Simplex/Messaging/Notifications/Transport.hs
View File

@ -3,17 +3,21 @@ module Simplex.Messaging.Notifications.Transport where
import Control.Monad.Except
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Transport
import Simplex.Messaging.Version
ntfBlockSize :: Int
ntfBlockSize = 512
supportedNTFServerVRange :: VersionRange
supportedNTFServerVRange = mkVersionRange 1 1
-- | Notifcations server transport handshake.
ntfServerHandshake :: Transport c => c -> C.KeyHash -> ExceptT TransportError IO (THandle c)
ntfServerHandshake c _ = pure $ ntfTHandle c
ntfServerHandshake :: Transport c => c -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c)
ntfServerHandshake c _ _ = pure $ ntfTHandle c
-- | Notifcations server client transport handshake.
ntfClientHandshake :: Transport c => c -> C.KeyHash -> ExceptT TransportError IO (THandle c)
ntfClientHandshake c _ = pure $ ntfTHandle c
ntfClientHandshake :: Transport c => c -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c)
ntfClientHandshake c _ _ = pure $ ntfTHandle c
ntfTHandle :: Transport c => c -> THandle c
ntfTHandle c = THandle {connection = c, sessionId = tlsUnique c, blockSize = ntfBlockSize, thVersion = 0}

2
src/Simplex/Messaging/Protocol.hs
View File

@ -584,7 +584,7 @@ transmissionP = do
class (ProtocolEncoding msg, ProtocolEncoding (ProtocolCommand msg)) => Protocol msg where
type ProtocolCommand msg = cmd | cmd -> msg
protocolClientHandshake :: forall c. Transport c => c -> C.KeyHash -> ExceptT TransportError IO (THandle c)
protocolClientHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c)
protocolPing :: ProtocolCommand msg
protocolError :: msg -> Maybe ErrorType

3
src/Simplex/Messaging/Server.hs
View File

@ -175,7 +175,8 @@ smpServer started = do
runClient :: Transport c => TProxy c -> c -> m ()
runClient _ h = do
kh <- asks serverIdentity
liftIO (runExceptT $ smpServerHandshake h kh) >>= \case
smpVRange <- asks $ smpServerVRange . config
liftIO (runExceptT $ smpServerHandshake h kh smpVRange) >>= \case
Right th -> runClientTransport th
Left _ -> pure ()

5
src/Simplex/Messaging/Server/Env/STM.hs
View File

@ -31,6 +31,7 @@ import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport (ATransport)
import Simplex.Messaging.Transport.Server (loadFingerprint, loadTLSServerParams)
import Simplex.Messaging.Version
import System.IO (IOMode (..))
import System.Mem.Weak (Weak)
import UnliftIO.STM
@ -58,7 +59,9 @@ data ServerConfig = ServerConfig
-- | CA certificate private key is not needed for initialization
caCertificateFile :: FilePath,
privateKeyFile :: FilePath,
certificateFile :: FilePath
certificateFile :: FilePath,
-- | SMP client-server protocol version range
smpServerVRange :: VersionRange
}
defaultMessageExpiration :: ExpirationConfig

20
src/Simplex/Messaging/Transport.hs
View File

@ -26,7 +26,7 @@
-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a
module Simplex.Messaging.Transport
( -- * SMP transport parameters
supportedSMPVersions,
supportedSMPServerVRange,
simplexMQVersion,
-- * Transport connection class
@ -92,8 +92,8 @@ import UnliftIO.STM
smpBlockSize :: Int
smpBlockSize = 16384
supportedSMPVersions :: VersionRange
supportedSMPVersions = mkVersionRange 1 2
supportedSMPServerVRange :: VersionRange
supportedSMPServerVRange = mkVersionRange 1 2
simplexMQVersion :: String
simplexMQVersion = "2.2.1"
@ -351,28 +351,28 @@ tGetBlock THandle {connection = c, blockSize} =
-- | 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 -> ExceptT TransportError IO (THandle c)
smpServerHandshake c kh = do
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 = supportedSMPVersions}
sendHandshake th $ ServerHandshake {sessionId, smpVersionRange = smpVRange}
getHandshake th >>= \case
ClientHandshake {smpVersion, keyHash}
| keyHash /= kh ->
throwE $ TEHandshake IDENTITY
| smpVersion `isCompatible` supportedSMPVersions -> do
| smpVersion `isCompatible` smpVRange -> do
pure (th :: THandle c) {thVersion = smpVersion}
| 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 -> ExceptT TransportError IO (THandle c)
smpClientHandshake c keyHash = do
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
if sessionId /= sessId
then throwE TEBadSession
else case smpVersionRange `compatibleVersion` supportedSMPVersions of
else case smpVersionRange `compatibleVersion` smpVRange of
Just (Compatible smpVersion) -> do
sendHandshake th $ ClientHandshake {smpVersion, keyHash}
pure (th :: THandle c) {thVersion = smpVersion}

136
tests/AgentTests.hs
View File

@ -132,25 +132,25 @@ testDuplexConnection _ alice bob = do
bob <# ("", "alice", CON)
alice <# ("", "bob", CON)
-- message IDs 1 to 3 get assigned to control messages, so first MSG is assigned ID 4
alice #: ("3", "bob", "SEND F :hello") #> ("3", "bob", MID 5)
alice <# ("", "bob", SENT 5)
alice #: ("3", "bob", "SEND F :hello") #> ("3", "bob", MID 4)
alice <# ("", "bob", SENT 4)
bob <#= \case ("", "alice", Msg "hello") -> True; _ -> False
bob #: ("12", "alice", "ACK 5") #> ("12", "alice", OK)
alice #: ("4", "bob", "SEND F :how are you?") #> ("4", "bob", MID 6)
alice <# ("", "bob", SENT 6)
bob #: ("12", "alice", "ACK 4") #> ("12", "alice", OK)
alice #: ("4", "bob", "SEND F :how are you?") #> ("4", "bob", MID 5)
alice <# ("", "bob", SENT 5)
bob <#= \case ("", "alice", Msg "how are you?") -> True; _ -> False
bob #: ("13", "alice", "ACK 6") #> ("13", "alice", OK)
bob #: ("14", "alice", "SEND F 9\nhello too") #> ("14", "alice", MID 7)
bob <# ("", "alice", SENT 7)
bob #: ("13", "alice", "ACK 5") #> ("13", "alice", OK)
bob #: ("14", "alice", "SEND F 9\nhello too") #> ("14", "alice", MID 6)
bob <# ("", "alice", SENT 6)
alice <#= \case ("", "bob", Msg "hello too") -> True; _ -> False
alice #: ("3a", "bob", "ACK 7") #> ("3a", "bob", OK)
bob #: ("15", "alice", "SEND F 9\nmessage 1") #> ("15", "alice", MID 8)
bob <# ("", "alice", SENT 8)
alice #: ("3a", "bob", "ACK 6") #> ("3a", "bob", OK)
bob #: ("15", "alice", "SEND F 9\nmessage 1") #> ("15", "alice", MID 7)
bob <# ("", "alice", SENT 7)
alice <#= \case ("", "bob", Msg "message 1") -> True; _ -> False
alice #: ("4a", "bob", "ACK 8") #> ("4a", "bob", OK)
alice #: ("4a", "bob", "ACK 7") #> ("4a", "bob", OK)
alice #: ("5", "bob", "OFF") #> ("5", "bob", OK)
bob #: ("17", "alice", "SEND F 9\nmessage 3") #> ("17", "alice", MID 9)
bob <# ("", "alice", MERR 9 (SMP AUTH))
bob #: ("17", "alice", "SEND F 9\nmessage 3") #> ("17", "alice", MID 8)
bob <# ("", "alice", MERR 8 (SMP AUTH))
alice #: ("6", "bob", "DEL") #> ("6", "bob", OK)
alice #:# "nothing else should be delivered to alice"
@ -165,25 +165,25 @@ testDuplexConnRandomIds _ alice bob = do
bob <# ("", aliceConn, INFO "alice's connInfo")
bob <# ("", aliceConn, CON)
alice <# ("", bobConn, CON)
alice #: ("2", bobConn, "SEND F :hello") #> ("2", bobConn, MID 5)
alice <# ("", bobConn, SENT 5)
alice #: ("2", bobConn, "SEND F :hello") #> ("2", bobConn, MID 4)
alice <# ("", bobConn, SENT 4)
bob <#= \case ("", c, Msg "hello") -> c == aliceConn; _ -> False
bob #: ("12", aliceConn, "ACK 5") #> ("12", aliceConn, OK)
alice #: ("3", bobConn, "SEND F :how are you?") #> ("3", bobConn, MID 6)
alice <# ("", bobConn, SENT 6)
bob #: ("12", aliceConn, "ACK 4") #> ("12", aliceConn, OK)
alice #: ("3", bobConn, "SEND F :how are you?") #> ("3", bobConn, MID 5)
alice <# ("", bobConn, SENT 5)
bob <#= \case ("", c, Msg "how are you?") -> c == aliceConn; _ -> False
bob #: ("13", aliceConn, "ACK 6") #> ("13", aliceConn, OK)
bob #: ("14", aliceConn, "SEND F 9\nhello too") #> ("14", aliceConn, MID 7)
bob <# ("", aliceConn, SENT 7)
bob #: ("13", aliceConn, "ACK 5") #> ("13", aliceConn, OK)
bob #: ("14", aliceConn, "SEND F 9\nhello too") #> ("14", aliceConn, MID 6)
bob <# ("", aliceConn, SENT 6)
alice <#= \case ("", c, Msg "hello too") -> c == bobConn; _ -> False
alice #: ("3a", bobConn, "ACK 7") #> ("3a", bobConn, OK)
bob #: ("15", aliceConn, "SEND F 9\nmessage 1") #> ("15", aliceConn, MID 8)
bob <# ("", aliceConn, SENT 8)
alice #: ("3a", bobConn, "ACK 6") #> ("3a", bobConn, OK)
bob #: ("15", aliceConn, "SEND F 9\nmessage 1") #> ("15", aliceConn, MID 7)
bob <# ("", aliceConn, SENT 7)
alice <#= \case ("", c, Msg "message 1") -> c == bobConn; _ -> False
alice #: ("4a", bobConn, "ACK 8") #> ("4a", bobConn, OK)
alice #: ("4a", bobConn, "ACK 7") #> ("4a", bobConn, OK)
alice #: ("5", bobConn, "OFF") #> ("5", bobConn, OK)
bob #: ("17", aliceConn, "SEND F 9\nmessage 3") #> ("17", aliceConn, MID 9)
bob <# ("", aliceConn, MERR 9 (SMP AUTH))
bob #: ("17", aliceConn, "SEND F 9\nmessage 3") #> ("17", aliceConn, MID 8)
bob <# ("", aliceConn, MERR 8 (SMP AUTH))
alice #: ("6", bobConn, "DEL") #> ("6", bobConn, OK)
alice #:# "nothing else should be delivered to alice"
@ -200,10 +200,10 @@ testContactConnection _ alice bob tom = do
alice <# ("", "bob", INFO "bob's connInfo 2")
alice <# ("", "bob", CON)
bob <# ("", "alice", CON)
alice #: ("3", "bob", "SEND F :hi") #> ("3", "bob", MID 5)
alice <# ("", "bob", SENT 5)
alice #: ("3", "bob", "SEND F :hi") #> ("3", "bob", MID 4)
alice <# ("", "bob", SENT 4)
bob <#= \case ("", "alice", Msg "hi") -> True; _ -> False
bob #: ("13", "alice", "ACK 5") #> ("13", "alice", OK)
bob #: ("13", "alice", "ACK 4") #> ("13", "alice", OK)
tom #: ("21", "alice", "JOIN " <> cReq' <> " 14\ntom's connInfo") #> ("21", "alice", OK)
("", "alice_contact", Right (REQ aInvId' "tom's connInfo")) <- (alice <#:)
@ -213,10 +213,10 @@ testContactConnection _ alice bob tom = do
alice <# ("", "tom", INFO "tom's connInfo 2")
alice <# ("", "tom", CON)
tom <# ("", "alice", CON)
alice #: ("5", "tom", "SEND F :hi there") #> ("5", "tom", MID 5)
alice <# ("", "tom", SENT 5)
alice #: ("5", "tom", "SEND F :hi there") #> ("5", "tom", MID 4)
alice <# ("", "tom", SENT 4)
tom <#= \case ("", "alice", Msg "hi there") -> True; _ -> False
tom #: ("23", "alice", "ACK 5") #> ("23", "alice", OK)
tom #: ("23", "alice", "ACK 4") #> ("23", "alice", OK)
testContactConnRandomIds :: Transport c => TProxy c -> c -> c -> IO ()
testContactConnRandomIds _ alice bob = do
@ -236,10 +236,10 @@ testContactConnRandomIds _ alice bob = do
alice <# ("", bobConn, CON)
bob <# ("", aliceConn, CON)
alice #: ("3", bobConn, "SEND F :hi") #> ("3", bobConn, MID 5)
alice <# ("", bobConn, SENT 5)
alice #: ("3", bobConn, "SEND F :hi") #> ("3", bobConn, MID 4)
alice <# ("", bobConn, SENT 4)
bob <#= \case ("", c, Msg "hi") -> c == aliceConn; _ -> False
bob #: ("13", aliceConn, "ACK 5") #> ("13", aliceConn, OK)
bob #: ("13", aliceConn, "ACK 4") #> ("13", aliceConn, OK)
testRejectContactRequest :: Transport c => TProxy c -> c -> c -> IO ()
testRejectContactRequest _ alice bob = do
@ -256,20 +256,20 @@ testRejectContactRequest _ alice bob = do
testSubscription :: Transport c => TProxy c -> c -> c -> c -> IO ()
testSubscription _ alice1 alice2 bob = do
(alice1, "alice") `connect` (bob, "bob")
bob #: ("12", "alice", "SEND F 5\nhello") #> ("12", "alice", MID 5)
bob <# ("", "alice", SENT 5)
bob #: ("12", "alice", "SEND F 5\nhello") #> ("12", "alice", MID 4)
bob <# ("", "alice", SENT 4)
alice1 <#= \case ("", "bob", Msg "hello") -> True; _ -> False
alice1 #: ("1", "bob", "ACK 5") #> ("1", "bob", OK)
bob #: ("13", "alice", "SEND F 11\nhello again") #> ("13", "alice", MID 6)
bob <# ("", "alice", SENT 6)
alice1 #: ("1", "bob", "ACK 4") #> ("1", "bob", OK)
bob #: ("13", "alice", "SEND F 11\nhello again") #> ("13", "alice", MID 5)
bob <# ("", "alice", SENT 5)
alice1 <#= \case ("", "bob", Msg "hello again") -> True; _ -> False
alice1 #: ("2", "bob", "ACK 6") #> ("2", "bob", OK)
alice1 #: ("2", "bob", "ACK 5") #> ("2", "bob", OK)
alice2 #: ("21", "bob", "SUB") #> ("21", "bob", OK)
alice1 <# ("", "bob", END)
bob #: ("14", "alice", "SEND F 2\nhi") #> ("14", "alice", MID 7)
bob <# ("", "alice", SENT 7)
bob #: ("14", "alice", "SEND F 2\nhi") #> ("14", "alice", MID 6)
bob <# ("", "alice", SENT 6)
alice2 <#= \case ("", "bob", Msg "hi") -> True; _ -> False
alice2 #: ("22", "bob", "ACK 7") #> ("22", "bob", OK)
alice2 #: ("22", "bob", "ACK 6") #> ("22", "bob", OK)
alice1 #:# "nothing else should be delivered to alice1"
testSubscrNotification :: Transport c => TProxy c -> (ThreadId, ThreadId) -> c -> IO ()
@ -285,23 +285,23 @@ testMsgDeliveryServerRestart :: Transport c => TProxy c -> c -> c -> IO ()
testMsgDeliveryServerRestart t alice bob = do
withServer $ do
connect (alice, "alice") (bob, "bob")
bob #: ("1", "alice", "SEND F 2\nhi") #> ("1", "alice", MID 5)
bob <# ("", "alice", SENT 5)
bob #: ("1", "alice", "SEND F 2\nhi") #> ("1", "alice", MID 4)
bob <# ("", "alice", SENT 4)
alice <#= \case ("", "bob", Msg "hi") -> True; _ -> False
alice #: ("11", "bob", "ACK 5") #> ("11", "bob", OK)
alice #: ("11", "bob", "ACK 4") #> ("11", "bob", OK)
alice #:# "nothing else delivered before the server is killed"
let server = (SMPServer "localhost" testPort2 testKeyHash)
alice <# ("", "", DOWN server ["bob"])
bob #: ("2", "alice", "SEND F 11\nhello again") #> ("2", "alice", MID 6)
bob #: ("2", "alice", "SEND F 11\nhello again") #> ("2", "alice", MID 5)
bob #:# "nothing else delivered before the server is restarted"
alice #:# "nothing else delivered before the server is restarted"
withServer $ do
bob <# ("", "alice", SENT 6)
bob <# ("", "alice", SENT 5)
alice <# ("", "", UP server ["bob"])
alice <#= \case ("", "bob", Msg "hello again") -> True; _ -> False
alice #: ("12", "bob", "ACK 6") #> ("12", "bob", OK)
alice #: ("12", "bob", "ACK 5") #> ("12", "bob", OK)
removeFile testStoreLogFile
where
@ -316,7 +316,7 @@ testServerConnectionAfterError t _ = do
bob <# ("", "", DOWN server ["alice"])
alice <# ("", "", DOWN server ["bob"])
alice #: ("1", "bob", "SEND F 5\nhello") #> ("1", "bob", MID 5)
alice #: ("1", "bob", "SEND F 5\nhello") #> ("1", "bob", MID 4)
alice #:# "nothing else delivered before the server is restarted"
bob #:# "nothing else delivered before the server is restarted"
@ -325,13 +325,13 @@ testServerConnectionAfterError t _ = do
bob #: ("1", "alice", "SUB") #> ("1", "alice", ERR (BROKER NETWORK))
alice #: ("1", "bob", "SUB") #> ("1", "bob", ERR (BROKER NETWORK))
withServer $ do
alice <# ("", "bob", SENT 5)
alice <# ("", "bob", SENT 4)
bob <# ("", "", UP server ["alice"])
bob <#= \case ("", "alice", Msg "hello") -> True; _ -> False
bob #: ("2", "alice", "ACK 5") #> ("2", "alice", OK)
bob #: ("2", "alice", "ACK 4") #> ("2", "alice", OK)
alice <# ("", "", UP server ["bob"])
alice #: ("1", "bob", "SEND F 11\nhello again") #> ("1", "bob", MID 6)
alice <# ("", "bob", SENT 6)
alice #: ("1", "bob", "SEND F 11\nhello again") #> ("1", "bob", MID 5)
alice <# ("", "bob", SENT 5)
bob <#= \case ("", "alice", Msg "hello again") -> True; _ -> False
removeFile testStoreLogFile
@ -351,14 +351,14 @@ testMsgDeliveryAgentRestart t bob = do
withAgent $ \alice -> do
withServer $ do
connect (bob, "bob") (alice, "alice")
alice #: ("1", "bob", "SEND F 5\nhello") #> ("1", "bob", MID 5)
alice <# ("", "bob", SENT 5)
alice #: ("1", "bob", "SEND F 5\nhello") #> ("1", "bob", MID 4)
alice <# ("", "bob", SENT 4)
bob <#= \case ("", "alice", Msg "hello") -> True; _ -> False
bob #: ("11", "alice", "ACK 5") #> ("11", "alice", OK)
bob #: ("11", "alice", "ACK 4") #> ("11", "alice", OK)
bob #:# "nothing else delivered before the server is down"
bob <# ("", "", DOWN server ["alice"])
alice #: ("2", "bob", "SEND F 11\nhello again") #> ("2", "bob", MID 6)
alice #: ("2", "bob", "SEND F 11\nhello again") #> ("2", "bob", MID 5)
alice #:# "nothing else delivered before the server is restarted"
bob #:# "nothing else delivered before the server is restarted"
@ -368,11 +368,11 @@ testMsgDeliveryAgentRestart t bob = do
alice <#= \case
(corrId, "bob", cmd) ->
(corrId == "3" && cmd == OK)
|| (corrId == "" && cmd == SENT 6)
|| (corrId == "" && cmd == SENT 5)
_ -> False
bob <# ("", "", UP server ["alice"])
bob <#= \case ("", "alice", Msg "hello again") -> True; _ -> False
bob #: ("12", "alice", "ACK 6") #> ("12", "alice", OK)
bob #: ("12", "alice", "ACK 5") #> ("12", "alice", OK)
removeFile testStoreLogFile
removeFile testDB
@ -400,11 +400,11 @@ testConcurrentMsgDelivery _ alice bob = do
-- alice <# ("", "bob", SENT 1)
-- bob <#= \case ("", "alice", Msg "hello") -> True; _ -> False
-- bob #: ("12", "alice", "ACK 1") #> ("12", "alice", OK)
bob #: ("14", "alice", "SEND F 9\nhello too") #> ("14", "alice", MID 6)
bob <# ("", "alice", SENT 6)
bob #: ("14", "alice", "SEND F 9\nhello too") #> ("14", "alice", MID 5)
bob <# ("", "alice", SENT 5)
-- if delivery is blocked it won't go further
alice <#= \case ("", "bob", Msg "hello too") -> True; _ -> False
alice #: ("3", "bob", "ACK 6") #> ("3", "bob", OK)
alice #: ("3", "bob", "ACK 5") #> ("3", "bob", OK)
testMsgDeliveryQuotaExceeded :: Transport c => TProxy c -> c -> c -> IO ()
testMsgDeliveryQuotaExceeded _ alice bob = do
@ -417,9 +417,9 @@ testMsgDeliveryQuotaExceeded _ alice bob = do
alice <#= \case ("", "bob", SENT m) -> m == mId; _ -> False
(_, "bob", Right (MID _)) <- alice #: ("5", "bob", "SEND F :over quota")
alice #: ("1", "bob2", "SEND F :hello") #> ("1", "bob2", MID 5)
alice #: ("1", "bob2", "SEND F :hello") #> ("1", "bob2", MID 4)
-- if delivery is blocked it won't go further
alice <# ("", "bob2", SENT 5)
alice <# ("", "bob2", SENT 4)
connect :: forall c. Transport c => (c, ByteString) -> (c, ByteString) -> IO ()
connect (h1, name1) (h2, name2) = do

4
tests/AgentTests/ConnectionRequestTests.hs
View File

@ -48,7 +48,7 @@ connReqData :: ConnReqUriData
connReqData =
ConnReqUriData
{ crScheme = simplexChat,
crAgentVRange = smpAgentVRange,
crAgentVRange = mkVersionRange 1 1,
crSmpQueues = [queue]
}
@ -70,7 +70,7 @@ connectionRequest12 :: AConnectionRequestUri
connectionRequest12 =
ACR SCMInvitation $
CRInvitationUri
connReqData {crAgentVRange = mkVersionRange 1 2, crSmpQueues = [queue, queue]}
connReqData {crAgentVRange = supportedSMPAgentVRange, crSmpQueues = [queue, queue]}
testE2ERatchetParams13
connectionRequestTests :: Spec

166
tests/AgentTests/FunctionalAPITests.hs
View File

@ -22,6 +22,7 @@ import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Server.Env.STM (ServerConfig (..))
import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.Transport (ATransport (..))
import Simplex.Messaging.Version
import Test.Hspec
import UnliftIO
@ -37,11 +38,31 @@ get c = atomically (readTBQueue $ subQ c)
pattern Msg :: MsgBody -> ACommand 'Agent
pattern Msg msgBody <- MSG MsgMeta {integrity = MsgOk} _ msgBody
agentCfgV1 :: AgentConfig
agentCfgV1 = agentCfg {smpAgentVersion = 1, smpAgentVRange = mkVersionRange 1 1}
functionalAPITests :: ATransport -> Spec
functionalAPITests t = do
describe "Establishing duplex connection" $
it "should connect via one server using SMP agent clients" $
withSmpServer t testAgentClient
describe "Duplex connection between agent versions 1 and 2" $ do
it "should connect agent v1 to v1" $
withSmpServer t testAgentClientV1toV1
it "should connect agent v1 to v2" $
withSmpServer t testAgentClientV1toV2
it "should connect agent v2 to v1" $
withSmpServer t testAgentClientV2toV1
describe "Establish duplex connection via contact address" $
it "should connect via one server using SMP agent clients" $
withSmpServer t testAgentClientContact
describe "Duplex connection via contact address between agent versions 1 and 2" $ do
it "should connect agent v1 to v1" $
withSmpServer t testAgentClientContactV1toV1
it "should connect agent v1 to v2" $
withSmpServer t testAgentClientContactV1toV2
it "should connect agent v2 to v1" $
withSmpServer t testAgentClientContactV2toV1
describe "Establishing connection asynchronously" $ do
it "should connect with initiating client going offline" $
withSmpServer t testAsyncInitiatingOffline
@ -63,6 +84,52 @@ testAgentClient :: IO ()
testAgentClient = do
alice <- getSMPAgentClient agentCfg initAgentServers
bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
runAgentClientTest alice bob 3
testAgentClientV1toV1 :: IO ()
testAgentClientV1toV1 = do
alice <- getSMPAgentClient agentCfgV1 initAgentServers
bob <- getSMPAgentClient agentCfgV1 {dbFile = testDB2} initAgentServers
runAgentClientTest alice bob 4
testAgentClientV1toV2 :: IO ()
testAgentClientV1toV2 = do
alice <- getSMPAgentClient agentCfgV1 initAgentServers
bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
runAgentClientTest alice bob 4
testAgentClientV2toV1 :: IO ()
testAgentClientV2toV1 = do
alice <- getSMPAgentClient agentCfg initAgentServers
bob <- getSMPAgentClient agentCfgV1 {dbFile = testDB2} initAgentServers
runAgentClientTest alice bob 4
testAgentClientContact :: IO ()
testAgentClientContact = do
alice <- getSMPAgentClient agentCfg initAgentServers
bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
runAgentClientContactTest alice bob 3
testAgentClientContactV1toV1 :: IO ()
testAgentClientContactV1toV1 = do
alice <- getSMPAgentClient agentCfgV1 initAgentServers
bob <- getSMPAgentClient agentCfgV1 {dbFile = testDB2} initAgentServers
runAgentClientContactTest alice bob 4
testAgentClientContactV1toV2 :: IO ()
testAgentClientContactV1toV2 = do
alice <- getSMPAgentClient agentCfg initAgentServers
bob <- getSMPAgentClient agentCfgV1 {dbFile = testDB2} initAgentServers
runAgentClientContactTest alice bob 4
testAgentClientContactV2toV1 :: IO ()
testAgentClientContactV2toV1 = do
alice <- getSMPAgentClient agentCfgV1 initAgentServers
bob <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers
runAgentClientContactTest alice bob 4
runAgentClientTest :: AgentClient -> AgentClient -> AgentMsgId -> IO ()
runAgentClientTest alice bob baseId = do
Right () <- runExceptT $ do
(bobId, qInfo) <- createConnection alice SCMInvitation
aliceId <- joinConnection bob qInfo "bob's connInfo"
@ -71,37 +138,77 @@ testAgentClient = do
get alice ##> ("", bobId, CON)
get bob ##> ("", aliceId, INFO "alice's connInfo")
get bob ##> ("", aliceId, CON)
-- message IDs 1 to 4 get assigned to control messages, so first MSG is assigned ID 5
5 <- sendMessage alice bobId SMP.noMsgFlags "hello"
get alice ##> ("", bobId, SENT 5)
6 <- sendMessage alice bobId SMP.noMsgFlags "how are you?"
get alice ##> ("", bobId, SENT 6)
-- message IDs 1 to 3 (or 1 to 4 in v1) get assigned to control messages, so first MSG is assigned ID 4
1 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "hello"
get alice ##> ("", bobId, SENT $ baseId + 1)
2 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?"
get alice ##> ("", bobId, SENT $ baseId + 2)
get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
ackMessage bob aliceId 5
ackMessage bob aliceId $ baseId + 1
get bob =##> \case ("", c, Msg "how are you?") -> c == aliceId; _ -> False
ackMessage bob aliceId 6
7 <- sendMessage bob aliceId SMP.noMsgFlags "hello too"
get bob ##> ("", aliceId, SENT 7)
8 <- sendMessage bob aliceId SMP.noMsgFlags "message 1"
get bob ##> ("", aliceId, SENT 8)
ackMessage bob aliceId $ baseId + 2
3 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "hello too"
get bob ##> ("", aliceId, SENT $ baseId + 3)
4 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "message 1"
get bob ##> ("", aliceId, SENT $ baseId + 4)
get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
ackMessage alice bobId 7
ackMessage alice bobId $ baseId + 3
get alice =##> \case ("", c, Msg "message 1") -> c == bobId; _ -> False
ackMessage alice bobId 8
ackMessage alice bobId $ baseId + 4
suspendConnection alice bobId
9 <- sendMessage bob aliceId SMP.noMsgFlags "message 2"
get bob ##> ("", aliceId, MERR 9 (SMP AUTH))
5 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "message 2"
get bob ##> ("", aliceId, MERR (baseId + 5) (SMP AUTH))
deleteConnection alice bobId
liftIO $ noMessages alice "nothing else should be delivered to alice"
pure ()
where
noMessages :: AgentClient -> String -> Expectation
noMessages c err = tryGet `shouldReturn` ()
where
tryGet =
10000 `timeout` get c >>= \case
Just _ -> error err
_ -> return ()
msgId = subtract baseId
runAgentClientContactTest :: AgentClient -> AgentClient -> AgentMsgId -> IO ()
runAgentClientContactTest alice bob baseId = do
Right () <- runExceptT $ do
(_, qInfo) <- createConnection alice SCMContact
aliceId <- joinConnection bob qInfo "bob's connInfo"
("", _, REQ invId "bob's connInfo") <- get alice
bobId <- acceptContact alice invId "alice's connInfo"
("", _, CONF confId "alice's connInfo") <- get bob
allowConnection bob aliceId confId "bob's connInfo"
get alice ##> ("", bobId, INFO "bob's connInfo")
get alice ##> ("", bobId, CON)
get bob ##> ("", aliceId, CON)
-- message IDs 1 to 3 (or 1 to 4 in v1) get assigned to control messages, so first MSG is assigned ID 4
1 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "hello"
get alice ##> ("", bobId, SENT $ baseId + 1)
2 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?"
get alice ##> ("", bobId, SENT $ baseId + 2)
get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
ackMessage bob aliceId $ baseId + 1
get bob =##> \case ("", c, Msg "how are you?") -> c == aliceId; _ -> False
ackMessage bob aliceId $ baseId + 2
3 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "hello too"
get bob ##> ("", aliceId, SENT $ baseId + 3)
4 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "message 1"
get bob ##> ("", aliceId, SENT $ baseId + 4)
get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
ackMessage alice bobId $ baseId + 3
get alice =##> \case ("", c, Msg "message 1") -> c == bobId; _ -> False
ackMessage alice bobId $ baseId + 4
suspendConnection alice bobId
5 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "message 2"
get bob ##> ("", aliceId, MERR (baseId + 5) (SMP AUTH))
deleteConnection alice bobId
liftIO $ noMessages alice "nothing else should be delivered to alice"
pure ()
where
msgId = subtract baseId
noMessages :: AgentClient -> String -> Expectation
noMessages c err = tryGet `shouldReturn` ()
where
tryGet =
10000 `timeout` get c >>= \case
Just _ -> error err
_ -> return ()
testAsyncInitiatingOffline :: IO ()
testAsyncInitiatingOffline = do
@ -189,7 +296,8 @@ testAsyncServerOffline t = do
testAsyncHelloTimeout :: IO ()
testAsyncHelloTimeout = do
alice <- getSMPAgentClient agentCfg initAgentServers
-- this test would only work if any of the agent is v1, there is no HELLO timeout in v2
alice <- getSMPAgentClient agentCfgV1 initAgentServers
bob <- getSMPAgentClient agentCfg {dbFile = testDB2, helloTimeout = 1} initAgentServers
Right () <- runExceptT $ do
(_, cReq) <- createConnection alice SCMInvitation
@ -238,11 +346,11 @@ testActiveClientNotDisconnected t = do
exchangeGreetings :: AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO ()
exchangeGreetings alice bobId bob aliceId = do
5 <- sendMessage alice bobId SMP.noMsgFlags "hello"
get alice ##> ("", bobId, SENT 5)
4 <- sendMessage alice bobId SMP.noMsgFlags "hello"
get alice ##> ("", bobId, SENT 4)
get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
ackMessage bob aliceId 5
6 <- sendMessage bob aliceId SMP.noMsgFlags "hello too"
get bob ##> ("", aliceId, SENT 6)
ackMessage bob aliceId 4
5 <- sendMessage bob aliceId SMP.noMsgFlags "hello too"
get bob ##> ("", aliceId, SENT 5)
get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
ackMessage alice bobId 6
ackMessage alice bobId 5

2
tests/AgentTests/SQLiteTests.hs
View File

@ -145,7 +145,7 @@ testForeignKeysEnabled =
`shouldThrow` (\e -> DB.sqlError e == DB.ErrorConstraint)
cData1 :: ConnData
cData1 = ConnData {connId = "conn1"}
cData1 = ConnData {connId = "conn1", connAgentVersion = 1, duplexHandshake = Nothing}
testPrivateSignKey :: C.APrivateSignKey
testPrivateSignKey = C.APrivateSignKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe"

2
tests/NtfClient.hs
View File

@ -65,7 +65,7 @@ testKeyHash = "LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI="
testNtfClient :: (Transport c, MonadUnliftIO m) => (THandle c -> m a) -> m a
testNtfClient client =
runTransportClient testHost ntfTestPort (Just testKeyHash) (Just defaultKeepAliveOpts) $ \h ->
liftIO (runExceptT $ ntfClientHandshake h testKeyHash) >>= \case
liftIO (runExceptT $ ntfClientHandshake h testKeyHash supportedNTFServerVRange) >>= \case
Right th -> client th
Left e -> error $ show e

5
tests/SMPClient.hs
View File

@ -46,7 +46,7 @@ testStoreLogFile = "tests/tmp/smp-server-store.log"
testSMPClient :: (Transport c, MonadUnliftIO m) => (THandle c -> m a) -> m a
testSMPClient client =
runTransportClient testHost testPort (Just testKeyHash) (Just defaultKeepAliveOpts) $ \h ->
liftIO (runExceptT $ smpClientHandshake h testKeyHash) >>= \case
liftIO (runExceptT $ smpClientHandshake h testKeyHash supportedSMPServerVRange) >>= \case
Right th -> client th
Left e -> error $ show e
@ -67,7 +67,8 @@ cfg =
logStatsStartTime = 0,
caCertificateFile = "tests/fixtures/ca.crt",
privateKeyFile = "tests/fixtures/server.key",
certificateFile = "tests/fixtures/server.crt"
certificateFile = "tests/fixtures/server.crt",
smpServerVRange = supportedSMPServerVRange
}
withSmpServerStoreLogOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> ServiceName -> (ThreadId -> m a) -> m a