simplexmq 0.4.1 → 0.5.0
raw patch · 17 files changed
+773/−161 lines, 17 filesdep +http-types
Dependencies added: http-types
Files
- CHANGELOG.md +10/−0
- migrations/20210101_initial.sql +1/−1
- migrations/20211202_connection_mode.sql +11/−0
- simplexmq.cabal +8/−2
- src/Simplex/Messaging/Agent.hs +86/−34
- src/Simplex/Messaging/Agent/Client.hs +29/−2
- src/Simplex/Messaging/Agent/Protocol.hs +254/−41
- src/Simplex/Messaging/Agent/Store.hs +31/−2
- src/Simplex/Messaging/Agent/Store/SQLite.hs +110/−19
- src/Simplex/Messaging/Crypto.hs +10/−1
- src/Simplex/Messaging/Parsers.hs +19/−4
- src/Simplex/Messaging/Transport.hs +7/−3
- tests/AgentTests.hs +100/−23
- tests/AgentTests/ConnectionRequestTests.hs +68/−0
- tests/AgentTests/FunctionalAPITests.hs +14/−14
- tests/AgentTests/SQLiteTests.hs +14/−14
- tests/SMPAgentClient.hs +1/−1
CHANGELOG.md view
@@ -1,3 +1,13 @@+# 0.5.0++- No changes in SMP server implementation - it is backwards compatible with v0.4.1+- SMP agent changes:+ - URI syntax for SMP queues and connection requests.+ - long-term connections links ("contacts") in SMP agent protocol.+ - agent command changes:+ - `REQ` notification and `ACPT` command are used only with long-term connection links.+ - `CONF` notification and `LET` commands are used for normal duplex connections.+ # 0.4.1 - Include migrations in the package
migrations/20210101_initial.sql view
@@ -50,7 +50,7 @@ snd_host TEXT, snd_port TEXT, snd_id BLOB,- last_internal_msg_id INTEGER NOT NULL,+ last_internal_msg_id INTEGER NOT NULL, -- TODO add defauls here and below in the new schema last_internal_rcv_msg_id INTEGER NOT NULL, last_internal_snd_msg_id INTEGER NOT NULL, last_external_snd_msg_id INTEGER NOT NULL,
+ migrations/20211202_connection_mode.sql view
@@ -0,0 +1,11 @@+ALTER TABLE connections ADD conn_mode TEXT NOT NULL DEFAULT 'INV';++CREATE TABLE conn_invitations (+ invitation_id BLOB NOT NULL PRIMARY KEY,+ contact_conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,+ cr_invitation BLOB NOT NULL,+ recipient_conn_info BLOB NOT NULL,+ accepted INTEGER NOT NULL DEFAULT 0,+ own_conn_info BLOB,+ created_at TEXT NOT NULL DEFAULT (datetime('now'))+) WITHOUT ROWID;
simplexmq.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 706d2f9155c3f3be0f08ea0d6c8954c0e2b9a6e22615f7b19499a3a349af7cc9+-- hash: 3bdb491a0318dc4b53cba4131f192e4c4e17b42e88043495666d1688a1f95443 name: simplexmq-version: 0.4.1+version: 0.5.0 synopsis: SimpleXMQ message broker description: This package includes <./docs/Simplex-Messaging-Server.html server>, <./docs/Simplex-Messaging-Client.html client> and@@ -31,6 +31,7 @@ migrations/20210101_initial.sql migrations/20210624_confirmations.sql migrations/20210809_snd_messages.sql+ migrations/20211202_connection_mode.sql migrations/README.md library@@ -81,6 +82,7 @@ , file-embed ==0.0.14.* , filepath ==1.4.* , generic-random >=1.3 && <1.5+ , http-types ==0.12.* , iso8601-time ==0.1.* , memory ==0.15.* , mtl ==2.2.*@@ -126,6 +128,7 @@ , file-embed ==0.0.14.* , filepath ==1.4.* , generic-random >=1.3 && <1.5+ , http-types ==0.12.* , iso8601-time ==0.1.* , memory ==0.15.* , mtl ==2.2.*@@ -173,6 +176,7 @@ , file-embed ==0.0.14.* , filepath ==1.4.* , generic-random >=1.3 && <1.5+ , http-types ==0.12.* , ini ==0.4.* , iso8601-time ==0.1.* , memory ==0.15.*@@ -200,6 +204,7 @@ main-is: Test.hs other-modules: AgentTests+ AgentTests.ConnectionRequestTests AgentTests.FunctionalAPITests AgentTests.SQLiteTests ProtocolErrorTests@@ -232,6 +237,7 @@ , 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.*
src/Simplex/Messaging/Agent.hs view
@@ -4,9 +4,11 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-}@@ -43,7 +45,9 @@ withAgentLock, createConnection, joinConnection,- acceptConnection,+ allowConnection,+ acceptContact,+ rejectContact, subscribeConnection, sendMessage, ackMessage,@@ -82,7 +86,7 @@ import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Protocol (MsgBody, SenderPublicKey) import qualified Simplex.Messaging.Protocol as SMP-import Simplex.Messaging.Transport (ATransport (..), TProxy, Transport (..), runTransportServer)+import Simplex.Messaging.Transport (ATransport (..), TProxy, Transport (..), currentSMPVersionStr, runTransportServer) import Simplex.Messaging.Util (bshow, tryError) import System.Random (randomR) import UnliftIO.Async (Async, async, race_)@@ -106,7 +110,7 @@ where smpAgent :: forall c m'. (Transport c, MonadUnliftIO m', MonadReader Env m') => TProxy c -> m' () smpAgent _ = runTransportServer started tcpPort $ \(h :: c) -> do- liftIO $ putLn h "Welcome to SMP v0.4.1 agent"+ liftIO . putLn h $ "Welcome to SMP agent v" <> currentSMPVersionStr c <- getAgentClient logConnection c True race_ (connectClient h c) (runAgentClient c)@@ -128,17 +132,25 @@ type AgentErrorMonad m = (MonadUnliftIO m, MonadError AgentErrorType m) -- | Create SMP agent connection (NEW command)-createConnection :: AgentErrorMonad m => AgentClient -> m (ConnId, SMPQueueInfo)-createConnection c = withAgentEnv c $ newConn c ""+createConnection :: AgentErrorMonad m => AgentClient -> SConnectionMode c -> m (ConnId, ConnectionRequest c)+createConnection c cMode = withAgentEnv c $ newConn c "" cMode -- | Join SMP agent connection (JOIN command)-joinConnection :: AgentErrorMonad m => AgentClient -> SMPQueueInfo -> ConnInfo -> m ConnId+joinConnection :: AgentErrorMonad m => AgentClient -> ConnectionRequest c -> ConnInfo -> m ConnId joinConnection c = withAgentEnv c .: joinConn c "" --- | Approve confirmation (LET command)-acceptConnection :: AgentErrorMonad m => AgentClient -> ConnId -> ConfirmationId -> ConnInfo -> m ()-acceptConnection c = withAgentEnv c .:. acceptConnection' c+-- | Allow connection to continue after CONF notification (LET command)+allowConnection :: AgentErrorMonad m => AgentClient -> ConnId -> ConfirmationId -> ConnInfo -> m ()+allowConnection c = withAgentEnv c .:. allowConnection' c +-- | Accept contact after REQ notification (ACPT command)+acceptContact :: AgentErrorMonad m => AgentClient -> ConfirmationId -> ConnInfo -> m ConnId+acceptContact c = withAgentEnv c .: acceptContact' c ""++-- | Reject contact (RJCT command)+rejectContact :: AgentErrorMonad m => AgentClient -> ConnId -> ConfirmationId -> m ()+rejectContact c = withAgentEnv c .: rejectContact' c+ -- | Subscribe to receive connection messages (SUB command) subscribeConnection :: AgentErrorMonad m => AgentClient -> ConnId -> m () subscribeConnection c = withAgentEnv c . subscribeConnection' c@@ -230,33 +242,39 @@ SEConnDuplicate -> CONN DUPLICATE SEBadConnType CRcv -> CONN SIMPLEX SEBadConnType CSnd -> CONN SIMPLEX+ SEInvitationNotFound -> CMD PROHIBITED e -> INTERNAL $ show e -- | execute any SMP agent command 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- ACPT confId ownConnInfo -> acceptConnection' c connId confId ownConnInfo $> (connId, OK)+ NEW (ACM cMode) -> second (INV . ACR cMode) <$> newConn c connId cMode+ JOIN (ACR _ cReq) connInfo -> (,OK) <$> joinConn c connId cReq connInfo+ LET confId ownCInfo -> allowConnection' c connId confId ownCInfo $> (connId, OK)+ ACPT invId ownCInfo -> (,OK) <$> acceptContact' c connId invId ownCInfo+ RJCT invId -> rejectContact' c connId invId $> (connId, OK) SUB -> subscribeConnection' c connId $> (connId, OK) SEND msgBody -> (connId,) . MID <$> sendMessage' c connId msgBody ACK msgId -> ackMessage' c connId msgId $> (connId, OK) OFF -> suspendConnection' c connId $> (connId, OK) DEL -> deleteConnection' c connId $> (connId, OK) -newConn :: AgentMonad m => AgentClient -> ConnId -> m (ConnId, SMPQueueInfo)-newConn c connId = do+newConn :: AgentMonad m => AgentClient -> ConnId -> SConnectionMode c -> m (ConnId, ConnectionRequest c)+newConn c connId cMode = 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+ connId' <- withStore $ \st -> createRcvConn st g cData rq cMode addSubscription c rq connId'- pure (connId', qInfo)+ let crData = ConnReqData simplexChat [qUri] encryptKey+ pure . (connId',) $ case cMode of+ SCMInvitation -> CRInvitation crData+ SCMContact -> CRContact crData -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 c -> ConnInfo -> m ConnId+joinConn c connId (CRInvitation (ConnReqData _ (qUri :| _) encryptKey)) cInfo = do+ (sq, senderKey, verifyKey) <- newSndQueue qUri encryptKey g <- asks idsDrg cfg <- asks config let cData = ConnData {connId}@@ -264,6 +282,10 @@ confirmQueue c sq senderKey cInfo activateQueueJoining c connId' sq verifyKey $ retryInterval cfg pure connId'+joinConn c connId (CRContact (ConnReqData _ (qUri :| _) encryptKey)) cInfo = do+ (connId', cReq) <- newConn c connId SCMInvitation+ sendInvitation c qUri encryptKey cReq cInfo+ pure connId' activateQueueJoining :: forall m. AgentMonad m => AgentClient -> ConnId -> SndQueue -> VerificationKey -> RetryInterval -> m () activateQueueJoining c connId sq verifyKey retryInterval =@@ -272,20 +294,35 @@ 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 $ CRInvitation $ ConnReqData CRSSimplex [qUri'] encryptKey -- | Approve confirmation (LET command) in Reader monad-acceptConnection' :: AgentMonad m => AgentClient -> ConnId -> ConfirmationId -> ConnInfo -> m ()-acceptConnection' c connId confId ownConnInfo =+allowConnection' :: AgentMonad m => AgentClient -> ConnId -> ConfirmationId -> ConnInfo -> m ()+allowConnection' c connId confId ownConnInfo = do withStore (`getConn` connId) >>= \case- SomeConn SCRcv (RcvConnection _ rq) -> do+ SomeConn _ (RcvConnection _ rq) -> do AcceptedConfirmation {senderKey} <- withStore $ \st -> acceptConfirmation st confId ownConnInfo processConfirmation c rq senderKey _ -> throwError $ CMD PROHIBITED +-- | Accept contact (ACPT command) in Reader monad+acceptContact' :: AgentMonad m => AgentClient -> ConnId -> InvitationId -> ConnInfo -> m ConnId+acceptContact' c connId invId ownConnInfo = do+ Invitation {contactConnId, connReq} <- withStore (`getInvitation` invId)+ withStore (`getConn` contactConnId) >>= \case+ SomeConn _ ContactConnection {} -> do+ withStore $ \st -> acceptInvitation st invId ownConnInfo+ joinConn c connId connReq ownConnInfo+ _ -> throwError $ CMD PROHIBITED++-- | Reject contact (RJCT command) in Reader monad+rejectContact' :: AgentMonad m => AgentClient -> ConnId -> InvitationId -> m ()+rejectContact' _ contactConnId invId =+ withStore $ \st -> deleteInvitation st contactConnId invId+ processConfirmation :: AgentMonad m => AgentClient -> RcvQueue -> SenderPublicKey -> m () processConfirmation c rq sndKey = do withStore $ \st -> setRcvQueueStatus st rq Confirmed@@ -315,6 +352,7 @@ Active -> throwError $ CONN SIMPLEX _ -> throwError $ INTERNAL "unexpected queue status" SomeConn _ (RcvConnection _ rq) -> subscribeQueue c rq connId+ SomeConn _ (ContactConnection _ rq) -> subscribeQueue c rq connId where resumeDelivery :: SndQueue -> m () resumeDelivery SndQueue {server} = do@@ -458,7 +496,8 @@ withStore (`getConn` connId) >>= \case SomeConn _ (DuplexConnection _ rq _) -> delete rq SomeConn _ (RcvConnection _ rq) -> delete rq- _ -> withStore (`deleteConn` connId)+ SomeConn _ (ContactConnection _ rq) -> delete rq+ SomeConn _ (SndConnection _ _) -> withStore (`deleteConn` connId) where delete :: RcvQueue -> m () delete rq = do@@ -498,6 +537,7 @@ 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 _ -> atomically $ writeTBQueue subQ ("", "", ERR $ CONN NOT_FOUND) where processSMP :: SConnType c -> ConnData -> RcvQueue -> m ()@@ -508,13 +548,14 @@ msg <- decryptAndVerify rq msgBody let msgHash = C.sha256Hash msg case parseSMPMessage msg of- Left e -> notify $ ERR e+ Left e -> notify (ERR e) >> sendAck c rq Right (SMPConfirmation senderKey cInfo) -> smpConfirmation senderKey cInfo >> sendAck c rq 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+ A_INV cReq cInfo -> smpInvitation cReq cInfo >> sendAck c rq SMP.END -> do removeSubscription c connId logServer "<--" c srv rId "END"@@ -538,7 +579,7 @@ g <- asks idsDrg let newConfirmation = NewConfirmation {connId, senderKey, senderConnInfo = cInfo} confId <- withStore $ \st -> createConfirmation st g newConfirmation- notify $ REQ confId cInfo+ notify $ CONF confId cInfo SCDuplex -> do notify $ INFO cInfo processConfirmation c rq senderKey@@ -557,13 +598,13 @@ SCDuplex -> notifyConnected c connId _ -> pure () - replyMsg :: SMPQueueInfo -> m ()- replyMsg qInfo = do+ replyMsg :: ConnectionRequest 'CMInvitation -> m ()+ replyMsg (CRInvitation (ConnReqData _ (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)@@ -583,6 +624,17 @@ withStore $ \st -> createRcvMsg st connId rcvMsg notify $ MSG msgMeta msgBody + smpInvitation :: ConnectionRequest 'CMInvitation -> ConnInfo -> m ()+ smpInvitation connReq cInfo = do+ logServer "<--" c srv rId "MSG <KEY>"+ case cType of+ SCContact -> do+ g <- asks idsDrg+ let newInv = NewInvitation {contactConnId = connId, connReq, recipientConnInfo = cInfo}+ invId <- withStore $ \st -> createInvitation st g newInv+ notify $ REQ invId cInfo+ _ -> prohibited+ checkMsgIntegrity :: PrevExternalSndId -> ExternalSndId -> PrevRcvMsgHash -> ByteString -> MsgIntegrity checkMsgIntegrity prevExtSndId extSndId internalPrevMsgHash receivedPrevMsgHash | extSndId == prevExtSndId + 1 && internalPrevMsgHash == receivedPrevMsgHash = MsgOk@@ -623,8 +675,8 @@ notifyConnected c connId = atomically $ writeTBQueue (subQ c) ("", connId, CON) newSndQueue ::- (MonadUnliftIO m, MonadReader Env m) => SMPQueueInfo -> m (SndQueue, SenderPublicKey, VerificationKey)-newSndQueue (SMPQueueInfo smpServer senderId encryptKey) = do+ (MonadUnliftIO m, MonadReader Env m) => SMPQueueUri -> EncryptionKey -> m (SndQueue, SenderPublicKey, VerificationKey)+newSndQueue (SMPQueueUri smpServer senderId _) encryptKey = do size <- asks $ rsaKeySize . config (senderKey, sndPrivateKey) <- liftIO $ C.generateKeyPair size (verifyKey, signKey) <- liftIO $ C.generateKeyPair size
src/Simplex/Messaging/Agent/Client.hs view
@@ -17,6 +17,7 @@ subscribeQueue, addSubscription, sendConfirmation,+ sendInvitation, RetryInterval (..), sendHello, secureQueue,@@ -226,7 +227,7 @@ 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, EncryptionKey) newRcvQueue c srv = do size <- asks $ rsaKeySize . config (recipientKey, rcvPrivateKey) <- liftIO $ C.generateKeyPair size@@ -244,7 +245,7 @@ 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@@ -322,6 +323,23 @@ agentMessage = HELLO verifyKey ackMode } +sendInvitation :: forall m. AgentMonad m => AgentClient -> SMPQueueUri -> EncryptionKey -> ConnectionRequest 'CMInvitation -> ConnInfo -> m ()+sendInvitation c SMPQueueUri {smpServer, senderId} encryptKey cReq connInfo = do+ withLogSMP_ c smpServer senderId "SEND <INV>" $ \smp -> do+ msg <- mkInvitation smp+ liftSMP $ sendSMPMessage smp Nothing senderId msg+ where+ mkInvitation :: SMPClient -> m ByteString+ mkInvitation smp = do+ senderTimestamp <- liftIO getCurrentTime+ encryptUnsigned smp encryptKey . serializeSMPMessage $+ SMPMessage+ { senderMsgId = 0,+ senderTimestamp,+ previousMsgHash = "",+ agentMessage = A_INV cReq connInfo+ }+ secureQueue :: AgentMonad m => AgentClient -> RcvQueue -> SenderPublicKey -> m () secureQueue c RcvQueue {server, rcvId, rcvPrivateKey} senderKey = withLogSMP c server rcvId "KEY <key>" $ \smp ->@@ -360,6 +378,15 @@ decryptAndVerify RcvQueue {decryptKey, verifyKey} msg = verifyMessage verifyKey msg >>= liftError cryptoError . C.decrypt decryptKey++encryptUnsigned :: AgentMonad m => SMPClient -> EncryptionKey -> ByteString -> m ByteString+encryptUnsigned smp encryptKey msg = do+ paddedSize <- asks $ (blockSize smp -) . reservedMsgSize+ size <- asks $ rsaKeySize . config+ liftError cryptoError $ do+ enc <- C.encrypt encryptKey paddedSize msg+ let sig = B.replicate size ' '+ pure $ sig <> enc verifyMessage :: AgentMonad m => Maybe VerificationKey -> ByteString -> m ByteString verifyMessage verifyKey msg = do
src/Simplex/Messaging/Agent/Protocol.hs view
@@ -10,6 +10,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}@@ -37,7 +38,18 @@ SMPMessage (..), AMessage (..), SMPServer (..),- SMPQueueInfo (..),+ SMPQueueUri (..),+ ConnectionMode (..),+ SConnectionMode (..),+ AConnectionMode (..),+ cmInvitation,+ cmContact,+ ConnectionModeI (..),+ ConnectionRequest (..),+ AConnectionRequest (..),+ ConnReqData (..),+ ConnReqScheme (..),+ simplexChat, AgentErrorType (..), CommandErrorType (..), ConnectionErrorType (..),@@ -48,7 +60,6 @@ ARawTransmission, ConnId, ConfirmationId,- IntroId, InvitationId, AckMode (..), OnOff (..),@@ -67,14 +78,25 @@ serializeSMPMessage, serializeMsgIntegrity, serializeServer,- serializeSmpQueueInfo,+ serializeSMPQueueUri,+ reservedServerKey, -- TODO remove+ serializeConnMode,+ serializeConnMode',+ connMode,+ connMode',+ serializeConnReq,+ serializeConnReq', serializeAgentError, commandP, parseSMPMessage, smpServerP,- smpQueueInfoP,+ smpQueueUriP,+ connModeT,+ connReqP,+ connReqP', msgIntegrityP, agentErrorTypeP,+ agentMessageP, -- * TCP transport functions tPut,@@ -86,21 +108,28 @@ 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.Maybe (isJust) import Data.String (IsString (..))+import Data.Text (Text) import Data.Time.Clock (UTCTime) import Data.Time.ISO8601 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@@ -115,7 +144,7 @@ import Simplex.Messaging.Util import Test.QuickCheck (Arbitrary (..)) import Text.Read-import UnliftIO.Exception+import UnliftIO.Exception (Exception) -- | Raw (unparsed) SMP agent protocol transmission. type ARawTransmission = (ByteString, ByteString, ByteString)@@ -154,11 +183,14 @@ -- | 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- REQ :: ConfirmationId -> ConnInfo -> ACommand Agent -- ConnInfo is from sender- ACPT :: ConfirmationId -> ConnInfo -> ACommand Client -- ConnInfo is from client+ NEW :: AConnectionMode -> ACommand Client -- response INV+ INV :: AConnectionRequest -> ACommand Agent+ JOIN :: AConnectionRequest -> ConnInfo -> ACommand Client -- response OK+ CONF :: ConfirmationId -> ConnInfo -> ACommand Agent -- ConnInfo is from sender+ LET :: ConfirmationId -> ConnInfo -> ACommand Client -- ConnInfo is from client+ REQ :: InvitationId -> ConnInfo -> ACommand Agent -- ConnInfo is from sender+ ACPT :: InvitationId -> ConnInfo -> ACommand Client -- ConnInfo is from client+ RJCT :: InvitationId -> ACommand Client INFO :: ConnInfo -> ACommand Agent CON :: ACommand Agent -- notification that connection is established SUB :: ACommand Client@@ -183,6 +215,49 @@ deriving instance Show (ACommand p) +data ConnectionMode = CMInvitation | CMContact+ deriving (Eq, Show)++data SConnectionMode (m :: ConnectionMode) where+ SCMInvitation :: SConnectionMode CMInvitation+ SCMContact :: SConnectionMode CMContact++deriving instance Eq (SConnectionMode m)++deriving instance Show (SConnectionMode m)++instance TestEquality SConnectionMode where+ testEquality SCMInvitation SCMInvitation = Just Refl+ testEquality SCMContact SCMContact = Just Refl+ testEquality _ _ = Nothing++data AConnectionMode = forall m. ACM (SConnectionMode m)++instance Eq AConnectionMode where+ ACM m == ACM m' = isJust $ testEquality m m'++cmInvitation :: AConnectionMode+cmInvitation = ACM SCMInvitation++cmContact :: AConnectionMode+cmContact = ACM SCMContact++deriving instance Show AConnectionMode++connMode :: SConnectionMode m -> ConnectionMode+connMode SCMInvitation = CMInvitation+connMode SCMContact = CMContact++connMode' :: ConnectionMode -> AConnectionMode+connMode' CMInvitation = cmInvitation+connMode' CMContact = cmContact++class ConnectionModeI (m :: ConnectionMode) where sConnectionMode :: SConnectionMode m++instance ConnectionModeI CMInvitation where sConnectionMode = SCMInvitation++instance ConnectionModeI CMContact where sConnectionMode = SCMContact+ type MsgHash = ByteString -- | Agent message metadata sent to the client@@ -225,9 +300,11 @@ -- | the first message in the queue to validate it is secured HELLO :: VerificationKey -> AckMode -> AMessage -- | reply queue information- REPLY :: SMPQueueInfo -> AMessage+ REPLY :: ConnectionRequest CMInvitation -> AMessage -- | agent envelope for the client message A_MSG :: MsgBody -> AMessage+ -- | connection request with the invitation to connect+ A_INV :: ConnectionRequest CMInvitation -> ConnInfo -> AMessage deriving (Show) -- | Parse SMP message.@@ -268,17 +345,14 @@ "HELLO " *> hello <|> "REPLY " *> reply <|> "MSG " *> a_msg+ <|> "INV " *> a_inv where hello = HELLO <$> C.pubKeyP <*> ackMode- reply = REPLY <$> smpQueueInfoP+ reply = REPLY <$> connReqP' a_msg = A_MSG <$> binaryBodyP <* A.endOfLine+ a_inv = A_INV <$> connReqP' <* A.space <*> binaryBodyP <* A.endOfLine ackMode = AckMode <$> (" NO_ACK" $> Off <|> pure On) --- | SMP queue information parser.-smpQueueInfoP :: Parser SMPQueueInfo-smpQueueInfoP =- "smp::" *> (SMPQueueInfo <$> smpServerP <* "::" <*> base64P <* "::" <*> C.pubKeyP)- -- | SMP server location parser. smpServerP :: Parser SMPServer smpServerP = SMPServer <$> server <*> optional port <*> optional kHash@@ -290,19 +364,114 @@ serializeAgentMessage :: AMessage -> ByteString serializeAgentMessage = \case HELLO verifyKey ackMode -> "HELLO " <> C.serializePubKey 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"+ A_INV cReq cInfo -> B.unwords ["INV", serializeConnReq' cReq, serializeBinary cInfo] <> "\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.serializePubKey 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.PublicKey+reservedServerKey = C.PublicKey $ R.PublicKey 1 0 0++serializeConnReq :: AConnectionRequest -> ByteString+serializeConnReq (ACR _ cr) = serializeConnReq' cr++serializeConnReq' :: ConnectionRequest m -> ByteString+serializeConnReq' = \case+ CRInvitation crData -> serialize CMInvitation crData+ CRContact crData -> serialize CMContact crData+ where+ serialize crMode ConnReqData {crScheme, crSmpQueues, crEncryptKey} =+ sch <> "/" <> m <> "#/" <> queryStr+ where+ sch = case crScheme of+ CRSSimplex -> "simplex:"+ CRSAppServer host port -> B.pack $ "https://" <> host <> maybe "" (':' :) port+ m = case crMode of+ CMInvitation -> "invitation"+ CMContact -> "contact"+ queryStr = renderSimpleQuery True [("smp", queues), ("e2e", key)]+ queues = B.intercalate "," . map serializeSMPQueueUri $ L.toList crSmpQueues+ key = C.serializePubKeyUri crEncryptKey++connReqP' :: forall m. ConnectionModeI m => Parser (ConnectionRequest m)+connReqP' = do+ ACR m cr <- connReqP+ case testEquality m $ sConnectionMode @m of+ Just Refl -> pure cr+ _ -> fail "bad connection request mode"++connReqP :: Parser AConnectionRequest+connReqP = do+ crScheme <- "simplex:" $> CRSSimplex <|> "https://" *> appServer+ crMode <- "/" *> mode <* "#/?"+ query <- parseSimpleQuery <$> A.takeTill (\c -> c == ' ' || c == '\n')+ crSmpQueues <- paramP "smp" smpQueues query+ crEncryptKey <- paramP "e2e" C.pubKeyUriP query+ let cReq = ConnReqData {crScheme, crSmpQueues, crEncryptKey}+ pure $ case crMode of+ CMInvitation -> ACR SCMInvitation $ CRInvitation cReq+ CMContact -> ACR SCMContact $ CRContact cReq+ where+ appServer = CRSAppServer <$> host <*> optional port+ host = B.unpack <$> A.takeTill (\c -> c == ':' || c == '/')+ port = B.unpack <$> (A.char ':' *> A.takeTill (== '/'))+ mode = "invitation" $> CMInvitation <|> "contact" $> CMContact+ 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}++serializeConnMode :: AConnectionMode -> ByteString+serializeConnMode (ACM cMode) = serializeConnMode' $ connMode cMode++serializeConnMode' :: ConnectionMode -> ByteString+serializeConnMode' = \case+ CMInvitation -> "INV"+ CMContact -> "CON"++connModeP' :: Parser ConnectionMode+connModeP' = "INV" $> CMInvitation <|> "CON" $> CMContact++connModeP :: Parser AConnectionMode+connModeP = connMode' <$> connModeP'++connModeT :: Text -> Maybe ConnectionMode+connModeT = \case+ "INV" -> Just CMInvitation+ "CON" -> Just CMContact+ _ -> Nothing+ -- | SMP server location and transport key digest (hash). data SMPServer = SMPServer { host :: HostName,@@ -319,8 +488,6 @@ type ConfirmationId = ByteString -type IntroId = ByteString- type InvitationId = ByteString -- | Connection modes.@@ -332,9 +499,43 @@ -- | 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 EncryptionKey+data SMPQueueUri = SMPQueueUri+ { smpServer :: SMPServer,+ senderId :: SMP.SenderId,+ serverVerifyKey :: VerificationKey+ } deriving (Eq, Show) +data ConnectionRequest (m :: ConnectionMode) where+ CRInvitation :: ConnReqData -> ConnectionRequest CMInvitation+ CRContact :: ConnReqData -> ConnectionRequest CMContact++deriving instance Eq (ConnectionRequest m)++deriving instance Show (ConnectionRequest m)++data AConnectionRequest = forall m. ACR (SConnectionMode m) (ConnectionRequest m)++instance Eq AConnectionRequest where+ ACR m cr == ACR m' cr' = case testEquality m m' of+ Just Refl -> cr == cr'+ _ -> False++deriving instance Show AConnectionRequest++data ConnReqData = ConnReqData+ { crScheme :: ConnReqScheme,+ crSmpQueues :: L.NonEmpty SMPQueueUri,+ crEncryptKey :: EncryptionKey+ }+ deriving (Eq, Show)++data ConnReqScheme = CRSSimplex | CRSAppServer HostName (Maybe ServiceName)+ deriving (Eq, Show)++simplexChat :: ConnReqScheme+simplexChat = CRSAppServer "simplex.chat" Nothing+ -- | Public key used to E2E encrypt SMP messages. type EncryptionKey = C.PublicKey @@ -454,11 +655,14 @@ -- | SMP agent command and response parser commandP :: Parser ACmd commandP =- "NEW" $> ACmd SClient NEW+ "NEW " *> newCmd <|> "INV " *> invResp <|> "JOIN " *> joinCmd- <|> "REQ " *> reqCmd+ <|> "CONF " *> confMsg+ <|> "LET " *> letCmd+ <|> "REQ " *> reqMsg <|> "ACPT " *> acptCmd+ <|> "RJCT " *> rjctCmd <|> "INFO " *> infoCmd <|> "SUB" $> ACmd SClient SUB <|> "END" $> ACmd SAgent END@@ -476,10 +680,14 @@ <|> "CON" $> ACmd SAgent CON <|> "OK" $> ACmd SAgent OK where- invResp = ACmd SAgent . INV <$> smpQueueInfoP- joinCmd = ACmd SClient <$> (JOIN <$> smpQueueInfoP <* A.space <*> A.takeByteString)- reqCmd = ACmd SAgent <$> (REQ <$> A.takeTill (== ' ') <* A.space <*> A.takeByteString)+ newCmd = ACmd SClient . NEW <$> connModeP+ invResp = ACmd SAgent . INV <$> connReqP+ joinCmd = ACmd SClient <$> (JOIN <$> connReqP <* A.space <*> A.takeByteString)+ confMsg = ACmd SAgent <$> (CONF <$> A.takeTill (== ' ') <* A.space <*> A.takeByteString)+ letCmd = ACmd SClient <$> (LET <$> A.takeTill (== ' ') <* A.space <*> A.takeByteString)+ reqMsg = ACmd SAgent <$> (REQ <$> A.takeTill (== ' ') <* A.space <*> A.takeByteString) acptCmd = ACmd SClient <$> (ACPT <$> A.takeTill (== ' ') <* A.space <*> A.takeByteString)+ rjctCmd = ACmd SClient . RJCT <$> A.takeByteString infoCmd = ACmd SAgent . INFO <$> A.takeByteString sendCmd = ACmd SClient . SEND <$> A.takeByteString msgIdResp = ACmd SAgent . MID <$> A.decimal@@ -512,11 +720,14 @@ -- | Serialize SMP agent command. serializeCommand :: ACommand p -> ByteString serializeCommand = \case- NEW -> "NEW"- INV qInfo -> "INV " <> serializeSmpQueueInfo qInfo- JOIN qInfo cInfo -> "JOIN " <> serializeSmpQueueInfo qInfo <> " " <> serializeBinary cInfo- REQ confId cInfo -> "REQ " <> confId <> " " <> serializeBinary cInfo- ACPT confId cInfo -> "ACPT " <> confId <> " " <> serializeBinary cInfo+ NEW cMode -> "NEW " <> serializeConnMode cMode+ INV cReq -> "INV " <> serializeConnReq cReq+ JOIN cReq cInfo -> B.unwords ["JOIN", serializeConnReq cReq, serializeBinary cInfo]+ CONF confId cInfo -> B.unwords ["CONF", confId, serializeBinary cInfo]+ LET confId cInfo -> B.unwords ["LET", confId, serializeBinary cInfo]+ REQ invId cInfo -> B.unwords ["REQ", invId, serializeBinary cInfo]+ ACPT invId cInfo -> B.unwords ["ACPT", invId, serializeBinary cInfo]+ RJCT invId -> "RJCT " <> invId INFO cInfo -> "INFO " <> serializeBinary cInfo SUB -> "SUB" END -> "END"@@ -525,9 +736,8 @@ SEND msgBody -> "SEND " <> serializeBinary msgBody MID mId -> "MID " <> bshow mId SENT mId -> "SENT " <> bshow mId- MERR mId e -> "MERR " <> bshow mId <> " " <> serializeAgentError e- MSG msgMeta msgBody ->- "MSG " <> serializeMsgMeta msgMeta <> " " <> serializeBinary msgBody+ MERR mId e -> B.unwords ["MERR", bshow mId, serializeAgentError e]+ MSG msgMeta msgBody -> B.unwords ["MSG", serializeMsgMeta msgMeta, serializeBinary msgBody] ACK mId -> "ACK " <> bshow mId OFF -> "OFF" DEL -> "DEL"@@ -617,8 +827,9 @@ tConnId :: ARawTransmission -> ACommand p -> Either AgentErrorType (ACommand p) tConnId (_, connId, _) cmd = case cmd of -- NEW, JOIN and ACPT have optional connId- NEW -> Right cmd+ NEW _ -> Right cmd JOIN {} -> Right cmd+ ACPT {} -> Right cmd -- ERROR response does not always have connId ERR _ -> Right cmd -- other responses must have connId@@ -630,9 +841,11 @@ cmdWithMsgBody = \case SEND body -> SEND <$$> getBody body MSG msgMeta body -> MSG msgMeta <$$> getBody body- JOIN qInfo cInfo -> JOIN qInfo <$$> getBody cInfo- REQ confId cInfo -> REQ confId <$$> getBody cInfo- ACPT confId cInfo -> ACPT confId <$$> getBody cInfo+ JOIN qUri cInfo -> JOIN qUri <$$> getBody cInfo+ CONF confId cInfo -> CONF confId <$$> getBody cInfo+ LET confId cInfo -> LET confId <$$> getBody cInfo+ REQ invId cInfo -> REQ invId <$$> getBody cInfo+ ACPT invId cInfo -> ACPT invId <$$> getBody cInfo INFO cInfo -> INFO <$$> getBody cInfo cmd -> pure $ Right cmd
src/Simplex/Messaging/Agent/Store.hs view
@@ -32,7 +32,7 @@ -- | Store class type. Defines store access methods for implementations. class Monad m => MonadAgentStore s m where -- Queue and Connection management- createRcvConn :: s -> TVar ChaChaDRG -> ConnData -> RcvQueue -> m ConnId+ createRcvConn :: s -> TVar ChaChaDRG -> ConnData -> RcvQueue -> SConnectionMode c -> m ConnId createSndConn :: s -> TVar ChaChaDRG -> ConnData -> SndQueue -> m ConnId getConn :: s -> ConnId -> m SomeConn getAllConnIds :: s -> m [ConnId] -- TODO remove - hack for subscribing to all@@ -51,6 +51,12 @@ getAcceptedConfirmation :: s -> ConnId -> m AcceptedConfirmation removeConfirmations :: s -> ConnId -> m () + -- Invitations - sent via Contact connections+ createInvitation :: s -> TVar ChaChaDRG -> NewInvitation -> m InvitationId+ getInvitation :: s -> InvitationId -> m Invitation+ acceptInvitation :: s -> InvitationId -> ConnInfo -> m ()+ deleteInvitation :: s -> ConnId -> InvitationId -> m ()+ -- Msg management updateRcvIds :: s -> ConnId -> m (InternalId, InternalRcvId, PrevExternalSndId, PrevRcvMsgHash) createRcvMsg :: s -> ConnId -> RcvMsgData -> m ()@@ -91,7 +97,7 @@ -- * Connection types -- | Type of a connection.-data ConnType = CRcv | CSnd | CDuplex deriving (Eq, Show)+data ConnType = CRcv | CSnd | CDuplex | CContact deriving (Eq, Show) -- | Connection of a specific type. --@@ -107,6 +113,7 @@ RcvConnection :: ConnData -> RcvQueue -> Connection CRcv SndConnection :: ConnData -> SndQueue -> Connection CSnd DuplexConnection :: ConnData -> RcvQueue -> SndQueue -> Connection CDuplex+ ContactConnection :: ConnData -> RcvQueue -> Connection CContact deriving instance Eq (Connection d) @@ -116,11 +123,13 @@ SCRcv :: SConnType CRcv SCSnd :: SConnType CSnd SCDuplex :: SConnType CDuplex+ SCContact :: SConnType CContact connType :: SConnType c -> ConnType connType SCRcv = CRcv connType SCSnd = CSnd connType SCDuplex = CDuplex+connType SCContact = CContact deriving instance Eq (SConnType d) @@ -130,6 +139,7 @@ testEquality SCRcv SCRcv = Just Refl testEquality SCSnd SCSnd = Just Refl testEquality SCDuplex SCDuplex = Just Refl+ testEquality SCContact SCContact = Just Refl testEquality _ _ = Nothing -- | Connection of an unknown type.@@ -162,6 +172,23 @@ ownConnInfo :: ConnInfo } +-- * Invitations++data NewInvitation = NewInvitation+ { contactConnId :: ConnId,+ connReq :: ConnectionRequest 'CMInvitation,+ recipientConnInfo :: ConnInfo+ }++data Invitation = Invitation+ { invitationId :: InvitationId,+ contactConnId :: ConnId,+ connReq :: ConnectionRequest 'CMInvitation,+ recipientConnInfo :: ConnInfo,+ ownConnInfo :: Maybe ConnInfo,+ accepted :: Bool+ }+ -- * Message integrity validation types -- | Corresponds to `last_external_snd_msg_id` in `connections` table@@ -320,6 +347,8 @@ SEBadConnType ConnType | -- | Confirmation not found. SEConfirmationNotFound+ | -- | Invitation not found+ SEInvitationNotFound | -- | Message not found SEMsgNotFound | -- | Currently not used. The intention was to pass current expected queue status in methods,
src/Simplex/Messaging/Agent/Store/SQLite.hs view
@@ -39,7 +39,8 @@ import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T-import Database.SQLite.Simple (FromRow, NamedParam (..), Only (..), SQLData (..), SQLError, field)+import Data.Text.Encoding (decodeLatin1)+import Database.SQLite.Simple (FromRow, NamedParam (..), Only (..), SQLData (..), SQLError, ToRow, field) import qualified Database.SQLite.Simple as DB import Database.SQLite.Simple.FromField import Database.SQLite.Simple.Internal (Field (..))@@ -150,8 +151,8 @@ else E.throwIO e instance (MonadUnliftIO m, MonadError StoreError m) => MonadAgentStore SQLiteStore m where- createRcvConn :: SQLiteStore -> TVar ChaChaDRG -> ConnData -> RcvQueue -> m ConnId- createRcvConn st gVar cData q@RcvQueue {server} =+ createRcvConn :: SQLiteStore -> TVar ChaChaDRG -> ConnData -> RcvQueue -> SConnectionMode c -> m ConnId+ createRcvConn st gVar cData q@RcvQueue {server} cMode = -- TODO if schema has to be restarted, this function can be refactored -- to create connection first using createWithRandomId liftIOEither . checkConstraint SEConnDuplicate . withTransaction st $ \db ->@@ -161,7 +162,7 @@ create db connId = do upsertServer_ db server insertRcvQueue_ db connId q- insertRcvConnection_ db cData {connId} q+ insertRcvConnection_ db cData {connId} q cMode pure connId createSndConn :: SQLiteStore -> TVar ChaChaDRG -> ConnData -> SndQueue -> m ConnId@@ -359,6 +360,60 @@ |] [":conn_alias" := connId] + createInvitation :: SQLiteStore -> TVar ChaChaDRG -> NewInvitation -> m InvitationId+ createInvitation st gVar NewInvitation {contactConnId, connReq, recipientConnInfo} =+ liftIOEither . withTransaction st $ \db ->+ createWithRandomId gVar $ \invitationId ->+ DB.execute+ db+ [sql|+ INSERT INTO conn_invitations+ (invitation_id, contact_conn_id, cr_invitation, recipient_conn_info, accepted) VALUES (?, ?, ?, ?, 0);+ |]+ (invitationId, contactConnId, connReq, recipientConnInfo)++ getInvitation :: SQLiteStore -> InvitationId -> m Invitation+ getInvitation st invitationId =+ liftIOEither . withTransaction st $ \db ->+ invitation+ <$> DB.query+ db+ [sql|+ SELECT contact_conn_id, cr_invitation, recipient_conn_info, own_conn_info, accepted+ FROM conn_invitations+ WHERE invitation_id = ?+ AND accepted = 0+ |]+ (Only invitationId)+ where+ invitation [(contactConnId, connReq, recipientConnInfo, ownConnInfo, accepted)] =+ Right Invitation {invitationId, contactConnId, connReq, recipientConnInfo, ownConnInfo, accepted}+ invitation _ = Left SEInvitationNotFound++ acceptInvitation :: SQLiteStore -> InvitationId -> ConnInfo -> m ()+ acceptInvitation st invitationId ownConnInfo =+ liftIO . withTransaction st $ \db -> do+ DB.executeNamed+ db+ [sql|+ UPDATE conn_invitations+ SET accepted = 1,+ own_conn_info = :own_conn_info+ WHERE invitation_id = :invitation_id+ |]+ [ ":own_conn_info" := ownConnInfo,+ ":invitation_id" := invitationId+ ]++ deleteInvitation :: SQLiteStore -> ConnId -> InvitationId -> m ()+ deleteInvitation st contactConnId invId =+ liftIOEither . withTransaction st $ \db ->+ runExceptT $+ ExceptT (getConn_ db contactConnId) >>= \case+ SomeConn SCContact _ ->+ liftIO $ DB.execute db "DELETE FROM conn_invitations WHERE contact_conn_id = ? AND invitation_id = ?" (contactConnId, invId)+ _ -> throwError SEConnNotFound+ updateRcvIds :: SQLiteStore -> ConnId -> m (InternalId, InternalRcvId, PrevExternalSndId, PrevRcvMsgHash) updateRcvIds st connId = liftIO . withTransaction st $ \db -> do@@ -501,10 +556,26 @@ 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 AConnectionRequest where toField = toField . serializeConnReq++instance FromField AConnectionRequest where fromField = blobFieldParser connReqP++instance ToField (ConnectionRequest c) where toField = toField . serializeConnReq'++instance (E.Typeable c, ConnectionModeI c) => FromField (ConnectionRequest c) where fromField = blobFieldParser connReqP'++instance ToField ConnectionMode where toField = toField . decodeLatin1 . serializeConnMode'++instance FromField ConnectionMode where fromField = fromTextField_ connModeT++instance ToField (SConnectionMode c) where toField = toField . connMode++instance FromField AConnectionMode where fromField = fromTextField_ $ fmap connMode' . connModeT+ fromTextField_ :: (E.Typeable a) => (Text -> Maybe a) -> Field -> Ok a fromTextField_ fromText = \case f@(Field (SQLText t) _) ->@@ -522,6 +593,22 @@ fromRow = (,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field++instance (FromField a, FromField b, FromField c, FromField d, FromField e,+ FromField f, FromField g, FromField h, FromField i, FromField j,+ FromField k, FromField l) =>+ FromRow (a,b,c,d,e,f,g,h,i,j,k,l) where+ fromRow = (,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field+ <*> field <*> field <*> field <*> field <*> field+ <*> field <*> field++instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,+ ToField g, ToField h, ToField i, ToField j, ToField k, ToField l) =>+ ToRow (a,b,c,d,e,f,g,h,i,j,k,l) where+ toRow (a,b,c,d,e,f,g,h,i,j,k,l) =+ [ toField a, toField b, toField c, toField d, toField e, toField f,+ toField g, toField h, toField i, toField j, toField k, toField l+ ] {- ORMOLU_ENABLE -} -- * Server upsert helper@@ -564,21 +651,24 @@ ":status" := status ] -insertRcvConnection_ :: DB.Connection -> ConnData -> RcvQueue -> IO ()-insertRcvConnection_ dbConn ConnData {connId} RcvQueue {server, rcvId} = do+insertRcvConnection_ :: DB.Connection -> ConnData -> RcvQueue -> SConnectionMode c -> IO ()+insertRcvConnection_ dbConn ConnData {connId} RcvQueue {server, rcvId} cMode = do let port_ = serializePort_ $ port server DB.executeNamed dbConn [sql| INSERT INTO connections- ( conn_alias, rcv_host, rcv_port, rcv_id, snd_host, snd_port, snd_id, last_internal_msg_id, last_internal_rcv_msg_id, last_internal_snd_msg_id, last_external_snd_msg_id, last_rcv_msg_hash, last_snd_msg_hash)+ ( conn_alias, rcv_host, rcv_port, rcv_id, snd_host, snd_port, snd_id, last_internal_msg_id, last_internal_rcv_msg_id, last_internal_snd_msg_id, last_external_snd_msg_id, last_rcv_msg_hash, last_snd_msg_hash,+ conn_mode ) VALUES- (:conn_alias,:rcv_host,:rcv_port,:rcv_id, NULL, NULL, NULL, 0, 0, 0, 0, x'', x'');+ (:conn_alias,:rcv_host,:rcv_port,:rcv_id, NULL, NULL, NULL, 0, 0, 0, 0, x'', x'',+ :conn_mode ); |] [ ":conn_alias" := connId, ":rcv_host" := host server, ":rcv_port" := port_,- ":rcv_id" := rcvId+ ":rcv_id" := rcvId,+ ":conn_mode" := cMode ] -- * createSndConn helpers@@ -627,21 +717,22 @@ getConn_ dbConn connId = getConnData_ dbConn connId >>= \case Nothing -> pure $ Left SEConnNotFound- Just connData -> do+ Just (connData, cMode) -> do rQ <- getRcvQueueByConnAlias_ dbConn connId sQ <- getSndQueueByConnAlias_ dbConn connId- pure $ case (rQ, sQ) of- (Just rcvQ, Just sndQ) -> Right $ SomeConn SCDuplex (DuplexConnection connData rcvQ sndQ)- (Just rcvQ, Nothing) -> Right $ SomeConn SCRcv (RcvConnection connData rcvQ)- (Nothing, Just sndQ) -> Right $ SomeConn SCSnd (SndConnection connData sndQ)+ pure $ case (rQ, sQ, cMode) of+ (Just rcvQ, Just sndQ, CMInvitation) -> Right $ SomeConn SCDuplex (DuplexConnection connData rcvQ sndQ)+ (Just rcvQ, Nothing, CMInvitation) -> Right $ SomeConn SCRcv (RcvConnection connData rcvQ)+ (Nothing, Just sndQ, CMInvitation) -> Right $ SomeConn SCSnd (SndConnection connData sndQ)+ (Just rcvQ, Nothing, CMContact) -> Right $ SomeConn SCContact (ContactConnection connData rcvQ) _ -> Left SEConnNotFound -getConnData_ :: DB.Connection -> ConnId -> IO (Maybe ConnData)+getConnData_ :: DB.Connection -> ConnId -> IO (Maybe (ConnData, ConnectionMode)) getConnData_ dbConn connId' = connData- <$> DB.query dbConn "SELECT conn_alias FROM connections WHERE conn_alias = ?;" (Only connId')+ <$> DB.query dbConn "SELECT conn_alias, conn_mode FROM connections WHERE conn_alias = ?;" (Only connId') where- connData [Only connId] = Just ConnData {connId}+ connData [(connId, cMode)] = Just (ConnData {connId}, cMode) connData _ = Nothing getRcvQueueByConnAlias_ :: DB.Connection -> ConnId -> IO (Maybe RcvQueue)
src/Simplex/Messaging/Crypto.hs view
@@ -64,10 +64,12 @@ -- * Encoding of RSA keys serializePrivKey, serializePubKey,+ serializePubKeyUri, encodePubKey, publicKeyHash, privKeyP, pubKeyP,+ pubKeyUriP, binaryPubKeyP, -- * SHA256 hash@@ -99,6 +101,7 @@ import Data.Bifunctor (bimap, first) import qualified Data.ByteArray as BA import Data.ByteString.Base64 (decode, encode)+import qualified Data.ByteString.Base64.URL as U import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.ByteString.Internal (c2w, w2c)@@ -108,7 +111,7 @@ import Database.SQLite.Simple.FromField (FromField (..)) import Database.SQLite.Simple.ToField (ToField (..)) import Network.Transport.Internal (decodeWord32, encodeWord32)-import Simplex.Messaging.Parsers (base64P, blobFieldParser, parseAll, parseString)+import Simplex.Messaging.Parsers (base64P, base64UriP, blobFieldParser, parseAll, parseString) import Simplex.Messaging.Util (liftEitherError, (<$?>)) -- | A newtype of 'Crypto.PubKey.RSA.PublicKey'.@@ -436,6 +439,9 @@ serializePubKey :: PublicKey -> ByteString serializePubKey = ("rsa:" <>) . encode . encodePubKey +serializePubKeyUri :: PublicKey -> ByteString+serializePubKeyUri = ("rsa:" <>) . U.encode . encodePubKey+ -- | Base-64 PKCS8 encoding of PSA private key. -- -- Not used as part of SMP protocols.@@ -445,6 +451,9 @@ -- Base-64 X509 RSA public key parser. pubKeyP :: Parser PublicKey pubKeyP = decodePubKey <$?> ("rsa:" *> base64P)++pubKeyUriP :: Parser PublicKey+pubKeyUriP = decodePubKey <$?> ("rsa:" *> base64UriP) -- Binary X509 RSA public key parser. binaryPubKeyP :: Parser PublicKey
src/Simplex/Messaging/Parsers.hs view
@@ -7,6 +7,7 @@ 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 = 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
src/Simplex/Messaging/Transport.hs view
@@ -45,6 +45,7 @@ tGetEncrypted, serializeTransportError, transportErrorP,+ currentSMPVersionStr, -- * Trim trailing CR trimCR,@@ -63,7 +64,7 @@ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Functor (($>))-import Data.Maybe(fromMaybe)+import Data.Maybe (fromMaybe) import Data.Set (Set) import qualified Data.Set as S import Data.String@@ -221,8 +222,11 @@ major (SMPVersion a b _ _) = (a, b) currentSMPVersion :: SMPVersion-currentSMPVersion = "0.4.1.0"+currentSMPVersion = "0.5.0.0" +currentSMPVersionStr :: ByteString+currentSMPVersionStr = serializeSMPVersion currentSMPVersion+ serializeSMPVersion :: SMPVersion -> ByteString serializeSMPVersion (SMPVersion a b c d) = B.intercalate "." [bshow a, bshow b, bshow c, bshow d] @@ -372,7 +376,7 @@ liftError (const $ TEHandshake DECRYPT) (C.decryptOAEP pk encKeys) >>= liftEither . parseClientHandshake sendWelcome_6 :: THandle c -> ExceptT TransportError IO ()- sendWelcome_6 th = ExceptT . tPutEncrypted th $ serializeSMPVersion currentSMPVersion <> " "+ sendWelcome_6 th = ExceptT . tPutEncrypted th $ currentSMPVersionStr <> " " -- | Client SMP encrypted transport handshake. --
tests/AgentTests.hs view
@@ -10,14 +10,17 @@ 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+import qualified Simplex.Messaging.Agent.Protocol as A import Simplex.Messaging.Protocol (ErrorType (..), MsgBody) import Simplex.Messaging.Transport (ATransport (..), TProxy (..), Transport (..)) import System.Directory (removeFile)@@ -26,6 +29,7 @@ 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@@ -42,6 +46,13 @@ smpAgentTest2_2_2 $ testDuplexConnection t it "should connect via 2 servers and 2 agents (random IDs)" $ smpAgentTest2_2_2 $ testDuplexConnRandomIds t+ describe "Establishing connections via `contact connection`" do+ it "should connect via contact connection with one server and 3 agents" $+ smpAgentTest3 $ testContactConnection t+ it "should connect via contact connection with one server and 2 agents (random IDs)" $+ smpAgentTest2_2_1 $ testContactConnRandomIds t+ it "should support rejecting contact request" $+ smpAgentTest2_2_1 $ testRejectContactRequest t describe "Connection subscriptions" do it "should connect via one server and one agent" $ smpAgentTest3_1_1 $ testSubscription t@@ -98,11 +109,11 @@ 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)- ("", "bob", Right (REQ confId "bob's connInfo")) <- (alice <#:)- alice #: ("2", "bob", "ACPT " <> confId <> " 16\nalice's connInfo") #> ("2", "bob", OK)+ ("1", "bob", Right (INV cReq)) <- alice #: ("1", "bob", "NEW INV")+ let cReq' = serializeConnReq cReq+ bob #: ("11", "alice", "JOIN " <> cReq' <> " 14\nbob's connInfo") #> ("11", "alice", OK)+ ("", "bob", Right (CONF confId "bob's connInfo")) <- (alice <#:)+ alice #: ("2", "bob", "LET " <> confId <> " 16\nalice's connInfo") #> ("2", "bob", OK) bob <# ("", "alice", INFO "alice's connInfo") bob <# ("", "alice", CON) alice <# ("", "bob", CON)@@ -130,12 +141,12 @@ 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")- ("", bobConn', Right (REQ confId "bob's connInfo")) <- (alice <#:)+ ("1", bobConn, Right (INV cReq)) <- alice #: ("1", "", "NEW INV")+ let cReq' = serializeConnReq cReq+ ("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN " <> cReq' <> " 14\nbob's connInfo")+ ("", bobConn', Right (CONF confId "bob's connInfo")) <- (alice <#:) bobConn' `shouldBe` bobConn- alice #: ("2", bobConn, "ACPT " <> confId <> " 16\nalice's connInfo") =#> \case ("2", c, OK) -> c == bobConn; _ -> False+ alice #: ("2", bobConn, "LET " <> confId <> " 16\nalice's connInfo") =#> \case ("2", c, OK) -> c == bobConn; _ -> False bob <# ("", aliceConn, INFO "alice's connInfo") bob <# ("", aliceConn, CON) alice <# ("", bobConn, CON)@@ -161,6 +172,72 @@ alice #: ("6", bobConn, "DEL") #> ("6", bobConn, OK) alice #:# "nothing else should be delivered to alice" +testContactConnection :: Transport c => TProxy c -> c -> c -> c -> IO ()+testContactConnection _ alice bob tom = do+ ("1", "alice_contact", Right (INV cReq)) <- alice #: ("1", "alice_contact", "NEW CON")+ let cReq' = serializeConnReq cReq++ bob #: ("11", "alice", "JOIN " <> cReq' <> " 14\nbob's connInfo") #> ("11", "alice", OK)+ ("", "alice_contact", Right (REQ aInvId "bob's connInfo")) <- (alice <#:)+ alice #: ("2", "bob", "ACPT " <> aInvId <> " 16\nalice's connInfo") #> ("2", "bob", OK)+ ("", "alice", Right (CONF bConfId "alice's connInfo")) <- (bob <#:)+ bob #: ("12", "alice", "LET " <> bConfId <> " 16\nbob's connInfo 2") #> ("12", "alice", OK)+ alice <# ("", "bob", INFO "bob's connInfo 2")+ alice <# ("", "bob", CON)+ bob <# ("", "alice", CON)+ alice #: ("3", "bob", "SEND :hi") #> ("3", "bob", MID 1)+ alice <# ("", "bob", SENT 1)+ bob <#= \case ("", "alice", Msg "hi") -> True; _ -> False+ bob #: ("13", "alice", "ACK 1") #> ("13", "alice", OK)++ tom #: ("21", "alice", "JOIN " <> cReq' <> " 14\ntom's connInfo") #> ("21", "alice", OK)+ ("", "alice_contact", Right (REQ aInvId' "tom's connInfo")) <- (alice <#:)+ alice #: ("4", "tom", "ACPT " <> aInvId' <> " 16\nalice's connInfo") #> ("4", "tom", OK)+ ("", "alice", Right (CONF tConfId "alice's connInfo")) <- (tom <#:)+ tom #: ("22", "alice", "LET " <> tConfId <> " 16\ntom's connInfo 2") #> ("22", "alice", OK)+ alice <# ("", "tom", INFO "tom's connInfo 2")+ alice <# ("", "tom", CON)+ tom <# ("", "alice", CON)+ alice #: ("5", "tom", "SEND :hi there") #> ("5", "tom", MID 1)+ alice <# ("", "tom", SENT 1)+ tom <#= \case ("", "alice", Msg "hi there") -> True; _ -> False+ tom #: ("23", "alice", "ACK 1") #> ("23", "alice", OK)++testContactConnRandomIds :: Transport c => TProxy c -> c -> c -> IO ()+testContactConnRandomIds _ alice bob = do+ ("1", aliceContact, Right (INV cReq)) <- alice #: ("1", "", "NEW CON")+ let cReq' = serializeConnReq cReq++ ("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN " <> cReq' <> " 14\nbob's connInfo")+ ("", aliceContact', Right (REQ aInvId "bob's connInfo")) <- (alice <#:)+ aliceContact' `shouldBe` aliceContact++ ("2", bobConn, Right OK) <- alice #: ("2", "", "ACPT " <> aInvId <> " 16\nalice's connInfo")+ ("", aliceConn', Right (CONF bConfId "alice's connInfo")) <- (bob <#:)+ aliceConn' `shouldBe` aliceConn++ bob #: ("12", aliceConn, "LET " <> bConfId <> " 16\nbob's connInfo 2") #> ("12", aliceConn, OK)+ alice <# ("", bobConn, INFO "bob's connInfo 2")+ alice <# ("", bobConn, CON)+ bob <# ("", aliceConn, CON)++ alice #: ("3", bobConn, "SEND :hi") #> ("3", bobConn, MID 1)+ alice <# ("", bobConn, SENT 1)+ bob <#= \case ("", c, Msg "hi") -> c == aliceConn; _ -> False+ bob #: ("13", aliceConn, "ACK 1") #> ("13", aliceConn, OK)++testRejectContactRequest :: Transport c => TProxy c -> c -> c -> IO ()+testRejectContactRequest _ alice bob = do+ ("1", "a_contact", Right (INV cReq)) <- alice #: ("1", "a_contact", "NEW CON")+ let cReq' = serializeConnReq cReq+ bob #: ("11", "alice", "JOIN " <> cReq' <> " 10\nbob's info") #> ("11", "alice", OK)+ ("", "a_contact", Right (REQ aInvId "bob's info")) <- (alice <#:)+ -- RJCT must use correct contact connection+ alice #: ("2a", "bob", "RJCT " <> aInvId) #> ("2a", "bob", ERR $ CONN NOT_FOUND)+ alice #: ("2b", "a_contact", "RJCT " <> aInvId) #> ("2b", "a_contact", OK)+ alice #: ("3", "bob", "ACPT " <> aInvId <> " 12\nalice's info") #> ("3", "bob", ERR $ A.CMD PROHIBITED)+ bob #:# "nothing should be delivered to bob"+ testSubscription :: Transport c => TProxy c -> c -> c -> c -> IO () testSubscription _ alice1 alice2 bob = do (alice1, "alice") `connect` (bob, "bob")@@ -182,7 +259,7 @@ testSubscrNotification :: Transport c => TProxy c -> (ThreadId, ThreadId) -> c -> IO () testSubscrNotification t (server, _) client = do- client #: ("1", "conn1", "NEW") =#> \case ("1", "conn1", INV {}) -> True; _ -> False+ client #: ("1", "conn1", "NEW INV") =#> \case ("1", "conn1", INV {}) -> True; _ -> False client #:# "nothing should be delivered to client before the server is killed" killThread server client <# ("", "conn1", DOWN)@@ -250,20 +327,20 @@ 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)- ("", _, Right (REQ connId "info2")) <- (h1 <#:)- h1 #: ("c3", name2, "ACPT " <> connId <> " 5\ninfo1") #> ("c3", name2, OK)+ ("c1", _, Right (INV cReq)) <- h1 #: ("c1", name2, "NEW INV")+ let cReq' = serializeConnReq cReq+ h2 #: ("c2", name1, "JOIN " <> cReq' <> " 5\ninfo2") #> ("c2", name1, OK)+ ("", _, Right (CONF connId "info2")) <- (h1 <#:)+ h1 #: ("c3", name2, "LET " <> connId <> " 5\ninfo1") #> ("c3", name2, OK) h2 <# ("", name1, INFO "info1") h2 <# ("", name1, CON) h1 <# ("", name2, CON) -- 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 INV")+-- 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")@@ -272,7 +349,7 @@ -- pure (conn1, conn2) samplePublicKey :: ByteString-samplePublicKey = "rsa:MIIBoDANBgkqhkiG9w0BAQEFAAOCAY0AMIIBiAKCAQEAtn1NI2tPoOGSGfad0aUg0tJ0kG2nzrIPGLiz8wb3dQSJC9xkRHyzHhEE8Kmy2cM4q7rNZIlLcm4M7oXOTe7SC4x59bLQG9bteZPKqXu9wk41hNamV25PWQ4zIcIRmZKETVGbwN7jFMpH7wxLdI1zzMArAPKXCDCJ5ctWh4OWDI6OR6AcCtEj+toCI6N6pjxxn5VigJtwiKhxYpoUJSdNM60wVEDCSUrZYBAuDH8pOxPfP+Tm4sokaFDTIG3QJFzOjC+/9nW4MUjAOFll9PCp9kaEFHJ/YmOYKMWNOCCPvLS6lxA83i0UaardkNLNoFS5paWfTlroxRwOC2T6PwO2ywKBgDjtXcSED61zK1seocQMyGRINnlWdhceD669kIHju/f6kAayvYKW3/lbJNXCmyinAccBosO08/0sUxvtuniIo18kfYJE0UmP1ReCjhMP+O+yOmwZJini/QelJk/Pez8IIDDWnY1qYQsN/q7ocjakOYrpGG7mig6JMFpDJtD6istR"+samplePublicKey = "rsa:MIIBoDANBgkqhkiG9w0BAQEFAAOCAY0AMIIBiAKCAQEAtn1NI2tPoOGSGfad0aUg0tJ0kG2nzrIPGLiz8wb3dQSJC9xkRHyzHhEE8Kmy2cM4q7rNZIlLcm4M7oXOTe7SC4x59bLQG9bteZPKqXu9wk41hNamV25PWQ4zIcIRmZKETVGbwN7jFMpH7wxLdI1zzMArAPKXCDCJ5ctWh4OWDI6OR6AcCtEj-toCI6N6pjxxn5VigJtwiKhxYpoUJSdNM60wVEDCSUrZYBAuDH8pOxPfP-Tm4sokaFDTIG3QJFzOjC-_9nW4MUjAOFll9PCp9kaEFHJ_YmOYKMWNOCCPvLS6lxA83i0UaardkNLNoFS5paWfTlroxRwOC2T6PwO2ywKBgDjtXcSED61zK1seocQMyGRINnlWdhceD669kIHju_f6kAayvYKW3_lbJNXCmyinAccBosO08_0sUxvtuniIo18kfYJE0UmP1ReCjhMP-O-yOmwZJini_QelJk_Pez8IIDDWnY1qYQsN_q7ocjakOYrpGG7mig6JMFpDJtD6istR" syntaxTests :: forall c. Transport c => TProxy c -> Spec syntaxTests t = do@@ -280,17 +357,17 @@ describe "NEW" do describe "valid" do -- TODO: add tests with defined connection alias- it "without parameters" $ ("211", "", "NEW") >#>= \case ("211", _, "INV" : _) -> True; _ -> False+ it "with correct parameter" $ ("211", "", "NEW INV") >#>= \case ("211", _, "INV" : _) -> True; _ -> False describe "invalid" do -- TODO: add tests with defined connection alias- it "with parameters" $ ("222", "", "NEW hi") >#> ("222", "", "ERR CMD SYNTAX")+ it "with incorrect parameter" $ ("222", "", "NEW hi") >#> ("222", "", "ERR CMD SYNTAX") describe "JOIN" do describe "valid" 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/invitation#/?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")
+ tests/AgentTests/ConnectionRequestTests.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}++module AgentTests.ConnectionRequestTests where++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++connectionRequest :: AConnectionRequest+connectionRequest =+ ACR SCMInvitation . CRInvitation $+ ConnReqData+ { crScheme = appServer,+ crSmpQueues = [queue],+ crEncryptKey = reservedServerKey+ }++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 connectionRequest+ `shouldBe` "https://simplex.chat/invitation#/?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+ parseAll connReqP "https://simplex.chat/invitation#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F1234-w%3D%3D%23&e2e=rsa%3AMBowDQYJKoZIhvcNAQEBBQADCQAwBgIBAAIBAA%3D%3D"+ `shouldBe` Right connectionRequest
tests/AgentTests/FunctionalAPITests.hs view
@@ -53,10 +53,10 @@ alice <- getSMPAgentClient cfg bob <- getSMPAgentClient cfg {dbFile = testDB2} Right () <- runExceptT $ do- (bobId, qInfo) <- createConnection alice+ (bobId, qInfo) <- createConnection alice SCMInvitation aliceId <- joinConnection bob qInfo "bob's connInfo"- ("", _, REQ confId "bob's connInfo") <- get alice- acceptConnection alice bobId confId "alice's connInfo"+ ("", _, CONF confId "bob's connInfo") <- get alice+ allowConnection alice bobId confId "alice's connInfo" get alice ##> ("", bobId, CON) get bob ##> ("", aliceId, INFO "alice's connInfo") get bob ##> ("", aliceId, CON)@@ -96,13 +96,13 @@ alice <- getSMPAgentClient cfg bob <- getSMPAgentClient cfg {dbFile = testDB2} Right () <- runExceptT $ do- (bobId, qInfo) <- createConnection alice+ (bobId, cReq) <- createConnection alice SCMInvitation disconnectAgentClient alice- aliceId <- joinConnection bob qInfo "bob's connInfo"+ aliceId <- joinConnection bob cReq "bob's connInfo" alice' <- liftIO $ getSMPAgentClient cfg subscribeConnection alice' bobId- ("", _, REQ confId "bob's connInfo") <- get alice'- acceptConnection alice' bobId confId "alice's connInfo"+ ("", _, CONF confId "bob's connInfo") <- get alice'+ allowConnection alice' bobId confId "alice's connInfo" get alice' ##> ("", bobId, CON) get bob ##> ("", aliceId, INFO "alice's connInfo") get bob ##> ("", aliceId, CON)@@ -114,11 +114,11 @@ alice <- getSMPAgentClient cfg bob <- getSMPAgentClient cfg {dbFile = testDB2} Right () <- runExceptT $ do- (bobId, qInfo) <- createConnection alice+ (bobId, qInfo) <- createConnection alice SCMInvitation aliceId <- joinConnection bob qInfo "bob's connInfo" disconnectAgentClient bob- ("", _, REQ confId "bob's connInfo") <- get alice- acceptConnection alice bobId confId "alice's connInfo"+ ("", _, CONF confId "bob's connInfo") <- get alice+ allowConnection alice bobId confId "alice's connInfo" bob' <- liftIO $ getSMPAgentClient cfg {dbFile = testDB2} subscribeConnection bob' aliceId get alice ##> ("", bobId, CON)@@ -135,14 +135,14 @@ alice <- getSMPAgentClient cfg bob <- getSMPAgentClient cfg {dbFile = testDB2} Right () <- runExceptT $ do- (bobId, qInfo) <- createConnection alice+ (bobId, cReq) <- createConnection alice SCMInvitation disconnectAgentClient alice- aliceId <- joinConnection bob qInfo "bob's connInfo"+ aliceId <- joinConnection bob cReq "bob's connInfo" disconnectAgentClient bob alice' <- liftIO $ getSMPAgentClient cfg subscribeConnection alice' bobId- ("", _, REQ confId "bob's connInfo") <- get alice'- acceptConnection alice' bobId confId "alice's connInfo"+ ("", _, CONF confId "bob's connInfo") <- get alice'+ allowConnection alice' bobId confId "alice's connInfo" bob' <- liftIO $ getSMPAgentClient cfg {dbFile = testDB2} subscribeConnection bob' aliceId get alice' ##> ("", bobId, CON)
tests/AgentTests/SQLiteTests.hs view
@@ -114,7 +114,7 @@ testConcurrentWrites = it "should complete multiple concurrent write transactions w/t sqlite busy errors" $ \(s1, s2) -> do g <- newTVarIO =<< drgNew- _ <- runExceptT $ createRcvConn s1 g cData1 rcvQueue1+ _ <- runExceptT $ createRcvConn s1 g cData1 rcvQueue1 SCMInvitation let ConnData {connId} = cData1 concurrently_ (runTest s1 connId) (runTest s2 connId) where@@ -176,7 +176,7 @@ testCreateRcvConn = it "should create RcvConnection and add SndQueue" $ \store -> do g <- newTVarIO =<< drgNew- createRcvConn store g cData1 rcvQueue1+ createRcvConn store g cData1 rcvQueue1 SCMInvitation `returnsResult` "conn1" getConn store "conn1" `returnsResult` SomeConn SCRcv (RcvConnection cData1 rcvQueue1)@@ -189,7 +189,7 @@ testCreateRcvConnRandomId = it "should create RcvConnection and add SndQueue with random ID" $ \store -> do g <- newTVarIO =<< drgNew- Right connId <- runExceptT $ createRcvConn store g cData1 {connId = ""} rcvQueue1+ Right connId <- runExceptT $ createRcvConn store g cData1 {connId = ""} rcvQueue1 SCMInvitation getConn store connId `returnsResult` SomeConn SCRcv (RcvConnection cData1 {connId} rcvQueue1) upgradeRcvConnToDuplex store connId sndQueue1@@ -201,8 +201,8 @@ testCreateRcvConnDuplicate = it "should throw error on attempt to create duplicate RcvConnection" $ \store -> do g <- newTVarIO =<< drgNew- _ <- runExceptT $ createRcvConn store g cData1 rcvQueue1- createRcvConn store g cData1 rcvQueue1+ _ <- runExceptT $ createRcvConn store g cData1 rcvQueue1 SCMInvitation+ createRcvConn store g cData1 rcvQueue1 SCMInvitation `throwsError` SEConnDuplicate testCreateSndConn :: SpecWith SQLiteStore@@ -242,7 +242,7 @@ testGetAllConnIds = it "should get all conn aliases" $ \store -> do g <- newTVarIO =<< drgNew- _ <- runExceptT $ createRcvConn store g cData1 rcvQueue1+ _ <- runExceptT $ createRcvConn store g cData1 rcvQueue1 SCMInvitation _ <- runExceptT $ createSndConn store g cData1 {connId = "conn2"} sndQueue1 getAllConnIds store `returnsResult` ["conn1" :: ConnId, "conn2" :: ConnId]@@ -253,7 +253,7 @@ let smpServer = SMPServer "smp.simplex.im" (Just "5223") testKeyHash let recipientId = "1234" g <- newTVarIO =<< drgNew- _ <- runExceptT $ createRcvConn store g cData1 rcvQueue1+ _ <- runExceptT $ createRcvConn store g cData1 rcvQueue1 SCMInvitation getRcvConn store smpServer recipientId `returnsResult` SomeConn SCRcv (RcvConnection cData1 rcvQueue1) @@ -261,7 +261,7 @@ testDeleteRcvConn = it "should create RcvConnection and delete it" $ \store -> do g <- newTVarIO =<< drgNew- _ <- runExceptT $ createRcvConn store g cData1 rcvQueue1+ _ <- runExceptT $ createRcvConn store g cData1 rcvQueue1 SCMInvitation getConn store "conn1" `returnsResult` SomeConn SCRcv (RcvConnection cData1 rcvQueue1) deleteConn store "conn1"@@ -287,7 +287,7 @@ testDeleteDuplexConn = it "should create DuplexConnection and delete it" $ \store -> do g <- newTVarIO =<< drgNew- _ <- runExceptT $ createRcvConn store g cData1 rcvQueue1+ _ <- runExceptT $ createRcvConn store g cData1 rcvQueue1 SCMInvitation _ <- runExceptT $ upgradeRcvConnToDuplex store "conn1" sndQueue1 getConn store "conn1" `returnsResult` SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 sndQueue1)@@ -321,7 +321,7 @@ testUpgradeSndConnToDuplex = it "should throw error on attempt to add RcvQueue to RcvConnection or DuplexConnection" $ \store -> do g <- newTVarIO =<< drgNew- _ <- runExceptT $ createRcvConn store g cData1 rcvQueue1+ _ <- runExceptT $ createRcvConn store g cData1 rcvQueue1 SCMInvitation let anotherRcvQueue = RcvQueue { server = SMPServer "smp.simplex.im" (Just "5223") testKeyHash,@@ -342,7 +342,7 @@ testSetRcvQueueStatus = it "should update status of RcvQueue" $ \store -> do g <- newTVarIO =<< drgNew- _ <- runExceptT $ createRcvConn store g cData1 rcvQueue1+ _ <- runExceptT $ createRcvConn store g cData1 rcvQueue1 SCMInvitation getConn store "conn1" `returnsResult` SomeConn SCRcv (RcvConnection cData1 rcvQueue1) setRcvQueueStatus store rcvQueue1 Confirmed@@ -366,7 +366,7 @@ testSetQueueStatusDuplex = it "should update statuses of RcvQueue and SndQueue in DuplexConnection" $ \store -> do g <- newTVarIO =<< drgNew- _ <- runExceptT $ createRcvConn store g cData1 rcvQueue1+ _ <- runExceptT $ createRcvConn store g cData1 rcvQueue1 SCMInvitation _ <- runExceptT $ upgradeRcvConnToDuplex store "conn1" sndQueue1 getConn store "conn1" `returnsResult` SomeConn SCDuplex (DuplexConnection cData1 rcvQueue1 sndQueue1)@@ -426,7 +426,7 @@ it "should reserve internal ids and create a RcvMsg" $ \st -> do g <- newTVarIO =<< drgNew let ConnData {connId} = cData1- _ <- runExceptT $ createRcvConn st g cData1 rcvQueue1+ _ <- runExceptT $ createRcvConn st g cData1 rcvQueue1 SCMInvitation -- TODO getMsg to check message testCreateRcvMsg' st 0 "" connId $ mkRcvMsgData (InternalId 1) (InternalRcvId 1) 1 "1" "hash_dummy" testCreateRcvMsg' st 1 "hash_dummy" connId $ mkRcvMsgData (InternalId 2) (InternalRcvId 2) 2 "2" "new_hash_dummy"@@ -464,7 +464,7 @@ it "should create multiple RcvMsg and SndMsg, correctly ordering internal Ids and returning previous state" $ \store -> do g <- newTVarIO =<< drgNew let ConnData {connId} = cData1- _ <- runExceptT $ createRcvConn store g cData1 rcvQueue1+ _ <- runExceptT $ createRcvConn store g cData1 rcvQueue1 SCMInvitation _ <- runExceptT $ upgradeRcvConnToDuplex store "conn1" sndQueue1 testCreateRcvMsg' store 0 "" connId $ mkRcvMsgData (InternalId 1) (InternalRcvId 1) 1 "1" "rcv_hash_1" testCreateRcvMsg' store 1 "rcv_hash_1" connId $ mkRcvMsgData (InternalId 2) (InternalRcvId 2) 2 "2" "rcv_hash_2"
tests/SMPAgentClient.hs view
@@ -189,7 +189,7 @@ testSMPAgentClientOn port' client = do runTransportClient agentTestHost port' $ \h -> do line <- liftIO $ getLn h- if line == "Welcome to SMP v0.4.1 agent"+ if line == "Welcome to SMP agent v" <> currentSMPVersionStr then client h else error $ "wrong welcome message: " <> B.unpack line