917 lines
44 KiB
Haskell
917 lines
44 KiB
Haskell
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE DuplicateRecordFields #-}
|
|
{-# LANGUAGE GADTs #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedLists #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE PatternSynonyms #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
|
|
module ServerTests where
|
|
|
|
import Control.Concurrent (ThreadId, killThread, threadDelay)
|
|
import Control.Concurrent.STM
|
|
import Control.Exception (SomeException, try)
|
|
import Control.Monad.Except (forM, forM_, runExceptT)
|
|
import Control.Monad.IO.Class
|
|
import Data.Bifunctor (first)
|
|
import Data.ByteString.Base64
|
|
import Data.ByteString.Char8 (ByteString)
|
|
import qualified Data.ByteString.Char8 as B
|
|
import SMPClient
|
|
import qualified Simplex.Messaging.Crypto as C
|
|
import Simplex.Messaging.Encoding
|
|
import Simplex.Messaging.Encoding.String
|
|
import Simplex.Messaging.Parsers (parseAll)
|
|
import Simplex.Messaging.Protocol
|
|
import Simplex.Messaging.Server.Env.STM (ServerConfig (..))
|
|
import Simplex.Messaging.Server.Expiration
|
|
import Simplex.Messaging.Transport
|
|
import System.Directory (removeFile)
|
|
import System.TimeIt (timeItT)
|
|
import System.Timeout
|
|
import Test.HUnit
|
|
import Test.Hspec
|
|
|
|
serverTests :: ATransport -> Spec
|
|
serverTests t@(ATransport t') = do
|
|
describe "SMP syntax" $ syntaxTests t
|
|
describe "SMP queues" $ do
|
|
describe "NEW and KEY commands, SEND messages (v2)" $ testCreateSecureV2 t'
|
|
describe "NEW and KEY commands, SEND messages (v3)" $ testCreateSecure t
|
|
describe "NEW, OFF and DEL commands, SEND messages" $ testCreateDelete t
|
|
describe "Stress test" $ stressTest t
|
|
describe "allowNewQueues setting" $ testAllowNewQueues t'
|
|
describe "SMP messages" $ do
|
|
describe "duplex communication over 2 SMP connections" $ testDuplex t
|
|
describe "switch subscription to another TCP connection" $ testSwitchSub t
|
|
describe "GET command" $ testGetCommand t'
|
|
describe "GET & SUB commands" $ testGetSubCommands t'
|
|
describe "Store log" $ testWithStoreLog t
|
|
describe "Restore messages" $ testRestoreMessages t
|
|
describe "Restore messages (v2)" $ testRestoreMessagesV2 t
|
|
describe "Timing of AUTH error" $ testTiming t
|
|
describe "Message notifications" $ testMessageNotifications t
|
|
describe "Message expiration" $ do
|
|
testMsgExpireOnSend t'
|
|
testMsgExpireOnInterval t'
|
|
testMsgNOTExpireOnInterval t'
|
|
|
|
pattern Resp :: CorrId -> QueueId -> BrokerMsg -> SignedTransmission BrokerMsg
|
|
pattern Resp corrId queueId command <- (_, _, (corrId, queueId, Right command))
|
|
|
|
pattern Ids :: RecipientId -> SenderId -> RcvPublicDhKey -> BrokerMsg
|
|
pattern Ids rId sId srvDh <- IDS (QIK rId sId srvDh)
|
|
|
|
pattern Msg :: MsgId -> MsgBody -> BrokerMsg
|
|
pattern Msg msgId body <- MSG RcvMessage {msgId, msgBody = EncRcvMsgBody body}
|
|
|
|
sendRecv :: forall c p. (Transport c, PartyI p) => THandle c -> (Maybe C.ASignature, ByteString, ByteString, Command p) -> IO (SignedTransmission BrokerMsg)
|
|
sendRecv h@THandle {thVersion, sessionId} (sgn, corrId, qId, cmd) = do
|
|
let t = encodeTransmission thVersion sessionId (CorrId corrId, qId, cmd)
|
|
Right () <- tPut1 h (sgn, t)
|
|
tGet1 h
|
|
|
|
signSendRecv :: forall c p. (Transport c, PartyI p) => THandle c -> C.APrivateSignKey -> (ByteString, ByteString, Command p) -> IO (SignedTransmission BrokerMsg)
|
|
signSendRecv h@THandle {thVersion, sessionId} pk (corrId, qId, cmd) = do
|
|
let t = encodeTransmission thVersion sessionId (CorrId corrId, qId, cmd)
|
|
Right sig <- runExceptT $ C.sign pk t
|
|
Right () <- tPut1 h (Just sig, t)
|
|
tGet1 h
|
|
|
|
tPut1 :: Transport c => THandle c -> SentRawTransmission -> IO (Either TransportError ())
|
|
tPut1 h t = do
|
|
[r] <- tPut h [t]
|
|
pure r
|
|
|
|
tGet1 :: (ProtocolEncoding cmd, Transport c, MonadIO m, MonadFail m) => THandle c -> m (SignedTransmission cmd)
|
|
tGet1 h = do
|
|
[r] <- tGet h
|
|
pure r
|
|
|
|
(#==) :: (HasCallStack, Eq a, Show a) => (a, a) -> String -> Assertion
|
|
(actual, expected) #== message = assertEqual message expected actual
|
|
|
|
_SEND :: MsgBody -> Command 'Sender
|
|
_SEND = SEND noMsgFlags
|
|
|
|
_SEND' :: MsgBody -> Command 'Sender
|
|
_SEND' = SEND MsgFlags {notification = True}
|
|
|
|
decryptMsgV2 :: C.DhSecret 'C.X25519 -> ByteString -> ByteString -> Either C.CryptoError ByteString
|
|
decryptMsgV2 dhShared = C.cbDecrypt dhShared . C.cbNonce
|
|
|
|
decryptMsgV3 :: C.DhSecret 'C.X25519 -> ByteString -> ByteString -> Either String MsgBody
|
|
decryptMsgV3 dhShared nonce body = do
|
|
ClientRcvMsgBody {msgBody} <- parseAll clientRcvMsgBodyP =<< first show (C.cbDecrypt dhShared (C.cbNonce nonce) body)
|
|
pure msgBody
|
|
|
|
testCreateSecureV2 :: forall c. Transport c => TProxy c -> Spec
|
|
testCreateSecureV2 _ =
|
|
it "should create (NEW) and secure (KEY) queue" $
|
|
withSmpServerConfigOn (transport @c) cfgV2 testPort $ \_ -> testSMPClient @c $ \h -> do
|
|
(rPub, rKey) <- C.generateSignatureKeyPair C.SEd448
|
|
(dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
|
|
Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub)
|
|
let dec = decryptMsgV2 $ C.dh' srvDh dhPriv
|
|
(rId1, "") #== "creates queue"
|
|
|
|
Resp "bcda" sId1 ok1 <- sendRecv h ("", "bcda", sId, _SEND "hello")
|
|
(ok1, OK) #== "accepts unsigned SEND"
|
|
(sId1, sId) #== "same queue ID in response 1"
|
|
|
|
Resp "" _ (Msg mId1 msg1) <- tGet1 h
|
|
(dec mId1 msg1, Right "hello") #== "delivers message"
|
|
|
|
Resp "cdab" _ ok4 <- signSendRecv h rKey ("cdab", rId, ACK mId1)
|
|
(ok4, OK) #== "replies OK when message acknowledged if no more messages"
|
|
|
|
Resp "dabc" _ err6 <- signSendRecv h rKey ("dabc", rId, ACK mId1)
|
|
(err6, ERR NO_MSG) #== "replies ERR when message acknowledged without messages"
|
|
|
|
(sPub, sKey) <- C.generateSignatureKeyPair C.SEd448
|
|
Resp "abcd" sId2 err1 <- signSendRecv h sKey ("abcd", sId, _SEND "hello")
|
|
(err1, ERR AUTH) #== "rejects signed SEND"
|
|
(sId2, sId) #== "same queue ID in response 2"
|
|
|
|
Resp "bcda" _ err2 <- sendRecv h (sampleSig, "bcda", rId, KEY sPub)
|
|
(err2, ERR AUTH) #== "rejects KEY with wrong signature"
|
|
|
|
Resp "cdab" _ err3 <- signSendRecv h rKey ("cdab", sId, KEY sPub)
|
|
(err3, ERR AUTH) #== "rejects KEY with sender's ID"
|
|
|
|
Resp "dabc" rId2 ok2 <- signSendRecv h rKey ("dabc", rId, KEY sPub)
|
|
(ok2, OK) #== "secures queue"
|
|
(rId2, rId) #== "same queue ID in response 3"
|
|
|
|
Resp "abcd" _ err4 <- signSendRecv h rKey ("abcd", rId, KEY sPub)
|
|
(err4, ERR AUTH) #== "rejects KEY if already secured"
|
|
|
|
Resp "bcda" _ ok3 <- signSendRecv h sKey ("bcda", sId, _SEND "hello again")
|
|
(ok3, OK) #== "accepts signed SEND"
|
|
|
|
Resp "" _ (Msg mId2 msg2) <- tGet1 h
|
|
(dec mId2 msg2, Right "hello again") #== "delivers message 2"
|
|
|
|
Resp "cdab" _ ok5 <- signSendRecv h rKey ("cdab", rId, ACK mId2)
|
|
(ok5, OK) #== "replies OK when message acknowledged 2"
|
|
|
|
Resp "dabc" _ err5 <- sendRecv h ("", "dabc", sId, _SEND "hello")
|
|
(err5, ERR AUTH) #== "rejects unsigned SEND"
|
|
|
|
let maxAllowedMessage = B.replicate maxMessageLength '-'
|
|
Resp "bcda" _ OK <- signSendRecv h sKey ("bcda", sId, _SEND maxAllowedMessage)
|
|
Resp "" _ (Msg mId3 msg3) <- tGet1 h
|
|
(dec mId3 msg3, Right maxAllowedMessage) #== "delivers message of max size"
|
|
|
|
let biggerMessage = B.replicate (maxMessageLength + 1) '-'
|
|
Resp "bcda" _ (ERR LARGE_MSG) <- signSendRecv h sKey ("bcda", sId, _SEND biggerMessage)
|
|
pure ()
|
|
|
|
testCreateSecure :: ATransport -> Spec
|
|
testCreateSecure (ATransport t) =
|
|
it "should create (NEW) and secure (KEY) queue" $
|
|
smpTest t $ \h -> do
|
|
(rPub, rKey) <- C.generateSignatureKeyPair C.SEd448
|
|
(dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
|
|
Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub)
|
|
let dec = decryptMsgV3 $ C.dh' srvDh dhPriv
|
|
(rId1, "") #== "creates queue"
|
|
|
|
Resp "bcda" sId1 ok1 <- sendRecv h ("", "bcda", sId, _SEND "hello")
|
|
(ok1, OK) #== "accepts unsigned SEND"
|
|
(sId1, sId) #== "same queue ID in response 1"
|
|
|
|
Resp "" _ (Msg mId1 msg1) <- tGet1 h
|
|
(dec mId1 msg1, Right "hello") #== "delivers message"
|
|
|
|
Resp "cdab" _ ok4 <- signSendRecv h rKey ("cdab", rId, ACK mId1)
|
|
(ok4, OK) #== "replies OK when message acknowledged if no more messages"
|
|
|
|
Resp "dabc" _ err6 <- signSendRecv h rKey ("dabc", rId, ACK mId1)
|
|
(err6, ERR NO_MSG) #== "replies ERR when message acknowledged without messages"
|
|
|
|
(sPub, sKey) <- C.generateSignatureKeyPair C.SEd448
|
|
Resp "abcd" sId2 err1 <- signSendRecv h sKey ("abcd", sId, _SEND "hello")
|
|
(err1, ERR AUTH) #== "rejects signed SEND"
|
|
(sId2, sId) #== "same queue ID in response 2"
|
|
|
|
Resp "bcda" _ err2 <- sendRecv h (sampleSig, "bcda", rId, KEY sPub)
|
|
(err2, ERR AUTH) #== "rejects KEY with wrong signature"
|
|
|
|
Resp "cdab" _ err3 <- signSendRecv h rKey ("cdab", sId, KEY sPub)
|
|
(err3, ERR AUTH) #== "rejects KEY with sender's ID"
|
|
|
|
Resp "dabc" rId2 ok2 <- signSendRecv h rKey ("dabc", rId, KEY sPub)
|
|
(ok2, OK) #== "secures queue"
|
|
(rId2, rId) #== "same queue ID in response 3"
|
|
|
|
Resp "abcd" _ err4 <- signSendRecv h rKey ("abcd", rId, KEY sPub)
|
|
(err4, ERR AUTH) #== "rejects KEY if already secured"
|
|
|
|
Resp "bcda" _ ok3 <- signSendRecv h sKey ("bcda", sId, _SEND "hello again")
|
|
(ok3, OK) #== "accepts signed SEND"
|
|
|
|
Resp "" _ (Msg mId2 msg2) <- tGet1 h
|
|
(dec mId2 msg2, Right "hello again") #== "delivers message 2"
|
|
|
|
Resp "cdab" _ ok5 <- signSendRecv h rKey ("cdab", rId, ACK mId2)
|
|
(ok5, OK) #== "replies OK when message acknowledged 2"
|
|
|
|
Resp "dabc" _ err5 <- sendRecv h ("", "dabc", sId, _SEND "hello")
|
|
(err5, ERR AUTH) #== "rejects unsigned SEND"
|
|
|
|
let maxAllowedMessage = B.replicate maxMessageLength '-'
|
|
Resp "bcda" _ OK <- signSendRecv h sKey ("bcda", sId, _SEND maxAllowedMessage)
|
|
Resp "" _ (Msg mId3 msg3) <- tGet1 h
|
|
(dec mId3 msg3, Right maxAllowedMessage) #== "delivers message of max size"
|
|
|
|
let biggerMessage = B.replicate (maxMessageLength + 1) '-'
|
|
Resp "bcda" _ (ERR LARGE_MSG) <- signSendRecv h sKey ("bcda", sId, _SEND biggerMessage)
|
|
pure ()
|
|
|
|
testCreateDelete :: ATransport -> Spec
|
|
testCreateDelete (ATransport t) =
|
|
it "should create (NEW), suspend (OFF) and delete (DEL) queue" $
|
|
smpTest2 t $ \rh sh -> do
|
|
(rPub, rKey) <- C.generateSignatureKeyPair C.SEd25519
|
|
(dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
|
|
Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub)
|
|
let dec = decryptMsgV3 $ C.dh' srvDh dhPriv
|
|
(rId1, "") #== "creates queue"
|
|
|
|
(sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
|
|
Resp "bcda" _ ok1 <- signSendRecv rh rKey ("bcda", rId, KEY sPub)
|
|
(ok1, OK) #== "secures queue"
|
|
|
|
Resp "cdab" _ ok2 <- signSendRecv sh sKey ("cdab", sId, _SEND "hello")
|
|
(ok2, OK) #== "accepts signed SEND"
|
|
|
|
Resp "dabc" _ ok7 <- signSendRecv sh sKey ("dabc", sId, _SEND "hello 2")
|
|
(ok7, OK) #== "accepts signed SEND 2 - this message is not delivered because the first is not ACKed"
|
|
|
|
Resp "" _ (Msg mId1 msg1) <- tGet1 rh
|
|
(dec mId1 msg1, Right "hello") #== "delivers message"
|
|
|
|
Resp "abcd" _ err1 <- sendRecv rh (sampleSig, "abcd", rId, OFF)
|
|
(err1, ERR AUTH) #== "rejects OFF with wrong signature"
|
|
|
|
Resp "bcda" _ err2 <- signSendRecv rh rKey ("bcda", sId, OFF)
|
|
(err2, ERR AUTH) #== "rejects OFF with sender's ID"
|
|
|
|
Resp "cdab" rId2 ok3 <- signSendRecv rh rKey ("cdab", rId, OFF)
|
|
(ok3, OK) #== "suspends queue"
|
|
(rId2, rId) #== "same queue ID in response 2"
|
|
|
|
Resp "dabc" _ err3 <- signSendRecv sh sKey ("dabc", sId, _SEND "hello")
|
|
(err3, ERR AUTH) #== "rejects signed SEND"
|
|
|
|
Resp "abcd" _ err4 <- sendRecv sh ("", "abcd", sId, _SEND "hello")
|
|
(err4, ERR AUTH) #== "reject unsigned SEND too"
|
|
|
|
Resp "bcda" _ ok4 <- signSendRecv rh rKey ("bcda", rId, OFF)
|
|
(ok4, OK) #== "accepts OFF when suspended"
|
|
|
|
Resp "cdab" _ (Msg mId2 msg2) <- signSendRecv rh rKey ("cdab", rId, SUB)
|
|
(dec mId2 msg2, Right "hello") #== "accepts SUB when suspended and delivers the message again (because was not ACKed)"
|
|
|
|
Resp "dabc" _ err5 <- sendRecv rh (sampleSig, "dabc", rId, DEL)
|
|
(err5, ERR AUTH) #== "rejects DEL with wrong signature"
|
|
|
|
Resp "abcd" _ err6 <- signSendRecv rh rKey ("abcd", sId, DEL)
|
|
(err6, ERR AUTH) #== "rejects DEL with sender's ID"
|
|
|
|
Resp "bcda" rId3 ok6 <- signSendRecv rh rKey ("bcda", rId, DEL)
|
|
(ok6, OK) #== "deletes queue"
|
|
(rId3, rId) #== "same queue ID in response 3"
|
|
|
|
Resp "cdab" _ err7 <- signSendRecv sh sKey ("cdab", sId, _SEND "hello")
|
|
(err7, ERR AUTH) #== "rejects signed SEND when deleted"
|
|
|
|
Resp "dabc" _ err8 <- sendRecv sh ("", "dabc", sId, _SEND "hello")
|
|
(err8, ERR AUTH) #== "rejects unsigned SEND too when deleted"
|
|
|
|
Resp "abcd" _ err11 <- signSendRecv rh rKey ("abcd", rId, ACK "")
|
|
(err11, ERR AUTH) #== "rejects ACK when conn deleted - the second message is deleted"
|
|
|
|
Resp "bcda" _ err9 <- signSendRecv rh rKey ("bcda", rId, OFF)
|
|
(err9, ERR AUTH) #== "rejects OFF when deleted"
|
|
|
|
Resp "cdab" _ err10 <- signSendRecv rh rKey ("cdab", rId, SUB)
|
|
(err10, ERR AUTH) #== "rejects SUB when deleted"
|
|
|
|
stressTest :: ATransport -> Spec
|
|
stressTest (ATransport t) =
|
|
it "should create many queues, disconnect and re-connect" $
|
|
smpTest3 t $ \h1 h2 h3 -> do
|
|
(rPub, rKey) <- C.generateSignatureKeyPair C.SEd25519
|
|
(dhPub, _ :: C.PrivateKeyX25519) <- C.generateKeyPair'
|
|
rIds <- forM ([1 .. 50] :: [Int]) . const $ do
|
|
Resp "" "" (Ids rId _ _) <- signSendRecv h1 rKey ("", "", NEW rPub dhPub)
|
|
pure rId
|
|
let subscribeQueues h = forM_ rIds $ \rId -> do
|
|
Resp "" rId' OK <- signSendRecv h rKey ("", rId, SUB)
|
|
rId' `shouldBe` rId
|
|
closeConnection $ connection h1
|
|
subscribeQueues h2
|
|
closeConnection $ connection h2
|
|
subscribeQueues h3
|
|
|
|
testAllowNewQueues :: forall c. Transport c => TProxy c -> Spec
|
|
testAllowNewQueues t =
|
|
it "should prohibit creating new queues with allowNewQueues = False" $ do
|
|
withSmpServerConfigOn (ATransport t) cfg {allowNewQueues = False} testPort $ \_ ->
|
|
testSMPClient @c $ \h -> do
|
|
(rPub, rKey) <- C.generateSignatureKeyPair C.SEd448
|
|
(dhPub, _ :: C.PrivateKeyX25519) <- C.generateKeyPair'
|
|
Resp "abcd" "" (ERR AUTH) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub)
|
|
pure ()
|
|
|
|
testDuplex :: ATransport -> Spec
|
|
testDuplex (ATransport t) =
|
|
it "should create 2 simplex connections and exchange messages" $
|
|
smpTest2 t $ \alice bob -> do
|
|
(arPub, arKey) <- C.generateSignatureKeyPair C.SEd448
|
|
(aDhPub, aDhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
|
|
Resp "abcd" _ (Ids aRcv aSnd aSrvDh) <- signSendRecv alice arKey ("abcd", "", NEW arPub aDhPub)
|
|
let aDec = decryptMsgV3 $ C.dh' aSrvDh aDhPriv
|
|
-- aSnd ID is passed to Bob out-of-band
|
|
|
|
(bsPub, bsKey) <- C.generateSignatureKeyPair C.SEd448
|
|
Resp "bcda" _ OK <- sendRecv bob ("", "bcda", aSnd, _SEND $ "key " <> strEncode bsPub)
|
|
-- "key ..." is ad-hoc, not a part of SMP protocol
|
|
|
|
Resp "" _ (Msg mId1 msg1) <- tGet1 alice
|
|
Resp "cdab" _ OK <- signSendRecv alice arKey ("cdab", aRcv, ACK mId1)
|
|
Right ["key", bobKey] <- pure $ B.words <$> aDec mId1 msg1
|
|
(bobKey, strEncode bsPub) #== "key received from Bob"
|
|
Resp "dabc" _ OK <- signSendRecv alice arKey ("dabc", aRcv, KEY bsPub)
|
|
|
|
(brPub, brKey) <- C.generateSignatureKeyPair C.SEd448
|
|
(bDhPub, bDhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
|
|
Resp "abcd" _ (Ids bRcv bSnd bSrvDh) <- signSendRecv bob brKey ("abcd", "", NEW brPub bDhPub)
|
|
let bDec = decryptMsgV3 $ C.dh' bSrvDh bDhPriv
|
|
Resp "bcda" _ OK <- signSendRecv bob bsKey ("bcda", aSnd, _SEND $ "reply_id " <> encode bSnd)
|
|
-- "reply_id ..." is ad-hoc, not a part of SMP protocol
|
|
|
|
Resp "" _ (Msg mId2 msg2) <- tGet1 alice
|
|
Resp "cdab" _ OK <- signSendRecv alice arKey ("cdab", aRcv, ACK mId2)
|
|
Right ["reply_id", bId] <- pure $ B.words <$> aDec mId2 msg2
|
|
(bId, encode bSnd) #== "reply queue ID received from Bob"
|
|
|
|
(asPub, asKey) <- C.generateSignatureKeyPair C.SEd448
|
|
Resp "dabc" _ OK <- sendRecv alice ("", "dabc", bSnd, _SEND $ "key " <> strEncode asPub)
|
|
-- "key ..." is ad-hoc, not a part of SMP protocol
|
|
|
|
Resp "" _ (Msg mId3 msg3) <- tGet1 bob
|
|
Resp "abcd" _ OK <- signSendRecv bob brKey ("abcd", bRcv, ACK mId3)
|
|
Right ["key", aliceKey] <- pure $ B.words <$> bDec mId3 msg3
|
|
(aliceKey, strEncode asPub) #== "key received from Alice"
|
|
Resp "bcda" _ OK <- signSendRecv bob brKey ("bcda", bRcv, KEY asPub)
|
|
|
|
Resp "cdab" _ OK <- signSendRecv bob bsKey ("cdab", aSnd, _SEND "hi alice")
|
|
|
|
Resp "" _ (Msg mId4 msg4) <- tGet1 alice
|
|
Resp "dabc" _ OK <- signSendRecv alice arKey ("dabc", aRcv, ACK mId4)
|
|
(aDec mId4 msg4, Right "hi alice") #== "message received from Bob"
|
|
|
|
Resp "abcd" _ OK <- signSendRecv alice asKey ("abcd", bSnd, _SEND "how are you bob")
|
|
|
|
Resp "" _ (Msg mId5 msg5) <- tGet1 bob
|
|
Resp "bcda" _ OK <- signSendRecv bob brKey ("bcda", bRcv, ACK mId5)
|
|
(bDec mId5 msg5, Right "how are you bob") #== "message received from alice"
|
|
|
|
testSwitchSub :: ATransport -> Spec
|
|
testSwitchSub (ATransport t) =
|
|
it "should create simplex connections and switch subscription to another TCP connection" $
|
|
smpTest3 t $ \rh1 rh2 sh -> do
|
|
(rPub, rKey) <- C.generateSignatureKeyPair C.SEd448
|
|
(dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
|
|
Resp "abcd" _ (Ids rId sId srvDh) <- signSendRecv rh1 rKey ("abcd", "", NEW rPub dhPub)
|
|
let dec = decryptMsgV3 $ C.dh' srvDh dhPriv
|
|
Resp "bcda" _ ok1 <- sendRecv sh ("", "bcda", sId, _SEND "test1")
|
|
(ok1, OK) #== "sent test message 1"
|
|
Resp "cdab" _ ok2 <- sendRecv sh ("", "cdab", sId, _SEND "test2, no ACK")
|
|
(ok2, OK) #== "sent test message 2"
|
|
|
|
Resp "" _ (Msg mId1 msg1) <- tGet1 rh1
|
|
(dec mId1 msg1, Right "test1") #== "test message 1 delivered to the 1st TCP connection"
|
|
Resp "abcd" _ (Msg mId2 msg2) <- signSendRecv rh1 rKey ("abcd", rId, ACK mId1)
|
|
(dec mId2 msg2, Right "test2, no ACK") #== "test message 2 delivered, no ACK"
|
|
|
|
Resp "bcda" _ (Msg mId2' msg2') <- signSendRecv rh2 rKey ("bcda", rId, SUB)
|
|
(dec mId2' msg2', Right "test2, no ACK") #== "same simplex queue via another TCP connection, tes2 delivered again (no ACK in 1st queue)"
|
|
Resp "cdab" _ OK <- signSendRecv rh2 rKey ("cdab", rId, ACK mId2')
|
|
|
|
Resp "" _ end <- tGet1 rh1
|
|
(end, END) #== "unsubscribed the 1st TCP connection"
|
|
|
|
Resp "dabc" _ OK <- sendRecv sh ("", "dabc", sId, _SEND "test3")
|
|
|
|
Resp "" _ (Msg mId3 msg3) <- tGet1 rh2
|
|
(dec mId3 msg3, Right "test3") #== "delivered to the 2nd TCP connection"
|
|
|
|
Resp "abcd" _ err <- signSendRecv rh1 rKey ("abcd", rId, ACK mId3)
|
|
(err, ERR NO_MSG) #== "rejects ACK from the 1st TCP connection"
|
|
|
|
Resp "bcda" _ ok3 <- signSendRecv rh2 rKey ("bcda", rId, ACK mId3)
|
|
(ok3, OK) #== "accepts ACK from the 2nd TCP connection"
|
|
|
|
1000 `timeout` tGet @BrokerMsg rh1 >>= \case
|
|
Nothing -> return ()
|
|
Just _ -> error "nothing else is delivered to the 1st TCP connection"
|
|
|
|
testGetCommand :: forall c. Transport c => TProxy c -> Spec
|
|
testGetCommand t =
|
|
it "should retrieve messages from the queue using GET command" $ do
|
|
(sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
|
|
smpTest t $ \sh -> do
|
|
queue <- newEmptyTMVarIO
|
|
testSMPClient @c $ \rh ->
|
|
atomically . putTMVar queue =<< createAndSecureQueue rh sPub
|
|
testSMPClient @c $ \rh -> do
|
|
(sId, rId, rKey, dhShared) <- atomically $ takeTMVar queue
|
|
let dec = decryptMsgV3 dhShared
|
|
Resp "1" _ OK <- signSendRecv sh sKey ("1", sId, _SEND "hello")
|
|
Resp "2" _ (Msg mId1 msg1) <- signSendRecv rh rKey ("2", rId, GET)
|
|
(dec mId1 msg1, Right "hello") #== "retrieved from queue"
|
|
Resp "3" _ OK <- signSendRecv rh rKey ("3", rId, ACK mId1)
|
|
Resp "4" _ OK <- signSendRecv rh rKey ("4", rId, GET)
|
|
pure ()
|
|
|
|
testGetSubCommands :: forall c. Transport c => TProxy c -> Spec
|
|
testGetSubCommands t =
|
|
it "should retrieve messages with GET and receive with SUB, only one ACK would work" $ do
|
|
(sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
|
|
smpTest3 t $ \rh1 rh2 sh -> do
|
|
(sId, rId, rKey, dhShared) <- createAndSecureQueue rh1 sPub
|
|
let dec = decryptMsgV3 dhShared
|
|
Resp "1" _ OK <- signSendRecv sh sKey ("1", sId, _SEND "hello 1")
|
|
Resp "1a" _ OK <- signSendRecv sh sKey ("1a", sId, _SEND "hello 2")
|
|
Resp "1b" _ OK <- signSendRecv sh sKey ("1b", sId, _SEND "hello 3")
|
|
Resp "1c" _ OK <- signSendRecv sh sKey ("1c", sId, _SEND "hello 4")
|
|
-- both get the same if not ACK'd
|
|
Resp "" _ (Msg mId1 msg1) <- tGet1 rh1
|
|
Resp "2" _ (Msg mId1' msg1') <- signSendRecv rh2 rKey ("2", rId, GET)
|
|
(dec mId1 msg1, Right "hello 1") #== "received from queue via SUB"
|
|
(dec mId1' msg1', Right "hello 1") #== "retrieved from queue with GET"
|
|
mId1 `shouldBe` mId1'
|
|
msg1 `shouldBe` msg1'
|
|
-- subscriber cannot GET, getter cannot SUB
|
|
Resp "3" _ (ERR (CMD PROHIBITED)) <- signSendRecv rh1 rKey ("3", rId, GET)
|
|
Resp "3a" _ (ERR (CMD PROHIBITED)) <- signSendRecv rh2 rKey ("3a", rId, SUB)
|
|
-- ACK for SUB delivers the next message
|
|
Resp "4" _ (Msg mId2 msg2) <- signSendRecv rh1 rKey ("4", rId, ACK mId1)
|
|
(dec mId2 msg2, Right "hello 2") #== "received from queue via SUB"
|
|
-- bad msgId returns error
|
|
Resp "5" _ (ERR NO_MSG) <- signSendRecv rh2 rKey ("5", rId, ACK "1234")
|
|
-- already ACK'd by subscriber, but still returns OK when msgId matches
|
|
Resp "5a" _ OK <- signSendRecv rh2 rKey ("5a", rId, ACK mId1)
|
|
-- msg2 is not lost - even if subscriber does not ACK it, it is delivered to getter
|
|
Resp "6" _ (Msg mId2' msg2') <- signSendRecv rh2 rKey ("6", rId, GET)
|
|
(dec mId2' msg2', Right "hello 2") #== "retrieved from queue with GET"
|
|
mId2 `shouldBe` mId2'
|
|
msg2 `shouldBe` msg2'
|
|
-- getter ACK returns OK, even though there is the next message
|
|
Resp "7" _ OK <- signSendRecv rh2 rKey ("7", rId, ACK mId2')
|
|
Resp "8" _ (Msg mId3 msg3) <- signSendRecv rh2 rKey ("8", rId, GET)
|
|
(dec mId3 msg3, Right "hello 3") #== "retrieved from queue with GET"
|
|
-- subscriber ACK does not lose message
|
|
Resp "9" _ (Msg mId3' msg3') <- signSendRecv rh1 rKey ("9", rId, ACK mId2')
|
|
(dec mId3' msg3', Right "hello 3") #== "retrieved from queue with GET"
|
|
mId3 `shouldBe` mId3'
|
|
msg3 `shouldBe` msg3'
|
|
Resp "10" _ (Msg mId4 msg4) <- signSendRecv rh1 rKey ("10", rId, ACK mId3)
|
|
(dec mId4 msg4, Right "hello 4") #== "retrieved from queue with GET"
|
|
Resp "11" _ OK <- signSendRecv rh1 rKey ("11", rId, ACK mId4)
|
|
-- no more messages for getter too
|
|
Resp "12" _ OK <- signSendRecv rh2 rKey ("12", rId, GET)
|
|
pure ()
|
|
|
|
testWithStoreLog :: ATransport -> Spec
|
|
testWithStoreLog at@(ATransport t) =
|
|
it "should store simplex queues to log and restore them after server restart" $ do
|
|
(sPub1, sKey1) <- C.generateSignatureKeyPair C.SEd25519
|
|
(sPub2, sKey2) <- C.generateSignatureKeyPair C.SEd25519
|
|
(nPub, nKey) <- C.generateSignatureKeyPair C.SEd25519
|
|
recipientId1 <- newTVarIO ""
|
|
recipientKey1 <- newTVarIO Nothing
|
|
dhShared1 <- newTVarIO Nothing
|
|
senderId1 <- newTVarIO ""
|
|
senderId2 <- newTVarIO ""
|
|
notifierId <- newTVarIO ""
|
|
|
|
withSmpServerStoreLogOn at testPort . runTest t $ \h -> runClient t $ \h1 -> do
|
|
(sId1, rId1, rKey1, dhShared) <- createAndSecureQueue h sPub1
|
|
(rcvNtfPubDhKey, _) <- C.generateKeyPair'
|
|
Resp "abcd" _ (NID nId _) <- signSendRecv h rKey1 ("abcd", rId1, NKEY nPub rcvNtfPubDhKey)
|
|
atomically $ do
|
|
writeTVar recipientId1 rId1
|
|
writeTVar recipientKey1 $ Just rKey1
|
|
writeTVar dhShared1 $ Just dhShared
|
|
writeTVar senderId1 sId1
|
|
writeTVar notifierId nId
|
|
Resp "dabc" _ OK <- signSendRecv h1 nKey ("dabc", nId, NSUB)
|
|
Resp "bcda" _ OK <- signSendRecv h sKey1 ("bcda", sId1, _SEND' "hello")
|
|
Resp "" _ (Msg mId1 msg1) <- tGet1 h
|
|
(decryptMsgV3 dhShared mId1 msg1, Right "hello") #== "delivered from queue 1"
|
|
Resp "" _ (NMSG _ _) <- tGet1 h1
|
|
|
|
(sId2, rId2, rKey2, dhShared2) <- createAndSecureQueue h sPub2
|
|
atomically $ writeTVar senderId2 sId2
|
|
Resp "cdab" _ OK <- signSendRecv h sKey2 ("cdab", sId2, _SEND "hello too")
|
|
Resp "" _ (Msg mId2 msg2) <- tGet1 h
|
|
(decryptMsgV3 dhShared2 mId2 msg2, Right "hello too") #== "delivered from queue 2"
|
|
|
|
Resp "dabc" _ OK <- signSendRecv h rKey2 ("dabc", rId2, DEL)
|
|
pure ()
|
|
|
|
logSize testStoreLogFile `shouldReturn` 6
|
|
|
|
withSmpServerThreadOn at testPort . runTest t $ \h -> do
|
|
sId1 <- readTVarIO senderId1
|
|
-- fails if store log is disabled
|
|
Resp "bcda" _ (ERR AUTH) <- signSendRecv h sKey1 ("bcda", sId1, _SEND "hello")
|
|
pure ()
|
|
|
|
withSmpServerStoreLogOn at testPort . runTest t $ \h -> runClient t $ \h1 -> do
|
|
-- this queue is restored
|
|
rId1 <- readTVarIO recipientId1
|
|
Just rKey1 <- readTVarIO recipientKey1
|
|
Just dh1 <- readTVarIO dhShared1
|
|
sId1 <- readTVarIO senderId1
|
|
nId <- readTVarIO notifierId
|
|
Resp "dabc" _ OK <- signSendRecv h1 nKey ("dabc", nId, NSUB)
|
|
Resp "bcda" _ OK <- signSendRecv h sKey1 ("bcda", sId1, _SEND' "hello")
|
|
Resp "cdab" _ (Msg mId3 msg3) <- signSendRecv h rKey1 ("cdab", rId1, SUB)
|
|
(decryptMsgV3 dh1 mId3 msg3, Right "hello") #== "delivered from restored queue"
|
|
Resp "" _ (NMSG _ _) <- tGet1 h1
|
|
-- this queue is removed - not restored
|
|
sId2 <- readTVarIO senderId2
|
|
Resp "cdab" _ (ERR AUTH) <- signSendRecv h sKey2 ("cdab", sId2, _SEND "hello too")
|
|
pure ()
|
|
|
|
logSize testStoreLogFile `shouldReturn` 1
|
|
removeFile testStoreLogFile
|
|
where
|
|
runTest :: Transport c => TProxy c -> (THandle c -> IO ()) -> ThreadId -> Expectation
|
|
runTest _ test' server = do
|
|
testSMPClient test' `shouldReturn` ()
|
|
killThread server
|
|
|
|
runClient :: Transport c => TProxy c -> (THandle c -> IO ()) -> Expectation
|
|
runClient _ test' = testSMPClient test' `shouldReturn` ()
|
|
|
|
logSize :: FilePath -> IO Int
|
|
logSize f =
|
|
try (length . B.lines <$> B.readFile f) >>= \case
|
|
Right l -> pure l
|
|
Left (_ :: SomeException) -> logSize f
|
|
|
|
testRestoreMessages :: ATransport -> Spec
|
|
testRestoreMessages at@(ATransport t) =
|
|
it "should store messages on exit and restore on start" $ do
|
|
(sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
|
|
recipientId <- newTVarIO ""
|
|
recipientKey <- newTVarIO Nothing
|
|
dhShared <- newTVarIO Nothing
|
|
senderId <- newTVarIO ""
|
|
|
|
withSmpServerStoreMsgLogOn at testPort . runTest t $ \h -> do
|
|
runClient t $ \h1 -> do
|
|
(sId, rId, rKey, dh) <- createAndSecureQueue h1 sPub
|
|
atomically $ do
|
|
writeTVar recipientId rId
|
|
writeTVar recipientKey $ Just rKey
|
|
writeTVar dhShared $ Just dh
|
|
writeTVar senderId sId
|
|
Resp "1" _ OK <- signSendRecv h sKey ("1", sId, _SEND "hello")
|
|
Resp "" _ (Msg mId1 msg1) <- tGet1 h1
|
|
Resp "1a" _ OK <- signSendRecv h1 rKey ("1a", rId, ACK mId1)
|
|
(decryptMsgV3 dh mId1 msg1, Right "hello") #== "message delivered"
|
|
-- messages below are delivered after server restart
|
|
sId <- readTVarIO senderId
|
|
Resp "2" _ OK <- signSendRecv h sKey ("2", sId, _SEND "hello 2")
|
|
Resp "3" _ OK <- signSendRecv h sKey ("3", sId, _SEND "hello 3")
|
|
Resp "4" _ OK <- signSendRecv h sKey ("4", sId, _SEND "hello 4")
|
|
pure ()
|
|
|
|
logSize testStoreLogFile `shouldReturn` 2
|
|
logSize testStoreMsgsFile `shouldReturn` 3
|
|
|
|
withSmpServerStoreMsgLogOn at testPort . runTest t $ \h -> do
|
|
rId <- readTVarIO recipientId
|
|
Just rKey <- readTVarIO recipientKey
|
|
Just dh <- readTVarIO dhShared
|
|
let dec = decryptMsgV3 dh
|
|
Resp "2" _ (Msg mId2 msg2) <- signSendRecv h rKey ("2", rId, SUB)
|
|
(dec mId2 msg2, Right "hello 2") #== "restored message delivered"
|
|
Resp "3" _ (Msg mId3 msg3) <- signSendRecv h rKey ("3", rId, ACK mId2)
|
|
(dec mId3 msg3, Right "hello 3") #== "restored message delivered"
|
|
Resp "4" _ (Msg mId4 msg4) <- signSendRecv h rKey ("4", rId, ACK mId3)
|
|
(dec mId4 msg4, Right "hello 4") #== "restored message delivered"
|
|
|
|
logSize testStoreLogFile `shouldReturn` 1
|
|
-- the last message is not removed because it was not ACK'd
|
|
logSize testStoreMsgsFile `shouldReturn` 1
|
|
|
|
withSmpServerStoreMsgLogOn at testPort . runTest t $ \h -> do
|
|
rId <- readTVarIO recipientId
|
|
Just rKey <- readTVarIO recipientKey
|
|
Just dh <- readTVarIO dhShared
|
|
Resp "4" _ (Msg mId4 msg4) <- signSendRecv h rKey ("4", rId, SUB)
|
|
Resp "5" _ OK <- signSendRecv h rKey ("5", rId, ACK mId4)
|
|
(decryptMsgV3 dh mId4 msg4, Right "hello 4") #== "restored message delivered"
|
|
|
|
logSize testStoreLogFile `shouldReturn` 1
|
|
logSize testStoreMsgsFile `shouldReturn` 0
|
|
|
|
removeFile testStoreLogFile
|
|
removeFile testStoreMsgsFile
|
|
where
|
|
runTest :: Transport c => TProxy c -> (THandle c -> IO ()) -> ThreadId -> Expectation
|
|
runTest _ test' server = do
|
|
testSMPClient test' `shouldReturn` ()
|
|
killThread server
|
|
|
|
runClient :: Transport c => TProxy c -> (THandle c -> IO ()) -> Expectation
|
|
runClient _ test' = testSMPClient test' `shouldReturn` ()
|
|
|
|
testRestoreMessagesV2 :: ATransport -> Spec
|
|
testRestoreMessagesV2 at@(ATransport t) =
|
|
it "should store messages on exit and restore on start" $ do
|
|
(sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
|
|
recipientId <- newTVarIO ""
|
|
recipientKey <- newTVarIO Nothing
|
|
dhShared <- newTVarIO Nothing
|
|
senderId <- newTVarIO ""
|
|
|
|
withSmpServerStoreMsgLogOnV2 at testPort . runTest t $ \h -> do
|
|
runClient t $ \h1 -> do
|
|
(sId, rId, rKey, dh) <- createAndSecureQueue h1 sPub
|
|
atomically $ do
|
|
writeTVar recipientId rId
|
|
writeTVar recipientKey $ Just rKey
|
|
writeTVar dhShared $ Just dh
|
|
writeTVar senderId sId
|
|
Resp "1" _ OK <- signSendRecv h sKey ("1", sId, _SEND "hello")
|
|
Resp "" _ (Msg mId1 msg1) <- tGet1 h1
|
|
Resp "1a" _ OK <- signSendRecv h1 rKey ("1a", rId, ACK mId1)
|
|
(decryptMsgV2 dh mId1 msg1, Right "hello") #== "message delivered"
|
|
-- messages below are delivered after server restart
|
|
sId <- readTVarIO senderId
|
|
Resp "2" _ OK <- signSendRecv h sKey ("2", sId, _SEND "hello 2")
|
|
Resp "3" _ OK <- signSendRecv h sKey ("3", sId, _SEND "hello 3")
|
|
Resp "4" _ OK <- signSendRecv h sKey ("4", sId, _SEND "hello 4")
|
|
pure ()
|
|
|
|
logSize testStoreLogFile `shouldReturn` 2
|
|
logSize testStoreMsgsFile `shouldReturn` 3
|
|
|
|
withSmpServerStoreMsgLogOnV2 at testPort . runTest t $ \h -> do
|
|
rId <- readTVarIO recipientId
|
|
Just rKey <- readTVarIO recipientKey
|
|
Just dh <- readTVarIO dhShared
|
|
let dec = decryptMsgV2 dh
|
|
Resp "2" _ (Msg mId2 msg2) <- signSendRecv h rKey ("2", rId, SUB)
|
|
(dec mId2 msg2, Right "hello 2") #== "restored message delivered"
|
|
Resp "3" _ (Msg mId3 msg3) <- signSendRecv h rKey ("3", rId, ACK mId2)
|
|
(dec mId3 msg3, Right "hello 3") #== "restored message delivered"
|
|
Resp "4" _ (Msg mId4 msg4) <- signSendRecv h rKey ("4", rId, ACK mId3)
|
|
(dec mId4 msg4, Right "hello 4") #== "restored message delivered"
|
|
|
|
logSize testStoreLogFile `shouldReturn` 1
|
|
-- the last message is not removed because it was not ACK'd
|
|
logSize testStoreMsgsFile `shouldReturn` 1
|
|
|
|
withSmpServerStoreMsgLogOnV2 at testPort . runTest t $ \h -> do
|
|
rId <- readTVarIO recipientId
|
|
Just rKey <- readTVarIO recipientKey
|
|
Just dh <- readTVarIO dhShared
|
|
Resp "4" _ (Msg mId4 msg4) <- signSendRecv h rKey ("4", rId, SUB)
|
|
Resp "5" _ OK <- signSendRecv h rKey ("5", rId, ACK mId4)
|
|
(decryptMsgV2 dh mId4 msg4, Right "hello 4") #== "restored message delivered"
|
|
|
|
logSize testStoreLogFile `shouldReturn` 1
|
|
logSize testStoreMsgsFile `shouldReturn` 0
|
|
|
|
removeFile testStoreLogFile
|
|
removeFile testStoreMsgsFile
|
|
where
|
|
runTest :: Transport c => TProxy c -> (THandle c -> IO ()) -> ThreadId -> Expectation
|
|
runTest _ test' server = do
|
|
testSMPClient test' `shouldReturn` ()
|
|
killThread server
|
|
|
|
runClient :: Transport c => TProxy c -> (THandle c -> IO ()) -> Expectation
|
|
runClient _ test' = testSMPClient test' `shouldReturn` ()
|
|
|
|
createAndSecureQueue :: Transport c => THandle c -> SndPublicVerifyKey -> IO (SenderId, RecipientId, RcvPrivateSignKey, RcvDhSecret)
|
|
createAndSecureQueue h sPub = do
|
|
(rPub, rKey) <- C.generateSignatureKeyPair C.SEd448
|
|
(dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
|
|
Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub)
|
|
let dhShared = C.dh' srvDh dhPriv
|
|
Resp "dabc" rId' OK <- signSendRecv h rKey ("dabc", rId, KEY sPub)
|
|
(rId', rId) #== "same queue ID"
|
|
pure (sId, rId, rKey, dhShared)
|
|
|
|
testTiming :: ATransport -> Spec
|
|
testTiming (ATransport t) =
|
|
it "should have similar time for auth error, whether queue exists or not, for all key sizes" $
|
|
smpTest2 t $ \rh sh ->
|
|
mapM_ (testSameTiming rh sh) timingTests
|
|
where
|
|
timingTests :: [(Int, Int, Int)]
|
|
timingTests =
|
|
[ (32, 32, 200),
|
|
(32, 57, 100),
|
|
(57, 32, 200),
|
|
(57, 57, 100)
|
|
]
|
|
timeRepeat n = fmap fst . timeItT . forM_ (replicate n ()) . const
|
|
similarTime t1 t2 = abs (t2 / t1 - 1) < 0.25 `shouldBe` True
|
|
testSameTiming :: Transport c => THandle c -> THandle c -> (Int, Int, Int) -> Expectation
|
|
testSameTiming rh sh (goodKeySize, badKeySize, n) = do
|
|
(rPub, rKey) <- generateKeys goodKeySize
|
|
(dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair'
|
|
Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub)
|
|
let dec = decryptMsgV3 $ C.dh' srvDh dhPriv
|
|
Resp "cdab" _ OK <- signSendRecv rh rKey ("cdab", rId, SUB)
|
|
|
|
(_, badKey) <- generateKeys badKeySize
|
|
-- runTimingTest rh badKey rId "SUB"
|
|
|
|
(sPub, sKey) <- generateKeys goodKeySize
|
|
Resp "dabc" _ OK <- signSendRecv rh rKey ("dabc", rId, KEY sPub)
|
|
|
|
Resp "bcda" _ OK <- signSendRecv sh sKey ("bcda", sId, _SEND "hello")
|
|
Resp "" _ (Msg mId msg) <- tGet1 rh
|
|
(dec mId msg, Right "hello") #== "delivered from queue"
|
|
|
|
runTimingTest sh badKey sId $ _SEND "hello"
|
|
where
|
|
generateKeys = \case
|
|
32 -> C.generateSignatureKeyPair C.SEd25519
|
|
57 -> C.generateSignatureKeyPair C.SEd448
|
|
_ -> error "unsupported key size"
|
|
runTimingTest h badKey qId cmd = do
|
|
timeWrongKey <- timeRepeat n $ do
|
|
Resp "cdab" _ (ERR AUTH) <- signSendRecv h badKey ("cdab", qId, cmd)
|
|
return ()
|
|
timeNoQueue <- timeRepeat n $ do
|
|
Resp "dabc" _ (ERR AUTH) <- signSendRecv h badKey ("dabc", "1234", cmd)
|
|
return ()
|
|
-- (putStrLn . unwords . map show)
|
|
-- [ fromIntegral goodKeySize,
|
|
-- fromIntegral badKeySize,
|
|
-- timeWrongKey,
|
|
-- timeNoQueue,
|
|
-- timeWrongKey / timeNoQueue - 1
|
|
-- ]
|
|
similarTime timeNoQueue timeWrongKey
|
|
|
|
testMessageNotifications :: ATransport -> Spec
|
|
testMessageNotifications (ATransport t) =
|
|
it "should create simplex connection, subscribe notifier and deliver notifications" $ do
|
|
(sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
|
|
(nPub, nKey) <- C.generateSignatureKeyPair C.SEd25519
|
|
smpTest4 t $ \rh sh nh1 nh2 -> do
|
|
(sId, rId, rKey, dhShared) <- createAndSecureQueue rh sPub
|
|
let dec = decryptMsgV3 dhShared
|
|
(rcvNtfPubDhKey, _) <- C.generateKeyPair'
|
|
Resp "1" _ (NID nId' _) <- signSendRecv rh rKey ("1", rId, NKEY nPub rcvNtfPubDhKey)
|
|
Resp "1a" _ (NID nId _) <- signSendRecv rh rKey ("1a", rId, NKEY nPub rcvNtfPubDhKey)
|
|
nId' `shouldNotBe` nId
|
|
Resp "2" _ OK <- signSendRecv nh1 nKey ("2", nId, NSUB)
|
|
Resp "3" _ OK <- signSendRecv sh sKey ("3", sId, _SEND' "hello")
|
|
Resp "" _ (Msg mId1 msg1) <- tGet1 rh
|
|
(dec mId1 msg1, Right "hello") #== "delivered from queue"
|
|
Resp "3a" _ OK <- signSendRecv rh rKey ("3a", rId, ACK mId1)
|
|
Resp "" _ (NMSG _ _) <- tGet1 nh1
|
|
Resp "4" _ OK <- signSendRecv nh2 nKey ("4", nId, NSUB)
|
|
Resp "" _ END <- tGet1 nh1
|
|
Resp "5" _ OK <- signSendRecv sh sKey ("5", sId, _SEND' "hello again")
|
|
Resp "" _ (Msg mId2 msg2) <- tGet1 rh
|
|
Resp "5a" _ OK <- signSendRecv rh rKey ("5a", rId, ACK mId2)
|
|
(dec mId2 msg2, Right "hello again") #== "delivered from queue again"
|
|
Resp "" _ (NMSG _ _) <- tGet1 nh2
|
|
1000 `timeout` tGet @BrokerMsg nh1 >>= \case
|
|
Nothing -> pure ()
|
|
Just _ -> error "nothing else should be delivered to the 1st notifier's TCP connection"
|
|
Resp "6" _ OK <- signSendRecv rh rKey ("6", rId, NDEL)
|
|
Resp "7" _ OK <- signSendRecv sh sKey ("7", sId, _SEND' "hello there")
|
|
Resp "" _ (Msg mId3 msg3) <- tGet1 rh
|
|
(dec mId3 msg3, Right "hello there") #== "delivered from queue again"
|
|
1000 `timeout` tGet @BrokerMsg nh2 >>= \case
|
|
Nothing -> pure ()
|
|
Just _ -> error "nothing else should be delivered to the 2nd notifier's TCP connection"
|
|
|
|
testMsgExpireOnSend :: forall c. Transport c => TProxy c -> Spec
|
|
testMsgExpireOnSend t =
|
|
it "should expire messages that are not received before messageTTL on SEND" $ do
|
|
(sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
|
|
let cfg' = cfg {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 10000}}
|
|
withSmpServerConfigOn (ATransport t) cfg' testPort $ \_ ->
|
|
testSMPClient @c $ \sh -> do
|
|
(sId, rId, rKey, dhShared) <- testSMPClient @c $ \rh -> createAndSecureQueue rh sPub
|
|
let dec = decryptMsgV3 dhShared
|
|
Resp "1" _ OK <- signSendRecv sh sKey ("1", sId, _SEND "hello (should expire)")
|
|
threadDelay 2500000
|
|
Resp "2" _ OK <- signSendRecv sh sKey ("2", sId, _SEND "hello (should NOT expire)")
|
|
testSMPClient @c $ \rh -> do
|
|
Resp "3" _ (Msg mId msg) <- signSendRecv rh rKey ("3", rId, SUB)
|
|
(dec mId msg, Right "hello (should NOT expire)") #== "delivered"
|
|
1000 `timeout` tGet @BrokerMsg rh >>= \case
|
|
Nothing -> return ()
|
|
Just _ -> error "nothing else should be delivered"
|
|
|
|
testMsgExpireOnInterval :: forall c. Transport c => TProxy c -> Spec
|
|
testMsgExpireOnInterval t =
|
|
it "should expire messages that are not received before messageTTL after expiry interval" $ do
|
|
(sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
|
|
let cfg' = cfg {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}}
|
|
withSmpServerConfigOn (ATransport t) cfg' testPort $ \_ ->
|
|
testSMPClient @c $ \sh -> do
|
|
(sId, rId, rKey, _) <- testSMPClient @c $ \rh -> createAndSecureQueue rh sPub
|
|
Resp "1" _ OK <- signSendRecv sh sKey ("1", sId, _SEND "hello (should expire)")
|
|
threadDelay 2500000
|
|
testSMPClient @c $ \rh -> do
|
|
Resp "2" _ OK <- signSendRecv rh rKey ("2", rId, SUB)
|
|
1000 `timeout` tGet @BrokerMsg rh >>= \case
|
|
Nothing -> return ()
|
|
Just _ -> error "nothing should be delivered"
|
|
|
|
testMsgNOTExpireOnInterval :: forall c. Transport c => TProxy c -> Spec
|
|
testMsgNOTExpireOnInterval t =
|
|
it "should NOT expire messages that are not received before messageTTL if expiry interval is large" $ do
|
|
(sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
|
|
let cfg' = cfg {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 10000}}
|
|
withSmpServerConfigOn (ATransport t) cfg' testPort $ \_ ->
|
|
testSMPClient @c $ \sh -> do
|
|
(sId, rId, rKey, dhShared) <- testSMPClient @c $ \rh -> createAndSecureQueue rh sPub
|
|
let dec = decryptMsgV3 dhShared
|
|
Resp "1" _ OK <- signSendRecv sh sKey ("1", sId, _SEND "hello (should NOT expire)")
|
|
threadDelay 2500000
|
|
testSMPClient @c $ \rh -> do
|
|
Resp "2" _ (Msg mId msg) <- signSendRecv rh rKey ("2", rId, SUB)
|
|
(dec mId msg, Right "hello (should NOT expire)") #== "delivered"
|
|
1000 `timeout` tGet @BrokerMsg rh >>= \case
|
|
Nothing -> return ()
|
|
Just _ -> error "nothing else should be delivered"
|
|
|
|
samplePubKey :: C.APublicVerifyKey
|
|
samplePubKey = C.APublicVerifyKey C.SEd25519 "MCowBQYDK2VwAyEAfAOflyvbJv1fszgzkQ6buiZJVgSpQWsucXq7U6zjMgY="
|
|
|
|
sampleDhPubKey :: C.PublicKey 'C.X25519
|
|
sampleDhPubKey = "MCowBQYDK2VuAyEAriy+HcARIhqsgSjVnjKqoft+y6pxrxdY68zn4+LjYhQ="
|
|
|
|
sampleSig :: Maybe C.ASignature
|
|
sampleSig = "e8JK+8V3fq6kOLqco/SaKlpNaQ7i1gfOrXoqekEl42u4mF8Bgu14T5j0189CGcUhJHw2RwCMvON+qbvQ9ecJAA=="
|
|
|
|
syntaxTests :: ATransport -> Spec
|
|
syntaxTests (ATransport t) = do
|
|
it "unknown command" $ ("", "abcd", "1234", ('H', 'E', 'L', 'L', 'O')) >#> ("", "abcd", "1234", ERR $ CMD UNKNOWN)
|
|
describe "NEW" $ do
|
|
it "no parameters" $ (sampleSig, "bcda", "", NEW_) >#> ("", "bcda", "", ERR $ CMD SYNTAX)
|
|
it "many parameters" $ (sampleSig, "cdab", "", (NEW_, ' ', ('\x01', 'A'), samplePubKey, sampleDhPubKey)) >#> ("", "cdab", "", ERR $ CMD SYNTAX)
|
|
it "no signature" $ ("", "dabc", "", (NEW_, ' ', samplePubKey, sampleDhPubKey)) >#> ("", "dabc", "", ERR $ CMD NO_AUTH)
|
|
it "queue ID" $ (sampleSig, "abcd", "12345678", (NEW_, ' ', samplePubKey, sampleDhPubKey)) >#> ("", "abcd", "12345678", ERR $ CMD HAS_AUTH)
|
|
describe "KEY" $ do
|
|
it "valid syntax" $ (sampleSig, "bcda", "12345678", (KEY_, ' ', samplePubKey)) >#> ("", "bcda", "12345678", ERR AUTH)
|
|
it "no parameters" $ (sampleSig, "cdab", "12345678", KEY_) >#> ("", "cdab", "12345678", ERR $ CMD SYNTAX)
|
|
it "many parameters" $ (sampleSig, "dabc", "12345678", (KEY_, ' ', ('\x01', 'A'), samplePubKey)) >#> ("", "dabc", "12345678", ERR $ CMD SYNTAX)
|
|
it "no signature" $ ("", "abcd", "12345678", (KEY_, ' ', samplePubKey)) >#> ("", "abcd", "12345678", ERR $ CMD NO_AUTH)
|
|
it "no queue ID" $ (sampleSig, "bcda", "", (KEY_, ' ', samplePubKey)) >#> ("", "bcda", "", ERR $ CMD NO_AUTH)
|
|
noParamsSyntaxTest "SUB" SUB_
|
|
noParamsSyntaxTest "OFF" OFF_
|
|
noParamsSyntaxTest "DEL" DEL_
|
|
describe "SEND" $ do
|
|
it "valid syntax" $ (sampleSig, "cdab", "12345678", (SEND_, ' ', noMsgFlags, ' ', "hello" :: ByteString)) >#> ("", "cdab", "12345678", ERR AUTH)
|
|
it "no parameters" $ (sampleSig, "abcd", "12345678", SEND_) >#> ("", "abcd", "12345678", ERR $ CMD SYNTAX)
|
|
it "no queue ID" $ (sampleSig, "bcda", "", (SEND_, ' ', noMsgFlags, ' ', "hello" :: ByteString)) >#> ("", "bcda", "", ERR $ CMD NO_ENTITY)
|
|
describe "ACK" $ do
|
|
it "valid syntax" $ (sampleSig, "cdab", "12345678", (ACK_, ' ', "1234" :: ByteString)) >#> ("", "cdab", "12345678", ERR AUTH)
|
|
it "no parameters" $ (sampleSig, "abcd", "12345678", ACK_) >#> ("", "abcd", "12345678", ERR $ CMD SYNTAX)
|
|
it "no queue ID" $ (sampleSig, "bcda", "", (ACK_, ' ', "1234" :: ByteString)) >#> ("", "bcda", "", ERR $ CMD NO_AUTH)
|
|
it "no signature" $ ("", "cdab", "12345678", (ACK_, ' ', "1234" :: ByteString)) >#> ("", "cdab", "12345678", ERR $ CMD NO_AUTH)
|
|
describe "PING" $ do
|
|
it "valid syntax" $ ("", "abcd", "", PING_) >#> ("", "abcd", "", PONG)
|
|
describe "broker response not allowed" $ do
|
|
it "OK" $ (sampleSig, "bcda", "12345678", OK_) >#> ("", "bcda", "12345678", ERR $ CMD UNKNOWN)
|
|
where
|
|
noParamsSyntaxTest :: PartyI p => String -> CommandTag p -> Spec
|
|
noParamsSyntaxTest description cmd = describe description $ do
|
|
it "valid syntax" $ (sampleSig, "abcd", "12345678", cmd) >#> ("", "abcd", "12345678", ERR AUTH)
|
|
it "wrong terminator" $ (sampleSig, "bcda", "12345678", (cmd, '=')) >#> ("", "bcda", "12345678", ERR $ CMD UNKNOWN)
|
|
it "no signature" $ ("", "cdab", "12345678", cmd) >#> ("", "cdab", "12345678", ERR $ CMD NO_AUTH)
|
|
it "no queue ID" $ (sampleSig, "dabc", "", cmd) >#> ("", "dabc", "", ERR $ CMD NO_AUTH)
|
|
(>#>) ::
|
|
Encoding smp =>
|
|
(Maybe C.ASignature, ByteString, ByteString, smp) ->
|
|
(Maybe C.ASignature, ByteString, ByteString, BrokerMsg) ->
|
|
Expectation
|
|
command >#> response = smpServerTest t command `shouldReturn` response
|