mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-03-30 18:35:59 +00:00
274 lines
11 KiB
Haskell
274 lines
11 KiB
Haskell
{-# LANGUAGE BlockArguments #-}
|
|
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE GADTs #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE PatternSynonyms #-}
|
|
|
|
import Data.ByteString.Base64
|
|
import Data.ByteString.Char8 (ByteString)
|
|
import qualified Data.ByteString.Char8 as B
|
|
import Data.Either
|
|
import SMPClient
|
|
import System.IO (Handle)
|
|
import System.Timeout
|
|
import Test.HUnit
|
|
import Test.Hspec
|
|
import Transmission
|
|
import Transport
|
|
|
|
(>#>) :: [RawTransmission] -> [RawTransmission] -> Expectation
|
|
commands >#> responses = smpServerTest commands `shouldReturn` responses
|
|
|
|
main :: IO ()
|
|
main = hspec do
|
|
describe "SMP syntax" syntaxTests
|
|
describe "SMP connections" do
|
|
describe "CONN and KEY commands, SEND messages" testCreateSecure
|
|
describe "CONN, OFF and DEL commands, SEND messages" testCreateDelete
|
|
describe "SMP messages" do
|
|
describe "duplex communication over 2 SMP connections" testDuplex
|
|
describe "switch subscription to another SMP connection" testSwitchSub
|
|
|
|
pattern Resp :: ConnId -> Command 'Broker -> TransmissionOrError
|
|
pattern Resp connId command = ("", (connId, Right (Cmd SBroker command)))
|
|
|
|
smpTest :: (Handle -> IO ()) -> Expectation
|
|
smpTest test' = runSmpTest test' `shouldReturn` ()
|
|
|
|
smpTestN :: Int -> ([Handle] -> IO ()) -> Expectation
|
|
smpTestN n test' = runSmpTestN n test' `shouldReturn` ()
|
|
|
|
sendRecv :: Handle -> RawTransmission -> IO TransmissionOrError
|
|
sendRecv h (sgn, cId, cmd) = tPutRaw h (fromRight "" $ decode sgn, cId, cmd) >> tGet fromServer h
|
|
|
|
(#==) :: (HasCallStack, Eq a, Show a) => (a, a) -> String -> Assertion
|
|
(actual, expected) #== message = assertEqual message expected actual
|
|
|
|
testCreateSecure :: SpecWith ()
|
|
testCreateSecure =
|
|
it "should create (CONN) and secure (KEY) connection" $
|
|
smpTest \h -> do
|
|
Resp rId1 (IDS rId sId) <- sendRecv h ("", "", "CONN 1234")
|
|
(rId1, "") #== "creates connection"
|
|
|
|
Resp sId1 ok1 <- sendRecv h ("", sId, "SEND :hello")
|
|
(ok1, OK) #== "accepts unsigned SEND"
|
|
(sId1, sId) #== "same connection ID in response 1"
|
|
|
|
Resp _ (MSG _ _ msg1) <- tGet fromServer h
|
|
(msg1, "hello") #== "delivers message"
|
|
|
|
Resp _ ok4 <- sendRecv h ("1234", rId, "ACK")
|
|
(ok4, OK) #== "replies OK when message acknowledged if no more messages"
|
|
|
|
Resp sId2 err1 <- sendRecv h ("4567", sId, "SEND :hello")
|
|
(err1, ERR AUTH) #== "rejects signed SEND"
|
|
(sId2, sId) #== "same connection ID in response 2"
|
|
|
|
Resp _ err2 <- sendRecv h ("12345678", rId, "KEY 4567")
|
|
(err2, ERR AUTH) #== "rejects KEY with wrong signature (password atm)"
|
|
|
|
Resp _ err3 <- sendRecv h ("1234", sId, "KEY 4567")
|
|
(err3, ERR AUTH) #== "rejects KEY with sender's ID"
|
|
|
|
Resp rId2 ok2 <- sendRecv h ("1234", rId, "KEY 4567")
|
|
(ok2, OK) #== "secures connection"
|
|
(rId2, rId) #== "same connection ID in response 3"
|
|
|
|
Resp _ err4 <- sendRecv h ("1234", rId, "KEY 4567")
|
|
(err4, ERR AUTH) #== "rejects KEY if already secured"
|
|
|
|
Resp _ ok3 <- sendRecv h ("4567", sId, "SEND 11\nhello again")
|
|
(ok3, OK) #== "accepts signed SEND"
|
|
|
|
Resp _ (MSG _ _ msg) <- tGet fromServer h
|
|
(msg, "hello again") #== "delivers message 2"
|
|
|
|
Resp _ ok5 <- sendRecv h ("1234", rId, "ACK")
|
|
(ok5, OK) #== "replies OK when message acknowledged 2"
|
|
|
|
Resp _ err5 <- sendRecv h ("", sId, "SEND :hello")
|
|
(err5, ERR AUTH) #== "rejects unsigned SEND"
|
|
|
|
testCreateDelete :: SpecWith ()
|
|
testCreateDelete =
|
|
it "should create (CONN), suspend (OFF) and delete (DEL) connection" $
|
|
smpTest \h -> do
|
|
Resp rId1 (IDS rId sId) <- sendRecv h ("", "", "CONN 1234")
|
|
(rId1, "") #== "creates connection"
|
|
|
|
Resp _ ok1 <- sendRecv h ("1234", rId, "KEY 4567")
|
|
(ok1, OK) #== "secures connection"
|
|
|
|
Resp _ ok2 <- sendRecv h ("4567", sId, "SEND :hello")
|
|
(ok2, OK) #== "accepts signed SEND"
|
|
|
|
Resp _ (MSG _ _ msg1) <- tGet fromServer h
|
|
(msg1, "hello") #== "delivers message"
|
|
|
|
Resp _ err1 <- sendRecv h ("12345678", rId, "OFF")
|
|
(err1, ERR AUTH) #== "rejects OFF with wrong signature (password atm)"
|
|
|
|
Resp _ err2 <- sendRecv h ("1234", sId, "OFF")
|
|
(err2, ERR AUTH) #== "rejects OFF with sender's ID"
|
|
|
|
Resp rId2 ok3 <- sendRecv h ("1234", rId, "OFF")
|
|
(ok3, OK) #== "suspends connection"
|
|
(rId2, rId) #== "same connection ID in response 2"
|
|
|
|
Resp _ err3 <- sendRecv h ("4567", sId, "SEND :hello")
|
|
(err3, ERR AUTH) #== "rejects signed SEND"
|
|
|
|
Resp _ err4 <- sendRecv h ("", sId, "SEND :hello")
|
|
(err4, ERR AUTH) #== "reject unsigned SEND too"
|
|
|
|
Resp _ ok4 <- sendRecv h ("1234", rId, "OFF")
|
|
(ok4, OK) #== "accepts OFF when suspended"
|
|
|
|
Resp _ (MSG _ _ msg) <- sendRecv h ("1234", rId, "SUB")
|
|
(msg, "hello") #== "accepts SUB when suspended and delivers the message again (because was not ACKed)"
|
|
|
|
Resp _ err5 <- sendRecv h ("12345678", rId, "DEL")
|
|
(err5, ERR AUTH) #== "rejects DEL with wrong signature (password atm)"
|
|
|
|
Resp _ err6 <- sendRecv h ("1234", sId, "DEL")
|
|
(err6, ERR AUTH) #== "rejects DEL with sender's ID"
|
|
|
|
Resp rId3 ok6 <- sendRecv h ("1234", rId, "DEL")
|
|
(ok6, OK) #== "deletes connection"
|
|
(rId3, rId) #== "same connection ID in response 3"
|
|
|
|
Resp _ err7 <- sendRecv h ("4567", sId, "SEND :hello")
|
|
(err7, ERR AUTH) #== "rejects signed SEND when deleted"
|
|
|
|
Resp _ err8 <- sendRecv h ("", sId, "SEND :hello")
|
|
(err8, ERR AUTH) #== "rejects unsigned SEND too when deleted"
|
|
|
|
Resp _ err9 <- sendRecv h ("1234", rId, "OFF")
|
|
(err9, ERR AUTH) #== "rejects OFF when deleted"
|
|
|
|
Resp _ err10 <- sendRecv h ("1234", rId, "SUB")
|
|
(err10, ERR AUTH) #== "rejects SUB when deleted"
|
|
|
|
testDuplex :: SpecWith ()
|
|
testDuplex =
|
|
it "should create 2 simplex connections and exchange messages" $
|
|
smpTestN 2 _test
|
|
where
|
|
_test [alice, bob] = _testDuplex alice bob
|
|
_test _ = error "expected 2 handles"
|
|
|
|
_testDuplex :: Handle -> Handle -> IO ()
|
|
_testDuplex alice bob = do
|
|
Resp _ (IDS aRcv aSnd) <- sendRecv alice ("", "", "CONN 1234")
|
|
-- aSnd ID is passed to Bob out-of-band
|
|
|
|
Resp _ OK <- sendRecv bob ("", aSnd, "SEND :key efgh")
|
|
-- "key efgh" is ad-hoc, different from SMP protocol
|
|
|
|
Resp _ (MSG _ _ msg1) <- tGet fromServer alice
|
|
Resp _ OK <- sendRecv alice ("1234", aRcv, "ACK")
|
|
["key", key1] <- return $ B.words msg1
|
|
(key1, "efgh") #== "key received from Bob"
|
|
Resp _ OK <- sendRecv alice ("1234", aRcv, "KEY " <> key1)
|
|
|
|
Resp _ (IDS bRcv bSnd) <- sendRecv bob ("", "", "CONN abcd")
|
|
Resp _ OK <- sendRecv bob ("efgh", aSnd, "SEND :reply_id " <> encode bSnd)
|
|
-- "reply_id ..." is ad-hoc, it is not a part of SMP protocol
|
|
|
|
Resp _ (MSG _ _ msg2) <- tGet fromServer alice
|
|
Resp _ OK <- sendRecv alice ("1234", aRcv, "ACK")
|
|
["reply_id", bId] <- return $ B.words msg2
|
|
(bId, encode bSnd) #== "reply connection ID received from Bob"
|
|
Resp _ OK <- sendRecv alice ("", bSnd, "SEND :key 5678")
|
|
-- "key 5678" is ad-hoc, different from SMP protocol
|
|
|
|
Resp _ (MSG _ _ msg3) <- tGet fromServer bob
|
|
Resp _ OK <- sendRecv bob ("abcd", bRcv, "ACK")
|
|
["key", key2] <- return $ B.words msg3
|
|
(key2, "5678") #== "key received from Alice"
|
|
Resp _ OK <- sendRecv bob ("abcd", bRcv, "KEY " <> key2)
|
|
|
|
Resp _ OK <- sendRecv bob ("efgh", aSnd, "SEND :hi alice")
|
|
|
|
Resp _ (MSG _ _ msg4) <- tGet fromServer alice
|
|
Resp _ OK <- sendRecv alice ("1234", aRcv, "ACK")
|
|
(msg4, "hi alice") #== "message received from Bob"
|
|
|
|
Resp _ OK <- sendRecv alice ("5678", bSnd, "SEND :how are you bob")
|
|
|
|
Resp _ (MSG _ _ msg5) <- tGet fromServer bob
|
|
Resp _ OK <- sendRecv bob ("abcd", bRcv, "ACK")
|
|
(msg5, "how are you bob") #== "message received from alice"
|
|
|
|
testSwitchSub :: SpecWith ()
|
|
testSwitchSub =
|
|
it "should create simplex connections and switch subscription to another TCP connection" $
|
|
smpTestN 3 _test
|
|
where
|
|
_test [rh1, rh2, sh] = _testSwitch rh1 rh2 sh
|
|
_test _ = error "expected 3 handles"
|
|
|
|
_testSwitch :: Handle -> Handle -> Handle -> IO ()
|
|
_testSwitch rh1 rh2 sh = do
|
|
Resp _ (IDS rId sId) <- sendRecv rh1 ("", "", "CONN 1234")
|
|
Resp _ ok1 <- sendRecv sh ("", sId, "SEND :test1")
|
|
(ok1, OK) #== "sent test message 1"
|
|
|
|
Resp _ (MSG _ _ msg1) <- tGet fromServer rh1
|
|
(msg1, "test1") #== "test message 1 delivered to the 1st TCP connection"
|
|
Resp _ OK <- sendRecv rh1 ("1234", rId, "ACK")
|
|
|
|
Resp _ ok2 <- sendRecv rh2 ("1234", rId, "SUB")
|
|
(ok2, OK) #== "connected to the same simplex connection via another TCP connection"
|
|
|
|
Resp _ end <- tGet fromServer rh1
|
|
(end, END) #== "unsubscribed the 1st connection"
|
|
|
|
Resp _ OK <- sendRecv sh ("", sId, "SEND :test2")
|
|
|
|
Resp _ (MSG _ _ msg2) <- tGet fromServer rh2
|
|
(msg2, "test2") #== "delivered to the 2nd TCP connection"
|
|
Resp _ OK <- sendRecv rh1 ("1234", rId, "ACK")
|
|
|
|
timeout 1000 (tGet fromServer rh1) >>= \case
|
|
Nothing -> return ()
|
|
Just _ -> error "nothing should be delivered to the 1st TCPconnection"
|
|
|
|
syntaxTests :: SpecWith ()
|
|
syntaxTests = do
|
|
it "unknown command" $ [("", "1234", "HELLO")] >#> [("", "1234", "ERR UNKNOWN")]
|
|
describe "CONN" do
|
|
it "no parameters" $ [("", "", "CONN")] >#> [("", "", "ERR SYNTAX 2")]
|
|
it "many parameters" $ [("", "", "CONN 1 2")] >#> [("", "", "ERR SYNTAX 2")]
|
|
it "has signature" $ [("1234", "", "CONN 1234")] >#> [("", "", "ERR SYNTAX 4")]
|
|
it "connection ID" $ [("", "1", "CONN 1234")] >#> [("", "1", "ERR SYNTAX 4")]
|
|
describe "KEY" do
|
|
it "valid syntax" $ [("1234", "1", "KEY 4567")] >#> [("", "1", "ERR AUTH")]
|
|
it "no parameters" $ [("1234", "1", "KEY")] >#> [("", "1", "ERR SYNTAX 2")]
|
|
it "many parameters" $ [("1234", "1", "KEY 1 2")] >#> [("", "1", "ERR SYNTAX 2")]
|
|
it "no signature" $ [("", "1", "KEY 4567")] >#> [("", "1", "ERR SYNTAX 3")]
|
|
it "no connection ID" $ [("1234", "", "KEY 4567")] >#> [("", "", "ERR SYNTAX 3")]
|
|
noParamsSyntaxTest "SUB"
|
|
noParamsSyntaxTest "ACK"
|
|
noParamsSyntaxTest "OFF"
|
|
noParamsSyntaxTest "DEL"
|
|
describe "SEND" do
|
|
it "valid syntax 1" $ [("1234", "1", "SEND :hello")] >#> [("", "1", "ERR AUTH")]
|
|
it "valid syntax 2" $ [("1234", "1", "SEND 11\nhello there\n")] >#> [("", "1", "ERR AUTH")]
|
|
it "no parameters" $ [("1234", "1", "SEND")] >#> [("", "1", "ERR SYNTAX 2")]
|
|
it "no connection ID" $ [("1234", "", "SEND :hello")] >#> [("", "", "ERR SYNTAX 5")]
|
|
it "bad message body 1" $ [("1234", "1", "SEND 11 hello")] >#> [("", "1", "ERR SYNTAX 6")]
|
|
it "bad message body 2" $ [("1234", "1", "SEND hello")] >#> [("", "1", "ERR SYNTAX 6")]
|
|
it "bigger body" $ [("1234", "1", "SEND 4\nhello\n")] >#> [("", "1", "ERR SIZE")]
|
|
describe "broker response not allowed" do
|
|
it "OK" $ [("1234", "1", "OK")] >#> [("", "1", "ERR PROHIBITED")]
|
|
where
|
|
noParamsSyntaxTest :: ByteString -> SpecWith ()
|
|
noParamsSyntaxTest cmd = describe (B.unpack cmd) do
|
|
it "valid syntax" $ [("1234", "1", cmd)] >#> [("", "1", "ERR AUTH")]
|
|
it "parameters" $ [("1234", "1", cmd <> " 1")] >#> [("", "1", "ERR SYNTAX 2")]
|
|
it "no signature" $ [("", "1", cmd)] >#> [("", "1", "ERR SYNTAX 3")]
|
|
it "no connection ID" $ [("1234", "", cmd)] >#> [("", "", "ERR SYNTAX 3")]
|