mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-10-12 02:22:45 +00:00
Merge branch 'master' into names
This commit is contained in:
Evgeny @ SimpleX Chat
+155
-19
@@ -66,8 +66,19 @@ jobs:
|
||||
build:
|
||||
name: "ubuntu-${{ matrix.os }}-${{ matrix.arch }}, GHC: ${{ matrix.ghc }}"
|
||||
needs: maybe-release
|
||||
permissions:
|
||||
contents: write
|
||||
packages: write
|
||||
env:
|
||||
apps: "smp-server xftp-server ntf-server xftp"
|
||||
opt: ${{ github.event_name == 'pull_request' && 'O0' || 'O2' }}
|
||||
ghc_options: ${{ github.event_name == 'pull_request' && '--ghc-options=-O0' || '' }}
|
||||
release: ${{ startsWith(github.ref, 'refs/tags/v') }}
|
||||
postgres_dist: ${{ startsWith(github.ref, 'refs/tags/v') && 'dist-newstyle' || 'dist-postgres' }}
|
||||
branch: ${{ github.base_ref || github.ref_name }}
|
||||
cache_o0: ${{ github.event_name == 'push' && (github.ref == 'refs/heads/master' || github.ref == 'refs/heads/stable') }}
|
||||
image_cache: ghcr.io/simplex-chat/simplexmq-build-cache:${{ matrix.os }}-${{ matrix.arch }}-ghc${{ matrix.ghc }}
|
||||
source_hashes: dist-newstyle/sources.sha256
|
||||
runs-on: ${{ matrix.runner }}
|
||||
services:
|
||||
postgres:
|
||||
@@ -146,6 +157,18 @@ jobs:
|
||||
sudo apt update
|
||||
sudo apt -y install postgresql-client-15
|
||||
|
||||
- name: Log in to GitHub Container Registry
|
||||
if: matrix.should_run == true && env.release != 'true'
|
||||
shell: bash
|
||||
env:
|
||||
GHCR_TOKEN: ${{ secrets.GITHUB_TOKEN }}
|
||||
run: echo "$GHCR_TOKEN" | docker login ghcr.io -u "${{ github.actor }}" --password-stdin
|
||||
|
||||
- name: Compute image cache week
|
||||
id: week
|
||||
if: matrix.should_run == true && env.release != 'true'
|
||||
run: echo "week=$(date -u +%G-W%V)" >> "$GITHUB_OUTPUT"
|
||||
|
||||
- name: Build and cache Docker image
|
||||
if: matrix.should_run == true
|
||||
uses: simplex-chat/docker-build-push-action@v6
|
||||
@@ -157,20 +180,14 @@ jobs:
|
||||
build-args: |
|
||||
TAG=${{ matrix.os }}
|
||||
GHC=${{ matrix.ghc }}
|
||||
|
||||
- name: Cache dependencies
|
||||
if: matrix.should_run == true
|
||||
uses: actions/cache@v4
|
||||
with:
|
||||
path: |
|
||||
~/.cabal/store
|
||||
dist-newstyle
|
||||
key: ubuntu-${{ matrix.os }}-${{ matrix.arch }}-ghc${{ matrix.ghc }}-${{ hashFiles('cabal.project', 'simplexmq.cabal') }}
|
||||
cache-from: ${{ env.release != 'true' && format('type=registry,ref={0}-{1}', env.image_cache, steps.week.outputs.week) || '' }}
|
||||
cache-to: ${{ github.event_name == 'push' && github.ref == 'refs/heads/master' && format('type=registry,ref={0}-{1},mode=max,ignore-error=true', env.image_cache, steps.week.outputs.week) || '' }}
|
||||
|
||||
- name: Start container
|
||||
if: matrix.should_run == true
|
||||
shell: bash
|
||||
run: |
|
||||
mkdir -p ~/.cabal
|
||||
docker run -t -d \
|
||||
--device /dev/fuse \
|
||||
--cap-add SYS_ADMIN \
|
||||
@@ -181,21 +198,66 @@ jobs:
|
||||
-v ${{ github.workspace }}:/project \
|
||||
build/${{ matrix.os }}:latest
|
||||
|
||||
- name: Compute cache key prefixes
|
||||
id: keys
|
||||
if: matrix.should_run == true && env.release != 'true'
|
||||
run: |
|
||||
toolchain=$(docker exec builder dpkg-query -W -f '${db:Status-Status} ${binary:Package} ${Version}\n' 'binutils*' 'cpp*' 'gcc*' '*-dev' | grep '^installed ' | sha256sum | cut -c1-16)
|
||||
target=${{ matrix.os }}-${{ matrix.arch }}-ghc${{ matrix.ghc }}-$toolchain
|
||||
echo "deps=deps-$target" >> "$GITHUB_OUTPUT"
|
||||
echo "dist=dist-$target" >> "$GITHUB_OUTPUT"
|
||||
|
||||
- name: Restore dependencies from cache
|
||||
id: restore-deps
|
||||
if: matrix.should_run == true && env.release != 'true'
|
||||
uses: actions/cache/restore@v4
|
||||
with:
|
||||
path: ~/.cabal/store
|
||||
key: ${{ steps.keys.outputs.deps }}-${{ env.branch }}-${{ github.sha }}
|
||||
restore-keys: |
|
||||
${{ steps.keys.outputs.deps }}-${{ env.branch }}-
|
||||
${{ steps.keys.outputs.deps }}-
|
||||
|
||||
- name: Warn if dependencies not in cache
|
||||
if: matrix.should_run == true && env.release != 'true' && steps.restore-deps.outputs.cache-matched-key == ''
|
||||
run: echo "::warning title=Cache miss::${{ steps.keys.outputs.deps }}-${{ env.branch }}"
|
||||
|
||||
- name: Restore build directories from cache
|
||||
id: restore-build
|
||||
if: matrix.should_run == true && env.release != 'true'
|
||||
uses: actions/cache/restore@v4
|
||||
with:
|
||||
path: |
|
||||
dist-newstyle
|
||||
dist-postgres
|
||||
key: ${{ steps.keys.outputs.dist }}-${{ env.opt }}-${{ env.branch }}-${{ github.sha }}
|
||||
restore-keys: |
|
||||
${{ steps.keys.outputs.dist }}-${{ env.opt }}-${{ env.branch }}-
|
||||
${{ steps.keys.outputs.dist }}-${{ env.opt }}-
|
||||
|
||||
- name: Warn if build directories not in cache
|
||||
if: matrix.should_run == true && env.release != 'true' && steps.restore-build.outputs.cache-matched-key == ''
|
||||
run: echo "::warning title=Cache miss::${{ steps.keys.outputs.dist }}-${{ env.opt }}-${{ env.branch }}"
|
||||
|
||||
- name: Set old timestamps on unchanged sources (GHC 8.10.7)
|
||||
if: matrix.ghc == '8.10.7' && steps.restore-build.outputs.cache-matched-key != '' && hashFiles(env.source_hashes) != ''
|
||||
run: scripts/ci/source-timestamps.sh restore ${{ env.source_hashes }}
|
||||
|
||||
- name: Build smp-server, xftp-server (postgresql) and tests
|
||||
if: matrix.should_run == true
|
||||
shell: docker exec -t builder sh -eu {0}
|
||||
run: |
|
||||
chmod -fR 777 ~/.cabal ./dist-newstyle || :; git config --global --add safe.directory '*'
|
||||
cabal clean
|
||||
chmod -fR 777 ~/.cabal ./dist-newstyle ./dist-postgres || :; git config --global --add safe.directory '*'
|
||||
scripts/ci/prune-old-builds.sh dist-newstyle dist-postgres
|
||||
cabal update
|
||||
cabal build --jobs=$(nproc) --enable-tests -fserver_postgres
|
||||
cabal build --builddir=${{ env.postgres_dist }} --jobs=$(nproc) --enable-tests -fserver_postgres ${{ env.ghc_options }}
|
||||
mkdir -p /out
|
||||
for i in smp-server xftp-server simplexmq-test; do
|
||||
bin=$(find /project/dist-newstyle -name "$i" -type f -executable)
|
||||
for i in smp-server xftp-server ntf-server simplexmq-test; do
|
||||
bin=$(find /project/${{ env.postgres_dist }} -name "$i" -type f -executable)
|
||||
chmod +x "$bin"
|
||||
mv "$bin" /out/
|
||||
cp "$bin" /out/
|
||||
done
|
||||
strip /out/smp-server /out/xftp-server
|
||||
strip /out/smp-server /out/xftp-server /out/ntf-server
|
||||
|
||||
- name: Copy simplexmq-test from container
|
||||
if: matrix.should_run == true
|
||||
@@ -228,16 +290,17 @@ jobs:
|
||||
cat hashes.output >> "$GITHUB_OUTPUT"
|
||||
|
||||
- name: Build everything else (standard)
|
||||
id: build-standard
|
||||
if: matrix.should_run == true
|
||||
shell: docker exec -t builder sh -eu {0}
|
||||
run: |
|
||||
cabal build --jobs=$(nproc)
|
||||
cabal build --jobs=$(nproc) ${{ env.ghc_options }}
|
||||
mkdir -p /out
|
||||
for i in ${{ env.apps }}; do
|
||||
for i in smp-server xftp-server xftp; do
|
||||
bin=$(find /project/dist-newstyle -name "$i" -type f -executable)
|
||||
strip "$bin"
|
||||
chmod +x "$bin"
|
||||
mv "$bin" /out/
|
||||
cp "$bin" /out/
|
||||
done
|
||||
|
||||
- name: Copy binaries from container and prepare them
|
||||
@@ -282,6 +345,33 @@ jobs:
|
||||
env:
|
||||
GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
|
||||
|
||||
- name: Record source hashes (GHC 8.10.7)
|
||||
if: matrix.should_run == true && matrix.ghc == '8.10.7'
|
||||
shell: docker exec -t builder sh -eu {0}
|
||||
run: scripts/ci/source-timestamps.sh record ${{ env.source_hashes }}
|
||||
|
||||
- name: Compute dependency cache key
|
||||
id: hash-deps
|
||||
if: matrix.should_run == true && env.release != 'true'
|
||||
shell: bash
|
||||
run: echo "hash=$(ls ~/.cabal/store/ghc-*/ | sha256sum | cut -c1-16)" >> "$GITHUB_OUTPUT"
|
||||
|
||||
- name: Save dependencies to cache
|
||||
if: matrix.should_run == true && env.release != 'true' && steps.restore-deps.outputs.cache-matched-key != format('{0}-{1}-{2}', steps.keys.outputs.deps, env.branch, steps.hash-deps.outputs.hash)
|
||||
uses: actions/cache/save@v4
|
||||
with:
|
||||
path: ~/.cabal/store
|
||||
key: ${{ steps.keys.outputs.deps }}-${{ env.branch }}-${{ steps.hash-deps.outputs.hash }}
|
||||
|
||||
- name: Save build directories to cache
|
||||
if: matrix.should_run == true && env.release != 'true' && steps.restore-build.outputs.cache-hit != 'true'
|
||||
uses: actions/cache/save@v4
|
||||
with:
|
||||
path: |
|
||||
dist-newstyle
|
||||
dist-postgres
|
||||
key: ${{ steps.keys.outputs.dist }}-${{ env.opt }}-${{ env.branch }}-${{ github.sha }}
|
||||
|
||||
- name: Test
|
||||
if: matrix.should_run == true && matrix.arch == 'x86-64'
|
||||
timeout-minutes: 120
|
||||
@@ -306,6 +396,52 @@ jobs:
|
||||
exit 1
|
||||
fi
|
||||
|
||||
- name: Remove -O2 build directories
|
||||
id: remove-o2
|
||||
if: env.cache_o0 == 'true' && !cancelled() && steps.build-standard.outcome == 'success'
|
||||
shell: docker exec -t builder sh -eu {0}
|
||||
run: rm -rf dist-newstyle dist-postgres
|
||||
|
||||
- name: Restore -O0 build directories from cache
|
||||
id: restore-build-o0
|
||||
if: ${{ !cancelled() && steps.remove-o2.outcome == 'success' }}
|
||||
uses: actions/cache/restore@v4
|
||||
with:
|
||||
path: |
|
||||
dist-newstyle
|
||||
dist-postgres
|
||||
key: ${{ steps.keys.outputs.dist }}-O0-${{ env.branch }}-${{ github.sha }}
|
||||
restore-keys: |
|
||||
${{ steps.keys.outputs.dist }}-O0-${{ env.branch }}-
|
||||
${{ steps.keys.outputs.dist }}-O0-
|
||||
|
||||
- name: Set old timestamps on unchanged sources for -O0 build (GHC 8.10.7)
|
||||
if: ${{ !cancelled() && matrix.ghc == '8.10.7' && steps.restore-build-o0.outputs.cache-matched-key != '' && hashFiles(env.source_hashes) != '' }}
|
||||
run: scripts/ci/source-timestamps.sh restore ${{ env.source_hashes }}
|
||||
|
||||
- name: Build at -O0 for pull request caches
|
||||
id: build-o0
|
||||
if: ${{ !cancelled() && steps.remove-o2.outcome == 'success' }}
|
||||
shell: docker exec -t builder sh -eu {0}
|
||||
run: |
|
||||
scripts/ci/prune-old-builds.sh dist-newstyle dist-postgres
|
||||
cabal build --builddir=dist-postgres --jobs=$(nproc) --enable-tests -fserver_postgres --ghc-options=-O0
|
||||
cabal build --jobs=$(nproc) --ghc-options=-O0
|
||||
|
||||
- name: Record source hashes for -O0 build (GHC 8.10.7)
|
||||
if: ${{ !cancelled() && matrix.ghc == '8.10.7' && steps.build-o0.outcome == 'success' }}
|
||||
shell: docker exec -t builder sh -eu {0}
|
||||
run: scripts/ci/source-timestamps.sh record ${{ env.source_hashes }}
|
||||
|
||||
- name: Save -O0 build directories to cache
|
||||
if: ${{ !cancelled() && steps.build-o0.outcome == 'success' && steps.restore-build-o0.outputs.cache-hit != 'true' }}
|
||||
uses: actions/cache/save@v4
|
||||
with:
|
||||
path: |
|
||||
dist-newstyle
|
||||
dist-postgres
|
||||
key: ${{ steps.keys.outputs.dist }}-O0-${{ env.branch }}-${{ github.sha }}
|
||||
|
||||
# =============================
|
||||
# Resolver test job
|
||||
# =============================
|
||||
|
||||
@@ -0,0 +1,52 @@
|
||||
# Delayed AUTH error responses
|
||||
|
||||
## Decisions
|
||||
|
||||
- Responses that include `ERR AUTH` are sent at the next multiple of the delay after the start time.
|
||||
- Delayed response sets:
|
||||
|
||||
| Source | Responses sent together | Start time |
|
||||
|---|---|---|
|
||||
| `receive`, failed verification | verification and parsing errors of one received block | block receipt |
|
||||
| `client`, command processing | responses and messages of one batch | batch read from `rcvQ` |
|
||||
| `RFWD`, forwarded command | the `RRES` of that command | start of forwarded command processing |
|
||||
|
||||
- A thread created by `forkClient` writes the responses to the send queue.
|
||||
- Delay 0: the responses are written to the send queue directly.
|
||||
- `authDelayExceeded`: incremented when processing took longer than the delay.
|
||||
- Prometheus counter `simplex_smp_auth_delay_exceeded`.
|
||||
- Not saved in the stats backup.
|
||||
- Not in the daily stats log.
|
||||
- Configuration:
|
||||
|
||||
| Item | Value |
|
||||
|---|---|
|
||||
| INI section | `TRANSPORT` |
|
||||
| INI key | `auth_error_delay_ms` |
|
||||
| default | 50 |
|
||||
| `ServerConfig` field | `authErrorDelay`, microseconds |
|
||||
| test servers | 20 ms |
|
||||
|
||||
- AUTH timing test: elapsed time of 5 requests, test servers' delay.
|
||||
- Out of scope: NTF and XFTP servers.
|
||||
|
||||
## Mechanics
|
||||
|
||||
- `Server.hs`:
|
||||
- `isAuthError`: response is `ERR AUTH`.
|
||||
- `sendResponses`: responses with `ERR AUTH` to `sendAfterDelay`, others to the send queue.
|
||||
- `sendAfterDelay`: writes responses to the send queue at the next multiple of the delay.
|
||||
- `receive`: block receipt time from the `rcvActiveAt` reading.
|
||||
- `client`: batch time.
|
||||
- `processForwardedCommand`: start time.
|
||||
- `Server/Env/STM.hs`: `authErrorDelay` field, `defaultAuthErrorDelayMs`.
|
||||
- `Server/Stats.hs`: `authDelayExceeded` in `ServerStats` and `ServerStatsData`.
|
||||
- `Server/Prometheus.hs`: `simplex_smp_auth_delay_exceeded`.
|
||||
- `Server/Main.hs`: INI value.
|
||||
- `Server/Main/Init.hs`: INI template line.
|
||||
- `simplexmq.cabal`: `timeit` removed from the test suite.
|
||||
- `tests/SMPClient.hs`: `authErrorDelay = 20000`.
|
||||
- `tests/ServerTests.hs`:
|
||||
- delayed AUTH for wrong key, absent queue, absent link and suspended queue; immediate `SOK`.
|
||||
- AUTH timing test measures elapsed time.
|
||||
- `tests/SMPProxyTests.hs`: delayed AUTH to forwarded `SEND` and `LGET`.
|
||||
Executable
+9
@@ -0,0 +1,9 @@
|
||||
#!/bin/sh
|
||||
set -eu
|
||||
|
||||
version=$(awk '/^version:/ {print $2}' simplexmq.cabal)
|
||||
for dir in "$@"; do
|
||||
if [ -d "$dir/build" ]; then
|
||||
find "$dir/build" -mindepth 3 -maxdepth 3 -type d -name 'simplexmq-*' ! -name "simplexmq-$version" -exec rm -rf {} +
|
||||
fi
|
||||
done
|
||||
Executable
+27
@@ -0,0 +1,27 @@
|
||||
#!/bin/sh
|
||||
set -eu
|
||||
|
||||
command=$1
|
||||
hashes=$2
|
||||
|
||||
sources() {
|
||||
git ls-files -z '*.hs' '*.hsc'
|
||||
}
|
||||
|
||||
case "$command" in
|
||||
record)
|
||||
sources | xargs -0 sha256sum > "$hashes"
|
||||
;;
|
||||
restore)
|
||||
sources | xargs -0 touch
|
||||
while read -r hash file; do
|
||||
if [ -f "$file" ] && [ "$(sha256sum "$file" | cut -d' ' -f1)" = "$hash" ]; then
|
||||
touch -d 2000-01-01 "$file"
|
||||
fi
|
||||
done < "$hashes"
|
||||
;;
|
||||
*)
|
||||
echo "usage: $0 record|restore <hashes file>" >&2
|
||||
exit 1
|
||||
;;
|
||||
esac
|
||||
@@ -660,7 +660,6 @@ test-suite simplexmq-test
|
||||
, stm
|
||||
, text
|
||||
, time
|
||||
, timeit ==2.0.*
|
||||
, tls >=1.9.0 && <1.10
|
||||
, transformers
|
||||
, unliftio
|
||||
|
||||
@@ -1145,14 +1145,16 @@ cancelSub s = case subThread s of
|
||||
type VerifiedTransmissionOrError s = Either (Transmission BrokerMsg) (VerifiedTransmission s)
|
||||
|
||||
receive :: forall c s. (Transport c, MsgStoreClass s) => THandleSMP c 'TServer -> s -> Client s -> M s ()
|
||||
receive h@THandle {params = THandleParams {thAuth, sessionId}} ms Client {rcvQ, sndQ, rcvActiveAt} = do
|
||||
receive h@THandle {params = THandleParams {thAuth, sessionId}} ms c@Client {rcvQ, rcvActiveAt} = do
|
||||
labelMyThread . B.unpack $ "client $" <> encode sessionId <> " receive"
|
||||
sa <- asks serverActive
|
||||
stats <- asks serverStats
|
||||
authDelay <- asks $ authErrorDelay . config
|
||||
liftIO $ forever $ do
|
||||
ts <- tGetServer h
|
||||
unlessM (readTVarIO sa) $ throwIO $ userError "server stopped"
|
||||
atomically . (writeTVar rcvActiveAt $!) =<< getSystemTime
|
||||
receivedAt <- getSystemTime
|
||||
atomically $ writeTVar rcvActiveAt $! receivedAt
|
||||
let (es, ts') = partitionEithers $ L.toList ts
|
||||
errs = map (second ERR) es
|
||||
errs' <- case ts' of
|
||||
@@ -1168,7 +1170,7 @@ receive h@THandle {params = THandleParams {thAuth, sessionId}} ms Client {rcvQ,
|
||||
mapM_ (atomically . writeTBQueue rcvQ) $ L.nonEmpty cmds
|
||||
pure $ errs ++ errs'
|
||||
[] -> pure errs
|
||||
mapM_ (atomically . writeTBQueue sndQ . (,[])) $ L.nonEmpty errs'
|
||||
mapM_ (sendResponses c stats authDelay receivedAt . (,[])) $ L.nonEmpty errs'
|
||||
where
|
||||
sameParty :: SParty p -> SignedTransmission Cmd -> Bool
|
||||
sameParty p (_, _, (_, _, Cmd p' _)) = isJust $ testEquality p p'
|
||||
@@ -1191,6 +1193,27 @@ receive h@THandle {params = THandleParams {thAuth, sessionId}} ms Client {rcvQ,
|
||||
GET -> incStat $ msgGetAuth stats
|
||||
_ -> pure ()
|
||||
|
||||
isAuthError :: Transmission BrokerMsg -> Bool
|
||||
isAuthError (_, _, r) = case r of
|
||||
ERR AUTH -> True
|
||||
_ -> False
|
||||
|
||||
sendResponses :: Client s -> ServerStats -> Int64 -> SystemTime -> (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg]) -> IO ()
|
||||
sendResponses c@Client {sndQ} stats authDelay since rs@(ts, _)
|
||||
| any isAuthError ts = sendAfterDelay c stats authDelay since rs
|
||||
| otherwise = atomically $ writeTBQueue sndQ rs
|
||||
|
||||
sendAfterDelay :: Client s -> ServerStats -> Int64 -> SystemTime -> (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg]) -> IO ()
|
||||
sendAfterDelay c@Client {sndQ, clientTHParams = THandleParams {sessionId}} stats delay since rs
|
||||
| delay > 0 = do
|
||||
elapsed <- subtract (microseconds since) . microseconds <$> getSystemTime
|
||||
when (elapsed >= delay) $ incStat $ authDelayExceeded stats
|
||||
forkClient c (B.unpack $ "client $" <> encode sessionId <> " auth") $ threadDelay' (delay - elapsed `mod` delay) >> write
|
||||
| otherwise = write
|
||||
where
|
||||
write = atomically $ writeTBQueue sndQ rs
|
||||
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
|
||||
labelMyThread . B.unpack $ "client $" <> encode sessionId <> " send"
|
||||
@@ -1374,15 +1397,18 @@ client
|
||||
ms
|
||||
clnt@Client {clientId, rcvQ, sndQ, msgQ, clientTHParams = thParams'@THandleParams {sessionId}, procThreads} = do
|
||||
labelMyThread . B.unpack $ "client $" <> encode sessionId <> " commands"
|
||||
stats <- asks serverStats
|
||||
authDelay <- asks $ authErrorDelay . config
|
||||
let clntServiceId = (\THClientService {serviceId} -> serviceId) <$> (peerClientService =<< thAuth thParams')
|
||||
process batchSubs t acc@(rs, msgs) =
|
||||
(maybe acc (\(!r, !msg_) -> (r : rs, maybe msgs (: msgs) msg_)))
|
||||
<$> processCommand clntServiceId batchSubs t
|
||||
forever $ do
|
||||
batch <- atomically (readTBQueue rcvQ)
|
||||
processedAt <- liftIO getSystemTime
|
||||
batchSubs <- prepareBatchSubs clntServiceId batch
|
||||
foldrM (process batchSubs) ([], []) batch
|
||||
>>= \(rs_, msgs) -> mapM_ (atomically . writeTBQueue sndQ . (,msgs)) (L.nonEmpty rs_)
|
||||
>>= \(rs_, msgs) -> mapM_ (liftIO . sendResponses clnt stats authDelay processedAt . (,msgs)) (L.nonEmpty rs_)
|
||||
where
|
||||
prepareBatchSubs ::
|
||||
Maybe ServiceId ->
|
||||
@@ -2119,6 +2145,7 @@ client
|
||||
|
||||
processForwardedCommand :: EncFwdTransmission -> M s (Maybe BrokerMsg)
|
||||
processForwardedCommand (EncFwdTransmission s) = fmap (either (Just . ERR) id) . runExceptT $ do
|
||||
startedAt <- liftIO getSystemTime
|
||||
THAuthServer {serverPrivKey, sessSecret'} <- maybe (throwE $ transportErr TENoServerAuth) pure (thAuth thParams')
|
||||
sessSecret <- maybe (throwE $ transportErr TENoServerAuth) pure sessSecret'
|
||||
proxyNonce <- liftEitherWith (const CRYPTO) $ C.cbNonce $ bs corrId
|
||||
@@ -2162,7 +2189,11 @@ client
|
||||
_ -> Just . maybe (corrId', entId', ERR INTERNAL) fst <$> lift (processCommand Nothing (Right (M.empty, M.empty, M.empty)) t'')
|
||||
stats <- asks serverStats
|
||||
incStat $ pMsgFwdsRecv stats
|
||||
traverse encodeResp r_
|
||||
traverse encodeResp r_ >>= \case
|
||||
Just rres | any isAuthError r_ -> do
|
||||
authDelay <- asks $ authErrorDelay . config
|
||||
Nothing <$ liftIO (sendAfterDelay clnt stats authDelay startedAt ([(corrId, NoEntity, rres)], []))
|
||||
rres_ -> pure rres_
|
||||
where
|
||||
rejectOrVerify :: Maybe (THandleAuth 'TServer) -> SignedTransmissionOrError ErrorType Cmd -> M s (VerifiedTransmissionOrError s)
|
||||
rejectOrVerify clntThAuth = \case
|
||||
|
||||
@@ -68,6 +68,7 @@ module Simplex.Messaging.Server.Env.STM
|
||||
defaultInactiveClientExpiration,
|
||||
defaultProxyClientConcurrency,
|
||||
defaultNameResolverConcurrency,
|
||||
defaultAuthErrorDelayMs,
|
||||
defaultMaxJournalMsgCount,
|
||||
defaultMaxJournalStateLines,
|
||||
defaultIdleQueueInterval,
|
||||
@@ -187,6 +188,7 @@ data ServerConfig s = ServerConfig
|
||||
ntfDeliveryInterval :: Int,
|
||||
-- | interval between sending pending END events to unsubscribed clients, seconds
|
||||
pendingENDInterval :: Int,
|
||||
authErrorDelay :: Int64,
|
||||
smpCredentials :: ServerCredentials,
|
||||
httpCredentials :: Maybe ServerCredentials,
|
||||
-- | SMP client-server protocol version range
|
||||
@@ -255,6 +257,9 @@ defaultProxyClientConcurrency = 32
|
||||
defaultNameResolverConcurrency :: Int
|
||||
defaultNameResolverConcurrency = 1000
|
||||
|
||||
defaultAuthErrorDelayMs :: Int64
|
||||
defaultAuthErrorDelayMs = 50
|
||||
|
||||
journalMsgStoreDepth :: Int
|
||||
journalMsgStoreDepth = 5
|
||||
|
||||
|
||||
@@ -580,6 +580,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
|
||||
prometheusMetricsFile = combine logPath "smp-server-metrics.txt",
|
||||
pendingENDInterval = 15000000, -- 15 seconds
|
||||
ntfDeliveryInterval = 1500000, -- 1.5 second
|
||||
authErrorDelay = 1000 * readIniDefault defaultAuthErrorDelayMs "TRANSPORT" "auth_error_delay_ms" ini,
|
||||
smpServerVRange = supportedServerSMPRelayVRange,
|
||||
transportConfig =
|
||||
mkTransportServerConfig
|
||||
|
||||
@@ -130,7 +130,9 @@ iniFileContent cfgPath logPath opts host basicAuth controlPortPwds =
|
||||
<> ("host = " <> T.pack host <> "\n")
|
||||
<> ("port = " <> defaultServerPorts <> "\n")
|
||||
<> "log_tls_errors = off\n\n\
|
||||
\# Use `websockets = 443` to run websockets server in addition to plain TLS.\n\
|
||||
\# Minimum time to respond with AUTH error, milliseconds.\n"
|
||||
<> ("# auth_error_delay_ms = " <> tshow defaultAuthErrorDelayMs <> "\n\n")
|
||||
<> "# Use `websockets = 443` to run websockets server in addition to plain TLS.\n\
|
||||
\# This option is deprecated and should be used for testing only.\n\
|
||||
\# , port 443 should be specified in port above\n\
|
||||
\websockets = off\n"
|
||||
|
||||
@@ -126,6 +126,7 @@ prometheusMetrics sm rtm ts =
|
||||
_ntfServices,
|
||||
_rcvServicesSubMsg,
|
||||
_rcvServicesSubDuplicate,
|
||||
_authDelayExceeded,
|
||||
_qCount,
|
||||
_msgCount,
|
||||
_ntfCount,
|
||||
@@ -192,6 +193,10 @@ prometheusMetrics sm rtm ts =
|
||||
\# HELP simplex_smp_queues_notify_monthly Monthly active queues with notifications.\n\
|
||||
\# TYPE simplex_smp_queues_notify_monthly gauge\n\
|
||||
\simplex_smp_queues_notify_monthly " <> mstr (monthCount psNtf) <> "\n# monthCountNtf\n\
|
||||
\\n\
|
||||
\# 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"
|
||||
subscriptions =
|
||||
"# Subscriptions\n\
|
||||
|
||||
@@ -128,6 +128,7 @@ data ServerStats = ServerStats
|
||||
ntfServices :: ServiceStats,
|
||||
rcvServicesSubMsg :: IORef Int,
|
||||
rcvServicesSubDuplicate :: IORef Int,
|
||||
authDelayExceeded :: IORef Int,
|
||||
qCount :: IORef Int,
|
||||
msgCount :: IORef Int,
|
||||
ntfCount :: IORef Int,
|
||||
@@ -190,6 +191,7 @@ data ServerStatsData = ServerStatsData
|
||||
_rcvServices :: ServiceStatsData,
|
||||
_rcvServicesSubMsg :: Int,
|
||||
_rcvServicesSubDuplicate :: Int,
|
||||
_authDelayExceeded :: Int,
|
||||
_qCount :: Int,
|
||||
_msgCount :: Int,
|
||||
_ntfCount :: Int,
|
||||
@@ -254,6 +256,7 @@ newServerStats ts = do
|
||||
ntfServices <- newServiceStats
|
||||
rcvServicesSubMsg <- newIORef 0
|
||||
rcvServicesSubDuplicate <- newIORef 0
|
||||
authDelayExceeded <- newIORef 0
|
||||
qCount <- newIORef 0
|
||||
msgCount <- newIORef 0
|
||||
ntfCount <- newIORef 0
|
||||
@@ -315,6 +318,7 @@ newServerStats ts = do
|
||||
ntfServices,
|
||||
rcvServicesSubMsg,
|
||||
rcvServicesSubDuplicate,
|
||||
authDelayExceeded,
|
||||
qCount,
|
||||
msgCount,
|
||||
ntfCount,
|
||||
@@ -378,6 +382,7 @@ getServerStatsData s = do
|
||||
_ntfServices <- getServiceStatsData $ ntfServices s
|
||||
_rcvServicesSubMsg <- readIORef $ rcvServicesSubMsg s
|
||||
_rcvServicesSubDuplicate <- readIORef $ rcvServicesSubDuplicate s
|
||||
_authDelayExceeded <- readIORef $ authDelayExceeded s
|
||||
_qCount <- readIORef $ qCount s
|
||||
_msgCount <- readIORef $ msgCount s
|
||||
_ntfCount <- readIORef $ ntfCount s
|
||||
@@ -439,6 +444,7 @@ getServerStatsData s = do
|
||||
_ntfServices,
|
||||
_rcvServicesSubMsg,
|
||||
_rcvServicesSubDuplicate,
|
||||
_authDelayExceeded,
|
||||
_qCount,
|
||||
_msgCount,
|
||||
_ntfCount,
|
||||
@@ -503,6 +509,7 @@ setServerStats s d = do
|
||||
setServiceStats (ntfServices s) $! _ntfServices d
|
||||
writeIORef (rcvServicesSubMsg s) $! _rcvServicesSubMsg d
|
||||
writeIORef (rcvServicesSubDuplicate s) $! _rcvServicesSubDuplicate d
|
||||
writeIORef (authDelayExceeded s) $! _authDelayExceeded d
|
||||
writeIORef (qCount s) $! _qCount d
|
||||
writeIORef (msgCount s) $! _msgCount d
|
||||
writeIORef (ntfCount s) $! _ntfCount d
|
||||
@@ -705,6 +712,7 @@ instance StrEncoding ServerStatsData where
|
||||
_ntfServices,
|
||||
_rcvServicesSubMsg = 0,
|
||||
_rcvServicesSubDuplicate = 0,
|
||||
_authDelayExceeded = 0,
|
||||
_qCount,
|
||||
_msgCount = 0,
|
||||
_ntfCount = 0,
|
||||
|
||||
@@ -263,6 +263,7 @@ cfgMS msType = withStoreCfg (testServerStoreConfig msType) $ \serverStoreCfg ->
|
||||
prometheusMetricsFile = testPrometheusMetricsFile,
|
||||
pendingENDInterval = 500000,
|
||||
ntfDeliveryInterval = 200000,
|
||||
authErrorDelay = 20000,
|
||||
smpCredentials =
|
||||
ServerCredentials
|
||||
{ caCertificateFile = Just "tests/fixtures/ca.crt",
|
||||
|
||||
+16
-1
@@ -26,7 +26,7 @@ import qualified Data.List.NonEmpty as L
|
||||
import Data.Time.Clock (getCurrentTime)
|
||||
import SMPAgentClient
|
||||
import SMPClient
|
||||
import ServerTests (decryptMsgV3, sendRecv)
|
||||
import ServerTests (decryptMsgV3, responseTime, sendRecv)
|
||||
import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMessage)
|
||||
import qualified Simplex.Messaging.Agent as A
|
||||
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers (..))
|
||||
@@ -77,6 +77,8 @@ smpProxyTests = do
|
||||
testChangedFwdVersion
|
||||
it "proxy rejects forwarded correlation ID that is not 24 bytes" $ \_ ->
|
||||
testFwdCorrIdSize
|
||||
it "relay delays AUTH errors to forwarded commands" $ \_ ->
|
||||
testForwardedAuthErrorDelay
|
||||
describe "deliver message via SMP proxy" $ do
|
||||
let srv1 = SMPServer testHost testPort testKeyHash
|
||||
srv2 = SMPServer testHost2 testPort2 testKeyHash
|
||||
@@ -490,6 +492,19 @@ 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 =
|
||||
withSmpServerConfigOn (transport @TLS) proxyCfg testPort $ \_ ->
|
||||
withSmpServerConfigOn (transport @TLS) (updateCfg cfgJ2 $ \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 ())
|
||||
sess <- runExceptT' $ connectSMPProxiedRelay pc NRMInteractive testSMPServer2 Nothing
|
||||
(sendTime, Left (PCEProtocolError SMP.AUTH)) <- responseTime $ runExceptT $ proxySMPMessage pc NRMInteractive sess Nothing (SMP.EntityId "1234") noMsgFlags "hello"
|
||||
(getLinkTime, Left (PCEProtocolError SMP.AUTH)) <- responseTime $ runExceptT $ proxyGetSMPQueueLink pc NRMInteractive sess (SMP.EntityId "1234")
|
||||
sendTime `shouldSatisfy` (>= 0.5)
|
||||
getLinkTime `shouldSatisfy` (>= 0.5)
|
||||
|
||||
-- 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).
|
||||
|
||||
+47
-19
@@ -36,6 +36,7 @@ import Data.List.NonEmpty (NonEmpty)
|
||||
import Data.List (isPrefixOf)
|
||||
import Data.Maybe (catMaybes)
|
||||
import Data.String (IsString (..))
|
||||
import Data.Time.Clock (NominalDiffTime, diffUTCTime, getCurrentTime)
|
||||
import Text.Read (readMaybe)
|
||||
import Data.Type.Equality
|
||||
import qualified Data.X509.Validation as XV
|
||||
@@ -58,7 +59,6 @@ import Simplex.Messaging.Transport.Credentials
|
||||
import Simplex.Messaging.Util (whenM)
|
||||
import System.Directory (doesDirectoryExist, doesFileExist, removeDirectoryRecursive, removeFile)
|
||||
import System.IO (IOMode (..), withFile)
|
||||
import System.TimeIt (timeItT)
|
||||
import System.Timeout
|
||||
import Test.HUnit
|
||||
import Test.Hspec hiding (fit, it)
|
||||
@@ -97,6 +97,7 @@ serverTests = do
|
||||
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
|
||||
testMessageServiceNotifications
|
||||
@@ -1274,21 +1275,21 @@ testTiming =
|
||||
smpTest2Cfg (cfgMS msType) supportedServerSMPRelayVRange t $ \rh sh ->
|
||||
testSameTiming rh sh tst msType
|
||||
where
|
||||
testName :: (C.AuthAlg, C.AuthAlg, Int) -> String
|
||||
testName (C.AuthAlg goodKeyAlg, C.AuthAlg badKeyAlg, _) = unwords ["queue key:", show goodKeyAlg, "/ used key:", show badKeyAlg]
|
||||
timingTests :: [(C.AuthAlg, C.AuthAlg, Int)]
|
||||
testName :: (C.AuthAlg, C.AuthAlg) -> String
|
||||
testName (C.AuthAlg goodKeyAlg, C.AuthAlg badKeyAlg) = unwords ["queue key:", show goodKeyAlg, "/ used key:", show badKeyAlg]
|
||||
timingTests :: [(C.AuthAlg, C.AuthAlg)]
|
||||
timingTests =
|
||||
[ (C.AuthAlg C.SEd25519, C.AuthAlg C.SEd25519, 200), -- correct key type
|
||||
-- (C.AuthAlg C.SEd25519, C.AuthAlg C.SEd448, 150),
|
||||
-- (C.AuthAlg C.SEd25519, C.AuthAlg C.SX25519, 200),
|
||||
(C.AuthAlg C.SEd448, C.AuthAlg C.SEd25519, 200),
|
||||
(C.AuthAlg C.SEd448, C.AuthAlg C.SEd448, 150), -- correct key type
|
||||
(C.AuthAlg C.SEd448, C.AuthAlg C.SX25519, 200),
|
||||
(C.AuthAlg C.SX25519, C.AuthAlg C.SEd25519, 200),
|
||||
(C.AuthAlg C.SX25519, C.AuthAlg C.SEd448, 150),
|
||||
(C.AuthAlg C.SX25519, C.AuthAlg C.SX25519, 200) -- correct key type
|
||||
[ (C.AuthAlg C.SEd25519, C.AuthAlg C.SEd25519), -- correct key type
|
||||
-- (C.AuthAlg C.SEd25519, C.AuthAlg C.SEd448),
|
||||
-- (C.AuthAlg C.SEd25519, C.AuthAlg C.SX25519),
|
||||
(C.AuthAlg C.SEd448, C.AuthAlg C.SEd25519),
|
||||
(C.AuthAlg C.SEd448, C.AuthAlg C.SEd448), -- correct key type
|
||||
(C.AuthAlg C.SEd448, C.AuthAlg C.SX25519),
|
||||
(C.AuthAlg C.SX25519, C.AuthAlg C.SEd25519),
|
||||
(C.AuthAlg C.SX25519, C.AuthAlg C.SEd448),
|
||||
(C.AuthAlg C.SX25519, C.AuthAlg C.SX25519) -- correct key type
|
||||
]
|
||||
timeRepeat n = fmap fst . timeItT . forM_ (replicate n ()) . const
|
||||
timeRepeat = fmap fst . responseTime . replicateM_ 5
|
||||
similarTime t1 t2 msType
|
||||
| t1 <= t2 = abs (1 - t1 / t2) < diff
|
||||
| otherwise = similarTime t2 t1 msType
|
||||
@@ -1297,8 +1298,8 @@ testTiming =
|
||||
diff = case msType of
|
||||
ASType SQSPostgres _ -> 0.45
|
||||
_ -> 0.3
|
||||
testSameTiming :: forall c. Transport c => THandleSMP c 'TClient -> THandleSMP c 'TClient -> (C.AuthAlg, C.AuthAlg, Int) -> AStoreType -> Expectation
|
||||
testSameTiming rh sh (C.AuthAlg goodKeyAlg, C.AuthAlg badKeyAlg, n) msType = do
|
||||
testSameTiming :: forall c. Transport c => THandleSMP c 'TClient -> THandleSMP c 'TClient -> (C.AuthAlg, C.AuthAlg) -> AStoreType -> Expectation
|
||||
testSameTiming rh sh (C.AuthAlg goodKeyAlg, C.AuthAlg badKeyAlg) msType = do
|
||||
g <- C.newRandom
|
||||
(rPub, rKey) <- atomically $ C.generateAuthKeyPair goodKeyAlg g
|
||||
(dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
|
||||
@@ -1325,16 +1326,16 @@ testTiming =
|
||||
runTimingTest :: PartyI p => THandleSMP c 'TClient -> C.APrivateAuthKey -> EntityId -> Command p -> IO ()
|
||||
runTimingTest h badKey qId cmd = do
|
||||
threadDelay 100000
|
||||
_ <- timeRepeat n $ do
|
||||
_ <- timeRepeat $ do
|
||||
-- "warm up" the server
|
||||
Resp "dabcdabcdabcdabcdabcdabc" _ (ERR AUTH) <- signSendRecv h badKey ("dabcdabcdabcdabcdabcdabc", EntityId "1234", cmd)
|
||||
return ()
|
||||
threadDelay 100000
|
||||
timeWrongKey <- timeRepeat n $ do
|
||||
timeWrongKey <- timeRepeat $ do
|
||||
Resp "cdabcdabcdabcdabcdabcdab" _ (ERR AUTH) <- signSendRecv h badKey ("cdabcdabcdabcdabcdabcdab", qId, cmd)
|
||||
return ()
|
||||
threadDelay 100000
|
||||
timeNoQueue <- timeRepeat n $ do
|
||||
timeNoQueue <- timeRepeat $ do
|
||||
Resp "dabcdabcdabcdabcdabcdabc" _ (ERR AUTH) <- signSendRecv h badKey ("dabcdabcdabcdabcdabcdabc", EntityId "1234", cmd)
|
||||
return ()
|
||||
let ok = similarTime timeNoQueue timeWrongKey msType
|
||||
@@ -1347,6 +1348,33 @@ testTiming =
|
||||
]
|
||||
ok `shouldBe` True
|
||||
|
||||
testAuthErrorDelay :: SpecWith (ASrvTransport, AStoreType)
|
||||
testAuthErrorDelay =
|
||||
it "should send AUTH errors after the delay and other responses without it" $ \(ATransport t, msType) ->
|
||||
smpTest2Cfg (updateCfg (cfgMS msType) $ \cfg' -> cfg' {authErrorDelay = 500000}) supportedClientSMPRelayVRange t $ \rh sh -> do
|
||||
g <- C.newRandom
|
||||
(rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
(dhPub, _ :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
|
||||
Resp "1" NoEntity (Ids rId sId _) <- signSendRecv rh rKey ("1", NoEntity, New rPub dhPub)
|
||||
(_, badKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
(wrongKeyTime, Resp "2" _ (ERR AUTH)) <- responseTime $ signSendRecv rh badKey ("2", rId, SUB)
|
||||
(noQueueTime, Resp "3" _ (ERR AUTH)) <- responseTime $ signSendRecv rh badKey ("3", EntityId "1234", SUB)
|
||||
(noLinkTime, Resp "4" _ (ERR AUTH)) <- responseTime $ sendRecv sh ("", "4", EntityId "1234", LGET)
|
||||
(subTime, Resp "5" _ (SOK Nothing)) <- responseTime $ signSendRecv rh rKey ("5", rId, SUB)
|
||||
Resp "6" _ OK <- signSendRecv rh rKey ("6", rId, OFF)
|
||||
(suspendedTime, Resp "7" _ (ERR AUTH)) <- responseTime $ sendRecv sh ("", "7", sId, _SEND "hello")
|
||||
wrongKeyTime `shouldSatisfy` (>= 0.5)
|
||||
noQueueTime `shouldSatisfy` (>= 0.5)
|
||||
suspendedTime `shouldSatisfy` (>= 0.5)
|
||||
noLinkTime `shouldSatisfy` (>= 0.5)
|
||||
subTime `shouldSatisfy` (< 0.5)
|
||||
|
||||
responseTime :: IO a -> IO (NominalDiffTime, a)
|
||||
responseTime action = do
|
||||
t <- getCurrentTime
|
||||
r <- action
|
||||
(,r) . (`diffUTCTime` t) <$> getCurrentTime
|
||||
|
||||
testMessageNotifications :: SpecWith (ASrvTransport, AStoreType)
|
||||
testMessageNotifications =
|
||||
it "should create simplex connection, subscribe notifier and deliver notifications" $ \(ATransport t, msType) -> do
|
||||
|
||||
+1
-1
@@ -56,7 +56,7 @@ instance Example a => Example (TestWrapper a) where
|
||||
ci <- envCI
|
||||
runTest `E.catches` [E.Handler (onTestFailure ci), E.Handler (onTestException ci)]
|
||||
where
|
||||
tt = 120
|
||||
tt = 300
|
||||
runTest =
|
||||
timeout (tt * 1000000) (evaluateExample action params hooks state) `finally` callCommand "sync" >>= \case
|
||||
Just r -> pure r
|
||||
|
||||
Reference in New Issue
Block a user