diff --git a/apps/smp-agent/Main.hs b/apps/smp-agent/Main.hs index f77eb0527..c27a77717 100644 --- a/apps/smp-agent/Main.hs +++ b/apps/smp-agent/Main.hs @@ -1,8 +1,10 @@ {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} module Main where import Control.Logger.Simple +import qualified Data.List.NonEmpty as L import Simplex.Messaging.Agent (runSMPAgent) import Simplex.Messaging.Agent.Env.SQLite import Simplex.Messaging.Client (smpDefaultConfig) @@ -11,6 +13,7 @@ cfg :: AgentConfig cfg = AgentConfig { tcpPort = "5224", + smpServers = L.fromList ["localhost:5223#KXNE1m2E1m0lm92WGKet9CL6+lO742Vy5G6nsrkvgs8="], rsaKeySize = 2048 `div` 8, connIdBytes = 12, tbqSize = 16, diff --git a/package.yaml b/package.yaml index 00fdfb021..04bad812d 100644 --- a/package.yaml +++ b/package.yaml @@ -31,6 +31,7 @@ dependencies: - network == 3.1.* - network-transport == 0.5.* - QuickCheck == 2.13.* + - random == 1.1.* - simple-logger == 0.1.* - sqlite-simple == 0.4.* - stm diff --git a/protocol/agent-protocol.md b/protocol/agent-protocol.md index 8958b9a52..94ee8d914 100644 --- a/protocol/agent-protocol.md +++ b/protocol/agent-protocol.md @@ -4,6 +4,7 @@ - [Abstract](#abstract) - [SMP agent](#smp-agent) +- [SMP servers management](#smp-servers-management) - [SMP agent protocol components](#smp-agent-protocol-components) - [Duplex connection procedure](#duplex-connection-procedure) - [Communication between SMP agents](#communication-between-smp-agents) @@ -29,7 +30,7 @@ The purpose of SMP agent protocol is to define the syntax and the semantics of communications between the client and the agent that connects to [SMP](./simplex-messaging.md) servers. It provides: -- convenient protocol to create and manage a bi-directional (duplex) connection to the users of SMP agents consisting of two separate unidirectional (simplex) SMP queues, abstracting away multiple steps required to establish bi-directional connections. +- convenient protocol to create and manage bi-directional (duplex) connections between the users of SMP agents consisting of two (or more) separate unidirectional (simplex) SMP queues, abstracting away multiple steps required to establish bi-directional connections and any information about the servers location from the users of the protocol. - management of E2E encryption between SMP agents, generating ephemeral RSA keys for each connection. - SMP command authentication on SMP servers, generating ephemeral RSA keys for each SMP queue. - TCP transport handshake and encryption with SMP servers. @@ -49,6 +50,12 @@ SMP agent is a client-side process or library that communicates via SMP servers The agent must have a persistent storage to manage the states of known connections and of the client-side information of two SMP queues that each connection consists of, and also the buffer of the most recent messages. The number of the messages that should be stored is implementation specific, depending on the error management approach that the agent implements; at the very least the agent must store the hash and id of the last received message. +## SMP servers management + +SMP agent protocol commands do not contain SMP servers that the agent will use to establish the connections between their users. The servers are part of the agent configuration and can be dynamically added and removed by the agent implementation: +- by the client applications via any API that is outside of scope of this protocol. +- by the agents themselves based on servers availability and latency. + ## SMP agent protocol components SMP agent protocol has 3 main parts: @@ -189,8 +196,7 @@ agentCommand = (userCmd / agentMsg) CRLF userCmd = newCmd / joinCmd / subscribeCmd / sendCmd / acknowledgeCmd / suspendCmd / deleteCmd agentMsg = invitation / connected / unsubscribed / message / sent / received / ok / error -newCmd = %s"NEW" SP [SP %s"NO_ACK"] ; `smpServer` is the same as in out-of-band message, see SMP protocol -; response is `invitation` or `error` +newCmd = %s"NEW" [SP %s"NO_ACK"] ; response is `invitation` or `error` invitation = %s"INV" SP ; `queueInfo` is the same as in out-of-band message, see SMP protocol @@ -202,8 +208,8 @@ unsubscribed = %s"END" ; when another agent (or another client of the same agent) ; subscribes to the same SMP queue on the server -joinCmd = %s"JOIN" SP [replyJoin] [SP %s"NO_ACK"] ; `queueInfo` is the same as in out-of-band message, see SMP protocol -replyJoin = SP ( / %s"NO_REPLY") ; reply queue SMP server, by default server from queueInfo is used +joinCmd = %s"JOIN" SP [SP %s"NO_REPLY"] [SP %s"NO_ACK"] +; `queueInfo` is the same as in out-of-band message, see SMP protocol ; response is `connected` or `error` suspendCmd = %s"OFF" ; can be sent by either party, response `ok` or `error` diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index e5b214033..b3e1a80b7 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -16,6 +16,7 @@ module Simplex.Messaging.Agent ) where +import Control.Concurrent.STM (stateTVar) import Control.Logger.Simple (logInfo, showText) import Control.Monad.Except import Control.Monad.IO.Unlift (MonadUnliftIO) @@ -23,6 +24,8 @@ import Control.Monad.Reader import Crypto.Random (MonadRandom) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as L import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8) import Data.Time.Clock @@ -39,6 +42,7 @@ import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Transport (putLn, runTCPServer) import Simplex.Messaging.Util (bshow) import System.IO (Handle) +import System.Random (randomR) import UnliftIO.Async (race_) import qualified UnliftIO.Exception as E import UnliftIO.STM @@ -51,7 +55,7 @@ runSMPAgentBlocking started cfg@AgentConfig {tcpPort} = runReaderT smpAgent =<< where smpAgent :: (MonadUnliftIO m', MonadReader Env m') => m' () smpAgent = runTCPServer started tcpPort $ \h -> do - liftIO $ putLn h "Welcome to SMP v0.2.0 agent" + liftIO $ putLn h "Welcome to SMP v0.3.0 agent" c <- getSMPAgentClient logConnection c True race_ (connectClient h c) (runSMPAgentClient c) @@ -127,7 +131,7 @@ withStore action = do processCommand :: forall m. AgentMonad m => AgentClient -> SQLiteStore -> ATransmission 'Client -> m () processCommand c@AgentClient {sndQ} st (corrId, connAlias, cmd) = case cmd of - NEW smpServer -> createNewConnection smpServer + NEW -> createNewConnection JOIN smpQueueInfo replyMode -> joinConnection smpQueueInfo replyMode SUB -> subscribeConnection connAlias SUBALL -> subscribeAll @@ -135,25 +139,32 @@ processCommand c@AgentClient {sndQ} st (corrId, connAlias, cmd) = OFF -> suspendConnection DEL -> deleteConnection where - createNewConnection :: SMPServer -> m () - createNewConnection server = do + createNewConnection :: m () + createNewConnection = do -- TODO create connection alias if not passed -- make connAlias Maybe? - (rq, qInfo) <- newReceiveQueue c server connAlias + srv <- getSMPServer + (rq, qInfo) <- newReceiveQueue c srv connAlias withStore $ createRcvConn st rq respond $ INV qInfo + getSMPServer :: m SMPServer + getSMPServer = + asks (smpServers . config) >>= \case + srv :| [] -> pure srv + servers -> do + gen <- asks randomServer + i <- atomically . stateTVar gen $ randomR (0, L.length servers - 1) + pure $ servers L.!! i + joinConnection :: SMPQueueInfo -> ReplyMode -> m () - joinConnection qInfo@(SMPQueueInfo srv _ _) replyMode = do + joinConnection qInfo (ReplyMode replyMode) = do -- TODO create connection alias if not passed -- make connAlias Maybe? (sq, senderKey, verifyKey) <- newSendQueue qInfo connAlias withStore $ createSndConn st sq connectToSendQueue c st sq senderKey verifyKey - case replyMode of - ReplyOn -> sendReplyQInfo srv sq - ReplyVia srv' -> sendReplyQInfo srv' sq - ReplyOff -> return () + when (replyMode == On) $ createReplyQueue sq respond CON subscribeConnection :: ConnAlias -> m () @@ -216,8 +227,9 @@ processCommand c@AgentClient {sndQ} st (corrId, connAlias, cmd) = removeSubscription c connAlias delConn - sendReplyQInfo :: SMPServer -> SndQueue -> m () - sendReplyQInfo srv sq = do + createReplyQueue :: SndQueue -> m () + createReplyQueue sq = do + srv <- getSMPServer (rq, qInfo) <- newReceiveQueue c srv connAlias withStore $ upgradeSndConnToDuplex st connAlias rq senderTimestamp <- liftIO getCurrentTime diff --git a/src/Simplex/Messaging/Agent/Env/SQLite.hs b/src/Simplex/Messaging/Agent/Env/SQLite.hs index b14bfb4a6..dd96d9b5c 100644 --- a/src/Simplex/Messaging/Agent/Env/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Env/SQLite.hs @@ -7,14 +7,18 @@ module Simplex.Messaging.Agent.Env.SQLite where import Control.Monad.IO.Unlift import Crypto.Random +import Data.List.NonEmpty (NonEmpty) import Network.Socket import Numeric.Natural import Simplex.Messaging.Agent.Store.SQLite +import Simplex.Messaging.Agent.Transmission (SMPServer) import Simplex.Messaging.Client +import System.Random (StdGen, newStdGen) import UnliftIO.STM data AgentConfig = AgentConfig { tcpPort :: ServiceName, + smpServers :: NonEmpty SMPServer, rsaKeySize :: Int, connIdBytes :: Int, tbqSize :: Natural, @@ -26,15 +30,17 @@ data Env = Env { config :: AgentConfig, idsDrg :: TVar ChaChaDRG, clientCounter :: TVar Int, - reservedMsgSize :: Int + reservedMsgSize :: Int, + randomServer :: TVar StdGen } newSMPAgentEnv :: (MonadUnliftIO m, MonadRandom m) => AgentConfig -> m Env newSMPAgentEnv config = do - idsDrg <- drgNew >>= newTVarIO + idsDrg <- newTVarIO =<< drgNew _ <- createSQLiteStore $ dbFile config clientCounter <- newTVarIO 0 - return Env {config, idsDrg, clientCounter, reservedMsgSize} + randomServer <- newTVarIO =<< liftIO newStdGen + return Env {config, idsDrg, clientCounter, reservedMsgSize, randomServer} where -- 1st rsaKeySize is used by the RSA signature in each command, -- 2nd - by encrypted message body header diff --git a/src/Simplex/Messaging/Agent/Transmission.hs b/src/Simplex/Messaging/Agent/Transmission.hs index eb504dd1a..247a321ef 100644 --- a/src/Simplex/Messaging/Agent/Transmission.hs +++ b/src/Simplex/Messaging/Agent/Transmission.hs @@ -23,6 +23,7 @@ import qualified Data.ByteString.Char8 as B import Data.Functor (($>)) import Data.Int (Int64) import Data.Kind (Type) +import Data.String (IsString (..)) import Data.Time.Clock (UTCTime) import Data.Time.ISO8601 import Data.Type.Equality @@ -75,7 +76,7 @@ data ACmd = forall p. ACmd (SAParty p) (ACommand p) deriving instance Show ACmd data ACommand (p :: AParty) where - NEW :: SMPServer -> ACommand Client -- response INV + NEW :: ACommand Client -- response INV INV :: SMPQueueInfo -> ACommand Agent JOIN :: SMPQueueInfo -> ReplyMode -> ACommand Client -- response OK CON :: ACommand Agent -- notification that connection is established @@ -170,7 +171,7 @@ agentMessageP = a_msg = do size :: Int <- A.decimal <* A.endOfLine A_MSG <$> A.take size <* A.endOfLine - ackMode = " NO_ACK" $> AckMode Off <|> pure (AckMode On) + ackMode = AckMode <$> (" NO_ACK" $> Off <|> pure On) smpQueueInfoP :: Parser SMPQueueInfo smpQueueInfoP = @@ -179,7 +180,7 @@ smpQueueInfoP = smpServerP :: Parser SMPServer smpServerP = SMPServer <$> server <*> optional port <*> optional kHash where - server = B.unpack <$> A.takeTill (A.inClass ":# ") + server = B.unpack <$> A.takeWhile1 (A.notInClass ":# ") port = A.char ':' *> (B.unpack <$> A.takeWhile1 A.isDigit) kHash = C.KeyHash <$> (A.char '#' *> base64P) @@ -207,18 +208,21 @@ data SMPServer = SMPServer } deriving (Eq, Ord, Show) +instance IsString SMPServer where + fromString = parseString . parseAll $ smpServerP + type ConnAlias = ByteString type OtherPartyId = Encoded -data Mode = On | Off deriving (Eq, Show, Read) +data OnOff = On | Off deriving (Eq, Show, Read) -newtype AckMode = AckMode Mode deriving (Eq, Show) +newtype AckMode = AckMode OnOff deriving (Eq, Show) data SMPQueueInfo = SMPQueueInfo SMPServer SMP.SenderId EncryptionKey deriving (Eq, Show) -data ReplyMode = ReplyOff | ReplyOn | ReplyVia SMPServer deriving (Eq, Show) +newtype ReplyMode = ReplyMode OnOff deriving (Eq, Show) type EncryptionKey = C.PublicKey @@ -294,7 +298,7 @@ instance Arbitrary SMPAgentError where arbitrary = genericArbitraryU commandP :: Parser ACmd commandP = - "NEW " *> newCmd + "NEW" $> ACmd SClient NEW <|> "INV " *> invResp <|> "JOIN " *> joinCmd <|> "SUB" $> ACmd SClient SUB @@ -309,7 +313,6 @@ commandP = <|> "CON" $> ACmd SAgent CON <|> "OK" $> ACmd SAgent OK where - newCmd = ACmd SClient . NEW <$> smpServerP invResp = ACmd SAgent . INV <$> smpQueueInfoP joinCmd = ACmd SClient <$> (JOIN <$> smpQueueInfoP <*> replyMode) sendCmd = ACmd SClient . SEND <$> A.takeByteString @@ -321,10 +324,7 @@ commandP = senderMeta <- "S=" *> partyMeta A.decimal msgBody <- A.takeByteString return $ ACmd SAgent MSG {recipientMeta, brokerMeta, senderMeta, msgIntegrity, msgBody} - replyMode = - " NO_REPLY" $> ReplyOff - <|> A.space *> (ReplyVia <$> smpServerP) - <|> pure ReplyOn + replyMode = ReplyMode <$> (" NO_REPLY" $> Off <|> pure On) partyMeta idParser = (,) <$> idParser <* "," <*> tsISO8601P <* A.space agentError = ACmd SAgent . ERR <$> agentErrorTypeP @@ -342,7 +342,7 @@ parseCommand = parse commandP $ CMD SYNTAX serializeCommand :: ACommand p -> ByteString serializeCommand = \case - NEW srv -> "NEW " <> serializeServer srv + NEW -> "NEW" INV qInfo -> "INV " <> serializeSmpQueueInfo qInfo JOIN qInfo rMode -> "JOIN " <> serializeSmpQueueInfo qInfo <> replyMode rMode SUB -> "SUB" @@ -367,9 +367,8 @@ serializeCommand = \case where replyMode :: ReplyMode -> ByteString replyMode = \case - ReplyOff -> " NO_REPLY" - ReplyVia srv -> " " <> serializeServer srv - ReplyOn -> "" + ReplyMode Off -> " NO_REPLY" + ReplyMode On -> "" showTs :: UTCTime -> ByteString showTs = B.pack . formatISO8601Millis @@ -433,7 +432,7 @@ tGet party h = liftIO (tGetRaw h) >>= tParseLoadBody tConnAlias :: ARawTransmission -> ACommand p -> Either AgentErrorType (ACommand p) tConnAlias (_, connAlias, _) cmd = case cmd of -- NEW and JOIN have optional connAlias - NEW _ -> Right cmd + NEW -> Right cmd JOIN _ _ -> Right cmd -- ERROR response does not always have connAlias ERR _ -> Right cmd diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index 8def2ab8a..549daf920 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -244,9 +244,8 @@ sendSMPCommand SMPClient {sndQ, sentCommands, clientCorrId, tcpTimeout} pKey qId getNextCorrId :: STM CorrId getNextCorrId = do - i <- (+ 1) <$> readTVar clientCorrId - writeTVar clientCorrId i - return . CorrId $ bshow i + i <- stateTVar clientCorrId $ \i -> (i, i + 1) + pure . CorrId $ bshow i signTransmission :: ByteString -> ExceptT SMPClientError IO SignedRawTransmission signTransmission t = case pKey of diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs index 05bd4fbc8..bbe4f57f3 100644 --- a/src/Simplex/Messaging/Crypto.hs +++ b/src/Simplex/Messaging/Crypto.hs @@ -80,7 +80,7 @@ import Data.X509 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) +import Simplex.Messaging.Parsers (base64P, blobFieldParser, parseAll, parseString) import Simplex.Messaging.Util (liftEitherError, (<$?>)) newtype PublicKey = PublicKey {rsaPublicKey :: R.PublicKey} deriving (Eq, Show) @@ -111,9 +111,6 @@ instance IsString FullPrivateKey where instance IsString PublicKey where fromString = parseString (decode >=> decodePubKey) -parseString :: (ByteString -> Either String a) -> (String -> a) -parseString parse = either error id . parse . B.pack - instance ToField SafePrivateKey where toField = toField . encodePrivKey instance ToField PublicKey where toField = toField . encodePubKey diff --git a/src/Simplex/Messaging/Parsers.hs b/src/Simplex/Messaging/Parsers.hs index 10ef29257..2b9522e3e 100644 --- a/src/Simplex/Messaging/Parsers.hs +++ b/src/Simplex/Messaging/Parsers.hs @@ -50,6 +50,9 @@ parseRead2 = parseRead $ do w2 <- A.takeTill (== ' ') pure $ w1 <> " " <> w2 +parseString :: (ByteString -> Either String a) -> (String -> a) +parseString p = either error id . p . B.pack + blobFieldParser :: Typeable k => Parser k -> FieldParser k blobFieldParser p = \case f@(Field (SQLBlob b) _) -> diff --git a/tests/AgentTests.hs b/tests/AgentTests.hs index 6a1754f13..e4d01ec96 100644 --- a/tests/AgentTests.hs +++ b/tests/AgentTests.hs @@ -13,7 +13,6 @@ import Control.Concurrent import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import SMPAgentClient -import SMPClient (testKeyHashStr) import Simplex.Messaging.Agent.Transmission import Simplex.Messaging.Protocol (ErrorType (..), MsgBody) import System.IO (Handle) @@ -26,12 +25,14 @@ agentTests = do describe "SMP agent protocol syntax" syntaxTests describe "Establishing duplex connection" do it "should connect via one server and one agent" $ - smpAgentTest2_1 testDuplexConnection + smpAgentTest2_1_1 testDuplexConnection it "should connect via one server and 2 agents" $ - smpAgentTest2 testDuplexConnection + smpAgentTest2_2_1 testDuplexConnection + it "should connect via 2 servers and 2 agents" $ + smpAgentTest2_2_2 testDuplexConnection describe "Connection subscriptions" do - xit "should connect via one server and one agent" $ - smpAgentTest3_1 testSubscription + it "should connect via one server and one agent" $ + smpAgentTest3_1_1 testSubscription it "should send notifications to client when server disconnects" $ smpAgentServerTest testSubscrNotification @@ -84,7 +85,7 @@ pattern Msg msgBody <- MSG {msgBody, msgIntegrity = MsgOk} testDuplexConnection :: Handle -> Handle -> IO () testDuplexConnection alice bob = do - ("1", "bob", Right (INV qInfo)) <- alice #: ("1", "bob", "NEW localhost:5000") + ("1", "bob", Right (INV qInfo)) <- alice #: ("1", "bob", "NEW") let qInfo' = serializeSmpQueueInfo qInfo bob #: ("11", "alice", "JOIN " <> qInfo') #> ("11", "alice", CON) alice <# ("", "bob", CON) @@ -103,17 +104,14 @@ testDuplexConnection alice bob = do testSubscription :: Handle -> Handle -> Handle -> IO () testSubscription alice1 alice2 bob = do - ("1", "bob", Right (INV qInfo)) <- alice1 #: ("1", "bob", "NEW localhost:5000") + ("1", "bob", Right (INV qInfo)) <- alice1 #: ("1", "bob", "NEW") let qInfo' = serializeSmpQueueInfo qInfo bob #: ("11", "alice", "JOIN " <> qInfo') #> ("11", "alice", CON) bob #: ("12", "alice", "SEND 5\nhello") =#> \case ("12", "alice", SENT _) -> True; _ -> False bob #: ("13", "alice", "SEND 11\nhello again") =#> \case ("13", "alice", SENT _) -> True; _ -> False alice1 <# ("", "bob", CON) alice1 <#= \case ("", "bob", Msg "hello") -> True; _ -> False - -- alice1 <#= \case ("", "bob", Msg "hello again") -> True; _ -> False - t <- tGet SAgent alice1 - print t - t `shouldSatisfy` (\case ("", "bob", Msg "hello again") -> True; _ -> False) . correctTransmission + alice1 <#= \case ("", "bob", Msg "hello again") -> True; _ -> False alice2 #: ("21", "bob", "SUB") #> ("21", "bob", OK) alice1 <# ("", "bob", END) bob #: ("14", "alice", "SEND 2\nhi") =#> \case ("14", "alice", SENT _) -> True; _ -> False @@ -122,7 +120,7 @@ testSubscription alice1 alice2 bob = do testSubscrNotification :: (ThreadId, ThreadId) -> Handle -> IO () testSubscrNotification (server, _) client = do - client #: ("1", "conn1", "NEW localhost:5000") =#> \case ("1", "conn1", INV _) -> True; _ -> False + client #: ("1", "conn1", "NEW") =#> \case ("1", "conn1", INV _) -> True; _ -> False client #:# "nothing should be delivered to client before the server is killed" killThread server client <# ("", "conn1", END) @@ -137,15 +135,10 @@ syntaxTests = 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 - xit "only server" $ ("211", "", "NEW localhost") >#>= \case ("211", "", "INV" : _) -> True; _ -> False - it "with port" $ ("212", "", "NEW localhost:5000") >#>= \case ("212", "", "INV" : _) -> True; _ -> False - xit "with keyHash" $ ("213", "", "NEW localhost#" <> testKeyHashStr) >#>= \case ("213", "", "INV" : _) -> True; _ -> False - it "with port and keyHash" $ ("214", "", "NEW localhost:5000#" <> testKeyHashStr) >#>= \case ("214", "", "INV" : _) -> True; _ -> False + xit "without parameters" $ ("211", "", "NEW") >#>= \case ("211", "", "INV" : _) -> True; _ -> False describe "invalid" do -- TODO: add tests with defined connection alias - it "no parameters" $ ("221", "", "NEW") >#> ("221", "", "ERR CMD SYNTAX") - it "many parameters" $ ("222", "", "NEW localhost:5000 hi") >#> ("222", "", "ERR CMD SYNTAX") - it "invalid server keyHash" $ ("223", "", "NEW localhost:5000#1") >#> ("223", "", "ERR CMD SYNTAX") + it "with parameters" $ ("222", "", "NEW hi") >#> ("222", "", "ERR CMD SYNTAX") describe "JOIN" do describe "valid" do diff --git a/tests/SMPAgentClient.hs b/tests/SMPAgentClient.hs index 9bf0bf187..9c4d76528 100644 --- a/tests/SMPAgentClient.hs +++ b/tests/SMPAgentClient.hs @@ -8,8 +8,17 @@ module SMPAgentClient where import Control.Monad.IO.Unlift import Crypto.Random +import qualified Data.List.NonEmpty as L import Network.Socket (HostName, ServiceName) -import SMPClient (serverBracket, testPort, withSmpServer, withSmpServerThreadOn) +import SMPClient + ( serverBracket, + testKeyHash, + testPort, + testPort2, + withSmpServer, + withSmpServerOn, + withSmpServerThreadOn, + ) import Simplex.Messaging.Agent (runSMPAgentBlocking) import Simplex.Messaging.Agent.Env.SQLite import Simplex.Messaging.Agent.Transmission @@ -24,13 +33,13 @@ agentTestHost :: HostName agentTestHost = "localhost" agentTestPort :: ServiceName -agentTestPort = "5001" +agentTestPort = "5010" agentTestPort2 :: ServiceName agentTestPort2 = "5011" agentTestPort3 :: ServiceName -agentTestPort3 = "5021" +agentTestPort3 = "5012" testDB :: String testDB = "tests/tmp/smp-agent.test.protocol.db" @@ -50,18 +59,18 @@ runSmpAgentTest test = withSmpServer . withSmpAgent $ testSMPAgentClient test runSmpAgentServerTest :: (MonadUnliftIO m, MonadRandom m) => ((ThreadId, ThreadId) -> Handle -> m a) -> m a runSmpAgentServerTest test = withSmpServerThreadOn testPort $ - \server -> withSmpAgentThreadOn (agentTestPort, testDB) $ + \server -> withSmpAgentThreadOn (agentTestPort, testPort, testDB) $ \agent -> testSMPAgentClient $ test (server, agent) smpAgentServerTest :: ((ThreadId, ThreadId) -> Handle -> IO ()) -> Expectation smpAgentServerTest test' = runSmpAgentServerTest test' `shouldReturn` () -runSmpAgentTestN :: forall m a. (MonadUnliftIO m, MonadRandom m) => [(ServiceName, String)] -> ([Handle] -> m a) -> m a +runSmpAgentTestN :: forall m a. (MonadUnliftIO m, MonadRandom m) => [(ServiceName, ServiceName, String)] -> ([Handle] -> m a) -> m a runSmpAgentTestN agents test = withSmpServer $ run agents [] where - run :: [(ServiceName, String)] -> [Handle] -> m a + run :: [(ServiceName, ServiceName, String)] -> [Handle] -> m a run [] hs = test hs - run (a@(p, _) : as) hs = withSmpAgentOn a $ testSMPAgentClientOn p $ \h -> run as (h : hs) + run (a@(p, _, _) : as) hs = withSmpAgentOn a $ testSMPAgentClientOn p $ \h -> run as (h : hs) runSmpAgentTestN_1 :: forall m a. (MonadUnliftIO m, MonadRandom m) => Int -> ([Handle] -> m a) -> m a runSmpAgentTestN_1 nClients test = withSmpServer . withSmpAgent $ run nClients [] @@ -70,21 +79,37 @@ runSmpAgentTestN_1 nClients test = withSmpServer . withSmpAgent $ run nClients [ run 0 hs = test hs run n hs = testSMPAgentClient $ \h -> run (n - 1) (h : hs) -smpAgentTestN :: [(ServiceName, String)] -> ([Handle] -> IO ()) -> Expectation +smpAgentTestN :: [(ServiceName, ServiceName, String)] -> ([Handle] -> IO ()) -> Expectation smpAgentTestN agents test' = runSmpAgentTestN agents test' `shouldReturn` () smpAgentTestN_1 :: Int -> ([Handle] -> IO ()) -> Expectation smpAgentTestN_1 n test' = runSmpAgentTestN_1 n test' `shouldReturn` () -smpAgentTest2 :: (Handle -> Handle -> IO ()) -> Expectation -smpAgentTest2 test' = - smpAgentTestN [(agentTestPort, testDB), (agentTestPort2, testDB2)] _test +smpAgentTest2_2_2 :: (Handle -> Handle -> IO ()) -> Expectation +smpAgentTest2_2_2 test' = + withSmpServerOn testPort2 $ + smpAgentTestN + [ (agentTestPort, testPort, testDB), + (agentTestPort2, testPort2, testDB2) + ] + _test where _test [h1, h2] = test' h1 h2 _test _ = error "expected 2 handles" -smpAgentTest2_1 :: (Handle -> Handle -> IO ()) -> Expectation -smpAgentTest2_1 test' = smpAgentTestN_1 2 _test +smpAgentTest2_2_1 :: (Handle -> Handle -> IO ()) -> Expectation +smpAgentTest2_2_1 test' = + smpAgentTestN + [ (agentTestPort, testPort, testDB), + (agentTestPort2, testPort, testDB2) + ] + _test + where + _test [h1, h2] = test' h1 h2 + _test _ = error "expected 2 handles" + +smpAgentTest2_1_1 :: (Handle -> Handle -> IO ()) -> Expectation +smpAgentTest2_1_1 test' = smpAgentTestN_1 2 _test where _test [h1, h2] = test' h1 h2 _test _ = error "expected 2 handles" @@ -92,14 +117,17 @@ smpAgentTest2_1 test' = smpAgentTestN_1 2 _test smpAgentTest3 :: (Handle -> Handle -> Handle -> IO ()) -> Expectation smpAgentTest3 test' = smpAgentTestN - [(agentTestPort, testDB), (agentTestPort2, testDB2), (agentTestPort3, testDB3)] + [ (agentTestPort, testPort, testDB), + (agentTestPort2, testPort, testDB2), + (agentTestPort3, testPort, testDB3) + ] _test where _test [h1, h2, h3] = test' h1 h2 h3 _test _ = error "expected 3 handles" -smpAgentTest3_1 :: (Handle -> Handle -> Handle -> IO ()) -> Expectation -smpAgentTest3_1 test' = smpAgentTestN_1 3 _test +smpAgentTest3_1_1 :: (Handle -> Handle -> Handle -> IO ()) -> Expectation +smpAgentTest3_1_1 test' = smpAgentTestN_1 3 _test where _test [h1, h2, h3] = test' h1 h2 h3 _test _ = error "expected 3 handles" @@ -108,6 +136,7 @@ cfg :: AgentConfig cfg = AgentConfig { tcpPort = agentTestPort, + smpServers = L.fromList ["localhost:5000#KXNE1m2E1m0lm92WGKet9CL6+lO742Vy5G6nsrkvgs8="], rsaKeySize = 2048 `div` 8, connIdBytes = 12, tbqSize = 1, @@ -120,23 +149,24 @@ cfg = } } -withSmpAgentThreadOn :: (MonadUnliftIO m, MonadRandom m) => (ServiceName, String) -> (ThreadId -> m a) -> m a -withSmpAgentThreadOn (port', db') = - serverBracket - (\started -> runSMPAgentBlocking started cfg {tcpPort = port', dbFile = db'}) - (removeFile db') +withSmpAgentThreadOn :: (MonadUnliftIO m, MonadRandom m) => (ServiceName, ServiceName, String) -> (ThreadId -> m a) -> m a +withSmpAgentThreadOn (port', smpPort', db') = + let cfg' = cfg {tcpPort = port', dbFile = db', smpServers = L.fromList [SMPServer "localhost" (Just smpPort') testKeyHash]} + in serverBracket + (`runSMPAgentBlocking` cfg') + (removeFile db') -withSmpAgentOn :: (MonadUnliftIO m, MonadRandom m) => (ServiceName, String) -> m a -> m a -withSmpAgentOn (port', db') = withSmpAgentThreadOn (port', db') . const +withSmpAgentOn :: (MonadUnliftIO m, MonadRandom m) => (ServiceName, ServiceName, String) -> m a -> m a +withSmpAgentOn (port', smpPort', db') = withSmpAgentThreadOn (port', smpPort', db') . const withSmpAgent :: (MonadUnliftIO m, MonadRandom m) => m a -> m a -withSmpAgent = withSmpAgentOn (agentTestPort, testDB) +withSmpAgent = withSmpAgentOn (agentTestPort, testPort, testDB) testSMPAgentClientOn :: MonadUnliftIO m => ServiceName -> (Handle -> m a) -> m a testSMPAgentClientOn port' client = do runTCPClient agentTestHost port' $ \h -> do line <- liftIO $ getLn h - if line == "Welcome to SMP v0.2.0 agent" + if line == "Welcome to SMP v0.3.0 agent" then client h else error "not connected" diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index 00e843119..1325ac4e7 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -32,6 +32,9 @@ testHost = "localhost" testPort :: ServiceName testPort = "5000" +testPort2 :: ServiceName +testPort2 = "5001" + testKeyHashStr :: B.ByteString testKeyHashStr = "KXNE1m2E1m0lm92WGKet9CL6+lO742Vy5G6nsrkvgs8="