mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-09-01 20:18:26 +00:00
270 lines
11 KiB
Haskell
270 lines
11 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE DuplicateRecordFields #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE StandaloneDeriving #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
{-# OPTIONS_GHC -Wno-orphans #-}
|
|
|
|
module CoreTests.StoreLogTests where
|
|
|
|
import Control.Concurrent.STM
|
|
import Control.Monad
|
|
import CoreTests.MsgStoreTests
|
|
import Crypto.Random (ChaChaDRG)
|
|
import qualified Data.ByteString.Char8 as B
|
|
import Data.Either (partitionEithers)
|
|
import qualified Data.List.NonEmpty as L
|
|
import qualified Data.Map.Strict as M
|
|
import qualified Data.X509 as X
|
|
import qualified Data.X509.Validation as XV
|
|
import SMPClient
|
|
import Simplex.FileTransfer.Protocol (FileInfo (..))
|
|
import Simplex.FileTransfer.Server.Store (FileRec (..), FileRecipient (..), FileStoreClass (..), RoundedFileTime, STMFileStore (..))
|
|
import Simplex.FileTransfer.Server.StoreLog (FileStoreLogRecord (..), readWriteFileStore)
|
|
import qualified Simplex.Messaging.Crypto as C
|
|
import Simplex.Messaging.Encoding.String
|
|
import Simplex.Messaging.Protocol
|
|
import Simplex.Messaging.Protocol.Types (ClientNotice (..))
|
|
import Simplex.Messaging.Server.Env.STM (readWriteQueueStore)
|
|
import Simplex.Messaging.Server.MsgStore.Journal
|
|
import Simplex.Messaging.Server.MsgStore.Types
|
|
import Simplex.Messaging.Server.QueueStore
|
|
import Simplex.Messaging.Server.QueueStore.STM (STMQueueStore (..))
|
|
import Simplex.Messaging.Server.QueueStore.Types
|
|
import Simplex.Messaging.Server.StoreLog
|
|
import Simplex.Messaging.SystemTime
|
|
import Simplex.Messaging.Transport (SMPServiceRole (..))
|
|
import Simplex.Messaging.Transport.Credentials (genCredentials)
|
|
import Test.Hspec hiding (fit, it)
|
|
import Util
|
|
|
|
#if defined(dbServerPostgres)
|
|
import Simplex.Messaging.Server.Main
|
|
#endif
|
|
|
|
testPublicAuthKey :: C.APublicAuthKey
|
|
testPublicAuthKey = C.APublicAuthKey C.SEd25519 (C.publicKey "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe")
|
|
|
|
testNtfCreds :: TVar ChaChaDRG -> IO NtfCreds
|
|
testNtfCreds g = do
|
|
(notifierKey, _) <- atomically $ C.generateAuthKeyPair C.SX25519 g
|
|
(k, pk) <- atomically $ C.generateKeyPair @'C.X25519 g
|
|
pure
|
|
NtfCreds
|
|
{ notifierId = EntityId "ijkl",
|
|
notifierKey,
|
|
rcvNtfDhSecret = C.dh' k pk,
|
|
ntfServiceId = Nothing
|
|
}
|
|
|
|
data StoreLogTestCase r s = SLTC {name :: String, saved :: [r], state :: s, compacted :: [r]}
|
|
|
|
type SMPStoreLogTestCase = StoreLogTestCase StoreLogRecord (M.Map RecipientId QueueRec)
|
|
|
|
deriving instance Eq QueueRec
|
|
|
|
deriving instance Eq ServiceRec
|
|
|
|
deriving instance Eq StoreLogRecord
|
|
|
|
deriving instance Eq NtfCreds
|
|
|
|
storeLogTests :: Spec
|
|
storeLogTests =
|
|
forM_ [QMMessaging, QMContact] $ \qm -> do
|
|
g <- runIO C.newRandom
|
|
((rId, qr), ntfCreds, date, sr@ServiceRec {serviceId}) <- runIO $
|
|
(,,,) <$> testNewQueueRec g qm <*> testNtfCreds g <*> getSystemDate <*> newTestServiceRec g
|
|
((rId', qr'), lnkId, qd) <- runIO $ do
|
|
lnkId <- atomically $ EntityId <$> C.randomBytes 24 g
|
|
let qd = (EncDataBytes "fixed data", EncDataBytes "user data")
|
|
q <- testNewQueueRecData g qm (Just (lnkId, qd))
|
|
pure (q, lnkId, qd)
|
|
let pubKey = fst <$> atomically (C.generateAuthKeyPair C.SEd25519 g)
|
|
newKeys <- runIO $ L.fromList <$> sequence [pubKey, pubKey]
|
|
testSMPStoreLog
|
|
("SMP server store log, queueMode = " <> show qm)
|
|
[ SLTC
|
|
{ name = "create new queue",
|
|
saved = [CreateQueue rId qr],
|
|
compacted = [CreateQueue rId qr],
|
|
state = M.fromList [(rId, qr)]
|
|
},
|
|
SLTC
|
|
{ name = "create new queue with link data",
|
|
saved = [CreateQueue rId' qr'],
|
|
compacted = [CreateQueue rId' qr'],
|
|
state = M.fromList [(rId', qr')]
|
|
},
|
|
SLTC
|
|
{ name = "create new queue, add link data",
|
|
saved = [CreateQueue rId' qr' {queueData = Nothing}, CreateLink rId' lnkId qd],
|
|
compacted = [CreateQueue rId' qr'],
|
|
state = M.fromList [(rId', qr')]
|
|
},
|
|
SLTC
|
|
{ name = "create new queue with link data, delete data",
|
|
saved = [CreateQueue rId' qr', DeleteLink rId'],
|
|
compacted = [CreateQueue rId' qr' {queueData = Nothing}],
|
|
state = M.fromList [(rId', qr' {queueData = Nothing})]
|
|
},
|
|
SLTC
|
|
{ name = "secure queue",
|
|
saved = [CreateQueue rId qr, SecureQueue rId testPublicAuthKey],
|
|
compacted = [CreateQueue rId qr {senderKey = Just testPublicAuthKey}],
|
|
state = M.fromList [(rId, qr {senderKey = Just testPublicAuthKey})]
|
|
},
|
|
SLTC
|
|
{ name = "create and delete queue",
|
|
saved = [CreateQueue rId qr, DeleteQueue rId],
|
|
compacted = [],
|
|
state = M.fromList []
|
|
},
|
|
SLTC
|
|
{ name = "create queue and add notifier",
|
|
saved = [CreateQueue rId qr, AddNotifier rId ntfCreds],
|
|
compacted = [CreateQueue rId qr {notifier = Just ntfCreds}],
|
|
state = M.fromList [(rId, qr {notifier = Just ntfCreds})]
|
|
},
|
|
SLTC
|
|
{ name = "create queue, add notifier, register and associate notification service",
|
|
saved = [CreateQueue rId qr, AddNotifier rId ntfCreds, NewService sr, QueueService rId (ASP SNotifierService) (Just serviceId)],
|
|
compacted = [NewService sr, CreateQueue rId qr {notifier = Just ntfCreds {ntfServiceId = Just serviceId}}],
|
|
state = M.fromList [(rId, qr {notifier = Just ntfCreds {ntfServiceId = Just serviceId}})]
|
|
},
|
|
SLTC
|
|
{ name = "delete notifier",
|
|
saved = [CreateQueue rId qr, AddNotifier rId ntfCreds, DeleteNotifier rId],
|
|
compacted = [CreateQueue rId qr],
|
|
state = M.fromList [(rId, qr)]
|
|
},
|
|
SLTC
|
|
{ name = "update time",
|
|
saved = [CreateQueue rId qr, UpdateTime rId date],
|
|
compacted = [CreateQueue rId qr {updatedAt = Just date}],
|
|
state = M.fromList [(rId, qr {updatedAt = Just date})]
|
|
},
|
|
SLTC
|
|
{ name = "update recipient keys",
|
|
saved = [CreateQueue rId qr, UpdateKeys rId newKeys],
|
|
compacted = [CreateQueue rId qr {recipientKeys = newKeys}],
|
|
state = M.fromList [(rId, qr {recipientKeys = newKeys})]
|
|
}
|
|
]
|
|
|
|
newTestServiceRec :: TVar ChaChaDRG -> IO ServiceRec
|
|
newTestServiceRec g = do
|
|
serviceId <- atomically $ EntityId <$> C.randomBytes 24 g
|
|
(_, cert) <- genCredentials g Nothing (0, 2400) "ntf.example.com"
|
|
serviceCreatedAt <- getSystemDate
|
|
pure
|
|
ServiceRec
|
|
{ serviceId,
|
|
serviceRole = SRNotifier,
|
|
serviceCert = X.CertificateChain [cert],
|
|
serviceCertHash = XV.getFingerprint cert X.HashSHA256,
|
|
serviceCreatedAt
|
|
}
|
|
|
|
testSMPStoreLog :: String -> [SMPStoreLogTestCase] -> Spec
|
|
testSMPStoreLog testSuite tests =
|
|
describe testSuite $ forM_ tests $ \t@SLTC {name, saved} -> it name $ do
|
|
l <- openWriteStoreLog False testStoreLogFile
|
|
mapM_ (writeStoreLogRecord l) saved
|
|
closeStoreLog l
|
|
replicateM_ 3 $ testReadWrite t
|
|
#if defined(dbServerPostgres)
|
|
(sCnt, qCnt) <- importStoreLogToDatabase "tests/tmp/" testStoreLogFile testStoreDBOpts
|
|
fromIntegral (sCnt + qCnt) `shouldBe` length (compacted t)
|
|
imported <- B.readFile $ testStoreLogFile <> ".bak"
|
|
(sCnt', qCnt') <- exportDatabaseToStoreLog "tests/tmp/" testStoreDBOpts testStoreLogFile
|
|
sCnt' `shouldBe` fromIntegral sCnt
|
|
qCnt' `shouldBe` fromIntegral qCnt
|
|
exported <- B.readFile testStoreLogFile
|
|
imported `shouldBe` exported
|
|
#endif
|
|
where
|
|
testReadWrite SLTC {compacted, state} = do
|
|
st <- newMsgStore $ testJournalStoreCfg MQStoreCfg
|
|
l <- readWriteQueueStore True (mkQueue st True) testStoreLogFile $ stmQueueStore st
|
|
storeState st `shouldReturn` state
|
|
closeStoreLog l
|
|
([], compacted') <- partitionEithers . map strDecode . B.lines <$> B.readFile testStoreLogFile
|
|
compacted' `shouldBe` compacted
|
|
storeState :: JournalMsgStore 'QSMemory -> IO (M.Map RecipientId QueueRec)
|
|
storeState st = M.mapMaybe id <$> (readTVarIO (queues $ stmQueueStore st) >>= mapM (readTVarIO . queueRec))
|
|
|
|
type FileRecState = (FileInfo, RoundedFileTime, Maybe RoundedFileTime, ServerEntityStatus)
|
|
|
|
type XFTPStoreLogTestCase = StoreLogTestCase FileStoreLogRecord (M.Map SenderId FileRecState)
|
|
|
|
deriving instance Eq FileInfo
|
|
|
|
deriving instance Eq FileRecipient
|
|
|
|
deriving instance Eq FileStoreLogRecord
|
|
|
|
testFileStoreLogFile :: FilePath
|
|
testFileStoreLogFile = "tests/tmp/xftp-server-store.log"
|
|
|
|
fileStoreLogTests :: Spec
|
|
fileStoreLogTests = do
|
|
g <- runIO C.newRandom
|
|
(sndKey, _) <- runIO $ atomically $ C.generateAuthKeyPair C.SEd25519 g
|
|
sId <- runIO $ atomically $ EntityId <$> C.randomBytes 24 g
|
|
let file = FileInfo {sndKey, size = 16384, digest = "12345678"}
|
|
createdAt = RoundedSystemTime 1600000000
|
|
expiresAt = RoundedSystemTime 1600172800
|
|
blocked = BlockingInfo {reason = BRSpam, notice = Nothing}
|
|
blockedWithNotice = BlockingInfo {reason = BRContent, notice = Just ClientNotice {ttl = Just 86400}}
|
|
testXFTPStoreLog
|
|
"XFTP server store log"
|
|
[ SLTC
|
|
{ name = "create file",
|
|
saved = [AddFile sId file createdAt (Just expiresAt) EntityActive],
|
|
compacted = [AddFile sId file createdAt (Just expiresAt) EntityActive],
|
|
state = M.fromList [(sId, (file, createdAt, Just expiresAt, EntityActive))]
|
|
},
|
|
SLTC
|
|
{ name = "create file without expiration",
|
|
saved = [AddFile sId file createdAt Nothing EntityActive],
|
|
compacted = [AddFile sId file createdAt Nothing EntityActive],
|
|
state = M.fromList [(sId, (file, createdAt, Nothing, EntityActive))]
|
|
},
|
|
SLTC
|
|
{ name = "create and block file",
|
|
saved = [AddFile sId file createdAt (Just expiresAt) EntityActive, BlockFile sId blocked],
|
|
compacted = [AddFile sId file createdAt (Just expiresAt) (EntityBlocked blocked)],
|
|
state = M.fromList [(sId, (file, createdAt, Just expiresAt, EntityBlocked blocked))]
|
|
},
|
|
SLTC
|
|
{ name = "create and block file with notice",
|
|
saved = [AddFile sId file createdAt (Just expiresAt) EntityActive, BlockFile sId blockedWithNotice],
|
|
compacted = [AddFile sId file createdAt (Just expiresAt) (EntityBlocked blockedWithNotice)],
|
|
state = M.fromList [(sId, (file, createdAt, Just expiresAt, EntityBlocked blockedWithNotice))]
|
|
}
|
|
]
|
|
|
|
testXFTPStoreLog :: String -> [XFTPStoreLogTestCase] -> Spec
|
|
testXFTPStoreLog testSuite tests =
|
|
describe testSuite $ forM_ tests $ \t@SLTC {name, saved} -> it name $ do
|
|
l <- openWriteStoreLog False testFileStoreLogFile
|
|
mapM_ (writeStoreLogRecord l) saved
|
|
closeStoreLog l
|
|
replicateM_ 3 $ testReadWrite t
|
|
where
|
|
testReadWrite SLTC {compacted, state} = do
|
|
st <- newFileStore () :: IO STMFileStore
|
|
l <- readWriteFileStore testFileStoreLogFile st
|
|
storeState st `shouldReturn` state
|
|
closeStoreLog l
|
|
([], compacted') <- partitionEithers . map strDecode . B.lines <$> B.readFile testFileStoreLogFile
|
|
compacted' `shouldBe` compacted
|
|
storeState :: STMFileStore -> IO (M.Map SenderId FileRecState)
|
|
storeState st = readTVarIO (files st) >>= mapM fileState
|
|
fileState FileRec {fileInfo, createdAt, expiresAt, fileStatus} = do
|
|
status <- readTVarIO fileStatus
|
|
pure (fileInfo, createdAt, expiresAt, status)
|