dandri/simplexmq
1
0 Fork 0
mirror of https://github.com/simplex-chat/simplexmq.git synced 2026-10-23 19:32:26 +00:00
Code Issues Packages Projects Releases Wiki Activity

Merge branch 'sh/fix-proxy-leak' into sh/fix-proxy-mesh

Browse Source 
# Conflicts:
#	src/Simplex/Messaging/Server.hs
#	src/Simplex/Messaging/Server/Env/STM.hs
#	tests/SMPProxyTests.hs
This commit is contained in:
shum committed 2026-10-16 15:33:58 +00:00
2 parents 987899583e 826c45f543
commit 344fd969ab
57 files changed
+1749 -3413
Download Patch File Download Diff File Expand all files Collapse all files

No files matched your search

.github/workflows/build.yml
+8
View File
@@ -372,6 +372,14 @@ jobs:
dist-postgres
key: ${{ steps.keys.outputs.dist }}-${{ env.opt }}-${{ env.branch }}-${{ github.sha }}
- name: Increase PostgreSQL connection limit
if: matrix.should_run == true && matrix.arch == 'x86-64'
shell: bash
run: |
docker exec ${{ job.services.postgres.id }} psql -U postgres -c "ALTER SYSTEM SET max_connections = 500"
docker restart ${{ job.services.postgres.id }}
timeout 60 sh -c 'until docker exec ${{ job.services.postgres.id }} pg_isready -U postgres; do sleep 1; done'
- name: Test
if: matrix.should_run == true && matrix.arch == 'x86-64'
timeout-minutes: 120
contributing/PROJECT.md
+8
View File
@@ -97,6 +97,14 @@ cabal test --test-option=--match="/SMP client agent/functional API/"
Tests require PostgreSQL running on `localhost:5432` when using `-fserver_postgres` or `-fclient_postgres`.
Tests run in parallel, one job per processor. With 4 jobs, the tests open up to 220 PostgreSQL connections with `-fserver_postgres` and up to 420 with both flags, while the default limit is 100. Raise the limit and restart PostgreSQL:
```bash
psql -U postgres -c "ALTER SYSTEM SET max_connections = 500"
```
With more than 4 processors, also limit the jobs: `--test-option=--jobs=4`.
Test files are in `tests/` with structure:
- `Test.hs`: Main runner
- `AgentTests/`: Agent protocol and connection tests
docs/smp-server-db-load.md
+1 -3
View File
@@ -144,9 +144,7 @@ space, so it is workload-dependent; `fillfactor = 80` reached 100% for this frac
larger share of queues at once would need a lower value. `fillfactor` applies to pages rewritten after
the change, so the ratio ramps up as the heap turns over, or immediately after `pg_repack`.
Dropping the index regresses the deprecated journal message store's expiration (`foldRecentQueueRecs`,
`Journal.hs:434`) to a sequential scan; this is accepted because that store is being retired. The
Postgres message store does not read `updated_at`.
The Postgres message store does not read `updated_at`, so no query depends on the dropped index.
Autovacuum reloptions applied by the migration:
plans/2026-10-07-parallel-tests.md
+80
View File
@@ -0,0 +1,80 @@
# Parallel test execution
Every test gets its own ports, directory and Postgres schemas, so hspec runs
the tree concurrently in one process with `parallel` and `--jobs`.
## Decisions
- `Util` defines the test environment:
```haskell
data TestEnv = TestEnv
{ testNo :: Int,
portBase :: Int
}
type HasTestEnv = (?testEnv :: TestEnv)
```
- `Util.it`, `fit` and `xit` take `HasTestEnv => a`. The test wrapper
creates the environment for each attempt, so a CI retry gets fresh ports,
directory and schemas.
- Environment creation:
- `testNo` from a counter, never reused in a run.
- `portBase` from a pool `[10000, 10010 .. 19990]`, returned after the test.
- directory `tests/tmp/<testNo>` with `xftp-sender-files` and
`xftp-recipient-files`, removed after the test.
- Fixture constants become `HasTestEnv =>` values:
- ports: offsets from `portBase`
| offset | fixture |
|--------|-----------------|
| 1 | `testPort` |
| 2 | `testPort2` |
| 3 | `ntfTestPort` |
| 4 | `ntfTestPort2` |
| 5 | `apnsTestPort` |
| 6 | `xftpTestPort` |
| 7 | `xftpTestPort2` |
- server addresses: built from the ports.
- files: in the test directory.
- Postgres schemas: `test<testNo>_<name>`.
- Functions that use fixtures gain `HasTestEnv` in their signatures.
- `withXFTPServerCfg` creates the server files directory.
- Removed hooks:
- `tests/tmp` creation and removal per test.
- per-test database recreation and schema drops.
- XFTP `testBracket` and server files directory hooks.
- `around (withMsgStore cfg)`: each test opens its store.
- `tests/tmp` is cleared before the run and removed after it.
- Postgres databases are created before the run and dropped after it.
- Schema dumps and the Ntf CLI test keep the production schema names and
recreate the database per test.
- Sequential, after all parallel tests:
- SMP proxy tests that change the number of capabilities.
- XFTP CLI tests: `withArgs` and stdout capture are process-wide.
- server CLI tests: the same, and fixed ports.
- tests with wall-clock assertions:
- retry intervals
- AUTH error timing
- agent user network info
- agent SMP queue info
- agent client notices
- schema dumps.
- The SQLite agent schema dump resets `tests/tmp` after each item.
- `createRandomFile_` in the XFTP agent tests writes random bytes directly.
- Test suite `-with-rtsopts=-N1` becomes `-with-rtsopts=-N`.
- `it "..." . f $ x` becomes `it "..." $ f $ x` where `f` or `x` uses the
environment.
## Mechanics
- `tests/Util.hs`: environment, wrapper, `it`, `fit`, `xit`,
`eventuallyRemove`, sender and recipient directories.
- `tests/Test.hs`: `parallel` tree, sequential tail, `tests/tmp` and database
brackets around `hspec`.
- `tests/SMPClient.hs`, `tests/SMPAgentClient.hs`, `tests/NtfClient.hs`,
`tests/XFTPClient.hs`, `tests/Fixtures.hs`: fixtures from the environment.
- Test modules: signatures, literal paths and ports, removed hooks.
- `simplexmq.cabal`: `-N`.
simplexmq.cabal
+1 -3
View File
@@ -284,8 +284,6 @@ library
Simplex.Messaging.Server.Main.Init
Simplex.Messaging.Server.Web
Simplex.Messaging.Server.MsgStore
Simplex.Messaging.Server.MsgStore.Journal
Simplex.Messaging.Server.MsgStore.Journal.SharedLock
Simplex.Messaging.Server.MsgStore.STM
Simplex.Messaging.Server.MsgStore.Types
Simplex.Messaging.Server.Names
@@ -602,7 +600,7 @@ test-suite simplexmq-test
default-extensions:
StrictData
-- add -fhpc to ghc-options to run tests with coverage
ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts "-with-rtsopts=-A64M -N1"
ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts "-with-rtsopts=-A64M -N"
build-depends:
base
, aeson
src/Simplex/FileTransfer/Agent.hs
+7 -4
View File
@@ -279,6 +279,7 @@ retryOnError name loop done e = do
rcvWorkerInternalError :: AgentClient -> DBRcvFileId -> RcvFileId -> Maybe RcvFileId -> Maybe FilePath -> AgentErrorType -> AM ()
rcvWorkerInternalError c rcvFileId rcvFileEntityId redirectEntityId_ tmpPath err = do
liftIO $ throwWhenInactive c
lift $ forM_ tmpPath (removePath <=< toFSFilePath)
withStore' c $ \db -> updateRcvFileError db rcvFileId (show err)
notify c (fromMaybe rcvFileEntityId redirectEntityId_) (RFERR err)
@@ -318,9 +319,6 @@ runXFTPRcvLocalWorker c Worker {doWork} = do
withStore' c (`updateRcvFileComplete` rcvFileId)
Just RcvFileRedirect {redirectFileInfo, redirectDbId} -> do
let RedirectFileInfo {size = redirectSize, digest = redirectDigest} = redirectFileInfo
lift $ forM_ tmpPath (removePath <=< toFSFilePath)
liftIO $ waitUntilForeground c
withStore' c (`updateRcvFileComplete` rcvFileId)
-- proceed with redirect
yaml <- liftError (FILE . FILE_IO . show) (CF.readFile $ CryptoFile fsSavePath cfArgs) `allFinally` (lift $ toFSFilePath fsSavePath >>= removePath)
next@FileDescription {chunks = nextChunks} <- case strDecode (LB.toStrict yaml) of
@@ -330,9 +328,12 @@ runXFTPRcvLocalWorker c Worker {doWork} = do
| dstSize /= redirectSize -> throwE . FILE $ REDIRECT "size mismatch"
| dstDigest /= redirectDigest -> throwE . FILE $ REDIRECT "digest mismatch"
| otherwise -> pure fd
liftIO $ waitUntilForeground c
-- register and download chunks from the actual file
withStore c $ \db -> updateRcvFileRedirect db redirectDbId next
withStore c $ \db -> updateRcvFileComplete db rcvFileId >> updateRcvFileRedirect db redirectDbId next
forM_ nextChunks (downloadChunk c)
flip catchAllErrors (\e -> logError $ "XFTP rcv worker error: " <> tshow e) $
lift $ forM_ tmpPath (removePath <=< toFSFilePath)
where
getChunkPaths :: [RcvFileChunk] -> AM [FilePath]
getChunkPaths [] = pure []
@@ -512,6 +513,7 @@ runXFTPSndPrepareWorker c Worker {doWork} = do
sndWorkerInternalError :: AgentClient -> DBSndFileId -> SndFileId -> Maybe FilePath -> AgentErrorType -> AM ()
sndWorkerInternalError c sndFileId sndFileEntityId prefixPath err = do
liftIO $ throwWhenInactive c
lift . forM_ prefixPath $ removePath <=< toFSFilePath
withStore' c $ \db -> updateSndFileError db sndFileId (show err)
notify c sndFileEntityId $ SFERR err
@@ -733,6 +735,7 @@ runXFTPDelWorker c srv Worker {doWork} = do
delWorkerInternalError :: AgentClient -> Int64 -> AgentErrorType -> AM ()
delWorkerInternalError c deletedSndChunkReplicaId e = do
liftIO $ throwWhenInactive c
withStore' c $ \db -> deleteDeletedSndChunkReplica db deletedSndChunkReplicaId
notify c "" $ SFERR e
src/Simplex/Messaging/Agent.hs
+6 -6
View File
@@ -2360,9 +2360,9 @@ runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do
-- we may add more statistics special to queue rotation later on,
-- not accounting secure during rotation for now:
-- atomically $ incSMPServerStat c userId server connSecured
withStore' c $ \db -> setRcvQueueStatus db rq' Secured
rq1' <- withStore' c $ \db -> setRcvQueueStatus db rq' Secured >> setRcvSwitchStatus db rq1 (Just RSSendingQUSE)
void . enqueueMessages c cData sqs SMP.noMsgFlags $ QUSE [((server, sndId), True)]
rq1' <- withStore' c $ \db -> setRcvSwitchStatus db rq1 (Just RSSendingQUSE) <* deleteCommand db cmdId
withStore' c (`deleteCommand` cmdId)
let rqs' = updatedQs rq1' rqs
conn' = DuplexConnection cData rqs' sqs
cStats <- connectionStats c conn'
@@ -4118,15 +4118,15 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar
withStore' c $ \db -> copyPendingSndDeliveries db sq sq2
enqueueCommand c "" connId (Just $ qServer sq2) $ AInternalCommand $ ICQSndSecure (snd $ qAddress sq2)
pure SSSecuringQueue
else do
let sqInfo' = (sqInfo :: SMPQueueInfo) {queueAddress = queueAddress {dhPublicKey}}
void . enqueueMessages c cData' sqs SMP.noMsgFlags $ QKEY [(sqInfo', C.toPublic sndPrivateKey)]
pure SSSendingQKEY
else pure SSSendingQKEY
sq1 <- withStore' c $ \db -> setSndSwitchStatus db sq $ Just swchStatus
let sqs'' = updatedQs sq1 sqs' <> [sq2]
conn' = DuplexConnection cData' rqs sqs''
cStats <- connectionStats c conn'
notify $ SWITCH QDSnd SPStarted cStats
when (connAgentVersion < rpcAddressSMPAgentVersion) $ do
let sqInfo' = (sqInfo :: SMPQueueInfo) {queueAddress = queueAddress {dhPublicKey}}
void . enqueueMessages c cData' sqs SMP.noMsgFlags $ QKEY [(sqInfo', C.toPublic sndPrivateKey)]
_ -> qError "QADD: won't delete all snd queues in connection"
_ -> qError "QADD: replaced queue address is not found in connection"
_ -> throwE $ AGENT A_VERSION
src/Simplex/Messaging/Agent/Client.hs
-1
View File
@@ -34,7 +34,6 @@ module Simplex.Messaging.Agent.Client
withInvLock,
withLockMap,
withLocksMap,
getMapLock,
ipAddressProtected,
closeAgentClient,
closeProtocolServerClients,
src/Simplex/Messaging/Agent/Lock.hs
-1
View File
@@ -6,7 +6,6 @@ module Simplex.Messaging.Agent.Lock
withLock',
withGetLock,
withGetLocks,
getPutLock,
)
where
src/Simplex/Messaging/Agent/Store/Postgres/Migrations/agent_postgres_schema.sql
-5
View File
@@ -1,5 +1,3 @@
SET statement_timeout = 0;
SET lock_timeout = 0;
SET idle_in_transaction_session_timeout = 0;
@@ -1531,6 +1529,3 @@ ALTER TABLE ONLY smp_agent_test_protocol_schema.snd_queues
ALTER TABLE ONLY smp_agent_test_protocol_schema.snd_queues
ADD CONSTRAINT snd_queues_host_port_fkey FOREIGN KEY (host, port) REFERENCES smp_agent_test_protocol_schema.servers(host, port) ON UPDATE CASCADE ON DELETE RESTRICT;
src/Simplex/Messaging/Notifications/Server/Store/ntf_server_schema.sql
-7
View File
@@ -1,6 +1,3 @@
SET statement_timeout = 0;
SET lock_timeout = 0;
SET idle_in_transaction_session_timeout = 0;
@@ -310,7 +307,3 @@ ALTER TABLE ONLY ntf_server.subscriptions
ALTER TABLE ONLY ntf_server.subscriptions
ADD CONSTRAINT subscriptions_token_id_fkey FOREIGN KEY (token_id) REFERENCES ntf_server.tokens(token_id) ON UPDATE RESTRICT ON DELETE CASCADE;
src/Simplex/Messaging/Server.hs
+83 -81
View File
@@ -33,9 +33,6 @@ module Simplex.Messaging.Server
( runSMPServer,
runSMPServerBlocking,
controlPortAuth,
importMessages,
exportMessages,
printMessageStats,
disconnectTransport,
verifyCmdAuthorization,
dummyVerifyCmd,
@@ -98,7 +95,7 @@ import Network.Socket (ServiceName, Socket, socketToHandle)
import qualified Network.TLS as TLS
import Numeric.Natural (Natural)
import Simplex.Messaging.Agent.Lock
import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClient (thParams), ProtocolClientConfig (..), ProtocolClientError (..), SMPClient, SMPClientError, clientHandlers, closeTimedOutClient, forwardSMPTransmission, smpProxyError, temporaryClientError)
import Simplex.Messaging.Client (NetworkConfig (..), NetworkRequestMode (..), ProtocolClient (thParams), ProtocolClientConfig (..), ProtocolClientError (..), SMPClient, SMPClientError, clientHandlers, closeTimedOutClient, forwardSMPTransmission, netTimeoutInt, smpProxyError, temporaryClientError)
import Simplex.Messaging.Client.Agent (OwnServer, SMPClientAgent (..), SMPClientAgentConfig (..), SMPClientAgentEvent (..), closeSMPClientAgent, getSMPServerClient'', isOwnServer, lookupSMPServerClient, getConnectedSMPServerClient)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding
@@ -108,7 +105,6 @@ import Simplex.Messaging.Server.Control
import Simplex.Messaging.Server.Env.STM as Env
import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.Server.MsgStore
import Simplex.Messaging.Server.MsgStore.Journal (JournalMsgStore, JournalQueue (..), getJournalQueueMessages)
import Simplex.Messaging.Server.Names (NamesEnv, closeNamesEnv, resolveName)
import Simplex.Messaging.Server.MsgStore.STM
import Simplex.Messaging.Server.MsgStore.Types
@@ -116,6 +112,7 @@ import Simplex.Messaging.Server.NtfStore
import Simplex.Messaging.Server.Prometheus
import Simplex.Messaging.Server.QueueStore
import Simplex.Messaging.Server.QueueStore.QueueInfo
import Simplex.Messaging.Server.QueueStore.STM (withLoadedQueues)
import Simplex.Messaging.Server.QueueStore.Types
import Simplex.Messaging.Server.Stats
import Simplex.Messaging.Server.StoreLog (foldLogLines)
@@ -145,7 +142,7 @@ import GHC.Conc.Sync (threadLabel)
#endif
#if defined(dbServerPostgres)
import Simplex.Messaging.Server.MsgStore.Postgres (exportDbMessages, getDbMessageStats)
import Simplex.Messaging.Server.MsgStore.Postgres (getDbMessageStats)
#endif
-- | Runs an SMP server using passed configuration.
@@ -1212,7 +1209,23 @@ sendAfterDelay c@Client {sndQ, clientTHParams = THandleParams {sessionId}} stats
| otherwise = write
where
write = atomically $ writeTBQueue sndQ rs
microseconds (MkSystemTime s ns) = s * 1000000 + fromIntegral (ns `div` 1000)
updateSlotWaitStats :: ServerStats -> SystemTime -> Bool -> IO ()
updateSlotWaitStats ServerStats {cmdSlotWaits, cmdSlotWaitMs, cmdSlotWaitMaxMs, cmdSlotWaitTimeouts} since taken = do
waitMs <- fromIntegral . (`div` 1000) . subtract (microseconds since) . microseconds <$> getSystemTime
incStat cmdSlotWaits
atomicModifyIORef'_ cmdSlotWaitMs (+ waitMs)
atomicModifyIORef'_ cmdSlotWaitMaxMs (max waitMs)
unless taken $ incStat cmdSlotWaitTimeouts
rslvTooManyRequests :: BrokerMsg
rslvTooManyRequests = ERR $ NAME $ RESOLVER "too many requests"
forwardedCmdWait :: ServerConfig s -> Int
forwardedCmdWait = (`netTimeoutInt` NRMBackground) . tcpTimeout . networkConfig . smpCfg . smpAgentCfg
microseconds :: SystemTime -> Int64
microseconds (MkSystemTime s ns) = s * 1000000 + fromIntegral (ns `div` 1000)
send :: Transport c => MVar (THandleSMP c 'TServer) -> Client s -> IO ()
send th c@Client {sndQ, msgQ, clientTHParams = THandleParams {sessionId}} = do
@@ -1500,25 +1513,49 @@ client
Nothing -> inc False pRequests >> inc False pErrorsConnect $> Just (ERR $ PROXY NO_SESSION)
where
forkProxiedCmd :: M s BrokerMsg -> M s (Maybe BrokerMsg)
forkProxiedCmd = forkCmd serverClientConcurrency corrId (EntityId sessId)
forkProxiedCmd = forkCmd serverClientConcurrency corrId (EntityId sessId) (ERR $ smpProxyError PCEResponseTimeout)
reserve maxFwds v = stateTVar v $ \fwds -> case M.lookup sessId fwds of
Just n | n >= maxFwds -> (False, fwds)
n_ -> (True, M.insert sessId (maybe 1 (+ 1) n_) fwds)
release v = modifyTVar' v $ M.update (\n -> if n > 1 then Just (n - 1) else Nothing) sessId
-- Run a slow command on a thread
forkCmd :: (ServerConfig s -> Int) -> CorrId -> EntityId -> M s BrokerMsg -> M s (Maybe a)
forkCmd concurrency corrId entId cmdAction = do
bracket_ wait signal . forkClient clnt (B.unpack $ "client $" <> encode sessionId <> " cmd") $
-- commands MUST be processed under a reasonable timeout or the client would halt
cmdAction >>= \t -> atomically $ writeTBQueue sndQ ([(corrId, entId, t)], [])
-- Run a slow command on a thread, responding with timeoutErr if it was not started before the client timeout
forkCmd :: (ServerConfig s -> Int) -> CorrId -> EntityId -> BrokerMsg -> M s BrokerMsg -> M s (Maybe a)
forkCmd concurrency corrId entId timeoutErr cmdAction =
-- commands MUST be processed under a reasonable timeout or the client would halt
forkCmd_ concurrency maxClientCmdWait (sendResp timeoutErr) $ cmdAction >>= sendResp
where
sendResp t = atomically $ writeTBQueue sndQ ([(corrId, entId, t)], [])
-- Run a slow command on a thread that sends its response
forkCmd_ :: (ServerConfig s -> Int) -> (ServerConfig s -> Int) -> M s () -> M s () -> M s (Maybe a)
forkCmd_ concurrency waitTimeout onTimeout cmd = do
let label = B.unpack $ "client $" <> encode sessionId <> " cmd"
-- Exceptions are masked so the slot is never lost between taking it and starting the thread.
-- The thread frees the slot when the command finishes; the caller frees it only if forking failed.
mask $ \restore ->
ifM
wait
(forkClient clnt label (restore cmd `finally` signal) `onException` signal)
(restore onTimeout)
pure Nothing
where
-- Takes a free slot at once if there is one. Otherwise waits for a slot until the client
-- timeout, after which the client no longer expects the response.
-- Other commands of this client are not processed while it waits.
wait = do
limit <- asks (concurrency . config)
atomically $ do
used <- readTVar procThreads
when (used >= limit) retry
writeTVar procThreads $! used + 1
ifM (atomically $ takeSlot limit) (pure True) $ do
clientTimeout <- asks $ waitTimeout . config
waitStarted <- liftIO getSystemTime
expired <- liftIO $ registerDelay clientTimeout
taken <- atomically $ ifM (takeSlot limit) (pure True) (ifM (readTVar expired) (pure False) retry)
stats <- asks serverStats
liftIO $ updateSlotWaitStats stats waitStarted taken
pure taken
takeSlot limit = do
used <- readTVar procThreads
let free = used < limit
when free $ writeTVar procThreads $! used + 1
pure free
signal = atomically $ modifyTVar' procThreads (\t -> t - 1)
rslvNamesEnv :: M s (Maybe NamesEnv)
rslvNamesEnv = do
@@ -1528,7 +1565,7 @@ client
Nothing -> incStat (rslvDisabled st) $> Nothing
Just nenv -> pure (Just nenv)
-- Runs on a forked thread so RSLV does not block other commands;
-- concurrency is limited by serverResolverConcurrency in forkCmd.
-- concurrency is limited in forkCmd by serverClientConcurrency for direct and serverResolverConcurrency for forwarded RSLV.
resolveNameMsg :: VersionSMP -> NamesEnv -> NameQuery -> M s BrokerMsg
resolveNameMsg v nenv q = do
st <- asks (rslvStats . serverStats)
@@ -1558,7 +1595,7 @@ client
Cmd SProxyService (RFWD encBlock) -> (response . (corrId, NoEntity,) =<<) <$> processForwardedCommand encBlock
Cmd SResolver (RSLV d) -> rslvNamesEnv >>= \case
Nothing -> pure $ response (corrId, NoEntity, ERR (NAME NO_RESOLVER))
Just nenv -> forkCmd serverResolverConcurrency corrId NoEntity (resolveNameMsg (thVersion thParams') nenv d)
Just nenv -> forkCmd serverClientConcurrency corrId NoEntity rslvTooManyRequests (resolveNameMsg (thVersion thParams') nenv d)
Cmd SSenderLink command -> case command of
LKEY k -> withQueue $ \q qr -> checkMode QMMessaging qr $ secureQueue_ q k $>> getQueueLink_ q qr
LGET -> withQueue $ \q qr -> checkContact qr $ getQueueLink_ q qr
@@ -2194,9 +2231,12 @@ client
Right t''@(_, (corrId', entId', cmd')) -> case cmd' of
Cmd SResolver (RSLV d) -> lift $ rslvNamesEnv >>= \case
Nothing -> pure $ Just (corrId', entId', ERR (NAME NO_RESOLVER))
Just nenv -> forkCmd serverResolverConcurrency corrId NoEntity $ do
msg <- resolveNameMsg (thVersion clntTHParams) nenv d
either ERR id <$> runExceptT (encodeResp (corrId', entId', msg))
Just nenv -> do
let sendResolved msg = do
rres <- either ERR id <$> runExceptT (encodeResp (corrId', entId', msg))
atomically $ writeTBQueue sndQ ([(corrId, NoEntity, rres)], [])
forkCmd_ serverResolverConcurrency forwardedCmdWait (sendResolved rslvTooManyRequests) $
resolveNameMsg (thVersion clntTHParams) nenv d >>= sendResolved
-- INTERNAL because processCommand never returns Nothing for sender commands;
-- `fst` drops the empty message only returned for SUB.
_ -> Just . maybe (corrId', entId', ERR INTERNAL) fst <$> lift (processCommand Nothing (Right (M.empty, M.empty, M.empty)) t'')
@@ -2317,40 +2357,27 @@ randomId = fmap EntityId . randomId'
saveServerMessages :: Bool -> MsgStore s -> IO ()
saveServerMessages drainMsgs ms = case ms of
StoreMemory STMMsgStore {storeConfig = STMStoreConfig {storePath}} -> case storePath of
Just f -> exportMessages False ms f drainMsgs
StoreMemory ms'@STMMsgStore {storeConfig = STMStoreConfig {storePath}} -> case storePath of
Just f -> exportMessages ms' f drainMsgs
Nothing -> logNote "undelivered messages are not saved"
StoreJournal _ -> logNote "closed journal message storage"
#if defined(dbServerPostgres)
StoreDatabase _ -> logNote "closed postgres message storage"
#endif
exportMessages :: forall s. MsgStoreClass s => Bool -> MsgStore s -> FilePath -> Bool -> IO ()
exportMessages tty st f drainMsgs = do
exportMessages :: STMMsgStore -> FilePath -> Bool -> IO ()
exportMessages ms f drainMsgs = do
logNote $ "saving messages to file " <> T.pack f
run $ case st of
StoreMemory ms -> exportMessages_ ms $ getMsgs ms
StoreJournal ms -> exportMessages_ ms $ getJournalMsgs ms
#if defined(dbServerPostgres)
StoreDatabase ms -> exportDbMessages tty ms
#endif
run $ fmap (\(Sum n) -> n) . withLoadedQueues (queueStore ms) . saveQueueMsgs
where
exportMessages_ ms get = fmap (\(Sum n) -> n) . unsafeWithAllMsgQueues tty ms . saveQueueMsgs get
run :: (Handle -> IO Int) -> IO ()
run a = liftIO $ withFile f WriteMode $ tryAny . a >=> \case
Right n -> logNote $ "messages saved: " <> tshow n
Left e -> do
logError $ "error exporting messages: " <> tshow e
exitFailure
getJournalMsgs ms q =
readTVarIO (msgQueue' q) >>= \case
Just _ -> getMsgs ms q
Nothing -> getJournalQueueMessages ms q
getMsgs :: MsgStoreClass s' => s' -> StoreQueue s' -> IO [Message]
getMsgs ms q = unsafeRunStore q "saveQueueMsgs" $ getQueueMessages_ drainMsgs q =<< getMsgQueue ms q False
saveQueueMsgs :: (StoreQueue s -> IO [Message]) -> Handle -> StoreQueue s -> IO (Sum Int)
saveQueueMsgs get h q = do
msgs <- get q
saveQueueMsgs :: Handle -> STMQueue -> IO (Sum Int)
saveQueueMsgs h q = do
msgs <- atomically $ getQueueMessages_ drainMsgs =<< getMsgQueue q
unless (null msgs) $ BLD.hPutBuilder h $ encodeMessages (recipientId q) msgs
pure $ Sum $ length msgs
encodeMessages rId = mconcat . map (\msg -> BLD.byteString (strEncode $ MLRv3 rId msg) <> BLD.char8 '\n')
@@ -2362,37 +2389,16 @@ processServerMessages StartOptions {skipWarnings} = do
asks msgStore_ >>= liftIO . processMessages old_ expire
where
processMessages :: Maybe Int64 -> Bool -> MsgStore s' -> IO (Maybe MessageStats)
#if defined(dbServerPostgres)
processMessages old_ expire = \case
#else
processMessages old_ _ = \case
#endif
StoreMemory ms@STMMsgStore {storeConfig = STMStoreConfig {storePath}} -> case storePath of
Just f -> ifM (doesFileExist f) (Just <$> importMessages False ms f old_ skipWarnings) (pure Nothing)
Just f -> ifM (doesFileExist f) (Just <$> importMessages ms f old_ skipWarnings) (pure Nothing)
Nothing -> pure Nothing
StoreJournal ms -> processJournalMessages old_ expire ms
#if defined(dbServerPostgres)
StoreDatabase ms -> processDbMessages old_ expire ms
#endif
processJournalMessages :: forall s. Maybe Int64 -> Bool -> JournalMsgStore s -> IO (Maybe MessageStats)
processJournalMessages old_ expire ms
| expire = Just <$> case old_ of
Just old -> do
logNote "expiring journal store messages..."
run $ processExpireQueue old
Nothing -> do
logNote "validating journal store messages..."
run processValidateQueue
| otherwise = logWarn "skipping message expiration" $> Nothing
where
run a = unsafeWithAllMsgQueues False ms a `catchAny` \_ -> exitFailure
processExpireQueue :: Int64 -> JournalQueue s -> IO MessageStats
processExpireQueue old q = unsafeRunStore q "processExpireQueue" $ do
mq <- getMsgQueue ms q False
expiredMsgsCount <- deleteExpireMsgs_ old q mq
storedMsgsCount <- getQueueSize_ mq
pure MessageStats {storedMsgsCount, expiredMsgsCount, storedQueues = 1}
processValidateQueue :: JournalQueue s -> IO MessageStats
processValidateQueue q = unsafeRunStore q "processValidateQueue" $ do
storedMsgsCount <- getQueueSize_ =<< getMsgQueue ms q False
pure newMessageStats {storedMsgsCount, storedQueues = 1}
#if defined(dbServerPostgres)
processDbMessages old_ expire ms
| expire = Just <$> case old_ of
Just old -> do
@@ -2404,18 +2410,17 @@ processServerMessages StartOptions {skipWarnings} = do
| otherwise = logWarn "skipping message expiration" $> Nothing
#endif
importMessages :: forall s. MsgStoreClass s => Bool -> s -> FilePath -> Maybe Int64 -> Bool -> IO MessageStats
importMessages tty ms f old_ skipWarnings = do
importMessages :: STMMsgStore -> FilePath -> Maybe Int64 -> Bool -> IO MessageStats
importMessages ms f old_ skipWarnings = do
logNote $ "restoring messages from file " <> T.pack f
(_, (storedMsgsCount, expiredMsgsCount, overQuota)) <-
foldLogLines tty f restoreMsg (Nothing, (0, 0, M.empty))
foldLogLines False f restoreMsg (Nothing, (0, 0, M.empty))
renameFile f $ f <> ".bak"
mapM_ setOverQuota_ overQuota
logQueueStates ms
EntityCounts {queueCount} <- liftIO $ getEntityCounts @(StoreQueue s) $ queueStore ms
EntityCounts {queueCount} <- liftIO $ getEntityCounts @STMQueue $ queueStore ms
pure MessageStats {storedMsgsCount, expiredMsgsCount, storedQueues = queueCount}
where
restoreMsg :: (Maybe (RecipientId, StoreQueue s), (Int, Int, Map RecipientId (StoreQueue s))) -> Bool -> ByteString -> IO (Maybe (RecipientId, StoreQueue s), (Int, Int, Map RecipientId (StoreQueue s)))
restoreMsg :: (Maybe (RecipientId, STMQueue), (Int, Int, Map RecipientId STMQueue)) -> Bool -> ByteString -> IO (Maybe (RecipientId, STMQueue), (Int, Int, Map RecipientId STMQueue))
restoreMsg (q_, counts@(!stored, !expired, !overQuota)) eof s = case strDecode s of
Right (MLRv3 rId msg) -> runExceptT (addToMsgQueue rId msg) >>= either (exitErr . tshow) pure
Left e
@@ -2423,7 +2428,6 @@ importMessages tty ms f old_ skipWarnings = do
| otherwise -> exitErr $ parsingErr e
where
exitErr e = do
when tty $ putStrLn ""
logError $ "error restoring messages: " <> e
liftIO exitFailure
parsingErr :: String -> Text
@@ -2436,7 +2440,6 @@ importMessages tty ms f old_ skipWarnings = do
case qOrErr of
Right q -> addToQueue_ q rId msg
Left AUTH -> liftIO $ do
when tty $ putStrLn ""
warnOrExit $ "queue " <> safeDecodeUtf8 (encode $ unEntityId rId) <> " does not exist"
pure (Nothing, counts)
Left e -> throwE e
@@ -2447,7 +2450,6 @@ importMessages tty ms f old_ skipWarnings = do
writeMsg ms q False msg >>= \case
Just _ -> pure (stored + 1, expired, overQuota)
Nothing -> liftIO $ do
when tty $ putStrLn ""
logError $ decodeLatin1 $ "message queue " <> strEncode rId <> " is full, message not restored: " <> strEncode (messageId msg)
pure counts
| otherwise -> pure (stored, expired + 1, overQuota)
@@ -2458,8 +2460,8 @@ importMessages tty ms f old_ skipWarnings = do
where
-- if the first message in queue head is "quota", remove it.
mergeQuotaMsgs =
withPeekMsgQueue ms q "mergeQuotaMsgs" $ maybe (pure ()) $ \case
(mq, MessageQuota {}) -> tryDeleteMsg_ q mq False
withPeekMsgQueue q $ maybe (pure ()) $ \case
(mq, MessageQuota {}) -> tryDeleteMsg_ mq
_ -> pure ()
warnOrExit e
| skipWarnings = logWarn e'
src/Simplex/Messaging/Server/Env/STM.hs
+14 -77
View File
@@ -42,7 +42,6 @@ module Simplex.Messaging.Server.Env.STM
VerifiedTransmission,
ResponseAndMessage,
newEnv,
mkJournalStoreConfig,
msgStore,
fromMsgStore,
newClient,
@@ -69,11 +68,8 @@ module Simplex.Messaging.Server.Env.STM
defaultProxyClientConcurrency,
defaultProxyRelayConcurrency,
defaultNameResolverConcurrency,
defaultMaxClientCmdWait,
defaultAuthErrorDelayMs,
defaultMaxJournalMsgCount,
defaultMaxJournalStateLines,
defaultIdleQueueInterval,
journalMsgStoreDepth,
readWriteQueueStore,
noPostgresExitStr,
noPostgresExit,
@@ -98,7 +94,7 @@ import Data.List.NonEmpty (NonEmpty)
import Data.Map.Strict (Map)
import Data.Maybe (isJust)
import qualified Data.Text as T
import Data.Time.Clock (getCurrentTime, nominalDay)
import Data.Time.Clock (getCurrentTime)
import Data.Time.Clock.System (SystemTime)
import qualified Data.X509 as X
import Data.X509.Validation (Fingerprint (..))
@@ -115,7 +111,6 @@ import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Protocol
import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.Server.Information
import Simplex.Messaging.Server.MsgStore.Journal
import Simplex.Messaging.Server.MsgStore.STM
import Simplex.Messaging.Server.MsgStore.Types
import Simplex.Messaging.Server.Names (NamesConfig (..), NamesEnv, newNamesEnv, pingEndpoint)
@@ -148,8 +143,6 @@ data ServerConfig s = ServerConfig
smpHandshakeTimeout :: Int,
tbqSize :: Natural,
msgQueueQuota :: Int,
maxJournalMsgCount :: Int,
maxJournalStateLines :: Int,
queueIdBytes :: Int,
msgIdBytes :: Int,
serverStoreCfg :: ServerStoreCfg s,
@@ -166,8 +159,6 @@ data ServerConfig s = ServerConfig
messageExpiration :: Maybe ExpirationConfig,
expireMessagesOnStart :: Bool,
expireMessagesOnSend :: Bool,
-- | interval of inactivity after which journal queue is closed
idleQueueInterval :: Int64,
-- | notification expiration interval (seconds)
notificationExpiration :: ExpirationConfig,
-- | time after which the socket with inactive client can be disconnected (without any messages or commands, incl. PING),
@@ -204,11 +195,12 @@ data ServerConfig s = ServerConfig
serverClientConcurrency :: Int,
-- | max forwarded commands awaiting a response from one destination relay
proxyRelayConcurrency :: Int,
-- | max concurrent name resolutions per connection, enforced in forkCmd.
-- | max concurrent forwarded name resolutions per proxy connection, enforced in forkCmd.
-- Much higher than serverClientConcurrency: forwarded RSLVs from many clients
-- aggregate over a single proxy->relay connection (only servers send proxied
-- requests), so bounding them by the per-client limit would throttle unduly.
serverResolverConcurrency :: Int,
maxClientCmdWait :: Int,
-- | public-namespace resolver config; Nothing disables the names role
namesConfig :: Maybe NamesConfig,
-- | server public information
@@ -234,9 +226,6 @@ defaultMessageExpiration =
checkInterval = 7200 -- seconds, 2 hours
}
defaultIdleQueueInterval :: Int64
defaultIdleQueueInterval = 14400 -- seconds, 4 hours
defNtfExpirationHours :: Int64
defNtfExpirationHours = 24
@@ -255,32 +244,23 @@ defaultInactiveClientExpiration =
}
defaultProxyClientConcurrency :: Int
defaultProxyClientConcurrency = 32
defaultProxyClientConcurrency = 500
defaultProxyRelayConcurrency :: Int
defaultProxyRelayConcurrency = 512
defaultNameResolverConcurrency :: Int
defaultNameResolverConcurrency = 1000
defaultNameResolverConcurrency = 5000
defaultMaxClientCmdWait :: Int
defaultMaxClientCmdWait = 60000000 -- microseconds
defaultAuthErrorDelayMs :: Int64
defaultAuthErrorDelayMs = 50
journalMsgStoreDepth :: Int
journalMsgStoreDepth = 5
defaultMaxJournalStateLines :: Int
defaultMaxJournalStateLines = 16
defaultMaxJournalMsgCount :: Int
defaultMaxJournalMsgCount = 256
defaultMsgQueueQuota :: Int
defaultMsgQueueQuota = 128
defaultStateTailSize :: Int
defaultStateTailSize = 512
data Env s = Env
{ config :: ServerConfig s,
serverActive :: TVar Bool,
@@ -306,7 +286,6 @@ msgStore = fromMsgStore . msgStore_
fromMsgStore :: MsgStore s -> s
fromMsgStore = \case
StoreMemory s -> s
StoreJournal s -> s
#if defined(dbServerPostgres)
StoreDatabase s -> s
#endif
@@ -314,12 +293,10 @@ fromMsgStore = \case
type family SupportedStore (qs :: QSType) (ms :: MSType) :: Constraint where
SupportedStore 'QSMemory 'MSMemory = ()
SupportedStore 'QSMemory 'MSJournal = ()
SupportedStore 'QSMemory 'MSPostgres =
(Int ~ Bool, TypeError ('TE.Text "Storing messages in Postgres DB with queues in memory is not supported"))
SupportedStore 'QSPostgres 'MSMemory =
(Int ~ Bool, TypeError ('TE.Text "Storing messages in memory with queues in Postgres DB is not supported"))
SupportedStore 'QSPostgres 'MSJournal = ()
#if defined(dbServerPostgres)
SupportedStore 'QSPostgres 'MSPostgres = ()
#else
@@ -333,8 +310,6 @@ data AStoreType =
data ServerStoreCfg s where
SSCMemory :: Maybe StorePaths -> ServerStoreCfg STMMsgStore
SSCMemoryJournal :: {storeLogFile :: FilePath, storeMsgsPath :: FilePath} -> ServerStoreCfg (JournalMsgStore 'QSMemory)
SSCDatabaseJournal :: {storeCfg :: PostgresStoreCfg, storeMsgsPath' :: FilePath} -> ServerStoreCfg (JournalMsgStore 'QSPostgres)
#if defined(dbServerPostgres)
SSCDatabase :: PostgresStoreCfg -> ServerStoreCfg PostgresMsgStore
#endif
@@ -342,8 +317,6 @@ data ServerStoreCfg s where
dbStoreCfg :: ServerStoreCfg s -> Maybe PostgresStoreCfg
dbStoreCfg = \case
SSCMemory _ -> Nothing
SSCMemoryJournal {} -> Nothing
SSCDatabaseJournal {storeCfg} -> Just storeCfg
#if defined(dbServerPostgres)
SSCDatabase cfg -> Just cfg
#endif
@@ -351,8 +324,6 @@ dbStoreCfg = \case
storeLogFile' :: ServerStoreCfg s -> Maybe FilePath
storeLogFile' = \case
SSCMemory sp_ -> (\StorePaths {storeLogFile} -> storeLogFile) <$> sp_
SSCMemoryJournal {storeLogFile} -> Just storeLogFile
SSCDatabaseJournal {storeCfg = PostgresStoreCfg {dbStoreLogPath}} -> dbStoreLogPath
#if defined(dbServerPostgres)
SSCDatabase (PostgresStoreCfg {dbStoreLogPath}) -> dbStoreLogPath
#endif
@@ -361,14 +332,12 @@ data StorePaths = StorePaths {storeLogFile :: FilePath, storeMsgsFile :: Maybe F
type family MsgStoreType (qs :: QSType) (ms :: MSType) where
MsgStoreType 'QSMemory 'MSMemory = STMMsgStore
MsgStoreType qs 'MSJournal = JournalMsgStore qs
#if defined(dbServerPostgres)
MsgStoreType 'QSPostgres 'MSPostgres = PostgresMsgStore
#endif
data MsgStore s where
StoreMemory :: STMMsgStore -> MsgStore STMMsgStore
StoreJournal :: JournalMsgStore qs -> MsgStore (JournalMsgStore qs)
#if defined(dbServerPostgres)
StoreDatabase :: PostgresMsgStore -> MsgStore PostgresMsgStore
#endif
@@ -584,7 +553,7 @@ newProhibitedSub = do
return Sub {subThread = ProhibitSub, delivered}
newEnv :: ServerConfig s -> IO (Env s)
newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smpAgentCfg, information, messageExpiration, idleQueueInterval, msgQueueQuota, maxJournalMsgCount, maxJournalStateLines, namesConfig, msgIdBytes} = do
newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smpAgentCfg, information, messageExpiration, msgQueueQuota, namesConfig, msgIdBytes} = do
when (msgIdBytes < 24) $ do
logError "Error: msgIdBytes must be at least 24"
exitFailure
@@ -594,32 +563,14 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smp
SSCMemory storePaths_ -> do
let storePath = storeMsgsFile =<< storePaths_
ms <- newMsgStore STMStoreConfig {storePath, quota = msgQueueQuota}
forM_ storePaths_ $ \StorePaths {storeLogFile = f} -> loadStoreLog (mkQueue ms True) f $ queueStore ms
forM_ storePaths_ $ \StorePaths {storeLogFile = f} -> loadStoreLog (mkQueue ms) f $ queueStore ms
pure $ StoreMemory ms
SSCMemoryJournal {storeLogFile, storeMsgsPath} -> do
logWarn $
"Journal message store is deprecated and will be removed soon.\n"
<> "Please migrate to in-memory storage using `journal export` command.\n"
<> "After that you can migrate to PostgreSQL using `database import` command."
let qsCfg = MQStoreCfg
cfg = mkJournalStoreConfig qsCfg storeMsgsPath msgQueueQuota maxJournalMsgCount maxJournalStateLines idleQueueInterval
ms <- newMsgStore cfg
loadStoreLog (mkQueue ms True) storeLogFile $ stmQueueStore ms
pure $ StoreJournal ms
#if defined(dbServerPostgres)
SSCDatabaseJournal {storeCfg, storeMsgsPath'} -> do
let StartOptions {compactLog, confirmMigrations} = startOptions config
qsCfg = PQStoreCfg (storeCfg {confirmMigrations} :: PostgresStoreCfg)
cfg = mkJournalStoreConfig qsCfg storeMsgsPath' msgQueueQuota maxJournalMsgCount maxJournalStateLines idleQueueInterval
when compactLog $ compactDbStoreLog $ dbStoreLogPath storeCfg
StoreJournal <$> newMsgStore cfg
SSCDatabase storeCfg -> do
let StartOptions {compactLog, confirmMigrations} = startOptions config
cfg = PostgresMsgStoreCfg storeCfg {confirmMigrations} msgQueueQuota
when compactLog $ compactDbStoreLog $ dbStoreLogPath storeCfg
StoreDatabase <$> newMsgStore cfg
#else
SSCDatabaseJournal {} -> noPostgresExit
#endif
ntfStore <- NtfStore <$> TM.emptyIO
random <- C.newRandom
@@ -671,8 +622,7 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smp
Just f -> do
logNote $ "compacting queues in file " <> T.pack f
st <- newMsgStore STMStoreConfig {storePath = Nothing, quota = msgQueueQuota}
-- we don't need to have locks in the map
sl <- readWriteQueueStore False (mkQueue st False) f (queueStore st)
sl <- readWriteQueueStore False (mkQueue st) f (queueStore st)
setStoreLog (queueStore st) sl
closeMsgStore st
Nothing -> do
@@ -719,7 +669,9 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smp
Nothing -> SPMMemoryOnly
Just StorePaths {storeMsgsFile = Just _} -> SPMMessages
_ -> SPMQueues
#if defined(dbServerPostgres)
_ -> SPMMessages
#endif
noPostgresExit :: IO a
noPostgresExit = putStrLn noPostgresExitStr >> exitFailure
@@ -729,21 +681,6 @@ noPostgresExitStr =
"Error: server binary is compiled without support for PostgreSQL database.\n"
<> "Please download `smp-server-postgres` or re-compile with `cabal build -fserver_postgres`."
mkJournalStoreConfig :: QStoreCfg s -> FilePath -> Int -> Int -> Int -> Int64 -> JournalStoreConfig s
mkJournalStoreConfig queueStoreCfg storePath msgQueueQuota maxJournalMsgCount maxJournalStateLines idleQueueInterval =
JournalStoreConfig
{ storePath,
quota = msgQueueQuota,
pathParts = journalMsgStoreDepth,
queueStoreCfg,
maxMsgCount = maxJournalMsgCount,
maxStateLines = maxJournalStateLines,
stateTailSize = defaultStateTailSize,
idleInterval = idleQueueInterval,
expireBackupsAfter = 14 * nominalDay,
keepMinBackups = 2
}
newSMPProxyAgent :: SMPClientAgentConfig -> TVar ChaChaDRG -> IO ProxyAgent
newSMPProxyAgent smpAgentCfg random = do
smpAgent <- newSMPClientAgent SSender smpAgentCfg Nothing random
src/Simplex/Messaging/Server/Main.hs
+50 -144
View File
@@ -28,8 +28,6 @@ module Simplex.Messaging.Server.Main
importMessagesToDatabase,
exportDatabaseToStoreLog,
#endif
newJournalMsgStore,
storeMsgsJournalDir',
getServerSourceCode,
simplexmqSource,
serverPublicInfo,
@@ -61,7 +59,6 @@ import qualified Data.Text.IO as T
import Options.Applicative
import Simplex.Messaging.Agent.Protocol (ConnectionLink (..), ConnectionMode (..), connReqUriP')
import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..))
import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..))
import Simplex.Messaging.Client (HostMode (..), NetworkConfig (..), ProtocolClientConfig (..), SMPWebPortServers (..), SocksMode (..), defaultNetworkConfig, textToHostMode)
import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig)
import qualified Simplex.Messaging.Crypto as C
@@ -69,23 +66,20 @@ import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (parseAll)
import Network.URI (URI (..), URIAuth (..), parseAbsoluteURI)
import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (ProtoServerWithAuth), pattern SMPServer)
import Simplex.Messaging.Server (AttachHTTP, exportMessages, importMessages, printMessageStats, runSMPServer)
import Simplex.Messaging.Server (AttachHTTP, runSMPServer)
import Simplex.Messaging.Server.CLI
import Simplex.Messaging.Server.Env.STM
import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.Server.Information
import Simplex.Messaging.Server.Main.Init
import Simplex.Messaging.Server.Web (EmbeddedWebParams (..), WebHttpsParams (..))
import Simplex.Messaging.Server.MsgStore.Journal (JournalMsgStore (..), QStoreCfg (..), stmQueueStore)
import Simplex.Messaging.Server.MsgStore.Types (MsgStoreClass (..), SQSType (..), SMSType (..), newMsgStore)
import Simplex.Messaging.Server.MsgStore.Types (SQSType (..), SMSType (..))
import Simplex.Messaging.Server.Names (NamesConfig (..), RpcAuth (..))
import Simplex.Messaging.Server.QueueStore.Postgres.Config
import Simplex.Messaging.Server.StoreLog.ReadWrite (readQueueStore)
import Simplex.Messaging.Transport (supportedProxyClientSMPRelayVRange, alpnSupportedSMPHandshakes, supportedServerSMPRelayVRange)
import Simplex.Messaging.Transport.Client (TransportHost (..), defaultSocksProxy)
import Simplex.Messaging.Transport.HTTP2 (httpALPN)
import Simplex.Messaging.Transport.Server (ServerCredentials (..), mkTransportServerConfig)
import Simplex.Messaging.Util (eitherToMaybe, ifM, safeDecodeUtf8)
import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8)
import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist)
import System.Exit (exitFailure)
import System.FilePath (combine)
@@ -98,15 +92,16 @@ import Data.Int (Int64)
import qualified Data.Map.Strict as M
import Data.Semigroup (Sum (..))
import Simplex.Messaging.Agent.Store.Postgres (checkSchemaExists)
import Simplex.Messaging.Server.MsgStore.Journal (JournalQueue)
import Simplex.Messaging.Server.MsgStore.Types (QSType (..))
import Simplex.Messaging.Server.MsgStore.Journal (postgresQueueStore)
import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..))
import Simplex.Messaging.Server.MsgStore.Postgres
import Simplex.Messaging.Server.QueueStore.Postgres (batchInsertQueues, batchInsertServices, foldQueueRecs, foldServiceRecs)
import Simplex.Messaging.Server.MsgStore.STM (STMStoreConfig (..))
import Simplex.Messaging.Server.MsgStore.Types (MsgStoreClass (..), newMsgStore)
import Simplex.Messaging.Server.QueueStore.Postgres.Config
import Simplex.Messaging.Server.QueueStore.Postgres (PostgresQueueStore, batchInsertQueues, batchInsertServices, foldQueueRecs, foldServiceRecs)
import Simplex.Messaging.Server.QueueStore.STM (STMQueueStore (..))
import Simplex.Messaging.Server.QueueStore.Types
import Simplex.Messaging.Server.StoreLog (closeStoreLog, logNewService, logCreateQueue, openWriteStoreLog)
import Simplex.Messaging.Util (unlessM)
import Simplex.Messaging.Util (ifM)
import System.Directory (renameFile)
import System.IO (IOMode (..), withFile)
#endif
@@ -136,79 +131,6 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
deleteDirIfExists cfgPath
deleteDirIfExists logPath
putStrLn "Deleted configuration and log files"
Journal cmd -> withIniFile $ \ini -> do
msgsDirExists <- doesDirectoryExist storeMsgsJournalDir
msgsFileExists <- doesFileExist storeMsgsFilePath
storeLogFile <- getRequiredStoreLogFile ini
case cmd of
SCImport
| msgsFileExists && msgsDirExists -> exitConfigureMsgStorage
| msgsDirExists -> do
putStrLn $ storeMsgsJournalDir <> " directory already exists."
exitFailure
| not msgsFileExists -> do
putStrLn $ storeMsgsFilePath <> " file does not exist."
exitFailure
| otherwise -> do
confirmOrExit
("WARNING: message log file " <> storeMsgsFilePath <> " will be imported to journal directory " <> storeMsgsJournalDir)
"Messages not imported"
ms <- newJournalMsgStore logPath MQStoreCfg
readQueueStore True (mkQueue ms False) storeLogFile $ stmQueueStore ms
msgStats <- importMessages True ms storeMsgsFilePath Nothing False -- no expiration
putStrLn "Import completed"
printMessageStats "Messages" msgStats
putStrLn $ case readStoreType ini of
Right (ASType SQSMemory SMSMemory) -> "store_messages set to `memory`, update it to `journal` in INI file"
Right (ASType SQSPostgres SMSPostgres) -> "store_messages set to `database`, update it to `journal` in INI file"
Right (ASType _ SMSJournal) -> "store_messages set to `journal`"
Left e -> e <> ", configure storage correctly"
SCExport
| msgsFileExists && msgsDirExists -> exitConfigureMsgStorage
| msgsFileExists -> do
putStrLn $ storeMsgsFilePath <> " file already exists."
exitFailure
| otherwise -> do
confirmOrExit
("WARNING: journal directory " <> storeMsgsJournalDir <> " will be exported to message log file " <> storeMsgsFilePath)
"Journal not exported"
case readStoreType ini of
Right (ASType SQSMemory msType) -> do
ms <- newJournalMsgStore logPath MQStoreCfg
readQueueStore True (mkQueue ms False) storeLogFile $ stmQueueStore ms
exportMessages True (StoreJournal ms) storeMsgsFilePath False
putStrLn "Export completed"
putStrLn $ case msType of
SMSMemory -> "store_messages set to `memory`, start the server."
SMSJournal -> "store_messages set to `journal`, update it to `memory` in INI file"
#if defined(dbServerPostgres)
Right (ASType SQSPostgres SMSJournal) -> do
let dbStoreLogPath = enableDbStoreLog' ini $> storeLogFilePath
dbOpts@DBOpts {connstr, schema} = iniDBOptions ini defaultDBOpts
unlessM (checkSchemaExists connstr schema) $ do
putStrLn $ "Schema " <> B.unpack schema <> " does not exist in PostrgreSQL database: " <> B.unpack connstr
exitFailure
ms <- newJournalMsgStore logPath $ PQStoreCfg PostgresStoreCfg {dbOpts, dbStoreLogPath, confirmMigrations = MCYesUp, deletedTTL = iniDeletedTTL ini}
exportMessages True (StoreJournal ms) storeMsgsFilePath False
putStrLn "Export completed"
putStrLn "store_messages set to `journal`, store_queues is set to `database`.\nExport queues to store log to use memory storage for messages (`smp-server database export`)."
Right (ASType SQSPostgres SMSPostgres) -> do
putStrLn $ "Messages can be exported with `dabatase export --table messages`."
exitFailure
#else
Right (ASType SQSPostgres SMSJournal) -> noPostgresExit
#endif
Left e -> putStrLn $ e <> ", configure storage correctly"
SCDelete
| not msgsDirExists -> do
putStrLn $ storeMsgsJournalDir <> " directory does not exists."
exitFailure
| otherwise -> do
confirmOrExit
("WARNING: journal directory " <> storeMsgsJournalDir <> " will be permanently deleted.\nTHIS CANNOT BE UNDONE!")
"Messages NOT deleted"
deleteDirIfExists storeMsgsJournalDir
putStrLn $ "Deleted all messages in journal " <> storeMsgsJournalDir
#if defined(dbServerPostgres)
Database cmd tables dbOpts@DBOpts {connstr, schema} -> withIniFile $ \ini -> do
schemaExists <- checkSchemaExists connstr schema
@@ -221,7 +143,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
confirmOrExit
("WARNING: store log file " <> storeLogFile <> " and message log file " <> storeMsgsFilePath <> " will be imported to PostrgreSQL database: " <> B.unpack connstr <> ", schema: " <> B.unpack schema)
"Store logs not imported"
(sCnt, qCnt) <- importStoreLogToDatabase logPath storeLogFile dbOpts
(sCnt, qCnt) <- importStoreLogToDatabase storeLogFile dbOpts
putStrLn $ "Imported: " <> show sCnt <> " services, " <> show qCnt <> " queues"
putStrLn "Importing messages..."
mCnt <- importMessagesToDatabase storeMsgsFilePath dbOpts
@@ -248,11 +170,10 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
confirmOrExit
("WARNING: store log file " <> storeLogFile <> " will be compacted and imported to PostrgreSQL database: " <> B.unpack connstr <> ", schema: " <> B.unpack schema)
"Queue records not imported"
(sCnt, qCnt) <- importStoreLogToDatabase logPath storeLogFile dbOpts
(sCnt, qCnt) <- importStoreLogToDatabase storeLogFile dbOpts
putStrLn $ "Import completed: " <> show sCnt <> " services, " <> show qCnt <> " queues"
putStrLn $ case readStoreType ini of
Right (ASType SQSMemory SMSMemory) -> setToDbStr <> "\nstore_messages set to `memory`, import messages to journal to use PostgreSQL database for queues (`smp-server journal import`)"
Right (ASType SQSMemory SMSJournal) -> setToDbStr
Right (ASType SQSMemory SMSMemory) -> setToDbStr <> "\nstore_messages set to `memory`, update it to `database` and import messages (`smp-server database import --table messages`)"
Right (ASType SQSPostgres _) -> "store_queues set to `database`, start the server."
Left e -> e <> ", configure storage correctly"
where
@@ -280,7 +201,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
confirmOrExit
("WARNING: PostrgreSQL schema " <> B.unpack schema <> " (database: " <> B.unpack connstr <> ") will be exported to store log file " <> storeLogFilePath <> " and to message log file " <> storeMsgsFilePath)
"Database store not exported"
(sCnt, qCnt) <- exportDatabaseToStoreLog logPath dbOpts storeLogFilePath
(sCnt, qCnt) <- exportDatabaseToStoreLog dbOpts storeLogFilePath
putStrLn $ "Exported: " <> show sCnt <> " services, " <> show qCnt <> " queues"
putStrLn "Exporting messages..."
let storeCfg = PostgresStoreCfg {dbOpts, dbStoreLogPath = Nothing, confirmMigrations = MCConsole, deletedTTL = 86400 * defaultDeletedTTL}
@@ -306,7 +227,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
confirmOrExit
("WARNING: PostrgreSQL schema " <> B.unpack schema <> " (database: " <> B.unpack connstr <> ") will be exported to store log file " <> storeLogFilePath)
"Queue records not exported"
(sCnt, qCnt) <- exportDatabaseToStoreLog logPath dbOpts storeLogFilePath
(sCnt, qCnt) <- exportDatabaseToStoreLog dbOpts storeLogFilePath
putStrLn $ "Export completed: " <> show sCnt <> " services, " <> show qCnt <> " queues"
putStrLn $ case readStoreType ini of
Right (ASType SQSPostgres _) -> "store_queues or store_messages set to `database`, update it to `memory` in INI file."
@@ -346,6 +267,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
doesFileExist iniFile >>= \case
True -> readIniFile iniFile >>= either exitError a
_ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`."
#if defined(dbServerPostgres)
getRequiredStoreLogFile ini = do
case enableStoreLog' ini $> storeLogFilePath of
Just storeLogFile -> do
@@ -354,6 +276,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
(pure storeLogFile)
(putStrLn ("Store log file " <> storeLogFile <> " not found") >> exitFailure)
Nothing -> putStrLn "Store log disabled, see `[STORE_LOG] enable`" >> exitFailure
#endif
iniFile = combine cfgPath "smp-server.ini"
serverVersion = "SMP server v" <> simplexmqVersionCommit
executableName = "smp-server"
@@ -364,10 +287,10 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
readStoreType :: Ini -> Either String AStoreType
readStoreType ini = case (iniStoreQueues, iniStoreMessage) of
("memory", "memory") -> Right $ ASType SQSMemory SMSMemory
("memory", "journal") -> Right $ ASType SQSMemory SMSJournal
("memory", "journal") -> Left journalRemovedStr
("memory", "database") -> Left "Database and memory storage are not compatible."
("database", "memory") -> Left "Database and memory storage are not compatible."
("database", "journal") -> Right $ ASType SQSPostgres SMSJournal
("database", "journal") -> Left journalRemovedStr
#if defined(dbServerPostgres)
("database", "database") -> Right $ ASType SQSPostgres SMSPostgres
#else
@@ -377,10 +300,12 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
where
iniStoreQueues = fromRight "memory" $ lookupValue "STORE_LOG" "store_queues" ini
iniStoreMessage = fromRight "memory" $ lookupValue "STORE_LOG" "store_messages" ini
#if defined(dbServerPostgres)
iniDeletedTTL ini = readIniDefault (86400 * defaultDeletedTTL) "STORE_LOG" "db_deleted_ttl" ini
enableDbStoreLog' = settingIsOn "STORE_LOG" "db_store_log"
#endif
defaultStaticPath = combine logPath "www"
enableStoreLog' = settingIsOn "STORE_LOG" "enable"
enableDbStoreLog' = settingIsOn "STORE_LOG" "db_store_log"
initializeServer opts
| scripted opts = initialize opts
| otherwise = do
@@ -517,16 +442,13 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
iniStoreType = either error id $! readStoreType ini
iniStoreCfg :: SupportedStore qs ms => SQSType qs -> SMSType ms -> ServerStoreCfg (MsgStoreType qs ms)
iniStoreCfg SQSMemory SMSMemory = SSCMemory $ enableStoreLog' ini $> StorePaths {storeLogFile = storeLogFilePath, storeMsgsFile = restoreMessagesFile storeMsgsFilePath}
iniStoreCfg SQSMemory SMSJournal = SSCMemoryJournal {storeLogFile = storeLogFilePath, storeMsgsPath = storeMsgsJournalDir}
iniStoreCfg SQSPostgres SMSJournal =
let dbStoreLogPath = enableDbStoreLog' ini $> storeLogFilePath
storeCfg = PostgresStoreCfg {dbOpts = iniDBOptions ini defaultDBOpts, dbStoreLogPath, confirmMigrations = MCYesUp, deletedTTL = iniDeletedTTL ini}
in SSCDatabaseJournal {storeCfg, storeMsgsPath' = storeMsgsJournalDir}
#if defined(dbServerPostgres)
iniStoreCfg SQSPostgres SMSPostgres =
let dbStoreLogPath = enableDbStoreLog' ini $> storeLogFilePath
storeCfg = PostgresStoreCfg {dbOpts = iniDBOptions ini defaultDBOpts, dbStoreLogPath, confirmMigrations = MCYesUp, deletedTTL = iniDeletedTTL ini}
in SSCDatabase storeCfg
#else
iniStoreCfg SQSPostgres _ = error noPostgresExitStr
#endif
serverConfig :: ServerStoreCfg s -> ServerConfig s
serverConfig serverStoreCfg =
@@ -535,8 +457,6 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
smpHandshakeTimeout = 120000000,
tbqSize = 128,
msgQueueQuota = defaultMsgQueueQuota,
maxJournalMsgCount = defaultMaxJournalMsgCount,
maxJournalStateLines = defaultMaxJournalStateLines,
queueIdBytes = 24,
msgIdBytes = 24, -- must be at least 24 bytes, it is used as 192-bit nonce for XSalsa20
smpCredentials =
@@ -561,7 +481,6 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
},
expireMessagesOnStart = fromMaybe True $ iniOnOff "STORE_LOG" "expire_messages_on_start" ini,
expireMessagesOnSend = fromMaybe True $ iniOnOff "STORE_LOG" "expire_messages_on_send" ini,
idleQueueInterval = defaultIdleQueueInterval,
notificationExpiration =
defaultNtfExpiration
{ ttl = 3600 * readIniDefault defNtfExpirationHours "STORE_LOG" "expire_ntfs_hours" ini
@@ -612,6 +531,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
serverClientConcurrency = readIniDefault defaultProxyClientConcurrency "PROXY" "client_concurrency" ini,
proxyRelayConcurrency = readIniDefault defaultProxyRelayConcurrency "PROXY" "relay_concurrency" ini,
serverResolverConcurrency = readIniDefault defaultNameResolverConcurrency "NAMES" "resolver_concurrency" ini,
maxClientCmdWait = defaultMaxClientCmdWait,
namesConfig = readNamesConfig ini,
information = serverPublicInfo ini,
startOptions
@@ -639,7 +559,6 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
checkMsgStoreMode ini mode = do
msgsDirExists <- doesDirectoryExist storeMsgsJournalDir
msgsFileExists <- doesFileExist storeMsgsFilePath
storeLogExists <- doesFileExist storeLogFilePath
case mode of
#if defined(dbServerPostgres)
ASType SQSPostgres SMSPostgres
@@ -647,35 +566,22 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
putStrLn $ "Error: " <> storeMsgsFilePath <> " file or " <> storeMsgsJournalDir <> " directory are present."
putStrLn "Configure memory storage."
exitFailure
| otherwise -> checkDbStorage ini storeLogExists
#endif
ASType qs SMSJournal
| msgsFileExists && msgsDirExists -> exitConfigureMsgStorage
| msgsFileExists -> do
putStrLn $ "Error: store_messages is `journal` with " <> storeMsgsFilePath <> " file present."
putStrLn "Set store_messages to `memory` or use `smp-server journal export` to migrate."
exitFailure
| not msgsDirExists ->
putStrLn $ "store_messages is `journal`, " <> storeMsgsJournalDir <> " directory will be created."
| otherwise -> case qs of
SQSMemory ->
unless (storeLogExists) $ putStrLn $ "store_queues is `memory`, " <> storeLogFilePath <> " file will be created."
#if defined(dbServerPostgres)
SQSPostgres -> checkDbStorage ini storeLogExists
| otherwise -> checkDbStorage ini =<< doesFileExist storeLogFilePath
#else
SQSPostgres -> noPostgresExit
ASType SQSPostgres _ -> noPostgresExit
#endif
ASType SQSMemory SMSMemory
| msgsFileExists && msgsDirExists -> exitConfigureMsgStorage
| msgsDirExists -> do
putStrLn $ "Error: store_messages is `memory` with " <> storeMsgsJournalDir <> " directory present."
putStrLn "Set store_messages to `journal` or use `smp-server journal import` to migrate."
putStrLn journalRemovedStr
exitFailure
| otherwise -> pure ()
exitConfigureMsgStorage :: IO ()
exitConfigureMsgStorage = do
putStrLn $ "Error: both " <> storeMsgsFilePath <> " file and " <> storeMsgsJournalDir <> " directory are present."
putStrLn "Configure memory storage."
putStrLn journalRemovedStr
exitFailure
#if defined(dbServerPostgres)
@@ -707,18 +613,19 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
putStrLn "Configure queue storage."
exitFailure
importStoreLogToDatabase :: FilePath -> FilePath -> DBOpts -> IO (Int64, Int64)
importStoreLogToDatabase logPath storeLogFile dbOpts = do
ms <- newJournalMsgStore logPath MQStoreCfg
let st = stmQueueStore ms
sl <- readWriteQueueStore True (mkQueue ms False) storeLogFile st
importStoreLogToDatabase :: FilePath -> DBOpts -> IO (Int64, Int64)
importStoreLogToDatabase storeLogFile dbOpts = do
ms <- newMsgStore STMStoreConfig {storePath = Nothing, quota = defaultMsgQueueQuota}
let st = queueStore ms
sl <- readWriteQueueStore True (mkQueue ms) storeLogFile st
closeStoreLog sl
queues <- readTVarIO $ loadedQueues st
qs <- readTVarIO $ queues st
services' <- M.elems <$> readTVarIO (services st)
let storeCfg = PostgresStoreCfg {dbOpts = dbOpts {createSchema = True}, dbStoreLogPath = Nothing, confirmMigrations = MCConsole, deletedTTL = 86400 * defaultDeletedTTL}
ps <- newJournalMsgStore logPath $ PQStoreCfg storeCfg
sCnt <- batchInsertServices services' $ postgresQueueStore ps
qCnt <- batchInsertQueues @(JournalQueue 'QSMemory) True queues $ postgresQueueStore ps
ps :: PostgresQueueStore PostgresQueue <- newQueueStore @PostgresQueue storeCfg
sCnt <- batchInsertServices services' ps
qCnt <- batchInsertQueues True qs ps
closeQueueStore @PostgresQueue ps
renameFile storeLogFile $ storeLogFile <> ".bak"
pure (sCnt, qCnt)
@@ -737,21 +644,23 @@ importMessagesToDatabase msgsLogFile dbOpts = do
renameFile msgsLogFile $ msgsLogFile <> ".bak"
pure mCnt'
exportDatabaseToStoreLog :: FilePath -> DBOpts -> FilePath -> IO (Int, Int)
exportDatabaseToStoreLog logPath dbOpts storeLogFilePath = do
exportDatabaseToStoreLog :: DBOpts -> FilePath -> IO (Int, Int)
exportDatabaseToStoreLog dbOpts storeLogFilePath = do
let storeCfg = PostgresStoreCfg {dbOpts, dbStoreLogPath = Nothing, confirmMigrations = MCConsole, deletedTTL = 86400 * defaultDeletedTTL}
ps <- newJournalMsgStore logPath $ PQStoreCfg storeCfg
ps :: PostgresQueueStore PostgresQueue <- newQueueStore @PostgresQueue storeCfg
sl <- openWriteStoreLog False storeLogFilePath
Sum sCnt <- foldServiceRecs (postgresQueueStore ps) $ \sr -> logNewService sl sr $> Sum (1 :: Int)
Sum qCnt <- foldQueueRecs True True (postgresQueueStore ps) $ \(rId, qr) -> logCreateQueue sl rId qr $> Sum (1 :: Int)
Sum sCnt <- foldServiceRecs ps $ \sr -> logNewService sl sr $> Sum (1 :: Int)
Sum qCnt <- foldQueueRecs True True ps $ \(rId, qr) -> logCreateQueue sl rId qr $> Sum (1 :: Int)
closeStoreLog sl
closeQueueStore @PostgresQueue ps
pure (sCnt, qCnt)
#endif
newJournalMsgStore :: FilePath -> QStoreCfg s -> IO (JournalMsgStore s)
newJournalMsgStore logPath qsCfg =
let cfg = mkJournalStoreConfig qsCfg (storeMsgsJournalDir' logPath) defaultMsgQueueQuota defaultMaxJournalMsgCount defaultMaxJournalStateLines $ checkInterval defaultMessageExpiration
in newMsgStore cfg
journalRemovedStr :: String
journalRemovedStr =
"Journal message storage is removed.\n"
<> "Export messages with `smp-server journal export` using smp-server v7.1.0.11 or earlier,\n"
<> "then set store_messages to `memory`, or to `database` and run `smp-server database import --table messages`."
storeMsgsJournalDir' :: FilePath -> FilePath
storeMsgsJournalDir' logPath = combine logPath "messages"
@@ -875,7 +784,6 @@ data CliCommand
| OnlineCert CertOptions
| Start StartOptions
| Delete
| Journal StoreCmd
| Database StoreCmd DatabaseTable DBOpts
data StoreCmd = SCImport | SCExport | SCDelete
@@ -901,7 +809,6 @@ cliCommandP cfgPath logPath iniFile =
<> command "cert" (info (OnlineCert <$> certOptionsP) (progDesc $ "Generate new online TLS server credentials (configuration: " <> iniFile <> ")"))
<> command "start" (info (Start <$> startOptionsP) (progDesc $ "Start server (configuration: " <> iniFile <> ")"))
<> command "delete" (info (pure Delete) (progDesc "Delete configuration and log files"))
<> command "journal" (info (Journal <$> journalCmdP) (progDesc "Import/export messages to/from journal storage"))
<> command "database" (info (Database <$> databaseCmdP <*> dbTableP <*> dbOptsP defaultDBOpts) (progDesc "Import/export queues to/from PostgreSQL database storage"))
)
where
@@ -1048,7 +955,6 @@ cliCommandP cfgPath logPath iniFile =
disableWeb,
scripted
}
journalCmdP = storeCmdP "message log file" "journal storage"
databaseCmdP = storeCmdP "queue store log file" "PostgreSQL database schema"
storeCmdP src dest =
hsubparser
src/Simplex/Messaging/Server/Main/Init.hs
+4 -4
View File
@@ -83,7 +83,7 @@ iniFileContent cfgPath logPath opts host basicAuth controlPortPwds =
<> ("enable = " <> onOff enableStoreLog <> "\n\n")
<> "# Queue storage mode: `memory` or `database` (to store queue records in PostgreSQL database).\n\
\# `memory` - in-memory persistence, with optional append-only log (`enable = on`).\n\
\# `database`- PostgreSQL databass (requires `store_messages = journal`).\n\
\# `database`- PostgreSQL databass (requires `store_messages = database`).\n\
\store_queues = memory\n\n\
\# Database connection settings for PostgreSQL database (`store_queues = database`).\n"
<> iniDbOpts dbOptions defaultDBOpts
@@ -91,7 +91,7 @@ iniFileContent cfgPath logPath opts host basicAuth controlPortPwds =
\# db_store_log = off\n\n\
\# Time to retain deleted queues in the database, days.\n"
<> ("# db_deleted_ttl = " <> tshow defaultDeletedTTL <> "\n\n")
<> "# Message storage mode: `memory` or `journal`.\n\
<> "# Message storage mode: `memory` or `database` (requires `store_queues = database`).\n\
\store_messages = memory\n\n\
\# When store_messages is `memory`, undelivered messages are optionally saved and restored\n\
\# when the server restarts, they are preserved in the .bak file until the next restart.\n"
@@ -154,7 +154,7 @@ iniFileContent cfgPath logPath opts host basicAuth controlPortPwds =
\# `socks_mode` can be 'onion' for SOCKS proxy to be used for .onion destination hosts only (default)\n\
\# or 'always' to be used for all destination hosts (can be used if it is an .onion server).\n\
\# socks_mode = onion\n\n\
\# Limit number of threads a client can spawn to process proxy commands in parrallel.\n"
\# Limit number of threads a client can spawn to process proxy commands and name resolutions in parallel.\n"
<> ("# client_concurrency = " <> tshow defaultProxyClientConcurrency)
<> "\n\n\
\# Limit number of messages forwarded to one destination server and awaiting its response.\n"
@@ -172,7 +172,7 @@ iniFileContent cfgPath logPath opts host basicAuth controlPortPwds =
\# resolver_auth: basic <username>:<password>\n\
\# resolver_timeout_ms: 3000\n\
\# resolver_max_response_bytes: 16000\n\
\# Max concurrent name resolutions per connection (forwarded RSLVs from many\n\
\# Max concurrent forwarded name resolutions per proxy connection (forwarded RSLVs from many\n\
\# clients share one proxy connection, so this is much higher than PROXY client_concurrency).\n"
<> ("# resolver_concurrency = " <> tshow defaultNameResolverConcurrency)
<> "\n\n\
src/Simplex/Messaging/Server/MsgStore/Journal.hs
-1085
View File
File diff suppressed because it is too large. Load diff
src/Simplex/Messaging/Server/MsgStore/Journal/SharedLock.hs
-44
View File
@@ -1,44 +0,0 @@
module Simplex.Messaging.Server.MsgStore.Journal.SharedLock
( withLockWaitShared,
withLockMapWaitShared,
withSharedWaitLock,
)
where
import Control.Concurrent.STM
import qualified Control.Exception as E
import Control.Monad
import Data.Text (Text)
import Simplex.Messaging.Agent.Lock
import Simplex.Messaging.Agent.Client (getMapLock)
import Simplex.Messaging.Protocol (RecipientId)
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Util (($>>), ($>>=))
-- wait until shared lock with passed ID is released and take lock
withLockWaitShared :: RecipientId -> Lock -> TMVar RecipientId -> Text -> IO a -> IO a
withLockWaitShared rId lock shared name =
E.bracket_
(atomically $ waitShared rId shared >> putTMVar lock name)
(void $ atomically $ takeTMVar lock)
-- wait until shared lock with passed ID is released and take lock from Map for this ID
withLockMapWaitShared :: RecipientId -> TMap RecipientId Lock -> TMVar RecipientId -> Text -> IO a -> IO a
withLockMapWaitShared rId locks shared name a =
E.bracket
(atomically $ waitShared rId shared >> getPutLock (getMapLock locks) rId name)
(atomically . takeTMVar)
(const a)
waitShared :: RecipientId -> TMVar RecipientId -> STM ()
waitShared rId shared = tryReadTMVar shared >>= mapM_ (\rId' -> when (rId == rId') retry)
-- wait until lock with passed ID in Map is released and take shared lock for this ID
withSharedWaitLock :: RecipientId -> TMap RecipientId Lock -> TMVar RecipientId -> IO a -> IO a
withSharedWaitLock rId locks shared =
E.bracket_
(atomically $ waitLock >> putTMVar shared rId)
(atomically $ takeTMVar shared)
where
waitLock = TM.lookup rId locks $>>= tryReadTMVar $>> retry
src/Simplex/Messaging/Server/MsgStore/Postgres.hs
+17 -70
View File
@@ -29,7 +29,6 @@ where
import Control.Concurrent.STM
import qualified Control.Exception as E
import Control.Monad
import Control.Monad.Reader
import Control.Monad.Trans.Except
import qualified Data.ByteString as B
import qualified Data.ByteString.Builder as BB
@@ -39,7 +38,6 @@ import Data.IORef
import Data.Int (Int64)
import Data.List (intersperse)
import qualified Data.Map.Strict as M
import Data.Text (Text)
import Data.Time.Clock.System (SystemTime (..))
import Database.PostgreSQL.Simple (Binary (..), In (..), Only (..), (:.) (..))
import qualified Database.PostgreSQL.Simple as DB
@@ -56,7 +54,7 @@ import Simplex.Messaging.Server.QueueStore.Postgres
import Simplex.Messaging.Server.QueueStore.Types
import Simplex.Messaging.Server.StoreLog (foldLogLines)
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Util (maybeFirstRow, maybeFirstRow', (<$$>))
import Simplex.Messaging.Util (maybeFirstRow, maybeFirstRow')
import System.IO (Handle, hFlush, stdout)
data PostgresMsgStore = PostgresMsgStore
@@ -81,32 +79,20 @@ instance StoreQueueClass PostgresQueue where
{-# INLINE recipientId #-}
queueRec = queueRec'
{-# INLINE queueRec #-}
withQueueLock PostgresQueue {} _ = id -- TODO [messages] maybe it's just transaction?
{-# INLINE withQueueLock #-}
newtype DBTransaction = DBTransaction {dbConn :: DB.Connection}
type DBStoreIO a = ReaderT DBTransaction IO a
instance MsgStoreClass PostgresMsgStore where
type StoreMonad PostgresMsgStore = ReaderT DBTransaction IO
type MsgQueue PostgresMsgStore = ()
type QueueStore PostgresMsgStore = PostgresQueueStore'
type StoreQueue PostgresMsgStore = PostgresQueue
type MsgStoreConfig PostgresMsgStore = PostgresMsgStoreCfg
newMsgStore :: PostgresMsgStoreCfg -> IO PostgresMsgStore
newMsgStore config = do
queueStore_ <- newQueueStore @PostgresQueue (queueStoreCfg config, False)
queueStore_ <- newQueueStore @PostgresQueue (queueStoreCfg config)
pure PostgresMsgStore {config, queueStore_}
closeMsgStore :: PostgresMsgStore -> IO ()
closeMsgStore = closeQueueStore @PostgresQueue . queueStore_
withActiveMsgQueues _ _ = error "withActiveMsgQueues not used"
unsafeWithAllMsgQueues _ _ _ = error "unsafeWithAllMsgQueues not used"
expireOldMessages :: Bool -> PostgresMsgStore -> Int64 -> Int64 -> IO MessageStats
expireOldMessages _tty ms now ttl =
maybeFirstRow' newMessageStats toMessageStats $ withConnection st $ \db ->
@@ -150,35 +136,16 @@ instance MsgStoreClass PostgresMsgStore where
msg_ = toMaybeMessage mRow
in f a rId $ Right ((qr,) <$> msg_)
logQueueStates _ = error "logQueueStates not used"
logQueueState _ = error "logQueueState not used"
queueStore = queueStore_
{-# INLINE queueStore #-}
loadedQueueCounts :: PostgresMsgStore -> IO LoadedQueueCounts
loadedQueueCounts ms = do
loadedQueueCount <- M.size <$> readTVarIO queues
loadedNotifierCount <- M.size <$> readTVarIO notifiers
notifierLockCount <- M.size <$> readTVarIO notifierLocks
pure LoadedQueueCounts {loadedQueueCount, loadedNotifierCount, openJournalCount = 0, queueLockCount = 0, notifierLockCount}
where
PostgresQueueStore {queues, notifiers, notifierLocks} = queueStore_ ms
loadedQueueCounts _ = pure LoadedQueueCounts {loadedQueueCount = 0, loadedNotifierCount = 0}
mkQueue :: PostgresMsgStore -> Bool -> RecipientId -> QueueRec -> IO PostgresQueue
mkQueue _ _keepLock rId qr = PostgresQueue rId <$> newTVarIO (Just qr)
mkQueue :: PostgresMsgStore -> RecipientId -> QueueRec -> IO PostgresQueue
mkQueue _ rId qr = PostgresQueue rId <$> newTVarIO (Just qr)
{-# INLINE mkQueue #-}
getMsgQueue _ _ _ = pure ()
{-# INLINE getMsgQueue #-}
getPeekMsgQueue :: PostgresMsgStore -> PostgresQueue -> DBStoreIO (Maybe ((), Message))
getPeekMsgQueue _ q = ((),) <$$> tryPeekMsg_ q ()
withIdleMsgQueue :: Int64 -> PostgresMsgStore -> PostgresQueue -> (() -> DBStoreIO a) -> DBStoreIO (Maybe a, Int)
withIdleMsgQueue _ _ _ _ = error "withIdleMsgQueue not used"
deleteQueue :: PostgresMsgStore -> PostgresQueue -> IO (Either ErrorType QueueRec)
deleteQueue ms q = deleteStoreQueue (queueStore_ ms) q
{-# INLINE deleteQueue #-}
@@ -189,8 +156,6 @@ instance MsgStoreClass PostgresMsgStore where
qr <- ExceptT $ deleteStoreQueue (queueStore_ ms) q
pure (qr, size)
getQueueMessages_ _ _ _ = error "getQueueMessages_ not used"
writeMsg :: PostgresMsgStore -> PostgresQueue -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool))
writeMsg ms q _ msg =
uninterruptibleMask_ $
@@ -209,43 +174,25 @@ instance MsgStoreClass PostgresMsgStore where
[] -> Nothing
PostgresMsgStore {config = PostgresMsgStoreCfg {quota}} = ms
setOverQuota_ :: PostgresQueue -> IO () -- can ONLY be used while restoring messages, not while server running
setOverQuota_ _ = error "TODO setOverQuota_" -- TODO [messages]
getQueueSize_ :: () -> DBStoreIO Int
getQueueSize_ _ = error "getQueueSize_ not used"
getQueueSize :: PostgresMsgStore -> PostgresQueue -> ExceptT ErrorType IO Int
getQueueSize ms q =
withDB' "getQueueSize" (queueStore_ ms) $ \db ->
maybeFirstRow' 0 fromOnly $
DB.query db "SELECT msg_queue_size FROM msg_queues WHERE recipient_id = ? AND deleted_at IS NULL" (Only (recipientId' q))
tryPeekMsg_ :: PostgresQueue -> () -> DBStoreIO (Maybe Message)
tryPeekMsg_ q _ = do
db <- asks dbConn
liftIO $ maybeFirstRow toMessage $
DB.query
db
[sql|
SELECT msg_id, msg_ts, msg_quota, msg_ntf_flag, msg_body
FROM messages
WHERE recipient_id = ?
ORDER BY message_id ASC LIMIT 1
|]
(Only (recipientId' q))
tryDeleteMsg_ :: PostgresQueue -> () -> Bool -> DBStoreIO ()
tryDeleteMsg_ _q _ _ = error "tryDeleteMsg_ not used" -- do
isolateQueue :: PostgresMsgStore -> PostgresQueue -> Text -> DBStoreIO a -> ExceptT ErrorType IO a
isolateQueue ms _q op a = uninterruptibleMask_ $ withDB' op (queueStore_ ms) $ runReaderT a . DBTransaction
unsafeRunStore _ _ _ = error "unsafeRunStore not used"
tryPeekMsg :: PostgresMsgStore -> PostgresQueue -> ExceptT ErrorType IO (Maybe Message)
tryPeekMsg ms q = isolateQueue ms q "tryPeekMsg" $ tryPeekMsg_ q ()
{-# INLINE tryPeekMsg #-}
tryPeekMsg ms q =
uninterruptibleMask_ $ withDB' "tryPeekMsg" (queueStore_ ms) $ \db ->
maybeFirstRow toMessage $
DB.query
db
[sql|
SELECT msg_id, msg_ts, msg_quota, msg_ntf_flag, msg_body
FROM messages
WHERE recipient_id = ?
ORDER BY message_id ASC LIMIT 1
|]
(Only (recipientId' q))
tryPeekMsgs :: PostgresMsgStore -> [PostgresQueue] -> ExceptT ErrorType IO (M.Map RecipientId Message)
tryPeekMsgs _ms [] = pure M.empty
src/Simplex/Messaging/Server/MsgStore/STM.hs
+96 -66
View File
@@ -15,6 +15,11 @@ module Simplex.Messaging.Server.MsgStore.STM
( STMMsgStore (..),
STMStoreConfig (..),
STMQueue,
getMsgQueue,
withPeekMsgQueue,
getQueueMessages_,
setOverQuota_,
tryDeleteMsg_,
)
where
@@ -24,7 +29,8 @@ import Control.Monad.Trans.Except
import Data.Functor (($>))
import Data.Int (Int64)
import qualified Data.Map.Strict as M
import Data.Text (Text)
import Data.Maybe (catMaybes)
import Data.Time.Clock.System (SystemTime (systemSeconds))
import Simplex.Messaging.Protocol
import Simplex.Messaging.Server.MsgStore.Types
import Simplex.Messaging.Server.QueueStore
@@ -61,12 +67,8 @@ instance StoreQueueClass STMQueue where
{-# INLINE recipientId #-}
queueRec = queueRec'
{-# INLINE queueRec #-}
withQueueLock _ _ = id
{-# INLINE withQueueLock #-}
instance MsgStoreClass STMMsgStore where
type StoreMonad STMMsgStore = STM
type MsgQueue STMMsgStore = STMMsgQueue
type QueueStore STMMsgStore = STMQueueStore STMQueue
type StoreQueue STMMsgStore = STMQueue
type MsgStoreConfig STMMsgStore = STMStoreConfig
@@ -78,24 +80,16 @@ instance MsgStoreClass STMMsgStore where
closeMsgStore = closeQueueStore @STMQueue . queueStore_
{-# INLINE closeMsgStore #-}
withActiveMsgQueues = withLoadedQueues . queueStore_
{-# INLINE withActiveMsgQueues #-}
unsafeWithAllMsgQueues _ = withLoadedQueues . queueStore_
{-# INLINE unsafeWithAllMsgQueues #-}
expireOldMessages :: Bool -> STMMsgStore -> Int64 -> Int64 -> IO MessageStats
expireOldMessages _tty ms now ttl =
withLoadedQueues (queueStore_ ms) $ atomically . expireQueueMsgs ms now (now - ttl)
withLoadedQueues (queueStore_ ms) $ atomically . expireQueueMsgs (now - ttl)
foldRcvServiceMessages :: STMMsgStore -> ServiceId -> (a -> RecipientId -> Either ErrorType (Maybe (QueueRec, Message)) -> IO a) -> a -> IO (Either ErrorType a)
foldRcvServiceMessages ms serviceId f = fmap Right . foldRcvServiceQueues (queueStore_ ms) serviceId f'
where
f' a (q, qr) = runExceptT (tryPeekMsg ms q) >>= f a (recipientId q) . ((qr,) <$$>)
logQueueStates _ = pure ()
{-# INLINE logQueueStates #-}
logQueueState _ = pure ()
{-# INLINE logQueueState #-}
queueStore = queueStore_
{-# INLINE queueStore #-}
@@ -103,34 +97,11 @@ instance MsgStoreClass STMMsgStore where
loadedQueueCounts STMMsgStore {queueStore_ = st} = do
loadedQueueCount <- M.size <$> readTVarIO (queues st)
loadedNotifierCount <- M.size <$> readTVarIO (notifiers st)
pure LoadedQueueCounts {loadedQueueCount, loadedNotifierCount, openJournalCount = 0, queueLockCount = 0, notifierLockCount = 0}
pure LoadedQueueCounts {loadedQueueCount, loadedNotifierCount}
mkQueue _ _ rId qr = STMQueue rId <$> newTVarIO (Just qr) <*> newTVarIO Nothing
mkQueue _ rId qr = STMQueue rId <$> newTVarIO (Just qr) <*> newTVarIO Nothing
{-# INLINE mkQueue #-}
getMsgQueue :: STMMsgStore -> STMQueue -> Bool -> STM STMMsgQueue
getMsgQueue _ STMQueue {msgQueue'} _ = readTVar msgQueue' >>= maybe newQ pure
where
newQ = do
msgTQueue <- newTQueue
canWrite <- newTVar True
size <- newTVar 0
let q = STMMsgQueue {msgTQueue, canWrite, size}
writeTVar msgQueue' (Just q)
pure q
getPeekMsgQueue :: STMMsgStore -> STMQueue -> STM (Maybe (STMMsgQueue, Message))
getPeekMsgQueue _ q@STMQueue {msgQueue'} = readTVar msgQueue' $>>= \mq -> (mq,) <$$> tryPeekMsg_ q mq
-- does not create queue if it does not exist, does not delete it if it does (can't just close in-memory queue)
withIdleMsgQueue :: Int64 -> STMMsgStore -> STMQueue -> (STMMsgQueue -> STM a) -> STM (Maybe a, Int)
withIdleMsgQueue _ _ STMQueue {msgQueue'} action = readTVar msgQueue' >>= \case
Just q -> do
r <- action q
sz <- getQueueSize_ q
pure (Just r, sz)
Nothing -> pure (Nothing, 0)
deleteQueue :: STMMsgStore -> STMQueue -> IO (Either ErrorType QueueRec)
deleteQueue ms q = fst <$$> deleteQueue_ ms q
@@ -140,17 +111,9 @@ instance MsgStoreClass STMMsgStore where
where
getSize = maybe (pure 0) (\STMMsgQueue {size} -> readTVarIO size)
getQueueMessages_ :: Bool -> STMQueue -> STMMsgQueue -> STM [Message]
getQueueMessages_ drainMsgs _ = (if drainMsgs then flushTQueue else snapshotTQueue) . msgTQueue
where
snapshotTQueue q = do
msgs <- flushTQueue q
mapM_ (writeTQueue q) msgs
pure msgs
writeMsg :: STMMsgStore -> STMQueue -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool))
writeMsg ms q' _logState msg = liftIO $ atomically $ do
STMMsgQueue {msgTQueue = q, canWrite, size} <- getMsgQueue ms q' True
STMMsgQueue {msgTQueue = q, canWrite, size} <- getMsgQueue q'
canWrt <- readTVar canWrite
empty <- isEmptyTQueue q
if canWrt || empty
@@ -166,29 +129,96 @@ instance MsgStoreClass STMMsgStore where
STMMsgStore {storeConfig = STMStoreConfig {quota}} = ms
msgQuota = MessageQuota {msgId = messageId msg, msgTs = messageTs msg}
setOverQuota_ :: STMQueue -> IO ()
setOverQuota_ q = readTVarIO (msgQueue' q) >>= mapM_ (\mq -> atomically $ writeTVar (canWrite mq) False)
tryPeekMsg :: STMMsgStore -> STMQueue -> ExceptT ErrorType IO (Maybe Message)
tryPeekMsg _ q = snd <$$> withPeekMsgQueue q pure
{-# INLINE tryPeekMsg #-}
getQueueSize_ :: STMMsgQueue -> STM Int
getQueueSize_ STMMsgQueue {size} = readTVar size
tryPeekMsgs :: STMMsgStore -> [STMQueue] -> ExceptT ErrorType IO (M.Map RecipientId Message)
tryPeekMsgs st qs = M.fromList . catMaybes <$> mapM (\q -> (recipientId q,) <$$> tryPeekMsg st q) qs
tryPeekMsg_ :: STMQueue -> STMMsgQueue -> STM (Maybe Message)
tryPeekMsg_ _ = tryPeekTQueue . msgTQueue
{-# INLINE tryPeekMsg_ #-}
tryDelMsg :: STMMsgStore -> STMQueue -> MsgId -> ExceptT ErrorType IO (Maybe Message)
tryDelMsg _ q msgId' =
withPeekMsgQueue q $
maybe (pure Nothing) $ \(mq, msg) ->
if messageId msg == msgId'
then tryDeleteMsg_ mq $> Just msg
else pure Nothing
tryDeleteMsg_ :: STMQueue -> STMMsgQueue -> Bool -> STM ()
tryDeleteMsg_ _ STMMsgQueue {msgTQueue = q, size} _logState =
tryReadTQueue q >>= \case
Just _ -> modifyTVar' size (subtract 1)
_ -> pure ()
tryDelPeekMsg :: STMMsgStore -> STMQueue -> MsgId -> ExceptT ErrorType IO (Maybe Message, Maybe Message)
tryDelPeekMsg _ q msgId' =
withPeekMsgQueue q $
maybe (pure (Nothing, Nothing)) $ \(mq, msg) ->
if messageId msg == msgId'
then (Just msg,) <$> (tryDeleteMsg_ mq >> tryPeekMsg_ mq)
else pure (Nothing, Just msg)
isolateQueue :: STMMsgStore -> STMQueue -> Text -> STM a -> ExceptT ErrorType IO a
isolateQueue _ _ _ = liftIO . atomically
{-# INLINE isolateQueue #-}
deleteExpiredMsgs :: STMMsgStore -> STMQueue -> Int64 -> ExceptT ErrorType IO Int
deleteExpiredMsgs _ q old = liftIO $ atomically $ getMsgQueue q >>= deleteExpireMsgs_ old
unsafeRunStore :: STMQueue -> Text -> STM a -> IO a
unsafeRunStore _ _ = atomically
{-# INLINE unsafeRunStore #-}
getQueueSize :: STMMsgStore -> STMQueue -> ExceptT ErrorType IO Int
getQueueSize _ q = withPeekMsgQueue q $ maybe (pure 0) (getQueueSize_ . fst)
{-# INLINE getQueueSize #-}
-- can ONLY be used while restoring messages, not while server running
setOverQuota_ :: STMQueue -> IO ()
setOverQuota_ q = readTVarIO (msgQueue' q) >>= mapM_ (\mq -> atomically $ writeTVar (canWrite mq) False)
getQueueSize_ :: STMMsgQueue -> STM Int
getQueueSize_ STMMsgQueue {size} = readTVar size
tryPeekMsg_ :: STMMsgQueue -> STM (Maybe Message)
tryPeekMsg_ = tryPeekTQueue . msgTQueue
{-# INLINE tryPeekMsg_ #-}
tryDeleteMsg_ :: STMMsgQueue -> STM ()
tryDeleteMsg_ STMMsgQueue {msgTQueue = q, size} =
tryReadTQueue q >>= \case
Just _ -> modifyTVar' size (subtract 1)
_ -> pure ()
getMsgQueue :: STMQueue -> STM STMMsgQueue
getMsgQueue STMQueue {msgQueue'} = readTVar msgQueue' >>= maybe newQ pure
where
newQ = do
msgTQueue <- newTQueue
canWrite <- newTVar True
size <- newTVar 0
let q = STMMsgQueue {msgTQueue, canWrite, size}
writeTVar msgQueue' (Just q)
pure q
-- The action is called with Nothing when it is known that the queue is empty
withPeekMsgQueue :: STMQueue -> (Maybe (STMMsgQueue, Message) -> STM a) -> ExceptT ErrorType IO a
withPeekMsgQueue STMQueue {msgQueue'} a =
liftIO $ atomically $ (readTVar msgQueue' $>>= \mq -> (mq,) <$$> tryPeekMsg_ mq) >>= a
getQueueMessages_ :: Bool -> STMMsgQueue -> STM [Message]
getQueueMessages_ drainMsgs = (if drainMsgs then flushTQueue else snapshotTQueue) . msgTQueue
where
snapshotTQueue q = do
msgs <- flushTQueue q
mapM_ (writeTQueue q) msgs
pure msgs
-- does not create queue if it does not exist
expireQueueMsgs :: Int64 -> STMQueue -> STM MessageStats
expireQueueMsgs old STMQueue {msgQueue'} =
readTVar msgQueue' >>= \case
Just mq -> do
expiredMsgsCount <- deleteExpireMsgs_ old mq
storedMsgsCount <- getQueueSize_ mq
pure MessageStats {storedMsgsCount, expiredMsgsCount, storedQueues = 1}
Nothing -> pure newMessageStats {storedQueues = 1}
deleteExpireMsgs_ :: Int64 -> STMMsgQueue -> STM Int
deleteExpireMsgs_ old mq = loop 0
where
loop dc =
tryPeekMsg_ mq >>= \case
Just Message {msgTs}
| systemSeconds msgTs < old ->
tryDeleteMsg_ mq >> loop (dc + 1)
_ -> pure dc
deleteQueue_ :: STMMsgStore -> STMQueue -> IO (Either ErrorType (QueueRec, Maybe STMMsgQueue))
deleteQueue_ ms q = deleteStoreQueue (queueStore_ ms) q >>= mapM remove
src/Simplex/Messaging/Server/MsgStore/Types.hs
+6 -96
View File
@@ -4,17 +4,12 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Redundant multi-way if" #-}
module Simplex.Messaging.Server.MsgStore.Types
( MsgStoreClass (..),
MSType (..),
@@ -30,107 +25,50 @@ module Simplex.Messaging.Server.MsgStore.Types
getQueues,
getQueueRecs,
readQueueRec,
withPeekMsgQueue,
expireQueueMsgs,
deleteExpireMsgs_,
) where
import Control.Concurrent.STM
import Control.Monad
import Control.Monad.Trans.Except
import Data.Functor (($>))
import Data.Int (Int64)
import Data.Kind
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (catMaybes, fromMaybe)
import Data.Text (Text)
import Data.Time.Clock.System (SystemTime (systemSeconds))
import Simplex.Messaging.Protocol
import Simplex.Messaging.Server.QueueStore
import Simplex.Messaging.Server.QueueStore.Types
import Simplex.Messaging.Util ((<$$>), ($>>=))
import Simplex.Messaging.Util (($>>=))
class (Monad (StoreMonad s), QueueStoreClass (StoreQueue s) (QueueStore s)) => MsgStoreClass s where
type StoreMonad s = (m :: Type -> Type) | m -> s
class QueueStoreClass (StoreQueue s) (QueueStore s) => MsgStoreClass s where
type MsgStoreConfig s = c | c -> s
type MsgQueue s = q | q -> s
type StoreQueue s = q | q -> s
type QueueStore s = qs | qs -> s
newMsgStore :: MsgStoreConfig s -> IO s
closeMsgStore :: s -> IO ()
withActiveMsgQueues :: Monoid a => s -> (StoreQueue s -> IO a) -> IO a
-- This function can only be used in server CLI commands or before server is started.
-- tty, store
unsafeWithAllMsgQueues :: Monoid a => Bool -> s -> (StoreQueue s -> IO a) -> IO a
-- tty, store, now, ttl
expireOldMessages :: Bool -> s -> Int64 -> Int64 -> IO MessageStats
foldRcvServiceMessages :: s -> ServiceId -> (a -> RecipientId -> Either ErrorType (Maybe (QueueRec, Message)) -> IO a) -> a -> IO (Either ErrorType a)
logQueueStates :: s -> IO ()
logQueueState :: StoreQueue s -> StoreMonad s ()
queueStore :: s -> QueueStore s
loadedQueueCounts :: s -> IO LoadedQueueCounts
-- message store methods
mkQueue :: s -> Bool -> RecipientId -> QueueRec -> IO (StoreQueue s)
getMsgQueue :: s -> StoreQueue s -> Bool -> StoreMonad s (MsgQueue s)
getPeekMsgQueue :: s -> StoreQueue s -> StoreMonad s (Maybe (MsgQueue s, Message))
-- the journal queue will be closed after action if it was initially closed or idle longer than interval in config
withIdleMsgQueue :: Int64 -> s -> StoreQueue s -> (MsgQueue s -> StoreMonad s a) -> StoreMonad s (Maybe a, Int)
mkQueue :: s -> RecipientId -> QueueRec -> IO (StoreQueue s)
deleteQueue :: s -> StoreQueue s -> IO (Either ErrorType QueueRec)
deleteQueueSize :: s -> StoreQueue s -> IO (Either ErrorType (QueueRec, Int))
getQueueMessages_ :: Bool -> StoreQueue s -> MsgQueue s -> StoreMonad s [Message]
writeMsg :: s -> StoreQueue s -> Bool -> Message -> ExceptT ErrorType IO (Maybe (Message, Bool))
setOverQuota_ :: StoreQueue s -> IO () -- can ONLY be used while restoring messages, not while server running
getQueueSize_ :: MsgQueue s -> StoreMonad s Int
tryPeekMsg_ :: StoreQueue s -> MsgQueue s -> StoreMonad s (Maybe Message)
tryDeleteMsg_ :: StoreQueue s -> MsgQueue s -> Bool -> StoreMonad s ()
isolateQueue :: s -> StoreQueue s -> Text -> StoreMonad s a -> ExceptT ErrorType IO a
unsafeRunStore :: StoreQueue s -> Text -> StoreMonad s a -> IO a
-- default implementations are overridden for PostgreSQL storage of messages
tryPeekMsg :: s -> StoreQueue s -> ExceptT ErrorType IO (Maybe Message)
tryPeekMsg st q = snd <$$> withPeekMsgQueue st q "tryPeekMsg" pure
{-# INLINE tryPeekMsg #-}
tryPeekMsgs :: s -> [StoreQueue s] -> ExceptT ErrorType IO (Map RecipientId Message)
tryPeekMsgs st qs = M.fromList . catMaybes <$> mapM (\q -> (recipientId q,) <$$> tryPeekMsg st q) qs
tryDelMsg :: s -> StoreQueue s -> MsgId -> ExceptT ErrorType IO (Maybe Message)
tryDelMsg st q msgId' =
withPeekMsgQueue st q "tryDelMsg" $
maybe (pure Nothing) $ \(mq, msg) ->
if
| messageId msg == msgId' ->
tryDeleteMsg_ q mq True $> Just msg
| otherwise -> pure Nothing
-- atomic delete (== read) last and peek next message if available
tryDelPeekMsg :: s -> StoreQueue s -> MsgId -> ExceptT ErrorType IO (Maybe Message, Maybe Message)
tryDelPeekMsg st q msgId' =
withPeekMsgQueue st q "tryDelPeekMsg" $
maybe (pure (Nothing, Nothing)) $ \(mq, msg) ->
if
| messageId msg == msgId' -> (Just msg,) <$> (tryDeleteMsg_ q mq True >> tryPeekMsg_ q mq)
| otherwise -> pure (Nothing, Just msg)
deleteExpiredMsgs :: s -> StoreQueue s -> Int64 -> ExceptT ErrorType IO Int
deleteExpiredMsgs st q old =
isolateQueue st q "deleteExpiredMsgs" $
getMsgQueue st q False >>= deleteExpireMsgs_ old q
getQueueSize :: s -> StoreQueue s -> ExceptT ErrorType IO Int
getQueueSize st q = withPeekMsgQueue st q "getQueueSize" $ maybe (pure 0) (getQueueSize_ . fst)
{-# INLINE getQueueSize #-}
data MSType = MSMemory | MSJournal | MSPostgres
data MSType = MSMemory | MSPostgres
data QSType = QSMemory | QSPostgres
data SMSType :: MSType -> Type where
SMSMemory :: SMSType 'MSMemory
SMSJournal :: SMSType 'MSJournal
SMSPostgres :: SMSType 'MSPostgres
data SQSType :: QSType -> Type where
@@ -154,17 +92,14 @@ instance Semigroup MessageStats where
data LoadedQueueCounts = LoadedQueueCounts
{ loadedQueueCount :: Int,
loadedNotifierCount :: Int,
openJournalCount :: Int,
queueLockCount :: Int,
notifierLockCount :: Int
loadedNotifierCount :: Int
}
newMessageStats :: MessageStats
newMessageStats = MessageStats 0 0 0
addQueue :: MsgStoreClass s => s -> RecipientId -> QueueRec -> IO (Either ErrorType (StoreQueue s))
addQueue st = addQueue_ (queueStore st) (mkQueue st True)
addQueue st = addQueue_ (queueStore st) (mkQueue st)
{-# INLINE addQueue #-}
getQueue :: (MsgStoreClass s, QueueParty p) => s -> SParty p -> QueueId -> IO (Either ErrorType (StoreQueue s))
@@ -184,28 +119,3 @@ getQueueRecs st party qIds = getQueues st party qIds >>= mapM (fmap join . mapM
readQueueRec :: StoreQueueClass q => q -> IO (Either ErrorType (q, QueueRec))
readQueueRec q = maybe (Left AUTH) (Right . (q,)) <$> readTVarIO (queueRec q)
{-# INLINE readQueueRec #-}
-- The action is called with Nothing when it is known that the queue is empty
withPeekMsgQueue :: MsgStoreClass s => s -> StoreQueue s -> Text -> (Maybe (MsgQueue s, Message) -> StoreMonad s a) -> ExceptT ErrorType IO a
withPeekMsgQueue st q op a = isolateQueue st q op $ getPeekMsgQueue st q >>= a
{-# INLINE withPeekMsgQueue #-}
-- not used with PostgreSQL message store
expireQueueMsgs :: MsgStoreClass s => s -> Int64 -> Int64 -> StoreQueue s -> StoreMonad s MessageStats
expireQueueMsgs st now old q = do
(expired_, stored) <- withIdleMsgQueue now st q $ deleteExpireMsgs_ old q
pure MessageStats {storedMsgsCount = stored, expiredMsgsCount = fromMaybe 0 expired_, storedQueues = 1}
-- not used with PostgreSQL message store
deleteExpireMsgs_ :: MsgStoreClass s => Int64 -> StoreQueue s -> MsgQueue s -> StoreMonad s Int
deleteExpireMsgs_ old q mq = do
n <- loop 0
logQueueState q
pure n
where
loop dc =
tryPeekMsg_ q mq >>= \case
Just Message {msgTs}
| systemSeconds msgTs < old ->
tryDeleteMsg_ q mq False >> loop (dc + 1)
_ -> pure dc
src/Simplex/Messaging/Server/Names/HttpResolver.hs
+5 -1
View File
@@ -141,4 +141,8 @@ httpGet ResolverEnv {manager, baseUrl, authHdr, timeoutMicro, maxResponseBytes}
else do
bs <- brReadSome (responseBody res) (maxResponseBytes + 1)
pure $ if BL.length bs > fromIntegral maxResponseBytes then Left BodyTooLarge else Right bs
pure (either (Left . HttpFailure) id result)
pure (either (Left . httpError) id result)
where
httpError = \case
HC.HttpExceptionRequest _ HC.ResponseTimeout -> ResolverTimeout
e -> HttpFailure e
src/Simplex/Messaging/Server/Prometheus.hs
+20 -15
View File
@@ -128,6 +128,10 @@ prometheusMetrics sm rtm ts =
_rcvServicesSubMsg,
_rcvServicesSubDuplicate,
_authDelayExceeded,
_cmdSlotWaits,
_cmdSlotWaitMs,
_cmdSlotWaitMaxMs,
_cmdSlotWaitTimeouts,
_qCount,
_msgCount,
_ntfCount,
@@ -198,6 +202,19 @@ prometheusMetrics sm rtm ts =
\# HELP simplex_smp_auth_delay_exceeded Responses with AUTH errors sent without delay, as processing took longer than the delay.\n\
\# TYPE simplex_smp_auth_delay_exceeded counter\n\
\simplex_smp_auth_delay_exceeded " <> mshow _authDelayExceeded <> "\n# authDelayExceeded\n\
\\n\
\# HELP simplex_smp_cmd_slot_wait_ms Time commands waited for a free slot of the connection concurrency limit, in ms.\n\
\# TYPE simplex_smp_cmd_slot_wait_ms summary\n\
\simplex_smp_cmd_slot_wait_ms_sum " <> mshow _cmdSlotWaitMs <> "\n# cmdSlotWaitMs\n\
\simplex_smp_cmd_slot_wait_ms_count " <> mshow _cmdSlotWaits <> "\n# cmdSlotWaits\n\
\\n\
\# HELP simplex_smp_cmd_slot_wait_ms_max The longest wait for a free command slot, in ms.\n\
\# TYPE simplex_smp_cmd_slot_wait_ms_max gauge\n\
\simplex_smp_cmd_slot_wait_ms_max " <> mshow _cmdSlotWaitMaxMs <> "\n# cmdSlotWaitMaxMs\n\
\\n\
\# HELP simplex_smp_cmd_slot_wait_timeouts Commands not processed because the client timed out while they waited for a free slot.\n\
\# TYPE simplex_smp_cmd_slot_wait_timeouts counter\n\
\simplex_smp_cmd_slot_wait_timeouts " <> mshow _cmdSlotWaitTimeouts <> "\n# cmdSlotWaitTimeouts\n\
\\n"
subscriptions =
"# Subscriptions\n\
@@ -574,25 +591,13 @@ prometheusMetrics sm rtm ts =
\# TYPE simplex_smp_subscription_ntf_service_subs_total gauge\n\
\simplex_smp_subscription_ntf_service_subs_total " <> mshow (subServiceSubsCount ntfSubs) <> "\n# ntf.subServiceSubsCount\n\
\\n\
\# HELP simplex_smp_loaded_queues_queue_count Total loaded queues count (all queues for memory/journal storage)\n\
\# HELP simplex_smp_loaded_queues_queue_count Total loaded queues count (all queues for memory storage)\n\
\# TYPE simplex_smp_loaded_queues_queue_count gauge\n\
\simplex_smp_loaded_queues_queue_count " <> mshow (loadedQueueCount loadedCounts) <> "\n# loadedCounts.loadedQueueCount\n\
\\n\
\# HELP simplex_smp_loaded_queues_ntf_count Total loaded ntf credential references (all ntf credentials for memory/journal storage)\n\
\# HELP simplex_smp_loaded_queues_ntf_count Total loaded ntf credential references (all ntf credentials for memory storage)\n\
\# TYPE simplex_smp_loaded_queues_ntf_count gauge\n\
\simplex_smp_loaded_queues_ntf_count " <> mshow (loadedNotifierCount loadedCounts) <> "\n# loadedCounts.loadedNotifierCount\n\
\\n\
\# HELP simplex_smp_loaded_queues_open_journal_count Total opened queue journals (0 for memory storage)\n\
\# TYPE simplex_smp_loaded_queues_open_journal_count gauge\n\
\simplex_smp_loaded_queues_open_journal_count " <> mshow (openJournalCount loadedCounts) <> "\n# loadedCounts.openJournalCount\n\
\\n\
\# HELP simplex_smp_loaded_queues_queue_lock_count Total queue locks (0 for memory storage)\n\
\# TYPE simplex_smp_loaded_queues_queue_lock_count gauge\n\
\simplex_smp_loaded_queues_queue_lock_count " <> mshow (queueLockCount loadedCounts) <> "\n# loadedCounts.queueLockCount\n\
\\n\
\# HELP simplex_smp_loaded_queues_ntf_lock_count Total notifier locks (0 for memory/journal storage)\n\
\# TYPE simplex_smp_loaded_queues_ntf_lock_count gauge\n\
\simplex_smp_loaded_queues_ntf_lock_count " <> mshow (notifierLockCount loadedCounts) <> "\n# loadedCounts.notifierLockCount\n"
\simplex_smp_loaded_queues_ntf_count " <> mshow (loadedNotifierCount loadedCounts) <> "\n# loadedCounts.loadedNotifierCount\n"
showTimeBuckets :: Text -> IM.IntMap Int -> Text
showTimeBuckets metric = T.concat . snd . mapAccumL accumBucket (0, 0) . IM.assocs
src/Simplex/Messaging/Server/QueueStore/Postgres.hs
+46 -187
View File
@@ -24,9 +24,7 @@ module Simplex.Messaging.Server.QueueStore.Postgres
batchInsertServices,
batchInsertQueues,
foldServiceRecs,
foldRcvServiceQueueRecs,
foldQueueRecs,
foldRecentQueueRecs,
handleDuplicate,
rowToQueueRec,
withLog_,
@@ -43,13 +41,12 @@ import Control.Monad
import Control.Monad.Except
import Control.Monad.IO.Class
import Control.Monad.Trans.Except
import Data.Bifunctor (first)
import Data.ByteString.Builder (Builder)
import qualified Data.ByteString.Builder as BB
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Lazy as LB
import Data.Bitraversable (bimapM)
import Data.Either (fromRight, lefts)
import Data.Either (fromRight)
import Data.Functor (($>))
import Data.Int (Int64)
import Data.List (foldl', intersperse, partition)
@@ -91,7 +88,7 @@ import Simplex.Messaging.SystemTime
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport (SMPServiceRole (..))
import Simplex.Messaging.Util (eitherToMaybe, firstRow, ifM, maybeFirstRow, maybeFirstRow', tshow, (<$$>), ($>>=))
import Simplex.Messaging.Util (eitherToMaybe, firstRow, maybeFirstRow, maybeFirstRow', tshow, (<$$>), ($>>=))
import System.Exit (exitFailure)
import System.IO (IOMode (..), hFlush, stdout)
import UnliftIO.STM
@@ -103,35 +100,19 @@ import Simplex.Messaging.Encoding.String
data PostgresQueueStore q = PostgresQueueStore
{ dbStore :: DBStore,
dbStoreLog :: Maybe (StoreLog 'WriteMode),
-- this map caches all created and opened queues
queues :: TMap RecipientId q,
-- this map only cashes the queues that were attempted to send messages to,
senders :: TMap SenderId RecipientId,
links :: TMap LinkId RecipientId,
-- this map only cashes the queues that were attempted to be subscribed to,
notifiers :: TMap NotifierId RecipientId,
notifierLocks :: TMap NotifierId Lock,
serviceLocks :: TMap CertFingerprint Lock,
deletedTTL :: Int64,
useCache :: Bool
deletedTTL :: Int64
}
type UseQueueCache = Bool
instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
type QueueStoreCfg (PostgresQueueStore q) = (PostgresStoreCfg, UseQueueCache)
type QueueStoreCfg (PostgresQueueStore q) = PostgresStoreCfg
newQueueStore :: (PostgresStoreCfg, UseQueueCache) -> IO (PostgresQueueStore q)
newQueueStore (PostgresStoreCfg {dbOpts, dbStoreLogPath, confirmMigrations, deletedTTL}, useCache) = do
newQueueStore :: PostgresStoreCfg -> IO (PostgresQueueStore q)
newQueueStore PostgresStoreCfg {dbOpts, dbStoreLogPath, confirmMigrations, deletedTTL} = do
dbStore <- either err pure =<< createDBStore dbOpts serverMigrations (MigrationConfig confirmMigrations Nothing)
dbStoreLog <- mapM (openWriteStoreLog True) dbStoreLogPath
queues <- TM.emptyIO
senders <- TM.emptyIO
links <- TM.emptyIO
notifiers <- TM.emptyIO
notifierLocks <- TM.emptyIO
serviceLocks <- TM.emptyIO
pure PostgresQueueStore {dbStore, dbStoreLog, queues, senders, links, notifiers, notifierLocks, serviceLocks, deletedTTL, useCache}
pure PostgresQueueStore {dbStore, dbStoreLog, serviceLocks, deletedTTL}
where
err e = do
logError $ "STORE: newQueueStore, error opening PostgreSQL database, " <> tshow e
@@ -142,9 +123,6 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
closeDBStore dbStore
mapM_ closeStoreLog dbStoreLog
loadedQueues = queues
{-# INLINE loadedQueues #-}
compactQueues :: PostgresQueueStore q -> IO Int64
compactQueues st@PostgresQueueStore {deletedTTL} = do
old <- subtract deletedTTL . systemSeconds <$> liftIO getSystemTime
@@ -170,131 +148,44 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
(SRMessaging, SRNotifier)
pure EntityCounts {queueCount, notifierCount, rcvServiceCount, ntfServiceCount, rcvServiceQueuesCount, ntfServiceQueuesCount}
-- this implementation assumes that the lock is already taken by addQueue
-- and relies on unique constraints in the database to prevent duplicate IDs.
-- this implementation relies on unique constraints in the database to prevent duplicate IDs.
addQueue_ :: PostgresQueueStore q -> (RecipientId -> QueueRec -> IO q) -> RecipientId -> QueueRec -> IO (Either ErrorType q)
addQueue_ st mkQ rId qr = do
sq <- mkQ rId qr
withQueueLock sq "addQueue_" $ E.uninterruptibleMask_ $ runExceptT $ do
E.uninterruptibleMask_ $ runExceptT $ do
void $ withDB "addQueue_" st $ \db ->
E.try (DB.execute db insertQueueQuery $ queueRecToRow (rId, qr))
>>= bimapM handleDuplicate pure
when useCache $ do
atomically $ TM.insert rId sq queues
atomically $ TM.insert (senderId qr) rId senders
forM_ (notifier qr) $ \NtfCreds {notifierId = nId} -> atomically $ TM.insert nId rId notifiers
forM_ (queueData qr) $ \(lnkId, _) -> atomically $ TM.insert lnkId rId links
withLog "addStoreQueue" st $ \s -> logCreateQueue s rId qr
pure sq
where
PostgresQueueStore {queues, senders, links, notifiers, useCache} = st
-- Not doing duplicate checks in maps as the probability of duplicates is very low.
-- It needs to be reconsidered when IDs are supplied by the users.
-- hasId = anyM [TM.memberIO rId queues, TM.memberIO senderId senders, hasNotifier]
-- hasNotifier = maybe (pure False) (\NtfCreds {notifierId} -> TM.memberIO notifierId notifiers) notifier
getQueue_ :: QueueParty p => PostgresQueueStore q -> (Bool -> RecipientId -> QueueRec -> IO q) -> SParty p -> QueueId -> IO (Either ErrorType q)
getQueue_ st mkQ party qId
| useCache = case party of
SRecipient -> getRcvQueue qId
SSender -> TM.lookupIO qId senders >>= maybe (mask loadSndQueue) getRcvQueue
SSenderLink -> TM.lookupIO qId links >>= maybe (mask loadLinkQueue) getRcvQueue
-- loaded queue is deleted from notifiers map to reduce cache size after queue was subscribed to by ntf server
SNotifier -> TM.lookupIO qId notifiers >>= maybe (mask loadNtfQueue) (getRcvQueue >=> (atomically (TM.delete qId notifiers) $>))
| otherwise = case party of
SRecipient -> loadQueueNoCache " WHERE recipient_id = ?"
SSender -> loadQueueNoCache " WHERE sender_id = ?"
SSenderLink -> loadQueueNoCache " WHERE link_id = ?"
SNotifier -> loadQueueNoCache " WHERE notifier_id = ?"
getQueue_ :: QueueParty p => PostgresQueueStore q -> (RecipientId -> QueueRec -> IO q) -> SParty p -> QueueId -> IO (Either ErrorType q)
getQueue_ st mkQ party qId = case party of
SRecipient -> loadQueue " WHERE recipient_id = ?"
SSender -> loadQueue " WHERE sender_id = ?"
SSenderLink -> loadQueue " WHERE link_id = ?"
SNotifier -> loadQueue " WHERE notifier_id = ?"
where
PostgresQueueStore {queues, senders, links, notifiers, useCache} = st
getRcvQueue rId = TM.lookupIO rId queues >>= maybe (mask loadRcvQueue) (pure . Right)
loadRcvQueue = do
(rId, qRec) <- loadQueue " WHERE recipient_id = ?"
liftIO $ cacheQueue rId qRec $ \_ -> pure () -- recipient map already checked, not caching sender ref
loadSndQueue = loadSndQueue_ " WHERE sender_id = ?"
loadLinkQueue = loadSndQueue_ " WHERE link_id = ?"
loadNtfQueue = do
(rId, qRec) <- loadQueue " WHERE notifier_id = ?"
liftIO $
TM.lookupIO rId queues -- checking recipient map first, not creating lock in map, not caching queue
>>= maybe (mkQ False rId qRec) pure
loadSndQueue_ condition = do
(rId, qRec) <- loadQueue condition
liftIO $
TM.lookupIO rId queues -- checking recipient map first
>>= maybe (cacheQueue rId qRec cacheSender) (atomically (cacheSender rId) $>)
loadQueueNoCache cond = mask $ loadQueue cond >>= liftIO . uncurry (mkQ True)
loadQueue cond = mask $ loadQueueRec cond >>= liftIO . uncurry mkQ
mask = E.uninterruptibleMask_ . runExceptT
cacheSender rId = TM.insert qId rId senders
loadQueue condition =
loadQueueRec condition =
withDB "getQueue_" st $ \db -> firstRow rowToQueueRec AUTH $
DB.query db (queueRecQuery <> condition <> " AND deleted_at IS NULL") (Only qId)
cacheQueue rId qRec insertRef = do
sq <- mkQ True rId qRec -- loaded queue
-- This lock prevents the scenario when the queue is added to cache,
-- while another thread is proccessing the same queue in withAllMsgQueues
-- without adding it to cache, possibly trying to open the same files twice.
-- Alse see comment in idleDeleteExpiredMsgs.
withQueueLock sq "getQueue_" $ atomically $
-- checking the cache again for concurrent reads,
-- use previously loaded queue if exists.
TM.lookup rId queues >>= \case
Just sq' -> pure sq'
Nothing -> do
insertRef rId
TM.insert rId sq queues
pure sq
getQueues_ :: forall p. BatchParty p => PostgresQueueStore q -> (Bool -> RecipientId -> QueueRec -> IO q) -> SParty p -> [QueueId] -> IO [Either ErrorType q]
getQueues_ :: forall p. BatchParty p => PostgresQueueStore q -> (RecipientId -> QueueRec -> IO q) -> SParty p -> [QueueId] -> IO [Either ErrorType q]
getQueues_ st mkQ party qIds
| null qIds = pure []
| useCache = case party of
SRecipient -> do
qs <- readTVarIO queues
let qs' = map (\qId -> get qs qId qId) qIds
E.uninterruptibleMask_ $ loadQueues qs' " WHERE recipient_id IN ?" cacheRcvQueue
SNotifier -> do
ns <- readTVarIO notifiers
qs <- readTVarIO queues
let qs' = map (\qId -> get ns qId qId >>= get qs qId) qIds
E.uninterruptibleMask_ $ loadQueues qs' " WHERE notifier_id IN ?" $ \(rId, qRec) ->
forM (notifier qRec) $ \NtfCreds {notifierId = nId} -> -- it is always Just with this query
(nId,) <$> maybe (mkQ False rId qRec) pure (M.lookup rId qs)
| otherwise = E.uninterruptibleMask_ $ case party of
SRecipient -> loadQueuesNoCache " WHERE recipient_id IN ?" $ \(rId, qRec) ->
Just . (rId,) <$> mkQ False rId qRec
SNotifier -> loadQueuesNoCache " WHERE notifier_id IN ?" $ \(rId, qRec) ->
forM (notifier qRec) $ \NtfCreds {notifierId = nId} -> (nId,) <$> mkQ False rId qRec
SRecipient -> loadQueues " WHERE recipient_id IN ?" $ \(rId, qRec) ->
Just . (rId,) <$> mkQ rId qRec
SNotifier -> loadQueues " WHERE notifier_id IN ?" $ \(rId, qRec) ->
forM (notifier qRec) $ \NtfCreds {notifierId = nId} -> (nId,) <$> mkQ rId qRec
where
PostgresQueueStore {queues, notifiers, useCache} = st
get :: M.Map QueueId a -> QueueId -> QueueId -> Either QueueId a
get m qId = maybe (Left qId) Right . (`M.lookup` m)
loadQueues :: [Either QueueId q] -> Query -> ((RecipientId, QueueRec) -> IO (Maybe (QueueId, q))) -> IO [Either ErrorType q]
loadQueues qs' cond mkCacheQueue = do
let qIds' = lefts qs'
if null qIds'
then pure $ map (first (const INTERNAL)) qs'
else do
qs_ <- dbLoadQueues qIds' cond mkCacheQueue
pure $ map (result qs_) qs'
where
result :: Either ErrorType (M.Map QueueId q) -> Either QueueId q -> Either ErrorType q
result _ (Right q) = Right q
result qs_ (Left qId) = maybe (Left AUTH) Right . M.lookup qId =<< qs_
dbLoadQueues qIds' cond mkQueue' =
runExceptT $ fmap M.fromList $
withDB' "getQueues_" st (\db -> DB.query db (queueRecQuery <> cond <> " AND deleted_at IS NULL") (Only (In qIds')))
>>= liftIO . fmap catMaybes . mapM (mkQueue' . rowToQueueRec)
cacheRcvQueue (rId, qRec) = do
sq <- mkQ True rId qRec
sq' <- withQueueLock sq "getQueue_" $ atomically $
-- checking the cache again for concurrent reads, use previously loaded queue if exists.
TM.lookup rId queues >>= \case
Just sq' -> pure sq'
Nothing -> sq <$ TM.insert rId sq queues
pure $ Just (rId, sq')
loadQueuesNoCache cond mkQueue' = do
loadQueues cond mkQueue' = do
qs_ <- dbLoadQueues qIds cond mkQueue'
pure $ map (result qs_) qIds
where
@@ -312,7 +203,7 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
addQueueLinkData :: PostgresQueueStore q -> q -> LinkId -> QueueLinkData -> IO (Either ErrorType ())
addQueueLinkData st sq lnkId d =
withQueueRec sq "addQueueLinkData" $ \q -> case queueData q of
withQueueRec sq $ \q -> case queueData q of
Nothing ->
addLink q $ \db -> DB.execute db qry (d :. (lnkId, rId, QMContact))
Just (lnkId', _) | lnkId' == lnkId ->
@@ -329,7 +220,7 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
deleteQueueLinkData :: PostgresQueueStore q -> q -> IO (Either ErrorType ())
deleteQueueLinkData st sq =
withQueueRec sq "deleteQueueLinkData" $ \q -> case queueData q of
withQueueRec sq $ \q -> case queueData q of
Just _ -> do
assertUpdated $ withDB' "deleteQueueLinkData" st $ \db ->
DB.execute db "UPDATE msg_queues SET link_id = NULL, fixed_data = NULL, user_data = NULL WHERE recipient_id = ? AND deleted_at IS NULL" (Only rId)
@@ -341,7 +232,7 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
secureQueue :: PostgresQueueStore q -> q -> SndPublicAuthKey -> IO (Either ErrorType ())
secureQueue st sq sKey =
withQueueRec sq "secureQueue" $ \q -> do
withQueueRec sq $ \q -> do
verify q
assertUpdated $ withDB' "secureQueue" st $ \db ->
DB.execute db "UPDATE msg_queues SET sender_key = ? WHERE recipient_id = ? AND deleted_at IS NULL AND (sender_key IS NULL OR sender_key = ?)" (sKey, rId, sKey)
@@ -355,7 +246,7 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
updateKeys :: PostgresQueueStore q -> q -> NonEmpty RcvPublicAuthKey -> IO (Either ErrorType ())
updateKeys st sq rKeys =
withQueueRec sq "updateKeys" $ \q -> do
withQueueRec sq $ \q -> do
assertUpdated $ withDB' "updateKeys" st $ \db ->
DB.execute db "UPDATE msg_queues SET recipient_keys = ? WHERE recipient_id = ? AND deleted_at IS NULL" (rKeys, rId)
atomically $ writeTVar (queueRec sq) $ Just q {recipientKeys = rKeys}
@@ -365,24 +256,14 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
addQueueNotifier :: PostgresQueueStore q -> q -> NtfCreds -> IO (Either ErrorType (Maybe NtfCreds))
addQueueNotifier st sq ntfCreds@NtfCreds {notifierId = nId, notifierKey, rcvNtfDhSecret} =
withQueueRec sq "addQueueNotifier" $ \q ->
checkCachedNotifier $ do
assertUpdated $ withDB "addQueueNotifier" st $ \db ->
E.try (update db) >>= bimapM handleDuplicate pure
nc_ <- forM (notifier q) $ \nc@NtfCreds {notifierId} -> atomically (TM.delete notifierId notifiers) $> nc
let !q' = q {notifier = Just ntfCreds}
atomically $ writeTVar (queueRec sq) $ Just q'
when useCache $ do
atomically $ TM.insert nId rId notifiers
withLog "addQueueNotifier" st $ \s -> logAddNotifier s rId ntfCreds
pure nc_
withQueueRec sq $ \q -> do
assertUpdated $ withDB "addQueueNotifier" st $ \db ->
E.try (update db) >>= bimapM handleDuplicate pure
let !q' = q {notifier = Just ntfCreds}
atomically $ writeTVar (queueRec sq) $ Just q'
withLog "addQueueNotifier" st $ \s -> logAddNotifier s rId ntfCreds
pure $ notifier q
where
checkCachedNotifier add
| useCache =
ExceptT $ withLockMap (notifierLocks st) nId "addQueueNotifier" $
ifM (TM.memberIO nId notifiers) (pure $ Left DUPLICATE_) $ runExceptT add
| otherwise = add
PostgresQueueStore {notifiers, useCache} = st
rId = recipientId sq
update db =
DB.execute
@@ -396,18 +277,13 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
deleteQueueNotifier :: PostgresQueueStore q -> q -> IO (Either ErrorType (Maybe NtfCreds))
deleteQueueNotifier st sq =
withQueueRec sq "deleteQueueNotifier" $ \q ->
ExceptT $ fmap sequence $ forM (notifier q) $ \nc@NtfCreds {notifierId = nId} ->
withNotifierLock nId $ runExceptT $ do
assertUpdated $ withDB' "deleteQueueNotifier" st update
when (useCache st) $ atomically $ TM.delete nId $ notifiers st
atomically $ writeTVar (queueRec sq) $ Just q {notifier = Nothing}
withLog "deleteQueueNotifier" st (`logDeleteNotifier` rId)
pure nc
withQueueRec sq $ \q ->
forM (notifier q) $ \nc -> do
assertUpdated $ withDB' "deleteQueueNotifier" st update
atomically $ writeTVar (queueRec sq) $ Just q {notifier = Nothing}
withLog "deleteQueueNotifier" st (`logDeleteNotifier` rId)
pure nc
where
withNotifierLock nId
| useCache st = withLockMap (notifierLocks st) nId "deleteQueueNotifier"
| otherwise = id
rId = recipientId sq
update db =
DB.execute
@@ -436,7 +312,7 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
updateQueueTime :: PostgresQueueStore q -> q -> SystemDate -> IO (Either ErrorType QueueRec)
updateQueueTime st sq t =
withQueueRec sq "updateQueueTime" $ \q@QueueRec {updatedAt} ->
withQueueRec sq $ \q@QueueRec {updatedAt} ->
if updatedAt == Just t
then pure q
else do
@@ -449,7 +325,6 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
where
rId = recipientId sq
-- this method is called from JournalMsgStore deleteQueue that already locks the queue
deleteStoreQueue :: PostgresQueueStore q -> q -> IO (Either ErrorType QueueRec)
deleteStoreQueue st sq = E.uninterruptibleMask_ $ runExceptT $ do
q <- ExceptT $ readQueueRecIO qr
@@ -457,11 +332,6 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
assertUpdated $ withDB' "deleteStoreQueue" st $ \db ->
DB.execute db "UPDATE msg_queues SET deleted_at = ? WHERE recipient_id = ? AND deleted_at IS NULL" (ts, rId)
atomically $ writeTVar qr Nothing
when (useCache st) $ do
atomically $ TM.delete (senderId q) $ senders st
forM_ (notifier q) $ \NtfCreds {notifierId} -> do
atomically $ TM.delete notifierId $ notifiers st
atomically $ TM.delete notifierId $ notifierLocks st
withLog "deleteStoreQueue" st (`logDeleteQueue` rId)
pure q
where
@@ -484,7 +354,7 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
pure serviceId
setQueueService :: (PartyI p, ServiceParty p) => PostgresQueueStore q -> q -> SParty p -> Maybe ServiceId -> IO (Either ErrorType ())
setQueueService st sq party serviceId = withQueueRec sq "setQueueService" $ \q -> case party of
setQueueService st sq party serviceId = withQueueRec sq $ \q -> case party of
SRecipientService
| rcvServiceId q == serviceId -> pure ()
| otherwise -> do
@@ -609,11 +479,6 @@ foldServiceRecs st f =
DB.fold_ db "SELECT service_id, service_role, service_cert, service_cert_hash, created_at FROM services" mempty $
\ !acc -> fmap (acc <>) . f . rowToServiceRec
foldRcvServiceQueueRecs :: PostgresQueueStore q -> ServiceId -> (a -> (RecipientId, QueueRec) -> IO a) -> a -> IO (Either ErrorType a)
foldRcvServiceQueueRecs st serviceId f acc =
runExceptT $ withDB' "foldRcvServiceQueueRecs" st $ \db ->
DB.fold db (queueRecQuery <> " WHERE rcv_service_id = ? AND deleted_at IS NULL") (Only serviceId) acc $ \a -> f a . rowToQueueRec
foldQueueRecs :: Monoid a => Bool -> Bool -> PostgresQueueStore q -> ((RecipientId, QueueRec) -> IO a) -> IO a
foldQueueRecs withData = foldQueueRecs_ foldRecs
where
@@ -622,12 +487,6 @@ foldQueueRecs withData = foldQueueRecs_ foldRecs
| otherwise = DB.fold_ db (queueRecQuery <> cond) acc $ \acc' -> f' acc' . rowToQueueRec
cond = " WHERE deleted_at IS NULL ORDER BY recipient_id ASC"
foldRecentQueueRecs :: Monoid a => Int64 -> Bool -> PostgresQueueStore q -> ((RecipientId, QueueRec) -> IO a) -> IO a
foldRecentQueueRecs old = foldQueueRecs_ foldRecs
where
foldRecs db acc f' = DB.fold db (queueRecQuery <> cond) (Only old) acc $ \acc' -> f' acc' . rowToQueueRec
cond = " WHERE deleted_at IS NULL AND updated_at > ? ORDER BY recipient_id ASC"
foldQueueRecs_ ::
Monoid a =>
(DB.Connection -> (Int, a) -> ((Int, a) -> (RecipientId, QueueRec) -> IO (Int, a)) -> IO (Int, a)) ->
@@ -751,15 +610,15 @@ rowToServiceRec (serviceId, serviceRole, serviceCert, Binary fp, serviceCreatedA
setStatusDB :: StoreQueueClass q => Text -> PostgresQueueStore q -> q -> ServerEntityStatus -> ExceptT ErrorType IO () -> IO (Either ErrorType ())
setStatusDB op st sq status writeLog =
withQueueRec sq op $ \q -> do
withQueueRec sq $ \q -> do
assertUpdated $ withDB' op st $ \db ->
DB.execute db "UPDATE msg_queues SET status = ? WHERE recipient_id = ? AND deleted_at IS NULL" (status, recipientId sq)
atomically $ writeTVar (queueRec sq) $ Just q {status}
writeLog
withQueueRec :: StoreQueueClass q => q -> Text -> (QueueRec -> ExceptT ErrorType IO a) -> IO (Either ErrorType a)
withQueueRec sq op action =
withQueueLock sq op $ E.uninterruptibleMask_ $ runExceptT $ ExceptT (readQueueRecIO $ queueRec sq) >>= action
withQueueRec :: StoreQueueClass q => q -> (QueueRec -> ExceptT ErrorType IO a) -> IO (Either ErrorType a)
withQueueRec sq action =
E.uninterruptibleMask_ $ runExceptT $ ExceptT (readQueueRecIO $ queueRec sq) >>= action
assertUpdated :: ExceptT ErrorType IO Int64 -> ExceptT ErrorType IO ()
assertUpdated = (>>= \n -> when (n == 0) (throwE AUTH))
src/Simplex/Messaging/Server/QueueStore/Postgres/server_schema.sql
-7
View File
@@ -1,6 +1,3 @@
SET statement_timeout = 0;
SET lock_timeout = 0;
SET idle_in_transaction_session_timeout = 0;
@@ -552,7 +549,3 @@ ALTER TABLE ONLY smp_server.msg_queues
ALTER TABLE ONLY smp_server.msg_queues
ADD CONSTRAINT msg_queues_rcv_service_id_fkey FOREIGN KEY (rcv_service_id) REFERENCES smp_server.services(service_id) ON UPDATE RESTRICT ON DELETE SET NULL;
src/Simplex/Messaging/Server/QueueStore/STM.hs
+11 -5
View File
@@ -18,6 +18,7 @@ module Simplex.Messaging.Server.QueueStore.STM
( STMQueueStore (..),
STMService (..),
foldRcvServiceQueues,
withLoadedQueues,
setStoreLog,
withLog',
readQueueRecIO,
@@ -91,8 +92,6 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where
atomically $ TM.clear senders
atomically $ TM.clear notifiers
loadedQueues = queues
{-# INLINE loadedQueues #-}
compactQueues _ = pure 0
{-# INLINE compactQueues #-}
@@ -134,7 +133,7 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where
hasNotifier = maybe (pure False) (\NtfCreds {notifierId} -> TM.member notifierId notifiers) notifier
hasLink = maybe (pure False) (\(lnkId, _) -> TM.member lnkId links) queueData
getQueue_ :: QueueParty p => STMQueueStore q -> (Bool -> RecipientId -> QueueRec -> IO q) -> SParty p -> QueueId -> IO (Either ErrorType q)
getQueue_ :: QueueParty p => STMQueueStore q -> (RecipientId -> QueueRec -> IO q) -> SParty p -> QueueId -> IO (Either ErrorType q)
getQueue_ st _ party qId =
maybe (Left AUTH) Right <$> case party of
SRecipient -> TM.lookupIO qId queues
@@ -144,7 +143,7 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where
where
STMQueueStore {queues, senders, notifiers, links} = st
getQueues_ :: BatchParty p => STMQueueStore q -> (Bool -> RecipientId -> QueueRec -> IO q) -> SParty p -> [QueueId] -> IO [Either ErrorType q]
getQueues_ :: BatchParty p => STMQueueStore q -> (RecipientId -> QueueRec -> IO q) -> SParty p -> [QueueId] -> IO [Either ErrorType q]
getQueues_ st _ party qIds = case party of
SRecipient -> do
qs <- readTVarIO queues
@@ -278,9 +277,11 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where
where
rId = recipientId sq
qr = queueRec sq
delete q@QueueRec {senderId, rcvServiceId} = do
delete q@QueueRec {senderId, queueData, rcvServiceId} = do
writeTVar qr Nothing
TM.delete rId $ queues st
TM.delete senderId $ senders st
forM_ queueData $ \(lnkId, _) -> TM.delete lnkId $ links st
mapM_ (removeServiceQueue st serviceRcvQueues rId) rcvServiceId
mapM_ (removeNotifier st) $ notifier q
pure q
@@ -379,6 +380,11 @@ foldRcvServiceQueues st serviceId f acc =
where
get rId = TM.lookupIO rId (queues st) $>>= \q -> (q,) <$$> readTVarIO (queueRec q)
withLoadedQueues :: Monoid a => STMQueueStore q -> (q -> IO a) -> IO a
withLoadedQueues st f = readTVarIO (queues st) >>= foldM run mempty
where
run !acc = fmap (acc <>) . f
withQueueRec :: TVar (Maybe QueueRec) -> (QueueRec -> STM a) -> IO (Either ErrorType a)
withQueueRec qr a = atomically $ readQueueRec qr >>= mapM a
src/Simplex/Messaging/Server/QueueStore/Types.hs
+2 -14
View File
@@ -1,5 +1,4 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
@@ -9,35 +8,29 @@ module Simplex.Messaging.Server.QueueStore.Types
( StoreQueueClass (..),
QueueStoreClass (..),
EntityCounts (..),
withLoadedQueues,
) where
import Control.Concurrent.STM
import Control.Monad
import Data.Int (Int64)
import Data.List.NonEmpty (NonEmpty)
import Data.Map.Strict (Map)
import Data.Text (Text)
import Simplex.Messaging.Protocol
import Simplex.Messaging.Server.QueueStore
import Simplex.Messaging.SystemTime
import Simplex.Messaging.TMap (TMap)
class StoreQueueClass q where
recipientId :: q -> RecipientId
queueRec :: q -> TVar (Maybe QueueRec)
withQueueLock :: q -> Text -> IO a -> IO a
class StoreQueueClass q => QueueStoreClass q s where
type QueueStoreCfg s
newQueueStore :: QueueStoreCfg s -> IO s
closeQueueStore :: s -> IO ()
getEntityCounts :: s -> IO EntityCounts
loadedQueues :: s -> TMap RecipientId q
compactQueues :: s -> IO Int64
addQueue_ :: s -> (RecipientId -> QueueRec -> IO q) -> RecipientId -> QueueRec -> IO (Either ErrorType q)
getQueue_ :: QueueParty p => s -> (Bool -> RecipientId -> QueueRec -> IO q) -> SParty p -> QueueId -> IO (Either ErrorType q)
getQueues_ :: BatchParty p => s -> (Bool -> RecipientId -> QueueRec -> IO q) -> SParty p -> [QueueId] -> IO [Either ErrorType q]
getQueue_ :: QueueParty p => s -> (RecipientId -> QueueRec -> IO q) -> SParty p -> QueueId -> IO (Either ErrorType q)
getQueues_ :: BatchParty p => s -> (RecipientId -> QueueRec -> IO q) -> SParty p -> [QueueId] -> IO [Either ErrorType q]
getQueueLinkData :: s -> q -> LinkId -> IO (Either ErrorType QueueLinkData)
addQueueLinkData :: s -> q -> LinkId -> QueueLinkData -> IO (Either ErrorType ())
deleteQueueLinkData :: s -> q -> IO (Either ErrorType ())
@@ -64,8 +57,3 @@ data EntityCounts = EntityCounts
rcvServiceQueuesCount :: Int,
ntfServiceQueuesCount :: Int
}
withLoadedQueues :: (Monoid a, QueueStoreClass q s) => s -> (q -> IO a) -> IO a
withLoadedQueues st f = readTVarIO (loadedQueues st) >>= foldM run mempty
where
run !acc = fmap (acc <>) . f
src/Simplex/Messaging/Server/Stats.hs
+33
View File
@@ -130,6 +130,11 @@ data ServerStats = ServerStats
rcvServicesSubMsg :: IORef Int,
rcvServicesSubDuplicate :: IORef Int,
authDelayExceeded :: IORef Int,
-- commands that waited for a free slot in forkCmd, total and max wait in ms, and waits that timed out
cmdSlotWaits :: IORef Int,
cmdSlotWaitMs :: IORef Int,
cmdSlotWaitMaxMs :: IORef Int,
cmdSlotWaitTimeouts :: IORef Int,
qCount :: IORef Int,
msgCount :: IORef Int,
ntfCount :: IORef Int,
@@ -194,6 +199,10 @@ data ServerStatsData = ServerStatsData
_rcvServicesSubMsg :: Int,
_rcvServicesSubDuplicate :: Int,
_authDelayExceeded :: Int,
_cmdSlotWaits :: Int,
_cmdSlotWaitMs :: Int,
_cmdSlotWaitMaxMs :: Int,
_cmdSlotWaitTimeouts :: Int,
_qCount :: Int,
_msgCount :: Int,
_ntfCount :: Int,
@@ -260,6 +269,10 @@ newServerStats ts = do
rcvServicesSubMsg <- newIORef 0
rcvServicesSubDuplicate <- newIORef 0
authDelayExceeded <- newIORef 0
cmdSlotWaits <- newIORef 0
cmdSlotWaitMs <- newIORef 0
cmdSlotWaitMaxMs <- newIORef 0
cmdSlotWaitTimeouts <- newIORef 0
qCount <- newIORef 0
msgCount <- newIORef 0
ntfCount <- newIORef 0
@@ -323,6 +336,10 @@ newServerStats ts = do
rcvServicesSubMsg,
rcvServicesSubDuplicate,
authDelayExceeded,
cmdSlotWaits,
cmdSlotWaitMs,
cmdSlotWaitMaxMs,
cmdSlotWaitTimeouts,
qCount,
msgCount,
ntfCount,
@@ -388,6 +405,10 @@ getServerStatsData s = do
_rcvServicesSubMsg <- readIORef $ rcvServicesSubMsg s
_rcvServicesSubDuplicate <- readIORef $ rcvServicesSubDuplicate s
_authDelayExceeded <- readIORef $ authDelayExceeded s
_cmdSlotWaits <- readIORef $ cmdSlotWaits s
_cmdSlotWaitMs <- readIORef $ cmdSlotWaitMs s
_cmdSlotWaitMaxMs <- readIORef $ cmdSlotWaitMaxMs s
_cmdSlotWaitTimeouts <- readIORef $ cmdSlotWaitTimeouts s
_qCount <- readIORef $ qCount s
_msgCount <- readIORef $ msgCount s
_ntfCount <- readIORef $ ntfCount s
@@ -451,6 +472,10 @@ getServerStatsData s = do
_rcvServicesSubMsg,
_rcvServicesSubDuplicate,
_authDelayExceeded,
_cmdSlotWaits,
_cmdSlotWaitMs,
_cmdSlotWaitMaxMs,
_cmdSlotWaitTimeouts,
_qCount,
_msgCount,
_ntfCount,
@@ -517,6 +542,10 @@ setServerStats s d = do
writeIORef (rcvServicesSubMsg s) $! _rcvServicesSubMsg d
writeIORef (rcvServicesSubDuplicate s) $! _rcvServicesSubDuplicate d
writeIORef (authDelayExceeded s) $! _authDelayExceeded d
writeIORef (cmdSlotWaits s) $! _cmdSlotWaits d
writeIORef (cmdSlotWaitMs s) $! _cmdSlotWaitMs d
writeIORef (cmdSlotWaitMaxMs s) $! _cmdSlotWaitMaxMs d
writeIORef (cmdSlotWaitTimeouts s) $! _cmdSlotWaitTimeouts d
writeIORef (qCount s) $! _qCount d
writeIORef (msgCount s) $! _msgCount d
writeIORef (ntfCount s) $! _ntfCount d
@@ -721,6 +750,10 @@ instance StrEncoding ServerStatsData where
_rcvServicesSubMsg = 0,
_rcvServicesSubDuplicate = 0,
_authDelayExceeded = 0,
_cmdSlotWaits = 0,
_cmdSlotWaitMs = 0,
_cmdSlotWaitMaxMs = 0,
_cmdSlotWaitTimeouts = 0,
_qCount,
_msgCount = 0,
_ntfCount = 0,
src/Simplex/Messaging/Server/StoreLog/ReadWrite.hs
+3 -12
View File
@@ -14,19 +14,16 @@ module Simplex.Messaging.Server.StoreLog.ReadWrite
import Control.Concurrent.STM
import Control.Logger.Simple
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Except
import qualified Data.ByteString.Char8 as B
import qualified Data.Text as T
import Data.Text.Encoding (decodeLatin1)
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol (ASubscriberParty (..), ErrorType, RecipientId, SParty (..))
import Simplex.Messaging.Server.QueueStore (QueueRec, ServiceRec (..))
import Simplex.Messaging.Server.QueueStore.STM (STMQueueStore (..), STMService (..))
import Simplex.Messaging.Server.QueueStore.STM (STMQueueStore (..), STMService (..), withLoadedQueues)
import Simplex.Messaging.Server.QueueStore.Types
import Simplex.Messaging.Server.StoreLog
import Simplex.Messaging.Util (tshow)
import Simplex.Messaging.Util (tshow, ($>>=))
import System.IO
writeQueueStore :: forall q. StoreQueueClass q => StoreLog 'WriteMode -> STMQueueStore q -> IO ()
@@ -68,13 +65,7 @@ readQueueStore tty mkQ f st = readLogLines tty f $ \_ -> processLine
printError :: String -> IO ()
printError e = B.putStrLn $ "Error parsing log: " <> B.pack e <> " - " <> s
withQueue :: forall a. RecipientId -> T.Text -> (q -> IO (Either ErrorType a)) -> IO ()
withQueue qId op a = runExceptT go >>= qError qId op
where
go = do
q <- ExceptT $ getQueue_ st (\_ -> mkQ) SRecipient qId
liftIO (readTVarIO $ queueRec q) >>= \case
Nothing -> logWarn $ logPfx qId op <> "already deleted"
Just _ -> void $ ExceptT $ a q
withQueue qId op a = (getQueue_ st mkQ SRecipient qId $>>= a) >>= qError qId op
qError qId op = \case
Left e -> logError $ logPfx qId op <> tshow e
Right _ -> pure ()
tests/AgentTests.hs
+4 -15
View File
@@ -19,17 +19,12 @@ import Simplex.Messaging.Server.Env.STM (AStoreType (..))
import Simplex.Messaging.Transport (ASrvTransport)
import Test.Hspec hiding (fit, it)
#if defined(dbPostgres)
import Fixtures
import Simplex.Messaging.Agent.Store.Postgres.Util (dropAllSchemasExceptSystem)
#else
#if !defined(dbPostgres)
import AgentTests.SQLiteTests (storeTests)
#endif
#if defined(dbServerPostgres)
import AgentTests.NotificationTests (notificationTests)
import SMPClient (postgressBracket)
import NtfClient (ntfTestServerDBConnectInfo)
#endif
agentCoreTests :: Spec
@@ -42,16 +37,10 @@ agentCoreTests = do
agentTests :: (ASrvTransport, AStoreType) -> Spec
agentTests ps = do
#if defined(dbPostgres)
after_ (dropAllSchemasExceptSystem testDBConnectInfo) $ do
#else
do
#endif
describe "Functional API" $ functionalAPITests ps
describe "Chosen servers" serverChoiceTests
describe "Functional API" $ functionalAPITests ps
describe "Chosen servers" serverChoiceTests
#if defined(dbServerPostgres)
around_ (postgressBracket ntfTestServerDBConnectInfo) $
describe "Notification tests" $ notificationTests ps
describe "Notification tests" $ notificationTests ps
#endif
#if !defined(dbPostgres)
describe "SQLite store" storeTests
tests/AgentTests/FunctionalAPITests.hs
+208 -206
View File
File diff suppressed because it is too large. Load diff
tests/AgentTests/NotificationTests.hs
+37 -29
View File
@@ -8,6 +8,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
@@ -65,7 +66,7 @@ import SMPAgentClient (agentCfg, initAgentServers, initAgentServers2, testDB, te
import SMPClient
import Simplex.Messaging.Agent hiding (checkNtfToken, createConnection, joinConnection, registerNtfToken, sendMessage, verifyNtfToken)
import qualified Simplex.Messaging.Agent as A
import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), withStore')
import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), ServerQueueInfo (..), withStore')
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, Env (..), InitialAgentServers)
import Simplex.Messaging.Agent.Protocol hiding (CON, CONF, INFO, SENT)
import Simplex.Messaging.Agent.Store.AgentStore (getSavedNtfToken)
@@ -85,6 +86,7 @@ import Simplex.Messaging.Protocol (ErrorType (AUTH), NetworkError (..), MsgFlags
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (..))
import Simplex.Messaging.Server.Information (ServerPublicInfo (..))
import Simplex.Messaging.Server.QueueStore.QueueInfo (QueueInfo (..))
import Simplex.Messaging.Transport (ASrvTransport)
import Simplex.Messaging.Transport.Server (TransportServerConfig (..))
import System.Process (callCommand)
@@ -138,7 +140,8 @@ notificationTests ps@(t, _) = do
testNtfTokenReRegisterInvalidOnCheck t apns
describe "notification server tests" $ do
it "should pass" $ testRunNTFServerTests t testNtfServer `shouldReturn` Right Nothing
let srv1 = testNtfServer {keyHash = "1234"}
let srv1 :: HasTestEnv => NtfServer
srv1 = testNtfServer {keyHash = "1234"}
it "should fail with incorrect fingerprint" $ do
testRunNTFServerTests t srv1 `shouldReturn` Left (ProtocolTestFailure TSConnect $ BROKER (B.unpack $ strEncode srv1) $ NETWORK NEUnknownCAError)
describe "Managing notification subscriptions" $ do
@@ -186,7 +189,7 @@ notificationTests ps@(t, _) = do
testNotificationsNewToken apns ntf
it "should migrate to service subscriptions" $ testMigrateToServiceSubscriptions ps
testNtfMatrix :: HasCallStack => (ASrvTransport, AStoreType) -> (APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> Spec
testNtfMatrix :: HasCallStack => (ASrvTransport, AStoreType) -> (HasTestEnv => APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> Spec
testNtfMatrix ps@(_, msType) runTest = do
describe "next and current" $ do
it "curr servers; curr clients" $ runNtfTestCfg ps 1 cfg' ntfServerCfg agentCfg agentCfg runTest
@@ -200,6 +203,7 @@ testNtfMatrix ps@(_, msType) runTest = do
it "servers: curr SMP, curr NTF; clients: curr/prev" $ runNtfTestCfg ps 1 cfg' ntfServerCfg agentCfg agentCfgVPrevPQ runTest
it "servers: curr SMP, curr NTF; clients: prev/curr" $ runNtfTestCfg ps 1 cfg' ntfServerCfg agentCfgVPrevPQ agentCfg runTest
where
cfg', cfgVPrev' :: HasTestEnv => AServerConfig
cfg' = cfgMS msType
cfgVPrev' = cfgVPrev msType
@@ -212,7 +216,7 @@ checkNtfToken c = A.checkNtfToken c NRMInteractive
verifyNtfToken :: AgentClient -> DeviceToken -> C.CbNonce -> ByteString -> AE ()
verifyNtfToken c = A.verifyNtfToken c NRMInteractive
runNtfTestCfg :: HasCallStack => (ASrvTransport, AStoreType) -> AgentMsgId -> AServerConfig -> NtfServerConfig -> AgentConfig -> AgentConfig -> (APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> IO ()
runNtfTestCfg :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> AgentMsgId -> AServerConfig -> NtfServerConfig -> AgentConfig -> AgentConfig -> (APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> IO ()
runNtfTestCfg (t, msType) baseId smpCfg ntfCfg aCfg bCfg runTest = do
ASSCfg qt mt serverStoreCfg <- pure $ testServerStoreConfig msType
let smpCfg' = withServerCfg smpCfg $ \cfg_ -> ASrvCfg qt mt cfg_ {serverStoreCfg}
@@ -222,7 +226,7 @@ runNtfTestCfg (t, msType) baseId smpCfg ntfCfg aCfg bCfg runTest = do
withAgentClientsCfg2 aCfg bCfg $ runTest apns baseId
threadDelay 100000
testNotificationToken :: APNSMockServer -> IO ()
testNotificationToken :: HasTestEnv => APNSMockServer -> IO ()
testNotificationToken apns = do
withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight_ $ do
let tkn = DeviceToken PPApnsTest "abcd"
@@ -246,7 +250,7 @@ v .-> key = do
-- logCfg :: LogConfig
-- logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
testNtfTokenRepeatRegistration :: APNSMockServer -> IO ()
testNtfTokenRepeatRegistration :: HasTestEnv => APNSMockServer -> IO ()
testNtfTokenRepeatRegistration apns = do
withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight_ $ do
let tkn = DeviceToken PPApnsTest "abcd"
@@ -265,7 +269,7 @@ testNtfTokenRepeatRegistration apns = do
NTActive <- checkNtfToken a tkn
pure ()
testNtfTokenSecondRegistration :: APNSMockServer -> IO ()
testNtfTokenSecondRegistration :: HasTestEnv => APNSMockServer -> IO ()
testNtfTokenSecondRegistration apns =
withAgentClients2 $ \a a' -> runRight_ $ do
let tkn = DeviceToken PPApnsTest "abcd"
@@ -295,7 +299,7 @@ testNtfTokenSecondRegistration apns =
NTActive <- checkNtfToken a' tkn
pure ()
testNtfTokenServerRestart :: ASrvTransport -> APNSMockServer -> IO ()
testNtfTokenServerRestart :: HasTestEnv => ASrvTransport -> APNSMockServer -> IO ()
testNtfTokenServerRestart t apns = do
let tkn = DeviceToken PPApnsTest "abcd"
ntfData <- withAgent 1 agentCfg initAgentServers testDB $ \a ->
@@ -316,7 +320,7 @@ testNtfTokenServerRestart t apns = do
NTActive <- checkNtfToken a' tkn
pure ()
testNtfTokenServerRestartReverify :: ASrvTransport -> APNSMockServer -> IO ()
testNtfTokenServerRestartReverify :: HasTestEnv => ASrvTransport -> APNSMockServer -> IO ()
testNtfTokenServerRestartReverify t apns = do
let tkn = DeviceToken PPApnsTest "abcd"
withAgent 1 agentCfg initAgentServers testDB $ \a -> do
@@ -339,7 +343,7 @@ testNtfTokenServerRestartReverify t apns = do
NTActive <- checkNtfToken a' tkn
pure ()
testNtfTokenServerRestartReverifyTimeout :: ASrvTransport -> APNSMockServer -> IO ()
testNtfTokenServerRestartReverifyTimeout :: HasTestEnv => ASrvTransport -> APNSMockServer -> IO ()
testNtfTokenServerRestartReverifyTimeout t apns = do
let tkn = DeviceToken PPApnsTest "abcd"
withAgent 1 agentCfg initAgentServers testDB $ \a@AgentClient {agentEnv = Env {store}} -> do
@@ -374,7 +378,7 @@ testNtfTokenServerRestartReverifyTimeout t apns = do
NTActive <- checkNtfToken a' tkn
pure ()
testNtfTokenServerRestartReregister :: ASrvTransport -> APNSMockServer -> IO ()
testNtfTokenServerRestartReregister :: HasTestEnv => ASrvTransport -> APNSMockServer -> IO ()
testNtfTokenServerRestartReregister t apns = do
let tkn = DeviceToken PPApnsTest "abcd"
withAgent 1 agentCfg initAgentServers testDB $ \a ->
@@ -398,7 +402,7 @@ testNtfTokenServerRestartReregister t apns = do
NTActive <- checkNtfToken a' tkn
pure ()
testNtfTokenServerRestartReregisterTimeout :: ASrvTransport -> APNSMockServer -> IO ()
testNtfTokenServerRestartReregisterTimeout :: HasTestEnv => ASrvTransport -> APNSMockServer -> IO ()
testNtfTokenServerRestartReregisterTimeout t apns = do
let tkn = DeviceToken PPApnsTest "abcd"
withAgent 1 agentCfg initAgentServers testDB $ \a@AgentClient {agentEnv = Env {store}} -> do
@@ -439,7 +443,7 @@ getTestNtfTokenPort a =
Just NtfToken {ntfServer = ProtocolServer {port}} -> pure port
Nothing -> error "no active NtfToken"
testNtfTokenMultipleServers :: ASrvTransport -> APNSMockServer -> IO ()
testNtfTokenMultipleServers :: HasTestEnv => ASrvTransport -> APNSMockServer -> IO ()
testNtfTokenMultipleServers t apns = do
let tkn = DeviceToken PPApnsTest "abcd"
withAgent 1 agentCfg initAgentServers2 testDB $ \a ->
@@ -463,7 +467,7 @@ testNtfTokenMultipleServers t apns = do
Left _ <- tryError (checkNtfToken a tkn)
pure ()
testNtfTokenChangeServers :: ASrvTransport -> APNSMockServer -> IO ()
testNtfTokenChangeServers :: HasTestEnv => ASrvTransport -> APNSMockServer -> IO ()
testNtfTokenChangeServers t apns =
withNtfServerThreadOn t ntfTestPort ntfTestDBCfg $ \ntf -> do
tkn1 <- withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight $ do
@@ -493,7 +497,7 @@ testNtfTokenChangeServers t apns =
tkn <- registerTestToken a "qwer" NMInstant apns
checkNtfToken a tkn >>= \r -> liftIO $ r `shouldBe` NTActive
testNtfTokenReRegisterInvalid :: ASrvTransport -> APNSMockServer -> IO ()
testNtfTokenReRegisterInvalid :: HasTestEnv => ASrvTransport -> APNSMockServer -> IO ()
testNtfTokenReRegisterInvalid t apns = do
tkn <- withNtfServer t $ do
withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight $ do
@@ -518,7 +522,7 @@ testNtfTokenReRegisterInvalid t apns = do
NTActive <- checkNtfToken a tkn1
pure ()
testNtfTokenReRegisterInvalidOnCheck :: ASrvTransport -> APNSMockServer -> IO ()
testNtfTokenReRegisterInvalidOnCheck :: HasTestEnv => ASrvTransport -> APNSMockServer -> IO ()
testNtfTokenReRegisterInvalidOnCheck t apns = do
tkn <- withNtfServer t $ do
withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight $ do
@@ -543,13 +547,13 @@ testNtfTokenReRegisterInvalidOnCheck t apns = do
NTActive <- checkNtfToken a tkn1
pure ()
testRunNTFServerTests :: ASrvTransport -> NtfServer -> IO (Either ProtocolTestFailure (Maybe (Either String ServerPublicInfo)))
testRunNTFServerTests :: HasTestEnv => ASrvTransport -> NtfServer -> IO (Either ProtocolTestFailure (Maybe (Either String ServerPublicInfo)))
testRunNTFServerTests t srv =
withNtfServer t $
withAgent 1 agentCfg initAgentServers testDB $ \a ->
testProtocolServer a NRMInteractive 1 (ProtoServerWithAuth srv Nothing)
testNotificationSubscriptionExistingConnection :: APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()
testNotificationSubscriptionExistingConnection :: HasTestEnv => APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()
testNotificationSubscriptionExistingConnection apns baseId alice@AgentClient {agentEnv = Env {config = aliceCfg, store}} bob = do
(bobId, aliceId, nonce, message) <- runRight $ do
-- establish connection
@@ -569,6 +573,7 @@ testNotificationSubscriptionExistingConnection apns baseId alice@AgentClient {ag
vNonce <- C.unsafeCbNonce <$> ntfData .-> "nonce"
verifyNtfToken alice tkn vNonce verification
NTActive <- checkNtfToken alice tkn
waitNotifier bobId
-- send message
1 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello"
get bob ##> ("", aliceId, SENT $ baseId + 1)
@@ -609,6 +614,9 @@ testNotificationSubscriptionExistingConnection apns baseId alice@AgentClient {ag
noNotification alice apns
where
msgId = subtract baseId
waitNotifier connId = do
ServerQueueInfo {info = QueueInfo {qiNtf}} <- getConnectionQueueInfo alice NRMInteractive connId
unless qiNtf $ liftIO (threadDelay 20000) >> waitNotifier connId
testNotificationSubscriptionNewConnection :: HasCallStack => APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()
testNotificationSubscriptionNewConnection apns baseId alice bob =
@@ -662,7 +670,7 @@ registerTestToken a token mode apns = do
NTActive <- checkNtfToken a tkn
pure tkn
testChangeNotificationsMode :: HasCallStack => APNSMockServer -> IO ()
testChangeNotificationsMode :: (HasCallStack, HasTestEnv) => APNSMockServer -> IO ()
testChangeNotificationsMode apns =
withAgentClients2 $ \alice bob -> runRight_ $ do
-- establish connection
@@ -725,7 +733,7 @@ testChangeNotificationsMode apns =
baseId = 1
msgId = subtract baseId
testChangeToken :: APNSMockServer -> IO ()
testChangeToken :: HasTestEnv => APNSMockServer -> IO ()
testChangeToken apns = withAgent 1 agentCfg initAgentServers testDB2 $ \bob -> do
(aliceId, bobId) <- withAgent 2 agentCfg initAgentServers testDB $ \alice -> runRight $ do
-- establish connection
@@ -765,7 +773,7 @@ testChangeToken apns = withAgent 1 agentCfg initAgentServers testDB2 $ \bob -> d
baseId = 1
msgId = subtract baseId
testNotificationsStoreLog :: (ASrvTransport, AStoreType) -> APNSMockServer -> IO ()
testNotificationsStoreLog :: HasTestEnv => (ASrvTransport, AStoreType) -> APNSMockServer -> IO ()
testNotificationsStoreLog ps@(t, _) apns = withAgentClients2 $ \alice bob -> do
withSmpServerStoreMsgLogOn ps testPort $ \_ -> do
(aliceId, bobId) <- withNtfServer t $ runRight $ do
@@ -800,7 +808,7 @@ testNotificationsStoreLog ps@(t, _) apns = withAgentClients2 $ \alice bob -> do
withNtfServer t $ runRight_ $ do
void $ messageNotificationData alice apns
testNotificationsSMPRestart :: (ASrvTransport, AStoreType) -> APNSMockServer -> IO ()
testNotificationsSMPRestart :: HasTestEnv => (ASrvTransport, AStoreType) -> APNSMockServer -> IO ()
testNotificationsSMPRestart ps apns = withAgentClients2 $ \alice bob -> do
(aliceId, bobId) <- withSmpServerStoreLogOn ps testPort $ \threadId -> runRight $ do
(aliceId, bobId) <- makeConnection alice bob
@@ -828,7 +836,7 @@ testNotificationsSMPRestart ps apns = withAgentClients2 $ \alice bob -> do
get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False
liftIO $ killThread threadId
testNotificationsSMPRestartBatch :: Int -> (ASrvTransport, AStoreType) -> APNSMockServer -> IO ()
testNotificationsSMPRestartBatch :: HasTestEnv => Int -> (ASrvTransport, AStoreType) -> APNSMockServer -> IO ()
testNotificationsSMPRestartBatch n ps@(t, ASType qsType _) apns =
withAgentClientsCfgServers2 agentCfg agentCfg initAgentServers2 $ \a b -> do
threadDelay 1000000
@@ -869,12 +877,12 @@ testNotificationsSMPRestartBatch n ps@(t, ASType qsType _) apns =
runServers :: ExceptT AgentErrorType IO a -> IO a
runServers a = do
withSmpServerStoreLogOn ps testPort $ \t1 -> do
res <- withSmpServerConfigOn t (cfgJ2QS qsType) testPort2 $ \t2 ->
res <- withSmpServerConfigOn t (cfgS2QS qsType) testPort2 $ \t2 ->
runRight a `finally` killThread t2
killThread t1
pure res
testSwitchNotifications :: AgentConfig -> (AgentClient -> ByteString -> AgentClient -> ByteString -> ExceptT AgentErrorType IO ()) -> InitialAgentServers -> APNSMockServer -> IO ()
testSwitchNotifications :: HasTestEnv => AgentConfig -> (AgentClient -> ByteString -> AgentClient -> ByteString -> ExceptT AgentErrorType IO ()) -> InitialAgentServers -> APNSMockServer -> IO ()
testSwitchNotifications cfg completeSwitch servers apns =
withAgentClientsCfgServers2 cfg cfg servers $ \a b -> runRight_ $ do
(aId, bId) <- makeConnection a b
@@ -893,7 +901,7 @@ testSwitchNotifications cfg completeSwitch servers apns =
liftIO $ threadDelay 500000
testMessage "hello again"
testNotificationsOldToken :: APNSMockServer -> IO ()
testNotificationsOldToken :: HasTestEnv => APNSMockServer -> IO ()
testNotificationsOldToken apns =
withAgentClients3 $ \a b c -> runRight_ $ do
(abId, baId) <- makeConnection a b
@@ -912,7 +920,7 @@ testNotificationsOldToken apns =
let testMessageAC = testMessage_ apns a acId c caId
testMessageAC "greetings"
testNotificationsNewToken :: APNSMockServer -> ThreadId -> IO ()
testNotificationsNewToken :: HasTestEnv => APNSMockServer -> ThreadId -> IO ()
testNotificationsNewToken apns oldNtf =
withAgentClients3 $ \a b c -> runRight_ $ do
(abId, baId) <- makeConnection a b
@@ -934,7 +942,7 @@ testNotificationsNewToken apns oldNtf =
let testMessageAC = testMessage_ apns a acId c caId
testMessageAC "greetings"
testMigrateToServiceSubscriptions :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
testMigrateToServiceSubscriptions :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO ()
testMigrateToServiceSubscriptions ps@(t, msType) = withAgentClients2 $ \a b -> do
(c1, c2, c3) <- withSmpServerConfigOn t cfgNoService testPort $ \_ -> do
(c1, c2) <- withAPNSMockServer $ \apns -> do
@@ -1032,7 +1040,7 @@ testMessage_ apns a aId b bId msg = do
messageNotification :: HasCallStack => APNSMockServer -> DeviceToken -> ExceptT AgentErrorType IO (C.CbNonce, ByteString)
messageNotification apns tkn = do
500000 `timeout` getMockNotification apns tkn >>= \case
5000000 `timeout` getMockNotification apns tkn >>= \case
Nothing -> error "no notification"
Just APNSMockRequest {notification = APNSNotification {aps = APNSMutableContent {}, notificationData = Just ntfData}} -> do
nonce <- C.unsafeCbNonce <$> ntfData .-> "nonce"
tests/AgentTests/ResolveNameTests.hs
+15 -15
View File
@@ -32,7 +32,7 @@ import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.SimplexName (SimplexDomain (..), SimplexTLD (..))
import Simplex.Messaging.Transport
import Test.Hspec hiding (fit, it)
import Util (it)
import Util (HasTestEnv, it)
nameSrvCfg :: SMPServer -> ServerCfg 'SMP.PSMP
nameSrvCfg = presetServerCfg True ServerRoles {storage = True, proxy = False, names = True} (Just 1) . SMP.noAuthSrv
@@ -40,16 +40,16 @@ nameSrvCfg = presetServerCfg True ServerRoles {storage = True, proxy = False, na
proxySrvCfg :: SMPServer -> ServerCfg 'SMP.PSMP
proxySrvCfg = presetServerCfg True ServerRoles {storage = True, proxy = True, names = False} (Just 1) . SMP.noAuthSrv
oneSrv :: ServerCfg 'SMP.PSMP -> InitialAgentServers
oneSrv :: HasTestEnv => ServerCfg 'SMP.PSMP -> InitialAgentServers
oneSrv cfg_ = (initAgentServersProxy_ SPMNever SPFProhibit) {smp = [(1, [cfg_])]}
withDirectResolver :: (Status, LB.ByteString) -> (AgentClient -> IO a) -> IO a
withDirectResolver :: HasTestEnv => (Status, LB.ByteString) -> (AgentClient -> IO a) -> IO a
withDirectResolver (st, body) k =
NRS.withResolverServer (NRS.resolveResp st body) $ \port _ ->
withSmpServerConfigOn (transport @TLS) (withNames port memCfg) testPort $ \_ ->
withAgent 1 agentCfg (oneSrv (nameSrvCfg testSMPServer)) testDB k
withProxyAndResolver :: (Status, LB.ByteString) -> (AgentClient -> IO a) -> IO a
withProxyAndResolver :: HasTestEnv => (Status, LB.ByteString) -> (AgentClient -> IO a) -> IO a
withProxyAndResolver (st, body) k =
NRS.withResolverServer (NRS.resolveResp st body) $ \port _ ->
withSmpServerConfigOn (transport @TLS) memProxyCfg testPort $ \_ ->
@@ -59,12 +59,12 @@ withProxyAndResolver (st, body) k =
-- only testSMPServer2 (the resolver) has the names role; testSMPServer is the proxy
proxyServers = (initAgentServersProxy_ SPMAlways SPFProhibit) {smp = [(1, [proxySrvCfg testSMPServer, nameSrvCfg testSMPServer2])]}
withNoResolver :: (AgentClient -> IO a) -> IO a
withNoResolver :: HasTestEnv => (AgentClient -> IO a) -> IO a
withNoResolver k =
withSmpServerConfigOn (transport @TLS) memCfg testPort $ \_ ->
withAgent 1 agentCfg (oneSrv (nameSrvCfg testSMPServer)) testDB k
withNoNameServers :: (AgentClient -> IO a) -> IO a
withNoNameServers :: HasTestEnv => (AgentClient -> IO a) -> IO a
withNoNameServers k = withAgent 1 agentCfg (oneSrv (proxySrvCfg testSMPServer)) testDB k
resolveNameTests :: Spec
@@ -88,7 +88,7 @@ resolveNameTests = do
describe "name availability" $
it "an unregistered name answers as available" testAvailSuccess
testAvailSuccess :: HasCallStack => IO ()
testAvailSuccess :: (HasCallStack, HasTestEnv) => IO ()
testAvailSuccess =
withDirectResolver (status200, availableBody) $ \c -> do
r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexDomain TLDSimplex "alice" [])
@@ -98,7 +98,7 @@ testAvailSuccess =
-- | 404 is a resolver that predates /v2/resolve: no status from that endpoint
-- means "not registered", since an unregistered name answers NRAvailable.
testDirectResolverErr :: HasCallStack => IO ()
testDirectResolverErr :: (HasCallStack, HasTestEnv) => IO ()
testDirectResolverErr =
withDirectResolver (status404, "{}") $ \c -> do
r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexDomain TLDSimplex "alice" [])
@@ -106,7 +106,7 @@ testDirectResolverErr =
Left (SMP _ (SMP.NAME (SMP.RESOLVER _))) -> pure ()
_ -> expectationFailure $ "expected Left (SMP _ (NAME (RESOLVER _))), got: " <> show r
testProxyResolverErr :: HasCallStack => IO ()
testProxyResolverErr :: (HasCallStack, HasTestEnv) => IO ()
testProxyResolverErr =
withProxyAndResolver (status404, "{}") $ \c -> do
r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexDomain TLDSimplex "alice" [])
@@ -114,7 +114,7 @@ testProxyResolverErr =
Left (SMP host (SMP.NAME (SMP.RESOLVER _))) | testPort `isInfixOf` host -> pure ()
_ -> expectationFailure $ "expected Left (SMP <proxyHost:" <> testPort <> "> (NAME (RESOLVER _))), got: " <> show r
testTestingTldResolverErr :: HasCallStack => IO ()
testTestingTldResolverErr :: (HasCallStack, HasTestEnv) => IO ()
testTestingTldResolverErr =
withDirectResolver (status404, "{}") $ \c -> do
r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexDomain TLDTesting "bob" [])
@@ -122,7 +122,7 @@ testTestingTldResolverErr =
Left (SMP _ (SMP.NAME (SMP.RESOLVER _))) -> pure ()
_ -> expectationFailure $ "expected Left (SMP _ (NAME (RESOLVER _))), got: " <> show r
testWebTldResolverErr :: HasCallStack => IO ()
testWebTldResolverErr :: (HasCallStack, HasTestEnv) => IO ()
testWebTldResolverErr =
withDirectResolver (status404, "{}") $ \c -> do
r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexDomain TLDWeb "example.com" [])
@@ -130,7 +130,7 @@ testWebTldResolverErr =
Left (SMP _ (SMP.NAME (SMP.RESOLVER _))) -> pure ()
_ -> expectationFailure $ "expected Left (SMP _ (NAME (RESOLVER _))), got: " <> show r
testNoResolver :: HasCallStack => IO ()
testNoResolver :: (HasCallStack, HasTestEnv) => IO ()
testNoResolver =
withNoResolver $ \c -> do
r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexDomain TLDSimplex "alice" [])
@@ -138,7 +138,7 @@ testNoResolver =
Left (SMP _ (SMP.NAME SMP.NO_RESOLVER)) -> pure ()
_ -> expectationFailure $ "expected Left (SMP _ (NAME NO_RESOLVER)), got: " <> show r
testNoNameServers :: HasCallStack => IO ()
testNoNameServers :: (HasCallStack, HasTestEnv) => IO ()
testNoNameServers =
withNoNameServers $ \c -> do
r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexDomain TLDSimplex "alice" [])
@@ -146,7 +146,7 @@ testNoNameServers =
Left NO_NAME_SERVERS -> pure ()
_ -> expectationFailure $ "expected Left NO_NAME_SERVERS, got: " <> show r
testBackendError :: HasCallStack => IO ()
testBackendError :: (HasCallStack, HasTestEnv) => IO ()
testBackendError =
withDirectResolver (status502, "{}") $ \c -> do
r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexDomain TLDSimplex "alice" [])
@@ -154,7 +154,7 @@ testBackendError =
Left (SMP _ (SMP.NAME (SMP.RESOLVER _))) -> pure ()
_ -> expectationFailure $ "expected Left (SMP _ (NAME (RESOLVER ..))), got: " <> show r
testDirectSuccess :: HasCallStack => IO ()
testDirectSuccess :: (HasCallStack, HasTestEnv) => IO ()
testDirectSuccess =
withDirectResolver (status200, registeredBody testNameRecord) $ \c -> do
r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexDomain TLDSimplex "alice" [])
tests/AgentTests/ServerChoice.hs
+2 -2
View File
@@ -57,7 +57,7 @@ storageOnly = ServerRoles {storage = True, proxy = False, names = False}
proxyOnly :: ServerRoles
proxyOnly = ServerRoles {storage = False, proxy = True, names = False}
initServers :: InitialAgentServers
initServers :: HasTestEnv => InitialAgentServers
initServers =
InitialAgentServers
{ smp = M.fromList [(1, testSMPServers)],
@@ -70,7 +70,7 @@ initServers =
presetServers = []
}
testChooseDifferentOperator :: IO ()
testChooseDifferentOperator :: HasTestEnv => IO ()
testChooseDifferentOperator = withAgent 1 agentCfg initServers testDB $ \c -> runRight_ $ do
-- chooses the only operator with storage role
srv1 <- withAgentEnv c $ getNextServer c 1 storageSrvs []
tests/CLITests.hs
+22 -22
View File
@@ -49,32 +49,32 @@ import Util
import qualified Data.ByteString.Char8 as B
import qualified Database.PostgreSQL.Simple as PSQL
import Database.PostgreSQL.Simple.Types (Query (..))
import NtfClient (ntfTestServerDBConnectInfo, ntfTestServerDBConnstr, ntfTestStoreDBOpts)
import NtfClient (ntfTestServerDBConnectInfo, ntfTestServerDBConnstr, ntfTestServerDBOpts)
import SMPClient (postgressBracket)
import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..))
import Simplex.Messaging.Notifications.Server.Main
#endif
cfgPath :: FilePath
cfgPath = "tests/tmp/cli/etc/opt/simplex"
cfgPath :: HasTestEnv => FilePath
cfgPath = testPath "cli/etc/opt/simplex"
logPath :: FilePath
logPath = "tests/tmp/cli/etc/var/simplex"
logPath :: HasTestEnv => FilePath
logPath = testPath "cli/etc/var/simplex"
webPath :: FilePath
webPath = "tests/tmp/cli/var/www"
webPath :: HasTestEnv => FilePath
webPath = testPath "cli/var/www"
ntfCfgPath :: FilePath
ntfCfgPath = "tests/tmp/cli/etc/opt/simplex-notifications"
ntfCfgPath :: HasTestEnv => FilePath
ntfCfgPath = testPath "cli/etc/opt/simplex-notifications"
ntfLogPath :: FilePath
ntfLogPath = "tests/tmp/cli/etc/var/simplex-notifications"
ntfLogPath :: HasTestEnv => FilePath
ntfLogPath = testPath "cli/etc/var/simplex-notifications"
fileCfgPath :: FilePath
fileCfgPath = "tests/tmp/cli/etc/opt/simplex-files"
fileCfgPath :: HasTestEnv => FilePath
fileCfgPath = testPath "cli/etc/opt/simplex-files"
fileLogPath :: FilePath
fileLogPath = "tests/tmp/cli/etc/var/simplex-files"
fileLogPath :: HasTestEnv => FilePath
fileLogPath = testPath "cli/etc/var/simplex-files"
cliTests :: Spec
cliTests = do
@@ -87,7 +87,7 @@ cliTests = do
it "static files" smpServerTestStatic
it "cloud scripts disable embedded web without certificates" smpCloudScriptsDisableWeb
#if defined(dbServerPostgres)
around_ (postgressBracket ntfTestServerDBConnectInfo) $ before_ (createNtfSchema ntfTestServerDBConnectInfo ntfTestStoreDBOpts) $
around_ (postgressBracket ntfTestServerDBConnectInfo) $ before_ (createNtfSchema ntfTestServerDBConnectInfo ntfTestServerDBOpts) $
describe "Ntf server CLI" $ do
it "should initialize, start and delete the server (no store log)" $ ntfServerTest False
it "should initialize, start and delete the server (with store log)" $ ntfServerTest True
@@ -96,7 +96,7 @@ cliTests = do
it "should initialize, start and delete the server (no store log)" $ xftpServerTest False
it "should initialize, start and delete the server (with store log)" $ xftpServerTest True
smpServerTest :: Bool -> Bool -> IO ()
smpServerTest :: HasTestEnv => Bool -> Bool -> IO ()
smpServerTest storeLog basicAuth = do
-- init
capture_ (withArgs (["init", "-y"] <> ["--disable-store-log" | not storeLog] <> ["--no-password" | not basicAuth]) $ smpServerCLI cfgPath logPath)
@@ -122,7 +122,7 @@ smpServerTest storeLog basicAuth = do
XF.readSignedObject certPath >>= \case
[cert'] -> pure . X.signedObject $ X.getSigned cert'
_ -> error "bad crt format"
r' <- lines <$> capture_ (withArgs ["cert"] $ (100000 `timeout` smpServerCLI cfgPath logPath) `catchAll_` pure (Just ()))
r' <- lines <$> capture_ (withArgs ["cert"] $ smpServerCLI cfgPath logPath)
r' `shouldContain` ["Generated new server credentials"]
newCrt <-
XF.readSignedObject certPath >>= \case
@@ -137,7 +137,7 @@ smpServerTest storeLog basicAuth = do
>>= (`shouldSatisfy` ("WARNING: deleting the server will make all queues inaccessible" `isPrefixOf`))
doesFileExist (cfgPath <> "/ca.key") `shouldReturn` False
smpServerTestStatic :: HasCallStack => IO ()
smpServerTestStatic :: (HasCallStack, HasTestEnv) => IO ()
smpServerTestStatic = do
let iniFile = cfgPath <> "/smp-server.ini"
capture_ (withArgs ["init", "-y", "--no-password", "--web-path", webPath] $ smpServerCLI cfgPath logPath)
@@ -225,7 +225,7 @@ createNtfSchema connInfo DBOpts {schema} = do
void $ PSQL.execute_ db $ Query $ "CREATE SCHEMA " <> schema
PSQL.close db
ntfServerTest :: Bool -> IO ()
ntfServerTest :: HasTestEnv => Bool -> IO ()
ntfServerTest storeLog = do
capture_ (withArgs (["init", "--database=" <> B.unpack ntfTestServerDBConnstr] <> ["--disable-store-log" | not storeLog]) $ ntfServerCLI ntfCfgPath ntfLogPath)
>>= (`shouldSatisfy` (("Server initialized, you can modify configuration in " <> ntfCfgPath <> "/ntf-server.ini") `isPrefixOf`))
@@ -244,9 +244,9 @@ ntfServerTest storeLog = do
doesFileExist (cfgPath <> "/ca.key") `shouldReturn` False
#endif
xftpServerTest :: Bool -> IO ()
xftpServerTest :: HasTestEnv => Bool -> IO ()
xftpServerTest storeLog = do
capture_ (withArgs (["init", "-p", "tests/tmp", "-q", "10gb"] <> ["--disable-store-log" | not storeLog]) $ xftpServerCLI fileCfgPath fileLogPath)
capture_ (withArgs (["init", "-p", testDir, "-q", "10gb"] <> ["--disable-store-log" | not storeLog]) $ xftpServerCLI fileCfgPath fileLogPath)
>>= (`shouldSatisfy` (("Server initialized, you can modify configuration in " <> fileCfgPath <> "/file-server.ini") `isPrefixOf`))
Right ini <- readIniFile $ fileCfgPath <> "/file-server.ini"
lookupValue "STORE_LOG" "enable" ini `shouldBe` Right (if storeLog then "on" else "off")
tests/CoreTests/CryptoFileTests.hs
+8 -8
View File
@@ -24,10 +24,10 @@ cryptoFileTests = do
it "should put/read file" testPutReadFile
it "should fail reading empty or small file" testSmallFile
testFilePath :: FilePath
testFilePath = "tests/tmp/testcryptofile"
testFilePath :: HasTestEnv => FilePath
testFilePath = testPath "testcryptofile"
testWriteReadFile :: IO ()
testWriteReadFile :: HasTestEnv => IO ()
testWriteReadFile = do
g <- C.newRandom
s <- atomically $ LB.fromStrict <$> C.randomBytes 100000 g
@@ -39,7 +39,7 @@ testWriteReadFile = do
s' <- CF.readFile file
liftIO $ s `shouldBe` s'
testPutGetFile :: IO ()
testPutGetFile :: HasTestEnv => IO ()
testPutGetFile = do
g <- C.newRandom
s <- atomically $ LB.fromStrict <$> C.randomBytes 50000 g
@@ -59,7 +59,7 @@ testPutGetFile = do
CF.hGetTag h
liftIO $ (s <> s') `shouldBe` LB.fromStrict (s1 <> s2 <> s3)
testWriteGetFile :: IO ()
testWriteGetFile :: HasTestEnv => IO ()
testWriteGetFile = do
g <- C.newRandom
s <- atomically $ LB.fromStrict <$> C.randomBytes 100000 g
@@ -73,7 +73,7 @@ testWriteGetFile = do
liftIO $ runExceptT (CF.hGetTag h) `shouldReturn` Left FTCEInvalidAuthTag
liftIO $ s `shouldBe` LB.fromStrict (s' <> s'')
testPutReadFile :: IO ()
testPutReadFile :: HasTestEnv => IO ()
testPutReadFile = do
g <- C.newRandom
s <- atomically $ LB.fromStrict <$> C.randomBytes 50000 g
@@ -92,7 +92,7 @@ testPutReadFile = do
s'' <- CF.readFile file
liftIO $ (s <> s') `shouldBe` s''
testSmallFile :: IO ()
testSmallFile :: HasTestEnv => IO ()
testSmallFile = do
g <- C.newRandom
file <- atomically $ mkCryptoFile g
@@ -101,5 +101,5 @@ testSmallFile = do
LB.writeFile testFilePath "123"
runExceptT (CF.readFile file) `shouldReturn` Left FTCEInvalidFileSize
mkCryptoFile :: TVar ChaChaDRG -> STM CryptoFile
mkCryptoFile :: HasTestEnv => TVar ChaChaDRG -> STM CryptoFile
mkCryptoFile g = CryptoFile testFilePath . Just <$> CF.randomArgs g
tests/CoreTests/CryptoTests.hs
+4 -4
View File
@@ -146,9 +146,9 @@ instance Eq C.APrivateKey where
Just Refl -> k == k'
Nothing -> False
testPadUnpadFile :: IO ()
testPadUnpadFile :: HasTestEnv => IO ()
testPadUnpadFile = do
let f = "tests/tmp/testpad"
let f = testPath "testpad"
paddedLen = 1024 * 1024
len = 1000000
s = LB.replicate len 'a'
@@ -208,7 +208,7 @@ testLazySecretBoxFile = it "should lazily encrypt / decrypt file with a random s
g <- C.newRandom
k <- atomically $ C.randomSbKey g
nonce <- atomically $ C.randomCbNonce g
let f = "tests/tmp/testsecretbox"
let f = testPath "testsecretbox"
paddedLen = 4 * 1024 * 1024
len = 4 * 1000 * 1000 :: Int64
s = LC.fastReplicate len 'a'
@@ -236,7 +236,7 @@ testLazySecretBoxFileTailTag = it "should lazily encrypt / decrypt file with a r
g <- C.newRandom
k <- atomically $ C.randomSbKey g
nonce <- atomically $ C.randomCbNonce g
let f = "tests/tmp/testsecretbox"
let f = testPath "testsecretbox"
paddedLen = 4 * 1024 * 1024
len = 4 * 1000 * 1000 :: Int64
s = LC.fastReplicate len 'a'
tests/CoreTests/MsgStoreTests.hs
+84 -465
View File
@@ -9,15 +9,12 @@
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module CoreTests.MsgStoreTests where
import AgentTests.FunctionalAPITests (runRight, runRight_)
import Control.Concurrent (threadDelay)
import AgentTests.FunctionalAPITests (runRight_)
import Control.Concurrent.STM
import Control.Exception (bracket)
import Control.Monad
@@ -25,83 +22,53 @@ import Control.Monad.IO.Class
import Control.Monad.Trans.Except
import Crypto.Random (ChaChaDRG)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Int (Int64)
import Data.List (isPrefixOf, isSuffixOf)
import Data.Maybe (fromJust)
import Data.Time.Clock (addUTCTime)
import Data.Time.Clock.System (SystemTime (..), getSystemTime)
import SMPClient (testStoreLogFile, testStoreMsgsDir, testStoreMsgsDir2, testStoreMsgsFile, testStoreMsgsFile2)
import qualified Data.Map.Strict as M
import Data.Time.Clock.System (getSystemTime)
import Simplex.Messaging.Crypto (pattern MaxLenBS)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Protocol (EncDataBytes (..), EntityId (..), ErrorType (..), LinkId, Message (..), QueueLinkData, RecipientId, SParty (..), noMsgFlags, randomMsgId)
import Simplex.Messaging.Server (exportMessages, importMessages, printMessageStats)
import Simplex.Messaging.Server.Env.STM (MsgStore (..), journalMsgStoreDepth, readWriteQueueStore)
import Simplex.Messaging.Server.Expiration (ExpirationConfig (..), expireBeforeEpoch)
import Simplex.Messaging.Server.MsgStore.Journal
import Simplex.Messaging.Server.MsgStore.STM
import Simplex.Messaging.Server.MsgStore.Types
import Simplex.Messaging.Server.QueueStore
import Simplex.Messaging.Server.QueueStore.QueueInfo
import Simplex.Messaging.Server.QueueStore.STM (STMQueueStore (..))
import Simplex.Messaging.Server.QueueStore.Types
import Simplex.Messaging.Server.StoreLog (closeStoreLog, logCreateQueue)
import System.Directory (copyFile, createDirectoryIfMissing, listDirectory, removeFile, renameFile)
import System.FilePath ((</>))
import System.IO (IOMode (..), withFile)
import Simplex.Messaging.TMap (TMap)
import Test.Hspec hiding (fit, it)
import Util
#if defined(dbServerPostgres)
import AgentTests.FunctionalAPITests (runRight)
import Control.Concurrent (threadDelay)
import Data.Time.Clock.System (SystemTime (..))
import Database.PostgreSQL.Simple (Only (..))
import qualified Database.PostgreSQL.Simple as DB
import Simplex.Messaging.Agent.Store.Postgres.Common
import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..))
import Simplex.Messaging.Server.MsgStore.Postgres
import Simplex.Messaging.Server.QueueStore.Postgres
import SMPClient (postgressBracket, testServerDBConnectInfo, testStoreDBOpts)
import SMPClient (testStoreDBOpts)
#endif
msgStoreTests :: Spec
msgStoreTests = do
around (withMsgStore testSMTStoreConfig) $ describe "STM message store" someMsgStoreTests
around (withMsgStore $ testJournalStoreCfg MQStoreCfg) $ describe "Journal message store" $ do
someMsgStoreTests
journalMsgStoreTests
it "should export and import journal store" testExportImportStore
describe "STM message store" $ do
someMsgStoreTests testSMTStoreConfig
it "should remove deleted queues from queue store maps" $ withMsgStore testSMTStoreConfig testDeleteQueueMaps
#if defined(dbServerPostgres)
around_ (postgressBracket testServerDBConnectInfo) $ do
around (withMsgStore $ testJournalStoreCfg $ PQStoreCfg testPostgresStoreCfg) $
describe "Postgres+journal message store" $ do
someMsgStoreTests
journalMsgStoreTests
around (withMsgStore testPostgresStoreConfig) $
describe "Postgres-only message store" $ do
someMsgStoreTests
it "should correctly update message counts and canWrite flag" testUpdateMessageCounts
it "tryDelPeekMsg (ACK not from NSE) should reset message counts when queue is empty" testResetMessageCounts
it "should expire messages across commit batches" testExpireMessagesInBatches
describe "Postgres-only message store" $ do
someMsgStoreTests testPostgresStoreConfig
it "should correctly update message counts and canWrite flag" $ withMsgStore testPostgresStoreConfig testUpdateMessageCounts
it "tryDelPeekMsg (ACK not from NSE) should reset message counts when queue is empty" $ withMsgStore testPostgresStoreConfig testResetMessageCounts
it "should expire messages across commit batches" $ withMsgStore testPostgresStoreConfig testExpireMessagesInBatches
#endif
describe "Journal message store: queue state backup expiration" $ do
it "should remove old queue state backups" testRemoveQueueStateBackups
it "should expire messages in idle queues" testExpireIdleQueues
where
journalMsgStoreTests :: SpecWith (JournalMsgStore s)
journalMsgStoreTests = do
describe "queue state" $ do
it "should restore queue state from the last line" testQueueState
it "should recover when message is written and state is not" testMessageState
it "should remove journal files when queue is empty" testRemoveJournals
describe "missing files" $ do
it "should create read file when missing" testReadFileMissing
it "should switch to write file when read file missing" testReadFileMissingSwitch
it "should create write file when missing" testWriteFileMissing
it "should create read file when read and write files are missing" testReadAndWriteFilesMissing
someMsgStoreTests :: MsgStoreClass s => SpecWith s
someMsgStoreTests = do
it "should get queue and store/read messages" testGetQueue
it "should write/ack messages" testWriteAckMessages
it "should not fail on EOF when changing read journal" testChangeReadJournal
it "should not add link data to secured messaging queue" testLinkDataSecuredQueue
someMsgStoreTests :: MsgStoreClass s => (HasTestEnv => MsgStoreConfig s) -> Spec
someMsgStoreTests cfg = do
it "should get queue and store/read messages" $ withMsgStore cfg testGetQueue
it "should write/ack messages" $ withMsgStore cfg testWriteAckMessages
it "should not add link data to secured messaging queue" $ withMsgStore cfg testLinkDataSecuredQueue
-- TODO constrain to STM stores?
withMsgStore :: MsgStoreClass s => MsgStoreConfig s -> (s -> IO ()) -> IO ()
@@ -110,30 +77,15 @@ withMsgStore cfg = bracket (newMsgStore cfg) closeMsgStore
testSMTStoreConfig :: STMStoreConfig
testSMTStoreConfig = STMStoreConfig {storePath = Nothing, quota = 3}
testJournalStoreCfg :: QStoreCfg s -> JournalStoreConfig s
testJournalStoreCfg queueStoreCfg =
JournalStoreConfig
{ storePath = testStoreMsgsDir,
pathParts = journalMsgStoreDepth,
queueStoreCfg,
quota = 3,
maxMsgCount = 4,
maxStateLines = 2,
stateTailSize = 256,
idleInterval = 21600,
expireBackupsAfter = 0,
keepMinBackups = 1
}
#if defined(dbServerPostgres)
testPostgresStoreConfig :: PostgresMsgStoreCfg
testPostgresStoreConfig :: HasTestEnv => PostgresMsgStoreCfg
testPostgresStoreConfig =
PostgresMsgStoreCfg
{ queueStoreCfg = testPostgresStoreCfg,
quota = 3
}
testPostgresStoreCfg :: PostgresStoreCfg
testPostgresStoreCfg :: HasTestEnv => PostgresStoreCfg
testPostgresStoreCfg =
PostgresStoreCfg
{ dbOpts = testStoreDBOpts,
@@ -153,12 +105,6 @@ mkMessage body = liftIO $ do
pattern Msg :: ByteString -> Maybe Message
pattern Msg s <- Just Message {msgBody = MaxLenBS s}
deriving instance Eq MsgQueueState
deriving instance Eq (JournalState t)
deriving instance Eq (SJournalType t)
testNewQueueRec :: TVar ChaChaDRG -> QueueMode -> IO (RecipientId, QueueRec)
testNewQueueRec g qm = testNewQueueRecData g qm Nothing
@@ -185,6 +131,18 @@ testNewQueueRecData g qm queueData = do
where
rndId = atomically $ EntityId <$> C.randomBytes 24 g
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
}
testGetQueue :: MsgStoreClass s => s -> IO ()
testGetQueue ms = do
g <- C.newRandom
@@ -249,25 +207,6 @@ testWriteAckMessages ms = do
void $ ExceptT $ deleteQueue ms q1
void $ ExceptT $ deleteQueue ms q2
testChangeReadJournal :: MsgStoreClass s => s -> IO ()
testChangeReadJournal ms = do
g <- C.newRandom
(rId, qr) <- testNewQueueRec g QMMessaging
runRight_ $ do
q <- ExceptT $ addQueue ms rId qr
let write s = writeMsg ms q True =<< mkMessage s
Just (Message {msgId = mId1}, True) <- write "message 1"
(Msg "message 1", Nothing) <- tryDelPeekMsg ms q mId1
Just (Message {msgId = mId2}, True) <- write "message 2"
(Msg "message 2", Nothing) <- tryDelPeekMsg ms q mId2
Just (Message {msgId = mId3}, True) <- write "message 3"
(Msg "message 3", Nothing) <- tryDelPeekMsg ms q mId3
Just (Message {msgId = mId4}, True) <- write "message 4"
(Msg "message 4", Nothing) <- tryDelPeekMsg ms q mId4
Just (Message {msgId = mId5}, True) <- write "message 5"
(Msg "message 5", Nothing) <- tryDelPeekMsg ms q mId5
void $ ExceptT $ deleteQueue ms q
testLinkDataSecuredQueue :: MsgStoreClass s => s -> IO ()
testLinkDataSecuredQueue ms = do
g <- C.newRandom
@@ -295,57 +234,55 @@ testLinkDataSecuredQueue ms = do
void $ ExceptT $ deleteQueue ms q
void $ ExceptT $ deleteQueue ms cq
testExportImportStore :: JournalMsgStore 'QSMemory -> IO ()
testExportImportStore ms = do
g <- C.newRandom
(rId1, qr1) <- testNewQueueRec g QMMessaging
(rId2, qr2) <- testNewQueueRec g QMMessaging
sl <- readWriteQueueStore True (mkQueue ms True) testStoreLogFile $ stmQueueStore ms
runRight_ $ do
let write q s = writeMsg ms q True =<< mkMessage s
q1 <- ExceptT $ addQueue ms rId1 qr1
liftIO $ logCreateQueue sl rId1 qr1
Just (Message {}, True) <- write q1 "message 1"
Just (Message {}, False) <- write q1 "message 2"
q2 <- ExceptT $ addQueue ms rId2 qr2
liftIO $ logCreateQueue sl rId2 qr2
Just (Message {msgId = mId3}, True) <- write q2 "message 3"
Just (Message {msgId = mId4}, False) <- write q2 "message 4"
(Msg "message 3", Msg "message 4") <- tryDelPeekMsg ms q2 mId3
(Msg "message 4", Nothing) <- tryDelPeekMsg ms q2 mId4
Just (Message {}, True) <- write q2 "message 5"
Just (Message {}, False) <- write q2 "message 6"
Just (Message {}, False) <- write q2 "message 7"
Nothing <- write q2 "message 8"
pure ()
length <$> listDirectory (msgQueueDirectory ms rId1) `shouldReturn` 2
length <$> listDirectory (msgQueueDirectory ms rId2) `shouldReturn` 3
exportMessages False (StoreJournal ms) testStoreMsgsFile False
closeMsgStore ms
closeStoreLog sl
-- export with closed queues and compare
ms2 <- newMsgStore $ testJournalStoreCfg MQStoreCfg
readWriteQueueStore True (mkQueue ms2 True) testStoreLogFile (stmQueueStore ms2) >>= closeStoreLog
exportMessages False (StoreJournal ms2) (testStoreMsgsFile <> ".copy") False
s <- B.readFile testStoreMsgsFile
B.readFile (testStoreMsgsFile <> ".copy") `shouldReturn` s
-- sizes of queues, senders, links and notifiers maps
type QueueMapSizes = (Int, Int, Int, Int)
let cfg = (testJournalStoreCfg MQStoreCfg :: JournalStoreConfig 'QSMemory) {storePath = testStoreMsgsDir2}
ms' <- newMsgStore cfg
readWriteQueueStore True (mkQueue ms' True) testStoreLogFile (stmQueueStore ms') >>= closeStoreLog
stats@MessageStats {storedMsgsCount = 5, expiredMsgsCount = 0, storedQueues = 2} <-
importMessages False ms' testStoreMsgsFile Nothing False
printMessageStats "Messages" stats
length <$> listDirectory (msgQueueDirectory ms rId1) `shouldReturn` 2
length <$> listDirectory (msgQueueDirectory ms rId2) `shouldReturn` 3 -- 2 message files
exportMessages False (StoreJournal ms') testStoreMsgsFile2 False
(B.readFile testStoreMsgsFile2 `shouldReturn`) =<< B.readFile (testStoreMsgsFile <> ".bak")
stmStore <- newMsgStore testSMTStoreConfig
readWriteQueueStore True (mkQueue stmStore True) testStoreLogFile (queueStore stmStore) >>= closeStoreLog
MessageStats {storedMsgsCount = 5, expiredMsgsCount = 0, storedQueues = 2} <-
importMessages False stmStore testStoreMsgsFile2 Nothing False
exportMessages False (StoreMemory stmStore) testStoreMsgsFile False
(B.sort <$> B.readFile testStoreMsgsFile `shouldReturn`) =<< (B.sort <$> B.readFile (testStoreMsgsFile2 <> ".bak"))
queueMapSizes :: STMMsgStore -> IO QueueMapSizes
queueMapSizes ms = (,,,) <$> size queues <*> size senders <*> size links <*> size notifiers
where
STMQueueStore {queues, senders, links, notifiers} = queueStore ms
size :: TMap k v -> IO Int
size = fmap M.size . readTVarIO
testDeleteQueueMaps :: STMMsgStore -> IO ()
testDeleteQueueMaps ms = do
g <- C.newRandom
ntfCreds <- testNtfCreds g
let newLinkId = atomically $ EntityId <$> C.randomBytes 24 g
lnkId1 <- newLinkId
lnkId2 <- newLinkId
lnkId3 <- newLinkId
(rId1, qr1) <- testNewQueueRec g QMMessaging
(rId2, qr2) <- testNewQueueRecData g QMContact (Just (lnkId1, testLinkData))
(rId3, qr3) <- testNewQueueRec g QMMessaging
(rId4, qr4) <- testNewQueueRec g QMMessaging
let rIds = [rId1, rId2, rId3, rId4] :: [RecipientId]
sIds = map senderId [qr1, qr2, qr3, qr4]
lnkIds = [lnkId1, lnkId2, lnkId3] :: [LinkId]
queueMapSizes ms `shouldReturn` (0, 0, 0, 0)
runRight_ $ do
q1 <- ExceptT $ addQueue ms rId1 qr1 {notifier = Just ntfCreds}
q2 <- ExceptT $ addQueue ms rId2 qr2
q3 <- ExceptT $ addQueue ms rId3 qr3
q4 <- ExceptT $ addQueue ms rId4 qr4
ExceptT $ addQueueLinkData (queueStore ms) q3 lnkId2 testLinkData
ExceptT $ addQueueLinkData (queueStore ms) q4 lnkId3 testLinkData
forM_ sIds $ void . ExceptT . getQueue ms SSender
forM_ lnkIds $ void . ExceptT . getQueue ms SSenderLink
liftIO $ queueMapSizes ms `shouldReturn` (4, 4, 3, 1)
ExceptT $ deleteQueueLinkData (queueStore ms) q3
liftIO $ queueMapSizes ms `shouldReturn` (4, 4, 2, 1)
forM_ ([q1, q2, q3, q4] :: [STMQueue]) $ void . ExceptT . deleteQueue ms
queueMapSizes ms `shouldReturn` (0, 0, 0, 0)
forM_ rIds $ \rId -> getQueue ms SRecipient rId >>= expectAuth
forM_ sIds $ \sId -> getQueue ms SSender sId >>= expectAuth
forM_ lnkIds $ \lnkId -> getQueue ms SSenderLink lnkId >>= expectAuth
queueMapSizes ms `shouldReturn` (0, 0, 0, 0)
where
expectAuth = either (`shouldBe` AUTH) (\_ -> expectationFailure "deleted queue is still found")
testLinkData :: QueueLinkData
testLinkData = (EncDataBytes "fixed data", EncDataBytes "user data")
#if defined(dbServerPostgres)
testUpdateMessageCounts :: PostgresMsgStore -> IO ()
@@ -455,321 +392,3 @@ testExpireMessagesInBatches ms = do
where
go n = write q "fill" >>= maybe (pure n) (const $ go (n + 1))
#endif
testQueueState :: JournalMsgStore s -> IO ()
testQueueState ms = do
g <- C.newRandom
rId <- EntityId <$> atomically (C.randomBytes 24 g)
let dir = msgQueueDirectory ms rId
statePath = msgQueueStatePath dir rId
createDirectoryIfMissing True dir
state <- newMsgQueueState <$> newJournalId (random ms)
withFile statePath WriteMode (`appendState` state)
length . lines <$> readFile statePath `shouldReturn` 1
readQueueState ms statePath `shouldReturn` (Just state, False)
length <$> listDirectory dir `shouldReturn` 1 -- no backup
let state1 =
state
{ size = 1,
readState = (readState state) {msgCount = 1, byteCount = 100},
writeState = (writeState state) {msgPos = 1, msgCount = 1, bytePos = 100, byteCount = 100}
}
withFile statePath AppendMode (`appendState` state1)
length . lines <$> readFile statePath `shouldReturn` 2
readQueueState ms statePath `shouldReturn` (Just state1, False)
length <$> listDirectory dir `shouldReturn` 1 -- no backup
let state2 =
state
{ size = 2,
readState = (readState state) {msgCount = 2, byteCount = 200},
writeState = (writeState state) {msgPos = 2, msgCount = 2, bytePos = 200, byteCount = 200}
}
withFile statePath AppendMode (`appendState` state2)
length . lines <$> readFile statePath `shouldReturn` 3
copyFile statePath (statePath <> ".2")
readQueueState ms statePath `shouldReturn` (Just state2, True)
length <$> listDirectory dir `shouldReturn` 2 -- new state + copy
ls <- lines <$> readFile statePath
length ls `shouldBe` 3
-- mock compacting file
writeFile statePath $ last ls
-- corrupt the only line
corruptFile statePath
(Nothing, True) <- readQueueState ms statePath
-- corrupt the last line
renameFile (statePath <> ".2") statePath
removeOtherFiles dir statePath
length . lines <$> readFile statePath `shouldReturn` 3
corruptFile statePath
readQueueState ms statePath `shouldReturn` (Just state1, True)
length <$> listDirectory dir `shouldReturn` 1
length . lines <$> readFile statePath `shouldReturn` 3
where
corruptFile f = do
s <- readFile f
removeFile f
writeFile f $ take (length s - 4) s
removeOtherFiles dir keep = do
names <- listDirectory dir
forM_ names $ \name ->
let f = dir </> name
in unless (f == keep) $ removeFile f
testMessageState :: JournalMsgStore s -> IO ()
testMessageState ms = do
g <- C.newRandom
(rId, qr) <- testNewQueueRec g QMMessaging
let dir = msgQueueDirectory ms rId
statePath = msgQueueStatePath dir rId
write q s = writeMsg ms q True =<< mkMessage s
mId1 <- runRight $ do
q <- ExceptT $ addQueue ms rId qr
Just (Message {msgId = mId1}, True) <- write q "message 1"
Just (Message {}, False) <- write q "message 2"
liftIO $ closeMsgQueue ms q
pure mId1
ls <- B.lines <$> B.readFile statePath
B.writeFile statePath $ B.unlines $ take (length ls - 1) ls
runRight_ $ do
q <- ExceptT $ getQueue ms SRecipient rId
Just (Message {msgId = mId3}, False) <- write q "message 3"
(Msg "message 1", Msg "message 3") <- tryDelPeekMsg ms q mId1
(Msg "message 3", Nothing) <- tryDelPeekMsg ms q mId3
liftIO $ closeMsgQueue ms q
testRemoveJournals :: JournalMsgStore s -> IO ()
testRemoveJournals ms = do
g <- C.newRandom
(rId, qr) <- testNewQueueRec g QMMessaging
let dir = msgQueueDirectory ms rId
statePath = msgQueueStatePath dir rId
write q s = writeMsg ms q True =<< mkMessage s
runRight $ do
q <- ExceptT $ addQueue ms rId qr
Just (Message {msgId = mId1}, True) <- write q "message 1"
Just (Message {msgId = mId2}, False) <- write q "message 2"
(Msg "message 1", Msg "message 2") <- tryDelPeekMsg ms q mId1
(Msg "message 2", Nothing) <- tryDelPeekMsg ms q mId2
liftIO $ closeMsgQueue ms q
ls <- B.lines <$> B.readFile statePath
length ls `shouldBe` 4
journalFilesCount dir `shouldReturn` 1
stateBackupCount dir `shouldReturn` 0
runRight $ do
q <- ExceptT $ getQueue ms SRecipient rId
-- not removed yet
liftIO $ journalFilesCount dir `shouldReturn` 1
liftIO $ stateBackupCount dir `shouldReturn` 0
Nothing <- tryPeekMsg ms q
-- still not removed, queue is empty and not opened
liftIO $ journalFilesCount dir `shouldReturn` 1
_mq <- isolateQueue ms q "test" $ getMsgQueue ms q False
-- journal is removed
liftIO $ journalFilesCount dir `shouldReturn` 0
liftIO $ stateBackupCount dir `shouldReturn` 1
Just (Message {msgId = mId3}, True) <- write q "message 3"
-- journal is created
liftIO $ journalFilesCount dir `shouldReturn` 1
Just (Message {msgId = mId4}, False) <- write q "message 4"
(Msg "message 3", Msg "message 4") <- tryDelPeekMsg ms q mId3
(Msg "message 4", Nothing) <- tryDelPeekMsg ms q mId4
Just (Message {msgId = mId5}, True) <- write q "message 5"
Just (Message {msgId = mId6}, False) <- write q "message 6"
liftIO $ journalFilesCount dir `shouldReturn` 1
Just (Message {msgId = mId7}, False) <- write q "message 7"
-- separate write journal is created
liftIO $ journalFilesCount dir `shouldReturn` 2
Nothing <- write q "message 8"
(Msg "message 5", Msg "message 6") <- tryDelPeekMsg ms q mId5
liftIO $ journalFilesCount dir `shouldReturn` 2
(Msg "message 6", Msg "message 7") <- tryDelPeekMsg ms q mId6
-- read journal is removed
liftIO $ journalFilesCount dir `shouldReturn` 1
(Msg "message 7", Just MessageQuota {msgId = mId8}) <- tryDelPeekMsg ms q mId7
(Just MessageQuota {}, Nothing) <- tryDelPeekMsg ms q mId8
liftIO $ closeMsgQueue ms q
journalFilesCount dir `shouldReturn` 1
runRight $ do
q <- ExceptT $ getQueue ms SRecipient rId
Just (Message {}, True) <- write q "message 8"
liftIO $ journalFilesCount dir `shouldReturn` 1
liftIO $ stateBackupCount dir `shouldReturn` 2
liftIO $ closeMsgQueue ms q
where
journalFilesCount dir = length . filter ("messages." `isPrefixOf`) <$> listDirectory dir
stateBackupCount dir = length . filter (".bak" `isSuffixOf`) <$> listDirectory dir
testRemoveQueueStateBackups :: IO ()
testRemoveQueueStateBackups = do
g <- C.newRandom
(rId, qr) <- testNewQueueRec g QMMessaging
ms' <- newMsgStore (testJournalStoreCfg MQStoreCfg) {maxStateLines = 1, expireBackupsAfter = 0, keepMinBackups = 0}
-- set expiration time 1 second ahead
let ms = ms' {expireBackupsBefore = addUTCTime 1 $ expireBackupsBefore ms'}
let dir = msgQueueDirectory ms rId
write q s = writeMsg ms q True =<< mkMessage s
runRight $ do
q <- ExceptT $ addQueue ms rId qr
Just (Message {msgId = mId1}, True) <- write q "message 1"
Just (Message {msgId = mId2}, False) <- write q "message 2"
(Msg "message 1", Msg "message 2") <- tryDelPeekMsg ms q mId1
(Msg "message 2", Nothing) <- tryDelPeekMsg ms q mId2
liftIO $ closeMsgQueue ms q
liftIO $ stateBackupCount dir `shouldReturn` 0
q1 <- ExceptT $ getQueue ms SRecipient rId
Just (Message {}, True) <- write q1 "message 3"
Just (Message {}, False) <- write q1 "message 4"
liftIO $ closeMsgQueue ms q1
liftIO $ stateBackupCount dir `shouldReturn` 0
liftIO $ threadDelay 1000000
q2 <- ExceptT $ getQueue ms SRecipient rId
Just (Message {}, False) <- write q2 "message 5"
Nothing <- write q2 "message 5"
liftIO $ closeMsgQueue ms q2
liftIO $ stateBackupCount dir `shouldReturn` 1
where
stateBackupCount dir = length . filter (".bak" `isSuffixOf`) <$> listDirectory dir
testExpireIdleQueues :: IO ()
testExpireIdleQueues = do
g <- C.newRandom
(rId, qr) <- testNewQueueRec g QMMessaging
ms <- newMsgStore (testJournalStoreCfg MQStoreCfg) {idleInterval = 0}
let dir = msgQueueDirectory ms rId
statePath = msgQueueStatePath dir rId
write q s = writeMsg ms q True =<< mkMessage s
q <- runRight $ do
q <- ExceptT $ addQueue ms rId qr
Just (Message {msgId = mId1}, True) <- write q "message 1"
Just (Message {msgId = mId2}, False) <- write q "message 2"
(Msg "message 1", Msg "message 2") <- tryDelPeekMsg ms q mId1
(Msg "message 2", Nothing) <- tryDelPeekMsg ms q mId2
liftIO $ closeMsgQueue ms q
pure q
(Just MsgQueueState {size = 0, readState = rs, writeState = ws}, True) <- readQueueState ms statePath
msgCount rs `shouldBe` 2
msgCount ws `shouldBe` 2
old <- expireBeforeEpoch ExpirationConfig {ttl = 1, checkInterval = 1} -- no old messages
now <- systemSeconds <$> getSystemTime
(expired_, stored) <- runRight $ isolateQueue ms q "" $ withIdleMsgQueue now ms q $ deleteExpireMsgs_ old q
expired_ `shouldBe` Just 0
stored `shouldBe` 0
(Nothing, False) <- readQueueState ms statePath
pure ()
testReadFileMissing :: JournalMsgStore s -> IO ()
testReadFileMissing ms = do
g <- C.newRandom
(rId, qr) <- testNewQueueRec g QMMessaging
let write q s = writeMsg ms q True =<< mkMessage s
q <- runRight $ do
q <- ExceptT $ addQueue ms rId qr
Just (Message {}, True) <- write q "message 1"
Msg "message 1" <- tryPeekMsg ms q
pure q
mq <- fromJust <$> readTVarIO (msgQueue' q)
MsgQueueState {readState = rs} <- readTVarIO $ state mq
closeMsgQueue ms q
let path = journalFilePath (queueDirectory $ queue mq) $ journalId rs
removeFile path
runRight_ $ do
q' <- ExceptT $ getQueue ms SRecipient rId
Nothing <- tryPeekMsg ms q'
Just (Message {}, True) <- write q' "message 2"
Msg "message 2" <- tryPeekMsg ms q'
pure ()
testReadFileMissingSwitch :: JournalMsgStore s -> IO ()
testReadFileMissingSwitch ms = do
g <- C.newRandom
(rId, qr) <- testNewQueueRec g QMMessaging
q <- writeMessages ms rId qr
mq <- fromJust <$> readTVarIO (msgQueue' q)
MsgQueueState {readState = rs} <- readTVarIO $ state mq
closeMsgQueue ms q
let path = journalFilePath (queueDirectory $ queue mq) $ journalId rs
removeFile path
runRight_ $ do
q' <- ExceptT $ getQueue ms SRecipient rId
Just (Message {}, False) <- writeMsg ms q' True =<< mkMessage "message 6"
Msg "message 5" <- tryPeekMsg ms q'
pure ()
testWriteFileMissing :: JournalMsgStore s -> IO ()
testWriteFileMissing ms = do
g <- C.newRandom
(rId, qr) <- testNewQueueRec g QMMessaging
q <- writeMessages ms rId qr
mq <- fromJust <$> readTVarIO (msgQueue' q)
MsgQueueState {writeState = ws} <- readTVarIO $ state mq
closeMsgQueue ms q
let path = journalFilePath (queueDirectory $ queue mq) $ journalId ws
print path
removeFile path
runRight_ $ do
q' <- ExceptT $ getQueue ms SRecipient rId
Just Message {msgId = mId3} <- tryPeekMsg ms q'
(Msg "message 3", Msg "message 4") <- tryDelPeekMsg ms q' mId3
Just Message {msgId = mId4} <- tryPeekMsg ms q'
(Msg "message 4", Nothing) <- tryDelPeekMsg ms q' mId4
Just (Message {}, True) <- writeMsg ms q' True =<< mkMessage "message 6"
Msg "message 6" <- tryPeekMsg ms q'
pure ()
testReadAndWriteFilesMissing :: JournalMsgStore s -> IO ()
testReadAndWriteFilesMissing ms = do
g <- C.newRandom
(rId, qr) <- testNewQueueRec g QMMessaging
q <- writeMessages ms rId qr
mq <- fromJust <$> readTVarIO (msgQueue' q)
MsgQueueState {readState = rs, writeState = ws} <- readTVarIO $ state mq
closeMsgQueue ms q
removeFile $ journalFilePath (queueDirectory $ queue mq) $ journalId rs
removeFile $ journalFilePath (queueDirectory $ queue mq) $ journalId ws
runRight_ $ do
q' <- ExceptT $ getQueue ms SRecipient rId
Nothing <- tryPeekMsg ms q'
Just (Message {}, True) <- writeMsg ms q' True =<< mkMessage "message 6"
Msg "message 6" <- tryPeekMsg ms q'
pure ()
writeMessages :: JournalMsgStore s -> RecipientId -> QueueRec -> IO (JournalQueue s)
writeMessages ms rId qr = runRight $ do
q <- ExceptT $ addQueue ms rId qr
let write s = writeMsg ms q True =<< mkMessage s
Just (Message {msgId = mId1}, True) <- write "message 1"
Just (Message {msgId = mId2}, False) <- write "message 2"
Just (Message {}, False) <- write "message 3"
(Msg "message 1", Msg "message 2") <- tryDelPeekMsg ms q mId1
(Msg "message 2", Msg "message 3") <- tryDelPeekMsg ms q mId2
Just (Message {}, False) <- write "message 4"
Just (Message {}, False) <- write "message 5"
pure q
tests/CoreTests/RetryIntervalTests.hs
+34 -34
View File
@@ -29,9 +29,9 @@ testRI =
RetryInterval2
{ riSlow =
RetryInterval
{ initialInterval = 20000,
increaseAfter = 40000,
maxInterval = 40000
{ initialInterval = 100000,
increaseAfter = 200000,
maxInterval = 200000
},
riFast = testFastRI
}
@@ -39,9 +39,9 @@ testRI =
testFastRI :: RetryInterval
testFastRI =
RetryInterval
{ initialInterval = 10000,
increaseAfter = 20000,
maxInterval = 40000
{ initialInterval = 50000,
increaseAfter = 100000,
maxInterval = 200000
}
type WithRetry2 = RetryInterval2 -> (RI2State -> (RetryIntervalMode -> IO ()) -> IO ()) -> IO ()
@@ -61,15 +61,15 @@ testRetryIntervalSameMode withRetry =
when (length ints < 9) $ loop RIFast
(reverse <$> readTVarIO intervals) `shouldReturn` [0, 1, 1, 1, 2, 3, 4, 4, 4]
(reverse <$> readTVarIO reportedIntervals)
`shouldReturn` [ (20000, 10000),
(20000, 10000),
(20000, 15000),
(20000, 22500),
(20000, 33750),
(20000, 40000),
(20000, 40000),
(20000, 40000),
(20000, 40000)
`shouldReturn` [ (100000, 50000),
(100000, 50000),
(100000, 75000),
(100000, 112500),
(100000, 168750),
(100000, 200000),
(100000, 200000),
(100000, 200000),
(100000, 200000)
]
testRetryIntervalSwitchMode :: WithRetry2 -> Spec
@@ -84,17 +84,17 @@ testRetryIntervalSwitchMode withRetry =
when (length ints < 11) $ loop $ if length ints <= 5 then RIFast else RISlow
(reverse <$> readTVarIO intervals) `shouldReturn` [0, 1, 1, 1, 2, 3, 2, 2, 3, 4, 4]
(reverse <$> readTVarIO reportedIntervals)
`shouldReturn` [ (20000, 10000),
(20000, 10000),
(20000, 15000),
(20000, 22500),
(20000, 33750),
(20000, 40000),
(20000, 40000),
(30000, 40000),
(40000, 40000),
(40000, 40000),
(40000, 40000)
`shouldReturn` [ (100000, 50000),
(100000, 50000),
(100000, 75000),
(100000, 112500),
(100000, 168750),
(100000, 200000),
(100000, 200000),
(150000, 200000),
(200000, 200000),
(200000, 200000),
(200000, 200000)
]
testRetryForeground :: Spec
@@ -110,7 +110,7 @@ testRetryForeground =
when (length ints < 8) $ loop
(reverse <$> readTVarIO intervals) `shouldReturn` [0, 1, 1, 1, 2, 3, 4, 4]
(reverse <$> readTVarIO reportedIntervals)
`shouldReturn` [10000, 10000, 15000, 22500, 33750, 40000, 40000, 40000]
`shouldReturn` [50000, 50000, 75000, 112500, 168750, 200000, 200000, 200000]
testRetryToBackground :: Spec
testRetryToBackground =
@@ -121,7 +121,7 @@ testRetryToBackground =
foreground <- newTVarIO True
concurrently_
( do
threadDelay 50000
threadDelay 250000
atomically $ writeTVar foreground False
)
( withRetryForeground testFastRI (readTVar foreground) (pure True) $ \delay loop -> do
@@ -131,7 +131,7 @@ testRetryToBackground =
)
(reverse <$> readTVarIO intervals) `shouldReturn` [0, 1, 1, 1, 2, 3, 4, 4]
(reverse <$> readTVarIO reportedIntervals)
`shouldReturn` [10000, 10000, 15000, 22500, 33750, 40000, 40000, 40000]
`shouldReturn` [50000, 50000, 75000, 112500, 168750, 200000, 200000, 200000]
testRetrySkipWhenForeground :: Spec
testRetrySkipWhenForeground =
@@ -142,11 +142,11 @@ testRetrySkipWhenForeground =
foreground <- newTVarIO False
concurrently_
( do
threadDelay 65000
threadDelay 312500
atomically $ writeTVar foreground True
threadDelay 10000
threadDelay 150000
atomically $ writeTVar foreground False
threadDelay 100000
threadDelay 381250
atomically $ writeTVar foreground True
)
( withRetryForeground testFastRI (readTVar foreground) (pure True) $ \delay loop -> do
@@ -156,11 +156,11 @@ testRetrySkipWhenForeground =
)
(reverse <$> readTVarIO intervals) `shouldReturn` [0, 1, 1, 1, 2, 0, 1, 1, 1, 2, 3, 1]
(reverse <$> readTVarIO reportedIntervals)
`shouldReturn` [10000, 10000, 15000, 22500, 33750, 10000, 10000, 15000, 22500, 33750, 40000, 10000]
`shouldReturn` [50000, 50000, 75000, 112500, 168750, 50000, 50000, 75000, 112500, 168750, 200000, 50000]
addInterval :: TVar [Int] -> TVar UTCTime -> IO [Int]
addInterval intervals ts = do
ts' <- getCurrentTime
atomically $ do
int :: Int <- truncate . (* 100) . nominalDiffTimeToSeconds <$> stateTVar ts (\t -> (diffUTCTime ts' t, ts'))
int :: Int <- truncate . (* 20) . nominalDiffTimeToSeconds <$> stateTVar ts (\t -> (diffUTCTime ts' t, ts'))
stateTVar intervals $ \ints -> (int : ints, int : ints)
tests/CoreTests/StoreLogTests.hs
+9 -21
View File
@@ -28,7 +28,7 @@ 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.STM (STMMsgStore (..))
import Simplex.Messaging.Server.MsgStore.Types
import Simplex.Messaging.Server.QueueStore
import Simplex.Messaging.Server.QueueStore.STM (STMQueueStore (..))
@@ -48,18 +48,6 @@ import Simplex.Messaging.Server.Main
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)
@@ -177,10 +165,10 @@ testSMPStoreLog testSuite tests =
closeStoreLog l
replicateM_ 3 $ testReadWrite t
#if defined(dbServerPostgres)
(sCnt, qCnt) <- importStoreLogToDatabase "tests/tmp/" testStoreLogFile testStoreDBOpts
(sCnt, qCnt) <- importStoreLogToDatabase testStoreLogFile testStoreDBOpts
fromIntegral (sCnt + qCnt) `shouldBe` length (compacted t)
imported <- B.readFile $ testStoreLogFile <> ".bak"
(sCnt', qCnt') <- exportDatabaseToStoreLog "tests/tmp/" testStoreDBOpts testStoreLogFile
(sCnt', qCnt') <- exportDatabaseToStoreLog testStoreDBOpts testStoreLogFile
sCnt' `shouldBe` fromIntegral sCnt
qCnt' `shouldBe` fromIntegral qCnt
exported <- B.readFile testStoreLogFile
@@ -188,14 +176,14 @@ testSMPStoreLog testSuite tests =
#endif
where
testReadWrite SLTC {compacted, state} = do
st <- newMsgStore $ testJournalStoreCfg MQStoreCfg
l <- readWriteQueueStore True (mkQueue st True) testStoreLogFile $ stmQueueStore st
st <- newMsgStore testSMTStoreConfig
l <- readWriteQueueStore True (mkQueue st) testStoreLogFile $ queueStore 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))
storeState :: STMMsgStore -> IO (M.Map RecipientId QueueRec)
storeState st = M.mapMaybe id <$> (readTVarIO (queues $ queueStore st) >>= mapM (readTVarIO . queueRec))
type FileRecState = (FileInfo, RoundedFileTime, Maybe RoundedFileTime, ServerEntityStatus)
@@ -207,8 +195,8 @@ deriving instance Eq FileRecipient
deriving instance Eq FileStoreLogRecord
testFileStoreLogFile :: FilePath
testFileStoreLogFile = "tests/tmp/xftp-server-store.log"
testFileStoreLogFile :: HasTestEnv => FilePath
testFileStoreLogFile = testPath "xftp-server-store.log"
fileExpirationTests :: Spec
fileExpirationTests =
tests/CoreTests/XFTPStoreTests.hs
+16 -16
View File
@@ -47,7 +47,7 @@ xftpMigrationTests = describe "XFTP migration round-trip" $ do
-- Test helpers
withPgStore :: (PostgresFileStore -> IO ()) -> IO ()
withPgStore :: HasTestEnv => (PostgresFileStore -> IO ()) -> IO ()
withPgStore test = do
st <- newFileStore testXFTPPostgresCfg :: IO PostgresFileStore
test st
@@ -75,7 +75,7 @@ testExpiresAt = RoundedSystemTime 2000000
-- Tests
testAddGetFileSender :: Expectation
testAddGetFileSender :: HasTestEnv => Expectation
testAddGetFileSender = withPgStore $ \st -> do
g <- C.newRandom
(sk, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
@@ -91,7 +91,7 @@ testAddGetFileSender = withPgStore $ \st -> do
key `shouldBe` sk
Left e -> expectationFailure $ "getFile failed: " <> show e
testAddGetFileRecipient :: Expectation
testAddGetFileRecipient :: HasTestEnv => Expectation
testAddGetFileRecipient = withPgStore $ \st -> do
g <- C.newRandom
(sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
@@ -106,7 +106,7 @@ testAddGetFileRecipient = withPgStore $ \st -> do
key `shouldBe` rcpKey
Left e -> expectationFailure $ "getFile failed: " <> show e
testDuplicateFile :: Expectation
testDuplicateFile :: HasTestEnv => Expectation
testDuplicateFile = withPgStore $ \st -> do
g <- C.newRandom
(sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
@@ -114,12 +114,12 @@ testDuplicateFile = withPgStore $ \st -> do
addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Right ()
addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Left DUPLICATE_
testGetNonexistent :: Expectation
testGetNonexistent :: HasTestEnv => Expectation
testGetNonexistent = withPgStore $ \st -> do
getFile st SFSender testSenderId >>= (`shouldBe` Left AUTH) . fmap (const ())
getFile st SFRecipient testRecipientId >>= (`shouldBe` Left AUTH) . fmap (const ())
testSetFilePath :: Expectation
testSetFilePath :: HasTestEnv => Expectation
testSetFilePath = withPgStore $ \st -> do
g <- C.newRandom
(sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
@@ -134,7 +134,7 @@ testSetFilePath = withPgStore $ \st -> do
Right (FileRec {filePath}, _) -> readTVarIO filePath `shouldReturn` Just "/tmp/test_file"
Left e -> expectationFailure $ "getFile failed: " <> show e
testDuplicateRecipient :: Expectation
testDuplicateRecipient :: HasTestEnv => Expectation
testDuplicateRecipient = withPgStore $ \st -> do
g <- C.newRandom
(sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
@@ -144,7 +144,7 @@ testDuplicateRecipient = withPgStore $ \st -> do
addRecipient st testSenderId (FileRecipient testRecipientId rcpKey) `shouldReturn` Right ()
addRecipient st testSenderId (FileRecipient testRecipientId rcpKey) `shouldReturn` Left DUPLICATE_
testDeleteFileCascade :: Expectation
testDeleteFileCascade :: HasTestEnv => Expectation
testDeleteFileCascade = withPgStore $ \st -> do
g <- C.newRandom
(sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
@@ -157,7 +157,7 @@ testDeleteFileCascade = withPgStore $ \st -> do
getFile st SFSender testSenderId >>= (`shouldBe` Left AUTH) . fmap (const ())
getFile st SFRecipient testRecipientId >>= (`shouldBe` Left AUTH) . fmap (const ())
testBlockFile :: Expectation
testBlockFile :: HasTestEnv => Expectation
testBlockFile = withPgStore $ \st -> do
g <- C.newRandom
(sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
@@ -170,7 +170,7 @@ testBlockFile = withPgStore $ \st -> do
Right (FileRec {fileStatus}, _) -> readTVarIO fileStatus `shouldReturn` EntityBlocked blockInfo
Left e -> expectationFailure $ "getFile failed: " <> show e
testAckFile :: Expectation
testAckFile :: HasTestEnv => Expectation
testAckFile = withPgStore $ \st -> do
g <- C.newRandom
(sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
@@ -186,7 +186,7 @@ testAckFile = withPgStore $ \st -> do
Right _ -> pure ()
Left e -> expectationFailure $ "getFile failed: " <> show e
testExpiredFiles :: Expectation
testExpiredFiles :: HasTestEnv => Expectation
testExpiredFiles = withPgStore $ \st -> do
g <- C.newRandom
(sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
@@ -207,7 +207,7 @@ testExpiredFiles = withPgStore $ \st -> do
sz `shouldBe` 128000
_ -> expectationFailure "expected 1 expired file"
testExpiredFilesStoredExpiration :: Expectation
testExpiredFilesStoredExpiration :: HasTestEnv => Expectation
testExpiredFilesStoredExpiration = withPgStore $ \st -> do
g <- C.newRandom
(sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
@@ -219,7 +219,7 @@ testExpiredFilesStoredExpiration = withPgStore $ \st -> do
expired <- expiredFiles st (RoundedSystemTime 500000) 0 100
map (\(sId, _, _) -> sId) expired `shouldBe` [EntityId "expired_file____"]
testStorageAndCount :: Expectation
testStorageAndCount :: HasTestEnv => Expectation
testStorageAndCount = withPgStore $ \st -> do
testStorageAndCountForStore st
@@ -250,10 +250,10 @@ testStorageAndCountForStore st = do
-- Migration round-trip test
testMigrationRoundTrip :: Expectation
testMigrationRoundTrip :: HasTestEnv => Expectation
testMigrationRoundTrip = do
let storeLogPath = "tests/tmp/xftp-migration-test.log"
storeLogPath2 = "tests/tmp/xftp-migration-test2.log"
let storeLogPath = testPath "xftp-migration-test.log"
storeLogPath2 = testPath "xftp-migration-test2.log"
-- 1. Create STM store with test data
stmStore <- newFileStore () :: IO STMFileStore
g <- C.newRandom
tests/FileDescriptionTests.hs
+5 -5
View File
@@ -33,8 +33,8 @@ fileDescriptionTests = do
fileDescPath :: FilePath
fileDescPath = "tests/fixtures/file_description.yaml"
tmpFileDescPath :: FilePath
tmpFileDescPath = "tests/tmp/file_description.yaml"
tmpFileDescPath :: HasTestEnv => FilePath
tmpFileDescPath = testPath "file_description.yaml"
testSbKey :: C.SbKey
testSbKey = either error id $ strDecode "00n8p1tJq5E-SGnHcYTOrS4A9I07gTA_WFD6MTFFFOY="
@@ -144,7 +144,7 @@ testParseYAMLFileDescription = do
yfd <- Y.decodeFileThrow fileDescPath
yfd `shouldBe` yamlFileDesc
testSerializeYAMLFileDescription :: IO ()
testSerializeYAMLFileDescription :: HasTestEnv => IO ()
testSerializeYAMLFileDescription = withRemoveTmpFile $ do
Y.encodeFile tmpFileDescPath yamlFileDesc
fdSer <- B.readFile tmpFileDescPath
@@ -158,7 +158,7 @@ testParseFileDescription = do
Left e -> expectationFailure $ show e
Right fd -> fd `shouldBe` fileDesc
testSerializeFileDescription :: IO ()
testSerializeFileDescription :: HasTestEnv => IO ()
testSerializeFileDescription = withRemoveTmpFile $ do
B.writeFile tmpFileDescPath $ strEncode fileDesc
fdSer <- B.readFile tmpFileDescPath
@@ -177,7 +177,7 @@ testFileDescriptionURIExtras = do
let descr = FileDescriptionURI SSSimplex vfd $ Just "{\"something\":\"extra\",\"more\":true}"
strDecode (strEncode descr) `shouldBe` Right descr
withRemoveTmpFile :: IO () -> IO ()
withRemoveTmpFile :: HasTestEnv => IO () -> IO ()
withRemoveTmpFile =
bracket_
(pure ())
tests/NamesResolverServer.hs
+7 -3
View File
@@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
@@ -30,6 +31,7 @@ import SMPClient (AServerConfig (..), cfgMS, proxyCfgMS, testStoreLogFile2, test
import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (..), ServerStoreCfg (..), StorePaths (..))
import Simplex.Messaging.Server.MsgStore.Types (SMSType (..), SQSType (..))
import Simplex.Messaging.Server.Names (NamesConfig (..))
import Util (HasTestEnv)
-- | Run an action with a local HTTP resolver on a free port.
withResolverServer :: ([Text] -> (Status, LB.ByteString)) -> (Int -> IORef [[Text]] -> IO a) -> IO a
@@ -64,20 +66,22 @@ testNamesConfig port =
resolverMaxResponseBytes = 65536
}
memCfg :: AServerConfig
memCfg :: HasTestEnv => AServerConfig
memCfg = cfgMS (ASType SQSMemory SMSMemory)
memProxyCfg :: AServerConfig
memProxyCfg :: HasTestEnv => AServerConfig
memProxyCfg = proxyCfgMS (ASType SQSMemory SMSMemory)
memCfg2 :: AServerConfig
memCfg2 :: HasTestEnv => AServerConfig
memCfg2 = case memCfg of
ASrvCfg qt mt c -> ASrvCfg qt mt c {serverStoreCfg = newStoreCfg (serverStoreCfg c)}
where
newStoreCfg :: ServerStoreCfg s -> ServerStoreCfg s
newStoreCfg = \case
SSCMemory _ -> SSCMemory (Just StorePaths {storeLogFile = testStoreLogFile2, storeMsgsFile = Just testStoreMsgsFile2})
#if defined(dbServerPostgres)
other -> other
#endif
withNames :: Int -> AServerConfig -> AServerConfig
withNames port c = updateCfg c $ \cfg_ -> cfg_ {namesConfig = Just (testNamesConfig port)}
tests/NtfClient.hs
+31 -27
View File
@@ -60,30 +60,31 @@ import UnliftIO.Async
import UnliftIO.Concurrent
import qualified UnliftIO.Exception as E
import UnliftIO.STM
import Util
testHost :: NonEmpty TransportHost
testHost = "localhost"
apnsTestPort :: ServiceName
apnsTestPort = "6010"
apnsTestPort :: HasTestEnv => ServiceName
apnsTestPort = testServerPort 5
testKeyHash :: C.KeyHash
testKeyHash = "LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI="
ntfTestStoreLogFile :: FilePath
ntfTestStoreLogFile = "tests/tmp/ntf-server-store.log"
ntfTestStoreLogFile :: HasTestEnv => FilePath
ntfTestStoreLogFile = testPath "ntf-server-store.log"
ntfTestStoreLogFile2 :: FilePath
ntfTestStoreLogFile2 = "tests/tmp/ntf-server-store.log.2"
ntfTestStoreLogFile2 :: HasTestEnv => FilePath
ntfTestStoreLogFile2 = testPath "ntf-server-store.log.2"
ntfTestStoreLastNtfsFile :: FilePath
ntfTestStoreLastNtfsFile = "tests/tmp/ntf-server-last-notifications.log"
ntfTestStoreLastNtfsFile :: HasTestEnv => FilePath
ntfTestStoreLastNtfsFile = testPath "ntf-server-last-notifications.log"
ntfTestPrometheusMetricsFile :: FilePath
ntfTestPrometheusMetricsFile = "tests/tmp/ntf-server-metrics.txt"
ntfTestPrometheusMetricsFile :: HasTestEnv => FilePath
ntfTestPrometheusMetricsFile = testPath "ntf-server-metrics.txt"
ntfTestStoreDBOpts :: DBOpts
ntfTestStoreDBOpts =
ntfTestServerDBOpts :: DBOpts
ntfTestServerDBOpts =
DBOpts
{ connstr = ntfTestServerDBConnstr,
schema = "ntf_server",
@@ -91,8 +92,11 @@ ntfTestStoreDBOpts =
createSchema = True
}
ntfTestStoreDBOpts2 :: DBOpts
ntfTestStoreDBOpts2 = ntfTestStoreDBOpts {schema = "smp_server2"}
ntfTestStoreDBOpts :: HasTestEnv => DBOpts
ntfTestStoreDBOpts = ntfTestServerDBOpts {schema = testSchemaName "ntf_server"}
ntfTestStoreDBOpts2 :: HasTestEnv => DBOpts
ntfTestStoreDBOpts2 = ntfTestStoreDBOpts {schema = testSchemaName "smp_server2"}
ntfTestServerDBConnstr :: ByteString
ntfTestServerDBConnstr = "postgresql://ntf_test_server_user@/ntf_test_server_db"
@@ -104,7 +108,7 @@ ntfTestServerDBConnectInfo =
connectDatabase = "ntf_test_server_db"
}
ntfTestDBCfg :: PostgresStoreCfg
ntfTestDBCfg :: HasTestEnv => PostgresStoreCfg
ntfTestDBCfg =
PostgresStoreCfg
{ dbOpts = ntfTestStoreDBOpts,
@@ -113,10 +117,10 @@ ntfTestDBCfg =
deletedTTL = 86400
}
ntfTestDBCfg2 :: PostgresStoreCfg
ntfTestDBCfg2 :: HasTestEnv => PostgresStoreCfg
ntfTestDBCfg2 = ntfTestDBCfg {dbOpts = ntfTestStoreDBOpts2, dbStoreLogPath = Just ntfTestStoreLogFile2}
testNtfClient :: Transport c => (THandleNTF c 'TClient -> IO a) -> IO a
testNtfClient :: (HasTestEnv, Transport c) => (THandleNTF c 'TClient -> IO a) -> IO a
testNtfClient client = do
Right host <- pure $ chooseTransportHost defaultNetworkConfig testHost
runTransportClient defaultTransportClientConfig Nothing host ntfTestPort (Just testKeyHash) $ \h ->
@@ -124,7 +128,7 @@ testNtfClient client = do
Right th -> client th
Left e -> error $ show e
ntfServerCfg :: NtfServerConfig
ntfServerCfg :: HasTestEnv => NtfServerConfig
ntfServerCfg =
NtfServerConfig
{ transports = [],
@@ -151,7 +155,7 @@ ntfServerCfg =
-- stats config
logStatsInterval = Nothing,
logStatsStartTime = 0,
serverStatsLogFile = "tests/ntf-server-stats.daily.log",
serverStatsLogFile = testPath "ntf-server-stats.daily.log",
serverStatsBackupFile = Nothing,
prometheusInterval = Nothing,
prometheusMetricsFile = ntfTestPrometheusMetricsFile,
@@ -171,7 +175,7 @@ ntfServerCfg =
-- smpCfg' = smpCfg smpAgentCfg'
-- serverVRange' = serverVRange smpCfg'
withNtfServerThreadOn :: HasCallStack => ASrvTransport -> ServiceName -> PostgresStoreCfg -> (HasCallStack => ThreadId -> IO a) -> IO a
withNtfServerThreadOn :: (HasCallStack, HasTestEnv) => ASrvTransport -> ServiceName -> PostgresStoreCfg -> (HasCallStack => ThreadId -> IO a) -> IO a
withNtfServerThreadOn t port' dbStoreConfig =
withNtfServerCfg ntfServerCfg {transports = [(port', t, False)], dbStoreConfig}
@@ -184,18 +188,18 @@ withNtfServerCfg cfg@NtfServerConfig {transports} =
(\started -> runNtfServerBlocking started cfg)
(pure ())
withNtfServerOn :: HasCallStack => ASrvTransport -> ServiceName -> PostgresStoreCfg -> (HasCallStack => IO a) -> IO a
withNtfServerOn :: (HasCallStack, HasTestEnv) => ASrvTransport -> ServiceName -> PostgresStoreCfg -> (HasCallStack => IO a) -> IO a
withNtfServerOn t port' dbStoreConfig = withNtfServerThreadOn t port' dbStoreConfig . const
withNtfServer :: HasCallStack => ASrvTransport -> (HasCallStack => IO a) -> IO a
withNtfServer :: (HasCallStack, HasTestEnv) => ASrvTransport -> (HasCallStack => IO a) -> IO a
withNtfServer t = withNtfServerOn t ntfTestPort ntfTestDBCfg
runNtfTest :: forall c a. Transport c => (THandleNTF c 'TClient -> IO a) -> IO a
runNtfTest :: forall c a. (HasTestEnv, Transport c) => (THandleNTF c 'TClient -> IO a) -> IO a
runNtfTest test = withNtfServer (transport @c) $ testNtfClient test
ntfServerTest ::
forall c smp.
(Transport c, Encoding smp) =>
(HasTestEnv, Transport c, Encoding smp) =>
TProxy c 'TServer ->
(Maybe TAuthorizations, ByteString, ByteString, smp) ->
IO (Maybe TAuthorizations, ByteString, ByteString, NtfResponse)
@@ -210,7 +214,7 @@ ntfServerTest _ t = runNtfTest $ \h -> tPut' h t >> tGet' h
[(CorrId corrId, EntityId qId, Right cmd)] <- tGetClient h
pure (Nothing, corrId, qId, cmd)
ntfTest :: Transport c => TProxy c 'TServer -> (THandleNTF c 'TClient -> IO ()) -> Expectation
ntfTest :: (HasTestEnv, Transport c) => TProxy c 'TServer -> (THandleNTF c 'TClient -> IO ()) -> Expectation
ntfTest _ test' = runNtfTest test' `shouldReturn` ()
data APNSMockRequest = APNSMockRequest
@@ -225,7 +229,7 @@ data APNSMockServer = APNSMockServer
http2Server :: HTTP2Server
}
apnsMockServerConfig :: HTTP2ServerConfig
apnsMockServerConfig :: HasTestEnv => HTTP2ServerConfig
apnsMockServerConfig =
HTTP2ServerConfig
{ qSize = 2,
@@ -242,7 +246,7 @@ apnsMockServerConfig =
transportConfig = mkTransportServerConfig True Nothing False
}
withAPNSMockServer :: (APNSMockServer -> IO a) -> IO a
withAPNSMockServer :: HasTestEnv => (APNSMockServer -> IO a) -> IO a
withAPNSMockServer = E.bracket (getAPNSMockServer apnsMockServerConfig) closeAPNSMockServer
deriving instance Generic APNSAlertBody
tests/NtfServerTests.hs
+2 -2
View File
@@ -69,13 +69,13 @@ ntfSyntaxTests (ATransport t) = do
it "token ID" $ (sampleSig, "abcd", "12345678", (TNEW_, ' ', ('T', 'A', 'T', "abcd" :: ByteString), samplePubKey, sampleDhPubKey)) >#> ("", "abcd", "12345678", NRErr $ CMD HAS_AUTH)
where
(>#>) ::
Encoding smp =>
(HasTestEnv, Encoding smp) =>
(Maybe TAuthorizations, ByteString, ByteString, smp) ->
(Maybe TAuthorizations, ByteString, ByteString, NtfResponse) ->
Expectation
command >#> response = withAPNSMockServer $ \_ -> ntfServerTest t command `shouldReturn` response
testApnsTestProviderRejected :: ASrvTransport -> Expectation
testApnsTestProviderRejected :: HasTestEnv => ASrvTransport -> Expectation
testApnsTestProviderRejected (ATransport (t :: TProxy c 'TServer)) = do
g <- C.newRandom
(tknPub, tknKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
tests/PostgresSchemaDump.hs
+3 -2
View File
@@ -66,5 +66,6 @@ postgresSchemaDumpTest migrations skipComparisonForDownMigrations testDBOpts@DBO
threadDelay 20000
let sed = (if os == "linux" then "sed -i" else "sed -i ''")
void $ readCreateProcess (shell $ sed <> " '/^--/d; /^\\\\restrict/d; /^\\\\unrestrict/d' " <> schemaPath) ""
sch <- readFile schemaPath
sch `deepseq` pure sch
sch <- unlines . dropWhileEnd null . dropWhile null . lines <$> readFile schemaPath
sch `deepseq` writeFile schemaPath sch
pure sch
tests/RSLVTests.hs
+109 -22
View File
@@ -11,11 +11,14 @@
module RSLVTests (rslvTests) where
import Control.Concurrent (threadDelay)
import Control.Monad (forM_)
import Control.Monad.Trans.Except (ExceptT, runExceptT)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as LB
import Data.IORef (IORef, readIORef)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as L
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Data.Time.Clock (getCurrentTime)
@@ -47,26 +50,27 @@ import Simplex.Messaging.Protocol
tPut,
)
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Server.Env.STM (ServerConfig (..))
import Simplex.Messaging.SimplexName (SimplexDomain)
import Simplex.Messaging.Transport
import Simplex.Messaging.Version (mkVersionRange)
import Test.Hspec hiding (fit, it)
import Util (it)
import Util (HasTestEnv, it)
domain :: Text -> SimplexDomain
domain = either error id . strDecode . encodeUtf8
withResolverServer :: (Status, LB.ByteString) -> IO a -> IO a
withResolverServer :: HasTestEnv => (Status, LB.ByteString) -> IO a -> IO a
withResolverServer (st, body) runTest =
NRS.withResolverServer (NRS.resolveResp st body) $ \port _ ->
withSmpServerConfigOn (transport @TLS) (withNames port memCfg) testPort (const runTest)
withResolverServerReqs :: (Status, LB.ByteString) -> (IORef [[Text]] -> IO a) -> IO a
withResolverServerReqs :: HasTestEnv => (Status, LB.ByteString) -> (IORef [[Text]] -> IO a) -> IO a
withResolverServerReqs (st, body) runTest =
NRS.withResolverServer (NRS.resolveResp st body) $ \port reqs ->
withSmpServerConfigOn (transport @TLS) (withNames port memCfg) testPort (const (runTest reqs))
withProxyAndResolver :: (Status, LB.ByteString) -> IO a -> IO a
withProxyAndResolver :: HasTestEnv => (Status, LB.ByteString) -> IO a -> IO a
withProxyAndResolver (st, body) runTest =
NRS.withResolverServer (NRS.resolveResp st body) $ \port _ ->
withSmpServerConfigOn (transport @TLS) memProxyCfg testPort $ \_ ->
@@ -102,10 +106,14 @@ rslvTests = do
it "RSLV sends the 2LD as its hash" testRslvSendsTheHash
it "a name with subnames is sent as text" testSubnameKeepsItsLabels
it "a record naming a different name is rejected" testRslvWrongName
describe "RSLV resource use" $ do
it "one connection has at most client_concurrency lookups in flight" testRslvConnectionCap
it "a lookup waiting for a slot runs when a slot is released" testRslvSlotWait
it "a lookup waiting for a slot fails when the client times out" testRslvSlotWaitTimeout
-- | /v2/resolve answers 200, 400 or 502, so a 404 is a resolver that predates
-- the route, not a name that does not exist.
testRslvBackendNotFound :: IO ()
testRslvBackendNotFound :: HasTestEnv => IO ()
testRslvBackendNotFound =
withResolverServer (status404, "{}") $
testSMPClient @TLS $ \h -> do
@@ -113,21 +121,21 @@ testRslvBackendNotFound =
corrId `shouldBe` CorrId "rs01"
resp `shouldBe` Right (ERR (NAME (RESOLVER "HTTP 404")))
testRslvBackendHttpErr :: IO ()
testRslvBackendHttpErr :: HasTestEnv => IO ()
testRslvBackendHttpErr =
withResolverServer (status502, "{}") $
testSMPClient @TLS $ \h -> do
(_, _, resp) <- sendRslv h "rs05" (domain "alice.simplex")
resp `shouldBe` Right (ERR (NAME (RESOLVER "HTTP 502")))
testRslvDisabled :: IO ()
testRslvDisabled :: HasTestEnv => IO ()
testRslvDisabled =
withSmpServerConfigOn (transport @TLS) memCfg testPort $ const $
testSMPClient @TLS $ \h -> do
(_, _, resp) <- sendRslv h "rs06" (domain "alice.simplex")
resp `shouldBe` Right (ERR (NAME NO_RESOLVER))
testRslvVersion :: IO ()
testRslvVersion :: HasTestEnv => IO ()
testRslvVersion =
withResolverServer (status200, registeredBody testNameRecord) $ do
g <- C.newRandom
@@ -141,7 +149,7 @@ testRslvVersion =
Left (PCETransportError TEVersion) -> pure ()
_ -> expectationFailure $ "expected Left (PCETransportError TEVersion), got: " <> show r
forwardedResolveAlice :: IO (Either SMPClientError (Either ProxyClientError SMP.NameResponse))
forwardedResolveAlice :: HasTestEnv => IO (Either SMPClientError (Either ProxyClientError SMP.NameResponse))
forwardedResolveAlice = do
g <- C.newRandom
ts <- getCurrentTime
@@ -153,21 +161,21 @@ forwardedResolveAlice = do
sess <- runExceptT' (connectSMPProxiedRelay pc NRMInteractive relayServ Nothing)
runExceptT (proxyResolveName pc NRMInteractive sess (domain "alice.simplex"))
testRslvForwarded :: IO ()
testRslvForwarded :: HasTestEnv => IO ()
testRslvForwarded =
withProxyAndResolver (status404, "{}") $
forwardedResolveAlice >>= \r -> case r of
Left (PCEProtocolError (SMP.NAME (SMP.RESOLVER _))) -> pure ()
_ -> expectationFailure $ "expected Left (PCEProtocolError (NAME (RESOLVER _))), got: " <> show r
testRslvForwardedSuccess :: IO ()
testRslvForwardedSuccess :: HasTestEnv => IO ()
testRslvForwardedSuccess =
withProxyAndResolver (status200, registeredBody testNameRecord) $
forwardedResolveAlice >>= \r -> case r of
Right (Right NameResponse {registration = NRRegistered {nameRecord}}) -> nameRecord `shouldBe` testNameRecord
_ -> expectationFailure $ "expected Right (Right NRRegistered), got: " <> show r
testRslvSuccess :: IO ()
testRslvSuccess :: HasTestEnv => IO ()
testRslvSuccess =
withResolverServer (status200, registeredBody testNameRecord) $
testSMPClient @TLS $ \h -> do
@@ -177,7 +185,7 @@ testRslvSuccess =
Right (RNAME NameResponse {registration = NRRegistered {nameRecord}}) -> nameRecord `shouldBe` testNameRecord
_ -> expectationFailure $ "expected Right (RNAME NRRegistered), got: " <> show resp
testRslvAvailable :: IO ()
testRslvAvailable :: HasTestEnv => IO ()
testRslvAvailable =
withResolverServer (status200, availableBody) $
testSMPClient @TLS $ \h -> do
@@ -185,7 +193,7 @@ testRslvAvailable =
corrId `shouldBe` CorrId "na01"
resp `shouldBe` Right (RNAME (resolved (NRAvailable testPricing)))
testRslvReserved :: IO ()
testRslvReserved :: HasTestEnv => IO ()
testRslvReserved =
withResolverServer (status200, reservedBody) $
testSMPClient @TLS $ \h -> do
@@ -194,7 +202,7 @@ testRslvReserved =
-- | A client that predates v22 must see exactly what it saw before: the record
-- for a name that resolves, and NOT_FOUND for one that does not.
oldClient :: IO SMPClient
oldClient :: HasTestEnv => IO SMPClient
oldClient = do
g <- C.newRandom
ts <- getCurrentTime
@@ -205,14 +213,14 @@ oldClient = do
pcE <- getProtocolClient g NRMInteractive (1, srv, Nothing) oldCfg [] Nothing ts (\_ -> pure ())
either (fail . show) pure pcE
testRslvOldClientRecord :: IO ()
testRslvOldClientRecord :: HasTestEnv => IO ()
testRslvOldClientRecord =
withResolverServer (status200, registeredBody testNameRecord) $ do
pc <- oldClient
r <- runExceptT' (directResolveName pc NRMInteractive (domain "alice.simplex"))
r `shouldBe` NameResponse Nothing (NRRegistered Nothing Nothing Nothing testNameRecord)
testRslvOldClientNotFound :: IO ()
testRslvOldClientNotFound :: HasTestEnv => IO ()
testRslvOldClientNotFound =
withResolverServer (status200, availableBody) $ do
pc <- oldClient
@@ -221,7 +229,7 @@ testRslvOldClientNotFound =
Left (PCEProtocolError (SMP.NAME SMP.NOT_FOUND)) -> pure ()
_ -> expectationFailure $ "expected Left (PCEProtocolError (NAME NOT_FOUND)), got: " <> show r
testRslvForwardedAvailable :: IO ()
testRslvForwardedAvailable :: HasTestEnv => IO ()
testRslvForwardedAvailable =
withProxyAndResolver (status200, availableBody) $
forwardedResolveAlice >>= \r -> case r of
@@ -238,7 +246,7 @@ resolvePaths reqs = filter isResolve <$> readIORef reqs
where
isResolve = \case ("v2" : "resolve" : _) -> True; _ -> False
currentClient :: IO SMPClient
currentClient :: HasTestEnv => IO SMPClient
currentClient = do
g <- C.newRandom
ts <- getCurrentTime
@@ -246,7 +254,7 @@ currentClient = do
pcE <- getProtocolClient g NRMInteractive (1, srv, Nothing) defaultSMPClientConfig [] Nothing ts (\_ -> pure ())
either (fail . show) pure pcE
testRslvSendsTheHash :: IO ()
testRslvSendsTheHash :: HasTestEnv => IO ()
testRslvSendsTheHash =
withResolverServerReqs (status200, registeredBody testNameRecord) $ \reqs -> do
pc <- currentClient
@@ -257,7 +265,7 @@ testRslvSendsTheHash =
NameResponse {registration = NRRegistered {nameRecord}} -> SMP.nrName nameRecord `shouldBe` "alice.simplex"
_ -> expectationFailure $ "expected NRRegistered, got: " <> show r
testSubnameKeepsItsLabels :: IO ()
testSubnameKeepsItsLabels :: HasTestEnv => IO ()
testSubnameKeepsItsLabels =
withResolverServerReqs (status200, availableBody) $ \reqs -> do
pc <- currentClient
@@ -266,7 +274,7 @@ testSubnameKeepsItsLabels =
-- a hashed query does not tell the router the name, so the record's own name is
-- checked against the one that was asked for
testRslvWrongName :: IO ()
testRslvWrongName :: HasTestEnv => IO ()
testRslvWrongName =
withResolverServer (status200, registeredBody testNameRecord {SMP.nrName = "mallory.simplex"}) $ do
pc <- currentClient
@@ -275,5 +283,84 @@ testRslvWrongName =
Left (PCEUnexpectedResponse _) -> pure ()
_ -> expectationFailure $ "expected Left (PCEUnexpectedResponse ..), got: " <> show r
-- The resolver answers after 3s and the server gives up after 1s, so a request
-- that reached the resolver stays in flight for the whole check.
testRslvConnectionCap :: HasTestEnv => IO ()
testRslvConnectionCap =
NRS.withResolverServerDelayed 3000 (NRS.resolveResp status200 "{}") $ \port reqs ->
withSmpServerConfigOn (transport @TLS) (updateCfg (withNames port memCfg) $ \c -> c {serverClientConcurrency = connCap}) testPort $ const $
testSMPClient @TLS $ \h -> do
sendRslvs h "cap" 16
threadDelay 800000
length <$> resolvePaths reqs `shouldReturn` connCap
recvResponses h 16 `shouldReturn` replicate 16 (Right (ERR (NAME (RESOLVER "timeout"))))
where
connCap = 4
-- 4 lookups take the slots for the 1s resolver timeout, the 5th waits for a slot.
testRslvSlotWait :: HasTestEnv => IO ()
testRslvSlotWait =
NRS.withResolverServerDelayed 3000 (NRS.resolveResp status200 "{}") $ \port reqs ->
withSmpServerConfigOn (transport @TLS) (slotWaitCfg port 10000000) testPort $ const $
testSMPClient @TLS $ \h -> do
sendRslvs h "wait" 5
recvResponses h 5 `shouldReturn` replicate 5 (Right (ERR (NAME (RESOLVER "timeout"))))
length <$> resolvePaths reqs `shouldReturn` 5
threadDelay 1500000
SlotWaitMetrics {waits, waitTimeouts, waitMaxMs, waitSumMs} <- readSlotWaitMetrics
(waits, waitTimeouts) `shouldBe` (1, 0)
waitMaxMs `shouldSatisfy` (\t -> t >= 500 && t < 2000)
waitSumMs `shouldBe` waitMaxMs
-- The client times out after 0.2s, so the 2 waiting lookups fail before the slots are released.
-- The connection does not process further commands while one waits, so the 6th waits after the 5th times out.
testRslvSlotWaitTimeout :: HasTestEnv => IO ()
testRslvSlotWaitTimeout =
NRS.withResolverServerDelayed 3000 (NRS.resolveResp status200 "{}") $ \port reqs ->
withSmpServerConfigOn (transport @TLS) (slotWaitCfg port 200000) testPort $ const $
testSMPClient @TLS $ \h -> do
sendRslvs h "wait" 6
recvResponses h 6 `shouldReturn` (replicate 2 (Right (ERR (NAME (RESOLVER "too many requests")))) <> replicate 4 (Right (ERR (NAME (RESOLVER "timeout")))))
threadDelay 1500000
length <$> resolvePaths reqs `shouldReturn` 4
SlotWaitMetrics {waits, waitTimeouts, waitMaxMs, waitSumMs} <- readSlotWaitMetrics
(waits, waitTimeouts) `shouldBe` (2, 2)
waitMaxMs `shouldSatisfy` (\t -> t >= 200 && t < 1000)
waitSumMs `shouldSatisfy` (>= 400)
slotWaitCfg :: HasTestEnv => Int -> Int -> AServerConfig
slotWaitCfg port clientTimeout =
updateCfg (withNames port memCfg) $ \c -> c {serverClientConcurrency = 4, prometheusInterval = Just 1, maxClientCmdWait = clientTimeout}
data SlotWaitMetrics = SlotWaitMetrics {waits :: Int, waitTimeouts :: Int, waitMaxMs :: Int, waitSumMs :: Int}
readSlotWaitMetrics :: HasTestEnv => IO SlotWaitMetrics
readSlotWaitMetrics = do
ms <- map words . lines <$> readFile testPrometheusMetricsFile
-- metric lines are "name value timestamp"
let metric name = case [v | n : v : _ <- ms, n == name] of
[v] -> pure $ read v
_ -> fail $ "no metric " <> name
SlotWaitMetrics
<$> metric "simplex_smp_cmd_slot_wait_ms_count"
<*> metric "simplex_smp_cmd_slot_wait_timeouts"
<*> metric "simplex_smp_cmd_slot_wait_ms_max"
<*> metric "simplex_smp_cmd_slot_wait_ms_sum"
-- | One RSLV per block, so no batch limit applies.
sendRslvs :: THandleSMP TLS 'TClient -> String -> Int -> IO ()
sendRslvs h@THandle {params} prefix n =
forM_ [1 .. n] $ \i -> do
let TransmissionForAuth {tToSend} = encodeTransmissionForAuth params (CorrId (B.pack $ prefix <> show i), NoEntity, Cmd SResolver (RSLV (NQDomain (domain "alice.simplex"))))
[Right ()] <- tPut h (Right (Nothing, tToSend) :| [])
pure ()
recvResponses :: THandleSMP TLS 'TClient -> Int -> IO [Either ErrorType BrokerMsg]
recvResponses h n
| n <= 0 = pure []
| otherwise = do
rs <- map (\(_, _, r) -> r) . L.toList <$> tGetClient h
(rs <>) <$> recvResponses h (n - length rs)
runExceptT' :: Show e => ExceptT e IO a -> IO a
runExceptT' a = runExceptT a >>= either (fail . show) pure
tests/SMPAgentClient.hs
+32 -30
View File
@@ -6,6 +6,7 @@
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
@@ -15,79 +16,80 @@ import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as L
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import SMPClient (ntfTestPort, testPort)
import SMPClient (ntfTestPort, ntfTestPort2, testHost, testHost2, testKeyHash, testPort, testPort2)
import Simplex.Messaging.Agent.Env.SQLite
import Simplex.Messaging.Agent.Protocol
import Simplex.Messaging.Agent.RetryInterval
import Simplex.Messaging.Client (NetworkTimeout (..), ProtocolClientConfig (..), SMPProxyFallback (..), SMPProxyMode (..), defaultNetworkConfig, defaultSMPClientConfig)
import Simplex.Messaging.Notifications.Client (defaultNTFClientConfig)
import Simplex.Messaging.Protocol (NtfServer, ProtoServerWithAuth (..), ProtocolServer)
import Simplex.Messaging.Protocol (NtfServer, ProtoServerWithAuth (..), ProtocolServer, pattern NtfServer)
import Simplex.Messaging.Transport
import Util
import XFTPClient (testXFTPServer)
-- name fixtures are reused, but they are used as schema name instead of database file path
#if defined(dbPostgres)
testDB :: String
testDB = "smp_agent_test_protocol_schema"
testDB :: HasTestEnv => String
testDB = testSchemaName "smp_agent_test_protocol_schema"
testDB2 :: String
testDB2 = "smp_agent2_test_protocol_schema"
testDB2 :: HasTestEnv => String
testDB2 = testSchemaName "smp_agent2_test_protocol_schema"
testDB3 :: String
testDB3 = "smp_agent3_test_protocol_schema"
testDB3 :: HasTestEnv => String
testDB3 = testSchemaName "smp_agent3_test_protocol_schema"
#else
testDB :: FilePath
testDB = "tests/tmp/smp-agent.test.protocol.db"
testDB :: HasTestEnv => FilePath
testDB = testPath "smp-agent.test.protocol.db"
testDB2 :: FilePath
testDB2 = "tests/tmp/smp-agent2.test.protocol.db"
testDB2 :: HasTestEnv => FilePath
testDB2 = testPath "smp-agent2.test.protocol.db"
testDB3 :: FilePath
testDB3 = "tests/tmp/smp-agent3.test.protocol.db"
testDB3 :: HasTestEnv => FilePath
testDB3 = testPath "smp-agent3.test.protocol.db"
#endif
testSMPServer :: SMPServer
testSMPServer = "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5001"
testSMPServer :: HasTestEnv => SMPServer
testSMPServer = SMPServer testHost testPort testKeyHash
testSMPServer2 :: SMPServer
testSMPServer2 = "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@127.0.0.1:5002"
testSMPServer2 :: HasTestEnv => SMPServer
testSMPServer2 = SMPServer testHost2 testPort2 testKeyHash
testNtfServer :: NtfServer
testNtfServer = "ntf://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:6001"
testNtfServer :: HasTestEnv => NtfServer
testNtfServer = NtfServer testHost ntfTestPort testKeyHash
testNtfServer2 :: NtfServer
testNtfServer2 = "ntf://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:6002"
testNtfServer2 :: HasTestEnv => NtfServer
testNtfServer2 = NtfServer testHost ntfTestPort2 testKeyHash
initAgentServers :: InitialAgentServers
initAgentServers :: HasTestEnv => InitialAgentServers
initAgentServers =
InitialAgentServers
{ smp = userServers [testSMPServer],
ntf = [testNtfServer],
xftp = userServers [testXFTPServer],
entitlements = M.empty,
netCfg = defaultNetworkConfig {tcpTimeout = NetworkTimeout 500000 500000, tcpConnectTimeout = NetworkTimeout 500000 500000},
netCfg = defaultNetworkConfig {tcpTimeout = NetworkTimeout 2000000 2000000, tcpConnectTimeout = NetworkTimeout 2000000 2000000},
useServices = M.empty,
presetDomains = [],
presetServers = []
}
initAgentServers2 :: InitialAgentServers
initAgentServers2 :: HasTestEnv => InitialAgentServers
initAgentServers2 = initAgentServers {smp = userServers [testSMPServer, testSMPServer2]}
initAgentServersProxy :: InitialAgentServers
initAgentServersProxy :: HasTestEnv => InitialAgentServers
initAgentServersProxy = initAgentServersProxy_ SPMAlways SPFProhibit
initAgentServersProxy_ :: SMPProxyMode -> SMPProxyFallback -> InitialAgentServers
initAgentServersProxy_ :: HasTestEnv => SMPProxyMode -> SMPProxyFallback -> InitialAgentServers
initAgentServersProxy_ smpProxyMode smpProxyFallback =
initAgentServers {netCfg = (netCfg initAgentServers) {smpProxyMode, smpProxyFallback}}
initAgentServersProxy2 :: InitialAgentServers
initAgentServersProxy2 :: HasTestEnv => InitialAgentServers
initAgentServersProxy2 = initAgentServersProxy {smp = userServers [testSMPServer2]}
initAgentServersClientService :: InitialAgentServers
initAgentServersClientService :: HasTestEnv => InitialAgentServers
initAgentServersClientService = initAgentServers {useServices = M.fromList [(1, True)]}
agentCfg :: AgentConfig
agentCfg :: HasTestEnv => AgentConfig
agentCfg =
defaultAgentConfig
{ tcpPort = Nothing,
tests/SMPClient.hs
+129 -115
View File
@@ -33,7 +33,6 @@ import Simplex.Messaging.Protocol
import Simplex.Messaging.Server (runSMPServerBlocking)
import Simplex.Messaging.Server.Env.STM
import Simplex.Messaging.Server.MsgStore.Types (MsgStoreClass (..), SMSType (..), SQSType (..))
import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..))
import Simplex.Messaging.Transport
import Simplex.Messaging.Transport.Client
import Simplex.Messaging.Transport.Server
@@ -45,12 +44,13 @@ import System.Info (os)
import Test.Hspec hiding (fit, it)
import UnliftIO.Concurrent
import qualified UnliftIO.Exception as E
import UnliftIO.STM (TMVar, atomically, newEmptyTMVarIO, putTMVar, takeTMVar)
import UnliftIO.STM (TMVar, atomically, checkSTM, newEmptyTMVarIO, orElse, putTMVar, readTMVar, readTVar, registerDelay, takeTMVar)
import UnliftIO.Timeout (timeout)
import Util
#if defined(dbServerPostgres)
import Database.PostgreSQL.Simple (defaultConnectInfo)
import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..))
#endif
#if defined(dbPostgres) || defined(dbServerPostgres)
@@ -72,29 +72,29 @@ testHost = "localhost"
testHost2 :: NonEmpty TransportHost
testHost2 = "127.0.0.1"
testPort :: ServiceName
testPort = "5001"
testPort :: HasTestEnv => ServiceName
testPort = testServerPort 1
testPort2 :: ServiceName
testPort2 = "5002"
testPort2 :: HasTestEnv => ServiceName
testPort2 = testServerPort 2
ntfTestPort :: ServiceName
ntfTestPort = "6001"
ntfTestPort :: HasTestEnv => ServiceName
ntfTestPort = testServerPort 3
ntfTestPort2 :: ServiceName
ntfTestPort2 = "6002"
ntfTestPort2 :: HasTestEnv => ServiceName
ntfTestPort2 = testServerPort 4
testKeyHash :: C.KeyHash
testKeyHash = "LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI="
testStoreLogFile :: FilePath
testStoreLogFile = "tests/tmp/smp-server-store.log"
testStoreLogFile :: HasTestEnv => FilePath
testStoreLogFile = testPath "smp-server-store.log"
testStoreLogFile2 :: FilePath
testStoreLogFile2 = "tests/tmp/smp-server-store.log.2"
testStoreLogFile2 :: HasTestEnv => FilePath
testStoreLogFile2 = testPath "smp-server-store.log.2"
testStoreDBOpts :: DBOpts
testStoreDBOpts =
testServerDBOpts :: DBOpts
testServerDBOpts =
DBOpts
{ connstr = testServerDBConnstr,
schema = "smp_server",
@@ -102,8 +102,11 @@ testStoreDBOpts =
createSchema = True
}
testStoreDBOpts2 :: DBOpts
testStoreDBOpts2 = testStoreDBOpts {schema = "smp_server2"}
testStoreDBOpts :: HasTestEnv => DBOpts
testStoreDBOpts = testServerDBOpts {schema = testSchemaName "smp_server"}
testStoreDBOpts2 :: HasTestEnv => DBOpts
testStoreDBOpts2 = testStoreDBOpts {schema = testSchemaName "smp_server2"}
testServerDBConnstr :: ByteString
testServerDBConnstr = "postgresql://test_server_user@/test_server_db"
@@ -117,48 +120,42 @@ testServerDBConnectInfo =
}
#endif
testStoreMsgsFile :: FilePath
testStoreMsgsFile = "tests/tmp/smp-server-messages.log"
testStoreMsgsFile :: HasTestEnv => FilePath
testStoreMsgsFile = testPath "smp-server-messages.log"
testStoreMsgsFile2 :: FilePath
testStoreMsgsFile2 = "tests/tmp/smp-server-messages.log.2"
testStoreMsgsFile2 :: HasTestEnv => FilePath
testStoreMsgsFile2 = testPath "smp-server-messages.log.2"
testStoreMsgsDir :: FilePath
testStoreMsgsDir = "tests/tmp/messages"
testStoreNtfsFile :: HasTestEnv => FilePath
testStoreNtfsFile = testPath "smp-server-ntfs.log"
testStoreMsgsDir2 :: FilePath
testStoreMsgsDir2 = "tests/tmp/messages.2"
testStoreNtfsFile2 :: HasTestEnv => FilePath
testStoreNtfsFile2 = testPath "smp-server-ntfs.log.2"
testStoreNtfsFile :: FilePath
testStoreNtfsFile = "tests/tmp/smp-server-ntfs.log"
testPrometheusMetricsFile :: HasTestEnv => FilePath
testPrometheusMetricsFile = testPath "smp-server-metrics.txt"
testStoreNtfsFile2 :: FilePath
testStoreNtfsFile2 = "tests/tmp/smp-server-ntfs.log.2"
testServerStatsBackupFile :: HasTestEnv => FilePath
testServerStatsBackupFile = testPath "smp-server-stats.log"
testPrometheusMetricsFile :: FilePath
testPrometheusMetricsFile = "tests/tmp/smp-server-metrics.txt"
xit' :: (HasCallStack, Example a) => String -> (HasTestEnv => a) -> SpecWith (Arg a)
xit' d t = if os == "linux" then skip "skipped on Linux" $ it d t else it d t
testServerStatsBackupFile :: FilePath
testServerStatsBackupFile = "tests/tmp/smp-server-stats.log"
xit' :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a)
xit' d = if os == "linux" then skip "skipped on Linux" . it d else it d
xit'' :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a)
xit'' d = skipOnCI . it d
xit'' :: (HasCallStack, Example a) => String -> (HasTestEnv => a) -> SpecWith (Arg a)
xit'' d t = skipOnCI $ it d t
skipOnCI :: SpecWith a -> SpecWith a
skipOnCI t = ifM (runIO envCI) (skip "skipped on CI" t) t
testSMPClient :: Transport c => (THandleSMP c 'TClient -> IO a) -> IO a
testSMPClient :: (HasTestEnv, Transport c) => (THandleSMP c 'TClient -> IO a) -> IO a
testSMPClient = testSMPClientVR supportedClientSMPRelayVRange
testSMPClientVR :: Transport c => VersionRangeSMP -> (THandleSMP c 'TClient -> IO a) -> IO a
testSMPClientVR :: (HasTestEnv, Transport c) => VersionRangeSMP -> (THandleSMP c 'TClient -> IO a) -> IO a
testSMPClientVR vr client = do
Right useHost <- pure $ chooseTransportHost defaultNetworkConfig testHost
testSMPClient_ useHost testPort vr Nothing client
testSMPServiceClient :: Transport c => (TLS.Credential, C.KeyPairEd25519) -> (THandleSMP c 'TClient -> IO a) -> IO a
testSMPServiceClient :: (HasTestEnv, Transport c) => (TLS.Credential, C.KeyPairEd25519) -> (THandleSMP c 'TClient -> IO a) -> IO a
testSMPServiceClient serviceCreds client = do
Right useHost <- pure $ chooseTransportHost defaultNetworkConfig testHost
testSMPClient_ useHost testPort supportedClientSMPRelayVRange (Just serviceCreds) client
@@ -181,13 +178,13 @@ testSMPClient_ host port vr serviceCreds_ client = do
where
clientALPN = Just alpnSupportedSMPHandshakes
runSMPClient :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO a) -> IO a
runSMPClient :: (HasTestEnv, Transport c) => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO a) -> IO a
runSMPClient _ test' = testSMPClient test'
runSMPServiceClient :: Transport c => TProxy c 'TServer -> (TLS.Credential, C.KeyPairEd25519) -> (THandleSMP c 'TClient -> IO a) -> IO a
runSMPServiceClient :: (HasTestEnv, Transport c) => TProxy c 'TServer -> (TLS.Credential, C.KeyPairEd25519) -> (THandleSMP c 'TClient -> IO a) -> IO a
runSMPServiceClient _ serviceCreds test' = testSMPServiceClient serviceCreds test'
testNtfServiceClient :: Transport c => TProxy c 'TServer -> C.KeyPairEd25519 -> (THandleSMP c 'TClient -> IO a) -> IO a
testNtfServiceClient :: (HasTestEnv, Transport c) => TProxy c 'TServer -> C.KeyPairEd25519 -> (THandleSMP c 'TClient -> IO a) -> IO a
testNtfServiceClient _ keys client = do
tlsNtfServerCreds <- loadServerCredential ntfTestServerCredentials
serviceCertHash <- loadFingerprint ntfTestServerCredentials
@@ -211,35 +208,44 @@ ntfTestServerCredentials =
certificateFile = "tests/fixtures/server.crt"
}
cfg :: AServerConfig
cfg = cfgMS (ASType SQSMemory SMSJournal)
cfg :: HasTestEnv => AServerConfig
cfg = cfgMS (ASType SQSMemory SMSMemory)
cfgJ2 :: AServerConfig
cfgJ2 = journalCfg cfg testStoreLogFile2 testStoreMsgsDir2
cfgS2 :: HasTestEnv => AServerConfig
cfgS2 = memoryCfg cfg testStoreLogFile2 testStoreMsgsFile2
cfgJ2QS :: SQSType s -> AServerConfig
cfgJ2QS = \case
SQSMemory -> journalCfg (cfgMS $ ASType SQSMemory SMSJournal) testStoreLogFile2 testStoreMsgsDir2
SQSPostgres -> journalCfgDB (cfgMS $ ASType SQSPostgres SMSJournal) testStoreDBOpts2 testStoreMsgsDir2
cfgS2QS :: HasTestEnv => SQSType s -> AServerConfig
cfgS2QS = \case
SQSMemory -> memoryCfg (cfgMS $ ASType SQSMemory SMSMemory) testStoreLogFile2 testStoreMsgsFile2
SQSPostgres -> databaseCfg (cfgMS postgresStoreType) testStoreDBOpts2
journalCfg :: AServerConfig -> FilePath -> FilePath -> AServerConfig
journalCfg (ASrvCfg _ _ cfg') storeLogFile storeMsgsPath =
ASrvCfg SQSMemory SMSJournal cfg' {serverStoreCfg = SSCMemoryJournal {storeLogFile, storeMsgsPath}}
memoryCfg :: AServerConfig -> FilePath -> FilePath -> AServerConfig
memoryCfg (ASrvCfg _ _ cfg') storeLogFile storeMsgsFile =
ASrvCfg SQSMemory SMSMemory cfg' {serverStoreCfg = SSCMemory $ Just StorePaths {storeLogFile, storeMsgsFile = Just storeMsgsFile}}
journalCfgDB :: AServerConfig -> DBOpts -> FilePath -> AServerConfig
journalCfgDB (ASrvCfg _ _ cfg') dbOpts storeMsgsPath' =
databaseCfg :: AServerConfig -> DBOpts -> AServerConfig
#if defined(dbServerPostgres)
databaseCfg (ASrvCfg _ _ cfg') dbOpts =
let storeCfg = PostgresStoreCfg {dbOpts, dbStoreLogPath = Nothing, confirmMigrations = MCYesUp, deletedTTL = 86400}
in ASrvCfg SQSPostgres SMSJournal cfg' {serverStoreCfg = SSCDatabaseJournal {storeCfg, storeMsgsPath'}}
in ASrvCfg SQSPostgres SMSPostgres cfg' {serverStoreCfg = SSCDatabase storeCfg}
#else
databaseCfg _ _ = error "no dbServerPostgres flag"
#endif
cfgMS :: AStoreType -> AServerConfig
postgresStoreType :: AStoreType
#if defined(dbServerPostgres)
postgresStoreType = ASType SQSPostgres SMSPostgres
#else
postgresStoreType = error "no dbServerPostgres flag"
#endif
cfgMS :: HasTestEnv => AStoreType -> AServerConfig
cfgMS msType = withStoreCfg (testServerStoreConfig msType) $ \serverStoreCfg ->
ServerConfig
{ transports = [],
smpHandshakeTimeout = 60000000,
tbqSize = 4,
msgQueueQuota = 4,
maxJournalMsgCount = 5,
maxJournalStateLines = 2,
queueIdBytes = 24,
msgIdBytes = 24,
serverStoreCfg,
@@ -252,12 +258,11 @@ cfgMS msType = withStoreCfg (testServerStoreConfig msType) $ \serverStoreCfg ->
messageExpiration = Just defaultMessageExpiration,
expireMessagesOnStart = True,
expireMessagesOnSend = False,
idleQueueInterval = defaultIdleQueueInterval,
notificationExpiration = defaultNtfExpiration,
inactiveClientExpiration = Just defaultInactiveClientExpiration,
logStatsInterval = Nothing,
logStatsStartTime = 0,
serverStatsLogFile = "tests/tmp/smp-server-stats.daily.log",
serverStatsLogFile = testPath "smp-server-stats.daily.log",
serverStatsBackupFile = Nothing,
prometheusInterval = Nothing,
prometheusMetricsFile = testPrometheusMetricsFile,
@@ -279,6 +284,7 @@ cfgMS msType = withStoreCfg (testServerStoreConfig msType) $ \serverStoreCfg ->
serverClientConcurrency = 2,
proxyRelayConcurrency = defaultProxyRelayConcurrency,
serverResolverConcurrency = defaultNameResolverConcurrency,
maxClientCmdWait = defaultMaxClientCmdWait,
namesConfig = Nothing,
information = Nothing,
startOptions = defaultStartOptions
@@ -290,26 +296,28 @@ withStoreCfg (ASSCfg qt mt storeCfg) f = ASrvCfg qt mt (f storeCfg)
defaultStartOptions :: StartOptions
defaultStartOptions = StartOptions {maintenance = False, compactLog = False, logLevel = testLogLevel, skipWarnings = False, confirmMigrations = MCYesUp}
testServerStoreConfig :: AStoreType -> AServerStoreCfg
testServerStoreConfig :: HasTestEnv => AStoreType -> AServerStoreCfg
testServerStoreConfig = serverStoreConfig_ False
serverStoreConfig_ :: Bool -> AStoreType -> AServerStoreCfg
serverStoreConfig_ :: HasTestEnv => Bool -> AStoreType -> AServerStoreCfg
#if defined(dbServerPostgres)
serverStoreConfig_ useDbStoreLog = \case
#else
serverStoreConfig_ _ = \case
#endif
ASType SQSMemory SMSMemory ->
ASSCfg SQSMemory SMSMemory $ SSCMemory $ Just StorePaths {storeLogFile = testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile}
ASType SQSMemory SMSJournal ->
ASSCfg SQSMemory SMSJournal $ SSCMemoryJournal {storeLogFile = testStoreLogFile, storeMsgsPath = testStoreMsgsDir}
ASType SQSPostgres SMSJournal ->
ASSCfg SQSPostgres SMSJournal SSCDatabaseJournal {storeCfg, storeMsgsPath' = testStoreMsgsDir}
#if defined(dbServerPostgres)
ASType SQSPostgres SMSPostgres ->
ASSCfg SQSPostgres SMSPostgres $ SSCDatabase storeCfg
#endif
where
dbStoreLogPath = if useDbStoreLog then Just testStoreLogFile else Nothing
storeCfg = PostgresStoreCfg {dbOpts = testStoreDBOpts, dbStoreLogPath, confirmMigrations = MCYesUp, deletedTTL = 86400}
#else
ASType SQSPostgres _ -> error "no dbServerPostgres flag"
#endif
cfgVPrev :: AStoreType -> AServerConfig
cfgVPrev :: HasTestEnv => AStoreType -> AServerConfig
cfgVPrev msType = updateCfg (cfgMS msType) $ \cfg' -> cfg' {smpServerVRange = prevRange $ smpServerVRange cfg'}
prevRange :: VersionRange v -> VersionRange v
@@ -321,10 +329,10 @@ prevVersion (Version v) = Version (v - 1)
nextVersion :: Version v -> Version v
nextVersion (Version v) = Version (v + 1)
proxyCfg :: AServerConfig
proxyCfg = proxyCfgMS (ASType SQSMemory SMSJournal)
proxyCfg :: HasTestEnv => AServerConfig
proxyCfg = proxyCfgMS (ASType SQSMemory SMSMemory)
proxyCfgMS :: AStoreType -> AServerConfig
proxyCfgMS :: HasTestEnv => AStoreType -> AServerConfig
proxyCfgMS msType =
updateCfg (cfgMS msType) $ \cfg' ->
let smpAgentCfg' = smpAgentCfg cfg'
@@ -333,17 +341,17 @@ proxyCfgMS msType =
smpAgentCfg = smpAgentCfg' {smpCfg = (smpCfg smpAgentCfg') {agreeSecret = True, proxyServer = True, serverVRange = supportedProxyClientSMPRelayVRange}}
}
proxyCfgJ2 :: AServerConfig
proxyCfgJ2 = journalCfg proxyCfg testStoreLogFile2 testStoreMsgsDir2
proxyCfgS2 :: HasTestEnv => AServerConfig
proxyCfgS2 = memoryCfg proxyCfg testStoreLogFile2 testStoreMsgsFile2
proxyCfgJ2QS :: SQSType qs -> AServerConfig
proxyCfgJ2QS = \case
SQSMemory -> journalCfg (proxyCfgMS $ ASType SQSMemory SMSJournal) testStoreLogFile2 testStoreMsgsDir2
SQSPostgres -> journalCfgDB (proxyCfgMS $ ASType SQSPostgres SMSJournal) testStoreDBOpts2 testStoreMsgsDir2
proxyCfgS2QS :: HasTestEnv => SQSType qs -> AServerConfig
proxyCfgS2QS = \case
SQSMemory -> memoryCfg (proxyCfgMS $ ASType SQSMemory SMSMemory) testStoreLogFile2 testStoreMsgsFile2
SQSPostgres -> databaseCfg (proxyCfgMS postgresStoreType) testStoreDBOpts2
-- Proxy config with a short relay-connection timeout, to bound how long a failing
-- proxy->relay connection attempt blocks in the relay reconnection tests.
proxyCfgShortTimeout :: AServerConfig
proxyCfgShortTimeout :: HasTestEnv => AServerConfig
proxyCfgShortTimeout =
updateCfg proxyCfg $ \cfg' ->
let aCfg = smpAgentCfg cfg'
@@ -351,7 +359,7 @@ proxyCfgShortTimeout =
nt = NetworkTimeout {backgroundTimeout = 4_000000, interactiveTimeout = 4_000000}
in cfg' {smpAgentCfg = aCfg {smpCfg = cCfg {networkConfig = (networkConfig cCfg) {tcpConnectTimeout = nt}}}}
proxyCfgForwardTimeout :: AServerConfig
proxyCfgForwardTimeout :: HasTestEnv => AServerConfig
proxyCfgForwardTimeout =
updateCfg proxyCfg $ \cfg' ->
let aCfg = smpAgentCfg cfg'
@@ -359,7 +367,7 @@ proxyCfgForwardTimeout =
nt = NetworkTimeout {backgroundTimeout = 1, interactiveTimeout = 1}
in cfg' {smpAgentCfg = aCfg {smpCfg = cCfg {networkConfig = (networkConfig cCfg) {tcpTimeout = nt}}}}
proxyCfgVPrev :: AStoreType -> AServerConfig
proxyCfgVPrev :: HasTestEnv => AStoreType -> AServerConfig
proxyCfgVPrev msType =
updateCfg (proxyCfgMS msType) $ \cfg' ->
let aCfg = smpAgentCfg cfg'
@@ -369,11 +377,11 @@ proxyCfgVPrev msType =
smpAgentCfg = aCfg {smpCfg = cCfg {serverVRange = prevRange $ serverVRange cCfg}}
}
withSmpServerStoreMsgLogOn :: HasCallStack => (ASrvTransport, AStoreType) -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
withSmpServerStoreMsgLogOn :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
withSmpServerStoreMsgLogOn (t, msType) =
withSmpServerConfigOn t $ updateCfg (cfgMS msType) $ \cfg' -> cfg' {storeNtfsFile = Just testStoreNtfsFile, serverStatsBackupFile = Just testServerStatsBackupFile}
withSmpServerStoreLogOn :: HasCallStack => (ASrvTransport, AStoreType) -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
withSmpServerStoreLogOn :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
withSmpServerStoreLogOn (t, msType) =
withSmpServerConfigOn t $ updateCfg (cfgMS msType) $ \cfg' -> cfg' {serverStatsBackupFile = Just testServerStatsBackupFile}
@@ -389,26 +397,32 @@ withSmpServerConfigOn t (ASrvCfg _ _ cfg') port' =
(\started -> runSMPServerBlocking started cfg' {transports = [(port', t, False)]} Nothing)
(threadDelay 10000)
withSmpServerThreadOn :: HasCallStack => (ASrvTransport, AStoreType) -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
withSmpServerThreadOn :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
withSmpServerThreadOn (t, msType) = withSmpServerConfigOn t (cfgMS msType)
serverBracket :: HasCallStack => (TMVar Bool -> IO ()) -> IO () -> (HasCallStack => ThreadId -> IO a) -> IO a
serverBracket process afterProcess f = do
started <- newEmptyTMVarIO
startError <- newEmptyTMVarIO
stopped <- newEmptyTMVarIO
E.bracket
(forkIOWithUnmask (\unmask -> unmask (process started) `E.catchAny` handleStartError started))
(\t -> killThread t >> afterProcess >> waitFor started "stop")
(\t -> waitFor started "start" >> f t >>= \r -> r <$ threadDelay 100000)
(forkIOWithUnmask (\unmask -> (unmask (process started) `E.catchAny` handleStartError started startError) `E.finally` atomically (putTMVar stopped ())))
(\t -> forkIO (killThread t) >> afterProcess >> waitStopped stopped)
(\t -> checkStarted started startError >> f t >>= \r -> r <$ threadDelay 100000)
where
-- it putTMVar is called twise to unlock both parts of the bracket in case of start failure
handleStartError started e = do
atomically $ putTMVar started False
handleStartError started startError e = do
atomically $ putTMVar startError e
atomically $ putTMVar started False
E.throwIO e
waitFor started s =
checkStarted started startError =
5_000_000 `timeout` atomically (takeTMVar started) >>= \case
Nothing -> error $ "server did not " <> s
_ -> pure ()
Nothing -> error "server did not start"
Just True -> pure ()
Just False -> atomically (readTMVar startError) >>= \e -> error $ "server did not start: " <> show e
waitStopped stopped = do
delay <- registerDelay 30_000_000
ok <- atomically $ (True <$ takeTMVar stopped) `orElse` (False <$ (readTVar delay >>= checkSTM))
unless ok $ error "server did not stop"
-- A TCP server that accepts connections but never performs a TLS handshake, so a client
-- connecting to it stays blocked in the TLS handshake until its connection timeout.
@@ -419,28 +433,28 @@ withStallingServerOn port action =
(pure ())
(const action)
withSmpServerOn :: HasCallStack => (ASrvTransport, AStoreType) -> ServiceName -> IO a -> IO a
withSmpServerOn :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> ServiceName -> IO a -> IO a
withSmpServerOn ps port' = withSmpServerThreadOn ps port' . const
withSmpServer :: HasCallStack => (ASrvTransport, AStoreType) -> IO a -> IO a
withSmpServer :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO a -> IO a
withSmpServer ps = withSmpServerOn ps testPort
withSmpServerProxy :: HasCallStack => (ASrvTransport, AStoreType) -> IO a -> IO a
withSmpServerProxy :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO a -> IO a
withSmpServerProxy (t, msType) = withSmpServerConfigOn t (proxyCfgMS msType) testPort . const
withSmpServers2 :: HasCallStack => (ASrvTransport, AStoreType) -> IO a -> IO a
withSmpServers2 ps@(t, ASType qs _ms) = withSmpServer ps . withSmpServerConfigOn t (cfgJ2QS qs) testPort2 . const
withSmpServers2 :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO a -> IO a
withSmpServers2 ps@(t, ASType qs _ms) = withSmpServer ps . withSmpServerConfigOn t (cfgS2QS qs) testPort2 . const
withSmpServersProxy2 :: HasCallStack => (ASrvTransport, AStoreType) -> IO a -> IO a
withSmpServersProxy2 ps@(t, ASType qs _ms) = withSmpServerProxy ps . withSmpServerConfigOn t (proxyCfgJ2QS qs) testPort2 . const
withSmpServersProxy2 :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO a -> IO a
withSmpServersProxy2 ps@(t, ASType qs _ms) = withSmpServerProxy ps . withSmpServerConfigOn t (proxyCfgS2QS qs) testPort2 . const
runSmpTest :: forall c a. (HasCallStack, Transport c) => AStoreType -> (HasCallStack => THandleSMP c 'TClient -> IO a) -> IO a
runSmpTest :: forall c a. (HasCallStack, HasTestEnv, Transport c) => AStoreType -> (HasCallStack => THandleSMP c 'TClient -> IO a) -> IO a
runSmpTest msType test = withSmpServerConfigOn (transport @c) (cfgMS msType) testPort $ \_ -> testSMPClient test
runSmpTestN :: forall c a. (HasCallStack, Transport c) => AStoreType -> Int -> (HasCallStack => [THandleSMP c 'TClient] -> IO a) -> IO a
runSmpTestN :: forall c a. (HasCallStack, HasTestEnv, Transport c) => AStoreType -> Int -> (HasCallStack => [THandleSMP c 'TClient] -> IO a) -> IO a
runSmpTestN msType = runSmpTestNCfg (cfgMS msType) supportedClientSMPRelayVRange
runSmpTestNCfg :: forall c a. (HasCallStack, Transport c) => AServerConfig -> VersionRangeSMP -> Int -> (HasCallStack => [THandleSMP c 'TClient] -> IO a) -> IO a
runSmpTestNCfg :: forall c a. (HasCallStack, HasTestEnv, Transport c) => AServerConfig -> VersionRangeSMP -> Int -> (HasCallStack => [THandleSMP c 'TClient] -> IO a) -> IO a
runSmpTestNCfg srvCfg clntVR nClients test = withSmpServerConfigOn (transport @c) srvCfg testPort $ \_ -> run nClients []
where
run :: Int -> [THandleSMP c 'TClient] -> IO a
@@ -449,11 +463,11 @@ runSmpTestNCfg srvCfg clntVR nClients test = withSmpServerConfigOn (transport @c
smpServerTest ::
forall c smp.
(Transport c, Encoding smp) =>
(HasTestEnv, Transport c, Encoding smp) =>
TProxy c 'TServer ->
(Maybe TAuthorizations, ByteString, ByteString, smp) ->
IO (Maybe TAuthorizations, ByteString, ByteString, BrokerMsg)
smpServerTest _ t = runSmpTest (ASType SQSMemory SMSJournal) $ \h -> tPut' h t >> tGet' h
smpServerTest _ t = runSmpTest (ASType SQSMemory SMSMemory) $ \h -> tPut' h t >> tGet' h
where
tPut' :: THandleSMP c 'TClient -> (Maybe TAuthorizations, ByteString, ByteString, smp) -> IO ()
tPut' h@THandle {params = THandleParams {sessionId, implySessId}} (sig, corrId, queueId, smp) = do
@@ -464,30 +478,30 @@ smpServerTest _ t = runSmpTest (ASType SQSMemory SMSJournal) $ \h -> tPut' h t >
[(CorrId corrId, EntityId qId, Right cmd)] <- tGetClient h
pure (Nothing, corrId, qId, cmd)
smpTest :: (HasCallStack, Transport c) => TProxy c 'TServer -> AStoreType -> (HasCallStack => THandleSMP c 'TClient -> IO ()) -> Expectation
smpTest :: (HasCallStack, HasTestEnv, Transport c) => TProxy c 'TServer -> AStoreType -> (HasCallStack => THandleSMP c 'TClient -> IO ()) -> Expectation
smpTest _ msType test' = runSmpTest msType test' `shouldReturn` ()
smpTestN :: (HasCallStack, Transport c) => AStoreType -> Int -> (HasCallStack => [THandleSMP c 'TClient] -> IO ()) -> Expectation
smpTestN :: (HasCallStack, HasTestEnv, Transport c) => AStoreType -> Int -> (HasCallStack => [THandleSMP c 'TClient] -> IO ()) -> Expectation
smpTestN msType n test' = runSmpTestN msType n test' `shouldReturn` ()
smpTest2 :: forall c. (HasCallStack, Transport c) => TProxy c 'TServer -> AStoreType -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
smpTest2 :: forall c. (HasCallStack, HasTestEnv, Transport c) => TProxy c 'TServer -> AStoreType -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
smpTest2 t msType = smpTest2Cfg (cfgMS msType) supportedClientSMPRelayVRange t
smpTest2Cfg :: forall c. (HasCallStack, Transport c) => AServerConfig -> VersionRangeSMP -> TProxy c 'TServer -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
smpTest2Cfg :: forall c. (HasCallStack, HasTestEnv, Transport c) => AServerConfig -> VersionRangeSMP -> TProxy c 'TServer -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
smpTest2Cfg srvCfg clntVR _ test' = runSmpTestNCfg srvCfg clntVR 2 _test `shouldReturn` ()
where
_test :: HasCallStack => [THandleSMP c 'TClient] -> IO ()
_test [h1, h2] = test' h1 h2
_test _ = error "expected 2 handles"
smpTest3 :: forall c. (HasCallStack, Transport c) => TProxy c 'TServer -> AStoreType -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
smpTest3 :: forall c. (HasCallStack, HasTestEnv, Transport c) => TProxy c 'TServer -> AStoreType -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
smpTest3 _ msType test' = smpTestN msType 3 _test
where
_test :: HasCallStack => [THandleSMP c 'TClient] -> IO ()
_test [h1, h2, h3] = test' h1 h2 h3
_test _ = error "expected 3 handles"
smpTest4 :: forall c. (HasCallStack, Transport c) => TProxy c 'TServer -> AStoreType -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
smpTest4 :: forall c. (HasCallStack, HasTestEnv, Transport c) => TProxy c 'TServer -> AStoreType -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
smpTest4 _ msType test' = smpTestN msType 4 _test
where
_test :: HasCallStack => [THandleSMP c 'TClient] -> IO ()
tests/SMPProxyTests.hs
+73 -77
View File
@@ -47,13 +47,9 @@ import Simplex.Messaging.Version (mkVersionRange)
import System.FilePath (splitExtensions)
import System.Random (randomRIO)
import Text.Read (readMaybe)
import Test.Hspec hiding (fit, it)
import Test.Hspec hiding (fit, it, xit)
import UnliftIO
import Util
#if defined(dbPostgres)
import Fixtures
import Simplex.Messaging.Agent.Store.Postgres.Util (dropAllSchemasExceptSystem)
#endif
smpProxyTests :: SpecWith AStoreType
smpProxyTests = do
@@ -88,73 +84,71 @@ smpProxyTests = do
it "relay delays AUTH errors to forwarded commands" $ \_ ->
testForwardedAuthErrorDelay
describe "deliver message via SMP proxy" $ do
let srv1 = SMPServer testHost testPort testKeyHash
let srv1, srv2 :: HasTestEnv => SMPServer
srv1 = SMPServer testHost testPort testKeyHash
srv2 = SMPServer testHost2 testPort2 testKeyHash
describe "client API" $ do
let maxLen = maxMessageLength
describe "one server" $ do
it "deliver via proxy" . oneServer $ do
it "deliver via proxy" $ oneServer $ do
deliverMessageViaProxy srv1 srv1 C.SEd448 "hello 1" "hello 2"
describe "two servers" $ do
let proxyServ = srv1
let proxyServ, relayServ :: HasTestEnv => SMPServer
proxyServ = srv1
relayServ = srv2
(msg1, msg2) <- runIO $ do
g <- C.newRandom
atomically $ (,) <$> C.randomBytes maxLen g <*> C.randomBytes maxLen g
it "deliver via proxy" . twoServersFirstProxy $
it "deliver via proxy" $ twoServersFirstProxy $
deliverMessageViaProxy proxyServ relayServ C.SEd448 "hello 1" "hello 2"
it "max message size, Ed448 keys" . twoServersFirstProxy $
it "max message size, Ed448 keys" $ twoServersFirstProxy $
deliverMessageViaProxy proxyServ relayServ C.SEd448 msg1 msg2
it "max message size, Ed25519 keys" . twoServersFirstProxy $
it "max message size, Ed25519 keys" $ twoServersFirstProxy $
deliverMessageViaProxy proxyServ relayServ C.SEd25519 msg1 msg2
it "max message size, X25519 keys" . twoServersFirstProxy $
it "max message size, X25519 keys" $ twoServersFirstProxy $
deliverMessageViaProxy proxyServ relayServ C.SX25519 msg1 msg2
describe "version compatibility" $ do
let deliver clientVR = deliverMessagesViaProxyVR clientVR srv1 srv2 C.SEd448 ["hello 1"] ["hello 2"]
it "prev client" . twoServersFirstProxy $ deliver (prevRange supportedClientSMPRelayVRange)
it "prev proxy" . twoServersPrevProxy $ deliver supportedClientSMPRelayVRange
it "prev relay" . twoServersPrevRelay $ deliver supportedClientSMPRelayVRange
it "prev client" $ twoServersFirstProxy $ deliver (prevRange supportedClientSMPRelayVRange)
it "prev proxy" $ twoServersPrevProxy $ deliver supportedClientSMPRelayVRange
it "prev relay" $ twoServersPrevRelay $ deliver supportedClientSMPRelayVRange
describe "stress test 1k" $ do
let deliver n = deliverMessagesViaProxy srv1 srv2 C.SEd448 [] (map bshow [1 :: Int .. n])
it "1x1000" . twoServersFirstProxy $ deliver 1000
it "5x200" . twoServersFirstProxy $ 5 `inParrallel` deliver 200
it "10x100" . twoServersFirstProxy $ 10 `inParrallel` deliver 100
it "1x1000" $ twoServersFirstProxy $ deliver 1000
it "5x200" $ twoServersFirstProxy $ 5 `inParrallel` deliver 200
it "10x100" $ twoServersFirstProxy $ 10 `inParrallel` deliver 100
describe "stress test - no host" $ do
it "1x1000, no delay" . oneServer $ proxyConnectDeadRelay 1000 0 srv1
xit "1x1000, 100ms" . oneServer $ proxyConnectDeadRelay 1000 100000 srv1
xit "100x1000, 100ms" . oneServer $ 100 `inParrallel` (randomRIO (0, 1000000) >>= threadDelay >> proxyConnectDeadRelay 1000 100000 srv1)
it "1x1000, no delay" $ oneServer $ proxyConnectDeadRelay 1000 0 srv1
xit "1x1000, 100ms" $ oneServer $ proxyConnectDeadRelay 1000 100000 srv1
xit "100x1000, 100ms" $ oneServer $ 100 `inParrallel` (randomRIO (0, 1000000) >>= threadDelay >> proxyConnectDeadRelay 1000 100000 srv1)
xdescribe "stress test 10k" $ do
let deliver n = deliverMessagesViaProxy srv1 srv2 C.SEd448 [] (map bshow [1 :: Int .. n])
it "1x10000" . twoServersFirstProxy $ deliver 10000
it "5x2000" . twoServersFirstProxy $ 5 `inParrallel` deliver 2000
it "10x1000" . twoServersFirstProxy $ 10 `inParrallel` deliver 1000
it "100x100 N1" . twoServersFirstProxy $ withNumCapabilities 1 $ 100 `inParrallel` deliver 100
it "100x100 N4 C1" . twoServersNoConc $ withNumCapabilities 4 $ 100 `inParrallel` deliver 100
it "100x100 N4 C2" . twoServersFirstProxy $ withNumCapabilities 4 $ 100 `inParrallel` deliver 100
it "100x100 N4 C16" . twoServersMoreConc $ withNumCapabilities 4 $ 100 `inParrallel` deliver 100
it "100x100 N" . twoServersFirstProxy $ withNCPUCapabilities $ 100 `inParrallel` deliver 100
it "500x20" . twoServersFirstProxy $ 500 `inParrallel` deliver 20
#if defined(dbPostgres)
after_ (dropAllSchemasExceptSystem testDBConnectInfo) . describe "agent API" $ do
#else
it "1x10000" $ twoServersFirstProxy $ deliver 10000
it "5x2000" $ twoServersFirstProxy $ 5 `inParrallel` deliver 2000
it "10x1000" $ twoServersFirstProxy $ 10 `inParrallel` deliver 1000
it "100x100 N1" $ twoServersFirstProxy $ withNumCapabilities 1 $ 100 `inParrallel` deliver 100
it "100x100 N4 C1" $ twoServersNoConc $ withNumCapabilities 4 $ 100 `inParrallel` deliver 100
it "100x100 N4 C2" $ twoServersFirstProxy $ withNumCapabilities 4 $ 100 `inParrallel` deliver 100
it "100x100 N4 C16" $ twoServersMoreConc $ withNumCapabilities 4 $ 100 `inParrallel` deliver 100
it "100x100 N" $ twoServersFirstProxy $ withNCPUCapabilities $ 100 `inParrallel` deliver 100
it "500x20" $ twoServersFirstProxy $ 500 `inParrallel` deliver 20
describe "agent API" $ do
#endif
describe "one server" $ do
it "always via proxy" . oneServer $
it "always via proxy" $ oneServer $
agentDeliverMessageViaProxy ([srv1], SPMAlways, True) ([srv1], SPMAlways, True) C.SEd448 "hello 1" "hello 2" 1
it "without proxy" . oneServer $
it "without proxy" $ oneServer $
agentDeliverMessageViaProxy ([srv1], SPMNever, False) ([srv1], SPMNever, False) C.SEd448 "hello 1" "hello 2" 1
describe "two servers" $ do
it "always via proxy" $ \msType -> twoServers
(agentDeliverMessageViaProxy ([srv1], SPMAlways, True) ([srv2], SPMAlways, True) C.SEd448 "hello 1" "hello 2" 1)
msType
it "both via proxy" . twoServers $
it "both via proxy" $ twoServers $
agentDeliverMessageViaProxy ([srv1], SPMUnknown, True) ([srv2], SPMUnknown, True) C.SEd448 "hello 1" "hello 2" 1
it "first via proxy" . twoServers $
it "first via proxy" $ twoServers $
agentDeliverMessageViaProxy ([srv1], SPMUnknown, True) ([srv2], SPMNever, False) C.SEd448 "hello 1" "hello 2" 1
it "without proxy" . twoServers $
it "without proxy" $ twoServers $
agentDeliverMessageViaProxy ([srv1], SPMNever, False) ([srv2], SPMNever, False) C.SEd448 "hello 1" "hello 2" 1
it "first via proxy for unknown" . twoServers $
it "first via proxy for unknown" $ twoServers $
agentDeliverMessageViaProxy ([srv1], SPMUnknown, True) ([srv1, srv2], SPMUnknown, False) C.SEd448 "hello 1" "hello 2" 1
it "retries sending when destination or proxy relay is offline" $ \_ ->
agentViaProxyRetryOffline
@@ -162,29 +156,35 @@ smpProxyTests = do
agentViaProxyRetryNoSession
describe "stress test 1k" $ do
let deliver nAgents nMsgs = agentDeliverMessagesViaProxyConc (replicate nAgents [srv1]) (map bshow [1 :: Int .. nMsgs])
it "2 agents, 250 messages" . oneServer $ deliver 2 250
it "5 agents, 10 pairs, 50 messages, N1" . oneServer . withNumCapabilities 1 $ deliver 5 50
it "5 agents, 10 pairs, 50 messages. N4" . oneServer . withNumCapabilities 4 $ deliver 5 50
it "2 agents, 250 messages" $ oneServer $ deliver 2 250
xdescribe "stress test 10k" $ do
let deliver nAgents nMsgs = agentDeliverMessagesViaProxyConc (replicate nAgents [srv1]) (map bshow [1 :: Int .. nMsgs])
it "25 agents, 300 pairs, 17 messages" . oneServer . withNumCapabilities 4 $ deliver 25 17
it "25 agents, 300 pairs, 17 messages" $ oneServer $ withNumCapabilities 4 $ deliver 25 17
where
oneServer test msType = withSmpServerConfigOn (transport @TLS) (updateCfg (proxyCfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 128, maxJournalMsgCount = 256}) testPort $ const test
twoServers test msType = twoServers_ (proxyCfgMS msType) (proxyCfgMS msType) test msType
twoServersFirstProxy test msType = twoServers_ (proxyCfgMS msType) (updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 128, maxJournalMsgCount = 256}) test msType
twoServersMoreConc test msType = twoServers_ (updateCfg (proxyCfgMS msType) $ \cfg_ -> cfg_ {serverClientConcurrency = 128}) (updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 128, maxJournalMsgCount = 256}) test msType
twoServersNoConc test msType = twoServers_ (updateCfg (proxyCfgMS msType) $ \cfg_ -> cfg_ {serverClientConcurrency = 1}) (updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 128, maxJournalMsgCount = 256}) test msType
twoServersFirstProxy test msType = twoServers_ (proxyCfgMS msType) (updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 128}) test msType
twoServersMoreConc test msType = twoServers_ (updateCfg (proxyCfgMS msType) $ \cfg_ -> cfg_ {serverClientConcurrency = 128}) (updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 128}) test msType
twoServersNoConc test msType = twoServers_ (updateCfg (proxyCfgMS msType) $ \cfg_ -> cfg_ {serverClientConcurrency = 1}) (updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 128}) test msType
twoServersPrevProxy test msType = twoServers_ (proxyCfgVPrev msType) (cfgMS msType) test msType
twoServersPrevRelay test msType = twoServers_ (proxyCfgMS msType) (prevServerVRange $ cfgMS msType) test msType
prevServerVRange cfg' = updateCfg cfg' $ \cfg_ -> cfg_ {smpServerVRange = prevRange $ smpServerVRange cfg_}
twoServers_ :: AServerConfig -> AServerConfig -> IO () -> AStoreType -> IO ()
twoServers_ :: HasTestEnv => AServerConfig -> AServerConfig -> IO () -> AStoreType -> IO ()
twoServers_ cfg1 cfg2 runTest (ASType qsType _) =
withSmpServerConfigOn (transport @TLS) cfg1 testPort $ \_ ->
let cfg2' = case qsType of
SQSMemory -> journalCfg cfg2 testStoreLogFile2 testStoreMsgsDir2
SQSPostgres -> journalCfgDB cfg2 testStoreDBOpts2 testStoreMsgsDir2
SQSMemory -> memoryCfg cfg2 testStoreLogFile2 testStoreMsgsFile2
SQSPostgres -> databaseCfg cfg2 testStoreDBOpts2
in withSmpServerConfigOn (transport @TLS) cfg2' testPort2 $ const runTest
smpProxyCapabilityTests :: SpecWith AStoreType
smpProxyCapabilityTests = do
let deliver nAgents nMsgs = agentDeliverMessagesViaProxyConc (replicate nAgents [testSMPServer]) (map bshow [1 :: Int .. nMsgs])
it "5 agents, 10 pairs, 50 messages, N1" $ oneServer $ withNumCapabilities 1 $ deliver 5 50
it "5 agents, 10 pairs, 50 messages. N4" $ oneServer $ withNumCapabilities 4 $ deliver 5 50
oneServer :: HasTestEnv => IO a -> AStoreType -> IO a
oneServer test msType = withSmpServerConfigOn (transport @TLS) (updateCfg (proxyCfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 128}) testPort $ const test
deliverMessageViaProxy :: (C.AlgorithmI a, C.AuthAlgorithm a) => SMPServer -> SMPServer -> C.SAlgorithm a -> ByteString -> ByteString -> IO ()
deliverMessageViaProxy proxyServ relayServ alg msg msg' = deliverMessagesViaProxy proxyServ relayServ alg [msg] [msg']
@@ -251,7 +251,7 @@ proxyConnectDeadRelay n d proxyServ = do
Right !_noWay -> error "got unexpected client"
Left !_err -> threadDelay d
agentDeliverMessageViaProxy :: (C.AlgorithmI a, C.AuthAlgorithm a) => (NonEmpty SMPServer, SMPProxyMode, Bool) -> (NonEmpty SMPServer, SMPProxyMode, Bool) -> C.SAlgorithm a -> ByteString -> ByteString -> AgentMsgId -> IO ()
agentDeliverMessageViaProxy :: (HasTestEnv, C.AlgorithmI a, C.AuthAlgorithm a) => (NonEmpty SMPServer, SMPProxyMode, Bool) -> (NonEmpty SMPServer, SMPProxyMode, Bool) -> C.SAlgorithm a -> ByteString -> ByteString -> AgentMsgId -> IO ()
agentDeliverMessageViaProxy aTestCfg@(aSrvs, _, aViaProxy) bTestCfg@(bSrvs, _, bViaProxy) alg msg1 msg2 baseId =
withAgent 1 aCfg (servers aTestCfg) testDB $ \alice ->
withAgent 2 aCfg (servers bTestCfg) testDB2 $ \bob -> runRight_ $ do
@@ -290,7 +290,7 @@ agentDeliverMessageViaProxy aTestCfg@(aSrvs, _, aViaProxy) bTestCfg@(bSrvs, _, b
aCfg = agentCfg {sndAuthAlg = C.AuthAlg alg, rcvAuthAlg = C.AuthAlg alg}
servers (srvs, smpProxyMode, _) = (initAgentServersProxy_ smpProxyMode SPFAllow) {smp = userServers srvs}
agentDeliverMessagesViaProxyConc :: [NonEmpty SMPServer] -> [MsgBody] -> IO ()
agentDeliverMessagesViaProxyConc :: HasTestEnv => [NonEmpty SMPServer] -> [MsgBody] -> IO ()
agentDeliverMessagesViaProxyConc agentServers msgs =
withAgents $ \agents -> do
let pairs = combinations 2 agents
@@ -357,7 +357,7 @@ agentDeliverMessagesViaProxyConc agentServers msgs =
aCfg = agentCfg {sndAuthAlg = C.AuthAlg C.SEd448, rcvAuthAlg = C.AuthAlg C.SEd448}
servers srvs = (initAgentServersProxy_ SPMAlways SPFAllow) {smp = userServers srvs}
agentViaProxyRetryOffline :: IO ()
agentViaProxyRetryOffline :: HasTestEnv => IO ()
agentViaProxyRetryOffline = do
let srv1 = SMPServer testHost testPort testKeyHash
srv2 = SMPServer testHost testPort2 testKeyHash
@@ -413,15 +413,11 @@ agentViaProxyRetryOffline = do
ackMessage alice bobId (baseId + 4) Nothing
where
withServer :: (ThreadId -> IO a) -> IO a
withServer = withServer_ testStoreLogFile testStoreMsgsDir testStoreNtfsFile testPort
-- TODO [postgres]
-- withServer = withServer_ testStoreDBOpts testStoreMsgsDir testStoreNtfsFile testPort
withServer = withServer_ testStoreLogFile testStoreMsgsFile testStoreNtfsFile testPort
withServer2 :: (ThreadId -> IO a) -> IO a
withServer2 = withServer_ testStoreLogFile2 testStoreMsgsDir2 testStoreNtfsFile2 testPort2
-- TODO [postgres]
-- withServer2 = withServer_ testStoreDBOpts2 testStoreMsgsDir2 testStoreNtfsFile2 testPort2
withServer2 = withServer_ testStoreLogFile2 testStoreMsgsFile2 testStoreNtfsFile2 testPort2
withServer_ storeLog storeMsgs storeNtfs =
let cfg' = updateCfg (journalCfg proxyCfg storeLog storeMsgs) $ \cfg_ -> cfg_ {storeNtfsFile = Just storeNtfs}
let cfg' = updateCfg (memoryCfg proxyCfg storeLog storeMsgs) $ \cfg_ -> cfg_ {storeNtfsFile = Just storeNtfs}
in withSmpServerConfigOn (transport @TLS) cfg'
a `up` cId = nGet a =##> \case ("", "", UP _ [c]) -> c == cId; _ -> False
a `down` cId = nGet a =##> \case ("", "", DOWN _ [c]) -> c == cId; _ -> False
@@ -430,7 +426,7 @@ agentViaProxyRetryOffline = do
msgId = subtract baseId . fst
servers srv = initAgentServersProxy {smp = userServers [srv]}
agentViaProxyRetryNoSession :: IO ()
agentViaProxyRetryNoSession :: HasTestEnv => IO ()
agentViaProxyRetryNoSession = do
let srv1 = SMPServer testHost testPort testKeyHash
srv2 = SMPServer testHost testPort2 testKeyHash
@@ -447,17 +443,17 @@ agentViaProxyRetryNoSession = do
_ <- runRight $ makeConnection b a
pure ()
where
withServer2 = withSmpServerConfigOn (transport @TLS) proxyCfgJ2 testPort2
withServer2 = withSmpServerConfigOn (transport @TLS) proxyCfgS2 testPort2
servers srv = initAgentServersProxy {smp = userServers [srv]}
testNoProxy :: AStoreType -> IO ()
testNoProxy :: HasTestEnv => AStoreType -> IO ()
testNoProxy msType = do
withSmpServerConfigOn (transport @TLS) (cfgMS msType) testPort2 $ \_ -> do
testSMPClient_ "127.0.0.1" testPort2 supportedServerSMPRelayVRange Nothing $ \(th :: THandleSMP TLS 'TClient) -> do
(_, _, reply) <- sendRecv th (Nothing, "0", NoEntity, SMP.PRXY testSMPServer Nothing)
reply `shouldBe` Right (SMP.ERR $ SMP.PROXY SMP.BASIC_AUTH)
testProxyAuth :: AStoreType -> IO ()
testProxyAuth :: HasTestEnv => AStoreType -> IO ()
testProxyAuth msType = do
withSmpServerConfigOn (transport @TLS) proxyCfgAuth testPort $ \_ -> do
testSMPClient_ "127.0.0.1" testPort supportedServerSMPRelayVRange Nothing $ \(th :: THandleSMP TLS 'TClient) -> do
@@ -468,12 +464,12 @@ testProxyAuth msType = do
-- Connect a sender client to the proxy and request a relay session to testSMPServer2 (PRXY).
-- On success the reply is PKEY; otherwise it is the proxy error for the relay connection.
requestRelaySession :: IO (Either SMP.ErrorType SMP.BrokerMsg)
requestRelaySession :: HasTestEnv => IO (Either SMP.ErrorType SMP.BrokerMsg)
requestRelaySession =
testSMPClient_ "localhost" testPort supportedServerSMPRelayVRange Nothing $ \(th :: THandleSMP TLS 'TClient) ->
(\(_, _, reply) -> reply) <$> sendRecv th (Nothing, "1", NoEntity, SMP.PRXY testSMPServer2 Nothing)
testChangedFwdVersion :: IO ()
testChangedFwdVersion :: HasTestEnv => IO ()
testChangedFwdVersion =
withSmpServerConfigOn (transport @TLS) cfg testPort $ \_ -> do
g <- C.newRandom
@@ -488,10 +484,10 @@ testChangedFwdVersion =
_ <- runExceptT' $ forward v
runExceptT (forward $ prevVersion v) `shouldReturn` Left (PCEProtocolError SMP.CRYPTO)
testFwdCorrIdSize :: IO ()
testFwdCorrIdSize :: HasTestEnv => IO ()
testFwdCorrIdSize =
withSmpServerConfigOn (transport @TLS) proxyCfg testPort $ \_ ->
withSmpServerConfigOn (transport @TLS) cfgJ2 testPort2 $ \_ ->
withSmpServerConfigOn (transport @TLS) cfgS2 testPort2 $ \_ ->
testSMPClient_ "localhost" testPort supportedServerSMPRelayVRange Nothing $ \(th :: THandleSMP TLS 'TClient) -> do
(_, _, Right (SMP.PKEY sessId _ _)) <- sendRecv th (Nothing, "1", NoEntity, SMP.PRXY testSMPServer2 Nothing)
g <- C.newRandom
@@ -500,10 +496,10 @@ testFwdCorrIdSize =
(_, _, reply) <- sendRecv th (Nothing, corrId, SMP.EntityId sessId, SMP.PFWD currentClientSMPRelayVersion cmdPubKey (SMP.EncTransmission ""))
reply `shouldBe` Right (SMP.ERR $ SMP.CMD SMP.SYNTAX)
testForwardedAuthErrorDelay :: IO ()
testForwardedAuthErrorDelay :: HasTestEnv => IO ()
testForwardedAuthErrorDelay =
withSmpServerConfigOn (transport @TLS) proxyCfg testPort $ \_ ->
withSmpServerConfigOn (transport @TLS) (updateCfg cfgJ2 $ \cfg_ -> cfg_ {authErrorDelay = 500000}) testPort2 $ \_ -> do
withSmpServerConfigOn (transport @TLS) (updateCfg cfgS2 $ \cfg_ -> cfg_ {authErrorDelay = 500000}) testPort2 $ \_ -> do
g <- C.newRandom
ts <- getCurrentTime
pc <- either (fail . show) pure =<< getProtocolClient g NRMInteractive (1, testSMPServer, Nothing) defaultSMPClientConfig [] Nothing ts (\_ -> pure ())
@@ -516,9 +512,9 @@ testForwardedAuthErrorDelay =
-- Shared "phase 2" of the reconnection tests: start a healthy relay, confirm it is reachable
-- directly (PING, not via the proxy) so a proxy failure can only mean the proxy didn't reconnect,
-- let any stored connection error expire, then require the proxy to establish the session (PKEY).
requireProxyReconnect :: IO ()
requireProxyReconnect :: HasTestEnv => IO ()
requireProxyReconnect =
withSmpServerConfigOn (transport @TLS) proxyCfgJ2 testPort2 $ \_ -> do
withSmpServerConfigOn (transport @TLS) proxyCfgS2 testPort2 $ \_ -> do
testSMPClient_ "127.0.0.1" testPort2 supportedServerSMPRelayVRange Nothing $ \(th :: THandleSMP TLS 'TClient) -> do
(_, _, reply) <- sendRecv th (Nothing, "0", NoEntity, SMP.PING)
reply `shouldBe` Right SMP.PONG
@@ -531,7 +527,7 @@ requireProxyReconnect =
-- The connect fails by timing out (storing a Left error that self-heals via persistErrorInterval),
-- so once a healthy relay is running the proxy reconnects. This proves the stalling relay alone
-- does not cause the permanent failure - only the mid-connection disconnect does.
testProxyRecoversWithoutDisconnect :: IO ()
testProxyRecoversWithoutDisconnect :: HasTestEnv => IO ()
testProxyRecoversWithoutDisconnect =
withSmpServerConfigOn (transport @TLS) proxyCfgShortTimeout testPort $ \_ -> do
withStallingServerOn testPort2 $
@@ -553,7 +549,7 @@ testProxyRecoversWithoutDisconnect =
-- The stalling relay (accepts TCP, never completes TLS) holds the connect open long enough to
-- interleave the disconnect. Phase 2 (requireProxyReconnect) is identical to the control above;
-- the only difference is this disconnect.
testProxyReconnectAfterRelayRestart :: IO ()
testProxyReconnectAfterRelayRestart :: HasTestEnv => IO ()
testProxyReconnectAfterRelayRestart =
withSmpServerConfigOn (transport @TLS) proxyCfgShortTimeout testPort $ \_ -> do
-- disconnect the sender 1s into the 4s connect to the stalling relay, killing the in-flight worker
@@ -614,14 +610,14 @@ testForwardOversizedNotKept =
-- skipped and the empty var is left in smpClients, so every later connection to that server times
-- out on it. Phase 1 cancels a connect to a stalling relay; phase 2 requires a fresh connect to a
-- healthy relay to succeed.
testAgentClientReconnectAfterCancel :: IO ()
testAgentClientReconnectAfterCancel :: HasTestEnv => IO ()
testAgentClientReconnectAfterCancel =
withAgent 1 agentCfg agentServersLeak testDB $ \a -> do
withStallingServerOn testPort2 $ do
t <- async $ runExceptT $ A.createConnection a NRMInteractive 1 True True SCMInvitation Nothing Nothing CR.IKPQOn False SMSubscribe
threadDelay 1000000 -- let the connect to the stalling relay start, then kill it mid-flight
cancel t
withSmpServerConfigOn (transport @TLS) cfgJ2 testPort2 $ \_ -> do
withSmpServerConfigOn (transport @TLS) cfgS2 testPort2 $ \_ -> do
testSMPClient_ "127.0.0.1" testPort2 supportedServerSMPRelayVRange Nothing $ \(th :: THandleSMP TLS 'TClient) -> do
(_, _, reply) <- sendRecv th (Nothing, "0", NoEntity, SMP.PING)
reply `shouldBe` Right SMP.PONG -- the relay is up and reachable, so a timeout can only be the poisoned var
tests/ServerTests.hs
+26 -35
View File
@@ -24,7 +24,6 @@ import Control.Concurrent.STM
import Control.Exception (SomeException, throwIO, try)
import Control.Monad
import Control.Monad.IO.Class
import CoreTests.MsgStoreTests (testJournalStoreCfg)
import Data.Bifunctor (first)
import qualified Data.ByteString.Base64 as B64
import Data.ByteString.Char8 (ByteString)
@@ -47,26 +46,26 @@ import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (parseAll, parseString)
import Simplex.Messaging.Protocol
import Simplex.Messaging.Server (exportMessages)
import Simplex.Messaging.Server.Env.STM (AStoreType (..), MsgStore (..), ServerConfig (..), ServerStoreCfg (..), readWriteQueueStore)
import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (..), ServerStoreCfg (..))
import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.Server.MsgStore.Journal (JournalStoreConfig (..), QStoreCfg (..), stmQueueStore)
import Simplex.Messaging.Server.MsgStore.Types (MsgStoreClass (..), QSType (..), SMSType (..), SQSType (..), newMsgStore)
import Simplex.Messaging.Server.MsgStore.Types (SMSType (..), SQSType (..))
import Simplex.Messaging.Server.Stats (PeriodStatsData (..), ServerStatsData (..))
import Simplex.Messaging.Server.StoreLog (StoreLogRecord (..), closeStoreLog)
import Simplex.Messaging.Server.StoreLog (StoreLogRecord (..))
import Simplex.Messaging.Transport
import Simplex.Messaging.Transport.Credentials
import Simplex.Messaging.Util (whenM)
import System.Directory (doesDirectoryExist, doesFileExist, removeDirectoryRecursive, removeFile)
import System.Directory (doesFileExist, removeFile)
import System.IO (IOMode (..), withFile)
import System.Timeout
import Test.HUnit
import Test.Hspec hiding (fit, it)
import Test.Hspec hiding (fit, it, xit)
import Util
#if defined(dbServerPostgres)
import CoreTests.MsgStoreTests (testPostgresStoreConfig)
import CoreTests.MsgStoreTests (testPostgresStoreConfig, testSMTStoreConfig)
import Simplex.Messaging.Server.Env.STM (readWriteQueueStore)
import Simplex.Messaging.Server.MsgStore.Postgres (PostgresMsgStoreCfg (..), exportDbMessages)
import Simplex.Messaging.Server.MsgStore.Types (MsgStoreClass (..), newMsgStore)
import Simplex.Messaging.Server.StoreLog (closeStoreLog)
#endif
serverTests :: SpecWith (ASrvTransport, AStoreType)
@@ -96,7 +95,6 @@ serverTests = do
describe "Restore messages" testRestoreMessages
describe "Restore messages (old / v2)" testRestoreExpireMessages
describe "Save prometheus metrics" testPrometheusMetrics
describe "Timing of AUTH error" testTiming
describe "Delay of AUTH error" testAuthErrorDelay
describe "Message notifications" $ do
testMessageNotifications
@@ -1035,15 +1033,15 @@ testWithStoreLog =
logSize testStoreLogFile `shouldReturn` (if compacting then 1 else 6)
removeFile testStoreLogFile
where
runTest :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation
runTest :: (HasTestEnv, Transport c) => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation
runTest _ test' server = do
testSMPClient test' `shouldReturn` ()
killThread server
runClient :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> Expectation
runClient :: (HasTestEnv, Transport c) => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> Expectation
runClient _ test' = testSMPClient test' `shouldReturn` ()
serverStoreLogCfg :: AStoreType -> (AServerConfig, Bool)
serverStoreLogCfg :: HasTestEnv => AStoreType -> (AServerConfig, Bool)
serverStoreLogCfg msType =
let cfg' =
withServerCfg (cfgMS msType) $ \cfg_ ->
@@ -1069,7 +1067,6 @@ testRestoreMessages =
it "should store messages on exit and restore on start" $ \(at@(ATransport t), msType) -> do
removeFileIfExists testStoreLogFile
removeFileIfExists testStoreMsgsFile
whenM (doesDirectoryExist testStoreMsgsDir) $ removeDirectoryRecursive testStoreMsgsDir
removeFileIfExists testServerStatsBackupFile
g <- C.newRandom
@@ -1139,15 +1136,14 @@ testRestoreMessages =
Right stats3 <- strDecode <$> B.readFile testServerStatsBackupFile
checkStats stats3 [rId] 5 5
removeFileIfExists testStoreMsgsFile
whenM (doesDirectoryExist testStoreMsgsDir) $ removeDirectoryRecursive testStoreMsgsDir
removeFile testServerStatsBackupFile
where
runTest :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation
runTest :: (HasTestEnv, Transport c) => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation
runTest _ test' server = do
testSMPClient test' `shouldReturn` ()
killThread server
runClient :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> Expectation
runClient :: (HasTestEnv, Transport c) => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> Expectation
runClient _ test' = testSMPClient test' `shouldReturn` ()
checkStats :: ServerStatsData -> [RecipientId] -> Int -> Int -> Expectation
@@ -1217,36 +1213,31 @@ testRestoreExpireMessages =
Right ServerStatsData {_msgExpired} <- strDecode <$> B.readFile testServerStatsBackupFile
_msgExpired `shouldBe` 2
where
exportStoreMessages :: AStoreType -> IO ()
exportStoreMessages :: HasTestEnv => AStoreType -> IO ()
exportStoreMessages = \case
ASType _ SMSJournal -> export
ASType _ SMSPostgres -> exportDB
ASType _ SMSMemory -> pure ()
where
export = do
ms <- readWriteQueues
exportMessages False (StoreJournal ms) testStoreMsgsFile False
closeMsgStore ms
#if defined(dbServerPostgres)
exportDB = do
readWriteQueues >>= closeMsgStore
ms' <- newMsgStore (testPostgresStoreConfig {quota = 4} :: PostgresMsgStoreCfg)
_n <- withFile testStoreMsgsFile WriteMode $ exportDbMessages False ms'
closeMsgStore ms'
readWriteQueues = do
ms <- newMsgStore testSMTStoreConfig
readWriteQueueStore True (mkQueue ms) testStoreLogFile (queueStore ms) >>= closeStoreLog
removeFileIfExists testStoreMsgsFile
pure ms
#else
exportDB = error "compiled without server_postgres flag"
#endif
readWriteQueues = do
ms <- newMsgStore ((testJournalStoreCfg MQStoreCfg) {quota = 4} :: JournalStoreConfig 'QSMemory)
readWriteQueueStore True (mkQueue ms True) testStoreLogFile (stmQueueStore ms) >>= closeStoreLog
removeFileIfExists testStoreMsgsFile
pure ms
runTest :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation
runTest :: (HasTestEnv, Transport c) => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation
runTest _ test' server = do
testSMPClient test' `shouldReturn` ()
killThread server
runClient :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> Expectation
runClient :: (HasTestEnv, Transport c) => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> Expectation
runClient _ test' = testSMPClient test' `shouldReturn` ()
testPrometheusMetrics :: SpecWith (ASrvTransport, AStoreType)
@@ -1539,7 +1530,7 @@ testServiceNotificationsTwoRestarts =
Resp "3.2" _ (SOK Nothing) <- signSendRecv rh rKey ("3.2", rId, SUB)
deliverMessage rh rId rKey sh sId sKey nh "hello 3" dec
where
runTest2 :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO a) -> ThreadId -> IO a
runTest2 :: (HasTestEnv, Transport c) => TProxy c 'TServer -> (THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO a) -> ThreadId -> IO a
runTest2 _ test' server = do
a <- testSMPClient $ \h1 -> testSMPClient $ \h2 -> test' h1 h2
killThread server
@@ -1577,7 +1568,7 @@ testMsgExpireOnInterval =
it "should expire messages that are not received before messageTTL after expiry interval" $ \(ATransport (t :: TProxy c 'TServer), msType) -> do
g <- C.newRandom
(sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
let cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}, idleQueueInterval = 1}
let cfg' = updateCfg (cfgMS msType) $ \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
@@ -1630,7 +1621,7 @@ testBlockMessageQueue =
Resp "dabc" sId2 (ERR (BLOCKED (BlockingInfo BRContent Nothing))) <- signSendRecv h sKey ("dabc", sId, SKEY sPub)
(sId2, sId) #== "same queue ID in response"
where
runTest :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO a) -> ThreadId -> IO a
runTest :: (HasTestEnv, Transport c) => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO a) -> ThreadId -> IO a
runTest _ test' server = do
a <- testSMPClient test'
killThread server
@@ -1858,7 +1849,7 @@ serverSyntaxTests (ATransport t) = do
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 =>
(HasTestEnv, Encoding smp) =>
(Maybe TAuthorizations, ByteString, ByteString, smp) ->
(Maybe TAuthorizations, ByteString, ByteString, BrokerMsg) ->
Expectation
tests/Test.hs
+111 -110
View File
@@ -1,11 +1,10 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeApplications #-}
import AgentTests (agentCoreTests, agentTests)
import AgentTests.FunctionalAPITests (functionalAPITimingTests)
import CLITests
import Control.Concurrent (threadDelay)
import qualified Control.Exception as E
import Control.Exception (bracket_)
import Control.Logger.Simple
import CoreTests.BatchingTests
import CoreTests.CryptoFileTests
@@ -19,20 +18,19 @@ import CoreTests.TSessionSubs
import CoreTests.UtilTests
import CoreTests.VersionRangeTests
import FileDescriptionTests (fileDescriptionTests)
import GHC.IO.Exception (IOException (..))
import qualified GHC.IO.Exception as IOException
import RSLVTests (rslvTests)
import RemoteControl (remoteControlTests)
import SMPNamesTests (smpNamesTests)
import SMPProxyTests (smpProxyTests)
import SMPProxyTests (smpProxyCapabilityTests, smpProxyTests)
import ServerTests
import Simplex.Messaging.Server.Env.STM (AStoreType (..))
import Simplex.Messaging.Server.MsgStore.Types (SMSType (..), SQSType (..))
import Simplex.Messaging.Transport (TLS, Transport (..))
-- import Simplex.Messaging.Transport.WebSockets (WS)
import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive)
import System.Environment (setEnv)
import System.Directory (createDirectory, removePathForcibly)
import System.Environment (getArgs, setEnv, withArgs)
import Test.Hspec hiding (fit, it)
import Test.Hspec.Core.Runner (defaultConfig, evalSpec, evaluateResult, readConfig, runSpecForest)
import Util
import XFTPAgent
import XFTPCLI (xftpCLIFileTests)
@@ -44,18 +42,18 @@ import XFTPWebTests (xftpWebTests)
#if defined(dbPostgres)
import Fixtures
import SMPAgentClient (testDB)
import Simplex.Messaging.Agent.Store.Postgres.Migrations.App
import Simplex.Messaging.Agent.Store.Postgres.Util (dropAllSchemasExceptSystem)
#else
import AgentTests.SchemaDump (schemaDumpTest)
import System.Directory (listDirectory)
import System.FilePath ((</>))
#endif
#if defined(dbServerPostgres)
import CoreTests.XFTPStoreTests (xftpStoreTests, xftpMigrationTests)
import NtfServerTests (ntfServerTests)
import NtfClient (ntfTestServerDBConnectInfo, ntfTestStoreDBOpts)
import SMPClient (testServerDBConnectInfo, testStoreDBOpts)
import NtfClient (ntfTestServerDBConnectInfo, ntfTestServerDBOpts)
import SMPClient (testServerDBConnectInfo, testServerDBOpts)
import Simplex.Messaging.Notifications.Server.Store.Migrations (ntfServerMigrations)
import Simplex.Messaging.Server.QueueStore.Postgres.Migrations (serverMigrations)
import XFTPClient (testXFTPDBConnectInfo)
@@ -75,132 +73,135 @@ main = do
withGlobalLogging logCfg $ do
setEnv "APNS_KEY_ID" "H82WD9K9AQ"
setEnv "APNS_KEY_FILE" "./tests/fixtures/AuthKey_H82WD9K9AQ.p8"
hspec
hspecInTmpDir
#if defined(dbPostgres)
. aroundAll_ (postgressBracket testDBConnectInfo)
#endif
. before_ (createDirectoryIfMissing False "tests/tmp")
. after_ (eventuallyRemove "tests/tmp" 3)
$ do
describe "Core tests" $ do
describe "Batching tests" batchingTests
describe "Encoding tests" encodingTests
describe "Version range" versionRangeTests
describe "Encryption tests" cryptoTests
describe "Encrypted files tests" cryptoFileTests
describe "Message store tests" msgStoreTests
describe "Retry interval tests" retryIntervalTests
describe "SOCKS settings tests" socksSettingsTests
#if defined(dbServerPostgres)
around_ (postgressBracket testServerDBConnectInfo) $
describe "Store log tests" storeLogTests
#else
describe "Store log tests" storeLogTests
. aroundAll_ (postgressBracket testServerDBConnectInfo)
. aroundAll_ (postgressBracket ntfTestServerDBConnectInfo)
. aroundAll_ (postgressBracket testXFTPDBConnectInfo)
#endif
describe "XFTP store log tests" fileStoreLogTests
fileExpirationTests
describe "TSessionSubs tests" tSessionSubsTests
describe "Util tests" utilTests
describe "Names resolver tests" smpNamesTests
describe "RSLV functional API tests" rslvTests
describe "Agent core tests" agentCoreTests
$ do
parallel $ do
describe "Core tests" $ do
describe "Batching tests" batchingTests
describe "Encoding tests" encodingTests
describe "Version range" versionRangeTests
describe "Encryption tests" cryptoTests
describe "Encrypted files tests" cryptoFileTests
describe "Message store tests" msgStoreTests
describe "SOCKS settings tests" socksSettingsTests
describe "Store log tests" storeLogTests
describe "XFTP store log tests" fileStoreLogTests
fileExpirationTests
describe "TSessionSubs tests" tSessionSubsTests
describe "Util tests" utilTests
describe "Names resolver tests" smpNamesTests
describe "RSLV functional API tests" rslvTests
describe "Agent core tests" agentCoreTests
#if defined(dbServerPostgres)
around_ (postgressBracket testServerDBConnectInfo) $
describe "SMP server schema dump" $
postgresSchemaDumpTest
serverMigrations
[ "20250320_short_links", -- snd_secure moves to the bottom on down migration
"20260918_expire_messages" -- msg_queue_expire moves to the bottom on down migration
] -- skipComparisonForDownMigrations
testStoreDBOpts
"src/Simplex/Messaging/Server/QueueStore/Postgres/server_schema.sql"
around_ (postgressBracket testServerDBConnectInfo) $ do
-- xdescribe "SMP server via TLS, postgres+jornal message store" $
-- before (pure (transport @TLS, ASType SQSPostgres SMSJournal)) serverTests
describe "SMP server via TLS, postgres-only message store" $
before (pure (transport @TLS, ASType SQSPostgres SMSPostgres)) serverTests
#endif
describe "SMP server via TLS, jornal message store" $ do
describe "SMP syntax" $ serverSyntaxTests (transport @TLS)
before (pure (transport @TLS, ASType SQSMemory SMSJournal)) serverTests
describe "SMP server via TLS, memory message store" $
before (pure (transport @TLS, ASType SQSMemory SMSMemory)) serverTests
-- xdescribe "SMP server via WebSockets" $ do
-- describe "SMP syntax" $ serverSyntaxTests (transport @WS)
-- before (pure (transport @WS, ASType SQSMemory SMSJournal)) serverTests
describe "SMP server via TLS, memory message store" $ do
describe "SMP syntax" $ serverSyntaxTests (transport @TLS)
before (pure (transport @TLS, ASType SQSMemory SMSMemory)) serverTests
-- xdescribe "SMP server via WebSockets" $ do
-- describe "SMP syntax" $ serverSyntaxTests (transport @WS)
-- before (pure (transport @WS, ASType SQSMemory SMSMemory)) serverTests
#if defined(dbServerPostgres)
around_ (postgressBracket ntfTestServerDBConnectInfo) $
describe "Ntf server schema dump" $
postgresSchemaDumpTest
ntfServerMigrations
[] -- skipComparisonForDownMigrations
ntfTestStoreDBOpts
"src/Simplex/Messaging/Notifications/Server/Store/ntf_server_schema.sql"
around_ (postgressBracket ntfTestServerDBConnectInfo) $ do
describe "Notifications server (SMP server: memory store)" $
ntfServerTests (transport @TLS, ASType SQSMemory SMSMemory)
around_ (postgressBracket testServerDBConnectInfo) $ do
-- xdescribe "Notifications server (SMP server: postgres+jornal store)" $
-- ntfServerTests (transport @TLS, ASType SQSPostgres SMSJournal)
describe "Notifications server (SMP server: postgres-only store)" $
ntfServerTests (transport @TLS, ASType SQSPostgres SMSPostgres)
around_ (postgressBracket testServerDBConnectInfo) $ do
-- xdescribe "SMP client agent, postgres+jornal message store" $ agentTests (transport @TLS, ASType SQSPostgres SMSJournal)
describe "Notifications server (SMP server: postgres-only store)" $
ntfServerTests (transport @TLS, ASType SQSPostgres SMSPostgres)
describe "SMP client agent, server postgres-only message store" $ agentTests (transport @TLS, ASType SQSPostgres SMSPostgres)
-- xdescribe "SMP proxy, postgres+jornal message store" $
-- before (pure $ ASType SQSPostgres SMSJournal) smpProxyTests
describe "SMP proxy, postgres-only message store" $
before (pure $ ASType SQSPostgres SMSPostgres) smpProxyTests
#endif
-- xdescribe "SMP client agent, server jornal message store" $ agentTests (transport @TLS, ASType SQSMemory SMSJournal)
describe "SMP client agent, server memory message store" $ agentTests (transport @TLS, ASType SQSMemory SMSMemory)
describe "SMP proxy, jornal message store" $
before (pure $ ASType SQSMemory SMSJournal) smpProxyTests
describe "XFTP" $ do
describe "XFTP server" $
before (pure $ AFSType SFSMemory) xftpServerTests
describe "XFTP file description" fileDescriptionTests
describe "XFTP CLI (memory)" $
before (pure $ AFSType SFSMemory) xftpCLIFileTests
describe "XFTP agent" $
before (pure $ AFSType SFSMemory) xftpAgentTests
describe "SMP client agent, server memory message store" $ agentTests (transport @TLS, ASType SQSMemory SMSMemory)
describe "SMP proxy, memory message store" $
before (pure $ ASType SQSMemory SMSMemory) smpProxyTests
describe "XFTP" $ do
describe "XFTP server" $
before (pure $ AFSType SFSMemory) xftpServerTests
describe "XFTP file description" fileDescriptionTests
describe "XFTP agent" $
before (pure $ AFSType SFSMemory) xftpAgentTests
#if defined(dbServerPostgres)
around_ (postgressBracket testXFTPDBConnectInfo) $ do
describe "XFTP Postgres store operations" xftpStoreTests
describe "XFTP migration round-trip" xftpMigrationTests
describe "XFTP server (PostgreSQL)" $
before (pure $ AFSType SFSPostgres) xftpServerTests
describe "XFTP agent (PostgreSQL)" $
before (pure $ AFSType SFSPostgres) xftpAgentTests
#endif
describe "XFTP Web Client" xftpWebTests
describe "XRCP" remoteControlTests
describe "Web" webTests
sequential $ do
describe "Core tests" $ describe "Retry interval tests" retryIntervalTests
#if defined(dbServerPostgres)
describe "SMP server via TLS, postgres-only message store" $
before (pure (transport @TLS, ASType SQSPostgres SMSPostgres)) $ describe "Timing of AUTH error" testTiming
#endif
describe "SMP server via TLS, memory message store" $
before (pure (transport @TLS, ASType SQSMemory SMSMemory)) $ describe "Timing of AUTH error" testTiming
#if defined(dbServerPostgres)
describe "SMP client agent, server postgres-only message store" $
describe "Functional API" $ functionalAPITimingTests (transport @TLS, ASType SQSPostgres SMSPostgres)
#endif
describe "SMP client agent, server memory message store" $
describe "Functional API" $ functionalAPITimingTests (transport @TLS, ASType SQSMemory SMSMemory)
#if defined(dbServerPostgres)
describe "SMP proxy capabilities, postgres-only message store" $
before (pure $ ASType SQSPostgres SMSPostgres) smpProxyCapabilityTests
#endif
describe "SMP proxy capabilities, memory message store" $
before (pure $ ASType SQSMemory SMSMemory) smpProxyCapabilityTests
describe "XFTP CLI (memory)" $
before (pure $ AFSType SFSMemory) xftpCLIFileTests
#if defined(dbServerPostgres)
describe "XFTP CLI (PostgreSQL)" $
before (pure $ AFSType SFSPostgres) xftpCLIFileTests
#endif
#if defined(dbPostgres)
describe "XFTP Web Client" $ xftpWebTests (dropAllSchemasExceptSystem testDBConnectInfo)
#else
describe "XFTP Web Client" $ xftpWebTests (pure ())
describe "Server CLIs" cliTests
#if defined(dbServerPostgres)
around_ (postgressBracket testServerDBConnectInfo) $
describe "SMP server schema dump" $
postgresSchemaDumpTest
serverMigrations
[ "20250320_short_links", -- snd_secure moves to the bottom on down migration
"20260918_expire_messages" -- msg_queue_expire moves to the bottom on down migration
] -- skipComparisonForDownMigrations
testServerDBOpts
"src/Simplex/Messaging/Server/QueueStore/Postgres/server_schema.sql"
around_ (postgressBracket ntfTestServerDBConnectInfo) $
describe "Ntf server schema dump" $
postgresSchemaDumpTest
ntfServerMigrations
[] -- skipComparisonForDownMigrations
ntfTestServerDBOpts
"src/Simplex/Messaging/Notifications/Server/Store/ntf_server_schema.sql"
#endif
describe "XRCP" remoteControlTests
describe "Web" webTests
describe "Server CLIs" cliTests
#if defined(dbPostgres)
around_ (postgressBracket testDBConnectInfo) $
describe "Agent PostgreSQL schema dump" $
postgresSchemaDumpTest
appMigrations
["20250322_short_links"] -- snd_secure and last_broker_ts columns swap order on down migration
(testDBOpts testDB)
"src/Simplex/Messaging/Agent/Store/Postgres/Migrations/agent_postgres_schema.sql"
around_ (postgressBracket testDBConnectInfo) $
describe "Agent PostgreSQL schema dump" $
postgresSchemaDumpTest
appMigrations
["20250322_short_links"] -- snd_secure and last_broker_ts columns swap order on down migration
(testDBOpts "smp_agent_test_protocol_schema")
"src/Simplex/Messaging/Agent/Store/Postgres/Migrations/agent_postgres_schema.sql"
#else
describe "Agent SQLite schema dump" schemaDumpTest
after_ (listDirectory tmpDir >>= mapM_ (removeFileIfExists . (tmpDir </>))) $
describe "Agent SQLite schema dump" schemaDumpTest
#endif
eventuallyRemove :: FilePath -> Int -> IO ()
eventuallyRemove path retries = case retries of
0 -> action
n ->
action `E.catch` \ioe@IOError {ioe_type, ioe_filename} -> case ioe_type of
IOException.UnsatisfiedConstraints | ioe_filename == Just path -> threadDelay 1000000 >> eventuallyRemove path (n - 1)
_ -> E.throwIO ioe
where
action = removeDirectoryRecursive path
hspecInTmpDir :: Spec -> IO ()
hspecInTmpDir spec = do
(config, forest) <- evalSpec defaultConfig spec
config' <- getArgs >>= readConfig config
withTmpDir (withArgs [] $ runSpecForest forest config') >>= evaluateResult
withTmpDir :: IO a -> IO a
withTmpDir = bracket_ (removePathForcibly tmpDir >> createDirectory tmpDir) (eventuallyRemove tmpDir 3)
tests/Util.hs
+88 -9
View File
@@ -1,21 +1,33 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Util where
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Exception as E
import Control.Logger.Simple
import Control.Monad (replicateM, when)
import Data.Either (partitionEithers)
import Data.List (tails)
import Data.String (IsString (..))
import GHC.Conc (getNumCapabilities, getNumProcessors, setNumCapabilities)
import System.Directory (doesFileExist, removeFile)
import GHC.IO.Exception (IOException (..))
import qualified GHC.IO.Exception as IOException
import Network.Socket (ServiceName)
import System.Directory (createDirectoryIfMissing, doesFileExist, removeDirectoryRecursive, removeFile)
import System.Environment (lookupEnv)
import System.FilePath ((</>))
import System.IO.Unsafe (unsafePerformIO)
import System.Process (callCommand)
import System.Timeout (timeout)
import Test.Hspec hiding (fit, it)
import Test.Hspec hiding (fit, it, xit)
import qualified Test.Hspec as Hspec
import Test.Hspec.Core.Spec (Example (..), Result (..), ResultStatus (..))
@@ -44,7 +56,70 @@ removeFileIfExists filePath = do
fileExists <- doesFileExist filePath
when fileExists $ removeFile filePath
newtype TestWrapper a = TestWrapper a
data TestEnv = TestEnv
{ testNo :: Int,
portBase :: Int
}
type HasTestEnv = (?testEnv :: TestEnv)
tmpDir :: FilePath
tmpDir = "tests/tmp"
testDir :: HasTestEnv => FilePath
testDir = tmpDir </> show (testNo ?testEnv)
testPath :: HasTestEnv => FilePath -> FilePath
testPath = (testDir </>)
testServerPort :: HasTestEnv => Int -> ServiceName
testServerPort offset = show (portBase ?testEnv + offset)
testSchemaName :: (HasTestEnv, IsString s) => String -> s
testSchemaName name = fromString $ "test" <> show (testNo ?testEnv) <> "_" <> name
senderFiles :: HasTestEnv => FilePath
senderFiles = testPath "xftp-sender-files"
recipientFiles :: HasTestEnv => FilePath
recipientFiles = testPath "xftp-recipient-files"
testCounter :: TVar Int
testCounter = unsafePerformIO $ newTVarIO 0
{-# NOINLINE testCounter #-}
portBases :: TVar [Int]
portBases = unsafePerformIO $ newTVarIO [10000, 10010 .. 19990]
{-# NOINLINE portBases #-}
withTestEnv :: (HasTestEnv => IO a) -> IO a
withTestEnv action =
bracket takePortBase releasePortBase $ \portBase -> do
testNo <- atomically $ stateTVar testCounter $ \n -> (n, n + 1)
let ?testEnv = TestEnv {testNo, portBase}
bracket_
(mapM_ (createDirectoryIfMissing True) [senderFiles, recipientFiles])
(eventuallyRemove testDir 3)
action
where
takePortBase =
atomically $
readTVar portBases >>= \case
b : bs -> b <$ writeTVar portBases bs
[] -> retry
releasePortBase b = atomically $ modifyTVar' portBases (<> [b])
eventuallyRemove :: FilePath -> Int -> IO ()
eventuallyRemove path retries = case retries of
0 -> action
n ->
action `E.catch` \ioe@IOError {ioe_type, ioe_filename} -> case ioe_type of
IOException.UnsatisfiedConstraints | ioe_filename == Just path -> threadDelay 1000000 >> eventuallyRemove path (n - 1)
_ -> E.throwIO ioe
where
action = removeDirectoryRecursive path
data TestWrapper a = TestWrapper (HasTestEnv => a)
-- TODO [ntfdb] running wiht LogWarn level shows potential issue "Queue count differs"
testLogLevel :: LogLevel
@@ -58,9 +133,10 @@ instance Example a => Example (TestWrapper a) where
where
tt = 300
runTest =
timeout (tt * 1000000) (evaluateExample action params hooks state) `finally` callCommand "sync" >>= \case
Just r -> pure r
Nothing -> throwIO $ userError $ "test timed out after " <> show tt <> " seconds"
withTestEnv $
timeout (tt * 1000000) (evaluateExample action params hooks state) `finally` callCommand "sync" >>= \case
Just r -> pure r
Nothing -> throwIO $ userError $ "test timed out after " <> show tt <> " seconds"
onTestFailure :: Bool -> ResultStatus -> IO Result
onTestFailure ci = \case
Failure loc_ reason | ci -> do
@@ -80,8 +156,11 @@ instance Example a => Example (TestWrapper a) where
envCI :: IO Bool
envCI = (Just "true" ==) <$> lookupEnv "CI"
it :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a)
it :: (HasCallStack, Example a) => String -> (HasTestEnv => a) -> SpecWith (Arg a)
it label action = Hspec.it label (TestWrapper action)
fit :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a)
fit = fmap focus . it
fit :: (HasCallStack, Example a) => String -> (HasTestEnv => a) -> SpecWith (Arg a)
fit label action = focus $ it label action
xit :: (HasCallStack, Example a) => String -> (HasTestEnv => a) -> SpecWith (Arg a)
xit label action = Hspec.xit label (TestWrapper action)
tests/XFTPAgent.hs
+52 -47
View File
@@ -48,34 +48,25 @@ import Simplex.Messaging.Crypto.Entitlement (Entitlement (..), MasterKey (..), s
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs)
import qualified Simplex.Messaging.Crypto.File as CF
import Simplex.Messaging.Encoding.String (StrEncoding (..))
import Simplex.Messaging.Protocol (BasicAuth, NetworkError (..), ProtoServerWithAuth (..), ProtocolServer (..), XFTPServerWithAuth)
import Simplex.Messaging.Protocol (BasicAuth, NetworkError (..), ProtoServerWithAuth (..), ProtocolServer (..), XFTPServer, XFTPServerWithAuth)
import Simplex.Messaging.Server.Expiration (ExpirationConfig (..))
import Simplex.Messaging.Server.Information (ServerPublicInfo)
import Simplex.Messaging.Transport (EntitlementConfig (..))
import Simplex.Messaging.Util (tshow)
import System.Directory (doesDirectoryExist, doesFileExist, getFileSize, listDirectory, removeFile)
import System.FilePath ((</>))
import Test.Hspec hiding (fit, it)
import Test.Hspec hiding (fit, it, xit)
import UnliftIO
import UnliftIO.Concurrent
import Util
import XFTPCLI
import XFTPClient
#if defined(dbPostgres)
import Fixtures
import Simplex.Messaging.Agent.Store.Postgres.Util (dropAllSchemasExceptSystem)
#endif
pattern SFDONE :: ValidFileDescription 'FSender -> [ValidFileDescription 'FRecipient] -> AEvent 'AESndFile
pattern SFDONE sndDescr rcvDescrs <- A.SFDONE sndDescr rcvDescrs _
xftpAgentTests :: SpecWith AFStoreType
xftpAgentTests =
around_ testBracket
#if defined(dbPostgres)
. after_ (dropAllSchemasExceptSystem testDBConnectInfo)
#endif
. describe "agent XFTP API" $ do
describe "agent XFTP API" $ do
it "should send and receive file" $ withXFTPServer testXFTPAgentSendReceive
-- uncomment CPP option slow_servers and run hpack to run this test
xit "should send and receive file with slow server responses" $ \_ ->
@@ -100,18 +91,21 @@ xftpAgentTests =
it "should request additional recipient IDs when number of recipients exceeds maximum per request" testXFTPAgentRequestAdditionalRecipientIDs
describe "XFTP server test via agent API" $ do
it "should pass without basic auth" $ \_ -> testXFTPServerTest Nothing (noAuthSrv testXFTPServer2) `shouldReturn` Right (Just (Right testServerInformation))
let srv1 = testXFTPServer2 {keyHash = "1234"}
let srv1 :: HasTestEnv => XFTPServer
srv1 = testXFTPServer2 {keyHash = "1234"}
it "should fail with incorrect fingerprint" $ \_ -> do
testXFTPServerTest Nothing (noAuthSrv srv1) `shouldReturn` Left (ProtocolTestFailure TSConnect $ BROKER (B.unpack $ strEncode srv1) $ NETWORK NEUnknownCAError)
describe "server with password" $ do
let auth = Just "abcd"
srv :: HasTestEnv => Maybe BasicAuth -> XFTPServerWithAuth
srv = ProtoServerWithAuth testXFTPServer2
authErr :: HasTestEnv => ProtocolTestFailure
authErr = ProtocolTestFailure TSCreateFile $ XFTP (B.unpack $ strEncode testXFTPServer2) AUTH
it "should pass with correct password" $ \_ -> testXFTPServerTest auth (srv auth) `shouldReturn` Right (Just (Right testServerInformation))
it "should fail without password" $ \_ -> testXFTPServerTest auth (srv Nothing) `shouldReturn` Left authErr
it "should fail with incorrect password" $ \_ -> testXFTPServerTest auth (srv $ Just "wrong") `shouldReturn` Left authErr
testXFTPServerTest :: HasCallStack => Maybe BasicAuth -> XFTPServerWithAuth -> IO (Either ProtocolTestFailure (Maybe (Either String ServerPublicInfo)))
testXFTPServerTest :: (HasCallStack, HasTestEnv) => Maybe BasicAuth -> XFTPServerWithAuth -> IO (Either ProtocolTestFailure (Maybe (Either String ServerPublicInfo)))
testXFTPServerTest newFileBasicAuth srv =
withXFTPServerCfg testXFTPServerConfig {newFileBasicAuth, xftpPort = xftpTestPort2, information = Just testServerInformation} $ \_ ->
-- initially passed server is not running
@@ -143,7 +137,7 @@ checkProgress (prev, expected) (progress, total) loop
| progress < total = loop progress
| otherwise = pure ()
testXFTPAgentSendReceive :: HasCallStack => IO ()
testXFTPAgentSendReceive :: (HasCallStack, HasTestEnv) => IO ()
testXFTPAgentSendReceive = do
filePath <- createRandomFile
-- send file, delete snd file internally
@@ -160,7 +154,7 @@ testXFTPAgentSendReceive = do
rfId <- runRight $ testReceive rcp rfd originalFilePath
xftpDeleteRcvFile rcp rfId
testXFTPAgentSendReceiveEncrypted :: HasCallStack => AFStoreType -> IO ()
testXFTPAgentSendReceiveEncrypted :: (HasCallStack, HasTestEnv) => AFStoreType -> IO ()
testXFTPAgentSendReceiveEncrypted = withXFTPServer $ do
g <- C.newRandom
filePath <- createRandomFile
@@ -181,13 +175,14 @@ testXFTPAgentSendReceiveEncrypted = withXFTPServer $ do
rfId <- runRight $ testReceiveCF rcp rfd cfArgs originalFilePath
xftpDeleteRcvFile rcp rfId
testXFTPAgentSendReceiveRedirect :: HasCallStack => AFStoreType -> IO ()
testXFTPAgentSendReceiveRedirect :: (HasCallStack, HasTestEnv) => AFStoreType -> IO ()
testXFTPAgentSendReceiveRedirect = withXFTPServer $ do
--- sender
filePathIn <- createRandomFile
let fileSize = mb 17
totalSize = fileSize + mb 1
withAgent 1 agentCfg initAgentServers testDB $ \sndr -> do
runRight_ $ xftpStartWorkers sndr (Just senderFiles)
directFileId <- runRight $ xftpSendFile sndr 1 (CryptoFile filePathIn Nothing) 1
sfGet sndr `shouldReturn` ("", directFileId, SFPROG 4194304 totalSize)
sfGet sndr `shouldReturn` ("", directFileId, SFPROG 8388608 totalSize)
@@ -222,7 +217,7 @@ testXFTPAgentSendReceiveRedirect = withXFTPServer $ do
--- recipient
withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> do
FileDescriptionURI {description} <- either fail pure $ strDecode uri
runRight_ $ xftpStartWorkers rcp (Just recipientFiles)
rcvFileId <- runRight $ xftpReceiveFile rcp 1 description Nothing True
rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 65536 totalSize) -- extra RFPROG before switching to real file
rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 4194304 totalSize)
@@ -239,12 +234,13 @@ testXFTPAgentSendReceiveRedirect = withXFTPServer $ do
inBytes <- B.readFile filePathIn
B.readFile out `shouldReturn` inBytes
testXFTPAgentSendReceiveNoRedirect :: HasCallStack => AFStoreType -> IO ()
testXFTPAgentSendReceiveNoRedirect :: (HasCallStack, HasTestEnv) => AFStoreType -> IO ()
testXFTPAgentSendReceiveNoRedirect = withXFTPServer $ do
--- sender
let fileSize = mb 5
filePathIn <- createRandomFile_ fileSize "testfile"
withAgent 1 agentCfg initAgentServers testDB $ \sndr -> do
runRight_ $ xftpStartWorkers sndr (Just senderFiles)
directFileId <- runRight $ xftpSendFile sndr 1 (CryptoFile filePathIn Nothing) 1
let totalSize = fileSize + mb 1
sfGet sndr `shouldReturn` ("", directFileId, SFPROG 4194304 totalSize)
@@ -267,6 +263,7 @@ testXFTPAgentSendReceiveNoRedirect = withXFTPServer $ do
FileDescriptionURI {description} <- either fail pure $ strDecode uri
let ValidFileDescription FileDescription {redirect} = description
redirect `shouldBe` Nothing
runRight_ $ xftpStartWorkers rcp (Just recipientFiles)
rcvFileId <- runRight $ xftpReceiveFile rcp 1 description Nothing True
-- NO extra "RFPROG 65k 65k" before switching to real file
rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 4194304 totalSize)
@@ -280,7 +277,7 @@ testXFTPAgentSendReceiveNoRedirect = withXFTPServer $ do
inBytes <- B.readFile filePathIn
B.readFile out `shouldReturn` inBytes
testXFTPAgentPrepareReceive :: HasCallStack => AFStoreType -> IO ()
testXFTPAgentPrepareReceive :: (HasCallStack, HasTestEnv) => AFStoreType -> IO ()
testXFTPAgentPrepareReceive = withXFTPServer $ do
filePath <- createRandomFile
(_, _, rfd1, rfd2) <- withAgent 1 agentCfg initAgentServers testDB $ \sndr -> runRight $ testSend sndr filePath
@@ -305,7 +302,7 @@ testXFTPAgentPrepareReceive = withXFTPServer $ do
file <- B.readFile filePath
B.readFile path `shouldReturn` file
testXFTPAgentPrepareSend :: HasCallStack => AFStoreType -> IO ()
testXFTPAgentPrepareSend :: (HasCallStack, HasTestEnv) => AFStoreType -> IO ()
testXFTPAgentPrepareSend = withXFTPServer $ do
filePath1 <- createRandomFile' "testfile1"
filePath2 <- createRandomFile' "testfile2"
@@ -343,11 +340,12 @@ testXFTPAgentSendReceiveMatrix = do
it "old sender, new recipient" $ run newServer oldClient newClient
it "old clients" $ run newServer oldClient oldClient
where
oldClient, newClient :: HasTestEnv => AgentConfig
oldClient = agentCfg {xftpCfg = (xftpCfg agentCfg) {clientALPN = Nothing}}
newClient = agentCfg
oldServer = withXFTPServerCfgNoALPN
newServer = withXFTPServerCfg
run :: HasCallStack => (HasCallStack => XFTPServerConfig STMFileStore -> (ThreadId -> IO ()) -> IO ()) -> AgentConfig -> AgentConfig -> IO ()
run :: (HasCallStack, HasTestEnv) => (HasCallStack => XFTPServerConfig STMFileStore -> (ThreadId -> IO ()) -> IO ()) -> AgentConfig -> AgentConfig -> IO ()
run withServer sender receiver =
withServer testXFTPServerConfig $ \_t -> do
filePath <- createRandomFile_ (kb 319 :: Integer) "testfile"
@@ -355,29 +353,30 @@ testXFTPAgentSendReceiveMatrix = do
(sfId, _, rfd1, _) <- runRight $ testSendCF' sndr (CF.plain filePath) (kb 320)
rfd1 <$ xftpDeleteSndFileInternal sndr sfId
withAgent 2 receiver initAgentServers testDB2 $ \rcp -> do
runRight_ $ xftpStartWorkers rcp (Just recipientFiles)
rfId <- runRight $ testReceiveCF' rcp rfd Nothing filePath (kb 320)
xftpDeleteRcvFile rcp rfId
createRandomFile :: HasCallStack => IO FilePath
createRandomFile :: (HasCallStack, HasTestEnv) => IO FilePath
createRandomFile = createRandomFile' "testfile"
createRandomFile' :: HasCallStack => FilePath -> IO FilePath
createRandomFile' :: (HasCallStack, HasTestEnv) => FilePath -> IO FilePath
createRandomFile' = createRandomFile_ (mb 17 :: Integer)
createRandomFile_ :: (HasCallStack, Integral s, Show s) => s -> FilePath -> IO FilePath
createRandomFile_ :: (HasCallStack, HasTestEnv, Integral s) => s -> FilePath -> IO FilePath
createRandomFile_ size fileName = do
let filePath = senderFiles </> fileName
xftpCLI ["rand", filePath, show size] `shouldReturn` ["File created: " <> filePath]
B.writeFile filePath =<< atomically . C.randomBytes (fromIntegral size) =<< C.newRandom
getFileSize filePath `shouldReturn` toInteger size
pure filePath
testSend :: HasCallStack => AgentClient -> FilePath -> ExceptT AgentErrorType IO (SndFileId, ValidFileDescription 'FSender, ValidFileDescription 'FRecipient, ValidFileDescription 'FRecipient)
testSend :: (HasCallStack, HasTestEnv) => AgentClient -> FilePath -> ExceptT AgentErrorType IO (SndFileId, ValidFileDescription 'FSender, ValidFileDescription 'FRecipient, ValidFileDescription 'FRecipient)
testSend sndr = testSendCF sndr . CF.plain
testSendCF :: HasCallStack => AgentClient -> CryptoFile -> ExceptT AgentErrorType IO (SndFileId, ValidFileDescription 'FSender, ValidFileDescription 'FRecipient, ValidFileDescription 'FRecipient)
testSendCF :: (HasCallStack, HasTestEnv) => AgentClient -> CryptoFile -> ExceptT AgentErrorType IO (SndFileId, ValidFileDescription 'FSender, ValidFileDescription 'FRecipient, ValidFileDescription 'FRecipient)
testSendCF sndr file = testSendCF' sndr file $ mb 18
testSendCF' :: HasCallStack => AgentClient -> CryptoFile -> Int64 -> ExceptT AgentErrorType IO (SndFileId, ValidFileDescription 'FSender, ValidFileDescription 'FRecipient, ValidFileDescription 'FRecipient)
testSendCF' :: (HasCallStack, HasTestEnv) => AgentClient -> CryptoFile -> Int64 -> ExceptT AgentErrorType IO (SndFileId, ValidFileDescription 'FSender, ValidFileDescription 'FRecipient, ValidFileDescription 'FRecipient)
testSendCF' sndr file size = do
xftpStartWorkers sndr (Just senderFiles)
sfId <- xftpSendFile sndr 1 file 2
@@ -392,7 +391,7 @@ testNoRedundancy :: HasCallStack => ValidFileDescription 'FRecipient -> IO ()
testNoRedundancy (ValidFileDescription FileDescription {chunks}) =
all (\FileChunk {replicas} -> length replicas == 1) chunks `shouldBe` True
testXFTPAgentEntitlement :: HasCallStack => IO ()
testXFTPAgentEntitlement :: (HasCallStack, HasTestEnv) => IO ()
testXFTPAgentEntitlement = do
Right (issuerPk, issuerSk) <- bbsKeyGen
now <- getCurrentTime
@@ -429,10 +428,10 @@ testXFTPAgentEntitlement = do
("", _, SFPROG _ _) -> waitSndDone sndr
r -> error $ "Expected SFDONE, got " <> show r
testReceive :: HasCallStack => AgentClient -> ValidFileDescription 'FRecipient -> FilePath -> ExceptT AgentErrorType IO RcvFileId
testReceive :: (HasCallStack, HasTestEnv) => AgentClient -> ValidFileDescription 'FRecipient -> FilePath -> ExceptT AgentErrorType IO RcvFileId
testReceive rcp rfd = testReceiveCF rcp rfd Nothing
testReceiveCF :: HasCallStack => AgentClient -> ValidFileDescription 'FRecipient -> Maybe CryptoFileArgs -> FilePath -> ExceptT AgentErrorType IO RcvFileId
testReceiveCF :: (HasCallStack, HasTestEnv) => AgentClient -> ValidFileDescription 'FRecipient -> Maybe CryptoFileArgs -> FilePath -> ExceptT AgentErrorType IO RcvFileId
testReceiveCF rcp rfd cfArgs originalFilePath = do
xftpStartWorkers rcp (Just recipientFiles)
testReceiveCF' rcp rfd cfArgs originalFilePath $ mb 18
@@ -454,7 +453,7 @@ testReceiveCF' rcp rfd cfArgs originalFilePath size = do
logCfgNoLogs :: LogConfig
logCfgNoLogs = LogConfig {lc_file = Nothing, lc_stderr = False}
testXFTPAgentReceiveRestore :: HasCallStack => IO ()
testXFTPAgentReceiveRestore :: (HasCallStack, HasTestEnv) => IO ()
testXFTPAgentReceiveRestore = do
filePath <- createRandomFile
@@ -498,7 +497,7 @@ testXFTPAgentReceiveRestore = do
-- tmp path should be removed after receiving file
doesDirectoryExist tmpPath `shouldReturn` False
testXFTPAgentReceiveCleanup :: HasCallStack => IO ()
testXFTPAgentReceiveCleanup :: (HasCallStack, HasTestEnv) => IO ()
testXFTPAgentReceiveCleanup = withGlobalLogging logCfgNoLogs $ do
filePath <- createRandomFile
@@ -523,13 +522,14 @@ testXFTPAgentReceiveCleanup = withGlobalLogging logCfgNoLogs $ do
-- receive file - should fail with AUTH error
withAgent 3 agentCfg initAgentServers testDB2 $ \rcp' -> do
runRight_ $ xftpStartWorkers rcp' (Just recipientFiles)
("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <- rfGet rcp'
("", rfId', RFERR (XFTP srv AUTH)) <- rfGet rcp'
rfId' `shouldBe` rfId
srv `shouldBe` testXFTPServerStr
-- tmp path should be removed after permanent error
doesDirectoryExist tmpPath `shouldReturn` False
testXFTPAgentSendRestore :: HasCallStack => IO ()
testXFTPAgentSendRestore :: (HasCallStack, HasTestEnv) => IO ()
testXFTPAgentSendRestore = withGlobalLogging logCfgNoLogs $ do
filePath <- createRandomFile
@@ -576,7 +576,7 @@ testXFTPAgentSendRestore = withGlobalLogging logCfgNoLogs $ do
withAgent 4 agentCfg initAgentServers testDB2 $ \rcp ->
runRight_ . void $ testReceive rcp rfd1 filePath
testXFTPAgentSendCleanup :: HasCallStack => IO ()
testXFTPAgentSendCleanup :: (HasCallStack, HasTestEnv) => IO ()
testXFTPAgentSendCleanup = withGlobalLogging logCfgNoLogs $ do
filePath <- createRandomFile
@@ -602,15 +602,16 @@ testXFTPAgentSendCleanup = withGlobalLogging logCfgNoLogs $ do
-- send file - should fail with AUTH error
withAgent 2 agentCfg initAgentServers testDB $ \sndr' -> do
runRight_ $ xftpStartWorkers sndr' (Just senderFiles)
("", sfId', SFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <-
("", sfId', SFERR (XFTP srv AUTH)) <-
sfGet sndr'
sfId' `shouldBe` sfId
srv `shouldBe` testXFTPServerStr
-- prefix path should be removed after permanent error
doesDirectoryExist prefixPath `shouldReturn` False
doesFileExist encPath `shouldReturn` False
testXFTPAgentDelete :: HasCallStack => AFStoreType -> IO ()
testXFTPAgentDelete :: (HasCallStack, HasTestEnv) => AFStoreType -> IO ()
testXFTPAgentDelete = withGlobalLogging logCfgNoLogs . withXFTPServer test
where
test = do
@@ -639,11 +640,12 @@ testXFTPAgentDelete = withGlobalLogging logCfgNoLogs . withXFTPServer test
withAgent 3 agentCfg initAgentServers testDB2 $ \rcp2 -> runRight $ do
xftpStartWorkers rcp2 (Just recipientFiles)
rfId <- xftpReceiveFile rcp2 1 rfd2 Nothing True
("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <-
("", rfId', RFERR (XFTP srv AUTH)) <-
rfGet rcp2
liftIO $ rfId' `shouldBe` rfId
liftIO $ srv `shouldBe` testXFTPServerStr
testXFTPAgentDeleteRestore :: HasCallStack => IO ()
testXFTPAgentDeleteRestore :: (HasCallStack, HasTestEnv) => IO ()
testXFTPAgentDeleteRestore = withGlobalLogging logCfgNoLogs $ do
filePath <- createRandomFile
@@ -677,11 +679,12 @@ testXFTPAgentDeleteRestore = withGlobalLogging logCfgNoLogs $ do
withAgent 5 agentCfg initAgentServers testDB3 $ \rcp2 -> runRight $ do
xftpStartWorkers rcp2 (Just recipientFiles)
rfId <- xftpReceiveFile rcp2 1 rfd2 Nothing True
("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <-
("", rfId', RFERR (XFTP srv AUTH)) <-
rfGet rcp2
liftIO $ rfId' `shouldBe` rfId
liftIO $ srv `shouldBe` testXFTPServerStr
testXFTPAgentDeleteOnServer :: HasCallStack => AFStoreType -> IO ()
testXFTPAgentDeleteOnServer :: (HasCallStack, HasTestEnv) => AFStoreType -> IO ()
testXFTPAgentDeleteOnServer = withGlobalLogging logCfgNoLogs . withXFTPServer test
where
test = do
@@ -713,14 +716,15 @@ testXFTPAgentDeleteOnServer = withGlobalLogging logCfgNoLogs . withXFTPServer te
runRight_ . void $ do
-- receive file 1 again
rfId1 <- xftpReceiveFile rcp 1 rfd1_2 Nothing True
("", rfId1', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <-
("", rfId1', RFERR (XFTP srv AUTH)) <-
rfGet rcp
liftIO $ rfId1 `shouldBe` rfId1'
liftIO $ srv `shouldBe` testXFTPServerStr
-- receive file 2
testReceive' rcp rfd2 filePath2
testXFTPAgentExpiredOnServer :: HasCallStack => AFStoreType -> IO ()
testXFTPAgentExpiredOnServer :: (HasCallStack, HasTestEnv) => AFStoreType -> IO ()
testXFTPAgentExpiredOnServer fsType = withGlobalLogging logCfgNoLogs $
withXFTPServerConfigOn (updateXFTPCfg (cfgFS fsType) $ \c -> c {fileExpiration = fastExpiration}) . const $ do
filePath1 <- createRandomFile' "testfile1"
@@ -745,9 +749,10 @@ testXFTPAgentExpiredOnServer fsType = withGlobalLogging logCfgNoLogs $
-- receive file 1 again - should fail with AUTH error
runRight $ do
rfId <- xftpReceiveFile rcp 1 rfd1_2 Nothing True
("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <-
("", rfId', RFERR (XFTP srv AUTH)) <-
rfGet rcp
liftIO $ rfId' `shouldBe` rfId
liftIO $ srv `shouldBe` testXFTPServerStr
-- create and send file 2
filePath2 <- createRandomFile' "testfile2"
@@ -760,7 +765,7 @@ testXFTPAgentExpiredOnServer fsType = withGlobalLogging logCfgNoLogs $
where
fastExpiration = ExpirationConfig {ttl = 2, checkInterval = 1}
testXFTPAgentRequestAdditionalRecipientIDs :: HasCallStack => AFStoreType -> IO ()
testXFTPAgentRequestAdditionalRecipientIDs :: (HasCallStack, HasTestEnv) => AFStoreType -> IO ()
testXFTPAgentRequestAdditionalRecipientIDs = withXFTPServer $ do
filePath <- createRandomFile
tests/XFTPCLI.hs
+17 -31
View File
@@ -1,6 +1,6 @@
module XFTPCLI (xftpCLIFileTests, xftpCLI, senderFiles, recipientFiles, testBracket) where
module XFTPCLI (xftpCLIFileTests, xftpCLI) where
import Control.Exception (bracket_, try)
import Control.Exception (try)
import qualified Data.ByteString as LB
import Data.List (isInfixOf, isPrefixOf, isSuffixOf)
import Simplex.FileTransfer.Client.Main
@@ -10,7 +10,7 @@ import Simplex.FileTransfer.Client.Main
)
import Simplex.FileTransfer.Description (kb, mb)
import Simplex.FileTransfer.Util (safeFileNameStr, uniqueCombine)
import System.Directory (createDirectoryIfMissing, getFileSize, listDirectory, removeDirectoryRecursive)
import System.Directory (getFileSize, listDirectory)
import System.Environment (withArgs)
import System.Exit (ExitCode (ExitSuccess))
import System.FilePath (takeFileName, (</>))
@@ -21,7 +21,7 @@ import Simplex.FileTransfer.Server.Env (AFStoreType)
import XFTPClient (cfgFS, cfgFS2, withXFTPServer, withXFTPServerConfigOn, testXFTPServerStr, testXFTPServerStr2, xftpServerFiles, xftpServerFiles2)
xftpCLIFileTests :: SpecWith AFStoreType
xftpCLIFileTests = around_ testBracket $ do
xftpCLIFileTests = do
it "shows experimental deprecation notice in help" $ \_ ->
testXFTPCLIHelpDeprecationNotice
it "should send and receive file" $ withXFTPServer testXFTPCLISendReceive_
@@ -43,20 +43,6 @@ xftpCLIFileTests = around_ testBracket $ do
sanitized n = let n' = safeFileNameStr n in n' /= "" && n' /= "." && n' /= ".."
bareName n = let n' = safeFileNameStr n in n' == takeFileName n'
testBracket :: IO () -> IO ()
testBracket =
bracket_
(mapM_ (createDirectoryIfMissing False) testDirs)
(mapM_ removeDirectoryRecursive testDirs)
where
testDirs = [xftpServerFiles, xftpServerFiles2, senderFiles, recipientFiles]
senderFiles :: FilePath
senderFiles = "tests/tmp/xftp-sender-files"
recipientFiles :: FilePath
recipientFiles = "tests/tmp/xftp-recipient-files"
xftpCLI :: [String] -> IO [String]
xftpCLI params = lines <$> capture_ (withArgs params xftpClientCLI)
@@ -66,7 +52,7 @@ testXFTPCLIHelpDeprecationNotice = do
result `shouldBe` (Left ExitSuccess :: Either ExitCode ())
unwords (words output) `shouldSatisfy` (xftpClientDeprecationNotice `isInfixOf`)
testXFTPCLISendReceive_ :: IO ()
testXFTPCLISendReceive_ :: HasTestEnv => IO ()
testXFTPCLISendReceive_ = do
let filePath = senderFiles </> "testfile"
xftpCLI ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath]
@@ -75,7 +61,7 @@ testXFTPCLISendReceive_ = do
let fdRcv1 = filePath <> ".xftp" </> "rcv1.xftp"
fdRcv2 = filePath <> ".xftp" </> "rcv2.xftp"
fdSnd = filePath <> ".xftp" </> "snd.xftp.private"
progress : sendResult <- xftpCLI ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr, "--tmp=tests/tmp"]
progress : sendResult <- xftpCLI ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr, "--tmp=" <> testDir]
progress `shouldSatisfy` uploadProgress
let (sendInfo, sendRest) = splitAt 4 sendResult
sendInfo
@@ -90,19 +76,19 @@ testXFTPCLISendReceive_ = do
testInfoFile fdRcv2 "Recipient"
testReceiveFile fdRcv2 "testfile_1" file
testInfoFile fdSnd "Sender"
xftpCLI ["recv", fdSnd, recipientFiles, "--tmp=tests/tmp"]
xftpCLI ["recv", fdSnd, recipientFiles, "--tmp=" <> testDir]
`shouldThrow` anyException
where
testInfoFile fd party = do
xftpCLI ["info", fd]
`shouldReturn` [party <> " file description", "File download size: 18mb", "File server(s):", testXFTPServerStr <> ": 18mb"]
testReceiveFile fd fileName file = do
progress : recvResult <- xftpCLI ["recv", fd, recipientFiles, "--tmp=tests/tmp", "-y"]
progress : recvResult <- xftpCLI ["recv", fd, recipientFiles, "--tmp=" <> testDir, "-y"]
progress `shouldSatisfy` downloadProgress fileName
recvResult `shouldBe` ["File description " <> fd <> " is deleted."]
LB.readFile (recipientFiles </> fileName) `shouldReturn` file
testXFTPCLISendReceive2servers_ :: IO ()
testXFTPCLISendReceive2servers_ :: HasTestEnv => IO ()
testXFTPCLISendReceive2servers_ = do
let filePath = senderFiles </> "testfile"
xftpCLI ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath]
@@ -111,7 +97,7 @@ testXFTPCLISendReceive2servers_ = do
let fdRcv1 = filePath <> ".xftp" </> "rcv1.xftp"
fdRcv2 = filePath <> ".xftp" </> "rcv2.xftp"
fdSnd = filePath <> ".xftp" </> "snd.xftp.private"
progress : sendResult <- xftpCLI ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr <> ";" <> testXFTPServerStr2, "--tmp=tests/tmp"]
progress : sendResult <- xftpCLI ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr <> ";" <> testXFTPServerStr2, "--tmp=" <> testDir]
progress `shouldSatisfy` uploadProgress
let (sendInfo, sendRest) = splitAt 4 sendResult
sendInfo
@@ -135,12 +121,12 @@ testXFTPCLISendReceive2servers_ = do
srv1 `shouldContain` testXFTPServerStr
srv2 `shouldContain` testXFTPServerStr2
_ -> print srvs >> error "more than 2 servers returned"
progress : recvResult <- xftpCLI ["recv", fd, recipientFiles, "--tmp=tests/tmp", "-y"]
progress : recvResult <- xftpCLI ["recv", fd, recipientFiles, "--tmp=" <> testDir, "-y"]
progress `shouldSatisfy` downloadProgress fileName
recvResult `shouldBe` ["File description " <> fd <> " is deleted."]
LB.readFile (recipientFiles </> fileName) `shouldReturn` file
testXFTPCLIDelete_ :: IO ()
testXFTPCLIDelete_ :: HasTestEnv => IO ()
testXFTPCLIDelete_ = do
let filePath = senderFiles </> "testfile"
xftpCLI ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath]
@@ -149,7 +135,7 @@ testXFTPCLIDelete_ = do
let fdRcv1 = filePath <> ".xftp" </> "rcv1.xftp"
fdRcv2 = filePath <> ".xftp" </> "rcv2.xftp"
fdSnd = filePath <> ".xftp" </> "snd.xftp.private"
progress : sendResult <- xftpCLI ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr <> ";" <> testXFTPServerStr2, "--tmp=tests/tmp"]
progress : sendResult <- xftpCLI ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr <> ";" <> testXFTPServerStr2, "--tmp=" <> testDir]
progress `shouldSatisfy` uploadProgress
let (sendInfo, sendRest) = splitAt 4 sendResult
sendInfo
@@ -161,7 +147,7 @@ testXFTPCLIDelete_ = do
sendRest `shouldSatisfy` any ("https://" `isPrefixOf`)
xftpCLI ["del", fdRcv1]
`shouldThrow` anyException
progress1 : recvResult <- xftpCLI ["recv", fdRcv1, recipientFiles, "--tmp=tests/tmp", "-y"]
progress1 : recvResult <- xftpCLI ["recv", fdRcv1, recipientFiles, "--tmp=" <> testDir, "-y"]
progress1 `shouldSatisfy` downloadProgress "testfile"
recvResult `shouldBe` ["File description " <> fdRcv1 <> " is deleted."]
LB.readFile (recipientFiles </> "testfile") `shouldReturn` file
@@ -172,10 +158,10 @@ testXFTPCLIDelete_ = do
`shouldReturn` ["File deleted! \r", "File description " <> fdSnd <> " is deleted."]
listDirectory xftpServerFiles >>= (`shouldBe` [])
listDirectory xftpServerFiles2 >>= (`shouldBe` [])
xftpCLI ["recv", fdRcv2, recipientFiles, "--tmp=tests/tmp"]
xftpCLI ["recv", fdRcv2, recipientFiles, "--tmp=" <> testDir]
`shouldThrow` anyException
testReceivedFileNameCombine :: IO ()
testReceivedFileNameCombine :: HasTestEnv => IO ()
testReceivedFileNameCombine =
uniqueCombine recipientFiles "../../escaped.txt" `shouldReturn` (recipientFiles </> "escaped.txt")
@@ -202,7 +188,7 @@ uploadProgress s =
&& "Uploading file..." `isInfixOf` s
&& "File uploaded!" `isInfixOf` s
downloadProgress :: FilePath -> String -> Bool
downloadProgress :: HasTestEnv => FilePath -> String -> Bool
downloadProgress fileName s =
"Downloading file..." `isPrefixOf` s
&& "Decrypting file..." `isInfixOf` s
tests/XFTPClient.hs
+48 -45
View File
@@ -26,11 +26,14 @@ import Simplex.Messaging.Crypto.File (CryptoFile)
import Simplex.Messaging.Protocol (XFTPServer)
import Simplex.Messaging.Transport.HTTP2 (httpALPN)
import Simplex.Messaging.Transport.Server
import System.Directory (createDirectoryIfMissing)
import Test.Hspec hiding (fit, it)
import Util
#if defined(dbServerPostgres)
import Control.Monad (void)
import qualified Database.PostgreSQL.Simple as PSQL
import Database.PostgreSQL.Simple (ConnectInfo (..), defaultConnectInfo)
import Database.PostgreSQL.Simple.Types (Query (..))
import Simplex.FileTransfer.Server.Store.Postgres.Config (PostgresFileStoreCfg (..), defaultXFTPDBOpts)
import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..))
import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..))
@@ -44,7 +47,7 @@ data AXFTPServerConfig = forall s. FileStoreClass s => AXFTPSrvCfg (XFTPServerCo
updateXFTPCfg :: AXFTPServerConfig -> (forall s. XFTPServerConfig s -> XFTPServerConfig s) -> AXFTPServerConfig
updateXFTPCfg (AXFTPSrvCfg cfg) f = AXFTPSrvCfg (f cfg)
cfgFS :: AFStoreType -> AXFTPServerConfig
cfgFS :: HasTestEnv => AFStoreType -> AXFTPServerConfig
cfgFS (AFSType fs) = case fs of
SFSMemory -> AXFTPSrvCfg testXFTPServerConfig
#if defined(dbServerPostgres)
@@ -53,7 +56,7 @@ cfgFS (AFSType fs) = case fs of
SFSPostgres -> error "no postgres support"
#endif
cfgFS2 :: AFStoreType -> AXFTPServerConfig
cfgFS2 :: HasTestEnv => AFStoreType -> AXFTPServerConfig
cfgFS2 (AFSType fs) = case fs of
SFSMemory -> AXFTPSrvCfg testXFTPServerConfig2
#if defined(dbServerPostgres)
@@ -73,12 +76,12 @@ testXFTPDBConnectInfo =
connectDatabase = "test_xftp_server_db"
}
testXFTPPostgresCfg :: PostgresFileStoreCfg
testXFTPPostgresCfg :: HasTestEnv => PostgresFileStoreCfg
testXFTPPostgresCfg =
PostgresFileStoreCfg
{ dbOpts = defaultXFTPDBOpts
{ connstr = "postgresql://test_xftp_server_user@/test_xftp_server_db",
schema = "xftp_server_test",
schema = testSchemaName "xftp_server_test",
poolSize = 10,
createSchema = True
},
@@ -86,94 +89,94 @@ testXFTPPostgresCfg =
confirmMigrations = MCYesUp
}
clearXFTPPostgresStore :: IO ()
clearXFTPPostgresStore :: HasTestEnv => IO ()
clearXFTPPostgresStore = do
let DBOpts {connstr} = dbOpts testXFTPPostgresCfg
let DBOpts {connstr, schema} = dbOpts testXFTPPostgresCfg
conn <- PSQL.connectPostgreSQL connstr
void $ PSQL.execute_ conn "SET search_path TO xftp_server_test,public"
void $ PSQL.execute_ conn $ Query $ "SET search_path TO " <> schema <> ",public"
void $ PSQL.execute_ conn "DELETE FROM files"
PSQL.close conn
#endif
xftpTest :: HasCallStack => (HasCallStack => XFTPClient -> IO ()) -> AFStoreType -> Expectation
xftpTest :: (HasCallStack, HasTestEnv) => (HasCallStack => XFTPClient -> IO ()) -> AFStoreType -> Expectation
xftpTest test fsType = withXFTPServerConfigOn (cfgFS fsType) (\_ -> testXFTPClient test) `shouldReturn` ()
xftpTestN :: HasCallStack => Int -> (HasCallStack => [XFTPClient] -> IO ()) -> AFStoreType -> Expectation
xftpTestN :: (HasCallStack, HasTestEnv) => Int -> (HasCallStack => [XFTPClient] -> IO ()) -> AFStoreType -> Expectation
xftpTestN nClients test fsType = withXFTPServerConfigOn (cfgFS fsType) (\_ -> run nClients []) `shouldReturn` ()
where
run :: Int -> [XFTPClient] -> IO ()
run 0 hs = test hs
run n hs = testXFTPClient $ \h -> run (n - 1) (h : hs)
xftpTest2 :: HasCallStack => (HasCallStack => XFTPClient -> XFTPClient -> IO ()) -> AFStoreType -> Expectation
xftpTest2 :: (HasCallStack, HasTestEnv) => (HasCallStack => XFTPClient -> XFTPClient -> IO ()) -> AFStoreType -> Expectation
xftpTest2 test = xftpTestN 2 _test
where
_test [h1, h2] = test h1 h2
_test _ = error "expected 2 handles"
xftpTest4 :: HasCallStack => (HasCallStack => XFTPClient -> XFTPClient -> XFTPClient -> XFTPClient -> IO ()) -> AFStoreType -> Expectation
xftpTest4 :: (HasCallStack, HasTestEnv) => (HasCallStack => XFTPClient -> XFTPClient -> XFTPClient -> XFTPClient -> IO ()) -> AFStoreType -> Expectation
xftpTest4 test = xftpTestN 4 _test
where
_test [h1, h2, h3, h4] = test h1 h2 h3 h4
_test _ = error "expected 4 handles"
withXFTPServerStoreLogOn :: HasCallStack => (HasCallStack => ThreadId -> IO a) -> IO a
withXFTPServerStoreLogOn :: (HasCallStack, HasTestEnv) => (HasCallStack => ThreadId -> IO a) -> IO a
withXFTPServerStoreLogOn = withXFTPServerCfg testXFTPServerConfig {serverStoreCfg = XSCMemory (Just testXFTPLogFile), storeLogFile = Just testXFTPLogFile, serverStatsBackupFile = Just testXFTPStatsBackupFile}
withXFTPServerCfgNoALPN :: (HasCallStack, FileStoreClass s) => XFTPServerConfig s -> (HasCallStack => ThreadId -> IO a) -> IO a
withXFTPServerCfgNoALPN cfg = withXFTPServerCfg cfg {transportConfig = (transportConfig cfg) {serverALPN = Nothing}}
withXFTPServerCfg :: (HasCallStack, FileStoreClass s) => XFTPServerConfig s -> (HasCallStack => ThreadId -> IO a) -> IO a
withXFTPServerCfg cfg =
withXFTPServerCfg cfg@XFTPServerConfig {filesPath} =
serverBracket
(\started -> runXFTPServerBlocking started cfg)
(\started -> createDirectoryIfMissing True filesPath >> runXFTPServerBlocking started cfg)
(threadDelay 10000)
withXFTPServerThreadOn :: HasCallStack => (HasCallStack => ThreadId -> IO a) -> IO a
withXFTPServerThreadOn :: (HasCallStack, HasTestEnv) => (HasCallStack => ThreadId -> IO a) -> IO a
withXFTPServerThreadOn = withXFTPServerCfg testXFTPServerConfig
withXFTPServer :: HasCallStack => IO a -> AFStoreType -> IO a
withXFTPServer :: (HasCallStack, HasTestEnv) => IO a -> AFStoreType -> IO a
withXFTPServer test fsType = withXFTPServerConfigOn (cfgFS fsType) $ const test
withXFTPServer2 :: HasCallStack => IO a -> AFStoreType -> IO a
withXFTPServer2 :: (HasCallStack, HasTestEnv) => IO a -> AFStoreType -> IO a
withXFTPServer2 test fsType = withXFTPServerConfigOn (cfgFS2 fsType) $ const test
-- Constants
xftpTestPort :: ServiceName
xftpTestPort = "8000"
xftpTestPort :: HasTestEnv => ServiceName
xftpTestPort = testServerPort 6
xftpTestPort2 :: ServiceName
xftpTestPort2 = "8001"
xftpTestPort2 :: HasTestEnv => ServiceName
xftpTestPort2 = testServerPort 7
testXFTPServer :: XFTPServer
testXFTPServer :: HasTestEnv => XFTPServer
testXFTPServer = fromString testXFTPServerStr
testXFTPServer2 :: XFTPServer
testXFTPServer2 :: HasTestEnv => XFTPServer
testXFTPServer2 = fromString testXFTPServerStr2
testXFTPServerStr :: String
testXFTPServerStr = "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000"
testXFTPServerStr :: HasTestEnv => String
testXFTPServerStr = "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:" <> xftpTestPort
testXFTPServerStr2 :: String
testXFTPServerStr2 = "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8001"
testXFTPServerStr2 :: HasTestEnv => String
testXFTPServerStr2 = "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:" <> xftpTestPort2
xftpServerFiles :: FilePath
xftpServerFiles = "tests/tmp/xftp-server-files"
xftpServerFiles :: HasTestEnv => FilePath
xftpServerFiles = testPath "xftp-server-files"
xftpServerFiles2 :: FilePath
xftpServerFiles2 = "tests/tmp/xftp-server-files2"
xftpServerFiles2 :: HasTestEnv => FilePath
xftpServerFiles2 = testPath "xftp-server-files2"
testXFTPLogFile :: FilePath
testXFTPLogFile = "tests/tmp/xftp-server-store.log"
testXFTPLogFile :: HasTestEnv => FilePath
testXFTPLogFile = testPath "xftp-server-store.log"
testXFTPStatsBackupFile :: FilePath
testXFTPStatsBackupFile = "tests/tmp/xftp-server-stats.log"
testXFTPStatsBackupFile :: HasTestEnv => FilePath
testXFTPStatsBackupFile = testPath "xftp-server-stats.log"
xftpTestPrometheusMetricsFile :: FilePath
xftpTestPrometheusMetricsFile = "tests/tmp/xftp-server-metrics.txt"
xftpTestPrometheusMetricsFile :: HasTestEnv => FilePath
xftpTestPrometheusMetricsFile = testPath "xftp-server-metrics.txt"
testXFTPServerConfig :: XFTPServerConfig STMFileStore
testXFTPServerConfig :: HasTestEnv => XFTPServerConfig STMFileStore
testXFTPServerConfig =
XFTPServerConfig
{ xftpPort = xftpTestPort,
@@ -204,7 +207,7 @@ testXFTPServerConfig =
information = Nothing,
logStatsInterval = Nothing,
logStatsStartTime = 0,
serverStatsLogFile = "tests/tmp/xftp-server-stats.daily.log",
serverStatsLogFile = testPath "xftp-server-stats.daily.log",
serverStatsBackupFile = Nothing,
prometheusInterval = Nothing,
prometheusMetricsFile = xftpTestPrometheusMetricsFile,
@@ -213,23 +216,23 @@ testXFTPServerConfig =
webStaticPath = Nothing
}
testXFTPServerConfig2 :: XFTPServerConfig STMFileStore
testXFTPServerConfig2 :: HasTestEnv => XFTPServerConfig STMFileStore
testXFTPServerConfig2 = testXFTPServerConfig {xftpPort = xftpTestPort2, filesPath = xftpServerFiles2}
testXFTPClientConfig :: XFTPClientConfig
testXFTPClientConfig = defaultXFTPClientConfig
testXFTPClient :: HasCallStack => (HasCallStack => XFTPClient -> IO a) -> IO a
testXFTPClient :: (HasCallStack, HasTestEnv) => (HasCallStack => XFTPClient -> IO a) -> IO a
testXFTPClient = testXFTPClientWith testXFTPClientConfig
testXFTPClientWith :: HasCallStack => XFTPClientConfig -> (HasCallStack => XFTPClient -> IO a) -> IO a
testXFTPClientWith :: (HasCallStack, HasTestEnv) => XFTPClientConfig -> (HasCallStack => XFTPClient -> IO a) -> IO a
testXFTPClientWith cfg client = do
ts <- getCurrentTime
getXFTPClient (1, testXFTPServer, Nothing) cfg [] ts (\_ -> pure Nothing) (\_ -> pure ()) >>= \case
Right c -> client c
Left e -> error $ show e
testXFTPServerConfigSNI :: XFTPServerConfig STMFileStore
testXFTPServerConfigSNI :: HasTestEnv => XFTPServerConfig STMFileStore
testXFTPServerConfigSNI =
testXFTPServerConfig
{ httpCredentials =
@@ -245,10 +248,10 @@ testXFTPServerConfigSNI =
}
}
withXFTPServerSNI :: HasCallStack => (HasCallStack => ThreadId -> IO a) -> IO a
withXFTPServerSNI :: (HasCallStack, HasTestEnv) => (HasCallStack => ThreadId -> IO a) -> IO a
withXFTPServerSNI = withXFTPServerCfg testXFTPServerConfigSNI
testXFTPServerConfigEd25519SNI :: XFTPServerConfig STMFileStore
testXFTPServerConfigEd25519SNI :: HasTestEnv => XFTPServerConfig STMFileStore
testXFTPServerConfigEd25519SNI =
testXFTPServerConfig
{ xftpCredentials =
tests/XFTPServerTests.hs
+50 -51
View File
@@ -47,7 +47,7 @@ import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..))
import qualified Simplex.Messaging.Transport.HTTP2.Client as HC
import Simplex.Messaging.Transport.Server (loadFileFingerprint)
import Simplex.Messaging.Transport.Shared (ChainCertificates (..), chainIdCaCerts)
import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive, removeFile)
import System.Directory (removeFile)
import System.FilePath ((</>))
import Test.Hspec hiding (fit, it)
import UnliftIO.STM
@@ -55,8 +55,7 @@ import Util
import XFTPClient
xftpServerTests :: SpecWith AFStoreType
xftpServerTests =
before_ (createDirectoryIfMissing False xftpServerFiles) . after_ (removeDirectoryRecursive xftpServerFiles) $ do
xftpServerTests = do
describe "XFTP file chunk delivery" $ do
it "should create, upload and receive file chunk (1 client)" testFileChunkDelivery
it "should create, upload and receive file chunk (2 clients)" testFileChunkDelivery2
@@ -90,8 +89,8 @@ xftpServerTests =
chSize :: Integral a => a
chSize = kb 128
testChunkPath :: FilePath
testChunkPath = "tests/tmp/chunk1"
testChunkPath :: HasTestEnv => FilePath
testChunkPath = testPath "chunk1"
createTestChunk :: FilePath -> IO ByteString
createTestChunk fp = do
@@ -103,16 +102,16 @@ createTestChunk fp = do
createXFTPChunk :: XFTPClient -> C.APrivateAuthKey -> FileInfo -> NonEmpty C.APublicAuthKey -> Maybe BasicAuth -> ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId)
createXFTPChunk c spKey file rcps auth = (\(sId, rIds, _) -> (sId, rIds)) <$> A.createXFTPChunk c spKey file rcps auth Nothing
readChunk :: XFTPFileId -> IO ByteString
readChunk :: HasTestEnv => XFTPFileId -> IO ByteString
readChunk sId = B.readFile (xftpServerFiles </> B.unpack (B64.encode $ unEntityId sId))
testFileChunkDelivery :: AFStoreType -> Expectation
testFileChunkDelivery :: HasTestEnv => AFStoreType -> Expectation
testFileChunkDelivery = xftpTest $ \c -> runRight_ $ runTestFileChunkDelivery c c
testFileChunkDelivery2 :: AFStoreType -> Expectation
testFileChunkDelivery2 :: HasTestEnv => AFStoreType -> Expectation
testFileChunkDelivery2 = xftpTest2 $ \s r -> runRight_ $ runTestFileChunkDelivery s r
runTestFileChunkDelivery :: XFTPClient -> XFTPClient -> ExceptT XFTPClientError IO ()
runTestFileChunkDelivery :: HasTestEnv => XFTPClient -> XFTPClient -> ExceptT XFTPClientError IO ()
runTestFileChunkDelivery s r = do
g <- liftIO C.newRandom
(sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
@@ -127,12 +126,12 @@ runTestFileChunkDelivery s r = do
uploadXFTPChunk s spKey sId' chunkSpec
`catchError` (liftIO . (`shouldBe` PCEProtocolError DIGEST))
liftIO $ readChunk sId `shouldReturn` bytes
downloadXFTPChunk g r rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize (digest <> "_wrong"))
downloadXFTPChunk g r rpKey rId (XFTPRcvChunkSpec (testPath "received_chunk1") chSize (digest <> "_wrong"))
`catchError` (liftIO . (`shouldBe` PCEResponseError DIGEST))
downloadXFTPChunk g r rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes
downloadXFTPChunk g r rpKey rId $ XFTPRcvChunkSpec (testPath "received_chunk1") chSize digest
liftIO $ B.readFile (testPath "received_chunk1") `shouldReturn` bytes
testFileChunkDeliveryAddRecipients :: AFStoreType -> Expectation
testFileChunkDeliveryAddRecipients :: HasTestEnv => AFStoreType -> Expectation
testFileChunkDeliveryAddRecipients = xftpTest4 $ \s r1 r2 r3 -> runRight_ $ do
g <- liftIO C.newRandom
(sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
@@ -149,17 +148,17 @@ testFileChunkDeliveryAddRecipients = xftpTest4 $ \s r1 r2 r3 -> runRight_ $ do
let testReceiveChunk r rpKey rId fPath = do
downloadXFTPChunk g r rpKey rId $ XFTPRcvChunkSpec fPath chSize digest
liftIO $ B.readFile fPath `shouldReturn` bytes
testReceiveChunk r1 rpKey1 rId1 "tests/tmp/received_chunk1"
testReceiveChunk r2 rpKey2 rId2 "tests/tmp/received_chunk2"
testReceiveChunk r3 rpKey3 rId3 "tests/tmp/received_chunk3"
testReceiveChunk r1 rpKey1 rId1 (testPath "received_chunk1")
testReceiveChunk r2 rpKey2 rId2 (testPath "received_chunk2")
testReceiveChunk r3 rpKey3 rId3 (testPath "received_chunk3")
testFileChunkDelete :: AFStoreType -> Expectation
testFileChunkDelete :: HasTestEnv => AFStoreType -> Expectation
testFileChunkDelete = xftpTest $ \c -> runRight_ $ runTestFileChunkDelete c c
testFileChunkDelete2 :: AFStoreType -> Expectation
testFileChunkDelete2 :: HasTestEnv => AFStoreType -> Expectation
testFileChunkDelete2 = xftpTest2 $ \s r -> runRight_ $ runTestFileChunkDelete s r
runTestFileChunkDelete :: XFTPClient -> XFTPClient -> ExceptT XFTPClientError IO ()
runTestFileChunkDelete :: HasTestEnv => XFTPClient -> XFTPClient -> ExceptT XFTPClientError IO ()
runTestFileChunkDelete s r = do
g <- liftIO C.newRandom
(sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
@@ -171,18 +170,18 @@ runTestFileChunkDelete s r = do
(sId, [rId]) <- createXFTPChunk s spKey file [rcvKey] Nothing
uploadXFTPChunk s spKey sId chunkSpec
downloadXFTPChunk g r rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes
downloadXFTPChunk g r rpKey rId $ XFTPRcvChunkSpec (testPath "received_chunk1") chSize digest
liftIO $ B.readFile (testPath "received_chunk1") `shouldReturn` bytes
deleteXFTPChunk s spKey sId
liftIO $
readChunk sId
`shouldThrow` \(e :: SomeException) -> "does not exist" `isInfixOf` show e
downloadXFTPChunk g r rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk2" chSize digest)
downloadXFTPChunk g r rpKey rId (XFTPRcvChunkSpec (testPath "received_chunk2") chSize digest)
`catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
deleteXFTPChunk s spKey sId
`catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
testWrongChunkSize :: AFStoreType -> Expectation
testWrongChunkSize :: HasTestEnv => AFStoreType -> Expectation
testWrongChunkSize = xftpTest $ \c -> do
g <- C.newRandom
(sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
@@ -194,7 +193,7 @@ testWrongChunkSize = xftpTest $ \c -> do
void (createXFTPChunk c spKey file [rcvKey] Nothing)
`catchError` (liftIO . (`shouldBe` PCEProtocolError SIZE))
testFileChunkExpiration :: AFStoreType -> Expectation
testFileChunkExpiration :: HasTestEnv => AFStoreType -> Expectation
testFileChunkExpiration fsType = withXFTPServerConfigOn (updateXFTPCfg (cfgFS fsType) $ \c -> c {fileExpiration}) $
\_ -> testXFTPClient $ \c -> runRight_ $ do
g <- liftIO C.newRandom
@@ -207,18 +206,18 @@ testFileChunkExpiration fsType = withXFTPServerConfigOn (updateXFTPCfg (cfgFS fs
(sId, [rId]) <- createXFTPChunk c spKey file [rcvKey] Nothing
uploadXFTPChunk c spKey sId chunkSpec
downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes
downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec (testPath "received_chunk1") chSize digest
liftIO $ B.readFile (testPath "received_chunk1") `shouldReturn` bytes
liftIO $ threadDelay 1000000
downloadXFTPChunk g c rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk2" chSize digest)
downloadXFTPChunk g c rpKey rId (XFTPRcvChunkSpec (testPath "received_chunk2") chSize digest)
`catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
deleteXFTPChunk c spKey sId
`catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
where
fileExpiration = ExpirationConfig {ttl = 1, checkInterval = 1}
testInactiveClientExpiration :: AFStoreType -> Expectation
testInactiveClientExpiration :: HasTestEnv => AFStoreType -> Expectation
testInactiveClientExpiration fsType = withXFTPServerConfigOn (updateXFTPCfg (cfgFS fsType) $ \c -> c {inactiveClientExpiration}) $ \_ -> runRight_ $ do
disconnected <- newEmptyTMVarIO
ts <- liftIO getCurrentTime
@@ -234,7 +233,7 @@ testInactiveClientExpiration fsType = withXFTPServerConfigOn (updateXFTPCfg (cfg
where
inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}
testFileStorageQuota :: AFStoreType -> Expectation
testFileStorageQuota :: HasTestEnv => AFStoreType -> Expectation
testFileStorageQuota fsType = withXFTPServerConfigOn (updateXFTPCfg (cfgFS fsType) $ \c -> c {fileSizeQuota = Just $ chSize * 2}) $
\_ -> testXFTPClient $ \c -> runRight_ $ do
g <- liftIO C.newRandom
@@ -245,8 +244,8 @@ testFileStorageQuota fsType = withXFTPServerConfigOn (updateXFTPCfg (cfgFS fsTyp
let file = FileInfo {sndKey, size = chSize, digest}
chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize}
download rId = do
downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes
downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec (testPath "received_chunk1") chSize digest
liftIO $ B.readFile (testPath "received_chunk1") `shouldReturn` bytes
(sId1, [rId1]) <- createXFTPChunk c spKey file [rcvKey] Nothing
uploadXFTPChunk c spKey sId1 chunkSpec
download rId1
@@ -262,7 +261,7 @@ testFileStorageQuota fsType = withXFTPServerConfigOn (updateXFTPCfg (cfgFS fsTyp
uploadXFTPChunk c spKey sId3 chunkSpec
download rId3
testFileLog :: AFStoreType -> Expectation
testFileLog :: HasTestEnv => AFStoreType -> Expectation
testFileLog _ = do
g <- C.newRandom
bytes <- liftIO $ createTestChunk testChunkPath
@@ -298,9 +297,9 @@ testFileLog _ = do
rId1 <- liftIO $ readTVarIO rIdVar1
rId2 <- liftIO $ readTVarIO rIdVar2
-- recipients and sender get AUTH error because server restarted without log
downloadXFTPChunk g c rpKey1 rId1 (XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest)
downloadXFTPChunk g c rpKey1 rId1 (XFTPRcvChunkSpec (testPath "received_chunk1") chSize digest)
`catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
downloadXFTPChunk g c rpKey2 rId2 (XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest)
downloadXFTPChunk g c rpKey2 rId2 (XFTPRcvChunkSpec (testPath "received_chunk1") chSize digest)
`catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
deleteXFTPChunk c spKey sId
`catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
@@ -331,10 +330,10 @@ testFileLog _ = do
removeFile testXFTPStatsBackupFile
where
download g c rpKey rId digest bytes = do
downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes
downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec (testPath "received_chunk1") chSize digest
liftIO $ B.readFile (testPath "received_chunk1") `shouldReturn` bytes
testFileBasicAuth :: Bool -> Maybe BasicAuth -> Maybe BasicAuth -> Bool -> AFStoreType -> IO ()
testFileBasicAuth :: HasTestEnv => Bool -> Maybe BasicAuth -> Maybe BasicAuth -> Bool -> AFStoreType -> IO ()
testFileBasicAuth allowNewFiles newFileBasicAuth clntAuth success fsType =
withXFTPServerConfigOn (updateXFTPCfg (cfgFS fsType) $ \c -> c {allowNewFiles, newFileBasicAuth}) $
\_ -> testXFTPClient $ \c -> do
@@ -350,13 +349,13 @@ testFileBasicAuth allowNewFiles newFileBasicAuth clntAuth success fsType =
then do
(sId, [rId]) <- createXFTPChunk c spKey file [rcvKey] clntAuth
uploadXFTPChunk c spKey sId chunkSpec
downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk" chSize digest
liftIO $ B.readFile "tests/tmp/received_chunk" `shouldReturn` bytes
downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec (testPath "received_chunk") chSize digest
liftIO $ B.readFile (testPath "received_chunk") `shouldReturn` bytes
else do
void (createXFTPChunk c spKey file [rcvKey] clntAuth)
`catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
testFileSkipCommitted :: AFStoreType -> IO ()
testFileSkipCommitted :: HasTestEnv => AFStoreType -> IO ()
testFileSkipCommitted fsType =
withXFTPServerConfigOn (cfgFS fsType) $
\_ -> testXFTPClient $ \c -> do
@@ -372,8 +371,8 @@ testFileSkipCommitted fsType =
uploadXFTPChunk c spKey sId chunkSpec
void . liftIO $ createTestChunk testChunkPath -- trash chunk contents
uploadXFTPChunk c spKey sId chunkSpec -- upload again to get FROk without getting stuck
downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk" chSize digest
liftIO $ B.readFile "tests/tmp/received_chunk" `shouldReturn` bytes -- new chunk content got ignored
downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec (testPath "received_chunk") chSize digest
liftIO $ B.readFile (testPath "received_chunk") `shouldReturn` bytes -- new chunk content got ignored
-- SNI and CORS tests
@@ -386,7 +385,7 @@ getCerts tls =
let X.CertificateChain cc = tlsPeerCert tls
in map (X.signedObject . X.getSigned) cc
testSNICertSelection :: Expectation
testSNICertSelection :: HasTestEnv => Expectation
testSNICertSelection =
withXFTPServerSNI $ \_ -> do
Fingerprint fpHTTP <- loadFileFingerprint "tests/fixtures/web_ca.crt"
@@ -399,7 +398,7 @@ testSNICertSelection =
leaf : _ -> expectationFailure $ "Expected RSA cert, got: " <> show (X.certPubKey leaf)
[] -> expectationFailure "Empty certificate chain"
testNoSNICertSelection :: Expectation
testNoSNICertSelection :: HasTestEnv => Expectation
testNoSNICertSelection =
withXFTPServerSNI $ \_ -> do
Fingerprint fpXFTP <- loadFileFingerprint "tests/fixtures/ca.crt"
@@ -412,7 +411,7 @@ testNoSNICertSelection =
leaf : _ -> expectationFailure $ "Expected Ed448 cert, got: " <> show (X.certPubKey leaf)
[] -> expectationFailure "Empty certificate chain"
testCORSHeaders :: Expectation
testCORSHeaders :: HasTestEnv => Expectation
testCORSHeaders =
withXFTPServerSNI $ \_ -> do
Fingerprint fpHTTP <- loadFileFingerprint "tests/fixtures/web_ca.crt"
@@ -426,7 +425,7 @@ testCORSHeaders =
lookupResponseHeader "access-control-allow-origin" response `shouldBe` Just "*"
lookupResponseHeader "access-control-expose-headers" response `shouldBe` Just "*"
testCORSPreflight :: Expectation
testCORSPreflight :: HasTestEnv => Expectation
testCORSPreflight =
withXFTPServerSNI $ \_ -> do
Fingerprint fpHTTP <- loadFileFingerprint "tests/fixtures/web_ca.crt"
@@ -442,7 +441,7 @@ testCORSPreflight =
lookupResponseHeader "access-control-allow-headers" response `shouldBe` Just "*"
lookupResponseHeader "access-control-max-age" response `shouldBe` Just "86400"
testNoCORSWithoutSNI :: Expectation
testNoCORSWithoutSNI :: HasTestEnv => Expectation
testNoCORSWithoutSNI =
withXFTPServerSNI $ \_ -> do
Fingerprint fpXFTP <- loadFileFingerprint "tests/fixtures/ca.crt"
@@ -455,11 +454,11 @@ testNoCORSWithoutSNI =
HC.HTTP2Response {HC.response} <- either (error . show) pure =<< HC.sendRequest h2 req (Just 5000000)
lookupResponseHeader "access-control-allow-origin" response `shouldBe` Nothing
testFileChunkDeliverySNI :: Expectation
testFileChunkDeliverySNI :: HasTestEnv => Expectation
testFileChunkDeliverySNI =
withXFTPServerSNI $ \_ -> testXFTPClient $ \c -> runRight_ $ runTestFileChunkDelivery c c
testWebHandshake :: Expectation
testWebHandshake :: HasTestEnv => Expectation
testWebHandshake =
withXFTPServerSNI $ \_ -> do
Fingerprint fpWeb <- loadFileFingerprint "tests/fixtures/web_ca.crt"
@@ -501,7 +500,7 @@ testWebHandshake =
let ackBody = bodyHead (HC.respBody resp2)
B.length ackBody `shouldBe` 0
testWebReHandshake :: Expectation
testWebReHandshake :: HasTestEnv => Expectation
testWebReHandshake =
withXFTPServerSNI $ \_ -> do
Fingerprint fpWeb <- loadFileFingerprint "tests/fixtures/web_ca.crt"
@@ -535,7 +534,7 @@ testWebReHandshake =
resp2b <- either (error . show) pure =<< HC.sendRequest h2 (H2.requestBuilder "POST" "/" [] $ byteString clientHsPadded) (Just 5000000)
B.length (bodyHead (HC.respBody resp2b)) `shouldBe` 0
testStaleWebSession :: Expectation
testStaleWebSession :: HasTestEnv => Expectation
testStaleWebSession =
withXFTPServerSNI $ \_ -> do
Fingerprint fpWeb <- loadFileFingerprint "tests/fixtures/web_ca.crt"
tests/XFTPWebTests.hs
+22 -27
View File
@@ -51,7 +51,6 @@ import AgentTests.FunctionalAPITests (rfGet, runRight, runRight_, sfGet, withAge
import Simplex.Messaging.Agent (AgentClient, xftpReceiveFile, xftpStartWorkers)
import Simplex.Messaging.Agent.Protocol (AEvent (..))
import SMPAgentClient (agentCfg, initAgentServers, testDB)
import XFTPCLI (recipientFiles, senderFiles, testBracket)
import qualified Simplex.Messaging.Crypto.File as CF
xftpWebDir :: FilePath
@@ -168,8 +167,8 @@ impAddr = "import * as Addr from './dist/protocol/address.js';"
jsOut :: String -> String
jsOut expr = "process.stdout.write(Buffer.from(" <> expr <> "));"
xftpWebTests :: IO () -> Spec
xftpWebTests dbCleanup = do
xftpWebTests :: Spec
xftpWebTests = do
xftpWebSourceHygieneTests
distExists <- runIO $ doesDirectoryExist (xftpWebDir <> "/dist")
if distExists
@@ -189,7 +188,7 @@ xftpWebTests dbCleanup = do
tsClientTests
tsDownloadTests
tsAddressTests
tsIntegrationTests dbCleanup
tsIntegrationTests
else
it "skipped (run 'cd xftp-web && npm install && npm run build' first)" $
pendingWith "TS project not compiled"
@@ -2847,9 +2846,8 @@ tsAddressTests = describe "protocol/address" $ do
-- ── integration ───────────────────────────────────────────────────
tsIntegrationTests :: IO () -> Spec
tsIntegrationTests dbCleanup = describe "integration" $
around_ testBracket . after_ dbCleanup $ do
tsIntegrationTests :: Spec
tsIntegrationTests = describe "integration" $ do
it "web handshake with Ed25519 identity verification" $
webHandshakeTest testXFTPServerConfigEd25519SNI "tests/fixtures/ed25519/ca.crt"
it "web handshake with Ed448 identity verification" $
@@ -2872,7 +2870,7 @@ tsIntegrationTests dbCleanup = describe "integration" $
it "cross-language: Haskell upload, TS download" $
haskellUploadTsDownloadTest testXFTPServerConfigSNI
webHandshakeTest :: XFTPServerConfig STMFileStore -> FilePath -> Expectation
webHandshakeTest :: HasTestEnv => XFTPServerConfig STMFileStore -> FilePath -> Expectation
webHandshakeTest cfg caFile = do
withXFTPServerCfg cfg $ \_ -> do
Fingerprint fp <- loadFileFingerprint caFile
@@ -2914,7 +2912,7 @@ webHandshakeTest cfg caFile = do
<> jsOut "new Uint8Array([idOk ? 1 : 0, ack.length === 0 ? 1 : 0])"
result `shouldBe` B.pack [1, 1]
pingTest :: XFTPServerConfig STMFileStore -> FilePath -> Expectation
pingTest :: HasTestEnv => XFTPServerConfig STMFileStore -> FilePath -> Expectation
pingTest cfg caFile = do
withXFTPServerCfg cfg $ \_ -> do
Fingerprint fp <- loadFileFingerprint caFile
@@ -2936,9 +2934,8 @@ pingTest cfg caFile = do
<> jsOut "new Uint8Array([1])"
result `shouldBe` B.pack [1]
fullRoundTripTest :: XFTPServerConfig STMFileStore -> FilePath -> Expectation
fullRoundTripTest :: HasTestEnv => XFTPServerConfig STMFileStore -> FilePath -> Expectation
fullRoundTripTest cfg caFile = do
createDirectoryIfMissing False "tests/tmp/xftp-server-files"
withXFTPServerCfg cfg $ \_ -> do
Fingerprint fp <- loadFileFingerprint caFile
let fpStr = map (toEnum . fromIntegral) $ B.unpack $ strEncode fp
@@ -3017,9 +3014,8 @@ agentURIRoundTripTest = do
<> jsOut "new Uint8Array([match])"
result `shouldBe` B.pack [1]
agentUploadDownloadTest :: XFTPServerConfig STMFileStore -> FilePath -> Expectation
agentUploadDownloadTest :: HasTestEnv => XFTPServerConfig STMFileStore -> FilePath -> Expectation
agentUploadDownloadTest cfg caFile = do
createDirectoryIfMissing False "tests/tmp/xftp-server-files"
withXFTPServerCfg cfg $ \_ -> do
Fingerprint fp <- loadFileFingerprint caFile
let fpStr = map (toEnum . fromIntegral) $ B.unpack $ strEncode fp
@@ -3050,9 +3046,8 @@ agentUploadDownloadTest cfg caFile = do
<> jsOut "new Uint8Array([nameMatch, sizeMatch, dataMatch])"
result `shouldBe` B.pack [1, 1, 1]
agentDeleteTest :: XFTPServerConfig STMFileStore -> FilePath -> Expectation
agentDeleteTest :: HasTestEnv => XFTPServerConfig STMFileStore -> FilePath -> Expectation
agentDeleteTest cfg caFile = do
createDirectoryIfMissing False "tests/tmp/xftp-server-files"
withXFTPServerCfg cfg $ \_ -> do
Fingerprint fp <- loadFileFingerprint caFile
let fpStr = map (toEnum . fromIntegral) $ B.unpack $ strEncode fp
@@ -3082,9 +3077,8 @@ agentDeleteTest cfg caFile = do
<> jsOut "new Uint8Array([deleted])"
result `shouldBe` B.pack [1]
agentRedirectTest :: XFTPServerConfig STMFileStore -> FilePath -> Expectation
agentRedirectTest :: HasTestEnv => XFTPServerConfig STMFileStore -> FilePath -> Expectation
agentRedirectTest cfg caFile = do
createDirectoryIfMissing False "tests/tmp/xftp-server-files"
withXFTPServerCfg cfg $ \_ -> do
Fingerprint fp <- loadFileFingerprint caFile
let fpStr = map (toEnum . fromIntegral) $ B.unpack $ strEncode fp
@@ -3116,9 +3110,8 @@ agentRedirectTest cfg caFile = do
<> jsOut "new Uint8Array([hasRedirect, nameMatch, sizeMatch, dataMatch])"
result `shouldBe` B.pack [1, 1, 1, 1]
tsUploadHaskellDownloadTest :: XFTPServerConfig STMFileStore -> FilePath -> Expectation
tsUploadHaskellDownloadTest :: HasTestEnv => XFTPServerConfig STMFileStore -> FilePath -> Expectation
tsUploadHaskellDownloadTest cfg caFile = do
createDirectoryIfMissing False "tests/tmp/xftp-server-files"
createDirectoryIfMissing False recipientFiles
withXFTPServerCfg cfg $ \_ -> do
Fingerprint fp <- loadFileFingerprint caFile
@@ -3151,9 +3144,8 @@ tsUploadHaskellDownloadTest cfg caFile = do
downloadedData <- B.readFile outPath
downloadedData `shouldBe` originalData
tsUploadRedirectHaskellDownloadTest :: XFTPServerConfig STMFileStore -> FilePath -> Expectation
tsUploadRedirectHaskellDownloadTest :: HasTestEnv => XFTPServerConfig STMFileStore -> FilePath -> Expectation
tsUploadRedirectHaskellDownloadTest cfg caFile = do
createDirectoryIfMissing False "tests/tmp/xftp-server-files"
createDirectoryIfMissing False recipientFiles
withXFTPServerCfg cfg $ \_ -> do
Fingerprint fp <- loadFileFingerprint caFile
@@ -3186,9 +3178,8 @@ tsUploadRedirectHaskellDownloadTest cfg caFile = do
downloadedData <- B.readFile outPath
downloadedData `shouldBe` originalData
haskellUploadTsDownloadTest :: XFTPServerConfig STMFileStore -> Expectation
haskellUploadTsDownloadTest :: HasTestEnv => XFTPServerConfig STMFileStore -> Expectation
haskellUploadTsDownloadTest cfg = do
createDirectoryIfMissing False "tests/tmp/xftp-server-files"
createDirectoryIfMissing False senderFiles
let filePath = senderFiles <> "/hs-to-ts.bin"
originalData <- B.pack <$> replicateM 50000 (randomIO :: IO Word8)
@@ -3201,8 +3192,8 @@ haskellUploadTsDownloadTest cfg = do
(_, _, SFDONE _ [rfd] _) <- sfGet sndr
pure rfd
let yamlDesc = strEncode vfd
tmpYaml = "tests/tmp/hs-to-ts-desc.yaml"
tmpData = "tests/tmp/hs-to-ts-data.bin"
tmpYaml = testPath "hs-to-ts-desc.yaml"
tmpData = testPath "hs-to-ts-data.bin"
B.writeFile tmpYaml yamlDesc
B.writeFile tmpData originalData
result <-
@@ -3212,8 +3203,12 @@ haskellUploadTsDownloadTest cfg = do
\import * as Agent from './dist/agent.js';\
\import {decodeFileDescription, validateFileDescription} from './dist/protocol/description.js';\
\await sodium.ready;\
\const yaml = fs.readFileSync('../tests/tmp/hs-to-ts-desc.yaml', 'utf-8');\
\const expected = new Uint8Array(fs.readFileSync('../tests/tmp/hs-to-ts-data.bin'));\
\const yaml = fs.readFileSync('../"
<> tmpYaml
<> "', 'utf-8');\
\const expected = new Uint8Array(fs.readFileSync('../"
<> tmpData
<> "'));\
\const fd = decodeFileDescription(yaml);\
\const err = validateFileDescription(fd);\
\if (err) throw new Error(err);\