mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-04-05 02:26:03 +00:00
Merge branch 'master' into v5
This commit is contained in:
Evgeny Poberezkin
@@ -39,6 +39,7 @@ dependencies:
|
||||
- directory == 1.3.*
|
||||
- file-embed >= 0.0.14.0 && <= 0.0.15.0
|
||||
- filepath == 1.4.*
|
||||
- http-types == 0.12.*
|
||||
- generic-random >= 1.3 && < 1.5
|
||||
- iso8601-time == 0.1.*
|
||||
- memory == 0.15.*
|
||||
|
||||
@@ -3,6 +3,8 @@ cabal-version: 1.12
|
||||
-- This file has been generated from package.yaml by hpack version 0.34.4.
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
--
|
||||
-- hash: eac6184d7efe4fc07606d5f6bd75f1821af768a087526ff08749385844580cec
|
||||
|
||||
name: simplexmq
|
||||
version: 0.4.1
|
||||
@@ -79,6 +81,7 @@ library
|
||||
, file-embed >=0.0.14.0 && <=0.0.15.0
|
||||
, filepath ==1.4.*
|
||||
, generic-random >=1.3 && <1.5
|
||||
, http-types ==0.12.*
|
||||
, iso8601-time ==0.1.*
|
||||
, memory ==0.15.*
|
||||
, mtl ==2.2.*
|
||||
@@ -124,6 +127,7 @@ executable smp-agent
|
||||
, file-embed >=0.0.14.0 && <=0.0.15.0
|
||||
, filepath ==1.4.*
|
||||
, generic-random >=1.3 && <1.5
|
||||
, http-types ==0.12.*
|
||||
, iso8601-time ==0.1.*
|
||||
, memory ==0.15.*
|
||||
, mtl ==2.2.*
|
||||
@@ -171,6 +175,7 @@ executable smp-server
|
||||
, file-embed >=0.0.14.0 && <=0.0.15.0
|
||||
, filepath ==1.4.*
|
||||
, generic-random >=1.3 && <1.5
|
||||
, http-types ==0.12.*
|
||||
, ini ==0.4.*
|
||||
, iso8601-time ==0.1.*
|
||||
, memory ==0.15.*
|
||||
@@ -198,6 +203,7 @@ test-suite smp-server-test
|
||||
main-is: Test.hs
|
||||
other-modules:
|
||||
AgentTests
|
||||
AgentTests.ConnectionRequestTests
|
||||
AgentTests.FunctionalAPITests
|
||||
AgentTests.SQLiteTests
|
||||
ProtocolErrorTests
|
||||
@@ -230,6 +236,7 @@ test-suite smp-server-test
|
||||
, generic-random >=1.3 && <1.5
|
||||
, hspec ==2.7.*
|
||||
, hspec-core ==2.7.*
|
||||
, http-types ==0.12.*
|
||||
, iso8601-time ==0.1.*
|
||||
, memory ==0.15.*
|
||||
, mtl ==2.2.*
|
||||
|
||||
@@ -7,6 +7,7 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE NumericUnderscores #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
@@ -127,11 +128,11 @@ disconnectAgentClient c = closeAgentClient c >> logConnection c False
|
||||
type AgentErrorMonad m = (MonadUnliftIO m, MonadError AgentErrorType m)
|
||||
|
||||
-- | Create SMP agent connection (NEW command)
|
||||
createConnection :: AgentErrorMonad m => AgentClient -> m (ConnId, SMPQueueInfo)
|
||||
createConnection :: AgentErrorMonad m => AgentClient -> m (ConnId, ConnectionRequest)
|
||||
createConnection c = withAgentEnv c $ newConn c ""
|
||||
|
||||
-- | Join SMP agent connection (JOIN command)
|
||||
joinConnection :: AgentErrorMonad m => AgentClient -> SMPQueueInfo -> ConnInfo -> m ConnId
|
||||
joinConnection :: AgentErrorMonad m => AgentClient -> ConnectionRequest -> ConnInfo -> m ConnId
|
||||
joinConnection c = withAgentEnv c .: joinConn c ""
|
||||
|
||||
-- | Approve confirmation (LET command)
|
||||
@@ -235,7 +236,7 @@ withStore action = do
|
||||
processCommand :: forall m. AgentMonad m => AgentClient -> (ConnId, ACommand 'Client) -> m (ConnId, ACommand 'Agent)
|
||||
processCommand c (connId, cmd) = case cmd of
|
||||
NEW -> second INV <$> newConn c connId
|
||||
JOIN smpQueueInfo connInfo -> (,OK) <$> joinConn c connId smpQueueInfo connInfo
|
||||
JOIN smpQueueUri connInfo -> (,OK) <$> joinConn c connId smpQueueUri connInfo
|
||||
ACPT confId ownConnInfo -> acceptConnection' c connId confId ownConnInfo $> (connId, OK)
|
||||
SUB -> subscribeConnection' c connId $> (connId, OK)
|
||||
SEND msgBody -> (connId,) . MID <$> sendMessage' c connId msgBody
|
||||
@@ -243,19 +244,19 @@ processCommand c (connId, cmd) = case cmd of
|
||||
OFF -> suspendConnection' c connId $> (connId, OK)
|
||||
DEL -> deleteConnection' c connId $> (connId, OK)
|
||||
|
||||
newConn :: AgentMonad m => AgentClient -> ConnId -> m (ConnId, SMPQueueInfo)
|
||||
newConn :: AgentMonad m => AgentClient -> ConnId -> m (ConnId, ConnectionRequest)
|
||||
newConn c connId = do
|
||||
srv <- getSMPServer
|
||||
(rq, qInfo) <- newRcvQueue c srv
|
||||
(rq, qUri, encryptKey) <- newRcvQueue c srv
|
||||
g <- asks idsDrg
|
||||
let cData = ConnData {connId}
|
||||
connId' <- withStore $ \st -> createRcvConn st g cData rq
|
||||
addSubscription c rq connId'
|
||||
pure (connId', qInfo)
|
||||
pure (connId', ConnectionRequest simplexChat CRAConnect [qUri] encryptKey)
|
||||
|
||||
joinConn :: AgentMonad m => AgentClient -> ConnId -> SMPQueueInfo -> ConnInfo -> m ConnId
|
||||
joinConn c connId qInfo cInfo = do
|
||||
(sq, senderKey, verifyKey) <- newSndQueue qInfo
|
||||
joinConn :: AgentMonad m => AgentClient -> ConnId -> ConnectionRequest -> ConnInfo -> m ConnId
|
||||
joinConn c connId (ConnectionRequest _ CRAConnect (qUri :| _) encryptKey) cInfo = do
|
||||
(sq, senderKey, verifyKey) <- newSndQueue qUri encryptKey
|
||||
g <- asks idsDrg
|
||||
cfg <- asks config
|
||||
let cData = ConnData {connId}
|
||||
@@ -271,10 +272,10 @@ activateQueueJoining c connId sq verifyKey retryInterval =
|
||||
createReplyQueue :: m ()
|
||||
createReplyQueue = do
|
||||
srv <- getSMPServer
|
||||
(rq, qInfo') <- newRcvQueue c srv
|
||||
(rq, qUri', encryptKey) <- newRcvQueue c srv
|
||||
addSubscription c rq connId
|
||||
withStore $ \st -> upgradeSndConnToDuplex st connId rq
|
||||
sendControlMessage c sq $ REPLY qInfo'
|
||||
sendControlMessage c sq . REPLY $ ConnectionRequest CRSSimplex CRAConnect [qUri'] encryptKey
|
||||
|
||||
-- | Approve confirmation (LET command) in Reader monad
|
||||
acceptConnection' :: AgentMonad m => AgentClient -> ConnId -> ConfirmationId -> ConnInfo -> m ()
|
||||
@@ -498,7 +499,7 @@ processSMPTransmission c@AgentClient {subQ} (srv, rId, cmd) = do
|
||||
Right SMPMessage {agentMessage, senderMsgId, senderTimestamp, previousMsgHash} ->
|
||||
case agentMessage of
|
||||
HELLO verifyKey _ -> helloMsg verifyKey msgBody >> sendAck c rq
|
||||
REPLY qInfo -> replyMsg qInfo >> sendAck c rq
|
||||
REPLY cReq -> replyMsg cReq >> sendAck c rq
|
||||
A_MSG body -> agentClientMsg previousMsgHash (senderMsgId, senderTimestamp) (srvMsgId, srvTs) body msgHash
|
||||
SMP.END -> do
|
||||
removeSubscription c connId
|
||||
@@ -542,13 +543,13 @@ processSMPTransmission c@AgentClient {subQ} (srv, rId, cmd) = do
|
||||
SCDuplex -> notifyConnected c connId
|
||||
_ -> pure ()
|
||||
|
||||
replyMsg :: SMPQueueInfo -> m ()
|
||||
replyMsg qInfo = do
|
||||
replyMsg :: ConnectionRequest -> m ()
|
||||
replyMsg (ConnectionRequest _ CRAConnect (qUri :| _) encryptKey) = do
|
||||
logServer "<--" c srv rId "MSG <REPLY>"
|
||||
case cType of
|
||||
SCRcv -> do
|
||||
AcceptedConfirmation {ownConnInfo} <- withStore (`getAcceptedConfirmation` connId)
|
||||
(sq, senderKey, verifyKey) <- newSndQueue qInfo
|
||||
(sq, senderKey, verifyKey) <- newSndQueue qUri encryptKey
|
||||
withStore $ \st -> upgradeRcvConnToDuplex st connId sq
|
||||
confirmQueue c sq senderKey ownConnInfo
|
||||
withStore (`removeConfirmations` connId)
|
||||
@@ -603,17 +604,18 @@ notifyConnected :: AgentMonad m => AgentClient -> ConnId -> m ()
|
||||
notifyConnected c connId = atomically $ writeTBQueue (subQ c) ("", connId, CON)
|
||||
|
||||
newSndQueue ::
|
||||
(MonadUnliftIO m, MonadReader Env m) => SMPQueueInfo -> m (SndQueue, SenderPublicKey, C.APublicVerifyKey)
|
||||
newSndQueue qInfo =
|
||||
(MonadUnliftIO m, MonadReader Env m) => SMPQueueUri -> C.APublicEncryptKey -> m (SndQueue, SenderPublicKey, C.APublicVerifyKey)
|
||||
newSndQueue qUri encryptKey =
|
||||
asks (cmdSignAlg . config) >>= \case
|
||||
C.SignAlg a -> newSndQueue_ a qInfo
|
||||
C.SignAlg a -> newSndQueue_ a qUri encryptKey
|
||||
|
||||
newSndQueue_ ::
|
||||
(C.SignatureAlgorithm a, C.AlgorithmI a, MonadUnliftIO m, MonadReader Env m) =>
|
||||
C.SAlgorithm a ->
|
||||
SMPQueueInfo ->
|
||||
SMPQueueUri ->
|
||||
C.APublicEncryptKey ->
|
||||
m (SndQueue, SenderPublicKey, C.APublicVerifyKey)
|
||||
newSndQueue_ a (SMPQueueInfo smpServer senderId encryptKey) = do
|
||||
newSndQueue_ a (SMPQueueUri smpServer senderId _) encryptKey = do
|
||||
size <- asks $ rsaKeySize . config
|
||||
(senderKey, sndPrivateKey) <- liftIO $ C.generateSignatureKeyPair size a
|
||||
(verifyKey, signKey) <- liftIO $ C.generateSignatureKeyPair size C.SRSA
|
||||
|
||||
@@ -223,7 +223,7 @@ smpClientError = \case
|
||||
SMPTransportError e -> BROKER $ TRANSPORT e
|
||||
e -> INTERNAL $ show e
|
||||
|
||||
newRcvQueue :: AgentMonad m => AgentClient -> SMPServer -> m (RcvQueue, SMPQueueInfo)
|
||||
newRcvQueue :: AgentMonad m => AgentClient -> SMPServer -> m (RcvQueue, SMPQueueUri, C.APublicEncryptKey)
|
||||
newRcvQueue c srv =
|
||||
asks (cmdSignAlg . config) >>= \case
|
||||
C.SignAlg a -> newRcvQueue_ a c srv
|
||||
@@ -233,7 +233,7 @@ newRcvQueue_ ::
|
||||
C.SAlgorithm a ->
|
||||
AgentClient ->
|
||||
SMPServer ->
|
||||
m (RcvQueue, SMPQueueInfo)
|
||||
m (RcvQueue, SMPQueueUri, C.APublicEncryptKey)
|
||||
newRcvQueue_ a c srv = do
|
||||
size <- asks $ rsaKeySize . config
|
||||
(recipientKey, rcvPrivateKey) <- liftIO $ C.generateSignatureKeyPair size a
|
||||
@@ -251,7 +251,7 @@ newRcvQueue_ a c srv = do
|
||||
verifyKey = Nothing,
|
||||
status = New
|
||||
}
|
||||
return (rq, SMPQueueInfo srv sId encryptKey)
|
||||
pure (rq, SMPQueueUri srv sId reservedServerKey, encryptKey)
|
||||
|
||||
subscribeQueue :: AgentMonad m => AgentClient -> RcvQueue -> ConnId -> m ()
|
||||
subscribeQueue c rq@RcvQueue {server, rcvPrivateKey, rcvId} connId = do
|
||||
|
||||
@@ -37,7 +37,11 @@ module Simplex.Messaging.Agent.Protocol
|
||||
SMPMessage (..),
|
||||
AMessage (..),
|
||||
SMPServer (..),
|
||||
SMPQueueInfo (..),
|
||||
SMPQueueUri (..),
|
||||
ConnectionRequest (..),
|
||||
ConnReqScheme (..),
|
||||
simplexChat,
|
||||
ConnReqAction (..),
|
||||
AgentErrorType (..),
|
||||
CommandErrorType (..),
|
||||
ConnectionErrorType (..),
|
||||
@@ -63,14 +67,18 @@ module Simplex.Messaging.Agent.Protocol
|
||||
serializeSMPMessage,
|
||||
serializeMsgIntegrity,
|
||||
serializeServer,
|
||||
serializeSmpQueueInfo,
|
||||
serializeSMPQueueUri,
|
||||
reservedServerKey, -- TODO remove
|
||||
serializeConnReq,
|
||||
serializeAgentError,
|
||||
commandP,
|
||||
parseSMPMessage,
|
||||
smpServerP,
|
||||
smpQueueInfoP,
|
||||
smpQueueUriP,
|
||||
connReqP,
|
||||
msgIntegrityP,
|
||||
agentErrorTypeP,
|
||||
agentMessageP,
|
||||
|
||||
-- * TCP transport functions
|
||||
tPut,
|
||||
@@ -82,14 +90,18 @@ where
|
||||
|
||||
import Control.Applicative (optional, (<|>))
|
||||
import Control.Monad.IO.Class
|
||||
import qualified Crypto.PubKey.RSA as R
|
||||
import Data.Attoparsec.ByteString.Char8 (Parser)
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import Data.ByteString.Base64
|
||||
import qualified Data.ByteString.Base64.URL as U
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Functor (($>))
|
||||
import Data.Int (Int64)
|
||||
import Data.Kind (Type)
|
||||
import Data.List (find)
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import Data.String (IsString (..))
|
||||
import Data.Time.Clock (UTCTime)
|
||||
import Data.Time.ISO8601
|
||||
@@ -97,6 +109,7 @@ import Data.Type.Equality
|
||||
import Data.Typeable ()
|
||||
import GHC.Generics (Generic)
|
||||
import Generic.Random (genericArbitraryU)
|
||||
import Network.HTTP.Types (parseSimpleQuery, renderSimpleQuery)
|
||||
import Network.Socket (HostName, ServiceName)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Parsers
|
||||
@@ -151,8 +164,8 @@ type ConnInfo = ByteString
|
||||
-- | Parameterized type for SMP agent protocol commands and responses from all participants.
|
||||
data ACommand (p :: AParty) where
|
||||
NEW :: ACommand Client -- response INV
|
||||
INV :: SMPQueueInfo -> ACommand Agent
|
||||
JOIN :: SMPQueueInfo -> ConnInfo -> ACommand Client -- response OK
|
||||
INV :: ConnectionRequest -> ACommand Agent
|
||||
JOIN :: ConnectionRequest -> ConnInfo -> ACommand Client -- response OK
|
||||
REQ :: ConfirmationId -> ConnInfo -> ACommand Agent -- ConnInfo is from sender
|
||||
ACPT :: ConfirmationId -> ConnInfo -> ACommand Client -- ConnInfo is from client
|
||||
INFO :: ConnInfo -> ACommand Agent
|
||||
@@ -221,7 +234,7 @@ data AMessage where
|
||||
-- | the first message in the queue to validate it is secured
|
||||
HELLO :: C.APublicVerifyKey -> AckMode -> AMessage
|
||||
-- | reply queue information
|
||||
REPLY :: SMPQueueInfo -> AMessage
|
||||
REPLY :: ConnectionRequest -> AMessage
|
||||
-- | agent envelope for the client message
|
||||
A_MSG :: MsgBody -> AMessage
|
||||
deriving (Show)
|
||||
@@ -266,15 +279,10 @@ agentMessageP =
|
||||
<|> "MSG " *> a_msg
|
||||
where
|
||||
hello = HELLO <$> C.strKeyP <*> ackMode
|
||||
reply = REPLY <$> smpQueueInfoP
|
||||
reply = REPLY <$> connReqP
|
||||
a_msg = A_MSG <$> binaryBodyP <* A.endOfLine
|
||||
ackMode = AckMode <$> (" NO_ACK" $> Off <|> pure On)
|
||||
|
||||
-- | SMP queue information parser.
|
||||
smpQueueInfoP :: Parser SMPQueueInfo
|
||||
smpQueueInfoP =
|
||||
"smp::" *> (SMPQueueInfo <$> smpServerP <* "::" <*> base64P <* "::" <*> C.strKeyP)
|
||||
|
||||
-- | SMP server location parser.
|
||||
smpServerP :: Parser SMPServer
|
||||
smpServerP = SMPServer <$> server <*> optional port <*> optional kHash
|
||||
@@ -286,19 +294,74 @@ smpServerP = SMPServer <$> server <*> optional port <*> optional kHash
|
||||
serializeAgentMessage :: AMessage -> ByteString
|
||||
serializeAgentMessage = \case
|
||||
HELLO verifyKey ackMode -> "HELLO " <> C.serializeKey verifyKey <> if ackMode == AckMode Off then " NO_ACK" else ""
|
||||
REPLY qInfo -> "REPLY " <> serializeSmpQueueInfo qInfo
|
||||
REPLY cReq -> "REPLY " <> serializeConnReq cReq
|
||||
A_MSG body -> "MSG " <> serializeBinary body <> "\n"
|
||||
|
||||
-- | Serialize SMP queue information that is sent out-of-band.
|
||||
serializeSmpQueueInfo :: SMPQueueInfo -> ByteString
|
||||
serializeSmpQueueInfo (SMPQueueInfo srv qId ek) =
|
||||
B.intercalate "::" ["smp", serializeServer srv, encode qId, C.serializeKey ek]
|
||||
serializeSMPQueueUri :: SMPQueueUri -> ByteString
|
||||
serializeSMPQueueUri (SMPQueueUri srv qId _) =
|
||||
serializeServerUri srv <> "/" <> U.encode qId <> "#"
|
||||
|
||||
-- | SMP queue information parser.
|
||||
smpQueueUriP :: Parser SMPQueueUri
|
||||
smpQueueUriP =
|
||||
SMPQueueUri <$> smpServerUriP <* "/" <*> base64UriP <* "#" <*> pure reservedServerKey
|
||||
|
||||
reservedServerKey :: C.APublicVerifyKey
|
||||
reservedServerKey = C.APublicVerifyKey C.SRSA (C.PublicKeyRSA $ R.PublicKey 1 0 0)
|
||||
|
||||
serializeConnReq :: ConnectionRequest -> ByteString
|
||||
serializeConnReq (ConnectionRequest scheme action smpQueues encryptionKey) =
|
||||
sch <> "/" <> act <> "#/" <> queryStr
|
||||
where
|
||||
sch = case scheme of
|
||||
CRSSimplex -> "simplex:"
|
||||
CRSAppServer host port -> B.pack $ "https://" <> host <> maybe "" (':' :) port
|
||||
act = case action of
|
||||
CRAConnect -> "connect"
|
||||
queryStr = renderSimpleQuery True [("smp", queues), ("e2e", key)]
|
||||
queues = B.intercalate "," . map serializeSMPQueueUri $ L.toList smpQueues
|
||||
key = C.serializeKey encryptionKey
|
||||
|
||||
connReqP :: Parser ConnectionRequest
|
||||
connReqP = do
|
||||
crScheme <- "simplex:" $> CRSSimplex <|> "https://" *> appServer
|
||||
crAction <- "/" *> ("connect" $> CRAConnect) <* "#/?"
|
||||
query <- parseSimpleQuery <$> A.takeTill (\c -> c == ' ' || c == '\n')
|
||||
crSmpQueues <- paramP "smp" smpQueues query
|
||||
crEncryptKey <- paramP "e2e" C.strKeyP query
|
||||
pure ConnectionRequest {crScheme, crAction, crSmpQueues, crEncryptKey}
|
||||
where
|
||||
appServer = CRSAppServer <$> host <*> optional port
|
||||
host = B.unpack <$> A.takeTill (\c -> c == ':' || c == '/')
|
||||
port = B.unpack <$> (A.char ':' *> A.takeTill (== '/'))
|
||||
paramP param parser query =
|
||||
let p = maybe (fail "") (pure . snd) $ find ((== param) . fst) query
|
||||
in parseAll parser <$?> p
|
||||
smpQueues =
|
||||
maybe (fail "no SMP queues") pure . L.nonEmpty
|
||||
=<< (smpQueue `A.sepBy1'` A.char ',')
|
||||
smpQueue = parseAll smpQueueUriP <$?> A.takeTill (== ',')
|
||||
|
||||
-- | Serialize SMP server location.
|
||||
serializeServer :: SMPServer -> ByteString
|
||||
serializeServer SMPServer {host, port, keyHash} =
|
||||
B.pack $ host <> maybe "" (':' :) port <> maybe "" (('#' :) . B.unpack . encode . C.unKeyHash) keyHash
|
||||
|
||||
serializeServerUri :: SMPServer -> ByteString
|
||||
serializeServerUri SMPServer {host, port, keyHash} = "smp://" <> kh <> B.pack host <> p
|
||||
where
|
||||
kh = maybe "" ((<> "@") . U.encode . C.unKeyHash) keyHash
|
||||
p = B.pack $ maybe "" (':' :) port
|
||||
|
||||
smpServerUriP :: Parser SMPServer
|
||||
smpServerUriP = do
|
||||
_ <- "smp://"
|
||||
keyHash <- optional $ C.KeyHash <$> (U.decode <$?> A.takeTill (== '@') <* A.char '@')
|
||||
host <- B.unpack <$> A.takeWhile1 (A.notInClass ":#,;/ ")
|
||||
port <- optional $ B.unpack <$> (A.char ':' *> A.takeWhile1 A.isDigit)
|
||||
pure SMPServer {host, port, keyHash}
|
||||
|
||||
-- | SMP server location and transport key digest (hash).
|
||||
data SMPServer = SMPServer
|
||||
{ host :: HostName,
|
||||
@@ -328,9 +391,29 @@ newtype AckMode = AckMode OnOff deriving (Eq, Show)
|
||||
-- | SMP queue information sent out-of-band.
|
||||
--
|
||||
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#out-of-band-messages
|
||||
data SMPQueueInfo = SMPQueueInfo SMPServer SMP.SenderId C.APublicEncryptKey
|
||||
data SMPQueueUri = SMPQueueUri
|
||||
{ smpServer :: SMPServer,
|
||||
senderId :: SMP.SenderId,
|
||||
serverVerifyKey :: C.APublicVerifyKey
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data ConnectionRequest = ConnectionRequest
|
||||
{ crScheme :: ConnReqScheme,
|
||||
crAction :: ConnReqAction,
|
||||
crSmpQueues :: L.NonEmpty SMPQueueUri,
|
||||
crEncryptKey :: C.APublicEncryptKey
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data ConnReqScheme = CRSSimplex | CRSAppServer HostName (Maybe ServiceName)
|
||||
deriving (Eq, Show)
|
||||
|
||||
simplexChat :: ConnReqScheme
|
||||
simplexChat = CRSAppServer "simplex.chat" Nothing
|
||||
|
||||
data ConnReqAction = CRAConnect deriving (Eq, Show)
|
||||
|
||||
data QueueDirection = SND | RCV deriving (Show)
|
||||
|
||||
-- | SMP queue status.
|
||||
@@ -460,8 +543,8 @@ commandP =
|
||||
<|> "CON" $> ACmd SAgent CON
|
||||
<|> "OK" $> ACmd SAgent OK
|
||||
where
|
||||
invResp = ACmd SAgent . INV <$> smpQueueInfoP
|
||||
joinCmd = ACmd SClient <$> (JOIN <$> smpQueueInfoP <* A.space <*> A.takeByteString)
|
||||
invResp = ACmd SAgent . INV <$> connReqP
|
||||
joinCmd = ACmd SClient <$> (JOIN <$> connReqP <* A.space <*> A.takeByteString)
|
||||
reqCmd = ACmd SAgent <$> (REQ <$> A.takeTill (== ' ') <* A.space <*> A.takeByteString)
|
||||
acptCmd = ACmd SClient <$> (ACPT <$> A.takeTill (== ' ') <* A.space <*> A.takeByteString)
|
||||
infoCmd = ACmd SAgent . INFO <$> A.takeByteString
|
||||
@@ -497,8 +580,8 @@ parseCommand = parse commandP $ CMD SYNTAX
|
||||
serializeCommand :: ACommand p -> ByteString
|
||||
serializeCommand = \case
|
||||
NEW -> "NEW"
|
||||
INV qInfo -> "INV " <> serializeSmpQueueInfo qInfo
|
||||
JOIN qInfo cInfo -> "JOIN " <> serializeSmpQueueInfo qInfo <> " " <> serializeBinary cInfo
|
||||
INV cReq -> "INV " <> serializeConnReq cReq
|
||||
JOIN cReq cInfo -> "JOIN " <> serializeConnReq cReq <> " " <> serializeBinary cInfo
|
||||
REQ confId cInfo -> "REQ " <> confId <> " " <> serializeBinary cInfo
|
||||
ACPT confId cInfo -> "ACPT " <> confId <> " " <> serializeBinary cInfo
|
||||
INFO cInfo -> "INFO " <> serializeBinary cInfo
|
||||
@@ -614,7 +697,7 @@ tGet party h = liftIO (tGetRaw h) >>= tParseLoadBody
|
||||
cmdWithMsgBody = \case
|
||||
SEND body -> SEND <$$> getBody body
|
||||
MSG msgMeta body -> MSG msgMeta <$$> getBody body
|
||||
JOIN qInfo cInfo -> JOIN qInfo <$$> getBody cInfo
|
||||
JOIN qUri cInfo -> JOIN qUri <$$> getBody cInfo
|
||||
REQ confId cInfo -> REQ confId <$$> getBody cInfo
|
||||
ACPT confId cInfo -> ACPT confId <$$> getBody cInfo
|
||||
INFO cInfo -> INFO <$$> getBody cInfo
|
||||
|
||||
@@ -490,9 +490,13 @@ instance ToField MsgIntegrity where toField = toField . serializeMsgIntegrity
|
||||
|
||||
instance FromField MsgIntegrity where fromField = blobFieldParser msgIntegrityP
|
||||
|
||||
instance ToField SMPQueueInfo where toField = toField . serializeSmpQueueInfo
|
||||
instance ToField SMPQueueUri where toField = toField . serializeSMPQueueUri
|
||||
|
||||
instance FromField SMPQueueInfo where fromField = blobFieldParser smpQueueInfoP
|
||||
instance FromField SMPQueueUri where fromField = blobFieldParser smpQueueUriP
|
||||
|
||||
instance ToField ConnectionRequest where toField = toField . serializeConnReq
|
||||
|
||||
instance FromField ConnectionRequest where fromField = blobFieldParser connReqP
|
||||
|
||||
fromTextField_ :: (E.Typeable a) => (Text -> Maybe a) -> Field -> Ok a
|
||||
fromTextField_ fromText = \case
|
||||
|
||||
@@ -7,6 +7,7 @@ import Data.Attoparsec.ByteString.Char8 (Parser)
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import Data.Bifunctor (first)
|
||||
import Data.ByteString.Base64
|
||||
import qualified Data.ByteString.Base64.URL as U
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Char (isAlphaNum)
|
||||
@@ -24,10 +25,24 @@ base64P :: Parser ByteString
|
||||
base64P = decode <$?> base64StringP
|
||||
|
||||
base64StringP :: Parser ByteString
|
||||
base64StringP = do
|
||||
str <- A.takeWhile1 (\c -> isAlphaNum c || c == '+' || c == '/')
|
||||
pad <- A.takeWhile (== '=')
|
||||
pure $ str <> pad
|
||||
base64StringP = paddedBase64 rawBase64P
|
||||
|
||||
base64UriP :: Parser ByteString
|
||||
base64UriP = U.decode <$?> base64UriStringP
|
||||
|
||||
base64UriStringP :: Parser ByteString
|
||||
base64UriStringP = paddedBase64 rawBase64UriP
|
||||
|
||||
paddedBase64 :: Parser ByteString -> Parser ByteString
|
||||
paddedBase64 raw = (<>) <$> raw <*> pad
|
||||
where
|
||||
pad = A.takeWhile (== '=')
|
||||
|
||||
rawBase64P :: Parser ByteString
|
||||
rawBase64P = A.takeWhile1 (\c -> isAlphaNum c || c == '+' || c == '/')
|
||||
|
||||
rawBase64UriP :: Parser ByteString
|
||||
rawBase64UriP = A.takeWhile1 (\c -> isAlphaNum c || c == '-' || c == '_')
|
||||
|
||||
tsISO8601P :: Parser UTCTime
|
||||
tsISO8601P = maybe (fail "timestamp") pure . parseISO8601 . B.unpack =<< A.takeTill wordEnd
|
||||
|
||||
@@ -10,11 +10,13 @@
|
||||
|
||||
module AgentTests (agentTests) where
|
||||
|
||||
import AgentTests.ConnectionRequestTests
|
||||
import AgentTests.FunctionalAPITests (functionalAPITests)
|
||||
import AgentTests.SQLiteTests (storeTests)
|
||||
import Control.Concurrent
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Network.HTTP.Types (urlEncode)
|
||||
import SMPAgentClient
|
||||
import SMPClient (testPort, testPort2, testStoreLogFile, withSmpServer, withSmpServerStoreLogOn)
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
@@ -26,6 +28,7 @@ import Test.Hspec
|
||||
|
||||
agentTests :: ATransport -> Spec
|
||||
agentTests (ATransport t) = do
|
||||
describe "Connection request" connectionRequestTests
|
||||
describe "Functional API" $ functionalAPITests (ATransport t)
|
||||
describe "SQLite store" storeTests
|
||||
describe "SMP agent protocol syntax" $ syntaxTests t
|
||||
@@ -98,9 +101,9 @@ pattern Msg msgBody <- MSG MsgMeta {integrity = MsgOk} msgBody
|
||||
|
||||
testDuplexConnection :: Transport c => TProxy c -> c -> c -> IO ()
|
||||
testDuplexConnection _ alice bob = do
|
||||
("1", "bob", Right (INV qInfo)) <- alice #: ("1", "bob", "NEW")
|
||||
let qInfo' = serializeSmpQueueInfo qInfo
|
||||
bob #: ("11", "alice", "JOIN " <> qInfo' <> " 14\nbob's connInfo") #> ("11", "alice", OK)
|
||||
("1", "bob", Right (INV cReq)) <- alice #: ("1", "bob", "NEW")
|
||||
let cReq' = serializeConnReq cReq
|
||||
bob #: ("11", "alice", "JOIN " <> cReq' <> " 14\nbob's connInfo") #> ("11", "alice", OK)
|
||||
("", "bob", Right (REQ confId "bob's connInfo")) <- (alice <#:)
|
||||
alice #: ("2", "bob", "ACPT " <> confId <> " 16\nalice's connInfo") #> ("2", "bob", OK)
|
||||
bob <# ("", "alice", INFO "alice's connInfo")
|
||||
@@ -130,9 +133,9 @@ testDuplexConnection _ alice bob = do
|
||||
|
||||
testDuplexConnRandomIds :: Transport c => TProxy c -> c -> c -> IO ()
|
||||
testDuplexConnRandomIds _ alice bob = do
|
||||
("1", bobConn, Right (INV qInfo)) <- alice #: ("1", "", "NEW")
|
||||
let qInfo' = serializeSmpQueueInfo qInfo
|
||||
("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN " <> qInfo' <> " 14\nbob's connInfo")
|
||||
("1", bobConn, Right (INV cReq)) <- alice #: ("1", "", "NEW")
|
||||
let cReq' = serializeConnReq cReq
|
||||
("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN " <> cReq' <> " 14\nbob's connInfo")
|
||||
("", bobConn', Right (REQ confId "bob's connInfo")) <- (alice <#:)
|
||||
bobConn' `shouldBe` bobConn
|
||||
alice #: ("2", bobConn, "ACPT " <> confId <> " 16\nalice's connInfo") =#> \case ("2", c, OK) -> c == bobConn; _ -> False
|
||||
@@ -250,9 +253,9 @@ testMsgDeliveryAgentRestart t bob = do
|
||||
|
||||
connect :: forall c. Transport c => (c, ByteString) -> (c, ByteString) -> IO ()
|
||||
connect (h1, name1) (h2, name2) = do
|
||||
("c1", _, Right (INV qInfo)) <- h1 #: ("c1", name2, "NEW")
|
||||
let qInfo' = serializeSmpQueueInfo qInfo
|
||||
h2 #: ("c2", name1, "JOIN " <> qInfo' <> " 5\ninfo2") #> ("c2", name1, OK)
|
||||
("c1", _, Right (INV cReq)) <- h1 #: ("c1", name2, "NEW")
|
||||
let cReq' = serializeConnReq cReq
|
||||
h2 #: ("c2", name1, "JOIN " <> cReq' <> " 5\ninfo2") #> ("c2", name1, OK)
|
||||
("", _, Right (REQ connId "info2")) <- (h1 <#:)
|
||||
h1 #: ("c3", name2, "ACPT " <> connId <> " 5\ninfo1") #> ("c3", name2, OK)
|
||||
h2 <# ("", name1, INFO "info1")
|
||||
@@ -261,9 +264,9 @@ connect (h1, name1) (h2, name2) = do
|
||||
|
||||
-- connect' :: forall c. Transport c => c -> c -> IO (ByteString, ByteString)
|
||||
-- connect' h1 h2 = do
|
||||
-- ("c1", conn2, Right (INV qInfo)) <- h1 #: ("c1", "", "NEW")
|
||||
-- let qInfo' = serializeSmpQueueInfo qInfo
|
||||
-- ("c2", conn1, Right OK) <- h2 #: ("c2", "", "JOIN " <> qInfo' <> " 5\ninfo2")
|
||||
-- ("c1", conn2, Right (INV cReq)) <- h1 #: ("c1", "", "NEW")
|
||||
-- let cReq' = serializeConnReq cReq
|
||||
-- ("c2", conn1, Right OK) <- h2 #: ("c2", "", "JOIN " <> cReq' <> " 5\ninfo2")
|
||||
-- ("", _, Right (REQ connId "info2")) <- (h1 <#:)
|
||||
-- h1 #: ("c3", conn2, "ACPT " <> connId <> " 5\ninfo1") =#> \case ("c3", c, OK) -> c == conn2; _ -> False
|
||||
-- h2 <# ("", conn1, INFO "info1")
|
||||
@@ -290,7 +293,7 @@ syntaxTests t = do
|
||||
-- TODO: ERROR no connection alias in the response (it does not generate it yet if not provided)
|
||||
-- TODO: add tests with defined connection alias
|
||||
it "using same server as in invitation" $
|
||||
("311", "a", "JOIN smp::localhost:5000::1234::" <> samplePublicKey <> " 14\nbob's connInfo") >#> ("311", "a", "ERR SMP AUTH")
|
||||
("311", "a", "JOIN https://simpex.chat/connect#/?smp=smp%3A%2F%2Flocalhost%3A5000%2F1234-w%3D%3D%23&e2e=" <> urlEncode True samplePublicKey <> " 14\nbob's connInfo") >#> ("311", "a", "ERR SMP AUTH")
|
||||
describe "invalid" do
|
||||
-- TODO: JOIN is not merged yet - to be added
|
||||
it "no parameters" $ ("321", "", "JOIN") >#> ("321", "", "ERR CMD SYNTAX")
|
||||
|
||||
70
tests/AgentTests/ConnectionRequestTests.hs
Normal file
70
tests/AgentTests/ConnectionRequestTests.hs
Normal file
@@ -0,0 +1,70 @@
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module AgentTests.ConnectionRequestTests where
|
||||
|
||||
import qualified Crypto.PubKey.RSA as R
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Parsers (parseAll)
|
||||
import Test.Hspec
|
||||
|
||||
uri :: String
|
||||
uri = "smp.simplex.im"
|
||||
|
||||
srv :: SMPServer
|
||||
srv =
|
||||
SMPServer
|
||||
{ host = "smp.simplex.im",
|
||||
port = Just "5223",
|
||||
keyHash = Just (C.KeyHash "\215m\248\251")
|
||||
}
|
||||
|
||||
queue :: SMPQueueUri
|
||||
queue =
|
||||
SMPQueueUri
|
||||
{ smpServer = srv,
|
||||
senderId = "\215m\248\251",
|
||||
serverVerifyKey = reservedServerKey
|
||||
}
|
||||
|
||||
appServer :: ConnReqScheme
|
||||
appServer = CRSAppServer "simplex.chat" Nothing
|
||||
|
||||
connReq :: ConnectionRequest
|
||||
connReq =
|
||||
ConnectionRequest
|
||||
{ crScheme = appServer,
|
||||
crAction = CRAConnect,
|
||||
crSmpQueues = [queue],
|
||||
crEncryptKey = C.APublicEncryptKey C.SRSA (C.PublicKeyRSA $ R.PublicKey 1 0 0)
|
||||
}
|
||||
|
||||
connectionRequestTests :: Spec
|
||||
connectionRequestTests = do
|
||||
describe "connection request parsing / serializing" $ do
|
||||
it "should serialize SMP queue URIs" $ do
|
||||
serializeSMPQueueUri queue {smpServer = srv {port = Nothing, keyHash = Nothing}}
|
||||
`shouldBe` "smp://smp.simplex.im/1234-w==#"
|
||||
serializeSMPQueueUri queue {smpServer = srv {keyHash = Nothing}}
|
||||
`shouldBe` "smp://smp.simplex.im:5223/1234-w==#"
|
||||
serializeSMPQueueUri queue {smpServer = srv {port = Nothing}}
|
||||
`shouldBe` "smp://1234-w==@smp.simplex.im/1234-w==#"
|
||||
serializeSMPQueueUri queue
|
||||
`shouldBe` "smp://1234-w==@smp.simplex.im:5223/1234-w==#"
|
||||
it "should parse SMP queue URIs" $ do
|
||||
parseAll smpQueueUriP "smp://smp.simplex.im/1234-w==#"
|
||||
`shouldBe` Right queue {smpServer = srv {port = Nothing, keyHash = Nothing}}
|
||||
parseAll smpQueueUriP "smp://smp.simplex.im:5223/1234-w==#"
|
||||
`shouldBe` Right queue {smpServer = srv {keyHash = Nothing}}
|
||||
parseAll smpQueueUriP "smp://1234-w==@smp.simplex.im/1234-w==#"
|
||||
`shouldBe` Right queue {smpServer = srv {port = Nothing}}
|
||||
parseAll smpQueueUriP "smp://1234-w==@smp.simplex.im:5223/1234-w==#"
|
||||
`shouldBe` Right queue
|
||||
it "should serialize connection requests" $ do
|
||||
serializeConnReq connReq
|
||||
`shouldBe` "https://simplex.chat/connect#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F1234-w%3D%3D%23&e2e=rsa%3AMBowDQYJKoZIhvcNAQEBBQADCQAwBgIBAAIBAA%3D%3D"
|
||||
it "should parse connection requests" $ do
|
||||
-- print $ parseSMPMessage "\n0 2021-11-29T19:23:27.005Z \nREPLY simplex:/connect#/?smp=smp%3A%2F%2FKXNE1m2E1m0lm92WGKet9CL6-lO742Vy5G6nsrkvgs8%3D%40localhost%3A5000%2FoWWCE_5ug0t05K6X%23&e2e=rsa%3AMIIBoDANBgkqhkiG9w0BAQEFAAOCAY0AMIIBiAKCAQEA3O4frbgUMRO%2B8FIX2%2ByqB%2F1B5pXmt%2F%2FY0dFd2HCVxL31TJHc90HJp92Qb7Ni%2B1dI2Ka1Hb1Fvup897mmEcFhZStG0OB6jffvPyxXCas8Tov3l757qCUZKqgTxSJkL7JvLkIN9jMs50islvrSHCAj8VReh5oR%2B8OFp8ITd5MuMHYuR1bt0XLl1TwSIyfRSQqtHlt%2FEBbEbWcgJMsDXMi3o983nezvF9En9F7OCnasdzKAsgcN2%2FdWp3CPeuMNe9epzrirxGfCKU%2FlVyZ77e7NZMkSmeOIDPGuE4Fk8bweAYArV%2FrECBJGBQkGx3YtEh0kIbCakQ1ZnKY%2F%2FMq0ZHGPhQKBgGRKfJ7xXftoLdVJ7EOW%2FR5Y%2Bj%2F%2Bb9yZMbTCdZfkuroV9FH8GF5tS3PWuSAOFu42h7TiqFjXlvM6aYp%2FBXxCosZjBlB6mWCLyuY48ZszhtCpLSlbR2x%2FpGMUEgyOsefeMusrHEqFJAI%2Fhh8LljBGL%2BV08qcGFxVTwCVePIjDOo1H\n"
|
||||
parseAll connReqP "https://simplex.chat/connect#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F1234-w%3D%3D%23&e2e=rsa%3AMBowDQYJKoZIhvcNAQEBBQADCQAwBgIBAAIBAA%3D%3D"
|
||||
`shouldBe` Right connReq
|
||||
Reference in New Issue
Block a user